diff --git a/CHANGELOG.md b/CHANGELOG.md index b9f45bdab89..7419ec79357 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -45,6 +45,7 @@ - Refactor analysis to decouple I/O from core logic. https://github.com/rescript-lang/rescript/pull/8426 - Deprecate `Stdlib_Error` and `Stdlib_Exn` modules in favor of `JsError/JsExn`. https://github.com/rescript-lang/rescript/pull/8404 - Remove vendored `Json` library and use `yojson` and `lsp` library for analysis. https://github.com/rescript-lang/rescript/pull/8436 +- Convert OCaml codebase to snake case format. https://github.com/rescript-lang/rescript/pull/8456 #### :house: Internal diff --git a/analysis/bin/main.ml b/analysis/bin/main.ml index 98b66acc7fa..cbb0db068e5 100644 --- a/analysis/bin/main.ml +++ b/analysis/bin/main.ml @@ -93,116 +93,127 @@ Options: let main () = let args = Array.to_list Sys.argv in - let debugLevel, args = + let debug_level, args = match args with - | _ :: "debug-dump" :: logLevel :: rest -> - ( (match logLevel with + | _ :: "debug-dump" :: log_level :: rest -> + ( (match log_level with | "verbose" -> Debug.Verbose | "regular" -> Regular | _ -> Off), "dummy" :: rest ) | args -> (Off, args) in - Debug.debugLevel := debugLevel; - let debug = debugLevel <> Debug.Off in - let printHeaderInfo path line col = + Debug.debug_level := debug_level; + let debug = debug_level <> Debug.Off in + let print_header_info path line col = if debug then Printf.printf "Debug level: %s\n%s:%s-%s\n\n" - (match debugLevel with + (match debug_level with | Debug.Verbose -> "verbose" | Regular -> "regular" | Off -> "off") path line col in match args with - | [_; "cache-project"; rootPath] -> ( - Cfg.readProjectConfigCache := false; - let uri = Uri.fromPath rootPath in - match Packages.getPackage ~uri with - | Some package -> Cache.cacheProject package + | [_; "cache-project"; root_path] -> ( + Cfg.read_project_config_cache := false; + let uri = Uri.from_path root_path in + match Packages.get_package ~uri with + | Some package -> Cache.cache_project package | None -> print_endline "\"ERR\"") - | [_; "cache-delete"; rootPath] -> ( - Cfg.readProjectConfigCache := false; - let uri = Uri.fromPath rootPath in - match Packages.findRoot ~uri (Hashtbl.create 0) with - | Some (`Bs rootPath) -> ( - match BuildSystem.getLibBs rootPath with + | [_; "cache-delete"; root_path] -> ( + Cfg.read_project_config_cache := false; + let uri = Uri.from_path root_path in + match Packages.find_root ~uri (Hashtbl.create 0) with + | Some (`Bs root_path) -> ( + match Build_system.get_lib_bs root_path with | None -> print_endline "\"ERR\"" - | Some libBs -> - Cache.deleteCache (Cache.targetFileFromLibBs libBs); + | Some lib_bs -> + Cache.delete_cache (Cache.target_file_from_lib_bs lib_bs); print_endline "\"OK\"") | _ -> print_endline "\"ERR: Did not find root \"") - | [_; "completion"; path; line; col; currentFile] -> - printHeaderInfo path line col; + | [_; "completion"; path; line; col; current_file] -> + print_header_info path line col; Cli.completion ~debug ~path ~pos:(int_of_string line, int_of_string col) - ~currentFile - | [_; "completionResolve"; path; modulePath] -> - Cli.completionResolve ~path ~modulePath + ~current_file + | [_; "completionResolve"; path; module_path] -> + Cli.completion_resolve ~path ~module_path | [_; "definition"; path; line; col] -> Cli.definition ~path ~pos:(int_of_string line, int_of_string col) ~debug | [_; "typeDefinition"; path; line; col] -> - Cli.typeDefinition ~path ~pos:(int_of_string line, int_of_string col) ~debug - | [_; "documentSymbol"; path] -> DocumentSymbol.command ~path - | [_; "hover"; path; line; col; currentFile; supportsMarkdownLinks] -> + Cli.type_definition ~path + ~pos:(int_of_string line, int_of_string col) + ~debug + | [_; "documentSymbol"; path] -> Document_symbol.command ~path + | [_; "hover"; path; line; col; current_file; supports_markdown_links] -> Cli.hover ~path ~pos:(int_of_string line, int_of_string col) - ~currentFile ~debug - ~supportsMarkdownLinks: - (match supportsMarkdownLinks with + ~current_file ~debug + ~supports_markdown_links: + (match supports_markdown_links with | "true" -> true | _ -> false) | [ - _; "signatureHelp"; path; line; col; currentFile; allowForConstructorPayloads; + _; + "signatureHelp"; + path; + line; + col; + current_file; + allow_for_constructor_payloads; ] -> - Cli.signatureHelp ~path + Cli.signature_help ~path ~pos:(int_of_string line, int_of_string col) - ~currentFile ~debug - ~allowForConstructorPayloads: - (match allowForConstructorPayloads with + ~current_file ~debug + ~allow_for_constructor_payloads: + (match allow_for_constructor_payloads with | "true" -> true | _ -> false) - | [_; "inlayHint"; path; line_start; line_end; maxLength] -> + | [_; "inlayHint"; path; line_start; line_end; max_length] -> Cli.inlayhint ~path ~pos:(int_of_string line_start, int_of_string line_end) - ~maxLength ~debug - | [_; "codeLens"; path] -> Cli.codeLens ~path ~debug - | [_; "codeAction"; path; startLine; startCol; endLine; endCol; currentFile] - -> - Cli.codeAction ~path - ~startPos:(int_of_string startLine, int_of_string startCol) - ~endPos:(int_of_string endLine, int_of_string endCol) - ~currentFile ~debug + ~max_length ~debug + | [_; "codeLens"; path] -> Cli.code_lens ~path ~debug + | [ + _; "codeAction"; path; start_line; start_col; end_line; end_col; current_file; + ] -> + Cli.code_action ~path + ~start_pos:(int_of_string start_line, int_of_string start_col) + ~end_pos:(int_of_string end_line, int_of_string end_col) + ~current_file ~debug | [_; "codemod"; path; line; col; typ; hint] -> let typ = match typ with | "add-missing-cases" -> Codemod.AddMissingCases | _ -> raise (Failure "unsupported type") in - let source = Files.readFile path |> Option.value ~default:"" in + let source = Files.read_file path |> Option.value ~default:"" in `String (Codemod.transform ~source ~pos:(int_of_string line, int_of_string col) ~debug ~typ ~hint) |> Yojson.Safe.pretty_to_string ~std:true |> print_endline - | [_; "diagnosticSyntax"; path] -> Cli.diagnosticSyntax ~path + | [_; "diagnosticSyntax"; path] -> Cli.diagnostic_syntax ~path | [_; "references"; path; line; col] -> Cli.references ~path ~pos:(int_of_string line, int_of_string col) ~debug | [_; "prepareRename"; path; line; col] -> - Cli.prepareRename ~path ~pos:(int_of_string line, int_of_string col) ~debug - | [_; "rename"; path; line; col; newName] -> + Cli.prepare_rename ~path ~pos:(int_of_string line, int_of_string col) ~debug + | [_; "rename"; path; line; col; new_name] -> Cli.rename ~path ~pos:(int_of_string line, int_of_string col) - ~newName ~debug - | [_; "semanticTokens"; currentFile] -> Cli.semanticTokens ~path:currentFile - | [_; "createInterface"; path; cmiFile] -> - `String (CreateInterface.command ~path ~cmiFile) + ~new_name ~debug + | [_; "semanticTokens"; current_file] -> + Cli.semantic_tokens ~path:current_file + | [_; "createInterface"; path; cmi_file] -> + `String (Create_interface.command ~path ~cmi_file) |> Yojson.Safe.pretty_to_string ~std:true |> print_endline | [_; "format"; path] -> Cli.format ~path | [_; "test"; path] -> Cli.test ~path - | [_; "cmt"; rescript_json; cmt_path] -> CmtViewer.dump rescript_json cmt_path + | [_; "cmt"; rescript_json; cmt_path] -> + Cmt_viewer.dump rescript_json cmt_path | args when List.mem "-h" args || List.mem "--help" args -> prerr_endline help | _ -> prerr_endline help; diff --git a/analysis/reactive/src/dune b/analysis/reactive/src/dune index cc8d382ccd8..94a1d26f67b 100644 --- a/analysis/reactive/src/dune +++ b/analysis/reactive/src/dune @@ -1,5 +1,5 @@ (library (name reactive) (wrapped false) - (private_modules ReactiveFixpoint) + (private_modules reactive_fixpoint) (libraries unix)) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/reactive.ml similarity index 98% rename from analysis/reactive/src/Reactive.ml rename to analysis/reactive/src/reactive.ml index 9db201901dc..9a12f90fd96 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/reactive.ml @@ -532,7 +532,7 @@ let source ~name () = (** {1 FlatMap} *) -let flatMap ~name (src : ('k1, 'v1) t) ~f ?merge () : ('k2, 'v2) t = +let flat_map ~name (src : ('k1, 'v1) t) ~f ?merge () : ('k2, 'v2) t = let my_level = src.level + 1 in let merge_fn = match merge with @@ -1077,7 +1077,7 @@ let fixpoint ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : let my_level = max init.level edges.level + 1 in (* Internal state *) - let state = ReactiveFixpoint.create () in + let state = Reactive_fixpoint.create () in let subscribers = ref [] in let my_stats = create_stats () in @@ -1122,7 +1122,7 @@ let fixpoint ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : my_stats.removes_received + init_removes + edges_removes; let output_entries = - ReactiveFixpoint.apply state ~init_entries ~edge_entries:edges_entries + Reactive_fixpoint.apply state ~init_entries ~edge_entries:edges_entries in emit_output output_entries in @@ -1145,14 +1145,15 @@ let fixpoint ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : Registry.mark_dirty name); (* Initialize from existing data *) - ReactiveFixpoint.initialize state ~roots_iter:init.iter ~edges_iter:edges.iter; + Reactive_fixpoint.initialize state ~roots_iter:init.iter + ~edges_iter:edges.iter; { name; subscribe = (fun h -> subscribers := h :: !subscribers); - iter = (fun f -> ReactiveFixpoint.iter_current state f); - get = (fun k -> ReactiveFixpoint.get_current state k); - length = (fun () -> ReactiveFixpoint.current_length state); + iter = (fun f -> Reactive_fixpoint.iter_current state f); + get = (fun k -> Reactive_fixpoint.get_current state k); + length = (fun () -> Reactive_fixpoint.current_length state); stats = my_stats; level = my_level; } diff --git a/analysis/reactive/src/Reactive.mli b/analysis/reactive/src/reactive.mli similarity index 99% rename from analysis/reactive/src/Reactive.mli rename to analysis/reactive/src/reactive.mli index cadaecc9691..b666907d5bc 100644 --- a/analysis/reactive/src/Reactive.mli +++ b/analysis/reactive/src/reactive.mli @@ -109,7 +109,7 @@ val source : name:string -> unit -> ('k, 'v) t * (('k, 'v) delta -> unit) (** {1 Combinators} *) -val flatMap : +val flat_map : name:string -> ('k1, 'v1) t -> f:('k1 -> 'v1 -> ('k2 * 'v2) list) -> diff --git a/analysis/reactive/src/ReactiveFileCollection.ml b/analysis/reactive/src/reactive_file_collection.ml similarity index 100% rename from analysis/reactive/src/ReactiveFileCollection.ml rename to analysis/reactive/src/reactive_file_collection.ml diff --git a/analysis/reactive/src/ReactiveFileCollection.mli b/analysis/reactive/src/reactive_file_collection.mli similarity index 100% rename from analysis/reactive/src/ReactiveFileCollection.mli rename to analysis/reactive/src/reactive_file_collection.mli diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/reactive_fixpoint.ml similarity index 100% rename from analysis/reactive/src/ReactiveFixpoint.ml rename to analysis/reactive/src/reactive_fixpoint.ml diff --git a/analysis/reactive/src/ReactiveFixpoint.mli b/analysis/reactive/src/reactive_fixpoint.mli similarity index 100% rename from analysis/reactive/src/ReactiveFixpoint.mli rename to analysis/reactive/src/reactive_fixpoint.mli diff --git a/analysis/reactive/test/ReactiveTest.ml b/analysis/reactive/test/ReactiveTest.ml deleted file mode 100644 index e94162f2b11..00000000000 --- a/analysis/reactive/test/ReactiveTest.ml +++ /dev/null @@ -1,13 +0,0 @@ -(** Main test driver for Reactive tests *) - -let () = - Printf.printf "\n====== Reactive Collection Tests ======\n"; - FlatMapTest.run_all (); - JoinTest.run_all (); - UnionTest.run_all (); - FixpointBasicTest.run_all (); - FixpointIncrementalTest.run_all (); - BatchTest.run_all (); - IntegrationTest.run_all (); - GlitchFreeTest.run_all (); - Printf.printf "\nAll tests passed!\n" diff --git a/analysis/reactive/test/BatchTest.ml b/analysis/reactive/test/batch_test.ml similarity index 96% rename from analysis/reactive/test/BatchTest.ml rename to analysis/reactive/test/batch_test.ml index 4c750d16cff..ad49c5dfeb7 100644 --- a/analysis/reactive/test/BatchTest.ml +++ b/analysis/reactive/test/batch_test.ml @@ -1,7 +1,7 @@ (** Batch processing tests *) open Reactive -open TestHelpers +open Test_helpers let test_batch_flatmap () = reset (); @@ -9,7 +9,7 @@ let test_batch_flatmap () = let source, emit = source ~name:"source" () in let derived = - flatMap ~name:"derived" source ~f:(fun k v -> [(k ^ "_derived", v * 2)]) () + flat_map ~name:"derived" source ~f:(fun k v -> [(k ^ "_derived", v * 2)]) () in (* Subscribe to track what comes out *) diff --git a/analysis/reactive/test/dune b/analysis/reactive/test/dune index cd8fe3ad9cf..34904fcfa34 100644 --- a/analysis/reactive/test/dune +++ b/analysis/reactive/test/dune @@ -1,14 +1,14 @@ (executable - (name ReactiveTest) + (name reactive_test) (modules - ReactiveTest - TestHelpers - FlatMapTest - JoinTest - UnionTest - FixpointBasicTest - FixpointIncrementalTest - BatchTest - IntegrationTest - GlitchFreeTest) + reactive_test + test_helpers + flat_map_test + join_test + union_test + fixpoint_basic_test + fixpoint_incremental_test + batch_test + integration_test + glitch_free_test) (libraries reactive)) diff --git a/analysis/reactive/test/FixpointBasicTest.ml b/analysis/reactive/test/fixpoint_basic_test.ml similarity index 100% rename from analysis/reactive/test/FixpointBasicTest.ml rename to analysis/reactive/test/fixpoint_basic_test.ml diff --git a/analysis/reactive/test/FixpointIncrementalTest.ml b/analysis/reactive/test/fixpoint_incremental_test.ml similarity index 99% rename from analysis/reactive/test/FixpointIncrementalTest.ml rename to analysis/reactive/test/fixpoint_incremental_test.ml index e0c2d0b6cbe..3f0e8d803d1 100644 --- a/analysis/reactive/test/FixpointIncrementalTest.ml +++ b/analysis/reactive/test/fixpoint_incremental_test.ml @@ -1,7 +1,7 @@ (** Incremental fixpoint update tests (add/remove base and edges) *) open Reactive -open TestHelpers +open Test_helpers let test_fixpoint_add_base () = reset (); diff --git a/analysis/reactive/test/FlatMapTest.ml b/analysis/reactive/test/flat_map_test.ml similarity index 85% rename from analysis/reactive/test/FlatMapTest.ml rename to analysis/reactive/test/flat_map_test.ml index b9d20504699..6a347e3486a 100644 --- a/analysis/reactive/test/FlatMapTest.ml +++ b/analysis/reactive/test/flat_map_test.ml @@ -1,7 +1,7 @@ (** FlatMap combinator tests *) open Reactive -open TestHelpers +open Test_helpers let test_flatmap_basic () = reset (); @@ -12,7 +12,7 @@ let test_flatmap_basic () = (* Create derived collection via flatMap *) let derived = - flatMap ~name:"derived" source + flat_map ~name:"derived" source ~f:(fun key value -> [(key * 10, value); ((key * 10) + 1, value); ((key * 10) + 2, value)]) () @@ -56,31 +56,31 @@ let test_flatmap_with_merge () = (* Create derived with merge *) let derived = - flatMap ~name:"derived" source + flat_map ~name:"derived" source ~f:(fun _key values -> [(0, values)]) (* all contribute to key 0 *) - ~merge:IntSet.union () + ~merge:Int_set.union () in (* Source 1 contributes {1, 2} *) - emit (Set (1, IntSet.of_list [1; 2])); + emit (Set (1, Int_set.of_list [1; 2])); let v = get derived 0 |> Option.get in Printf.printf "After source 1: {%s}\n" - (IntSet.elements v |> List.map string_of_int |> String.concat ", "); - assert (IntSet.equal v (IntSet.of_list [1; 2])); + (Int_set.elements v |> List.map string_of_int |> String.concat ", "); + assert (Int_set.equal v (Int_set.of_list [1; 2])); (* Source 2 contributes {3, 4} -> should merge *) - emit (Set (2, IntSet.of_list [3; 4])); + emit (Set (2, Int_set.of_list [3; 4])); let v = get derived 0 |> Option.get in Printf.printf "After source 2: {%s}\n" - (IntSet.elements v |> List.map string_of_int |> String.concat ", "); - assert (IntSet.equal v (IntSet.of_list [1; 2; 3; 4])); + (Int_set.elements v |> List.map string_of_int |> String.concat ", "); + assert (Int_set.equal v (Int_set.of_list [1; 2; 3; 4])); (* Remove source 1 *) emit (Remove 1); let v = get derived 0 |> Option.get in Printf.printf "After remove 1: {%s}\n" - (IntSet.elements v |> List.map string_of_int |> String.concat ", "); - assert (IntSet.equal v (IntSet.of_list [3; 4])); + (Int_set.elements v |> List.map string_of_int |> String.concat ", "); + assert (Int_set.equal v (Int_set.of_list [3; 4])); Printf.printf "PASSED\n\n" @@ -93,7 +93,7 @@ let test_composition () = (* First flatMap: file -> items *) let items = - flatMap ~name:"items" source + flat_map ~name:"items" source ~f:(fun path items -> List.mapi (fun i item -> (Printf.sprintf "%s:%d" path i, item)) items) () @@ -101,7 +101,7 @@ let test_composition () = (* Second flatMap: item -> chars *) let chars = - flatMap ~name:"chars" items + flat_map ~name:"chars" items ~f:(fun key value -> String.to_seq value |> Seq.mapi (fun i c -> (Printf.sprintf "%s:%d" key i, c)) @@ -147,7 +147,7 @@ let test_flatmap_on_existing_data () = (* Create flatMap AFTER source has data *) let derived = - flatMap ~name:"derived" source ~f:(fun k v -> [(k * 10, v)]) () + flat_map ~name:"derived" source ~f:(fun k v -> [(k * 10, v)]) () in (* Check derived has existing data *) diff --git a/analysis/reactive/test/GlitchFreeTest.ml b/analysis/reactive/test/glitch_free_test.ml similarity index 86% rename from analysis/reactive/test/GlitchFreeTest.ml rename to analysis/reactive/test/glitch_free_test.ml index 39540758775..dd354ca0ace 100644 --- a/analysis/reactive/test/GlitchFreeTest.ml +++ b/analysis/reactive/test/glitch_free_test.ml @@ -45,11 +45,11 @@ let test_same_source_anti_join () = let src, emit = source ~name:"source" () in let refs = - flatMap ~name:"refs" src ~f:(fun _file (data : file_data) -> data.refs) () + flat_map ~name:"refs" src ~f:(fun _file (data : file_data) -> data.refs) () in let decls = - flatMap ~name:"decls" src + flat_map ~name:"decls" src ~f:(fun _file (data : file_data) -> List.map (fun pos -> (pos, ())) data.decl_positions) () @@ -57,11 +57,11 @@ let test_same_source_anti_join () = let external_refs = join ~name:"external_refs" refs decls - ~key_of:(fun posFrom _posTo -> posFrom) - ~f:(fun _posFrom posTo decl_opt -> + ~key_of:(fun pos_from _posTo -> pos_from) + ~f:(fun _posFrom pos_to decl_opt -> match decl_opt with | Some () -> [] - | None -> [(posTo, ())]) + | None -> [(pos_to, ())]) ~merge:(fun () () -> ()) () in @@ -93,7 +93,7 @@ let test_multi_level_union () = (* refs1: level 1 *) let refs1 = - flatMap ~name:"refs1" src + flat_map ~name:"refs1" src ~f:(fun _file (data : file_data) -> List.filter (fun (k, _) -> String.length k > 0 && k.[0] = 'D') data.refs) () @@ -101,18 +101,18 @@ let test_multi_level_union () = (* intermediate: level 1 *) let intermediate = - flatMap ~name:"intermediate" src + flat_map ~name:"intermediate" src ~f:(fun _file (data : file_data) -> List.filter (fun (k, _) -> String.length k > 0 && k.[0] = 'I') data.refs) () in (* refs2: level 2 *) - let refs2 = flatMap ~name:"refs2" intermediate ~f:(fun k v -> [(k, v)]) () in + let refs2 = flat_map ~name:"refs2" intermediate ~f:(fun k v -> [(k, v)]) () in (* decls: level 1 *) let decls = - flatMap ~name:"decls" src + flat_map ~name:"decls" src ~f:(fun _file (data : file_data) -> List.map (fun pos -> (pos, ())) data.decl_positions) () @@ -124,11 +124,11 @@ let test_multi_level_union () = (* external_refs: join at level 4 *) let external_refs = join ~name:"external_refs" all_refs decls - ~key_of:(fun posFrom _posTo -> posFrom) - ~f:(fun _posFrom posTo decl_opt -> + ~key_of:(fun pos_from _posTo -> pos_from) + ~f:(fun _posFrom pos_to decl_opt -> match decl_opt with | Some () -> [] - | None -> [(posTo, ())]) + | None -> [(pos_to, ())]) ~merge:(fun () () -> ()) () in @@ -158,7 +158,7 @@ let test_real_pipeline_simulation () = (* decls: level 1 *) let decls = - flatMap ~name:"decls" src + flat_map ~name:"decls" src ~f:(fun _file (data : full_file_data) -> List.map (fun pos -> (pos, ())) data.full_decls) () @@ -166,21 +166,21 @@ let test_real_pipeline_simulation () = (* merged_value_refs: level 1 *) let merged_value_refs = - flatMap ~name:"merged_value_refs" src + flat_map ~name:"merged_value_refs" src ~f:(fun _file (data : full_file_data) -> data.value_refs) () in (* exception_refs_raw: level 1 *) let exception_refs_raw = - flatMap ~name:"exception_refs_raw" src + flat_map ~name:"exception_refs_raw" src ~f:(fun _file (data : full_file_data) -> data.exception_refs) () in (* exception_decls: level 2 *) let exception_decls = - flatMap ~name:"exception_decls" decls + flat_map ~name:"exception_decls" decls ~f:(fun pos () -> if String.length pos > 0 && pos.[0] = 'E' then [(pos, ())] else []) () @@ -199,8 +199,8 @@ let test_real_pipeline_simulation () = (* resolved_refs_from: level 4 *) let resolved_refs_from = - flatMap ~name:"resolved_refs_from" resolved_exception_refs - ~f:(fun posTo posFrom -> [(posFrom, posTo)]) + flat_map ~name:"resolved_refs_from" resolved_exception_refs + ~f:(fun pos_to pos_from -> [(pos_from, pos_to)]) () in @@ -212,11 +212,11 @@ let test_real_pipeline_simulation () = (* external_value_refs: join at level 6 *) let external_value_refs = join ~name:"external_value_refs" value_refs_from decls - ~key_of:(fun posFrom _posTo -> posFrom) - ~f:(fun _posFrom posTo decl_opt -> + ~key_of:(fun pos_from _posTo -> pos_from) + ~f:(fun _posFrom pos_to decl_opt -> match decl_opt with | Some () -> [] - | None -> [(posTo, ())]) + | None -> [(pos_to, ())]) ~merge:(fun () () -> ()) () in @@ -250,11 +250,11 @@ let test_separate_sources () = let external_refs = join ~name:"external_refs" refs_src decls_src - ~key_of:(fun posFrom _posTo -> posFrom) - ~f:(fun _posFrom posTo decl_opt -> + ~key_of:(fun pos_from _posTo -> pos_from) + ~f:(fun _posFrom pos_to decl_opt -> match decl_opt with | Some () -> [] - | None -> [(posTo, ())]) + | None -> [(pos_to, ())]) ~merge:(fun () () -> ()) () in diff --git a/analysis/reactive/test/IntegrationTest.ml b/analysis/reactive/test/integration_test.ml similarity index 86% rename from analysis/reactive/test/IntegrationTest.ml rename to analysis/reactive/test/integration_test.ml index 428a1b2f8e5..da65cf92c4c 100644 --- a/analysis/reactive/test/IntegrationTest.ml +++ b/analysis/reactive/test/integration_test.ml @@ -1,7 +1,7 @@ (** End-to-end integration tests *) open Reactive -open TestHelpers +open Test_helpers let test_file_collection () = reset (); @@ -15,8 +15,8 @@ let test_file_collection () = (* First flatMap: aggregate word counts across files with merge *) let word_counts = - flatMap ~name:"word_counts" files - ~f:(fun _path counts -> StringMap.bindings counts) + flat_map ~name:"word_counts" files + ~f:(fun _path counts -> String_map.bindings counts) (* Each file contributes its word counts *) ~merge:( + ) (* Sum counts from multiple files *) () @@ -24,17 +24,17 @@ let test_file_collection () = (* Second flatMap: filter to words with count >= 2 *) let frequent_words = - flatMap ~name:"frequent_words" word_counts + flat_map ~name:"frequent_words" word_counts ~f:(fun word count -> if count >= 2 then [(word, count)] else []) () in (* Simulate processing files by emitting their word counts *) let counts_a = - StringMap.empty |> StringMap.add "hello" 2 |> StringMap.add "world" 1 + String_map.empty |> String_map.add "hello" 2 |> String_map.add "world" 1 in let counts_b = - StringMap.empty |> StringMap.add "hello" 1 |> StringMap.add "foo" 1 + String_map.empty |> String_map.add "hello" 1 |> String_map.add "foo" 1 in emit_file (Set ("file_a", counts_a)); emit_file (Set ("file_b", counts_b)); @@ -58,7 +58,7 @@ let test_file_collection () = (* Modify file_a: now hello(1), world(2) *) Printf.printf "\nModifying file_a...\n"; let counts_a' = - StringMap.empty |> StringMap.add "hello" 1 |> StringMap.add "world" 2 + String_map.empty |> String_map.add "hello" 1 |> String_map.add "world" 2 in emit_file (Set ("file_a", counts_a')); diff --git a/analysis/reactive/test/JoinTest.ml b/analysis/reactive/test/join_test.ml similarity index 100% rename from analysis/reactive/test/JoinTest.ml rename to analysis/reactive/test/join_test.ml diff --git a/analysis/reactive/test/reactive_test.ml b/analysis/reactive/test/reactive_test.ml new file mode 100644 index 00000000000..49bda079d48 --- /dev/null +++ b/analysis/reactive/test/reactive_test.ml @@ -0,0 +1,13 @@ +(** Main test driver for Reactive tests *) + +let () = + Printf.printf "\n====== Reactive Collection Tests ======\n"; + Flat_map_test.run_all (); + Join_test.run_all (); + Union_test.run_all (); + Fixpoint_basic_test.run_all (); + Fixpoint_incremental_test.run_all (); + Batch_test.run_all (); + Integration_test.run_all (); + Glitch_free_test.run_all (); + Printf.printf "\nAll tests passed!\n" diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/test_helpers.ml similarity index 95% rename from analysis/reactive/test/TestHelpers.ml rename to analysis/reactive/test/test_helpers.ml index 54067172fe0..9f5cfab59c5 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/test_helpers.ml @@ -53,5 +53,5 @@ let[@warning "-32"] write_lines path lines = (** {1 Common set modules} *) -module IntSet = Set.Make (Int) -module StringMap = Map.Make (String) +module Int_set = Set.Make (Int) +module String_map = Map.Make (String) diff --git a/analysis/reactive/test/UnionTest.ml b/analysis/reactive/test/union_test.ml similarity index 82% rename from analysis/reactive/test/UnionTest.ml rename to analysis/reactive/test/union_test.ml index c5321803893..29813b2d9b3 100644 --- a/analysis/reactive/test/UnionTest.ml +++ b/analysis/reactive/test/union_test.ml @@ -1,7 +1,7 @@ (** Union combinator tests *) open Reactive -open TestHelpers +open Test_helpers let test_union_basic () = reset (); @@ -69,35 +69,35 @@ let test_union_with_merge () = let right, emit_right = source ~name:"right" () in (* Create union with set union as merge *) - let combined = union ~name:"combined" left right ~merge:IntSet.union () in + let combined = union ~name:"combined" left right ~merge:Int_set.union () in (* Add to left: key "x" -> {1, 2} *) - emit_left (Set ("x", IntSet.of_list [1; 2])); + emit_left (Set ("x", Int_set.of_list [1; 2])); let v = get combined "x" |> Option.get in Printf.printf "After left Set(x, {1,2}): {%s}\n" - (IntSet.elements v |> List.map string_of_int |> String.concat ", "); - assert (IntSet.equal v (IntSet.of_list [1; 2])); + (Int_set.elements v |> List.map string_of_int |> String.concat ", "); + assert (Int_set.equal v (Int_set.of_list [1; 2])); (* Add to right: key "x" -> {3, 4} (should merge) *) - emit_right (Set ("x", IntSet.of_list [3; 4])); + emit_right (Set ("x", Int_set.of_list [3; 4])); let v = get combined "x" |> Option.get in Printf.printf "After right Set(x, {3,4}): {%s}\n" - (IntSet.elements v |> List.map string_of_int |> String.concat ", "); - assert (IntSet.equal v (IntSet.of_list [1; 2; 3; 4])); + (Int_set.elements v |> List.map string_of_int |> String.concat ", "); + assert (Int_set.equal v (Int_set.of_list [1; 2; 3; 4])); (* Update left: key "x" -> {1, 5} *) - emit_left (Set ("x", IntSet.of_list [1; 5])); + emit_left (Set ("x", Int_set.of_list [1; 5])); let v = get combined "x" |> Option.get in Printf.printf "After left update to {1,5}: {%s}\n" - (IntSet.elements v |> List.map string_of_int |> String.concat ", "); - assert (IntSet.equal v (IntSet.of_list [1; 3; 4; 5])); + (Int_set.elements v |> List.map string_of_int |> String.concat ", "); + assert (Int_set.equal v (Int_set.of_list [1; 3; 4; 5])); (* Remove right *) emit_right (Remove "x"); let v = get combined "x" |> Option.get in Printf.printf "After right Remove(x): {%s}\n" - (IntSet.elements v |> List.map string_of_int |> String.concat ", "); - assert (IntSet.equal v (IntSet.of_list [1; 5])); + (Int_set.elements v |> List.map string_of_int |> String.concat ", "); + assert (Int_set.equal v (Int_set.of_list [1; 5])); Printf.printf "PASSED\n\n" diff --git a/analysis/reanalyze/src/AnnotationStore.ml b/analysis/reanalyze/src/AnnotationStore.ml deleted file mode 100644 index b34dbce8e77..00000000000 --- a/analysis/reanalyze/src/AnnotationStore.ml +++ /dev/null @@ -1,34 +0,0 @@ -(** Abstraction over annotation storage. - - Allows the solver to work with either: - - [Frozen]: Traditional [FileAnnotations.t] (copied from reactive) - - [Reactive]: Direct [Reactive.t] (no copy, zero-cost on warm runs) *) - -type t = - | Frozen of FileAnnotations.t - | Reactive of (Lexing.position, FileAnnotations.annotated_as) Reactive.t - -let of_frozen ann = Frozen ann - -let of_reactive reactive = Reactive reactive - -let is_annotated_dead t pos = - match t with - | Frozen ann -> FileAnnotations.is_annotated_dead ann pos - | Reactive reactive -> Reactive.get reactive pos = Some FileAnnotations.Dead - -let is_annotated_gentype_or_live t pos = - match t with - | Frozen ann -> FileAnnotations.is_annotated_gentype_or_live ann pos - | Reactive reactive -> ( - match Reactive.get reactive pos with - | Some (FileAnnotations.Live | FileAnnotations.GenType) -> true - | Some FileAnnotations.Dead | None -> false) - -let is_annotated_gentype_or_dead t pos = - match t with - | Frozen ann -> FileAnnotations.is_annotated_gentype_or_dead ann pos - | Reactive reactive -> ( - match Reactive.get reactive pos with - | Some (FileAnnotations.Dead | FileAnnotations.GenType) -> true - | Some FileAnnotations.Live | None -> false) diff --git a/analysis/reanalyze/src/Arnold.ml b/analysis/reanalyze/src/Arnold.ml deleted file mode 100644 index f6484080223..00000000000 --- a/analysis/reanalyze/src/Arnold.ml +++ /dev/null @@ -1,1425 +0,0 @@ -let printPos ppf (pos : Lexing.position) = - let file = pos.Lexing.pos_fname in - let line = pos.Lexing.pos_lnum in - Format.fprintf ppf "@{%s@} @{%i@}" - (file |> Filename.basename) - line - -module StringSet = Set.Make (String) - -(** Type Definitions *) -module FunctionName = struct - type t = string -end - -module FunctionArgs = struct - type arg = {label: string; functionName: FunctionName.t} - type t = arg list - - let empty = [] - let argToString {label; functionName} = label ^ ":" ^ functionName - - let toString functionArgs = - match functionArgs = [] with - | true -> "" - | false -> - "<" ^ (functionArgs |> List.map argToString |> String.concat ",") ^ ">" - - let find (t : t) ~label = - match t |> List.find_opt (fun arg -> arg.label = label) with - | Some {functionName} -> Some functionName - | None -> None - - let compareArg a1 a2 = - let n = compare a1.label a2.label in - if n <> 0 then n else compare a1.functionName a2.functionName - - let rec compare l1 l2 = - match (l1, l2) with - | [], [] -> 0 - | [], _ :: _ -> -1 - | _ :: _, [] -> 1 - | x1 :: l1, x2 :: l2 -> - let n = compareArg x1 x2 in - if n <> 0 then n else compare l1 l2 -end - -module FunctionCall = struct - type t = {functionName: FunctionName.t; functionArgs: FunctionArgs.t} - - let substituteName ~sub name = - match sub |> FunctionArgs.find ~label:name with - | Some functionName -> functionName - | None -> name - - let applySubstitution ~(sub : FunctionArgs.t) (t : t) = - if sub = [] then t - else - { - functionName = t.functionName |> substituteName ~sub; - functionArgs = - t.functionArgs - |> List.map (fun (arg : FunctionArgs.arg) -> - { - arg with - functionName = arg.functionName |> substituteName ~sub; - }); - } - - let noArgs functionName = {functionName; functionArgs = []} - - let toString {functionName; functionArgs} = - functionName ^ FunctionArgs.toString functionArgs - - let compare (x1 : t) x2 = - let n = compare x1.functionName x2.functionName in - if n <> 0 then n else FunctionArgs.compare x1.functionArgs x2.functionArgs -end - -module FunctionCallSet = Set.Make (FunctionCall) - -module Stats = struct - let nCacheChecks = ref 0 - let nCacheHits = ref 0 - let nFiles = ref 0 - let nFunctions = ref 0 - let nHygieneErrors = ref 0 - let nInfiniteLoops = ref 0 - let nRecursiveBlocks = ref 0 - - let print ppf () = - Format.fprintf ppf "@[@,@{Termination Analysis Stats@}@,"; - Format.fprintf ppf "Files:@{%d@}@," !nFiles; - Format.fprintf ppf "Recursive Blocks:@{%d@}@," !nRecursiveBlocks; - Format.fprintf ppf "Functions:@{%d@}@," !nFunctions; - Format.fprintf ppf "Infinite Loops:@{%d@}@," !nInfiniteLoops; - Format.fprintf ppf "Hygiene Errors:@{%d@}@," !nHygieneErrors; - Format.fprintf ppf "Cache Hits:@{%d@}/@{%d@}@," !nCacheHits - !nCacheChecks; - Format.fprintf ppf "@]" - - let dump ~ppf = Format.fprintf ppf "%a@." print () - let newFile () = incr nFiles - - let newRecursiveFunctions ~numFunctions = - incr nRecursiveBlocks; - nFunctions := !nFunctions + numFunctions - - let logLoop () = incr nInfiniteLoops - - let logCache ~config ~functionCall ~hit ~loc = - incr nCacheChecks; - if hit then incr nCacheHits; - if config.DceConfig.cli.debug then - Log_.warning ~forStats:false ~loc - (Termination - { - termination = TerminationAnalysisInternal; - message = - Format.asprintf "Cache %s for @{%s@}" - (match hit with - | true -> "hit" - | false -> "miss") - (FunctionCall.toString functionCall); - }) - - let logResult ~config ~functionCall ~loc ~resString = - if config.DceConfig.cli.debug then - Log_.warning ~forStats:false ~loc - (Termination - { - termination = TerminationAnalysisInternal; - message = - Format.asprintf "@{%s@} returns %s" - (FunctionCall.toString functionCall) - resString; - }) - - let logHygieneParametric ~functionName ~loc = - incr nHygieneErrors; - Log_.error ~loc - (Termination - { - termination = ErrorHygiene; - message = - Format.asprintf - "@{%s@} cannot be analyzed directly as it is parametric" - functionName; - }) - - let logHygieneOnlyCallDirectly ~path ~loc = - incr nHygieneErrors; - Log_.error ~loc - (Termination - { - termination = ErrorHygiene; - message = - Format.asprintf - "@{%s@} can only be called directly, or passed as \ - labeled argument" - (Path.name path); - }) - - let logHygieneMustHaveNamedArgument ~label ~loc = - incr nHygieneErrors; - Log_.error ~loc - (Termination - { - termination = ErrorHygiene; - message = - Format.asprintf "Call must have named argument @{%s@}" label; - }) - - let logHygieneNamedArgValue ~label ~loc = - incr nHygieneErrors; - Log_.error ~loc - (Termination - { - termination = ErrorHygiene; - message = - Format.asprintf - "Named argument @{%s@} must be passed a recursive \ - function" - label; - }) - - let logHygieneNoNestedLetRec ~loc = - incr nHygieneErrors; - Log_.error ~loc - (Termination - { - termination = ErrorHygiene; - message = Format.asprintf "Nested multiple let rec not supported yet"; - }) -end - -module Progress = struct - type t = Progress | NoProgress - - let toString progress = - match progress = Progress with - | true -> "Progress" - | false -> "NoProgress" -end - -module Call = struct - type progressFunction = Path.t - - type t = - | FunctionCall of FunctionCall.t - | ProgressFunction of progressFunction - - let toString call = - match call with - | ProgressFunction progressFunction -> "+" ^ Path.name progressFunction - | FunctionCall functionCall -> FunctionCall.toString functionCall -end - -module Trace = struct - type retOption = Rsome | Rnone - - type t = - | Tcall of Call.t * Progress.t - | Tnondet of t list - | Toption of retOption - | Tseq of t list - - let empty = Tseq [] - - let nd (t1 : t) (t2 : t) : t = - match (t1, t2) with - | Tnondet l1, Tnondet l2 -> Tnondet (l1 @ l2) - | _, Tnondet l2 -> Tnondet (t1 :: l2) - | Tnondet l1, _ -> Tnondet (l1 @ [t2]) - | _ -> Tnondet [t1; t2] - - let seq (t1 : t) (t2 : t) : t = - match (t1, t2) with - | Tseq l1, Tseq l2 -> Tseq (l1 @ l2) - | _, Tseq l2 -> Tseq (t1 :: l2) - | Tseq l1, _ -> Tseq (l1 @ [t2]) - | _ -> Tseq [t1; t2] - - let some = Toption Rsome - let none = Toption Rnone - - let retOptionToString r = - match r = Rsome with - | true -> "Some" - | false -> "None" - - let rec toString trace = - match trace with - | Tcall (ProgressFunction progressFunction, progress) -> - Path.name progressFunction ^ ":" ^ Progress.toString progress - | Tcall (FunctionCall functionCall, progress) -> - FunctionCall.toString functionCall ^ ":" ^ Progress.toString progress - | Tnondet traces -> - "[" ^ (traces |> List.map toString |> String.concat " || ") ^ "]" - | Toption retOption -> retOption |> retOptionToString - | Tseq traces -> ( - let tracesNotEmpty = traces |> List.filter (( <> ) empty) in - match tracesNotEmpty with - | [] -> "_" - | [t] -> t |> toString - | _ :: _ -> tracesNotEmpty |> List.map toString |> String.concat "; ") -end - -module Values : sig - type t - - val getNone : t -> Progress.t option - val getSome : t -> Progress.t option - val nd : t -> t -> t - val none : progress:Progress.t -> t - val some : progress:Progress.t -> t - val toString : t -> string -end = struct - type t = {none: Progress.t option; some: Progress.t option} - - let getNone {none} = none - let getSome {some} = some - - let toString x = - ((match x.some with - | None -> [] - | Some p -> ["some: " ^ Progress.toString p]) - @ - match x.none with - | None -> [] - | Some p -> ["none: " ^ Progress.toString p]) - |> String.concat ", " - - let none ~progress = {none = Some progress; some = None} - let some ~progress = {none = None; some = Some progress} - - let nd (v1 : t) (v2 : t) : t = - let combine x y = - match (x, y) with - | Some progress1, Some progress2 -> - Some - (match progress1 = Progress.Progress && progress2 = Progress with - | true -> Progress.Progress - | false -> NoProgress) - | None, progressOpt | progressOpt, None -> progressOpt - in - let none = combine v1.none v2.none in - let some = combine v1.some v2.some in - {none; some} -end - -module State = struct - type t = {progress: Progress.t; trace: Trace.t; valuesOpt: Values.t option} - - let toString {progress; trace; valuesOpt} = - let progressStr = - match valuesOpt with - | None -> progress |> Progress.toString - | Some values -> "{" ^ (values |> Values.toString) ^ "}" - in - progressStr ^ " with trace " ^ Trace.toString trace - - let init ?(progress = Progress.NoProgress) ?(trace = Trace.empty) - ?(valuesOpt = None) () = - {progress; trace; valuesOpt} - - let seq s1 s2 = - let progress = - match s1.progress = Progress || s2.progress = Progress with - | true -> Progress.Progress - | false -> NoProgress - in - let trace = Trace.seq s1.trace s2.trace in - let valuesOpt = s2.valuesOpt in - {progress; trace; valuesOpt} - - let sequence states = - match states with - | [] -> assert false - | s :: nextStates -> List.fold_left seq s nextStates - - let nd s1 s2 = - let progress = - match s1.progress = Progress && s2.progress = Progress with - | true -> Progress.Progress - | false -> NoProgress - in - let trace = Trace.nd s1.trace s2.trace in - let valuesOpt = - match (s1.valuesOpt, s2.valuesOpt) with - | None, valuesOpt -> ( - match s1.progress = Progress with - | true -> valuesOpt - | false -> None) - | valuesOpt, None -> ( - match s2.progress = Progress with - | true -> valuesOpt - | false -> None) - | Some values1, Some values2 -> Some (Values.nd values1 values2) - in - {progress; trace; valuesOpt} - - let nondet states = - match states with - | [] -> assert false - | s :: nextStates -> List.fold_left nd s nextStates - - let unorderedSequence states = {(states |> sequence) with valuesOpt = None} - - let none ~progress = - init ~progress ~trace:Trace.none - ~valuesOpt:(Some (Values.none ~progress)) - () - - let some ~progress = - init ~progress ~trace:Trace.some - ~valuesOpt:(Some (Values.some ~progress)) - () -end - -module Command = struct - type progress = Progress.t - type retOption = Trace.retOption - - type t = - | Call of Call.t * Location.t - | ConstrOption of retOption - | Nondet of t list - | Nothing - | Sequence of t list - | SwitchOption of { - functionCall: FunctionCall.t; - loc: Location.t; - some: t; - none: t; - } - | UnorderedSequence of t list - - let rec toString command = - match command with - | Call (call, _pos) -> call |> Call.toString - | ConstrOption r -> r |> Trace.retOptionToString - | Nondet commands -> - "[" ^ (commands |> List.map toString |> String.concat " || ") ^ "]" - | Nothing -> "_" - | Sequence commands -> commands |> List.map toString |> String.concat "; " - | SwitchOption {functionCall; some = cSome; none = cNone} -> - "switch " - ^ FunctionCall.toString functionCall - ^ " {some: " ^ toString cSome ^ ", none: " ^ toString cNone ^ "}" - | UnorderedSequence commands -> - "{" ^ (commands |> List.map toString |> String.concat ", ") ^ "}" - - let nothing = Nothing - - let nondet commands = - let rec loop commands = - match commands with - | [] -> nothing - | Nondet commands :: rest -> loop (commands @ rest) - | [command] -> command - | _ -> Nondet commands - in - loop commands - - let sequence commands = - let rec loop acc commands = - match commands with - | [] -> List.rev acc - | Nothing :: cs when cs <> [] -> loop acc cs - | Sequence cs1 :: cs2 -> loop acc (cs1 @ cs2) - | c :: cs -> loop (c :: acc) cs - in - match loop [] commands with - | [c] -> c - | cs -> Sequence cs - - let ( +++ ) c1 c2 = sequence [c1; c2] - - let unorderedSequence commands = - let relevantCommands = commands |> List.filter (fun x -> x <> nothing) in - match relevantCommands with - | [] -> nothing - | [c] -> c - | _ :: _ :: _ -> UnorderedSequence relevantCommands -end - -module Kind = struct - type t = entry list - and entry = {label: string; k: t} - - let empty = ([] : t) - - let hasLabel ~label (k : t) = - k |> List.exists (fun entry -> entry.label = label) - - let rec entryToString {label; k} = - match k = [] with - | true -> label - | false -> label ^ ":" ^ (k |> toString) - - and toString (kind : t) = - match kind = [] with - | true -> "" - | false -> - "<" ^ (kind |> List.map entryToString |> String.concat ", ") ^ ">" - - let addLabelWithEmptyKind ~label kind = - if not (kind |> hasLabel ~label) then - {label; k = empty} :: kind |> List.sort compare - else kind -end - -module FunctionTable = struct - type functionDefinition = { - mutable body: Command.t option; - mutable kind: Kind.t; - } - - type t = (FunctionName.t, functionDefinition) Hashtbl.t - - let create () : t = Hashtbl.create 1 - - let print ppf (tbl : t) = - Format.fprintf ppf "@[@,@{Function Table@}"; - let definitions = - Hashtbl.fold - (fun functionName {kind; body} definitions -> - (functionName, kind, body) :: definitions) - tbl [] - |> List.sort (fun (fn1, _, _) (fn2, _, _) -> String.compare fn1 fn2) - in - definitions - |> List.iteri (fun i (functionName, kind, body) -> - Format.fprintf ppf "@,@{%d@} @{%s%s@}: %s" (i + 1) - functionName (Kind.toString kind) - (match body with - | Some command -> Command.toString command - | None -> "None")); - Format.fprintf ppf "@]" - - let dump tbl = Format.fprintf Format.std_formatter "%a@." print tbl - let initialFunctionDefinition () = {kind = Kind.empty; body = None} - - let getFunctionDefinition ~functionName (tbl : t) = - try Hashtbl.find tbl functionName with Not_found -> assert false - - let isInFunctionInTable ~functionTable path = - Hashtbl.mem functionTable (Path.name path) - - let addFunction ~functionName (tbl : t) = - if Hashtbl.mem tbl functionName then assert false; - Hashtbl.replace tbl functionName (initialFunctionDefinition ()) - - let addLabelToKind ~functionName ~label (tbl : t) = - let functionDefinition = tbl |> getFunctionDefinition ~functionName in - functionDefinition.kind <- - functionDefinition.kind |> Kind.addLabelWithEmptyKind ~label - - let addBody ~body ~functionName (tbl : t) = - let functionDefinition = tbl |> getFunctionDefinition ~functionName in - functionDefinition.body <- body - - let functionGetKindOfLabel ~functionName ~label (tbl : t) = - match Hashtbl.find tbl functionName with - | {kind} -> ( - match kind |> Kind.hasLabel ~label with - | true -> Some Kind.empty - | false -> None) - | exception Not_found -> None -end - -module FindFunctionsCalled = struct - let traverseExpr ~callees = - let super = Tast_mapper.default in - let expr (self : Tast_mapper.mapper) (e : Typedtree.expression) = - (match e.exp_desc with - | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)}} -> - let functionName = Path.name callee in - callees := !callees |> StringSet.add functionName - | _ -> ()); - super.expr self e - in - {super with Tast_mapper.expr} - - let findCallees (expression : Typedtree.expression) = - let isFunction = - match expression.exp_desc with - | Texp_function {arity = None} -> true - | _ -> false - in - let callees = ref StringSet.empty in - let traverseExpr = traverseExpr ~callees in - if isFunction then expression |> traverseExpr.expr traverseExpr |> ignore; - !callees -end - -module ExtendFunctionTable = struct - (* Add functions passed a recursive function via a labeled argument, - and functions calling progress functions, to the function table. *) - let extractLabelledArgument ?(kindOpt = None) - (argOpt : Typedtree.expression option) = - match argOpt with - | Some {exp_desc = Texp_ident (path, {loc}, _)} -> Some (path, loc) - | Some - { - exp_desc = - Texp_let - ( Nonrecursive, - [ - { - vb_pat = {pat_desc = Tpat_var (_, _)}; - vb_expr = {exp_desc = Texp_ident (path, {loc}, _)}; - vb_loc = {loc_ghost = true}; - }; - ], - _ ); - } -> - Some (path, loc) - | Some - { - exp_desc = - Texp_apply {funct = {exp_desc = Texp_ident (path, {loc}, _)}; args}; - } - when kindOpt <> None -> - let checkArg ((argLabel : Asttypes.arg_label), _argOpt) = - match (argLabel, kindOpt) with - | (Labelled {txt = l} | Optional {txt = l}), Some kind -> - kind |> List.for_all (fun {Kind.label} -> label <> l) - | _ -> true - in - if args |> List.for_all checkArg then Some (path, loc) else None - | _ -> None - - let traverseExpr ~config ~functionTable ~progressFunctions ~valueBindingsTable - = - let super = Tast_mapper.default in - let expr (self : Tast_mapper.mapper) (e : Typedtree.expression) = - (match e.exp_desc with - | Texp_ident (callee, _, _) -> ( - let loc = e.exp_loc in - match Hashtbl.find_opt valueBindingsTable (Path.name callee) with - | None -> () - | Some (id_pos, _, callees) -> - if - not - (StringSet.is_empty - (StringSet.inter (Lazy.force callees) progressFunctions)) - then - let functionName = Path.name callee in - if not (callee |> FunctionTable.isInFunctionInTable ~functionTable) - then ( - functionTable |> FunctionTable.addFunction ~functionName; - if config.DceConfig.cli.debug then - Log_.warning ~forStats:false ~loc - (Termination - { - termination = TerminationAnalysisInternal; - message = - Format.asprintf - "Extend Function Table with @{%s@} (%a) as it \ - calls a progress function" - functionName printPos id_pos; - }))) - | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)}; args} - when callee |> FunctionTable.isInFunctionInTable ~functionTable -> - let functionName = Path.name callee in - args - |> List.iter (fun ((argLabel : Asttypes.arg_label), argOpt) -> - match (argLabel, argOpt |> extractLabelledArgument) with - | Labelled {txt = label}, Some (path, loc) - when path |> FunctionTable.isInFunctionInTable ~functionTable - -> - functionTable - |> FunctionTable.addLabelToKind ~functionName ~label; - if config.DceConfig.cli.debug then - Log_.warning ~forStats:false ~loc - (Termination - { - termination = TerminationAnalysisInternal; - message = - Format.asprintf - "@{%s@} is parametric \ - ~@{%s@}=@{%s@}" - functionName label (Path.name path); - }) - | _ -> ()) - | _ -> ()); - super.expr self e - in - {super with Tast_mapper.expr} - - let run ~config ~functionTable ~progressFunctions ~valueBindingsTable - (expression : Typedtree.expression) = - let traverseExpr = - traverseExpr ~config ~functionTable ~progressFunctions ~valueBindingsTable - in - expression |> traverseExpr.expr traverseExpr |> ignore -end - -module CheckExpressionWellFormed = struct - let traverseExpr ~config ~functionTable ~valueBindingsTable = - let super = Tast_mapper.default in - let checkIdent ~path ~loc = - if path |> FunctionTable.isInFunctionInTable ~functionTable then - Stats.logHygieneOnlyCallDirectly ~path ~loc - in - let expr (self : Tast_mapper.mapper) (e : Typedtree.expression) = - match e.exp_desc with - | Texp_ident (path, {loc}, _) -> - checkIdent ~path ~loc; - e - | Texp_apply {funct = {exp_desc = Texp_ident (functionPath, _, _)}; args} - -> - let functionName = Path.name functionPath in - args - |> List.iter (fun ((argLabel : Asttypes.arg_label), argOpt) -> - match argOpt |> ExtendFunctionTable.extractLabelledArgument with - | Some (path, loc) -> ( - match argLabel with - | Labelled {txt = label} -> ( - if - functionTable - |> FunctionTable.functionGetKindOfLabel ~functionName - ~label - <> None - then () - else - match Hashtbl.find_opt valueBindingsTable functionName with - | Some (_pos, (body : Typedtree.expression), _) - when path - |> FunctionTable.isInFunctionInTable ~functionTable - -> - let inTable = - functionPath - |> FunctionTable.isInFunctionInTable ~functionTable - in - if not inTable then - functionTable - |> FunctionTable.addFunction ~functionName; - functionTable - |> FunctionTable.addLabelToKind ~functionName ~label; - if config.DceConfig.cli.debug then - Log_.warning ~forStats:false ~loc:body.exp_loc - (Termination - { - termination = TerminationAnalysisInternal; - message = - Format.asprintf - "Extend Function Table with @{%s@} \ - as parametric ~@{%s@}=@{%s@}" - functionName label (Path.name path); - }) - | _ -> checkIdent ~path ~loc) - | Optional _ | Nolabel -> checkIdent ~path ~loc) - | _ -> ()); - e - | _ -> super.expr self e - in - {super with Tast_mapper.expr} - - let run ~config ~functionTable ~valueBindingsTable - (expression : Typedtree.expression) = - let traverseExpr = - traverseExpr ~config ~functionTable ~valueBindingsTable - in - expression |> traverseExpr.expr traverseExpr |> ignore -end - -module Compile = struct - type ctx = { - config: DceConfig.t; - currentFunctionName: FunctionName.t; - functionTable: FunctionTable.t; - innerRecursiveFunctions: (FunctionName.t, FunctionName.t) Hashtbl.t; - isProgressFunction: Path.t -> bool; - } - - let rec expression ~ctx (expr : Typedtree.expression) = - let {config; currentFunctionName; functionTable; isProgressFunction} = - ctx - in - let loc = expr.exp_loc in - let notImplemented case = - Log_.error ~loc - (Termination - {termination = ErrorNotImplemented; message = Format.asprintf case}) - in - - match expr.exp_desc with - | Texp_ident _ -> Command.nothing - | Texp_apply - { - funct = {exp_desc = Texp_ident (calleeToRename, l, vd)} as expr; - args = argsToExtend; - } -> ( - let callee, args = - match - Hashtbl.find_opt ctx.innerRecursiveFunctions - (Path.name calleeToRename) - with - | Some innerFunctionName -> - let innerFunctionDefinition = - functionTable - |> FunctionTable.getFunctionDefinition - ~functionName:innerFunctionName - in - let argsFromKind = - innerFunctionDefinition.kind - |> List.map (fun (entry : Kind.entry) -> - ( Asttypes.Labelled {txt = entry.label; loc = Location.none}, - Some - { - expr with - exp_desc = - Texp_ident - (Path.Pident (Ident.create entry.label), l, vd); - } )) - in - ( Path.Pident (Ident.create innerFunctionName), - argsFromKind @ argsToExtend ) - | None -> (calleeToRename, argsToExtend) - in - if callee |> FunctionTable.isInFunctionInTable ~functionTable then - let functionName = Path.name callee in - let functionDefinition = - functionTable |> FunctionTable.getFunctionDefinition ~functionName - in - let exception ArgError in - let getFunctionArg {Kind.label} = - let argOpt = - args - |> List.find_opt (fun arg -> - match arg with - | Asttypes.Labelled {txt = s}, Some _ -> s = label - | _ -> false) - in - let argOpt = - match argOpt with - | Some (_, Some e) -> Some e - | _ -> None - in - let functionArg () = - match - argOpt - |> ExtendFunctionTable.extractLabelledArgument - ~kindOpt:(Some functionDefinition.kind) - with - | None -> - Stats.logHygieneMustHaveNamedArgument ~label ~loc; - raise ArgError - | Some (path, _pos) - when path |> FunctionTable.isInFunctionInTable ~functionTable -> - let functionName = Path.name path in - {FunctionArgs.label; functionName} - | Some (path, _pos) - when functionTable - |> FunctionTable.functionGetKindOfLabel - ~functionName:currentFunctionName - ~label:(Path.name path) - = Some [] - (* TODO: when kinds are inferred, support and check non-empty kinds *) - -> - let functionName = Path.name path in - {FunctionArgs.label; functionName} - | _ -> - Stats.logHygieneNamedArgValue ~label ~loc; - raise ArgError - [@@raises ArgError] - in - functionArg () - [@@raises ArgError] - in - let functionArgsOpt = - try Some (functionDefinition.kind |> List.map getFunctionArg) - with ArgError -> None - in - match functionArgsOpt with - | None -> Command.nothing - | Some functionArgs -> - Command.Call (FunctionCall {functionName; functionArgs}, loc) - |> evalArgs ~args ~ctx - else if callee |> isProgressFunction then - Command.Call (ProgressFunction callee, loc) |> evalArgs ~args ~ctx - else - match - functionTable - |> FunctionTable.functionGetKindOfLabel - ~functionName:currentFunctionName ~label:(Path.name callee) - with - | Some kind when kind = Kind.empty -> - Command.Call - (FunctionCall (Path.name callee |> FunctionCall.noArgs), loc) - |> evalArgs ~args ~ctx - | Some _kind -> - (* TODO when kinds are extended in future: check that args matches with kind - and create a function call with the appropriate arguments *) - assert false - | None -> expr |> expression ~ctx |> evalArgs ~args ~ctx) - | Texp_apply {funct = expr; args} -> - expr |> expression ~ctx |> evalArgs ~args ~ctx - | Texp_let - ( Recursive, - [{vb_pat = {pat_desc = Tpat_var (id, _); pat_loc}; vb_expr}], - inExpr ) -> - let oldFunctionName = Ident.name id in - let newFunctionName = currentFunctionName ^ "$" ^ oldFunctionName in - functionTable |> FunctionTable.addFunction ~functionName:newFunctionName; - let newFunctionDefinition = - functionTable - |> FunctionTable.getFunctionDefinition ~functionName:newFunctionName - in - let currentFunctionDefinition = - functionTable - |> FunctionTable.getFunctionDefinition ~functionName:currentFunctionName - in - newFunctionDefinition.kind <- currentFunctionDefinition.kind; - let newCtx = {ctx with currentFunctionName = newFunctionName} in - Hashtbl.replace ctx.innerRecursiveFunctions oldFunctionName - newFunctionName; - newFunctionDefinition.body <- Some (vb_expr |> expression ~ctx:newCtx); - if config.DceConfig.cli.debug then - Log_.warning ~forStats:false ~loc:pat_loc - (Termination - { - termination = TerminationAnalysisInternal; - message = - Format.asprintf "Adding recursive definition @{%s@}" - newFunctionName; - }); - inExpr |> expression ~ctx - | Texp_let (recFlag, valueBindings, inExpr) -> - if recFlag = Recursive then Stats.logHygieneNoNestedLetRec ~loc; - let commands = - (valueBindings - |> List.map (fun (vb : Typedtree.value_binding) -> - vb.vb_expr |> expression ~ctx)) - @ [inExpr |> expression ~ctx] - in - Command.sequence commands - | Texp_sequence (e1, e2) -> - let open Command in - expression ~ctx e1 +++ expression ~ctx e2 - | Texp_ifthenelse (e1, e2, eOpt) -> - let c1 = e1 |> expression ~ctx in - let c2 = e2 |> expression ~ctx in - let c3 = eOpt |> expressionOpt ~ctx in - let open Command in - c1 +++ nondet [c2; c3] - | Texp_constant _ -> Command.nothing - | Texp_construct ({loc = {loc_ghost}}, {cstr_name}, expressions) -> ( - let c = - expressions - |> List.map (fun e -> e |> expression ~ctx) - |> Command.unorderedSequence - in - match cstr_name with - | "Some" when loc_ghost = false -> - let open Command in - c +++ ConstrOption Rsome - | "None" when loc_ghost = false -> - let open Command in - c +++ ConstrOption Rnone - | _ -> c) - | Texp_function {case = case_} -> case ~ctx case_ - | Texp_match (e, casesOk, casesExn, _partial) - when not - (casesExn - |> List.map (fun (case : Typedtree.case) -> case.c_lhs.pat_desc) - != []) -> ( - (* No exceptions *) - let cases = casesOk @ casesExn in - let cE = e |> expression ~ctx in - let cCases = cases |> List.map (case ~ctx) in - let fail () = - let open Command in - cE +++ nondet cCases - in - match (cE, cases) with - | ( Call (FunctionCall functionCall, loc), - [{c_lhs = pattern1}; {c_lhs = pattern2}] ) -> ( - match (pattern1.pat_desc, pattern2.pat_desc) with - | ( Tpat_construct (_, {cstr_name = ("Some" | "None") as name1}, _), - Tpat_construct (_, {cstr_name = "Some" | "None"}, _) ) -> - let casesArr = Array.of_list cCases in - let some, none = - try - match name1 = "Some" with - | true -> (casesArr.(0), casesArr.(1)) - | false -> (casesArr.(1), casesArr.(0)) - with Invalid_argument _ -> (Nothing, Nothing) - in - Command.SwitchOption {functionCall; loc; some; none} - | _ -> fail ()) - | _ -> fail ()) - | Texp_match _ -> assert false (* exceptions *) - | Texp_field (e, _lid, _desc) -> e |> expression ~ctx - | Texp_record {fields; extended_expression} -> - extended_expression - :: (fields |> Array.to_list - |> List.map - (fun - ( _desc, - (recordLabelDefinition : Typedtree.record_label_definition), - _ ) - -> - match recordLabelDefinition with - | Kept _typeExpr -> None - | Overridden (_loc, e) -> Some e)) - |> List.map (expressionOpt ~ctx) - |> Command.unorderedSequence - | Texp_setfield (e1, _loc, _desc, e2) -> - [e1; e2] |> List.map (expression ~ctx) |> Command.unorderedSequence - | Texp_tuple expressions | Texp_array expressions -> - expressions |> List.map (expression ~ctx) |> Command.unorderedSequence - | Texp_assert _ -> Command.nothing - | Texp_try (e, cases) -> - let cE = e |> expression ~ctx in - let cCases = cases |> List.map (case ~ctx) |> Command.nondet in - let open Command in - cE +++ cCases - | Texp_variant (_label, eOpt) -> eOpt |> expressionOpt ~ctx - | Texp_while _ -> - notImplemented "Texp_while"; - assert false - | Texp_for (_id, _pat, e1, e2, _dir, e3) -> - let open Command in - expression ~ctx e1 +++ expression ~ctx e2 +++ expression ~ctx e3 - | Texp_for_of (_id, _pat, e1, e2) -> - let open Command in - expression ~ctx e1 +++ expression ~ctx e2 - | Texp_for_await_of (_id, _pat, e1, e2) -> - let open Command in - expression ~ctx e1 +++ expression ~ctx e2 - | Texp_send _ -> - notImplemented "Texp_send"; - assert false - | Texp_letmodule _ -> - notImplemented "Texp_letmodule"; - assert false - | Texp_letexception _ -> - notImplemented "Texp_letexception"; - assert false - | Texp_pack _ -> - notImplemented "Texp_pack"; - assert false - | Texp_extension_constructor _ when true -> - notImplemented "Texp_extension_constructor"; - assert false - | _ -> - (* ocaml 4.08: Texp_letop(_) | Texp_open(_) *) - notImplemented "Texp_letop(_) | Texp_open(_)"; - assert false - - and expressionOpt ~ctx eOpt = - match eOpt with - | None -> Command.nothing - | Some e -> e |> expression ~ctx - - and evalArgs ~args ~ctx command = - (* Don't assume any evaluation order on the arguments *) - let commands = - args |> List.map (fun (_, eOpt) -> eOpt |> expressionOpt ~ctx) - in - let open Command in - unorderedSequence commands +++ command - - and case : ctx:ctx -> Typedtree.case -> _ = - fun ~ctx {c_guard; c_rhs} -> - match c_guard with - | None -> c_rhs |> expression ~ctx - | Some e -> - let open Command in - expression ~ctx e +++ expression ~ctx c_rhs -end - -module CallStack = struct - type frame = {frameNumber: int; pos: Lexing.position} - type t = {tbl: (FunctionCall.t, frame) Hashtbl.t; mutable size: int} - - let create () = {tbl = Hashtbl.create 1; size = 0} - - let toSet {tbl} = - Hashtbl.fold - (fun frame _i set -> FunctionCallSet.add frame set) - tbl FunctionCallSet.empty - - let hasFunctionCall ~functionCall (t : t) = Hashtbl.mem t.tbl functionCall - - let addFunctionCall ~functionCall ~pos (t : t) = - t.size <- t.size + 1; - Hashtbl.replace t.tbl functionCall {frameNumber = t.size; pos} - - let removeFunctionCall ~functionCall (t : t) = - t.size <- t.size - 1; - Hashtbl.remove t.tbl functionCall - - let print ppf (t : t) = - Format.fprintf ppf " CallStack:"; - let frames = - Hashtbl.fold - (fun functionCall {frameNumber; pos} frames -> - (functionCall, frameNumber, pos) :: frames) - t.tbl [] - |> List.sort (fun (_, i1, _) (_, i2, _) -> i2 - i1) - in - frames - |> List.iter (fun ((functionCall : FunctionCall.t), i, pos) -> - Format.fprintf ppf "\n @{%d@} %s (%a)" i - (FunctionCall.toString functionCall) - printPos pos) -end - -module Eval = struct - type progress = Progress.t - type cache = (FunctionCall.t, State.t) Hashtbl.t - - let createCache () : cache = Hashtbl.create 1 - - let lookupCache ~functionCall (cache : cache) = - Hashtbl.find_opt cache functionCall - - let updateCache ~config ~functionCall ~loc ~state (cache : cache) = - Stats.logResult ~config ~functionCall ~resString:(state |> State.toString) - ~loc; - if not (Hashtbl.mem cache functionCall) then - Hashtbl.replace cache functionCall state - - let hasInfiniteLoop ~callStack ~functionCallToInstantiate ~functionCall ~loc - ~state = - if callStack |> CallStack.hasFunctionCall ~functionCall then ( - if state.State.progress = NoProgress then ( - Log_.error ~loc - (Termination - { - termination = ErrorTermination; - message = - Format.asprintf "%a" - (fun ppf () -> - Format.fprintf ppf "Possible infinite loop when calling "; - (match functionCallToInstantiate = functionCall with - | true -> - Format.fprintf ppf "@{%s@}" - (functionCallToInstantiate |> FunctionCall.toString) - | false -> - Format.fprintf ppf "@{%s@} which is @{%s@}" - (functionCallToInstantiate |> FunctionCall.toString) - (functionCall |> FunctionCall.toString)); - Format.fprintf ppf "@,%a" CallStack.print callStack) - (); - }); - Stats.logLoop ()); - true) - else false - - let rec runFunctionCall ~config ~cache ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~loc ~state functionCallToInstantiate : State.t = - let pos = loc.Location.loc_start in - let functionCall = - functionCallToInstantiate - |> FunctionCall.applySubstitution ~sub:functionArgs - in - let functionName = functionCall.functionName in - let call = Call.FunctionCall functionCall in - let stateAfterCall = - match cache |> lookupCache ~functionCall with - | Some stateAfterCall -> - Stats.logCache ~config ~functionCall ~hit:true ~loc; - { - stateAfterCall with - trace = Trace.Tcall (call, stateAfterCall.progress); - } - | None -> - if FunctionCallSet.mem functionCall madeProgressOn then - State.init ~progress:Progress ~trace:(Trace.Tcall (call, Progress)) () - else if - hasInfiniteLoop ~callStack ~functionCallToInstantiate ~functionCall - ~loc ~state - then {state with trace = Trace.Tcall (call, state.progress)} - else ( - Stats.logCache ~config ~functionCall ~hit:false ~loc; - let functionDefinition = - functionTable |> FunctionTable.getFunctionDefinition ~functionName - in - callStack |> CallStack.addFunctionCall ~functionCall ~pos; - let body = - match functionDefinition.body with - | Some body -> body - | None -> assert false - in - let stateAfterCall = - body - |> run ~config ~cache ~callStack - ~functionArgs:functionCall.functionArgs ~functionTable - ~madeProgressOn ~state:(State.init ()) - in - cache |> updateCache ~config ~functionCall ~loc ~state:stateAfterCall; - (* Invariant: run should restore the callStack *) - callStack |> CallStack.removeFunctionCall ~functionCall; - let trace = Trace.Tcall (call, stateAfterCall.progress) in - {stateAfterCall with trace}) - in - State.seq state stateAfterCall - - and run ~config ~(cache : cache) ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~state (command : Command.t) : State.t = - match command with - | Call (FunctionCall functionCall, loc) -> - functionCall - |> runFunctionCall ~config ~cache ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~loc ~state - | Call ((ProgressFunction _ as call), _pos) -> - let state1 = - State.init ~progress:Progress ~trace:(Tcall (call, Progress)) () - in - State.seq state state1 - | ConstrOption r -> - let state1 = - match r = Rsome with - | true -> State.some ~progress:state.progress - | false -> State.none ~progress:state.progress - in - State.seq state state1 - | Nothing -> - let state1 = State.init () in - State.seq state state1 - | Sequence commands -> - (* if one command makes progress, then the sequence makes progress *) - let rec findFirstProgress ~callStack ~commands ~madeProgressOn ~state = - match commands with - | [] -> state - | c :: nextCommands -> - let state1 = - c - |> run ~config ~cache ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~state - in - let madeProgressOn, callStack = - match state1.progress with - | Progress -> - (* look for infinite loops in the rest of the sequence, remembering what has made progress *) - ( FunctionCallSet.union madeProgressOn - (callStack |> CallStack.toSet), - CallStack.create () ) - | NoProgress -> (madeProgressOn, callStack) - in - findFirstProgress ~callStack ~commands:nextCommands ~madeProgressOn - ~state:state1 - in - findFirstProgress ~callStack ~commands ~madeProgressOn ~state - | UnorderedSequence commands -> - let stateNoTrace = {state with trace = Trace.empty} in - (* the commands could be executed in any order: progess if any one does *) - let states = - commands - |> List.map (fun c -> - c - |> run ~config ~cache ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~state:stateNoTrace) - in - State.seq state (states |> State.unorderedSequence) - | Nondet commands -> - let stateNoTrace = {state with trace = Trace.empty} in - (* the commands could be executed in any order: progess if any one does *) - let states = - commands - |> List.map (fun c -> - c - |> run ~config ~cache ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~state:stateNoTrace) - in - State.seq state (states |> State.nondet) - | SwitchOption {functionCall; loc; some; none} -> ( - let stateAfterCall = - functionCall - |> runFunctionCall ~config ~cache ~callStack ~functionArgs - ~functionTable ~madeProgressOn ~loc ~state - in - match stateAfterCall.valuesOpt with - | None -> - Command.nondet [some; none] - |> run ~config ~cache ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~state:stateAfterCall - | Some values -> - let runOpt c progressOpt = - match progressOpt with - | None -> State.init ~progress:Progress () - | Some progress -> - c - |> run ~config ~cache ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~state:(State.init ~progress ()) - in - let stateNone = values |> Values.getNone |> runOpt none in - let stateSome = values |> Values.getSome |> runOpt some in - State.seq stateAfterCall (State.nondet [stateSome; stateNone])) - - let analyzeFunction ~config ~cache ~functionTable ~loc functionName = - if config.DceConfig.cli.debug then - Log_.log "@[@,@{Termination Analysis@} for @{%s@}@]@." - functionName; - let pos = loc.Location.loc_start in - let callStack = CallStack.create () in - let functionArgs = FunctionArgs.empty in - let functionCall = FunctionCall.noArgs functionName in - callStack |> CallStack.addFunctionCall ~functionCall ~pos; - let functionDefinition = - functionTable |> FunctionTable.getFunctionDefinition ~functionName - in - if functionDefinition.kind <> Kind.empty then - Stats.logHygieneParametric ~functionName ~loc - else - let body = - match functionDefinition.body with - | Some body -> body - | None -> assert false - in - let state = - body - |> run ~config ~cache ~callStack ~functionArgs ~functionTable - ~madeProgressOn:FunctionCallSet.empty ~state:(State.init ()) - in - cache |> updateCache ~config ~functionCall ~loc ~state -end - -let progressFunctionsFromAttributes attributes = - let lidToString lid = lid |> Longident.flatten |> String.concat "." in - let isProgress = ( = ) "progress" in - if attributes |> Annotation.hasAttribute isProgress then - Some - (match attributes |> Annotation.getAttributePayload isProgress with - | None -> [] - | Some (IdentPayload lid) -> [lidToString lid] - | Some (TuplePayload l) -> - l - |> List.filter_map (function - | Annotation.IdentPayload lid -> Some (lidToString lid) - | _ -> None) - | _ -> []) - else None - -let traverseAst ~config ~valueBindingsTable = - let super = Tast_mapper.default in - let value_bindings (self : Tast_mapper.mapper) (recFlag, valueBindings) = - (* Update the table of value bindings for variables *) - valueBindings - |> List.iter (fun (vb : Typedtree.value_binding) -> - match vb.vb_pat.pat_desc with - | Tpat_var (id, {loc = {loc_start = pos}}) -> - let callees = lazy (FindFunctionsCalled.findCallees vb.vb_expr) in - Hashtbl.replace valueBindingsTable (Ident.name id) - (pos, vb.vb_expr, callees) - | _ -> ()); - let progressFunctions, functionsToAnalyze = - if recFlag = Asttypes.Nonrecursive then (StringSet.empty, []) - else - let progressFunctions0, functionsToAnalyze0 = - valueBindings - |> List.fold_left - (fun (progressFunctions, functionsToAnalyze) - (valueBinding : Typedtree.value_binding) -> - match - progressFunctionsFromAttributes valueBinding.vb_attributes - with - | None -> (progressFunctions, functionsToAnalyze) - | Some newProgressFunctions -> - ( StringSet.union - (StringSet.of_list newProgressFunctions) - progressFunctions, - match valueBinding.vb_pat.pat_desc with - | Tpat_var (id, _) -> - (Ident.name id, valueBinding.vb_expr.exp_loc) - :: functionsToAnalyze - | _ -> functionsToAnalyze )) - (StringSet.empty, []) - in - (progressFunctions0, functionsToAnalyze0 |> List.rev) - in - if functionsToAnalyze <> [] then ( - let functionTable = FunctionTable.create () in - let isProgressFunction path = - StringSet.mem (Path.name path) progressFunctions - in - let recursiveFunctions = - List.fold_left - (fun defs (valueBinding : Typedtree.value_binding) -> - match valueBinding.vb_pat.pat_desc with - | Tpat_var (id, _) -> Ident.name id :: defs - | _ -> defs) - [] valueBindings - |> List.rev - in - let recursiveDefinitions = - recursiveFunctions - |> List.fold_left - (fun acc functionName -> - match Hashtbl.find_opt valueBindingsTable functionName with - | Some (_pos, e, _set) -> (functionName, e) :: acc - | None -> acc) - [] - |> List.rev - in - recursiveDefinitions - |> List.iter (fun (functionName, _body) -> - functionTable |> FunctionTable.addFunction ~functionName); - recursiveDefinitions - |> List.iter (fun (_, body) -> - body - |> ExtendFunctionTable.run ~config ~functionTable - ~progressFunctions ~valueBindingsTable); - recursiveDefinitions - |> List.iter (fun (_, body) -> - body - |> CheckExpressionWellFormed.run ~config ~functionTable - ~valueBindingsTable); - functionTable - |> Hashtbl.iter - (fun - functionName - (functionDefinition : FunctionTable.functionDefinition) - -> - if functionDefinition.body = None then - match Hashtbl.find_opt valueBindingsTable functionName with - | None -> () - | Some (_pos, body, _) -> - functionTable - |> FunctionTable.addBody - ~body: - (Some - (body - |> Compile.expression - ~ctx: - { - config; - currentFunctionName = functionName; - functionTable; - innerRecursiveFunctions = Hashtbl.create 1; - isProgressFunction; - })) - ~functionName); - if config.DceConfig.cli.debug then FunctionTable.dump functionTable; - let cache = Eval.createCache () in - functionsToAnalyze - |> List.iter (fun (functionName, loc) -> - functionName - |> Eval.analyzeFunction ~config ~cache ~functionTable ~loc); - Stats.newRecursiveFunctions ~numFunctions:(Hashtbl.length functionTable)); - valueBindings - |> List.iter (fun valueBinding -> - super.value_binding self valueBinding |> ignore); - (recFlag, valueBindings) - in - {super with Tast_mapper.value_bindings} - -let processStructure ~config (structure : Typedtree.structure) = - Stats.newFile (); - let valueBindingsTable = Hashtbl.create 1 in - let traverseAst = traverseAst ~config ~valueBindingsTable in - structure |> traverseAst.structure traverseAst |> ignore - -let processCmt ~config ~file:_ (cmt_infos : Cmt_format.cmt_infos) = - match cmt_infos.cmt_annots with - | Interface _ -> () - | Implementation structure -> processStructure ~config structure - | _ -> () - -let reportStats ~config:_ = Stats.dump ~ppf:Format.std_formatter diff --git a/analysis/reanalyze/src/CollectAnnotations.ml b/analysis/reanalyze/src/CollectAnnotations.ml deleted file mode 100644 index 2f6b53f4577..00000000000 --- a/analysis/reanalyze/src/CollectAnnotations.ml +++ /dev/null @@ -1,181 +0,0 @@ -(** AST traversal to collect source annotations (@dead, @live, @genType). - - This module traverses the typed AST to find attribute annotations - and records them in a FileAnnotations.builder. *) - -open DeadCommon - -type scope_default = FileAnnotations.annotated_as option - -let processAttributes ~(scope_default : scope_default) ~state ~config ~doGenType - ~name ~pos attributes = - (match scope_default with - | Some FileAnnotations.Live -> FileAnnotations.annotate_live state pos - | Some FileAnnotations.Dead -> FileAnnotations.annotate_dead state pos - | Some FileAnnotations.GenType -> FileAnnotations.annotate_gentype state pos - | None -> ()); - let getPayloadFun f = attributes |> Annotation.getAttributePayload f in - let getPayload (x : string) = - attributes |> Annotation.getAttributePayload (( = ) x) - in - if - doGenType - && getPayloadFun Annotation.tagIsOneOfTheGenTypeAnnotations <> None - then FileAnnotations.annotate_gentype state pos; - if getPayload "dead" <> None then FileAnnotations.annotate_dead state pos; - let nameIsInLiveNamesOrPaths () = - config.DceConfig.cli.live_names |> List.mem name - || - let fname = - match Filename.is_relative pos.pos_fname with - | true -> pos.pos_fname - | false -> Filename.concat (Sys.getcwd ()) pos.pos_fname - in - let fnameLen = String.length fname in - config.DceConfig.cli.live_paths - |> List.exists (fun prefix -> - String.length prefix <= fnameLen - && - try String.sub fname 0 (String.length prefix) = prefix - with Invalid_argument _ -> false) - in - if getPayload liveAnnotation <> None || nameIsInLiveNamesOrPaths () then - FileAnnotations.annotate_live state pos; - if attributes |> Annotation.isOcamlSuppressDeadWarning then - FileAnnotations.annotate_live state pos - -let collectExportLocations ~state ~config ~doGenType = - let super = Tast_mapper.default in - let currentlyDisableWarnings = ref false in - let currentScopeDefault : scope_default ref = ref None in - - let scopeDefaultFromToplevelAttribute (attribute : Parsetree.attribute) : - scope_default = - let attrs = [attribute] in - let getPayload (x : string) = - attrs |> Annotation.getAttributePayload (( = ) x) - in - if getPayload "dead" <> None then Some FileAnnotations.Dead - else if getPayload "live" <> None then Some FileAnnotations.Live - else if getPayload "genType" <> None then Some FileAnnotations.GenType - else None - in - - let value_binding self - ({vb_attributes; vb_pat} as value_binding : Typedtree.value_binding) = - (match vb_pat.pat_desc with - | Tpat_var (id, {loc = {loc_start = pos}}) - | Tpat_alias ({pat_desc = Tpat_any}, id, {loc = {loc_start = pos}}) -> - if !currentlyDisableWarnings then FileAnnotations.annotate_live state pos; - vb_attributes - |> processAttributes ~scope_default:!currentScopeDefault ~state ~config - ~doGenType ~name:(id |> Ident.name) ~pos - | _ -> ()); - super.value_binding self value_binding - in - let type_kind toplevelAttrs self (typeKind : Typedtree.type_kind) = - (match typeKind with - | Ttype_record labelDeclarations -> - labelDeclarations - |> List.iter - (fun ({ld_attributes; ld_loc} : Typedtree.label_declaration) -> - toplevelAttrs @ ld_attributes - |> processAttributes ~scope_default:!currentScopeDefault ~state - ~config ~doGenType:false ~name:"" ~pos:ld_loc.loc_start) - | Ttype_variant constructorDeclarations -> - constructorDeclarations - |> List.iter - (fun - ({cd_attributes; cd_loc; cd_args} : - Typedtree.constructor_declaration) - -> - let _process_inline_records = - match cd_args with - | Cstr_record flds -> - List.iter - (fun ({ld_attributes; ld_loc} : Typedtree.label_declaration) - -> - toplevelAttrs @ cd_attributes @ ld_attributes - |> processAttributes ~scope_default:!currentScopeDefault - ~state ~config ~doGenType:false ~name:"" - ~pos:ld_loc.loc_start) - flds - | Cstr_tuple _ -> () - in - toplevelAttrs @ cd_attributes - |> processAttributes ~scope_default:!currentScopeDefault ~state - ~config ~doGenType:false ~name:"" ~pos:cd_loc.loc_start) - | _ -> ()); - super.type_kind self typeKind - in - let type_declaration self (typeDeclaration : Typedtree.type_declaration) = - let attributes = typeDeclaration.typ_attributes in - let _ = type_kind attributes self typeDeclaration.typ_kind in - typeDeclaration - in - let value_description self - ({val_attributes; val_id; val_val = {val_loc = {loc_start = pos}}} as - value_description : - Typedtree.value_description) = - if !currentlyDisableWarnings then FileAnnotations.annotate_live state pos; - val_attributes - |> processAttributes ~scope_default:!currentScopeDefault ~state ~config - ~doGenType ~name:(val_id |> Ident.name) ~pos; - super.value_description self value_description - in - let structure_item self (item : Typedtree.structure_item) = - (match item.str_desc with - | Tstr_attribute attribute -> ( - match scopeDefaultFromToplevelAttribute attribute with - | Some _ as newDefault -> currentScopeDefault := newDefault - | None -> - if [attribute] |> Annotation.isOcamlSuppressDeadWarning then - currentlyDisableWarnings := true) - | _ -> ()); - super.structure_item self item - in - let structure self (structure : Typedtree.structure) = - let oldDisableWarnings = !currentlyDisableWarnings in - let oldScopeDefault = !currentScopeDefault in - super.structure self structure |> ignore; - currentlyDisableWarnings := oldDisableWarnings; - currentScopeDefault := oldScopeDefault; - structure - in - let signature_item self (item : Typedtree.signature_item) = - (match item.sig_desc with - | Tsig_attribute attribute -> ( - match scopeDefaultFromToplevelAttribute attribute with - | Some _ as newDefault -> currentScopeDefault := newDefault - | None -> - if [attribute] |> Annotation.isOcamlSuppressDeadWarning then - currentlyDisableWarnings := true) - | _ -> ()); - super.signature_item self item - in - let signature self (signature : Typedtree.signature) = - let oldDisableWarnings = !currentlyDisableWarnings in - let oldScopeDefault = !currentScopeDefault in - super.signature self signature |> ignore; - currentlyDisableWarnings := oldDisableWarnings; - currentScopeDefault := oldScopeDefault; - signature - in - { - super with - signature; - signature_item; - structure; - structure_item; - type_declaration; - value_binding; - value_description; - } - -let structure ~state ~config ~doGenType structure = - let mapper = collectExportLocations ~state ~config ~doGenType in - structure |> mapper.structure mapper |> ignore - -let signature ~state ~config signature = - let mapper = collectExportLocations ~state ~config ~doGenType:true in - signature |> mapper.signature mapper |> ignore diff --git a/analysis/reanalyze/src/DcePath.ml b/analysis/reanalyze/src/DcePath.ml deleted file mode 100644 index 5d73e9ff041..00000000000 --- a/analysis/reanalyze/src/DcePath.ml +++ /dev/null @@ -1,48 +0,0 @@ -(** Path representation for dead code analysis. - A path is a list of names, e.g. [MyModule; myFunction] *) - -type t = Name.t list - -let toName (path : t) = - path |> List.rev_map Name.toString |> String.concat "." |> Name.create - -let toString path = path |> toName |> Name.toString - -let withoutHead path = - match - path |> List.rev_map (fun n -> n |> Name.toInterface |> Name.toString) - with - | _ :: tl -> tl |> String.concat "." - | [] -> "" - -let onOkPath ~whenContainsApply ~f path = - match path |> Path.flatten with - | `Ok (id, mods) -> f (Ident.name id :: mods |> String.concat ".") - | `Contains_apply -> whenContainsApply - -let fromPathT path = - match path |> Path.flatten with - | `Ok (id, mods) -> Ident.name id :: mods |> List.rev_map Name.create - | `Contains_apply -> [] - -let moduleToImplementation path = - match path |> List.rev with - | moduleName :: rest -> - (moduleName |> Name.toImplementation) :: rest |> List.rev - | [] -> path - -let moduleToInterface path = - match path |> List.rev with - | moduleName :: rest -> (moduleName |> Name.toInterface) :: rest |> List.rev - | [] -> path - -let toModuleName ~isType path = - match path with - | _ :: tl when not isType -> tl |> toName - | _ :: _ :: tl when isType -> tl |> toName - | _ -> "" |> Name.create - -let typeToInterface path = - match path with - | typeName :: rest -> (typeName |> Name.toInterface) :: rest - | [] -> path diff --git a/analysis/reanalyze/src/DeadException.ml b/analysis/reanalyze/src/DeadException.ml deleted file mode 100644 index f0b6a7f255c..00000000000 --- a/analysis/reanalyze/src/DeadException.ml +++ /dev/null @@ -1,47 +0,0 @@ -open DeadCommon - -module PathMap = Map.Make (struct - type t = DcePath.t - - let compare = Stdlib.compare -end) - -let find_exception_from_decls (decls : Declarations.t) : - DcePath.t -> Location.t option = - let index = - Declarations.fold - (fun _pos (decl : Decl.t) acc -> - match decl.Decl.declKind with - | Exception -> - (* Use raw decl positions: reference graph keys are raw positions. *) - let loc : Location.t = - { - Location.loc_start = decl.pos; - loc_end = decl.posEnd; - loc_ghost = false; - } - in - PathMap.add decl.path loc acc - | _ -> acc) - decls PathMap.empty - in - fun path -> PathMap.find_opt path index - -let add ~config ~decls ~file ~path ~loc ~(strLoc : Location.t) - ~(moduleLoc : Location.t) name = - addDeclaration_ ~config ~decls ~file ~posEnd:strLoc.loc_end - ~posStart:strLoc.loc_start ~declKind:Exception ~moduleLoc ~path ~loc name; - name - -let markAsUsed ~config ~refs ~file_deps ~cross_file ~(binding : Location.t) - ~(locFrom : Location.t) ~(locTo : Location.t) path_ = - if locTo.loc_ghost then - (* Probably defined in another file, delay processing and check at the end *) - let exceptionPath = - path_ |> DcePath.fromPathT |> DcePath.moduleToImplementation - in - CrossFileItems.add_exception_ref cross_file ~exception_path:exceptionPath - ~loc_from:locFrom - else - addValueReference ~config ~refs ~file_deps ~binding ~addFileReference:true - ~locFrom ~locTo diff --git a/analysis/reanalyze/src/DeadException.mli b/analysis/reanalyze/src/DeadException.mli deleted file mode 100644 index 5988ee80eb9..00000000000 --- a/analysis/reanalyze/src/DeadException.mli +++ /dev/null @@ -1,25 +0,0 @@ -open DeadCommon - -val find_exception_from_decls : Declarations.t -> DcePath.t -> Location.t option - -val add : - config:DceConfig.t -> - decls:Declarations.builder -> - file:FileContext.t -> - path:DcePath.t -> - loc:Location.t -> - strLoc:Location.t -> - moduleLoc:Location.t -> - Name.t -> - Name.t - -val markAsUsed : - config:DceConfig.t -> - refs:References.builder -> - file_deps:FileDeps.builder -> - cross_file:CrossFileItems.builder -> - binding:Location.t -> - locFrom:Location.t -> - locTo:Location.t -> - Path.t -> - unit diff --git a/analysis/reanalyze/src/DeadModules.ml b/analysis/reanalyze/src/DeadModules.ml deleted file mode 100644 index c8d512c3717..00000000000 --- a/analysis/reanalyze/src/DeadModules.ml +++ /dev/null @@ -1,39 +0,0 @@ -let active ~config = - (* When transitive reporting is off, the only dead modules would be empty modules *) - config.DceConfig.run.transitive - -let table = Hashtbl.create 1 - -let markDead ~config ~isType ~loc path = - if active ~config then - let moduleName = path |> DcePath.toModuleName ~isType in - match Hashtbl.find_opt table moduleName with - | Some _ -> () - | _ -> Hashtbl.replace table moduleName (false, loc) - -let markLive ~config ~isType ~(loc : Location.t) path = - if active ~config then - let moduleName = path |> DcePath.toModuleName ~isType in - match Hashtbl.find_opt table moduleName with - | None -> Hashtbl.replace table moduleName (true, loc) - | Some (false, loc) -> Hashtbl.replace table moduleName (true, loc) - | Some (true, _) -> () - -(** Check if a module is dead and return issue if so. Pure - no logging. *) -let checkModuleDead ~config ~fileName:pos_fname moduleName : Issue.t option = - if not (active ~config) then None - else - match Hashtbl.find_opt table moduleName with - | Some (false, loc) -> - Hashtbl.remove table moduleName; - (* only report once *) - let loc = - if loc.loc_ghost then - let pos = - {Lexing.pos_fname; pos_lnum = 0; pos_bol = 0; pos_cnum = 0} - in - {Location.loc_start = pos; loc_end = pos; loc_ghost = false} - else loc - in - Some (AnalysisResult.make_dead_module_issue ~loc ~moduleName) - | _ -> None diff --git a/analysis/reanalyze/src/DeadOptionalArgs.ml b/analysis/reanalyze/src/DeadOptionalArgs.ml deleted file mode 100644 index 71bef0ac99b..00000000000 --- a/analysis/reanalyze/src/DeadOptionalArgs.ml +++ /dev/null @@ -1,127 +0,0 @@ -open DeadCommon - -let active () = true - -let addFunctionReference ~config ~decls ~cross_file ~(locFrom : Location.t) - ~(locTo : Location.t) = - if active () then - let posTo = locTo.loc_start in - let posFrom = locFrom.loc_start in - (* Check if target has optional args - for filtering and debug logging *) - let shouldAdd = - match Declarations.find_opt_builder decls posTo with - | Some {declKind = Value {optionalArgs}} -> - not (OptionalArgs.isEmpty optionalArgs) - | _ -> false - in - if shouldAdd then ( - if config.DceConfig.cli.debug then - Log_.item "OptionalArgs.addFunctionReference %s %s@." - (posFrom |> Pos.toString) (posTo |> Pos.toString); - CrossFileItems.add_function_reference cross_file ~pos_from:posFrom - ~pos_to:posTo) - -let rec hasOptionalArgs (texpr : Types.type_expr) = - match texpr.desc with - | _ when not (active ()) -> false - | Tarrow ({lbl = Optional _}, _tTo, _, _) -> true - | Tarrow (_, tTo, _, _) -> hasOptionalArgs tTo - | Tlink t -> hasOptionalArgs t - | Tsubst t -> hasOptionalArgs t - | _ -> false - -let rec fromTypeExpr (texpr : Types.type_expr) = - match texpr.desc with - | _ when not (active ()) -> [] - | Tarrow ({lbl = Optional {txt = s}}, tTo, _, _) -> s :: fromTypeExpr tTo - | Tarrow (_, tTo, _, _) -> fromTypeExpr tTo - | Tlink t -> fromTypeExpr t - | Tsubst t -> fromTypeExpr t - | _ -> [] - -let addReferences ~config ~cross_file ~(locFrom : Location.t) - ~(locTo : Location.t) ~(binding : Location.t) ~path (argNames, argNamesMaybe) - = - if active () then ( - let posTo = locTo.loc_start in - let posFrom = binding.loc_start in - CrossFileItems.add_optional_arg_call cross_file ~pos_from:posFrom - ~pos_to:posTo ~arg_names:argNames ~arg_names_maybe:argNamesMaybe; - if config.DceConfig.cli.debug then - let callPos = locFrom.loc_start in - Log_.item - "DeadOptionalArgs.addReferences %s called with optional argNames:%s \ - argNamesMaybe:%s %s@." - (path |> DcePath.fromPathT |> DcePath.toString) - (argNames |> String.concat ", ") - (argNamesMaybe |> String.concat ", ") - (callPos |> Pos.toString)) - -(** Check for optional args issues. Returns issues instead of logging. - Uses optional_args_state map for final computed state. *) -let check ~optional_args_state ~ann_store ~config:_ decl : Issue.t list = - match decl with - | {Decl.declKind = Value {optionalArgs}} - when active () - && not - (AnnotationStore.is_annotated_gentype_or_live ann_store decl.pos) - -> - (* Look up computed state from map, fall back to declaration's initial state *) - let state = - match OptionalArgsState.find_opt optional_args_state decl.pos with - | Some s -> s - | None -> optionalArgs - in - let loc = decl |> declGetLoc in - let unused_issues = - OptionalArgs.foldUnused - (fun s acc -> - let issue : Issue.t = - { - name = "Warning Unused Argument"; - severity = Warning; - loc; - description = - DeadOptional - { - deadOptional = WarningUnusedArgument; - message = - Format.asprintf - "optional argument @{%s@} of function \ - @{%s@} is never used" - s - (decl.path |> DcePath.withoutHead); - }; - } - in - issue :: acc) - state [] - in - let redundant_issues = - OptionalArgs.foldAlwaysUsed - (fun s nCalls acc -> - let issue : Issue.t = - { - name = "Warning Redundant Optional Argument"; - severity = Warning; - loc; - description = - DeadOptional - { - deadOptional = WarningRedundantOptionalArgument; - message = - Format.asprintf - "optional argument @{%s@} of function \ - @{%s@} is always supplied (%d calls)" - s - (decl.path |> DcePath.withoutHead) - nCalls; - }; - } - in - issue :: acc) - state [] - in - (* Reverse to maintain original order from iterUnused/iterAlwaysUsed *) - List.rev unused_issues @ List.rev redundant_issues - | _ -> [] diff --git a/analysis/reanalyze/src/DeadType.ml b/analysis/reanalyze/src/DeadType.ml deleted file mode 100644 index 3d486aac381..00000000000 --- a/analysis/reanalyze/src/DeadType.ml +++ /dev/null @@ -1,219 +0,0 @@ -(* Adapted from https://github.com/LexiFi/dead_code_analyzer *) - -open DeadCommon - -let addTypeReference ~config ~refs ~posFrom ~posTo = - if config.DceConfig.cli.debug then - Log_.item "addTypeReference %s --> %s@." (posFrom |> Pos.toString) - (posTo |> Pos.toString); - References.add_type_ref refs ~posTo ~posFrom - -let extendTypeDependencies ~config ~refs (loc1 : Location.t) (loc2 : Location.t) - = - let {Location.loc_start = posTo; loc_ghost = ghost1} = loc1 in - let {Location.loc_start = posFrom; loc_ghost = ghost2} = loc2 in - if (not ghost1) && (not ghost2) && posTo <> posFrom then ( - if config.DceConfig.cli.debug then - Log_.item "extendTypeDependencies %s --> %s@." (posTo |> Pos.toString) - (posFrom |> Pos.toString); - addTypeReference ~config ~refs ~posFrom ~posTo) - -let addDeclaration ~config ~decls ~file ~(modulePath : ModulePath.t) - ~(typeId : Ident.t) ~(typeKind : Types.type_kind) - ~(manifestTypePath : DcePath.t option) = - let moduleContext = modulePath.path @ [FileContext.module_name_tagged file] in - let pathToType = (typeId |> Ident.name |> Name.create) :: moduleContext in - let processTypeLabel ?(posAdjustment = Decl.Nothing) typeLabelName ~declKind - ~(loc : Location.t) = - addDeclaration_ ~config ~decls ~file ~declKind ~path:pathToType ~loc - ?manifestTypePath ~moduleLoc:modulePath.loc ~posAdjustment typeLabelName - in - match typeKind with - | Type_record (l, _) -> - List.iter - (fun {Types.ld_id; ld_loc} -> - Ident.name ld_id |> Name.create - |> processTypeLabel ~declKind:RecordLabel ~loc:ld_loc) - l - | Type_variant decls -> - List.iteri - (fun i {Types.cd_id; cd_loc; cd_args} -> - let _handle_inline_records = - match cd_args with - | Cstr_record lbls -> - List.iter - (fun {Types.ld_id; ld_loc} -> - Ident.name cd_id ^ "." ^ Ident.name ld_id - |> Name.create - |> processTypeLabel ~declKind:RecordLabel ~loc:ld_loc) - lbls - | Cstr_tuple _ -> () - in - let posAdjustment = - (* In Res the variant loc can include the | and spaces after it *) - let isRes = - let fname = cd_loc.loc_start.pos_fname in - Filename.check_suffix fname ".res" - || Filename.check_suffix fname ".resi" - in - if isRes then if i = 0 then Decl.FirstVariant else OtherVariant - else Nothing - in - Ident.name cd_id |> Name.create - |> processTypeLabel ~declKind:VariantCase ~loc:cd_loc ~posAdjustment) - decls - | _ -> () - -module PathMap = Map.Make (struct - type t = DcePath.t - - let compare = Stdlib.compare -end) - -let process_type_label_dependencies ~config ~decls ~refs = - (* Use raw declaration positions, not [declGetLoc], because references are keyed - by raw positions (decl.pos). [declGetLoc] applies [posAdjustment] (e.g. +2 - for OtherVariant), which is intended for reporting locations, not for - reference graph keys. *) - let decl_raw_loc (decl : Decl.t) : Location.t = - {Location.loc_start = decl.pos; loc_end = decl.posEnd; loc_ghost = false} - in - (* Build an index from full label path -> list of locations *) - let index = - Declarations.fold - (fun _pos decl acc -> - match decl.Decl.declKind with - | RecordLabel | VariantCase -> - let loc = decl |> decl_raw_loc in - let path = decl.path in - let existing = - PathMap.find_opt path acc |> Option.value ~default:[] - in - PathMap.add path (loc :: existing) acc - | _ -> acc) - decls PathMap.empty - in - (* Inner-module duplicates: if the same full path appears multiple times (e.g. from signature+structure), - connect them together. *) - index - |> PathMap.iter (fun _key locs -> - match locs with - | [] | [_] -> () - | loc0 :: rest -> - rest - |> List.iter (fun loc -> - extendTypeDependencies ~config ~refs loc loc0; - if not Config.reportTypesDeadOnlyInInterface then - extendTypeDependencies ~config ~refs loc0 loc)); - - (* Cross-file impl<->intf linking, modeled after the previous lookup logic. *) - let hd_opt = function - | [] -> None - | x :: _ -> Some x - in - let find_one path = - match PathMap.find_opt path index with - | None -> None - | Some locs -> hd_opt locs - in - - let is_interface_of_pathToType (pathToType : DcePath.t) = - match List.rev pathToType with - | moduleNameTag :: _ -> ( - try (moduleNameTag |> Name.toString).[0] <> '+' - with Invalid_argument _ -> true) - | [] -> true - in - - Declarations.iter - (fun _pos decl -> - match decl.Decl.declKind with - | RecordLabel | VariantCase -> ( - match decl.path with - | [] -> () - | typeLabelName :: pathToType -> ( - let loc = decl |> decl_raw_loc in - let isInterface = is_interface_of_pathToType pathToType in - if not isInterface then - let path_1 = pathToType |> DcePath.moduleToInterface in - let path_2 = path_1 |> DcePath.typeToInterface in - let path1 = typeLabelName :: path_1 in - let path2 = typeLabelName :: path_2 in - match find_one path1 with - | Some loc1 -> - extendTypeDependencies ~config ~refs loc loc1; - if not Config.reportTypesDeadOnlyInInterface then - extendTypeDependencies ~config ~refs loc1 loc - | None -> ( - match find_one path2 with - | Some loc2 -> - extendTypeDependencies ~config ~refs loc loc2; - if not Config.reportTypesDeadOnlyInInterface then - extendTypeDependencies ~config ~refs loc2 loc - | None -> ()) - else - let path_1 = pathToType |> DcePath.moduleToImplementation in - let path1 = typeLabelName :: path_1 in - match find_one path1 with - | None -> () - | Some loc1 -> - extendTypeDependencies ~config ~refs loc1 loc; - if not Config.reportTypesDeadOnlyInInterface then - extendTypeDependencies ~config ~refs loc loc1)) - | _ -> ()) - decls; - - (* Link fields of re-exported types (type y = x = {...}) to original type fields. - We store the manifest type path on the label declarations themselves, and - derive the set of re-export relationships here. To preserve stable output - ordering, we process types bottom-to-top (by their first label position) - and fields top-to-bottom (by their label position). *) - let compare_pos (p1 : Lexing.position) (p2 : Lexing.position) = - match compare p1.Lexing.pos_fname p2.Lexing.pos_fname with - | 0 -> compare p1.Lexing.pos_cnum p2.Lexing.pos_cnum - | c -> c - in - (* currentTypePath -> (rep_pos, manifestTypePath, (pos, fieldName, currentLoc) list) *) - let groups : - ( DcePath.t, - Lexing.position - * DcePath.t - * (Lexing.position * Name.t * Location.t) list ) - Hashtbl.t = - Hashtbl.create 32 - in - Declarations.iter - (fun _pos decl -> - match (decl.Decl.declKind, decl.manifestTypePath, decl.path) with - | ( (RecordLabel | VariantCase), - Some manifestTypePath, - fieldName :: currentTypePath ) -> ( - let item = (decl.pos, fieldName, decl_raw_loc decl) in - match Hashtbl.find_opt groups currentTypePath with - | None -> - Hashtbl.replace groups currentTypePath - (decl.pos, manifestTypePath, [item]) - | Some (rep_pos, mtp0, items) -> - (* manifestTypePath should be stable for a given currentTypePath *) - let rep_pos = - if compare_pos decl.pos rep_pos < 0 then decl.pos else rep_pos - in - Hashtbl.replace groups currentTypePath (rep_pos, mtp0, item :: items)) - | _ -> ()) - decls; - - groups |> Hashtbl.to_seq |> List.of_seq - |> List.map (fun (currentTypePath, (rep_pos, manifestTypePath, items)) -> - (rep_pos, currentTypePath, manifestTypePath, items)) - (* Later (lower) types first *) - |> List.fast_sort (fun (p1, _, _, _) (p2, _, _, _) -> compare_pos p2 p1) - |> List.iter (fun (_rep_pos, _currentTypePath, manifestTypePath, items) -> - items - |> List.fast_sort (fun (p1, _, _) (p2, _, _) -> compare_pos p1 p2) - |> List.iter (fun (_pos, fieldName, currentLoc) -> - let manifestFieldPath = fieldName :: manifestTypePath in - match find_one manifestFieldPath with - | None -> () - | Some manifestLoc -> - extendTypeDependencies ~config ~refs currentLoc manifestLoc; - extendTypeDependencies ~config ~refs manifestLoc currentLoc)) diff --git a/analysis/reanalyze/src/DeadValue.ml b/analysis/reanalyze/src/DeadValue.ml deleted file mode 100644 index 0bb26e9dca1..00000000000 --- a/analysis/reanalyze/src/DeadValue.ml +++ /dev/null @@ -1,484 +0,0 @@ -(* Adapted from https://github.com/LexiFi/dead_code_analyzer *) - -open DeadCommon - -let checkAnyValueBindingWithNoSideEffects ~config ~decls ~file - ~(modulePath : ModulePath.t) - ({vb_pat = {pat_desc}; vb_expr = expr; vb_loc = loc} : - Typedtree.value_binding) = - match pat_desc with - | Tpat_any when (not (SideEffects.checkExpr expr)) && not loc.loc_ghost -> - let name = "_" |> Name.create ~isInterface:false in - let path = modulePath.path @ [FileContext.module_name_tagged file] in - name - |> addValueDeclaration ~config ~decls ~file ~path ~loc - ~moduleLoc:modulePath.loc ~sideEffects:false - | _ -> () - -let collectValueBinding ~config ~decls ~file ~(current_binding : Location.t) - ~(modulePath : ModulePath.t) (vb : Typedtree.value_binding) = - let oldLastBinding = current_binding in - checkAnyValueBindingWithNoSideEffects ~config ~decls ~file ~modulePath vb; - let loc = - match vb.vb_pat.pat_desc with - | Tpat_var (id, {loc = {loc_start; loc_ghost} as loc}) - | Tpat_alias - ({pat_desc = Tpat_any}, id, {loc = {loc_start; loc_ghost} as loc}) - when (not loc_ghost) && not vb.vb_loc.loc_ghost -> - let name = Ident.name id |> Name.create ~isInterface:false in - let optionalArgs = - vb.vb_expr.exp_type |> DeadOptionalArgs.fromTypeExpr - |> OptionalArgs.fromList - in - let exists = - match Declarations.find_opt_builder decls loc_start with - | Some {declKind = Value r} -> - r.optionalArgs <- optionalArgs; - true - | _ -> false - in - let path = modulePath.path @ [FileContext.module_name_tagged file] in - let isFirstClassModule = - match vb.vb_expr.exp_type.desc with - | Tpackage _ -> true - | _ -> false - in - (if (not exists) && not isFirstClassModule then - (* This is never toplevel currently *) - let isToplevel = oldLastBinding = Location.none in - let sideEffects = SideEffects.checkExpr vb.vb_expr in - name - |> addValueDeclaration ~config ~decls ~file ~isToplevel ~loc - ~moduleLoc:modulePath.loc ~optionalArgs ~path ~sideEffects); - (match Declarations.find_opt_builder decls loc_start with - | None -> () - | Some decl -> - (* Value bindings contain the correct location for the entire declaration: update final position. - The previous value was taken from the signature, which only has positions for the id. *) - let declKind = - match decl.declKind with - | Value vk -> - Decl.Kind.Value - {vk with sideEffects = SideEffects.checkExpr vb.vb_expr} - | dk -> dk - in - Declarations.replace_builder decls loc_start - { - decl with - declKind; - posEnd = vb.vb_loc.loc_end; - posStart = vb.vb_loc.loc_start; - }); - loc - | _ -> current_binding - in - loc - -let processOptionalArgs ~config ~cross_file ~expType ~(locFrom : Location.t) - ~(binding : Location.t) ~locTo ~path args = - if expType |> DeadOptionalArgs.hasOptionalArgs then ( - let supplied = ref [] in - let suppliedMaybe = ref [] in - args - |> List.iter (fun (lbl, arg) -> - let argIsSupplied = - match arg with - | Some - { - Typedtree.exp_desc = - Texp_construct (_, {cstr_name = "Some"}, _); - } -> - Some true - | Some - { - Typedtree.exp_desc = - Texp_construct (_, {cstr_name = "None"}, _); - } -> - Some false - | Some _ -> None - | None -> Some false - in - match lbl with - | Asttypes.Optional {txt = s} when not locFrom.loc_ghost -> - if argIsSupplied <> Some false then supplied := s :: !supplied; - if argIsSupplied = None then suppliedMaybe := s :: !suppliedMaybe - | _ -> ()); - (!supplied, !suppliedMaybe) - |> DeadOptionalArgs.addReferences ~config ~cross_file ~locFrom ~locTo - ~binding ~path) - -let rec collectExpr ~config ~refs ~file_deps ~cross_file - ~(last_binding : Location.t) super self (e : Typedtree.expression) = - let locFrom = e.exp_loc in - let binding = last_binding in - (match e.exp_desc with - | Texp_ident (_path, _, {Types.val_loc = {loc_ghost = false; _} as locTo}) -> - (* if Path.name _path = "rc" then assert false; *) - if locFrom = locTo && _path |> Path.name = "emptyArray" then ( - (* Work around lowercase jsx with no children producing an artifact `emptyArray` - which is called from its own location as many things are generated on the same location. *) - if config.DceConfig.cli.debug then - Log_.item "addDummyReference %s --> %s@." - (Location.none.loc_start |> Pos.toString) - (locTo.loc_start |> Pos.toString); - References.add_value_ref refs ~posTo:locTo.loc_start - ~posFrom:Location.none.loc_start) - else - addValueReference ~config ~refs ~file_deps ~binding ~addFileReference:true - ~locFrom ~locTo - | Texp_apply - { - funct = - { - exp_desc = - Texp_ident - (path, _, {Types.val_loc = {loc_ghost = false; _} as locTo}); - exp_type; - }; - args; - } -> - args - |> processOptionalArgs ~config ~cross_file ~expType:exp_type - ~locFrom:(locFrom : Location.t) - ~binding:last_binding ~locTo ~path - | Texp_let - ( (* generated for functions with optional args *) - Nonrecursive, - [ - { - vb_pat = {pat_desc = Tpat_var (idArg, _)}; - vb_expr = - { - exp_desc = - Texp_ident - (path, _, {Types.val_loc = {loc_ghost = false; _} as locTo}); - exp_type; - }; - }; - ], - { - exp_desc = - Texp_function - { - case = - { - c_lhs = {pat_desc = Tpat_var (etaArg, _)}; - c_rhs = - { - exp_desc = - Texp_apply - { - funct = {exp_desc = Texp_ident (idArg2, _, _)}; - args; - }; - }; - }; - }; - } ) - when Ident.name idArg = "arg" - && Ident.name etaArg = "eta" - && Path.name idArg2 = "arg" -> - args - |> processOptionalArgs ~config ~cross_file ~expType:exp_type - ~locFrom:(locFrom : Location.t) - ~binding:last_binding ~locTo ~path - | Texp_field - (_, _, {lbl_loc = {Location.loc_start = posTo; loc_ghost = false}; _}) -> - if !Config.analyzeTypes then - DeadType.addTypeReference ~config ~refs ~posTo ~posFrom:locFrom.loc_start - | Texp_construct - ( _, - {cstr_loc = {Location.loc_start = posTo; loc_ghost} as locTo; cstr_tag}, - _ ) -> - (match cstr_tag with - | Cstr_extension path -> - path - |> DeadException.markAsUsed ~config ~refs ~file_deps ~cross_file ~binding - ~locFrom ~locTo - | _ -> ()); - if !Config.analyzeTypes && not loc_ghost then - DeadType.addTypeReference ~config ~refs ~posTo ~posFrom:locFrom.loc_start - | Texp_record {fields} -> - fields - |> Array.iter (fun (_, record_label_definition, _) -> - match record_label_definition with - | Typedtree.Overridden (_, ({exp_loc} as e)) when exp_loc.loc_ghost - -> - (* Punned field in OCaml projects has ghost location in expression *) - let e = {e with exp_loc = {exp_loc with loc_ghost = false}} in - collectExpr ~config ~refs ~file_deps ~cross_file ~last_binding - super self e - |> ignore - | _ -> ()) - | _ -> ()); - super.Tast_mapper.expr self e - -(* - type k. is a locally abstract type - https://caml.inria.fr/pub/docs/manual-ocaml/locallyabstract.html - it is required because in ocaml >= 4.11 Typedtree.pattern and ADT is converted - in a GADT - https://github.com/ocaml/ocaml/commit/312253ce822c32740349e572498575cf2a82ee96 - in short: all branches of pattern matches aren't the same type. - With this annotation we declare a new type for each branch to allow the - function to be typed. - *) -let collectPattern ~config ~refs : - _ -> _ -> Typedtree.pattern -> Typedtree.pattern = - fun super self pat -> - let posFrom = pat.Typedtree.pat_loc.loc_start in - (match pat.pat_desc with - | Typedtree.Tpat_record (cases, _clodsedFlag) -> - cases - |> List.iter (fun (_loc, {Types.lbl_loc = {loc_start = posTo}}, _pat, _) -> - if !Config.analyzeTypes then - DeadType.addTypeReference ~config ~refs ~posFrom ~posTo) - | _ -> ()); - super.Tast_mapper.pat self pat - -let rec getSignature (moduleType : Types.module_type) = - match moduleType with - | Mty_signature signature -> signature - | Mty_functor (_, _mtParam, mt) -> getSignature mt - | _ -> [] - -let rec processSignatureItem ~config ~decls ~file ~doTypes ~doValues ~moduleLoc - ~(modulePath : ModulePath.t) ~path (si : Types.signature_item) = - match si with - | Sig_type (id, t, _) when doTypes -> - if !Config.analyzeTypes then - (* Extract manifest type path for type re-exports (type y = x = {...}). - Use full Path.t so cross-module re-exports work (Path.Pdot, aliases, etc.). *) - let manifestTypePath = - match t.type_manifest with - | Some {desc = Tconstr (path, _, _)} -> ( - let p = path |> DcePath.fromPathT in - match p with - | [typeName] -> - let moduleContext = - modulePath.path @ [FileContext.module_name_tagged file] - in - Some (typeName :: moduleContext) - | _ -> - Some - (if FileContext.isInterface file then DcePath.moduleToInterface p - else DcePath.moduleToImplementation p)) - | _ -> None - in - DeadType.addDeclaration ~config ~decls ~file ~modulePath ~typeId:id - ~typeKind:t.type_kind ~manifestTypePath - | Sig_value (id, {Types.val_loc = loc; val_kind = kind; val_type}) - when doValues -> - if not loc.Location.loc_ghost then - let isPrimitive = - match kind with - | Val_prim _ -> true - | _ -> false - in - if (not isPrimitive) || !Config.analyzeExternals then - let optionalArgs = - val_type |> DeadOptionalArgs.fromTypeExpr |> OptionalArgs.fromList - in - - (* if Ident.name id = "someValue" then - Printf.printf "XXX %s\n" (Ident.name id); *) - Ident.name id - |> Name.create ~isInterface:false - |> addValueDeclaration ~config ~decls ~file ~loc ~moduleLoc - ~optionalArgs ~path ~sideEffects:false - | Sig_module (id, {Types.md_type = moduleType; md_loc = moduleLoc}, _) - | Sig_modtype (id, {Types.mtd_type = Some moduleType; mtd_loc = moduleLoc}) -> - let modulePath' = - ModulePath.enterModule modulePath - ~name:(id |> Ident.name |> Name.create) - ~loc:moduleLoc - in - let collect = - match si with - | Sig_modtype _ -> false - | _ -> true - in - if collect then - getSignature moduleType - |> List.iter - (processSignatureItem ~config ~decls ~file ~doTypes ~doValues - ~moduleLoc ~modulePath:modulePath' - ~path:((id |> Ident.name |> Name.create) :: path)) - | _ -> () - -(* Traverse the AST *) -let traverseStructure ~config ~decls ~refs ~file_deps ~cross_file ~file ~doTypes - ~doExternals (structure : Typedtree.structure) : unit = - let rec create_mapper (last_binding : Location.t) (modulePath : ModulePath.t) - = - let super = Tast_mapper.default in - let rec mapper = - { - super with - expr = - (fun _self e -> - e - |> collectExpr ~config ~refs ~file_deps ~cross_file ~last_binding - super mapper); - pat = (fun _self p -> p |> collectPattern ~config ~refs super mapper); - structure_item = - (fun _self (structureItem : Typedtree.structure_item) -> - let modulePath_for_item_opt = - match structureItem.str_desc with - | Tstr_module {mb_expr; mb_id; mb_loc} -> - let hasInterface = - match mb_expr.mod_desc with - | Tmod_constraint _ -> true - | _ -> false - in - let modulePath' = - ModulePath.enterModule modulePath - ~name:(mb_id |> Ident.name |> Name.create) - ~loc:mb_loc - in - if hasInterface then - match mb_expr.mod_type with - | Mty_signature signature -> - signature - |> List.iter - (processSignatureItem ~config ~decls ~file ~doTypes - ~doValues:false ~moduleLoc:mb_expr.mod_loc - ~modulePath:modulePath' - ~path: - (modulePath'.path - @ [FileContext.module_name_tagged file])) - | _ -> () - else (); - Some modulePath' - | Tstr_primitive vd when doExternals && !Config.analyzeExternals - -> - let path = - modulePath.path @ [FileContext.module_name_tagged file] - in - let exists = - match - Declarations.find_opt_builder decls vd.val_loc.loc_start - with - | Some {declKind = Value _} -> true - | _ -> false - in - let id = vd.val_id |> Ident.name in - Printf.printf "Primitive %s\n" id; - if - (not exists) && id <> "unsafe_expr" - (* see https://github.com/BuckleScript/bucklescript/issues/4532 *) - then - id - |> Name.create ~isInterface:false - |> addValueDeclaration ~config ~decls ~file ~path - ~loc:vd.val_loc ~moduleLoc:modulePath.loc - ~sideEffects:false; - None - | Tstr_type (_recFlag, typeDeclarations) when doTypes -> - if !Config.analyzeTypes then - typeDeclarations - |> List.iter - (fun (typeDeclaration : Typedtree.type_declaration) -> - (* Extract manifest type path for type re-exports (type y = x = {...}). *) - let manifestTypePath = - match typeDeclaration.typ_manifest with - | Some {ctyp_desc = Ttyp_constr (path, _, _)} -> ( - let p = path |> DcePath.fromPathT in - match p with - | [typeName] -> - let moduleContext = - modulePath.path - @ [FileContext.module_name_tagged file] - in - Some (typeName :: moduleContext) - | _ -> - Some - (if FileContext.isInterface file then - DcePath.moduleToInterface p - else DcePath.moduleToImplementation p)) - | _ -> None - in - DeadType.addDeclaration ~config ~decls ~file - ~modulePath ~typeId:typeDeclaration.typ_id - ~typeKind:typeDeclaration.typ_type.type_kind - ~manifestTypePath); - None - | Tstr_include {incl_mod; incl_type} -> - (match incl_mod.mod_desc with - | Tmod_ident (_path, _lid) -> - let currentPath = - modulePath.path @ [FileContext.module_name_tagged file] - in - incl_type - |> List.iter - (processSignatureItem ~config ~decls ~file ~doTypes - ~doValues:false (* TODO: also values? *) - ~moduleLoc:incl_mod.mod_loc ~modulePath - ~path:currentPath) - | _ -> ()); - None - | Tstr_exception {ext_id = id; ext_loc = loc} -> - let path = - modulePath.path @ [FileContext.module_name_tagged file] - in - let name = id |> Ident.name |> Name.create in - ignore - (DeadException.add ~config ~decls ~file ~path ~loc - ~strLoc:structureItem.str_loc ~moduleLoc:modulePath.loc - name); - None - | _ -> None - in - let mapper_for_item = - match modulePath_for_item_opt with - | None -> mapper - | Some modulePath_for_item -> - create_mapper last_binding modulePath_for_item - in - super.structure_item mapper_for_item structureItem); - value_binding = - (fun _self vb -> - let loc = - vb - |> collectValueBinding ~config ~decls ~file - ~current_binding:last_binding ~modulePath - in - let nested_mapper = create_mapper loc modulePath in - super.Tast_mapper.value_binding nested_mapper vb); - } - in - mapper - in - let mapper = create_mapper Location.none ModulePath.initial in - mapper.structure mapper structure |> ignore - -(* Merge a location's references to another one's *) -let processValueDependency ~config ~decls ~refs ~file_deps ~cross_file - ( ({ - val_loc = - {loc_start = {pos_fname = fnTo} as posTo; loc_ghost = ghost1} as - locTo; - } : - Types.value_description), - ({ - val_loc = - {loc_start = {pos_fname = fnFrom} as posFrom; loc_ghost = ghost2} as - locFrom; - } : - Types.value_description) ) = - if (not ghost1) && (not ghost2) && posTo <> posFrom then ( - let addFileReference = fileIsImplementationOf fnTo fnFrom in - addValueReference ~config ~refs ~file_deps ~binding:Location.none - ~addFileReference ~locFrom ~locTo; - DeadOptionalArgs.addFunctionReference ~config ~decls ~cross_file ~locFrom - ~locTo) - -let processStructure ~config ~decls ~refs ~file_deps ~cross_file ~file - ~cmt_value_dependencies ~doTypes ~doExternals - (structure : Typedtree.structure) = - traverseStructure ~config ~decls ~refs ~file_deps ~cross_file ~file ~doTypes - ~doExternals structure; - let valueDependencies = cmt_value_dependencies |> List.rev in - valueDependencies - |> List.iter - (processValueDependency ~config ~decls ~refs ~file_deps ~cross_file) diff --git a/analysis/reanalyze/src/EmitJson.ml b/analysis/reanalyze/src/EmitJson.ml deleted file mode 100644 index 6a636bc8c07..00000000000 --- a/analysis/reanalyze/src/EmitJson.ml +++ /dev/null @@ -1,30 +0,0 @@ -let items = ref 0 -let start () = - items := 0; - Printf.printf "[" -let finish () = Printf.printf "\n]\n" -let emitClose () = "\n}" -let jsonString text = Yojson.Safe.to_string (`String text) - -let emitItem ~ppf ~name ~kind ~file ~range ~message = - let open Format in - items := !items + 1; - let startLine, startCharacter, endLine, endCharacter = range in - fprintf ppf "%s{\n" (if !items = 1 then "\n" else ",\n"); - fprintf ppf " \"name\": %s,\n" (jsonString name); - fprintf ppf " \"kind\": %s,\n" (jsonString kind); - fprintf ppf " \"file\": %s,\n" (jsonString file); - fprintf ppf " \"range\": [%d,%d,%d,%d],\n" startLine startCharacter endLine - endCharacter; - fprintf ppf " \"message\": %s" (jsonString message) - -let locToPos (loc : Location.t) = - (loc.loc_start.pos_lnum - 1, loc.loc_start.pos_cnum - loc.loc_start.pos_bol) - -let emitAnnotate ~pos ~text ~action = - let line, character = pos in - Format.asprintf - ",\n\ - \ \"annotate\": { \"line\": %d, \"character\": %d, \"text\": %s, \ - \"action\": %s}" - line character (jsonString text) (jsonString action) diff --git a/analysis/reanalyze/src/Exception.ml b/analysis/reanalyze/src/Exception.ml deleted file mode 100644 index 0cd48824b09..00000000000 --- a/analysis/reanalyze/src/Exception.ml +++ /dev/null @@ -1,577 +0,0 @@ -open DeadCommon - -type values_builder = (Name.t, Exceptions.t) Hashtbl.t -(** Per-file mutable builder for exception values during AST processing *) - -type values_table = (string, (Name.t, Exceptions.t) Hashtbl.t) Hashtbl.t -(** Merged immutable table for cross-file lookups *) - -let create_values_builder () : values_builder = Hashtbl.create 15 - -let values_builder_add (builder : values_builder) ~modulePath ~name exceptions = - let path = (name |> Name.create) :: modulePath.ModulePath.path in - Hashtbl.replace builder (path |> DcePath.toName) exceptions - -(** Merge all per-file builders into a single lookup table *) -let merge_values_builders (builders : (string * values_builder) list) : - values_table = - let table = Hashtbl.create 15 in - builders - |> List.iter (fun (moduleName, builder) -> - Hashtbl.replace table moduleName builder); - table - -module Values = struct - let getFromModule (table : values_table) ~moduleName ~modulePath - (path_ : DcePath.t) = - let name = path_ @ modulePath |> DcePath.toName in - match Hashtbl.find_opt table (String.capitalize_ascii moduleName) with - | Some tbl -> Hashtbl.find_opt tbl name - | None -> ( - match Hashtbl.find_opt table (String.uncapitalize_ascii moduleName) with - | Some tbl -> Hashtbl.find_opt tbl name - | None -> None) - - let rec findLocal (table : values_table) ~moduleName ~modulePath path = - match path |> getFromModule table ~moduleName ~modulePath with - | Some exceptions -> Some exceptions - | None -> ( - match modulePath with - | [] -> None - | _ :: restModulePath -> - path |> findLocal table ~moduleName ~modulePath:restModulePath) - - let findPath (table : values_table) ~moduleName ~modulePath path = - let findExternal ~externalModuleName ~pathRev = - pathRev |> List.rev - |> getFromModule table - ~moduleName:(externalModuleName |> Name.toString) - ~modulePath:[] - in - match path |> findLocal table ~moduleName ~modulePath with - | None -> ( - (* Search in another file *) - match path |> List.rev with - | externalModuleName :: pathRev -> ( - match (findExternal ~externalModuleName ~pathRev, pathRev) with - | (Some _ as found), _ -> found - | None, externalModuleName2 :: pathRev2 - when !Cli.cmtCommand && pathRev2 <> [] -> - (* Simplistic namespace resolution for dune namespace: skip the root of the path *) - findExternal ~externalModuleName:externalModuleName2 ~pathRev:pathRev2 - | None, _ -> None) - | [] -> None) - | Some exceptions -> Some exceptions -end - -module Event = struct - type kind = - | Catches of t list (* with | E => ... *) - | Call of {callee: DcePath.t; modulePath: DcePath.t} (* foo() *) - | DoesNotThrow of - t list (* DoesNotThrow(events) where events come from an expression *) - | Throws (** throw E *) - - and t = {exceptions: Exceptions.t; kind: kind; loc: Location.t} - - let rec print ppf event = - match event with - | {kind = Call {callee; modulePath}; exceptions; loc} -> - Format.fprintf ppf "%s Call(%s, modulePath:%s) %a@." - (loc.loc_start |> Pos.toString) - (callee |> DcePath.toString) - (modulePath |> DcePath.toString) - (Exceptions.pp ~exnTable:None) - exceptions - | {kind = DoesNotThrow nestedEvents; loc} -> - Format.fprintf ppf "%s DoesNotThrow(%a)@." - (loc.loc_start |> Pos.toString) - (fun ppf () -> - nestedEvents |> List.iter (fun e -> Format.fprintf ppf "%a " print e)) - () - | {kind = Throws; exceptions; loc} -> - Format.fprintf ppf "%s throws %a@." - (loc.loc_start |> Pos.toString) - (Exceptions.pp ~exnTable:None) - exceptions - | {kind = Catches nestedEvents; exceptions; loc} -> - Format.fprintf ppf "%s Catches exceptions:%a nestedEvents:%a@." - (loc.loc_start |> Pos.toString) - (Exceptions.pp ~exnTable:None) - exceptions - (fun ppf () -> - nestedEvents |> List.iter (fun e -> Format.fprintf ppf "%a " print e)) - () - - let combine ~(values_table : values_table) ~config ~moduleName events = - if config.DceConfig.cli.debug then ( - Log_.item "@."; - Log_.item "Events combine: #events %d@." (events |> List.length)); - let exnTable = Hashtbl.create 1 in - let extendExnTable exn loc = - match Hashtbl.find_opt exnTable exn with - | Some locSet -> Hashtbl.replace exnTable exn (LocSet.add loc locSet) - | None -> Hashtbl.replace exnTable exn (LocSet.add loc LocSet.empty) - in - let shrinkExnTable exn loc = - match Hashtbl.find_opt exnTable exn with - | Some locSet -> Hashtbl.replace exnTable exn (LocSet.remove loc locSet) - | None -> () - in - let rec loop exnSet events = - match events with - | ({kind = Throws; exceptions; loc} as ev) :: rest -> - if config.DceConfig.cli.debug then Log_.item "%a@." print ev; - exceptions |> Exceptions.iter (fun exn -> extendExnTable exn loc); - loop (Exceptions.union exnSet exceptions) rest - | ({kind = Call {callee; modulePath}; loc} as ev) :: rest -> - if config.DceConfig.cli.debug then Log_.item "%a@." print ev; - let exceptions = - match - callee |> Values.findPath values_table ~moduleName ~modulePath - with - | Some exceptions -> exceptions - | _ -> ( - match ExnLib.find callee with - | Some exceptions -> exceptions - | None -> Exceptions.empty) - in - exceptions |> Exceptions.iter (fun exn -> extendExnTable exn loc); - loop (Exceptions.union exnSet exceptions) rest - | ({kind = DoesNotThrow nestedEvents; loc} as ev) :: rest -> - if config.DceConfig.cli.debug then Log_.item "%a@." print ev; - let nestedExceptions = loop Exceptions.empty nestedEvents in - (if Exceptions.isEmpty nestedExceptions (* catch-all *) then - let name = - match nestedEvents with - | {kind = Call {callee}} :: _ -> callee |> DcePath.toName - | _ -> "expression" |> Name.create - in - Log_.warning ~loc - (Issue.ExceptionAnalysis - { - message = - Format.asprintf - "@{%s@} does not throw and is annotated with \ - redundant @doesNotThrow" - (name |> Name.toString); - })); - loop exnSet rest - | ({kind = Catches nestedEvents; exceptions} as ev) :: rest -> - if config.DceConfig.cli.debug then Log_.item "%a@." print ev; - if Exceptions.isEmpty exceptions then loop exnSet rest - else - let nestedExceptions = loop Exceptions.empty nestedEvents in - let newThrows = Exceptions.diff nestedExceptions exceptions in - exceptions - |> Exceptions.iter (fun exn -> - nestedEvents - |> List.iter (fun event -> shrinkExnTable exn event.loc)); - loop (Exceptions.union exnSet newThrows) rest - | [] -> exnSet - in - let exnSet = loop Exceptions.empty events in - (exnSet, exnTable) -end - -type checks_builder = check list ref -(** Per-file mutable builder for checks during AST processing *) - -and check = { - events: Event.t list; - loc: Location.t; - locFull: Location.t; - moduleName: string; - exnName: string; - exceptions: Exceptions.t; -} - -let create_checks_builder () : checks_builder = ref [] - -let checks_builder_add (builder : checks_builder) ~events ~exceptions ~loc - ?(locFull = loc) ~moduleName exnName = - builder := {events; exceptions; loc; locFull; moduleName; exnName} :: !builder - -let checks_builder_to_list (builder : checks_builder) : check list = - !builder |> List.rev - -module Checks = struct - let doCheck ~(values_table : values_table) ~config - {events; exceptions; loc; locFull; moduleName; exnName} = - let throwSet, exnTable = - events |> Event.combine ~values_table ~config ~moduleName - in - let missingAnnotations = Exceptions.diff throwSet exceptions in - let redundantAnnotations = Exceptions.diff exceptions throwSet in - (if not (Exceptions.isEmpty missingAnnotations) then - let description = - Issue.ExceptionAnalysisMissing - {exnName; exnTable; throwSet; missingAnnotations; locFull} - in - Log_.warning ~loc description); - if not (Exceptions.isEmpty redundantAnnotations) then - Log_.warning ~loc - (Issue.ExceptionAnalysis - { - message = - (let throwsDescription ppf () = - if throwSet |> Exceptions.isEmpty then - Format.fprintf ppf "throws nothing" - else - Format.fprintf ppf "might throw %a" - (Exceptions.pp ~exnTable:(Some exnTable)) - throwSet - in - Format.asprintf - "@{%s@} %a and is annotated with redundant @throws(%a)" - exnName throwsDescription () - (Exceptions.pp ~exnTable:None) - redundantAnnotations); - }) - - let doChecks ~values_table ~config (checks : check list) = - checks |> List.iter (doCheck ~values_table ~config) -end - -let traverseAst ~file ~values_builder ~checks_builder () = - let super = Tast_mapper.default in - let currentId = ref "" in - let currentEvents = ref [] in - (* For local lookups during AST processing, we look up in the current file's builder *) - let findLocalExceptions ~modulePath path = - let name = path @ modulePath |> DcePath.toName in - Hashtbl.find_opt values_builder name - in - let rec findLocalPath ~modulePath path = - match path |> findLocalExceptions ~modulePath with - | Some exceptions -> Some exceptions - | None -> ( - match modulePath with - | [] -> None - | _ :: restModulePath -> path |> findLocalPath ~modulePath:restModulePath) - in - let exceptionsOfPatterns patterns = - patterns - |> List.fold_left - (fun acc desc -> - match desc with - | Typedtree.Tpat_construct ({txt}, _, _) -> - Exceptions.add (Exn.fromLid txt) acc - | _ -> acc) - Exceptions.empty - in - let iterExpr self e = self.Tast_mapper.expr self e |> ignore in - let iterExprOpt self eo = - match eo with - | None -> () - | Some e -> e |> iterExpr self - in - let iterPat self p = self.Tast_mapper.pat self p |> ignore in - let iterCases self cases = - cases - |> List.iter (fun case -> - case.Typedtree.c_lhs |> iterPat self; - case.c_guard |> iterExprOpt self; - case.c_rhs |> iterExpr self) - in - let isThrow s = s = "Pervasives.raise" || s = "Pervasives.throw" in - let throwArgs args = - match args with - | [(_, Some {Typedtree.exp_desc = Texp_construct ({txt}, _, _)})] -> - [Exn.fromLid txt] |> Exceptions.fromList - | [(_, Some {Typedtree.exp_desc = Texp_ident _})] -> - [Exn.fromString "genericException"] |> Exceptions.fromList - | _ -> [Exn.fromString "TODO_from_raise1"] |> Exceptions.fromList - in - let doesNotThrow attributes = - attributes - |> Annotation.getAttributePayload (function - | "doesNotRaise" | "doesnotraise" | "DoesNoRaise" | "doesNotraise" - | "doNotRaise" | "donotraise" | "DoNoRaise" | "doNotraise" - | "doesNotThrow" | "doesnotthrow" | "DoesNoThrow" | "doesNotthrow" - | "doNotThrow" | "donotthrow" | "DoNoThrow" | "doNotthrow" -> - true - | _ -> false) - <> None - in - let expr ~(modulePath : ModulePath.t) (self : Tast_mapper.mapper) - (expr : Typedtree.expression) = - let loc = expr.exp_loc in - let isDoesNoThrow = expr.exp_attributes |> doesNotThrow in - let oldEvents = !currentEvents in - if isDoesNoThrow then currentEvents := []; - (match expr.exp_desc with - | Texp_ident (callee_, _, _) -> - let callee = - callee_ |> DcePath.fromPathT |> ModulePath.resolveAlias modulePath - in - let calleeName = callee |> DcePath.toName in - if calleeName |> Name.toString |> isThrow then - Log_.warning ~loc - (Issue.ExceptionAnalysis - { - message = - Format.asprintf - "@{%s@} can be analyzed only if called directly" - (calleeName |> Name.toString); - }); - currentEvents := - { - Event.exceptions = Exceptions.empty; - loc; - kind = Call {callee; modulePath = modulePath.path}; - } - :: !currentEvents - | Texp_apply - { - funct = {exp_desc = Texp_ident (atat, _, _)}; - args = [(_lbl1, Some {exp_desc = Texp_ident (callee, _, _)}); arg]; - } - when (* raise @@ Exn(...) *) - atat |> Path.name = "Pervasives.@@" && callee |> Path.name |> isThrow - -> - let exceptions = [arg] |> throwArgs in - currentEvents := {Event.exceptions; loc; kind = Throws} :: !currentEvents; - arg |> snd |> iterExprOpt self - | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)} as e; args} -> - let calleeName = Path.name callee in - if calleeName |> isThrow then - let exceptions = args |> throwArgs in - currentEvents := - {Event.exceptions; loc; kind = Throws} :: !currentEvents - else e |> iterExpr self; - args |> List.iter (fun (_, eOpt) -> eOpt |> iterExprOpt self) - | Texp_match (e, casesOk, casesExn, partial) -> - let cases = casesOk @ casesExn in - let exceptionPatterns = - casesExn - |> List.map (fun (case : Typedtree.case) -> case.c_lhs.pat_desc) - in - let exceptions = exceptionPatterns |> exceptionsOfPatterns in - if exceptionPatterns <> [] then ( - let oldEvents = !currentEvents in - currentEvents := []; - e |> iterExpr self; - currentEvents := - {Event.exceptions; loc; kind = Catches !currentEvents} :: oldEvents) - else e |> iterExpr self; - cases |> iterCases self; - if partial = Partial then - currentEvents := - { - Event.exceptions = [Exn.matchFailure] |> Exceptions.fromList; - loc; - kind = Throws; - } - :: !currentEvents - | Texp_try (e, cases) -> - let exceptions = - cases - |> List.map (fun case -> case.Typedtree.c_lhs.pat_desc) - |> exceptionsOfPatterns - in - let oldEvents = !currentEvents in - currentEvents := []; - e |> iterExpr self; - currentEvents := - {Event.exceptions; loc; kind = Catches !currentEvents} :: oldEvents; - cases |> iterCases self - | _ -> super.expr self expr |> ignore); - (if isDoesNoThrow then - let nestedEvents = !currentEvents in - currentEvents := - { - Event.exceptions = Exceptions.empty; - loc; - kind = DoesNotThrow nestedEvents; - } - :: oldEvents); - expr - in - let getExceptionsFromAnnotations attributes = - let throwsAnnotationPayload = - attributes - |> Annotation.getAttributePayload (fun s -> - s = "throws" || s = "throw" || s = "raises" || s = "raise") - in - let rec getExceptions payload = - match payload with - | Annotation.StringPayload s -> [Exn.fromString s] |> Exceptions.fromList - | Annotation.ConstructPayload s when s <> "::" -> - [Exn.fromString s] |> Exceptions.fromList - | Annotation.IdentPayload s -> - [Exn.fromString (s |> Longident.flatten |> String.concat ".")] - |> Exceptions.fromList - | Annotation.TuplePayload tuple -> - tuple - |> List.map (fun payload -> - payload |> getExceptions |> Exceptions.toList) - |> List.concat |> Exceptions.fromList - | _ -> Exceptions.empty - in - match throwsAnnotationPayload with - | None -> Exceptions.empty - | Some payload -> payload |> getExceptions - in - let toplevelEval (self : Tast_mapper.mapper) (expr : Typedtree.expression) - attributes = - let oldId = !currentId in - let oldEvents = !currentEvents in - let name = "Toplevel expression" in - currentId := name; - currentEvents := []; - let moduleName = file.FileContext.module_name in - self.expr self expr |> ignore; - checks_builder_add checks_builder ~events:!currentEvents - ~exceptions:(getExceptionsFromAnnotations attributes) - ~loc:expr.exp_loc ~moduleName name; - currentId := oldId; - currentEvents := oldEvents - in - let value_binding ~(modulePath : ModulePath.t) (self : Tast_mapper.mapper) - (vb : Typedtree.value_binding) = - let oldId = !currentId in - let oldEvents = !currentEvents in - let isFunction = - match vb.vb_expr.exp_desc with - | Texp_function _ -> true - | _ -> false - in - let isToplevel = !currentId = "" in - let processBinding name = - currentId := name; - currentEvents := []; - let exceptionsFromAnnotations = - getExceptionsFromAnnotations vb.vb_attributes - in - values_builder_add values_builder ~modulePath ~name - exceptionsFromAnnotations; - let res = super.value_binding self vb in - let moduleName = file.FileContext.module_name in - let path = [name |> Name.create] in - let exceptions = - match path |> findLocalPath ~modulePath:modulePath.path with - | Some exceptions -> exceptions - | _ -> Exceptions.empty - in - checks_builder_add checks_builder ~events:!currentEvents ~exceptions - ~loc:vb.vb_pat.pat_loc ~locFull:vb.vb_loc ~moduleName name; - currentId := oldId; - currentEvents := oldEvents; - res - in - match vb.vb_pat.pat_desc with - | Tpat_any when isToplevel && not vb.vb_loc.loc_ghost -> processBinding "_" - | Tpat_construct ({txt}, _, _) - when isToplevel && (not vb.vb_loc.loc_ghost) - && txt = Longident.Lident "()" -> - processBinding "()" - | Tpat_var (id, {loc = {loc_ghost}}) - when (isFunction || isToplevel) && (not loc_ghost) - && not vb.vb_loc.loc_ghost -> - processBinding (id |> Ident.name) - | _ -> super.value_binding self vb - in - let make_mapper (modulePath : ModulePath.t) : Tast_mapper.mapper = - let open Tast_mapper in - { - super with - expr = expr ~modulePath; - value_binding = value_binding ~modulePath; - } - in - let rec process_module_expr (modulePath : ModulePath.t) - (me : Typedtree.module_expr) = - match me.mod_desc with - | Tmod_structure structure -> process_structure modulePath structure - | Tmod_constraint (me1, _mty, _mtc, _coercion) -> - process_module_expr modulePath me1 - | Tmod_apply (me1, me2, _) -> - process_module_expr modulePath me1; - process_module_expr modulePath me2 - | _ -> - let mapper = make_mapper modulePath in - super.module_expr mapper me |> ignore - and process_structure (modulePath : ModulePath.t) - (structure : Typedtree.structure) = - let rec loop (mp : ModulePath.t) (items : Typedtree.structure_item list) = - match items with - | [] -> () - | structureItem :: rest -> - let mapper = make_mapper mp in - let mp' = - match structureItem.str_desc with - | Tstr_eval (expr, attributes) -> - toplevelEval mapper expr attributes; - mp - | Tstr_module {mb_id; mb_loc; mb_expr} -> ( - let name = mb_id |> Ident.name |> Name.create in - let mp_inside = ModulePath.enterModule mp ~name ~loc:mb_loc in - process_module_expr mp_inside mb_expr; - match mb_expr.mod_desc with - | Tmod_ident (path_, _lid) -> - ModulePath.addAlias mp ~name ~path:(path_ |> DcePath.fromPathT) - | _ -> mp) - | Tstr_recmodule mbs -> - (* Process each module in the recursive group in the current scope; aliases are collected in the current scope too. *) - List.fold_left - (fun acc {Typedtree.mb_id; mb_loc; mb_expr} -> - let name = mb_id |> Ident.name |> Name.create in - let mp_inside = ModulePath.enterModule acc ~name ~loc:mb_loc in - process_module_expr mp_inside mb_expr; - match mb_expr.mod_desc with - | Tmod_ident (path_, _lid) -> - ModulePath.addAlias acc ~name - ~path:(path_ |> DcePath.fromPathT) - | _ -> acc) - mp mbs - | _ -> - super.structure_item mapper structureItem |> ignore; - mp - in - loop mp' rest - in - loop modulePath structure.str_items - in - fun (structure : Typedtree.structure) -> - process_structure ModulePath.initial structure - -type file_result = { - module_name: string; - values_builder: values_builder; - checks: check list; -} -(** Result of processing a single file *) - -let processStructure ~file ~values_builder ~checks_builder - (structure : Typedtree.structure) = - let process = traverseAst ~file ~values_builder ~checks_builder () in - process structure - -let processCmt ~file (cmt_infos : Cmt_format.cmt_infos) : file_result option = - match cmt_infos.cmt_annots with - | Interface _ -> None - | Implementation structure -> - let values_builder = create_values_builder () in - let checks_builder = create_checks_builder () in - structure |> processStructure ~file ~values_builder ~checks_builder; - Some - { - module_name = file.FileContext.module_name; - values_builder; - checks = checks_builder_to_list checks_builder; - } - | _ -> None - -(** Process all accumulated checks using merged values table *) -let runChecks ~config (all_results : file_result list) = - (* Merge all values builders *) - let values_table = - all_results - |> List.map (fun r -> (r.module_name, r.values_builder)) - |> merge_values_builders - in - (* Collect all checks *) - let all_checks = all_results |> List.concat_map (fun r -> r.checks) in - (* Run checks with merged table *) - Checks.doChecks ~values_table ~config all_checks diff --git a/analysis/reanalyze/src/Exceptions.ml b/analysis/reanalyze/src/Exceptions.ml deleted file mode 100644 index 91ae2000aa6..00000000000 --- a/analysis/reanalyze/src/Exceptions.ml +++ /dev/null @@ -1,36 +0,0 @@ -module ExnSet = Set.Make (Exn) - -type t = ExnSet.t - -let add = ExnSet.add -let diff = ExnSet.diff -let empty = ExnSet.empty -let fromList = ExnSet.of_list -let toList = ExnSet.elements -let isEmpty = ExnSet.is_empty -let iter = ExnSet.iter -let union = ExnSet.union - -let pp ~exnTable ppf exceptions = - let isFirst = ref true in - let ppExn exn = - let separator = if !isFirst then "" else ", " in - isFirst := false; - let name = Exn.toString exn in - match exnTable with - | Some exnTable -> ( - match Hashtbl.find_opt exnTable exn with - | Some locSet -> - let positions = - locSet |> LocSet.elements - |> List.map (fun loc -> loc.Location.loc_start) - in - Format.fprintf ppf "%s@{%s@} (@{%s@})" separator name - (positions |> List.map Pos.toString |> String.concat " ") - | None -> Format.fprintf ppf "%s@{%s@}" separator name) - | None -> Format.fprintf ppf "%s@{%s@}" separator name - in - let isList = exceptions |> ExnSet.cardinal > 1 in - if isList then Format.fprintf ppf "["; - exceptions |> ExnSet.iter ppExn; - if isList then Format.fprintf ppf "]" diff --git a/analysis/reanalyze/src/Exn.ml b/analysis/reanalyze/src/Exn.ml deleted file mode 100644 index 1970d035b12..00000000000 --- a/analysis/reanalyze/src/Exn.ml +++ /dev/null @@ -1,19 +0,0 @@ -type t = string - -let compare = String.compare -let decodeError = "DecodeError" -let assertFailure = "Assert_failure" -let divisionByZero = "Division_by_zero" -let endOfFile = "End_of_file" -let exit = "exit" -let failure = "Failure" -let invalidArgument = "Invalid_argument" -let jsExn = "JsExn" -let matchFailure = "Match_failure" -let notFound = "Not_found" -let sysError = "Sys_error" -let fromLid lid = lid |> Longident.flatten |> String.concat "." -let fromString s = s -let toString s = s -let yojsonJsonError = "Yojson.Json_error" -let yojsonTypeError = "Yojson.Basic.Util.Type_error" diff --git a/analysis/reanalyze/src/Exn.mli b/analysis/reanalyze/src/Exn.mli deleted file mode 100644 index c9c991847d8..00000000000 --- a/analysis/reanalyze/src/Exn.mli +++ /dev/null @@ -1,19 +0,0 @@ -type t - -val compare : t -> t -> int -val assertFailure : t -val decodeError : t -val divisionByZero : t -val endOfFile : t -val exit : t -val failure : t -val fromLid : Longident.t -> t -val fromString : string -> t -val invalidArgument : t -val jsExn : t -val matchFailure : t -val notFound : t -val sysError : t -val toString : t -> string -val yojsonJsonError : t -val yojsonTypeError : t diff --git a/analysis/reanalyze/src/ExnLib.ml b/analysis/reanalyze/src/ExnLib.ml deleted file mode 100644 index 1104661b715..00000000000 --- a/analysis/reanalyze/src/ExnLib.ml +++ /dev/null @@ -1,244 +0,0 @@ -let raisesLibTable : (Name.t, Exceptions.t) Hashtbl.t = - let table = Hashtbl.create 15 in - let open Exn in - let beltArray = - [ - ("getExn", [assertFailure]); - ("getOrThrow", [assertFailure]); - ("setExn", [assertFailure]); - ("setOrThrow", [assertFailure]); - ] - in - let beltList = - [ - ("getExn", [notFound]); - ("getOrThrow", [notFound]); - ("headExn", [notFound]); - ("headOrThrow", [notFound]); - ("tailExn", [notFound]); - ("tailOrThrow", [notFound]); - ] - in - let beltMap = [("getExn", [notFound]); ("getOrThrow", [notFound])] in - let beltMutableMap = beltMap in - let beltMutableQueue = - [ - ("peekExn", [notFound]); - ("peekOrThrow", [notFound]); - ("popExn", [notFound]); - ("popOrThrow", [notFound]); - ] - in - let beltSet = [("getExn", [notFound]); ("getOrThrow", [notFound])] in - let beltMutableSet = beltSet in - let beltOption = [("getExn", [notFound]); ("getOrThrow", [notFound])] in - let beltResult = [("getExn", [notFound]); ("getOrThrow", [notFound])] in - let bsJson = - (* bs-json *) - [ - ("bool", [decodeError]); - ("float", [decodeError]); - ("int", [decodeError]); - ("string", [decodeError]); - ("char", [decodeError]); - ("date", [decodeError]); - ("nullable", [decodeError]); - ("nullAs", [decodeError]); - ("array", [decodeError]); - ("list", [decodeError]); - ("pair", [decodeError]); - ("tuple2", [decodeError]); - ("tuple3", [decodeError]); - ("tuple4", [decodeError]); - ("dict", [decodeError]); - ("field", [decodeError]); - ("at", [decodeError; invalidArgument]); - ("oneOf", [decodeError]); - ("either", [decodeError]); - ] - in - let stdlib = - [ - ("panic", [jsExn]); - ("assertEqual", [jsExn]); - ("invalid_arg", [invalidArgument]); - ("failwith", [failure]); - ("/", [divisionByZero]); - ("mod", [divisionByZero]); - ("char_of_int", [invalidArgument]); - ("bool_of_string", [invalidArgument]); - ("int_of_string", [failure]); - ("float_of_string", [failure]); - ] - in - let stdlibBigInt = - [ - ("fromStringExn", [jsExn]); - ("fromStringOrThrow", [jsExn]); - ("fromFloatOrThrow", [jsExn]); - ] - in - let stdlibBool = - [ - ("fromStringExn", [invalidArgument]); - ("fromStringOrThrow", [invalidArgument]); - ] - in - let stdlibJsError = - [ - ("EvalError.throwWithMessage", [jsExn]); - ("RangeError.throwWithMessage", [jsExn]); - ("ReferenceError.throwWithMessage", [jsExn]); - ("SyntaxError.throwWithMessage", [jsExn]); - ("TypeError.throwWithMessage", [jsExn]); - ("URIError.throwWithMessage", [jsExn]); - ("panic", [jsExn]); - ("throw", [jsExn]); - ("throwWithMessage", [jsExn]); - ] - in - let stdlibError = - [("raise", [jsExn]); ("panic", [jsExn]); ("throw", [jsExn])] - in - let stdlibExn = - [ - ("raiseError", [jsExn]); - ("raiseEvalError", [jsExn]); - ("raiseRangeError", [jsExn]); - ("raiseReferenceError", [jsExn]); - ("raiseSyntaxError", [jsExn]); - ("raiseTypeError", [jsExn]); - ("raiseUriError", [jsExn]); - ] - in - let stdlibJson = - [ - ("parseExn", [jsExn]); - ("parseExnWithReviver", [jsExn]); - ("parseOrThrow", [jsExn]); - ("stringifyAny", [jsExn]); - ("stringifyAnyWithIndent", [jsExn]); - ("stringifyAnyWithReplacer", [jsExn]); - ("stringifyAnyWithReplacerAndIndent", [jsExn]); - ("stringifyAnyWithFilter", [jsExn]); - ("stringifyAnyWithFilterAndIndent", [jsExn]); - ] - in - let stdlibList = - [("headExn", [notFound]); ("tailExn", [notFound]); ("getExn", [notFound])] - in - let stdlibNull = [("getExn", [invalidArgument])] in - let stdlibNullable = [("getExn", [invalidArgument])] in - let stdlibOption = [("getExn", [jsExn])] in - let stdlibResult = [("getExn", [notFound])] in - let yojsonBasic = [("from_string", [yojsonJsonError])] in - let yojsonBasicUtil = - [ - ("member", [yojsonTypeError]); - ("to_assoc", [yojsonTypeError]); - ("to_bool", [yojsonTypeError]); - ("to_bool_option", [yojsonTypeError]); - ("to_float", [yojsonTypeError]); - ("to_float_option", [yojsonTypeError]); - ("to_int", [yojsonTypeError]); - ("to_list", [yojsonTypeError]); - ("to_number", [yojsonTypeError]); - ("to_number_option", [yojsonTypeError]); - ("to_string", [yojsonTypeError]); - ("to_string_option", [yojsonTypeError]); - ] - in - [ - ("Belt.Array", beltArray); - ("Belt_Array", beltArray); - ("Belt.List", beltList); - ("Belt_List", beltList); - ("Belt.Map", beltMap); - ("Belt.Map.Int", beltMap); - ("Belt.Map.String", beltMap); - ("Belt_Map", beltMap); - ("Belt_Map.Int", beltMap); - ("Belt_Map.String", beltMap); - ("Belt_MapInt", beltMap); - ("Belt_MapString", beltMap); - ("Belt.MutableMap", beltMutableMap); - ("Belt.MutableMap.Int", beltMutableMap); - ("Belt.MutableMap.String", beltMutableMap); - ("Belt_MutableMap", beltMutableMap); - ("Belt_MutableMap.Int", beltMutableMap); - ("Belt_MutableMap.String", beltMutableMap); - ("Belt_MutableMapInt", beltMutableMap); - ("Belt_MutableMapString", beltMutableMap); - ("Belt.MutableQueue", beltMutableQueue); - ("Belt_MutableQueue", beltMutableQueue); - ("Belt_MutableSetInt", beltMutableSet); - ("Belt_MutableSetString", beltMutableSet); - ("Belt.MutableSet", beltMutableSet); - ("Belt.MutableSet.Int", beltMutableSet); - ("Belt.MutableSet.String", beltMutableSet); - ("Belt.Option", beltOption); - ("Belt_Option", beltOption); - ("Belt.Result", beltResult); - ("Belt_Result", beltResult); - ("Belt.Set", beltSet); - ("Belt.Set.Int", beltSet); - ("Belt.Set.String", beltSet); - ("Belt_Set", beltSet); - ("Belt_Set.Int", beltSet); - ("Belt_Set.String", beltSet); - ("Belt_SetInt", beltSet); - ("Belt_SetString", beltSet); - ("BigInt", stdlibBigInt); - ("Bool", stdlibBool); - ("Error", stdlibError); - ("Exn", stdlibExn); - ("JsError", stdlibJsError); - ("Js.Json", [("parseExn", [jsExn])]); - ("JSON", stdlibJson); - ("Json_decode", bsJson); - ("Json.Decode", bsJson); - ("List", stdlibList); - ("MutableSet", beltMutableSet); - ("MutableSet.Int", beltMutableSet); - ("MutableSet.String", beltMutableSet); - ("Null", stdlibNull); - ("Nullable", stdlibNullable); - ("Option", stdlibOption); - ("Pervasives", stdlib); - ("Result", stdlibResult); - ("Stdlib", stdlib); - ("Stdlib_BigInt", stdlibBigInt); - ("Stdlib.BigInt", stdlibBigInt); - ("Stdlib_Bool", stdlibBool); - ("Stdlib.Bool", stdlibBool); - ("Stdlib_Error", stdlibError); - ("Stdlib.Error", stdlibError); - ("Stdlib_Exn", stdlibExn); - ("Stdlib.Exn", stdlibExn); - ("Stdlib_JsError", stdlibJsError); - ("Stdlib.JsError", stdlibJsError); - ("Stdlib_JSON", stdlibJson); - ("Stdlib.JSON", stdlibJson); - ("Stdlib_List", stdlibList); - ("Stdlib.List", stdlibList); - ("Stdlib_Null", stdlibNull); - ("Stdlib.Null", stdlibNull); - ("Stdlib_Nullable", stdlibNullable); - ("Stdlib.Nullable", stdlibNullable); - ("Stdlib_Option", stdlibOption); - ("Stdlib.Option", stdlibOption); - ("Stdlib_Result", stdlibResult); - ("Stdlib.Result", stdlibResult); - ("Yojson.Basic", yojsonBasic); - ("Yojson.Basic.Util", yojsonBasicUtil); - ] - |> List.iter (fun (name, group) -> - group - |> List.iter (fun (s, e) -> - Hashtbl.add table - (name ^ "." ^ s |> Name.create) - (e |> Exceptions.fromList))); - table - -let find (path : DcePath.t) = - Hashtbl.find_opt raisesLibTable (path |> DcePath.toName) diff --git a/analysis/reanalyze/src/FileDeps.ml b/analysis/reanalyze/src/FileDeps.ml deleted file mode 100644 index ec83cb2896c..00000000000 --- a/analysis/reanalyze/src/FileDeps.ml +++ /dev/null @@ -1,153 +0,0 @@ -(** File dependencies collected during AST processing. - - Tracks which files reference which other files. *) - -(* File-keyed hashtable *) -module FileHash = Hashtbl.Make (struct - type t = string - - let hash (x : t) = Hashtbl.hash x - let equal (x : t) y = x = y -end) - -(** {2 Types} *) - -type t = { - files: FileSet.t; - deps: FileSet.t FileHash.t; (* from_file -> set of to_files *) -} - -type builder = {mutable files: FileSet.t; deps: FileSet.t FileHash.t} - -(** {2 Builder API} *) - -let create_builder () : builder = - {files = FileSet.empty; deps = FileHash.create 256} - -let add_file (b : builder) file = - b.files <- FileSet.add file b.files; - (* Ensure file has an entry even if no deps *) - if not (FileHash.mem b.deps file) then - FileHash.replace b.deps file FileSet.empty - -let add_dep (b : builder) ~from_file ~to_file = - let set = - match FileHash.find_opt b.deps from_file with - | Some s -> s - | None -> FileSet.empty - in - FileHash.replace b.deps from_file (FileSet.add to_file set) - -(** {2 Merge API} *) - -let merge_into_builder ~(from : builder) ~(into : builder) = - into.files <- FileSet.union into.files from.files; - FileHash.iter - (fun from_file to_files -> - let existing = - match FileHash.find_opt into.deps from_file with - | Some s -> s - | None -> FileSet.empty - in - FileHash.replace into.deps from_file (FileSet.union existing to_files)) - from.deps - -let freeze_builder (b : builder) : t = - (* This is a zero-copy operation, so it's "unsafe" if the builder is - subsequently mutated. However, the calling discipline is that the - builder is no longer used after freezing. *) - {files = b.files; deps = b.deps} - -let merge_all (builders : builder list) : t = - let merged_builder = create_builder () in - builders - |> List.iter (fun b -> merge_into_builder ~from:b ~into:merged_builder); - freeze_builder merged_builder - -(** {2 Builder extraction for reactive merge} *) - -let builder_files (builder : builder) : FileSet.t = builder.files - -let builder_deps_to_list (builder : builder) : (string * FileSet.t) list = - FileHash.fold - (fun from_file to_files acc -> (from_file, to_files) :: acc) - builder.deps [] - -let create ~files ~deps : t = {files; deps} - -(** {2 Read-only API} *) - -let get_files (t : t) = t.files - -let get_deps (t : t) file = - match FileHash.find_opt t.deps file with - | Some s -> s - | None -> FileSet.empty - -let iter_deps (t : t) f = FileHash.iter f t.deps - -let file_exists (t : t) file = FileHash.mem t.deps file - -let files_count (t : t) = FileSet.cardinal t.files - -let deps_count (t : t) = FileHash.length t.deps - -(** {2 Topological ordering} *) - -let iter_files_from_roots_to_leaves (t : t) iterFun = - (* For each file, the number of incoming references *) - let inverseReferences = (Hashtbl.create 256 : (string, int) Hashtbl.t) in - (* For each number of incoming references, the files *) - let referencesByNumber = (Hashtbl.create 256 : (int, FileSet.t) Hashtbl.t) in - let getNum fileName = - try Hashtbl.find inverseReferences fileName with Not_found -> 0 - in - let getSet num = - try Hashtbl.find referencesByNumber num with Not_found -> FileSet.empty - in - let addIncomingEdge fileName = - let oldNum = getNum fileName in - let newNum = oldNum + 1 in - let oldSetAtNum = getSet oldNum in - let newSetAtNum = FileSet.remove fileName oldSetAtNum in - let oldSetAtNewNum = getSet newNum in - let newSetAtNewNum = FileSet.add fileName oldSetAtNewNum in - Hashtbl.replace inverseReferences fileName newNum; - Hashtbl.replace referencesByNumber oldNum newSetAtNum; - Hashtbl.replace referencesByNumber newNum newSetAtNewNum - in - let removeIncomingEdge fileName = - let oldNum = getNum fileName in - let newNum = oldNum - 1 in - let oldSetAtNum = getSet oldNum in - let newSetAtNum = FileSet.remove fileName oldSetAtNum in - let oldSetAtNewNum = getSet newNum in - let newSetAtNewNum = FileSet.add fileName oldSetAtNewNum in - Hashtbl.replace inverseReferences fileName newNum; - Hashtbl.replace referencesByNumber oldNum newSetAtNum; - Hashtbl.replace referencesByNumber newNum newSetAtNewNum - in - let addEdge fromFile toFile = - if file_exists t fromFile then addIncomingEdge toFile - in - let removeEdge fromFile toFile = - if file_exists t fromFile then removeIncomingEdge toFile - in - iter_deps t (fun fromFile set -> - if getNum fromFile = 0 then - Hashtbl.replace referencesByNumber 0 (FileSet.add fromFile (getSet 0)); - set |> FileSet.iter (fun toFile -> addEdge fromFile toFile)); - while getSet 0 <> FileSet.empty do - let filesWithNoIncomingReferences = getSet 0 in - Hashtbl.remove referencesByNumber 0; - filesWithNoIncomingReferences - |> FileSet.iter (fun fileName -> - iterFun fileName; - let references = get_deps t fileName in - references |> FileSet.iter (fun toFile -> removeEdge fileName toFile)) - done; - (* Process any remaining items in case of circular references *) - referencesByNumber - |> Hashtbl.iter (fun _num set -> - if FileSet.is_empty set then () - else set |> FileSet.iter (fun fileName -> iterFun fileName)) diff --git a/analysis/reanalyze/src/Issues.ml b/analysis/reanalyze/src/Issues.ml deleted file mode 100644 index d1c1a3ca3f4..00000000000 --- a/analysis/reanalyze/src/Issues.ml +++ /dev/null @@ -1,14 +0,0 @@ -let errorHygiene = "Error Hygiene" -let errorNotImplemented = "Error Not Implemented" -let errorTermination = "Error Termination" -let exceptionAnalysis = "Exception Analysis" -let incorrectDeadAnnotation = "Incorrect Dead Annotation" -let terminationAnalysisInternal = "Termination Analysis Internal" -let warningDeadAnalysisCycle = "Warning Dead Analysis Cycle" -let warningDeadException = "Warning Dead Exception" -let warningDeadModule = "Warning Dead Module" -let warningDeadType = "Warning Dead Type" -let warningDeadValue = "Warning Dead Value" -let warningDeadValueWithSideEffects = "Warning Dead Value With Side Effects" -let warningRedundantOptionalArgument = "Warning Redundant Optional Argument" -let warningUnusedArgument = "Warning Unused Argument" diff --git a/analysis/reanalyze/src/ModulePath.ml b/analysis/reanalyze/src/ModulePath.ml deleted file mode 100644 index f32087d7fac..00000000000 --- a/analysis/reanalyze/src/ModulePath.ml +++ /dev/null @@ -1,32 +0,0 @@ -module NameMap = Map.Make (Name) - -(* Keep track of the module path while traversing with Tast_mapper *) -type t = {aliases: DcePath.t NameMap.t; loc: Location.t; path: DcePath.t} - -let initial = ({aliases = NameMap.empty; loc = Location.none; path = []} : t) - -let normalizePath ~aliases path = - match path |> List.rev with - | name :: restRev when restRev <> [] -> ( - match aliases |> NameMap.find_opt name with - | None -> path - | Some path1 -> - let newPath = List.rev (path1 @ restRev) in - if !Cli.debug then - Log_.item "Resolve Alias: %s to %s@." (path |> DcePath.toString) - (newPath |> DcePath.toString); - newPath) - | _ -> path - -let addAlias (t : t) ~name ~path : t = - let aliases = t.aliases in - let pathNormalized = path |> normalizePath ~aliases in - if !Cli.debug then - Log_.item "Module Alias: %s = %s@." (name |> Name.toString) - (DcePath.toString pathNormalized); - {t with aliases = NameMap.add name pathNormalized aliases} - -let resolveAlias (t : t) path = path |> normalizePath ~aliases:t.aliases - -let enterModule (t : t) ~(name : Name.t) ~(loc : Location.t) : t = - {t with loc; path = name :: t.path} diff --git a/analysis/reanalyze/src/Name.mli b/analysis/reanalyze/src/Name.mli deleted file mode 100644 index 3f515e3065d..00000000000 --- a/analysis/reanalyze/src/Name.mli +++ /dev/null @@ -1,9 +0,0 @@ -type t - -val compare : t -> t -> int -val create : ?isInterface:bool -> string -> t -val isUnderscore : t -> bool -val startsWithUnderscore : t -> bool -val toImplementation : t -> t -val toInterface : t -> t -val toString : t -> string diff --git a/analysis/reanalyze/src/OptionalArgs.ml b/analysis/reanalyze/src/OptionalArgs.ml deleted file mode 100644 index 1010075979e..00000000000 --- a/analysis/reanalyze/src/OptionalArgs.ml +++ /dev/null @@ -1,45 +0,0 @@ -(** Immutable record tracking optional argument usage. - - unused: args that have never been passed - - alwaysUsed: args that are always passed (when count > 0) - - count: number of calls observed *) - -module StringSet = Set.Make (String) - -type t = {count: int; unused: StringSet.t; alwaysUsed: StringSet.t} - -let empty = {unused = StringSet.empty; alwaysUsed = StringSet.empty; count = 0} - -let fromList l = - {unused = StringSet.of_list l; alwaysUsed = StringSet.empty; count = 0} - -let isEmpty x = StringSet.is_empty x.unused - -(** Apply a call to the optional args state. Returns new state. *) -let apply_call ~argNames ~argNamesMaybe x = - let nameSet = argNames |> StringSet.of_list in - let nameSetMaybe = argNamesMaybe |> StringSet.of_list in - let nameSetAlways = StringSet.diff nameSet nameSetMaybe in - let alwaysUsed = - if x.count = 0 then nameSetAlways - else StringSet.inter nameSetAlways x.alwaysUsed - in - let unused = - argNames - |> List.fold_left (fun acc name -> StringSet.remove name acc) x.unused - in - {count = x.count + 1; unused; alwaysUsed} - -(** Combine two optional args states (for function references). - Returns a pair of updated states with intersected unused/alwaysUsed. *) -let combine_pair x y = - let unused = StringSet.inter x.unused y.unused in - let alwaysUsed = StringSet.inter x.alwaysUsed y.alwaysUsed in - ({x with unused; alwaysUsed}, {y with unused; alwaysUsed}) - -let iterUnused f x = StringSet.iter f x.unused -let iterAlwaysUsed f x = StringSet.iter (fun s -> f s x.count) x.alwaysUsed - -let foldUnused f x init = StringSet.fold f x.unused init - -let foldAlwaysUsed f x init = - StringSet.fold (fun s acc -> f s x.count acc) x.alwaysUsed init diff --git a/analysis/reanalyze/src/OptionalArgsState.ml b/analysis/reanalyze/src/OptionalArgsState.ml deleted file mode 100644 index 66a0d0cee6c..00000000000 --- a/analysis/reanalyze/src/OptionalArgsState.ml +++ /dev/null @@ -1,10 +0,0 @@ -(** State map for computed OptionalArgs. - Maps declaration position to final state after all calls/combines. *) - -type t = OptionalArgs.t PosHash.t - -let create () : t = PosHash.create 256 - -let find_opt (state : t) pos = PosHash.find_opt state pos - -let set (state : t) pos value = PosHash.replace state pos value diff --git a/analysis/reanalyze/src/RunConfig.ml b/analysis/reanalyze/src/RunConfig.ml deleted file mode 100644 index b6b1d28008f..00000000000 --- a/analysis/reanalyze/src/RunConfig.ml +++ /dev/null @@ -1,62 +0,0 @@ -type t = { - mutable bsbProjectRoot: string; - mutable dce: bool; - mutable exception_: bool; - mutable projectRoot: string; - mutable suppress: string list; - mutable termination: bool; - mutable transitive: bool; - mutable unsuppress: string list; -} - -let runConfig = - { - bsbProjectRoot = ""; - dce = false; - exception_ = false; - projectRoot = ""; - suppress = []; - termination = false; - transitive = false; - unsuppress = []; - } - -let reset () = - runConfig.dce <- false; - runConfig.exception_ <- false; - runConfig.suppress <- []; - runConfig.termination <- false; - runConfig.transitive <- false; - runConfig.unsuppress <- [] - -let all () = - runConfig.dce <- true; - runConfig.exception_ <- true; - runConfig.termination <- true - -let dce () = runConfig.dce <- true -let exception_ () = runConfig.exception_ <- true -let termination () = runConfig.termination <- true - -let transitive b = runConfig.transitive <- b - -type snapshot = { - dce: bool; - exception_: bool; - suppress: string list; - termination: bool; - transitive: bool; - unsuppress: string list; -} - -let snapshot () = - { - dce = runConfig.dce; - exception_ = runConfig.exception_; - suppress = runConfig.suppress; - termination = runConfig.termination; - transitive = runConfig.transitive; - unsuppress = runConfig.unsuppress; - } - -let equal_snapshot (a : snapshot) (b : snapshot) = a = b diff --git a/analysis/reanalyze/src/SideEffects.ml b/analysis/reanalyze/src/SideEffects.ml deleted file mode 100644 index ab49b36ea9a..00000000000 --- a/analysis/reanalyze/src/SideEffects.ml +++ /dev/null @@ -1,87 +0,0 @@ -let whiteListSideEffects = - [ - "Pervasives./."; - "Pervasives.ref"; - "Int64.mul"; - "Int64.neg"; - "Int64.sub"; - "Int64.shift_left"; - "Int64.one"; - "String.length"; - ] - -let whiteTableSideEffects = - lazy - (let tbl = Hashtbl.create 11 in - whiteListSideEffects |> List.iter (fun s -> Hashtbl.add tbl s ()); - tbl) - -let pathIsWhitelistedForSideEffects path = - path - |> DcePath.onOkPath ~whenContainsApply:false ~f:(fun s -> - Hashtbl.mem (Lazy.force whiteTableSideEffects) s) - -let rec exprNoSideEffects (expr : Typedtree.expression) = - match expr.exp_desc with - | Texp_ident _ | Texp_constant _ -> true - | Texp_construct (_, _, el) -> el |> List.for_all exprNoSideEffects - | Texp_function _ -> true - (* Loop control changes whether subsequent code in the enclosing loop runs, - so it should not be treated as a removable pure expression. *) - | Texp_break | Texp_continue -> false - | Texp_apply {funct = {exp_desc = Texp_ident (path, _, _)}; args} - when path |> pathIsWhitelistedForSideEffects -> - args |> List.for_all (fun (_, eo) -> eo |> exprOptNoSideEffects) - | Texp_apply _ -> false - | Texp_sequence (e1, e2) -> e1 |> exprNoSideEffects && e2 |> exprNoSideEffects - | Texp_let (_, vbs, e) -> - vbs - |> List.for_all (fun (vb : Typedtree.value_binding) -> - vb.vb_expr |> exprNoSideEffects) - && e |> exprNoSideEffects - | Texp_record {fields; extended_expression} -> - fields |> Array.for_all fieldNoSideEffects - && extended_expression |> exprOptNoSideEffects - | Texp_assert _ -> false - | Texp_match (e, casesOk, casesExn, partial) -> - let cases = casesOk @ casesExn in - partial = Total && e |> exprNoSideEffects - && cases |> List.for_all caseNoSideEffects - | Texp_letmodule _ -> false - | Texp_try (e, cases) -> - e |> exprNoSideEffects && cases |> List.for_all caseNoSideEffects - | Texp_tuple el -> el |> List.for_all exprNoSideEffects - | Texp_variant (_lbl, eo) -> eo |> exprOptNoSideEffects - | Texp_field (e, _lid, _ld) -> e |> exprNoSideEffects - | Texp_setfield _ -> false - | Texp_array el -> el |> List.for_all exprNoSideEffects - | Texp_ifthenelse (e1, e2, eo) -> - e1 |> exprNoSideEffects && e2 |> exprNoSideEffects - && eo |> exprOptNoSideEffects - | Texp_while (e1, e2) -> e1 |> exprNoSideEffects && e2 |> exprNoSideEffects - | Texp_for (_id, _pat, e1, e2, _dir, e3) -> - e1 |> exprNoSideEffects && e2 |> exprNoSideEffects - && e3 |> exprNoSideEffects - | Texp_for_of _ | Texp_for_await_of _ -> false - | Texp_send _ -> false - | Texp_letexception (_ec, e) -> e |> exprNoSideEffects - | Texp_pack _ -> false - | Texp_extension_constructor _ when true -> true - | _ -> (* on ocaml 4.08: Texp_letop | Texp_open *) true - -and exprOptNoSideEffects eo = - match eo with - | None -> true - | Some e -> e |> exprNoSideEffects - -and fieldNoSideEffects - ((_ld, rld, _) : _ * Typedtree.record_label_definition * _) = - match rld with - | Kept _typeExpr -> true - | Overridden (_lid, e) -> e |> exprNoSideEffects - -and caseNoSideEffects : Typedtree.case -> _ = - fun {c_guard; c_rhs} -> - c_guard |> exprOptNoSideEffects && c_rhs |> exprNoSideEffects - -let checkExpr e = not (exprNoSideEffects e) diff --git a/analysis/reanalyze/src/AnalysisResult.ml b/analysis/reanalyze/src/analysis_result.ml similarity index 81% rename from analysis/reanalyze/src/AnalysisResult.ml rename to analysis/reanalyze/src/analysis_result.ml index dd145b4c4bf..a2075b67d5b 100644 --- a/analysis/reanalyze/src/AnalysisResult.ml +++ b/analysis/reanalyze/src/analysis_result.ml @@ -18,10 +18,10 @@ let get_issues result = result.issues |> List.rev let issue_count result = List.length result.issues (** Create a dead code issue *) -let make_dead_issue ~loc ~deadWarning ~path ~message : Issue.t = +let make_dead_issue ~loc ~dead_warning ~path ~message : Issue.t = { Issue.name = - (match deadWarning with + (match dead_warning with | Issue.WarningDeadException -> "Warning Dead Exception" | WarningDeadType -> "Warning Dead Type" | WarningDeadValue -> "Warning Dead Value" @@ -30,11 +30,11 @@ let make_dead_issue ~loc ~deadWarning ~path ~message : Issue.t = | IncorrectDeadAnnotation -> "Incorrect Dead Annotation"); severity = Warning; loc; - description = DeadWarning {deadWarning; path; message}; + description = DeadWarning {dead_warning; path; message}; } (** Create a dead module issue *) -let make_dead_module_issue ~loc ~moduleName : Issue.t = +let make_dead_module_issue ~loc ~module_name : Issue.t = { Issue.name = "Warning Dead Module"; severity = Warning; @@ -44,7 +44,7 @@ let make_dead_module_issue ~loc ~moduleName : Issue.t = { message = Format.asprintf "@{%s@} %s" - (moduleName |> Name.toInterface |> Name.toString) + (module_name |> Name.to_interface |> Name.to_string) "is a dead module as all its items are dead."; }; } diff --git a/analysis/reanalyze/src/AnalysisResult.mli b/analysis/reanalyze/src/analysis_result.mli similarity index 87% rename from analysis/reanalyze/src/AnalysisResult.mli rename to analysis/reanalyze/src/analysis_result.mli index beee4e4d4e1..1fd429ad04d 100644 --- a/analysis/reanalyze/src/AnalysisResult.mli +++ b/analysis/reanalyze/src/analysis_result.mli @@ -25,11 +25,11 @@ val issue_count : t -> int val make_dead_issue : loc:Location.t -> - deadWarning:Issue.deadWarning -> + dead_warning:Issue.dead_warning -> path:string -> message:string -> Issue.t (** Create a dead code warning issue *) -val make_dead_module_issue : loc:Location.t -> moduleName:Name.t -> Issue.t +val make_dead_module_issue : loc:Location.t -> module_name:Name.t -> Issue.t (** Create a dead module warning issue *) diff --git a/analysis/reanalyze/src/Annotation.ml b/analysis/reanalyze/src/annotation.ml similarity index 76% rename from analysis/reanalyze/src/Annotation.ml rename to analysis/reanalyze/src/annotation.ml index ad522762dd4..f9df3d9e911 100644 --- a/analysis/reanalyze/src/Annotation.ml +++ b/analysis/reanalyze/src/annotation.ml @@ -1,22 +1,22 @@ -type attributePayload = +type attribute_payload = | BoolPayload of bool | ConstructPayload of string | FloatPayload of string | IdentPayload of Longident.t | IntPayload of string | StringPayload of string - | TuplePayload of attributePayload list + | TuplePayload of attribute_payload list | UnrecognizedPayload -let tagIsGenType s = s = "genType" || s = "gentype" -let tagIsGenTypeImport s = s = "genType.import" || s = "gentype.import" -let tagIsGenTypeOpaque s = s = "genType.opaque" || s = "gentype.opaque" +let tag_is_gen_type s = s = "genType" || s = "gentype" +let tag_is_gen_type_import s = s = "genType.import" || s = "gentype.import" +let tag_is_gen_type_opaque s = s = "genType.opaque" || s = "gentype.opaque" -let tagIsOneOfTheGenTypeAnnotations s = - tagIsGenType s || tagIsGenTypeImport s || tagIsGenTypeOpaque s +let tag_is_one_of_the_gen_type_annotations s = + tag_is_gen_type s || tag_is_gen_type_import s || tag_is_gen_type_opaque s -let rec getAttributePayload checkText (attributes : Typedtree.attributes) = - let rec fromExpr (expr : Parsetree.expression) = +let rec get_attribute_payload check_text (attributes : Typedtree.attributes) = + let rec from_expr (expr : Parsetree.expression) = match expr with | {pexp_desc = Pexp_constant (Pconst_string (s, _))} -> Some (StringPayload s) @@ -29,7 +29,7 @@ let rec getAttributePayload checkText (attributes : Typedtree.attributes) = Some (BoolPayload (s = "true")) | {pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> None | {pexp_desc = Pexp_construct ({txt = Longident.Lident "::"}, Some e)} -> - fromExpr e + from_expr e | {pexp_desc = Pexp_construct ({txt}, _); _} -> Some (ConstructPayload (txt |> Longident.flatten |> String.concat ".")) | {pexp_desc = Pexp_tuple exprs | Pexp_array exprs} -> @@ -37,7 +37,7 @@ let rec getAttributePayload checkText (attributes : Typedtree.attributes) = exprs |> List.rev |> List.fold_left (fun payloads expr -> - match expr |> fromExpr with + match expr |> from_expr with | Some payload -> payload :: payloads | None -> payloads) [] @@ -49,10 +49,10 @@ let rec getAttributePayload checkText (attributes : Typedtree.attributes) = match attributes with | [] -> None | ({Asttypes.txt}, payload) :: tl -> - if checkText txt then + if check_text txt then match payload with | PStr [] -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_eval (expr, _)} :: _) -> expr |> fromExpr + | PStr ({pstr_desc = Pstr_eval (expr, _)} :: _) -> expr |> from_expr | PStr ({pstr_desc = Pstr_extension _} :: _) -> Some UnrecognizedPayload | PStr ({pstr_desc = Pstr_value _} :: _) -> Some UnrecognizedPayload | PStr ({pstr_desc = Pstr_primitive _} :: _) -> Some UnrecognizedPayload @@ -68,15 +68,15 @@ let rec getAttributePayload checkText (attributes : Typedtree.attributes) = | PPat _ -> Some UnrecognizedPayload | PSig _ -> Some UnrecognizedPayload | PTyp _ -> Some UnrecognizedPayload - else getAttributePayload checkText tl + else get_attribute_payload check_text tl -let hasAttribute checkText (attributes : Typedtree.attributes) = - getAttributePayload checkText attributes <> None +let has_attribute check_text (attributes : Typedtree.attributes) = + get_attribute_payload check_text attributes <> None -let isOcamlSuppressDeadWarning attributes = +let is_ocaml_suppress_dead_warning attributes = match attributes - |> getAttributePayload (fun x -> x = "ocaml.warning" || x = "warning") + |> get_attribute_payload (fun x -> x = "ocaml.warning" || x = "warning") with | Some (StringPayload s) -> let numeric = diff --git a/analysis/reanalyze/src/annotation_store.ml b/analysis/reanalyze/src/annotation_store.ml new file mode 100644 index 00000000000..30036f09f6e --- /dev/null +++ b/analysis/reanalyze/src/annotation_store.ml @@ -0,0 +1,34 @@ +(** Abstraction over annotation storage. + + Allows the solver to work with either: + - [Frozen]: Traditional [FileAnnotations.t] (copied from reactive) + - [Reactive]: Direct [Reactive.t] (no copy, zero-cost on warm runs) *) + +type t = + | Frozen of File_annotations.t + | Reactive of (Lexing.position, File_annotations.annotated_as) Reactive.t + +let of_frozen ann = Frozen ann + +let of_reactive reactive = Reactive reactive + +let is_annotated_dead t pos = + match t with + | Frozen ann -> File_annotations.is_annotated_dead ann pos + | Reactive reactive -> Reactive.get reactive pos = Some File_annotations.Dead + +let is_annotated_gentype_or_live t pos = + match t with + | Frozen ann -> File_annotations.is_annotated_gentype_or_live ann pos + | Reactive reactive -> ( + match Reactive.get reactive pos with + | Some (File_annotations.Live | File_annotations.GenType) -> true + | Some File_annotations.Dead | None -> false) + +let is_annotated_gentype_or_dead t pos = + match t with + | Frozen ann -> File_annotations.is_annotated_gentype_or_dead ann pos + | Reactive reactive -> ( + match Reactive.get reactive pos with + | Some (File_annotations.Dead | File_annotations.GenType) -> true + | Some File_annotations.Live | None -> false) diff --git a/analysis/reanalyze/src/AnnotationStore.mli b/analysis/reanalyze/src/annotation_store.mli similarity index 84% rename from analysis/reanalyze/src/AnnotationStore.mli rename to analysis/reanalyze/src/annotation_store.mli index 0c8e099fd88..26142b936b8 100644 --- a/analysis/reanalyze/src/AnnotationStore.mli +++ b/analysis/reanalyze/src/annotation_store.mli @@ -7,11 +7,11 @@ type t (** Abstract annotation store *) -val of_frozen : FileAnnotations.t -> t +val of_frozen : File_annotations.t -> t (** Wrap a frozen [FileAnnotations.t] *) val of_reactive : - (Lexing.position, FileAnnotations.annotated_as) Reactive.t -> t + (Lexing.position, File_annotations.annotated_as) Reactive.t -> t (** Wrap a reactive collection directly (no copy) *) val is_annotated_dead : t -> Lexing.position -> bool diff --git a/analysis/reanalyze/src/arnold.ml b/analysis/reanalyze/src/arnold.ml new file mode 100644 index 00000000000..bdc2fab0afe --- /dev/null +++ b/analysis/reanalyze/src/arnold.ml @@ -0,0 +1,1451 @@ +let print_pos ppf (pos : Lexing.position) = + let file = pos.Lexing.pos_fname in + let line = pos.Lexing.pos_lnum in + Format.fprintf ppf "@{%s@} @{%i@}" + (file |> Filename.basename) + line + +module String_set = Set.Make (String) + +(** Type Definitions *) +module Function_name = struct + type t = string +end + +module Function_args = struct + type arg = {label: string; function_name: Function_name.t} + type t = arg list + + let empty = [] + let arg_to_string {label; function_name} = label ^ ":" ^ function_name + + let to_string function_args = + match function_args = [] with + | true -> "" + | false -> + "<" ^ (function_args |> List.map arg_to_string |> String.concat ",") ^ ">" + + let find (t : t) ~label = + match t |> List.find_opt (fun arg -> arg.label = label) with + | Some {function_name} -> Some function_name + | None -> None + + let compare_arg a1 a2 = + let n = compare a1.label a2.label in + if n <> 0 then n else compare a1.function_name a2.function_name + + let rec compare l1 l2 = + match (l1, l2) with + | [], [] -> 0 + | [], _ :: _ -> -1 + | _ :: _, [] -> 1 + | x1 :: l1, x2 :: l2 -> + let n = compare_arg x1 x2 in + if n <> 0 then n else compare l1 l2 +end + +module Function_call = struct + type t = {function_name: Function_name.t; function_args: Function_args.t} + + let substitute_name ~sub name = + match sub |> Function_args.find ~label:name with + | Some function_name -> function_name + | None -> name + + let apply_substitution ~(sub : Function_args.t) (t : t) = + if sub = [] then t + else + { + function_name = t.function_name |> substitute_name ~sub; + function_args = + t.function_args + |> List.map (fun (arg : Function_args.arg) -> + { + arg with + function_name = arg.function_name |> substitute_name ~sub; + }); + } + + let no_args function_name = {function_name; function_args = []} + + let to_string {function_name; function_args} = + function_name ^ Function_args.to_string function_args + + let compare (x1 : t) x2 = + let n = compare x1.function_name x2.function_name in + if n <> 0 then n + else Function_args.compare x1.function_args x2.function_args +end + +module Function_call_set = Set.Make (Function_call) + +module Stats = struct + let n_cache_checks = ref 0 + let n_cache_hits = ref 0 + let n_files = ref 0 + let n_functions = ref 0 + let n_hygiene_errors = ref 0 + let n_infinite_loops = ref 0 + let n_recursive_blocks = ref 0 + + let print ppf () = + Format.fprintf ppf "@[@,@{Termination Analysis Stats@}@,"; + Format.fprintf ppf "Files:@{%d@}@," !n_files; + Format.fprintf ppf "Recursive Blocks:@{%d@}@," !n_recursive_blocks; + Format.fprintf ppf "Functions:@{%d@}@," !n_functions; + Format.fprintf ppf "Infinite Loops:@{%d@}@," !n_infinite_loops; + Format.fprintf ppf "Hygiene Errors:@{%d@}@," !n_hygiene_errors; + Format.fprintf ppf "Cache Hits:@{%d@}/@{%d@}@," !n_cache_hits + !n_cache_checks; + Format.fprintf ppf "@]" + + let dump ~ppf = Format.fprintf ppf "%a@." print () + let new_file () = incr n_files + + let new_recursive_functions ~num_functions = + incr n_recursive_blocks; + n_functions := !n_functions + num_functions + + let log_loop () = incr n_infinite_loops + + let log_cache ~config ~function_call ~hit ~loc = + incr n_cache_checks; + if hit then incr n_cache_hits; + if config.Dce_config.cli.debug then + Log_.warning ~for_stats:false ~loc + (Termination + { + termination = TerminationAnalysisInternal; + message = + Format.asprintf "Cache %s for @{%s@}" + (match hit with + | true -> "hit" + | false -> "miss") + (Function_call.to_string function_call); + }) + + let log_result ~config ~function_call ~loc ~res_string = + if config.Dce_config.cli.debug then + Log_.warning ~for_stats:false ~loc + (Termination + { + termination = TerminationAnalysisInternal; + message = + Format.asprintf "@{%s@} returns %s" + (Function_call.to_string function_call) + res_string; + }) + + let log_hygiene_parametric ~function_name ~loc = + incr n_hygiene_errors; + Log_.error ~loc + (Termination + { + termination = ErrorHygiene; + message = + Format.asprintf + "@{%s@} cannot be analyzed directly as it is parametric" + function_name; + }) + + let log_hygiene_only_call_directly ~path ~loc = + incr n_hygiene_errors; + Log_.error ~loc + (Termination + { + termination = ErrorHygiene; + message = + Format.asprintf + "@{%s@} can only be called directly, or passed as \ + labeled argument" + (Path.name path); + }) + + let log_hygiene_must_have_named_argument ~label ~loc = + incr n_hygiene_errors; + Log_.error ~loc + (Termination + { + termination = ErrorHygiene; + message = + Format.asprintf "Call must have named argument @{%s@}" label; + }) + + let log_hygiene_named_arg_value ~label ~loc = + incr n_hygiene_errors; + Log_.error ~loc + (Termination + { + termination = ErrorHygiene; + message = + Format.asprintf + "Named argument @{%s@} must be passed a recursive \ + function" + label; + }) + + let log_hygiene_no_nested_let_rec ~loc = + incr n_hygiene_errors; + Log_.error ~loc + (Termination + { + termination = ErrorHygiene; + message = Format.asprintf "Nested multiple let rec not supported yet"; + }) +end + +module Progress = struct + type t = Progress | NoProgress + + let to_string progress = + match progress = Progress with + | true -> "Progress" + | false -> "NoProgress" +end + +module Call = struct + type progress_function = Path.t + + type t = + | FunctionCall of Function_call.t + | ProgressFunction of progress_function + + let to_string call = + match call with + | ProgressFunction progress_function -> "+" ^ Path.name progress_function + | FunctionCall function_call -> Function_call.to_string function_call +end + +module Trace = struct + type ret_option = Rsome | Rnone + + type t = + | Tcall of Call.t * Progress.t + | Tnondet of t list + | Toption of ret_option + | Tseq of t list + + let empty = Tseq [] + + let nd (t1 : t) (t2 : t) : t = + match (t1, t2) with + | Tnondet l1, Tnondet l2 -> Tnondet (l1 @ l2) + | _, Tnondet l2 -> Tnondet (t1 :: l2) + | Tnondet l1, _ -> Tnondet (l1 @ [t2]) + | _ -> Tnondet [t1; t2] + + let seq (t1 : t) (t2 : t) : t = + match (t1, t2) with + | Tseq l1, Tseq l2 -> Tseq (l1 @ l2) + | _, Tseq l2 -> Tseq (t1 :: l2) + | Tseq l1, _ -> Tseq (l1 @ [t2]) + | _ -> Tseq [t1; t2] + + let some = Toption Rsome + let none = Toption Rnone + + let ret_option_to_string r = + match r = Rsome with + | true -> "Some" + | false -> "None" + + let rec to_string trace = + match trace with + | Tcall (ProgressFunction progress_function, progress) -> + Path.name progress_function ^ ":" ^ Progress.to_string progress + | Tcall (FunctionCall function_call, progress) -> + Function_call.to_string function_call ^ ":" ^ Progress.to_string progress + | Tnondet traces -> + "[" ^ (traces |> List.map to_string |> String.concat " || ") ^ "]" + | Toption ret_option -> ret_option |> ret_option_to_string + | Tseq traces -> ( + let traces_not_empty = traces |> List.filter (( <> ) empty) in + match traces_not_empty with + | [] -> "_" + | [t] -> t |> to_string + | _ :: _ -> traces_not_empty |> List.map to_string |> String.concat "; ") +end + +module Values : sig + type t + + val get_none : t -> Progress.t option + val get_some : t -> Progress.t option + val nd : t -> t -> t + val none : progress:Progress.t -> t + val some : progress:Progress.t -> t + val to_string : t -> string +end = struct + type t = {none: Progress.t option; some: Progress.t option} + + let get_none {none} = none + let get_some {some} = some + + let to_string x = + ((match x.some with + | None -> [] + | Some p -> ["some: " ^ Progress.to_string p]) + @ + match x.none with + | None -> [] + | Some p -> ["none: " ^ Progress.to_string p]) + |> String.concat ", " + + let none ~progress = {none = Some progress; some = None} + let some ~progress = {none = None; some = Some progress} + + let nd (v1 : t) (v2 : t) : t = + let combine x y = + match (x, y) with + | Some progress1, Some progress2 -> + Some + (match progress1 = Progress.Progress && progress2 = Progress with + | true -> Progress.Progress + | false -> NoProgress) + | None, progress_opt | progress_opt, None -> progress_opt + in + let none = combine v1.none v2.none in + let some = combine v1.some v2.some in + {none; some} +end + +module State = struct + type t = {progress: Progress.t; trace: Trace.t; values_opt: Values.t option} + + let to_string {progress; trace; values_opt} = + let progress_str = + match values_opt with + | None -> progress |> Progress.to_string + | Some values -> "{" ^ (values |> Values.to_string) ^ "}" + in + progress_str ^ " with trace " ^ Trace.to_string trace + + let init ?(progress = Progress.NoProgress) ?(trace = Trace.empty) + ?(values_opt = None) () = + {progress; trace; values_opt} + + let seq s1 s2 = + let progress = + match s1.progress = Progress || s2.progress = Progress with + | true -> Progress.Progress + | false -> NoProgress + in + let trace = Trace.seq s1.trace s2.trace in + let values_opt = s2.values_opt in + {progress; trace; values_opt} + + let sequence states = + match states with + | [] -> assert false + | s :: next_states -> List.fold_left seq s next_states + + let nd s1 s2 = + let progress = + match s1.progress = Progress && s2.progress = Progress with + | true -> Progress.Progress + | false -> NoProgress + in + let trace = Trace.nd s1.trace s2.trace in + let values_opt = + match (s1.values_opt, s2.values_opt) with + | None, values_opt -> ( + match s1.progress = Progress with + | true -> values_opt + | false -> None) + | values_opt, None -> ( + match s2.progress = Progress with + | true -> values_opt + | false -> None) + | Some values1, Some values2 -> Some (Values.nd values1 values2) + in + {progress; trace; values_opt} + + let nondet states = + match states with + | [] -> assert false + | s :: next_states -> List.fold_left nd s next_states + + let unordered_sequence states = {(states |> sequence) with values_opt = None} + + let none ~progress = + init ~progress ~trace:Trace.none + ~values_opt:(Some (Values.none ~progress)) + () + + let some ~progress = + init ~progress ~trace:Trace.some + ~values_opt:(Some (Values.some ~progress)) + () +end + +module Command = struct + type progress = Progress.t + type ret_option = Trace.ret_option + + type t = + | Call of Call.t * Location.t + | ConstrOption of ret_option + | Nondet of t list + | Nothing + | Sequence of t list + | SwitchOption of { + function_call: Function_call.t; + loc: Location.t; + some: t; + none: t; + } + | UnorderedSequence of t list + + let rec to_string command = + match command with + | Call (call, _pos) -> call |> Call.to_string + | ConstrOption r -> r |> Trace.ret_option_to_string + | Nondet commands -> + "[" ^ (commands |> List.map to_string |> String.concat " || ") ^ "]" + | Nothing -> "_" + | Sequence commands -> commands |> List.map to_string |> String.concat "; " + | SwitchOption {function_call; some = c_some; none = c_none} -> + "switch " + ^ Function_call.to_string function_call + ^ " {some: " ^ to_string c_some ^ ", none: " ^ to_string c_none ^ "}" + | UnorderedSequence commands -> + "{" ^ (commands |> List.map to_string |> String.concat ", ") ^ "}" + + let nothing = Nothing + + let nondet commands = + let rec loop commands = + match commands with + | [] -> nothing + | Nondet commands :: rest -> loop (commands @ rest) + | [command] -> command + | _ -> Nondet commands + in + loop commands + + let sequence commands = + let rec loop acc commands = + match commands with + | [] -> List.rev acc + | Nothing :: cs when cs <> [] -> loop acc cs + | Sequence cs1 :: cs2 -> loop acc (cs1 @ cs2) + | c :: cs -> loop (c :: acc) cs + in + match loop [] commands with + | [c] -> c + | cs -> Sequence cs + + let ( +++ ) c1 c2 = sequence [c1; c2] + + let unordered_sequence commands = + let relevant_commands = commands |> List.filter (fun x -> x <> nothing) in + match relevant_commands with + | [] -> nothing + | [c] -> c + | _ :: _ :: _ -> UnorderedSequence relevant_commands +end + +module Kind = struct + type t = entry list + and entry = {label: string; k: t} + + let empty = ([] : t) + + let has_label ~label (k : t) = + k |> List.exists (fun entry -> entry.label = label) + + let rec entry_to_string {label; k} = + match k = [] with + | true -> label + | false -> label ^ ":" ^ (k |> to_string) + + and to_string (kind : t) = + match kind = [] with + | true -> "" + | false -> + "<" ^ (kind |> List.map entry_to_string |> String.concat ", ") ^ ">" + + let add_label_with_empty_kind ~label kind = + if not (kind |> has_label ~label) then + {label; k = empty} :: kind |> List.sort compare + else kind +end + +module Function_table = struct + type function_definition = { + mutable body: Command.t option; + mutable kind: Kind.t; + } + + type t = (Function_name.t, function_definition) Hashtbl.t + + let create () : t = Hashtbl.create 1 + + let print ppf (tbl : t) = + Format.fprintf ppf "@[@,@{Function Table@}"; + let definitions = + Hashtbl.fold + (fun function_name {kind; body} definitions -> + (function_name, kind, body) :: definitions) + tbl [] + |> List.sort (fun (fn1, _, _) (fn2, _, _) -> String.compare fn1 fn2) + in + definitions + |> List.iteri (fun i (function_name, kind, body) -> + Format.fprintf ppf "@,@{%d@} @{%s%s@}: %s" (i + 1) + function_name (Kind.to_string kind) + (match body with + | Some command -> Command.to_string command + | None -> "None")); + Format.fprintf ppf "@]" + + let dump tbl = Format.fprintf Format.std_formatter "%a@." print tbl + let initial_function_definition () = {kind = Kind.empty; body = None} + + let get_function_definition ~function_name (tbl : t) = + try Hashtbl.find tbl function_name with Not_found -> assert false + + let is_in_function_in_table ~function_table path = + Hashtbl.mem function_table (Path.name path) + + let add_function ~function_name (tbl : t) = + if Hashtbl.mem tbl function_name then assert false; + Hashtbl.replace tbl function_name (initial_function_definition ()) + + let add_label_to_kind ~function_name ~label (tbl : t) = + let function_definition = tbl |> get_function_definition ~function_name in + function_definition.kind <- + function_definition.kind |> Kind.add_label_with_empty_kind ~label + + let add_body ~body ~function_name (tbl : t) = + let function_definition = tbl |> get_function_definition ~function_name in + function_definition.body <- body + + let function_get_kind_of_label ~function_name ~label (tbl : t) = + match Hashtbl.find tbl function_name with + | {kind} -> ( + match kind |> Kind.has_label ~label with + | true -> Some Kind.empty + | false -> None) + | exception Not_found -> None +end + +module Find_functions_called = struct + let traverse_expr ~callees = + let super = Tast_mapper.default in + let expr (self : Tast_mapper.mapper) (e : Typedtree.expression) = + (match e.exp_desc with + | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)}} -> + let function_name = Path.name callee in + callees := !callees |> String_set.add function_name + | _ -> ()); + super.expr self e + in + {super with Tast_mapper.expr} + + let find_callees (expression : Typedtree.expression) = + let is_function = + match expression.exp_desc with + | Texp_function {arity = None} -> true + | _ -> false + in + let callees = ref String_set.empty in + let traverse_expr = traverse_expr ~callees in + if is_function then expression |> traverse_expr.expr traverse_expr |> ignore; + !callees +end + +module Extend_function_table = struct + (* Add functions passed a recursive function via a labeled argument, + and functions calling progress functions, to the function table. *) + let extract_labelled_argument ?(kind_opt = None) + (arg_opt : Typedtree.expression option) = + match arg_opt with + | Some {exp_desc = Texp_ident (path, {loc}, _)} -> Some (path, loc) + | Some + { + exp_desc = + Texp_let + ( Nonrecursive, + [ + { + vb_pat = {pat_desc = Tpat_var (_, _)}; + vb_expr = {exp_desc = Texp_ident (path, {loc}, _)}; + vb_loc = {loc_ghost = true}; + }; + ], + _ ); + } -> + Some (path, loc) + | Some + { + exp_desc = + Texp_apply {funct = {exp_desc = Texp_ident (path, {loc}, _)}; args}; + } + when kind_opt <> None -> + let check_arg ((arg_label : Asttypes.arg_label), _argOpt) = + match (arg_label, kind_opt) with + | (Labelled {txt = l} | Optional {txt = l}), Some kind -> + kind |> List.for_all (fun {Kind.label} -> label <> l) + | _ -> true + in + if args |> List.for_all check_arg then Some (path, loc) else None + | _ -> None + + let traverse_expr ~config ~function_table ~progress_functions + ~value_bindings_table = + let super = Tast_mapper.default in + let expr (self : Tast_mapper.mapper) (e : Typedtree.expression) = + (match e.exp_desc with + | Texp_ident (callee, _, _) -> ( + let loc = e.exp_loc in + match Hashtbl.find_opt value_bindings_table (Path.name callee) with + | None -> () + | Some (id_pos, _, callees) -> + if + not + (String_set.is_empty + (String_set.inter (Lazy.force callees) progress_functions)) + then + let function_name = Path.name callee in + if + not + (callee + |> Function_table.is_in_function_in_table ~function_table) + then ( + function_table |> Function_table.add_function ~function_name; + if config.Dce_config.cli.debug then + Log_.warning ~for_stats:false ~loc + (Termination + { + termination = TerminationAnalysisInternal; + message = + Format.asprintf + "Extend Function Table with @{%s@} (%a) as it \ + calls a progress function" + function_name print_pos id_pos; + }))) + | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)}; args} + when callee |> Function_table.is_in_function_in_table ~function_table -> + let function_name = Path.name callee in + args + |> List.iter (fun ((arg_label : Asttypes.arg_label), arg_opt) -> + match (arg_label, arg_opt |> extract_labelled_argument) with + | Labelled {txt = label}, Some (path, loc) + when path + |> Function_table.is_in_function_in_table ~function_table + -> + function_table + |> Function_table.add_label_to_kind ~function_name ~label; + if config.Dce_config.cli.debug then + Log_.warning ~for_stats:false ~loc + (Termination + { + termination = TerminationAnalysisInternal; + message = + Format.asprintf + "@{%s@} is parametric \ + ~@{%s@}=@{%s@}" + function_name label (Path.name path); + }) + | _ -> ()) + | _ -> ()); + super.expr self e + in + {super with Tast_mapper.expr} + + let run ~config ~function_table ~progress_functions ~value_bindings_table + (expression : Typedtree.expression) = + let traverse_expr = + traverse_expr ~config ~function_table ~progress_functions + ~value_bindings_table + in + expression |> traverse_expr.expr traverse_expr |> ignore +end + +module Check_expression_well_formed = struct + let traverse_expr ~config ~function_table ~value_bindings_table = + let super = Tast_mapper.default in + let check_ident ~path ~loc = + if path |> Function_table.is_in_function_in_table ~function_table then + Stats.log_hygiene_only_call_directly ~path ~loc + in + let expr (self : Tast_mapper.mapper) (e : Typedtree.expression) = + match e.exp_desc with + | Texp_ident (path, {loc}, _) -> + check_ident ~path ~loc; + e + | Texp_apply {funct = {exp_desc = Texp_ident (function_path, _, _)}; args} + -> + let function_name = Path.name function_path in + args + |> List.iter (fun ((arg_label : Asttypes.arg_label), arg_opt) -> + match + arg_opt |> Extend_function_table.extract_labelled_argument + with + | Some (path, loc) -> ( + match arg_label with + | Labelled {txt = label} -> ( + if + function_table + |> Function_table.function_get_kind_of_label ~function_name + ~label + <> None + then () + else + match + Hashtbl.find_opt value_bindings_table function_name + with + | Some (_pos, (body : Typedtree.expression), _) + when path + |> Function_table.is_in_function_in_table + ~function_table -> + let in_table = + function_path + |> Function_table.is_in_function_in_table + ~function_table + in + if not in_table then + function_table + |> Function_table.add_function ~function_name; + function_table + |> Function_table.add_label_to_kind ~function_name ~label; + if config.Dce_config.cli.debug then + Log_.warning ~for_stats:false ~loc:body.exp_loc + (Termination + { + termination = TerminationAnalysisInternal; + message = + Format.asprintf + "Extend Function Table with @{%s@} \ + as parametric ~@{%s@}=@{%s@}" + function_name label (Path.name path); + }) + | _ -> check_ident ~path ~loc) + | Optional _ | Nolabel -> check_ident ~path ~loc) + | _ -> ()); + e + | _ -> super.expr self e + in + {super with Tast_mapper.expr} + + let run ~config ~function_table ~value_bindings_table + (expression : Typedtree.expression) = + let traverse_expr = + traverse_expr ~config ~function_table ~value_bindings_table + in + expression |> traverse_expr.expr traverse_expr |> ignore +end + +module Compile = struct + type ctx = { + config: Dce_config.t; + current_function_name: Function_name.t; + function_table: Function_table.t; + inner_recursive_functions: (Function_name.t, Function_name.t) Hashtbl.t; + is_progress_function: Path.t -> bool; + } + + let rec expression ~ctx (expr : Typedtree.expression) = + let {config; current_function_name; function_table; is_progress_function} = + ctx + in + let loc = expr.exp_loc in + let not_implemented case = + Log_.error ~loc + (Termination + {termination = ErrorNotImplemented; message = Format.asprintf case}) + in + + match expr.exp_desc with + | Texp_ident _ -> Command.nothing + | Texp_apply + { + funct = {exp_desc = Texp_ident (callee_to_rename, l, vd)} as expr; + args = args_to_extend; + } -> ( + let callee, args = + match + Hashtbl.find_opt ctx.inner_recursive_functions + (Path.name callee_to_rename) + with + | Some inner_function_name -> + let inner_function_definition = + function_table + |> Function_table.get_function_definition + ~function_name:inner_function_name + in + let args_from_kind = + inner_function_definition.kind + |> List.map (fun (entry : Kind.entry) -> + ( Asttypes.Labelled {txt = entry.label; loc = Location.none}, + Some + { + expr with + exp_desc = + Texp_ident + (Path.Pident (Ident.create entry.label), l, vd); + } )) + in + ( Path.Pident (Ident.create inner_function_name), + args_from_kind @ args_to_extend ) + | None -> (callee_to_rename, args_to_extend) + in + if callee |> Function_table.is_in_function_in_table ~function_table then + let function_name = Path.name callee in + let function_definition = + function_table + |> Function_table.get_function_definition ~function_name + in + let exception ArgError in + let get_function_arg {Kind.label} = + let arg_opt = + args + |> List.find_opt (fun arg -> + match arg with + | Asttypes.Labelled {txt = s}, Some _ -> s = label + | _ -> false) + in + let arg_opt = + match arg_opt with + | Some (_, Some e) -> Some e + | _ -> None + in + let function_arg () = + match + arg_opt + |> Extend_function_table.extract_labelled_argument + ~kind_opt:(Some function_definition.kind) + with + | None -> + Stats.log_hygiene_must_have_named_argument ~label ~loc; + raise ArgError + | Some (path, _pos) + when path + |> Function_table.is_in_function_in_table ~function_table -> + let function_name = Path.name path in + {Function_args.label; function_name} + | Some (path, _pos) + when function_table + |> Function_table.function_get_kind_of_label + ~function_name:current_function_name + ~label:(Path.name path) + = Some [] + (* TODO: when kinds are inferred, support and check non-empty kinds *) + -> + let function_name = Path.name path in + {Function_args.label; function_name} + | _ -> + Stats.log_hygiene_named_arg_value ~label ~loc; + raise ArgError + [@@raises ArgError] + in + function_arg () + [@@raises ArgError] + in + let function_args_opt = + try Some (function_definition.kind |> List.map get_function_arg) + with ArgError -> None + in + match function_args_opt with + | None -> Command.nothing + | Some function_args -> + Command.Call (FunctionCall {function_name; function_args}, loc) + |> eval_args ~args ~ctx + else if callee |> is_progress_function then + Command.Call (ProgressFunction callee, loc) |> eval_args ~args ~ctx + else + match + function_table + |> Function_table.function_get_kind_of_label + ~function_name:current_function_name ~label:(Path.name callee) + with + | Some kind when kind = Kind.empty -> + Command.Call + (FunctionCall (Path.name callee |> Function_call.no_args), loc) + |> eval_args ~args ~ctx + | Some _kind -> + (* TODO when kinds are extended in future: check that args matches with kind + and create a function call with the appropriate arguments *) + assert false + | None -> expr |> expression ~ctx |> eval_args ~args ~ctx) + | Texp_apply {funct = expr; args} -> + expr |> expression ~ctx |> eval_args ~args ~ctx + | Texp_let + ( Recursive, + [{vb_pat = {pat_desc = Tpat_var (id, _); pat_loc}; vb_expr}], + in_expr ) -> + let old_function_name = Ident.name id in + let new_function_name = current_function_name ^ "$" ^ old_function_name in + function_table + |> Function_table.add_function ~function_name:new_function_name; + let new_function_definition = + function_table + |> Function_table.get_function_definition + ~function_name:new_function_name + in + let current_function_definition = + function_table + |> Function_table.get_function_definition + ~function_name:current_function_name + in + new_function_definition.kind <- current_function_definition.kind; + let new_ctx = {ctx with current_function_name = new_function_name} in + Hashtbl.replace ctx.inner_recursive_functions old_function_name + new_function_name; + new_function_definition.body <- Some (vb_expr |> expression ~ctx:new_ctx); + if config.Dce_config.cli.debug then + Log_.warning ~for_stats:false ~loc:pat_loc + (Termination + { + termination = TerminationAnalysisInternal; + message = + Format.asprintf "Adding recursive definition @{%s@}" + new_function_name; + }); + in_expr |> expression ~ctx + | Texp_let (rec_flag, value_bindings, in_expr) -> + if rec_flag = Recursive then Stats.log_hygiene_no_nested_let_rec ~loc; + let commands = + (value_bindings + |> List.map (fun (vb : Typedtree.value_binding) -> + vb.vb_expr |> expression ~ctx)) + @ [in_expr |> expression ~ctx] + in + Command.sequence commands + | Texp_sequence (e1, e2) -> + let open Command in + expression ~ctx e1 +++ expression ~ctx e2 + | Texp_ifthenelse (e1, e2, e_opt) -> + let c1 = e1 |> expression ~ctx in + let c2 = e2 |> expression ~ctx in + let c3 = e_opt |> expression_opt ~ctx in + let open Command in + c1 +++ nondet [c2; c3] + | Texp_constant _ -> Command.nothing + | Texp_construct ({loc = {loc_ghost}}, {cstr_name}, expressions) -> ( + let c = + expressions + |> List.map (fun e -> e |> expression ~ctx) + |> Command.unordered_sequence + in + match cstr_name with + | "Some" when loc_ghost = false -> + let open Command in + c +++ ConstrOption Rsome + | "None" when loc_ghost = false -> + let open Command in + c +++ ConstrOption Rnone + | _ -> c) + | Texp_function {case = case_} -> case ~ctx case_ + | Texp_match (e, cases_ok, cases_exn, _partial) + when not + (cases_exn + |> List.map (fun (case : Typedtree.case) -> case.c_lhs.pat_desc) + != []) -> ( + (* No exceptions *) + let cases = cases_ok @ cases_exn in + let c_e = e |> expression ~ctx in + let c_cases = cases |> List.map (case ~ctx) in + let fail () = + let open Command in + c_e +++ nondet c_cases + in + match (c_e, cases) with + | ( Call (FunctionCall function_call, loc), + [{c_lhs = pattern1}; {c_lhs = pattern2}] ) -> ( + match (pattern1.pat_desc, pattern2.pat_desc) with + | ( Tpat_construct (_, {cstr_name = ("Some" | "None") as name1}, _), + Tpat_construct (_, {cstr_name = "Some" | "None"}, _) ) -> + let cases_arr = Array.of_list c_cases in + let some, none = + try + match name1 = "Some" with + | true -> (cases_arr.(0), cases_arr.(1)) + | false -> (cases_arr.(1), cases_arr.(0)) + with Invalid_argument _ -> (Nothing, Nothing) + in + Command.SwitchOption {function_call; loc; some; none} + | _ -> fail ()) + | _ -> fail ()) + | Texp_match _ -> assert false (* exceptions *) + | Texp_field (e, _lid, _desc) -> e |> expression ~ctx + | Texp_record {fields; extended_expression} -> + extended_expression + :: (fields |> Array.to_list + |> List.map + (fun + ( _desc, + (record_label_definition : Typedtree.record_label_definition), + _ ) + -> + match record_label_definition with + | Kept _typeExpr -> None + | Overridden (_loc, e) -> Some e)) + |> List.map (expression_opt ~ctx) + |> Command.unordered_sequence + | Texp_setfield (e1, _loc, _desc, e2) -> + [e1; e2] |> List.map (expression ~ctx) |> Command.unordered_sequence + | Texp_tuple expressions | Texp_array expressions -> + expressions |> List.map (expression ~ctx) |> Command.unordered_sequence + | Texp_assert _ -> Command.nothing + | Texp_try (e, cases) -> + let c_e = e |> expression ~ctx in + let c_cases = cases |> List.map (case ~ctx) |> Command.nondet in + let open Command in + c_e +++ c_cases + | Texp_variant (_label, e_opt) -> e_opt |> expression_opt ~ctx + | Texp_while _ -> + not_implemented "Texp_while"; + assert false + | Texp_for (_id, _pat, e1, e2, _dir, e3) -> + let open Command in + expression ~ctx e1 +++ expression ~ctx e2 +++ expression ~ctx e3 + | Texp_for_of (_id, _pat, e1, e2) -> + let open Command in + expression ~ctx e1 +++ expression ~ctx e2 + | Texp_for_await_of (_id, _pat, e1, e2) -> + let open Command in + expression ~ctx e1 +++ expression ~ctx e2 + | Texp_send _ -> + not_implemented "Texp_send"; + assert false + | Texp_letmodule _ -> + not_implemented "Texp_letmodule"; + assert false + | Texp_letexception _ -> + not_implemented "Texp_letexception"; + assert false + | Texp_pack _ -> + not_implemented "Texp_pack"; + assert false + | Texp_extension_constructor _ when true -> + not_implemented "Texp_extension_constructor"; + assert false + | _ -> + (* ocaml 4.08: Texp_letop(_) | Texp_open(_) *) + not_implemented "Texp_letop(_) | Texp_open(_)"; + assert false + + and expression_opt ~ctx e_opt = + match e_opt with + | None -> Command.nothing + | Some e -> e |> expression ~ctx + + and eval_args ~args ~ctx command = + (* Don't assume any evaluation order on the arguments *) + let commands = + args |> List.map (fun (_, e_opt) -> e_opt |> expression_opt ~ctx) + in + let open Command in + unordered_sequence commands +++ command + + and case : ctx:ctx -> Typedtree.case -> _ = + fun ~ctx {c_guard; c_rhs} -> + match c_guard with + | None -> c_rhs |> expression ~ctx + | Some e -> + let open Command in + expression ~ctx e +++ expression ~ctx c_rhs +end + +module Call_stack = struct + type frame = {frame_number: int; pos: Lexing.position} + type t = {tbl: (Function_call.t, frame) Hashtbl.t; mutable size: int} + + let create () = {tbl = Hashtbl.create 1; size = 0} + + let to_set {tbl} = + Hashtbl.fold + (fun frame _i set -> Function_call_set.add frame set) + tbl Function_call_set.empty + + let has_function_call ~function_call (t : t) = Hashtbl.mem t.tbl function_call + + let add_function_call ~function_call ~pos (t : t) = + t.size <- t.size + 1; + Hashtbl.replace t.tbl function_call {frame_number = t.size; pos} + + let remove_function_call ~function_call (t : t) = + t.size <- t.size - 1; + Hashtbl.remove t.tbl function_call + + let print ppf (t : t) = + Format.fprintf ppf " CallStack:"; + let frames = + Hashtbl.fold + (fun function_call {frame_number; pos} frames -> + (function_call, frame_number, pos) :: frames) + t.tbl [] + |> List.sort (fun (_, i1, _) (_, i2, _) -> i2 - i1) + in + frames + |> List.iter (fun ((function_call : Function_call.t), i, pos) -> + Format.fprintf ppf "\n @{%d@} %s (%a)" i + (Function_call.to_string function_call) + print_pos pos) +end + +module Eval = struct + type progress = Progress.t + type cache = (Function_call.t, State.t) Hashtbl.t + + let create_cache () : cache = Hashtbl.create 1 + + let lookup_cache ~function_call (cache : cache) = + Hashtbl.find_opt cache function_call + + let update_cache ~config ~function_call ~loc ~state (cache : cache) = + Stats.log_result ~config ~function_call + ~res_string:(state |> State.to_string) ~loc; + if not (Hashtbl.mem cache function_call) then + Hashtbl.replace cache function_call state + + let has_infinite_loop ~call_stack ~function_call_to_instantiate ~function_call + ~loc ~state = + if call_stack |> Call_stack.has_function_call ~function_call then ( + if state.State.progress = NoProgress then ( + Log_.error ~loc + (Termination + { + termination = ErrorTermination; + message = + Format.asprintf "%a" + (fun ppf () -> + Format.fprintf ppf "Possible infinite loop when calling "; + (match function_call_to_instantiate = function_call with + | true -> + Format.fprintf ppf "@{%s@}" + (function_call_to_instantiate + |> Function_call.to_string) + | false -> + Format.fprintf ppf "@{%s@} which is @{%s@}" + (function_call_to_instantiate + |> Function_call.to_string) + (function_call |> Function_call.to_string)); + Format.fprintf ppf "@,%a" Call_stack.print call_stack) + (); + }); + Stats.log_loop ()); + true) + else false + + let rec run_function_call ~config ~cache ~call_stack ~function_args + ~function_table ~made_progress_on ~loc ~state function_call_to_instantiate + : State.t = + let pos = loc.Location.loc_start in + let function_call = + function_call_to_instantiate + |> Function_call.apply_substitution ~sub:function_args + in + let function_name = function_call.function_name in + let call = Call.FunctionCall function_call in + let state_after_call = + match cache |> lookup_cache ~function_call with + | Some state_after_call -> + Stats.log_cache ~config ~function_call ~hit:true ~loc; + { + state_after_call with + trace = Trace.Tcall (call, state_after_call.progress); + } + | None -> + if Function_call_set.mem function_call made_progress_on then + State.init ~progress:Progress ~trace:(Trace.Tcall (call, Progress)) () + else if + has_infinite_loop ~call_stack ~function_call_to_instantiate + ~function_call ~loc ~state + then {state with trace = Trace.Tcall (call, state.progress)} + else ( + Stats.log_cache ~config ~function_call ~hit:false ~loc; + let function_definition = + function_table + |> Function_table.get_function_definition ~function_name + in + call_stack |> Call_stack.add_function_call ~function_call ~pos; + let body = + match function_definition.body with + | Some body -> body + | None -> assert false + in + let state_after_call = + body + |> run ~config ~cache ~call_stack + ~function_args:function_call.function_args ~function_table + ~made_progress_on ~state:(State.init ()) + in + cache + |> update_cache ~config ~function_call ~loc ~state:state_after_call; + (* Invariant: run should restore the callStack *) + call_stack |> Call_stack.remove_function_call ~function_call; + let trace = Trace.Tcall (call, state_after_call.progress) in + {state_after_call with trace}) + in + State.seq state state_after_call + + and run ~config ~(cache : cache) ~call_stack ~function_args ~function_table + ~made_progress_on ~state (command : Command.t) : State.t = + match command with + | Call (FunctionCall function_call, loc) -> + function_call + |> run_function_call ~config ~cache ~call_stack ~function_args + ~function_table ~made_progress_on ~loc ~state + | Call ((ProgressFunction _ as call), _pos) -> + let state1 = + State.init ~progress:Progress ~trace:(Tcall (call, Progress)) () + in + State.seq state state1 + | ConstrOption r -> + let state1 = + match r = Rsome with + | true -> State.some ~progress:state.progress + | false -> State.none ~progress:state.progress + in + State.seq state state1 + | Nothing -> + let state1 = State.init () in + State.seq state state1 + | Sequence commands -> + (* if one command makes progress, then the sequence makes progress *) + let rec find_first_progress ~call_stack ~commands ~made_progress_on ~state + = + match commands with + | [] -> state + | c :: next_commands -> + let state1 = + c + |> run ~config ~cache ~call_stack ~function_args ~function_table + ~made_progress_on ~state + in + let made_progress_on, call_stack = + match state1.progress with + | Progress -> + (* look for infinite loops in the rest of the sequence, remembering what has made progress *) + ( Function_call_set.union made_progress_on + (call_stack |> Call_stack.to_set), + Call_stack.create () ) + | NoProgress -> (made_progress_on, call_stack) + in + find_first_progress ~call_stack ~commands:next_commands + ~made_progress_on ~state:state1 + in + find_first_progress ~call_stack ~commands ~made_progress_on ~state + | UnorderedSequence commands -> + let state_no_trace = {state with trace = Trace.empty} in + (* the commands could be executed in any order: progess if any one does *) + let states = + commands + |> List.map (fun c -> + c + |> run ~config ~cache ~call_stack ~function_args ~function_table + ~made_progress_on ~state:state_no_trace) + in + State.seq state (states |> State.unordered_sequence) + | Nondet commands -> + let state_no_trace = {state with trace = Trace.empty} in + (* the commands could be executed in any order: progess if any one does *) + let states = + commands + |> List.map (fun c -> + c + |> run ~config ~cache ~call_stack ~function_args ~function_table + ~made_progress_on ~state:state_no_trace) + in + State.seq state (states |> State.nondet) + | SwitchOption {function_call; loc; some; none} -> ( + let state_after_call = + function_call + |> run_function_call ~config ~cache ~call_stack ~function_args + ~function_table ~made_progress_on ~loc ~state + in + match state_after_call.values_opt with + | None -> + Command.nondet [some; none] + |> run ~config ~cache ~call_stack ~function_args ~function_table + ~made_progress_on ~state:state_after_call + | Some values -> + let run_opt c progress_opt = + match progress_opt with + | None -> State.init ~progress:Progress () + | Some progress -> + c + |> run ~config ~cache ~call_stack ~function_args ~function_table + ~made_progress_on ~state:(State.init ~progress ()) + in + let state_none = values |> Values.get_none |> run_opt none in + let state_some = values |> Values.get_some |> run_opt some in + State.seq state_after_call (State.nondet [state_some; state_none])) + + let analyze_function ~config ~cache ~function_table ~loc function_name = + if config.Dce_config.cli.debug then + Log_.log "@[@,@{Termination Analysis@} for @{%s@}@]@." + function_name; + let pos = loc.Location.loc_start in + let call_stack = Call_stack.create () in + let function_args = Function_args.empty in + let function_call = Function_call.no_args function_name in + call_stack |> Call_stack.add_function_call ~function_call ~pos; + let function_definition = + function_table |> Function_table.get_function_definition ~function_name + in + if function_definition.kind <> Kind.empty then + Stats.log_hygiene_parametric ~function_name ~loc + else + let body = + match function_definition.body with + | Some body -> body + | None -> assert false + in + let state = + body + |> run ~config ~cache ~call_stack ~function_args ~function_table + ~made_progress_on:Function_call_set.empty ~state:(State.init ()) + in + cache |> update_cache ~config ~function_call ~loc ~state +end + +let progress_functions_from_attributes attributes = + let lid_to_string lid = lid |> Longident.flatten |> String.concat "." in + let is_progress = ( = ) "progress" in + if attributes |> Annotation.has_attribute is_progress then + Some + (match attributes |> Annotation.get_attribute_payload is_progress with + | None -> [] + | Some (IdentPayload lid) -> [lid_to_string lid] + | Some (TuplePayload l) -> + l + |> List.filter_map (function + | Annotation.IdentPayload lid -> Some (lid_to_string lid) + | _ -> None) + | _ -> []) + else None + +let traverse_ast ~config ~value_bindings_table = + let super = Tast_mapper.default in + let value_bindings (self : Tast_mapper.mapper) (rec_flag, value_bindings) = + (* Update the table of value bindings for variables *) + value_bindings + |> List.iter (fun (vb : Typedtree.value_binding) -> + match vb.vb_pat.pat_desc with + | Tpat_var (id, {loc = {loc_start = pos}}) -> + let callees = + lazy (Find_functions_called.find_callees vb.vb_expr) + in + Hashtbl.replace value_bindings_table (Ident.name id) + (pos, vb.vb_expr, callees) + | _ -> ()); + let progress_functions, functions_to_analyze = + if rec_flag = Asttypes.Nonrecursive then (String_set.empty, []) + else + let progress_functions0, functions_to_analyze0 = + value_bindings + |> List.fold_left + (fun (progress_functions, functions_to_analyze) + (value_binding : Typedtree.value_binding) -> + match + progress_functions_from_attributes + value_binding.vb_attributes + with + | None -> (progress_functions, functions_to_analyze) + | Some new_progress_functions -> + ( String_set.union + (String_set.of_list new_progress_functions) + progress_functions, + match value_binding.vb_pat.pat_desc with + | Tpat_var (id, _) -> + (Ident.name id, value_binding.vb_expr.exp_loc) + :: functions_to_analyze + | _ -> functions_to_analyze )) + (String_set.empty, []) + in + (progress_functions0, functions_to_analyze0 |> List.rev) + in + if functions_to_analyze <> [] then ( + let function_table = Function_table.create () in + let is_progress_function path = + String_set.mem (Path.name path) progress_functions + in + let recursive_functions = + List.fold_left + (fun defs (value_binding : Typedtree.value_binding) -> + match value_binding.vb_pat.pat_desc with + | Tpat_var (id, _) -> Ident.name id :: defs + | _ -> defs) + [] value_bindings + |> List.rev + in + let recursive_definitions = + recursive_functions + |> List.fold_left + (fun acc function_name -> + match Hashtbl.find_opt value_bindings_table function_name with + | Some (_pos, e, _set) -> (function_name, e) :: acc + | None -> acc) + [] + |> List.rev + in + recursive_definitions + |> List.iter (fun (function_name, _body) -> + function_table |> Function_table.add_function ~function_name); + recursive_definitions + |> List.iter (fun (_, body) -> + body + |> Extend_function_table.run ~config ~function_table + ~progress_functions ~value_bindings_table); + recursive_definitions + |> List.iter (fun (_, body) -> + body + |> Check_expression_well_formed.run ~config ~function_table + ~value_bindings_table); + function_table + |> Hashtbl.iter + (fun + function_name + (function_definition : Function_table.function_definition) + -> + if function_definition.body = None then + match Hashtbl.find_opt value_bindings_table function_name with + | None -> () + | Some (_pos, body, _) -> + function_table + |> Function_table.add_body + ~body: + (Some + (body + |> Compile.expression + ~ctx: + { + config; + current_function_name = function_name; + function_table; + inner_recursive_functions = Hashtbl.create 1; + is_progress_function; + })) + ~function_name); + if config.Dce_config.cli.debug then Function_table.dump function_table; + let cache = Eval.create_cache () in + functions_to_analyze + |> List.iter (fun (function_name, loc) -> + function_name + |> Eval.analyze_function ~config ~cache ~function_table ~loc); + Stats.new_recursive_functions + ~num_functions:(Hashtbl.length function_table)); + value_bindings + |> List.iter (fun value_binding -> + super.value_binding self value_binding |> ignore); + (rec_flag, value_bindings) + in + {super with Tast_mapper.value_bindings} + +let process_structure ~config (structure : Typedtree.structure) = + Stats.new_file (); + let value_bindings_table = Hashtbl.create 1 in + let traverse_ast = traverse_ast ~config ~value_bindings_table in + structure |> traverse_ast.structure traverse_ast |> ignore + +let process_cmt ~config ~file:_ (cmt_infos : Cmt_format.cmt_infos) = + match cmt_infos.cmt_annots with + | Interface _ -> () + | Implementation structure -> process_structure ~config structure + | _ -> () + +let report_stats ~config:_ = Stats.dump ~ppf:Format.std_formatter diff --git a/analysis/reanalyze/src/Cli.ml b/analysis/reanalyze/src/cli.ml similarity index 83% rename from analysis/reanalyze/src/Cli.ml rename to analysis/reanalyze/src/cli.ml index ca8a4f54798..806a11af643 100644 --- a/analysis/reanalyze/src/Cli.ml +++ b/analysis/reanalyze/src/cli.ml @@ -5,22 +5,22 @@ let debug = ref false let ci = ref false (** The command was a -cmt variant (e.g. -exception-cmt) *) -let cmtCommand = ref false +let cmt_command = ref false let experimental = ref false let json = ref false (* names to be considered live values *) -let liveNames = ref ([] : string list) +let live_names = ref ([] : string list) (* paths of files where all values are considered live *) -let livePaths = ref ([] : string list) +let live_paths = ref ([] : string list) (* paths of files to exclude from analysis *) -let excludePaths = ref ([] : string list) +let exclude_paths = ref ([] : string list) (* test flag: shuffle file order to verify order-independence *) -let testShuffle = ref false +let test_shuffle = ref false (* timing: report internal timing of analysis phases *) let timing = ref false diff --git a/analysis/reanalyze/src/collect_annotations.ml b/analysis/reanalyze/src/collect_annotations.ml new file mode 100644 index 00000000000..e7c4e0a17f5 --- /dev/null +++ b/analysis/reanalyze/src/collect_annotations.ml @@ -0,0 +1,182 @@ +(** AST traversal to collect source annotations (@dead, @live, @genType). + + This module traverses the typed AST to find attribute annotations + and records them in a FileAnnotations.builder. *) + +open Dead_common + +type scope_default = File_annotations.annotated_as option + +let process_attributes ~(scope_default : scope_default) ~state ~config + ~do_gen_type ~name ~pos attributes = + (match scope_default with + | Some File_annotations.Live -> File_annotations.annotate_live state pos + | Some File_annotations.Dead -> File_annotations.annotate_dead state pos + | Some File_annotations.GenType -> File_annotations.annotate_gentype state pos + | None -> ()); + let get_payload_fun f = attributes |> Annotation.get_attribute_payload f in + let get_payload (x : string) = + attributes |> Annotation.get_attribute_payload (( = ) x) + in + if + do_gen_type + && get_payload_fun Annotation.tag_is_one_of_the_gen_type_annotations <> None + then File_annotations.annotate_gentype state pos; + if get_payload "dead" <> None then File_annotations.annotate_dead state pos; + let name_is_in_live_names_or_paths () = + config.Dce_config.cli.live_names |> List.mem name + || + let fname = + match Filename.is_relative pos.pos_fname with + | true -> pos.pos_fname + | false -> Filename.concat (Sys.getcwd ()) pos.pos_fname + in + let fname_len = String.length fname in + config.Dce_config.cli.live_paths + |> List.exists (fun prefix -> + String.length prefix <= fname_len + && + try String.sub fname 0 (String.length prefix) = prefix + with Invalid_argument _ -> false) + in + if get_payload live_annotation <> None || name_is_in_live_names_or_paths () + then File_annotations.annotate_live state pos; + if attributes |> Annotation.is_ocaml_suppress_dead_warning then + File_annotations.annotate_live state pos + +let collect_export_locations ~state ~config ~do_gen_type = + let super = Tast_mapper.default in + let currently_disable_warnings = ref false in + let current_scope_default : scope_default ref = ref None in + + let scope_default_from_toplevel_attribute (attribute : Parsetree.attribute) : + scope_default = + let attrs = [attribute] in + let get_payload (x : string) = + attrs |> Annotation.get_attribute_payload (( = ) x) + in + if get_payload "dead" <> None then Some File_annotations.Dead + else if get_payload "live" <> None then Some File_annotations.Live + else if get_payload "genType" <> None then Some File_annotations.GenType + else None + in + + let value_binding self + ({vb_attributes; vb_pat} as value_binding : Typedtree.value_binding) = + (match vb_pat.pat_desc with + | Tpat_var (id, {loc = {loc_start = pos}}) + | Tpat_alias ({pat_desc = Tpat_any}, id, {loc = {loc_start = pos}}) -> + if !currently_disable_warnings then + File_annotations.annotate_live state pos; + vb_attributes + |> process_attributes ~scope_default:!current_scope_default ~state ~config + ~do_gen_type ~name:(id |> Ident.name) ~pos + | _ -> ()); + super.value_binding self value_binding + in + let type_kind toplevel_attrs self (type_kind : Typedtree.type_kind) = + (match type_kind with + | Ttype_record label_declarations -> + label_declarations + |> List.iter + (fun ({ld_attributes; ld_loc} : Typedtree.label_declaration) -> + toplevel_attrs @ ld_attributes + |> process_attributes ~scope_default:!current_scope_default ~state + ~config ~do_gen_type:false ~name:"" ~pos:ld_loc.loc_start) + | Ttype_variant constructor_declarations -> + constructor_declarations + |> List.iter + (fun + ({cd_attributes; cd_loc; cd_args} : + Typedtree.constructor_declaration) + -> + let _process_inline_records = + match cd_args with + | Cstr_record flds -> + List.iter + (fun ({ld_attributes; ld_loc} : Typedtree.label_declaration) + -> + toplevel_attrs @ cd_attributes @ ld_attributes + |> process_attributes ~scope_default:!current_scope_default + ~state ~config ~do_gen_type:false ~name:"" + ~pos:ld_loc.loc_start) + flds + | Cstr_tuple _ -> () + in + toplevel_attrs @ cd_attributes + |> process_attributes ~scope_default:!current_scope_default ~state + ~config ~do_gen_type:false ~name:"" ~pos:cd_loc.loc_start) + | _ -> ()); + super.type_kind self type_kind + in + let type_declaration self (type_declaration : Typedtree.type_declaration) = + let attributes = type_declaration.typ_attributes in + let _ = type_kind attributes self type_declaration.typ_kind in + type_declaration + in + let value_description self + ({val_attributes; val_id; val_val = {val_loc = {loc_start = pos}}} as + value_description : + Typedtree.value_description) = + if !currently_disable_warnings then File_annotations.annotate_live state pos; + val_attributes + |> process_attributes ~scope_default:!current_scope_default ~state ~config + ~do_gen_type ~name:(val_id |> Ident.name) ~pos; + super.value_description self value_description + in + let structure_item self (item : Typedtree.structure_item) = + (match item.str_desc with + | Tstr_attribute attribute -> ( + match scope_default_from_toplevel_attribute attribute with + | Some _ as new_default -> current_scope_default := new_default + | None -> + if [attribute] |> Annotation.is_ocaml_suppress_dead_warning then + currently_disable_warnings := true) + | _ -> ()); + super.structure_item self item + in + let structure self (structure : Typedtree.structure) = + let old_disable_warnings = !currently_disable_warnings in + let old_scope_default = !current_scope_default in + super.structure self structure |> ignore; + currently_disable_warnings := old_disable_warnings; + current_scope_default := old_scope_default; + structure + in + let signature_item self (item : Typedtree.signature_item) = + (match item.sig_desc with + | Tsig_attribute attribute -> ( + match scope_default_from_toplevel_attribute attribute with + | Some _ as new_default -> current_scope_default := new_default + | None -> + if [attribute] |> Annotation.is_ocaml_suppress_dead_warning then + currently_disable_warnings := true) + | _ -> ()); + super.signature_item self item + in + let signature self (signature : Typedtree.signature) = + let old_disable_warnings = !currently_disable_warnings in + let old_scope_default = !current_scope_default in + super.signature self signature |> ignore; + currently_disable_warnings := old_disable_warnings; + current_scope_default := old_scope_default; + signature + in + { + super with + signature; + signature_item; + structure; + structure_item; + type_declaration; + value_binding; + value_description; + } + +let structure ~state ~config ~do_gen_type structure = + let mapper = collect_export_locations ~state ~config ~do_gen_type in + structure |> mapper.structure mapper |> ignore + +let signature ~state ~config signature = + let mapper = collect_export_locations ~state ~config ~do_gen_type:true in + signature |> mapper.signature mapper |> ignore diff --git a/analysis/reanalyze/src/CollectAnnotations.mli b/analysis/reanalyze/src/collect_annotations.mli similarity index 71% rename from analysis/reanalyze/src/CollectAnnotations.mli rename to analysis/reanalyze/src/collect_annotations.mli index c81279e3961..eee9f4c1736 100644 --- a/analysis/reanalyze/src/CollectAnnotations.mli +++ b/analysis/reanalyze/src/collect_annotations.mli @@ -3,16 +3,16 @@ Traverses the typed AST and records annotations in a FileAnnotations.builder. *) val structure : - state:FileAnnotations.builder -> - config:DceConfig.t -> - doGenType:bool -> + state:File_annotations.builder -> + config:Dce_config.t -> + do_gen_type:bool -> Typedtree.structure -> unit (** Traverse a structure and collect annotations. *) val signature : - state:FileAnnotations.builder -> - config:DceConfig.t -> + state:File_annotations.builder -> + config:Dce_config.t -> Typedtree.signature -> unit (** Traverse a signature and collect annotations. *) diff --git a/analysis/reanalyze/src/CrossFileItems.ml b/analysis/reanalyze/src/cross_file_items.ml similarity index 90% rename from analysis/reanalyze/src/CrossFileItems.ml rename to analysis/reanalyze/src/cross_file_items.ml index f51e55a4685..81ccc951119 100644 --- a/analysis/reanalyze/src/CrossFileItems.ml +++ b/analysis/reanalyze/src/cross_file_items.ml @@ -5,7 +5,7 @@ (** {2 Item types} *) -type exception_ref = {exception_path: DcePath.t; loc_from: Location.t} +type exception_ref = {exception_path: Dce_path.t; loc_from: Location.t} type optional_arg_call = { pos_from: Lexing.position; @@ -75,6 +75,5 @@ let process_exception_refs (t : t) ~refs ~file_deps ~find_exception ~config = match find_exception exception_path with | None -> () | Some loc_to -> - DeadCommon.addValueReference ~config ~refs ~file_deps - ~binding:Location.none ~addFileReference:true ~locFrom:loc_from - ~locTo:loc_to) + Dead_common.add_value_reference ~config ~refs ~file_deps + ~binding:Location.none ~add_file_reference:true ~loc_from ~loc_to) diff --git a/analysis/reanalyze/src/CrossFileItems.mli b/analysis/reanalyze/src/cross_file_items.mli similarity index 89% rename from analysis/reanalyze/src/CrossFileItems.mli rename to analysis/reanalyze/src/cross_file_items.mli index 93141b10046..1fb9b92cbf1 100644 --- a/analysis/reanalyze/src/CrossFileItems.mli +++ b/analysis/reanalyze/src/cross_file_items.mli @@ -7,7 +7,7 @@ (** {2 Item types} *) -type exception_ref = {exception_path: DcePath.t; loc_from: Location.t} +type exception_ref = {exception_path: Dce_path.t; loc_from: Location.t} type optional_arg_call = { pos_from: Lexing.position; @@ -35,7 +35,7 @@ type builder val create_builder : unit -> builder val add_exception_ref : - builder -> exception_path:DcePath.t -> loc_from:Location.t -> unit + builder -> exception_path:Dce_path.t -> loc_from:Location.t -> unit (** Add a cross-file exception reference (defined in another file). *) val add_optional_arg_call : @@ -66,9 +66,9 @@ val builder_to_t : builder -> t val process_exception_refs : t -> refs:References.builder -> - file_deps:FileDeps.builder -> - find_exception:(DcePath.t -> Location.t option) -> - config:DceConfig.t -> + file_deps:File_deps.builder -> + find_exception:(Dce_path.t -> Location.t option) -> + config:Dce_config.t -> unit (** Process cross-file exception references. *) diff --git a/analysis/reanalyze/src/CrossFileItemsStore.ml b/analysis/reanalyze/src/cross_file_items_store.ml similarity index 58% rename from analysis/reanalyze/src/CrossFileItemsStore.ml rename to analysis/reanalyze/src/cross_file_items_store.ml index 33e5a756d6d..3a07beb11dc 100644 --- a/analysis/reanalyze/src/CrossFileItemsStore.ml +++ b/analysis/reanalyze/src/cross_file_items_store.ml @@ -5,8 +5,8 @@ - [Reactive]: Direct iteration over reactive collection (no intermediate allocation) *) type t = - | Frozen of CrossFileItems.t - | Reactive of (string, CrossFileItems.t) Reactive.t + | Frozen of Cross_file_items.t + | Reactive of (string, Cross_file_items.t) Reactive.t let of_frozen cfi = Frozen cfi @@ -14,54 +14,53 @@ let of_reactive reactive = Reactive reactive let iter_optional_arg_calls t f = match t with - | Frozen cfi -> List.iter f cfi.CrossFileItems.optional_arg_calls + | Frozen cfi -> List.iter f cfi.Cross_file_items.optional_arg_calls | Reactive r -> Reactive.iter - (fun _path items -> List.iter f items.CrossFileItems.optional_arg_calls) + (fun _path items -> List.iter f items.Cross_file_items.optional_arg_calls) r let iter_function_refs t f = match t with - | Frozen cfi -> List.iter f cfi.CrossFileItems.function_refs + | Frozen cfi -> List.iter f cfi.Cross_file_items.function_refs | Reactive r -> Reactive.iter - (fun _path items -> List.iter f items.CrossFileItems.function_refs) + (fun _path items -> List.iter f items.Cross_file_items.function_refs) r (** Compute optional args state from calls and function references. Returns a map from position to final OptionalArgs.t state. Pure function - does not mutate declarations. *) let compute_optional_args_state (store : t) ~find_decl ~is_live : - OptionalArgsState.t = - let state = OptionalArgsState.create () in + Optional_args_state.t = + let state = Optional_args_state.create () in (* Initialize state from declarations *) let get_state pos = - match OptionalArgsState.find_opt state pos with + match Optional_args_state.find_opt state pos with | Some s -> s | None -> ( match find_decl pos with - | Some {Decl.declKind = Value {optionalArgs}} -> optionalArgs - | _ -> OptionalArgs.empty) + | Some {Decl.decl_kind = Value {optional_args}} -> optional_args + | _ -> Optional_args.empty) in - let set_state pos s = OptionalArgsState.set state pos s in + let set_state pos s = Optional_args_state.set state pos s in (* Process optional arg calls *) iter_optional_arg_calls store - (fun {CrossFileItems.pos_from; pos_to; arg_names; arg_names_maybe} -> + (fun {Cross_file_items.pos_from; pos_to; arg_names; arg_names_maybe} -> if is_live pos_from then let current = get_state pos_to in let updated = - OptionalArgs.apply_call ~argNames:arg_names - ~argNamesMaybe:arg_names_maybe current + Optional_args.apply_call ~arg_names ~arg_names_maybe current in set_state pos_to updated); (* Process function references *) - iter_function_refs store (fun {CrossFileItems.pos_from; pos_to} -> + iter_function_refs store (fun {Cross_file_items.pos_from; pos_to} -> if is_live pos_from then let state_from = get_state pos_from in let state_to = get_state pos_to in - if not (OptionalArgs.isEmpty state_to) then ( + if not (Optional_args.is_empty state_to) then ( let updated_from, updated_to = - OptionalArgs.combine_pair state_from state_to + Optional_args.combine_pair state_from state_to in set_state pos_from updated_from; set_state pos_to updated_to)); diff --git a/analysis/reanalyze/src/CrossFileItemsStore.mli b/analysis/reanalyze/src/cross_file_items_store.mli similarity index 68% rename from analysis/reanalyze/src/CrossFileItemsStore.mli rename to analysis/reanalyze/src/cross_file_items_store.mli index 98eda6d3d7c..f8da5db43c8 100644 --- a/analysis/reanalyze/src/CrossFileItemsStore.mli +++ b/analysis/reanalyze/src/cross_file_items_store.mli @@ -5,26 +5,26 @@ - [Reactive]: Direct iteration over reactive collection (no intermediate allocation) *) type t = - | Frozen of CrossFileItems.t - | Reactive of (string, CrossFileItems.t) Reactive.t + | Frozen of Cross_file_items.t + | Reactive of (string, Cross_file_items.t) Reactive.t (** Cross-file items store with exposed constructors for pattern matching *) -val of_frozen : CrossFileItems.t -> t +val of_frozen : Cross_file_items.t -> t (** Wrap a frozen [CrossFileItems.t] *) -val of_reactive : (string, CrossFileItems.t) Reactive.t -> t +val of_reactive : (string, Cross_file_items.t) Reactive.t -> t (** Wrap reactive collection directly (no intermediate collection) *) val iter_optional_arg_calls : - t -> (CrossFileItems.optional_arg_call -> unit) -> unit + t -> (Cross_file_items.optional_arg_call -> unit) -> unit (** Iterate over all optional arg calls *) -val iter_function_refs : t -> (CrossFileItems.function_ref -> unit) -> unit +val iter_function_refs : t -> (Cross_file_items.function_ref -> unit) -> unit (** Iterate over all function refs *) val compute_optional_args_state : t -> find_decl:(Lexing.position -> Decl.t option) -> is_live:(Lexing.position -> bool) -> - OptionalArgsState.t + Optional_args_state.t (** Compute optional args state from calls and function references *) diff --git a/analysis/reanalyze/src/DceConfig.ml b/analysis/reanalyze/src/dce_config.ml similarity index 75% rename from analysis/reanalyze/src/DceConfig.ml rename to analysis/reanalyze/src/dce_config.ml index ce7a074061b..0b7f3bf9ca6 100644 --- a/analysis/reanalyze/src/DceConfig.ml +++ b/analysis/reanalyze/src/dce_config.ml @@ -12,7 +12,7 @@ type cli_config = { exclude_paths: string list; } -type t = {run: RunConfig.t; cli: cli_config} +type t = {run: Run_config.t; cli: cli_config} (** Capture the current DCE configuration from global state. @@ -24,9 +24,9 @@ let current () = debug = !Cli.debug; ci = !Cli.ci; json = !Cli.json; - live_names = !Cli.liveNames; - live_paths = !Cli.livePaths; - exclude_paths = !Cli.excludePaths; + live_names = !Cli.live_names; + live_paths = !Cli.live_paths; + exclude_paths = !Cli.exclude_paths; } in - {run = RunConfig.runConfig; cli} + {run = Run_config.run_config; cli} diff --git a/analysis/reanalyze/src/DceFileProcessing.ml b/analysis/reanalyze/src/dce_file_processing.ml similarity index 53% rename from analysis/reanalyze/src/DceFileProcessing.ml rename to analysis/reanalyze/src/dce_file_processing.ml index 8b18d01aa12..626a5c845b4 100644 --- a/analysis/reanalyze/src/DceFileProcessing.ml +++ b/analysis/reanalyze/src/dce_file_processing.ml @@ -4,7 +4,7 @@ and returns them for merging. The caller freezes them before passing to the solver. *) -open DeadCommon +open Dead_common (* ===== File context ===== *) @@ -15,13 +15,13 @@ type file_context = { } let module_name_tagged (file : file_context) = - file.module_name |> Name.create ~isInterface:file.is_interface + file.module_name |> Name.create ~is_interface:file.is_interface (* ===== Signature processing ===== *) -let processSignature ~config ~decls ~(file : file_context) ~doValues ~doTypes +let process_signature ~config ~decls ~(file : file_context) ~do_values ~do_types (signature : Types.signature) = - let dead_common_file : FileContext.t = + let dead_common_file : File_context.t = { source_path = file.source_path; module_name = file.module_name; @@ -30,26 +30,26 @@ let processSignature ~config ~decls ~(file : file_context) ~doValues ~doTypes in signature |> List.iter (fun sig_item -> - DeadValue.processSignatureItem ~config ~decls ~file:dead_common_file - ~doValues ~doTypes ~moduleLoc:Location.none - ~modulePath:ModulePath.initial + Dead_value.process_signature_item ~config ~decls ~file:dead_common_file + ~do_values ~do_types ~module_loc:Location.none + ~module_path:Module_path.initial ~path:[module_name_tagged file] sig_item) (* ===== Main entry point ===== *) type file_data = { - annotations: FileAnnotations.builder; + annotations: File_annotations.builder; decls: Declarations.builder; refs: References.builder; - cross_file: CrossFileItems.builder; - file_deps: FileDeps.builder; + cross_file: Cross_file_items.builder; + file_deps: File_deps.builder; } -let process_cmt_file ~config ~(file : file_context) ~cmtFilePath +let process_cmt_file ~config ~(file : file_context) ~cmt_file_path (cmt_infos : Cmt_format.cmt_infos) : file_data = (* Convert to DeadCommon.FileContext for functions that need it *) - let dead_common_file : FileContext.t = + let dead_common_file : File_context.t = { source_path = file.source_path; module_name = file.module_name; @@ -57,29 +57,29 @@ let process_cmt_file ~config ~(file : file_context) ~cmtFilePath } in (* Mutable builders for AST processing *) - let annotations = FileAnnotations.create_builder () in + let annotations = File_annotations.create_builder () in let decls = Declarations.create_builder () in let refs = References.create_builder () in - let cross_file = CrossFileItems.create_builder () in - let file_deps = FileDeps.create_builder () in + let cross_file = Cross_file_items.create_builder () in + let file_deps = File_deps.create_builder () in (* Register this file *) - FileDeps.add_file file_deps file.source_path; + File_deps.add_file file_deps file.source_path; (match cmt_infos.cmt_annots with | Interface signature -> - CollectAnnotations.signature ~state:annotations ~config signature; - processSignature ~config ~decls ~file ~doValues:true ~doTypes:true + Collect_annotations.signature ~state:annotations ~config signature; + process_signature ~config ~decls ~file ~do_values:true ~do_types:true signature.sig_type | Implementation structure -> - let cmtiExists = - Sys.file_exists ((cmtFilePath |> Filename.remove_extension) ^ ".cmti") + let cmti_exists = + Sys.file_exists ((cmt_file_path |> Filename.remove_extension) ^ ".cmti") in - CollectAnnotations.structure ~state:annotations ~config - ~doGenType:(not cmtiExists) structure; - processSignature ~config ~decls ~file ~doValues:true ~doTypes:false + Collect_annotations.structure ~state:annotations ~config + ~do_gen_type:(not cmti_exists) structure; + process_signature ~config ~decls ~file ~do_values:true ~do_types:false structure.str_type; - let doExternals = false in - DeadValue.processStructure ~config ~decls ~refs ~file_deps ~cross_file - ~file:dead_common_file ~doTypes:true ~doExternals + let do_externals = false in + Dead_value.process_structure ~config ~decls ~refs ~file_deps ~cross_file + ~file:dead_common_file ~do_types:true ~do_externals ~cmt_value_dependencies:cmt_infos.cmt_value_dependencies structure | _ -> ()); (* Return builders - caller will merge and freeze *) diff --git a/analysis/reanalyze/src/DceFileProcessing.mli b/analysis/reanalyze/src/dce_file_processing.mli similarity index 82% rename from analysis/reanalyze/src/DceFileProcessing.mli rename to analysis/reanalyze/src/dce_file_processing.mli index 09b12aa3227..f3485a1daf5 100644 --- a/analysis/reanalyze/src/DceFileProcessing.mli +++ b/analysis/reanalyze/src/dce_file_processing.mli @@ -12,18 +12,18 @@ type file_context = { (** File context for processing *) type file_data = { - annotations: FileAnnotations.builder; + annotations: File_annotations.builder; decls: Declarations.builder; refs: References.builder; - cross_file: CrossFileItems.builder; - file_deps: FileDeps.builder; + cross_file: Cross_file_items.builder; + file_deps: File_deps.builder; } (** Result of processing a cmt file - annotations, declarations, references, cross-file items, and file dependencies *) val process_cmt_file : - config:DceConfig.t -> + config:Dce_config.t -> file:file_context -> - cmtFilePath:string -> + cmt_file_path:string -> Cmt_format.cmt_infos -> file_data (** Process a cmt file and return mutable builders. diff --git a/analysis/reanalyze/src/dce_path.ml b/analysis/reanalyze/src/dce_path.ml new file mode 100644 index 00000000000..c6913548a32 --- /dev/null +++ b/analysis/reanalyze/src/dce_path.ml @@ -0,0 +1,49 @@ +(** Path representation for dead code analysis. + A path is a list of names, e.g. [MyModule; myFunction] *) + +type t = Name.t list + +let to_name (path : t) = + path |> List.rev_map Name.to_string |> String.concat "." |> Name.create + +let to_string path = path |> to_name |> Name.to_string + +let without_head path = + match + path |> List.rev_map (fun n -> n |> Name.to_interface |> Name.to_string) + with + | _ :: tl -> tl |> String.concat "." + | [] -> "" + +let on_ok_path ~when_contains_apply ~f path = + match path |> Path.flatten with + | `Ok (id, mods) -> f (Ident.name id :: mods |> String.concat ".") + | `Contains_apply -> when_contains_apply + +let from_path_t path = + match path |> Path.flatten with + | `Ok (id, mods) -> Ident.name id :: mods |> List.rev_map Name.create + | `Contains_apply -> [] + +let module_to_implementation path = + match path |> List.rev with + | module_name :: rest -> + (module_name |> Name.to_implementation) :: rest |> List.rev + | [] -> path + +let module_to_interface path = + match path |> List.rev with + | module_name :: rest -> + (module_name |> Name.to_interface) :: rest |> List.rev + | [] -> path + +let to_module_name ~is_type path = + match path with + | _ :: tl when not is_type -> tl |> to_name + | _ :: _ :: tl when is_type -> tl |> to_name + | _ -> "" |> Name.create + +let type_to_interface path = + match path with + | type_name :: rest -> (type_name |> Name.to_interface) :: rest + | [] -> path diff --git a/analysis/reanalyze/src/DeadCode.ml b/analysis/reanalyze/src/dead_code.ml similarity index 65% rename from analysis/reanalyze/src/DeadCode.ml rename to analysis/reanalyze/src/dead_code.ml index d52b784a47c..e97abaa18bf 100644 --- a/analysis/reanalyze/src/DeadCode.ml +++ b/analysis/reanalyze/src/dead_code.ml @@ -1,4 +1,4 @@ (** Dead code analysis - cmt file processing. Delegates to DceFileProcessing for AST traversal. *) -let processCmt = DceFileProcessing.process_cmt_file +let process_cmt = Dce_file_processing.process_cmt_file diff --git a/analysis/reanalyze/src/DeadCommon.ml b/analysis/reanalyze/src/dead_common.ml similarity index 55% rename from analysis/reanalyze/src/DeadCommon.ml rename to analysis/reanalyze/src/dead_common.ml index a2434473c0e..a843d68606b 100644 --- a/analysis/reanalyze/src/DeadCommon.ml +++ b/analysis/reanalyze/src/dead_common.ml @@ -1,36 +1,36 @@ -module FileContext = struct +module File_context = struct type t = {source_path: string; module_name: string; is_interface: bool} (** Get module name as Name.t tagged with interface/implementation info *) let module_name_tagged file = - file.module_name |> Name.create ~isInterface:file.is_interface + file.module_name |> Name.create ~is_interface:file.is_interface - let isInterface (file : t) = file.is_interface + let is_interface (file : t) = file.is_interface end (* Adapted from https://github.com/LexiFi/dead_code_analyzer *) module Config = struct (* Turn on type analysis *) - let analyzeTypes = ref true - let analyzeExternals = ref false - let reportUnderscore = false - let reportTypesDeadOnlyInInterface = false - let warnOnCircularDependencies = false + let analyze_types = ref true + let analyze_externals = ref false + let report_underscore = false + let report_types_dead_only_in_interface = false + let warn_on_circular_dependencies = false end -let rec checkSub s1 s2 n = +let rec check_sub s1 s2 n = n <= 0 || (try s1.[n] = s2.[n] with Invalid_argument _ -> false) - && checkSub s1 s2 (n - 1) + && check_sub s1 s2 (n - 1) -let fileIsImplementationOf s1 s2 = +let file_is_implementation_of s1 s2 = let n1 = String.length s1 and n2 = String.length s2 in - n2 = n1 + 1 && checkSub s1 s2 (n1 - 1) + n2 = n1 + 1 && check_sub s1 s2 (n1 - 1) -let liveAnnotation = "live" +let live_annotation = "live" -type decls = Decl.t PosHash.t +type decls = Decl.t Pos_hash.t (** type alias for declaration hashtables *) (* NOTE: Global decls removed - now using Declarations.builder/t pattern *) @@ -40,7 +40,7 @@ type decls = Decl.t PosHash.t (* Local reporting context used only while emitting dead-code warnings. It tracks, per file, the end position of the last value we reported on, so nested values inside that range don't get duplicate warnings. *) -module ReportingContext = struct +module Reporting_context = struct type t = Lexing.position ref let create () : t = ref Lexing.dummy_pos @@ -50,50 +50,50 @@ end (* NOTE: Global TypeReferences removed - now using References.builder/t pattern *) -let declGetLoc decl = +let decl_get_loc decl = let loc_start = let offset = - match decl.Decl.posAdjustment with + match decl.Decl.pos_adjustment with | FirstVariant | Nothing -> 0 | OtherVariant -> 2 in - let cnumWithOffset = decl.posStart.pos_cnum + offset in - if cnumWithOffset < decl.posEnd.pos_cnum then - {decl.posStart with pos_cnum = cnumWithOffset} - else decl.posStart + let cnum_with_offset = decl.pos_start.pos_cnum + offset in + if cnum_with_offset < decl.pos_end.pos_cnum then + {decl.pos_start with pos_cnum = cnum_with_offset} + else decl.pos_start in - {Location.loc_start; loc_end = decl.posEnd; loc_ghost = false} + {Location.loc_start; loc_end = decl.pos_end; loc_ghost = false} -let addValueReference ~config ~refs ~file_deps ~(binding : Location.t) - ~addFileReference ~(locFrom : Location.t) ~(locTo : Location.t) : unit = - let effectiveFrom = if binding = Location.none then locFrom else binding in - if not effectiveFrom.loc_ghost then ( - if config.DceConfig.cli.debug then +let add_value_reference ~config ~refs ~file_deps ~(binding : Location.t) + ~add_file_reference ~(loc_from : Location.t) ~(loc_to : Location.t) : unit = + let effective_from = if binding = Location.none then loc_from else binding in + if not effective_from.loc_ghost then ( + if config.Dce_config.cli.debug then Log_.item "addValueReference %s --> %s@." - (effectiveFrom.loc_start |> Pos.toString) - (locTo.loc_start |> Pos.toString); - References.add_value_ref refs ~posTo:locTo.loc_start - ~posFrom:effectiveFrom.loc_start; + (effective_from.loc_start |> Pos.to_string) + (loc_to.loc_start |> Pos.to_string); + References.add_value_ref refs ~pos_to:loc_to.loc_start + ~pos_from:effective_from.loc_start; if - addFileReference && (not locTo.loc_ghost) - && (not effectiveFrom.loc_ghost) - && effectiveFrom.loc_start.pos_fname <> locTo.loc_start.pos_fname + add_file_reference && (not loc_to.loc_ghost) + && (not effective_from.loc_ghost) + && effective_from.loc_start.pos_fname <> loc_to.loc_start.pos_fname then - FileDeps.add_dep file_deps ~from_file:effectiveFrom.loc_start.pos_fname - ~to_file:locTo.loc_start.pos_fname) + File_deps.add_dep file_deps ~from_file:effective_from.loc_start.pos_fname + ~to_file:loc_to.loc_start.pos_fname) -let addDeclaration_ ~config ~decls ~(file : FileContext.t) ?posEnd ?posStart - ~declKind ~path ~(loc : Location.t) ?(posAdjustment = Decl.Nothing) - ?manifestTypePath ~moduleLoc (name : Name.t) = +let addDeclaration_ ~config ~decls ~(file : File_context.t) ?pos_end ?pos_start + ~decl_kind ~path ~(loc : Location.t) ?(pos_adjustment = Decl.Nothing) + ?manifest_type_path ~module_loc (name : Name.t) = let pos = loc.loc_start in - let posStart = - match posStart with - | Some posStart -> posStart + let pos_start = + match pos_start with + | Some pos_start -> pos_start | None -> pos in - let posEnd = - match posEnd with - | Some posEnd -> posEnd + let pos_end = + match pos_end with + | Some pos_end -> pos_end | None -> loc.loc_end in (* a .cmi file can contain locations from other files. @@ -102,63 +102,64 @@ let addDeclaration_ ~config ~decls ~(file : FileContext.t) ?posEnd ?posStart will create value definitions whose location is in set.mli *) if (not loc.loc_ghost) && pos.pos_fname = file.source_path then ( - if config.DceConfig.cli.debug then + if config.Dce_config.cli.debug then Log_.item "add%sDeclaration %s %s path:%s@." - (declKind |> Decl.Kind.toString) - (name |> Name.toString) (pos |> Pos.toString) (path |> DcePath.toString); + (decl_kind |> Decl.Kind.to_string) + (name |> Name.to_string) (pos |> Pos.to_string) + (path |> Dce_path.to_string); let decl = { - Decl.declKind; - moduleLoc; - posAdjustment; + Decl.decl_kind; + module_loc; + pos_adjustment; path = name :: path; - manifestTypePath; + manifest_type_path; pos; - posEnd; - posStart; - resolvedDead = None; + pos_end; + pos_start; + resolved_dead = None; report = true; } in Declarations.add decls pos decl) -let addValueDeclaration ~config ~decls ~file ?(isToplevel = true) - ~(loc : Location.t) ~moduleLoc ?(optionalArgs = OptionalArgs.empty) ~path - ~sideEffects name = +let add_value_declaration ~config ~decls ~file ?(is_toplevel = true) + ~(loc : Location.t) ~module_loc ?(optional_args = Optional_args.empty) ~path + ~side_effects name = name |> addDeclaration_ ~config ~decls ~file - ~declKind:(Value {isToplevel; optionalArgs; sideEffects}) - ~loc ~moduleLoc ~path + ~decl_kind:(Value {is_toplevel; optional_args; side_effects}) + ~loc ~module_loc ~path (** Create a dead code issue. Pure - no side effects. *) -let makeDeadIssue ~decl ~message deadWarning : Issue.t = - let loc = decl |> declGetLoc in - AnalysisResult.make_dead_issue ~loc ~deadWarning - ~path:(DcePath.withoutHead decl.path) +let make_dead_issue ~decl ~message dead_warning : Issue.t = + let loc = decl |> decl_get_loc in + Analysis_result.make_dead_issue ~loc ~dead_warning + ~path:(Dce_path.without_head decl.path) ~message -let isInsideReportedValue (ctx : ReportingContext.t) decl = - let max_end = ReportingContext.get_max_end ctx in - let fileHasChanged = max_end.pos_fname <> decl.Decl.pos.pos_fname in - let insideReportedValue = - decl |> Decl.isValue && (not fileHasChanged) +let is_inside_reported_value (ctx : Reporting_context.t) decl = + let max_end = Reporting_context.get_max_end ctx in + let file_has_changed = max_end.pos_fname <> decl.Decl.pos.pos_fname in + let inside_reported_value = + decl |> Decl.is_value && (not file_has_changed) && max_end.pos_cnum > decl.pos.pos_cnum in - if not insideReportedValue then - if decl |> Decl.isValue then - if fileHasChanged || decl.posEnd.pos_cnum > max_end.pos_cnum then - ReportingContext.set_max_end ctx decl.posEnd; - insideReportedValue + if not inside_reported_value then + if decl |> Decl.is_value then + if file_has_changed || decl.pos_end.pos_cnum > max_end.pos_cnum then + Reporting_context.set_max_end ctx decl.pos_end; + inside_reported_value (** Check if a reference position is "below" the declaration. A ref is below if it's in a different file, or comes after the declaration (but not inside it, e.g. not a callback). *) -let refIsBelow (decl : Decl.t) (posFrom : Lexing.position) = - decl.pos.pos_fname <> posFrom.pos_fname - || decl.pos.pos_cnum < posFrom.pos_cnum +let ref_is_below (decl : Decl.t) (pos_from : Lexing.position) = + decl.pos.pos_fname <> pos_from.pos_fname + || decl.pos.pos_cnum < pos_from.pos_cnum && (* not a function defined inside a function, e.g. not a callback *) - decl.posEnd.pos_cnum < posFrom.pos_cnum + decl.pos_end.pos_cnum < pos_from.pos_cnum (** Create hasRefBelow function using on-demand per-decl search. [iter_value_refs_from] iterates over (posFrom, posToSet) pairs. @@ -167,9 +168,9 @@ let make_hasRefBelow ~transitive ~iter_value_refs_from = if transitive then fun _ -> false else fun decl -> let found = ref false in - iter_value_refs_from (fun posFrom posToSet -> - if (not !found) && PosSet.mem decl.Decl.pos posToSet then - if refIsBelow decl posFrom then found := true); + iter_value_refs_from (fun pos_from pos_to_set -> + if (not !found) && Pos_set.mem decl.Decl.pos pos_to_set then + if ref_is_below decl pos_from then found := true); !found (** Report a dead declaration. Returns list of issues (dead module first, then dead value). @@ -177,11 +178,11 @@ let make_hasRefBelow ~transitive ~iter_value_refs_from = Only used when [config.run.transitive] is false. [?checkModuleDead] optional callback for checking dead modules. Defaults to DeadModules.checkModuleDead. [?shouldReport] optional callback to check if a decl should be reported. Defaults to checking decl.report. *) -let reportDeclaration ~config ~hasRefBelow ?checkModuleDead ?shouldReport - (ctx : ReportingContext.t) decl : Issue.t list = - let insideReportedValue = decl |> isInsideReportedValue ctx in +let report_declaration ~config ~has_ref_below ?check_module_dead ?should_report + (ctx : Reporting_context.t) decl : Issue.t list = + let inside_reported_value = decl |> is_inside_reported_value ctx in let should_report = - match shouldReport with + match should_report with | Some f -> f decl | None -> decl.report in @@ -191,34 +192,34 @@ let reportDeclaration ~config ~hasRefBelow ?checkModuleDead ?shouldReport let should_report = should_report && - match (decl.declKind, decl.manifestTypePath) with + match (decl.decl_kind, decl.manifest_type_path) with | (RecordLabel | VariantCase), Some _ -> false | _ -> true in if not should_report then [] else - let deadWarning, message = - match decl.declKind with + let dead_warning, message = + match decl.decl_kind with | Exception -> (Issue.WarningDeadException, "is never raised or passed as value") - | Value {sideEffects} -> ( - let noSideEffectsOrUnderscore = - (not sideEffects) + | Value {side_effects} -> ( + let no_side_effects_or_underscore = + (not side_effects) || match decl.path with - | hd :: _ -> hd |> Name.startsWithUnderscore + | hd :: _ -> hd |> Name.starts_with_underscore | [] -> false in - ( (match not noSideEffectsOrUnderscore with + ( (match not no_side_effects_or_underscore with | true -> WarningDeadValueWithSideEffects | false -> WarningDeadValue), match decl.path with - | name :: _ when name |> Name.isUnderscore -> + | name :: _ when name |> Name.is_underscore -> "has no side effects and can be removed" | _ -> ( "is never used" ^ - match not noSideEffectsOrUnderscore with + match not no_side_effects_or_underscore with | true -> " and could have side effects" | false -> "") )) | RecordLabel -> @@ -226,48 +227,48 @@ let reportDeclaration ~config ~hasRefBelow ?checkModuleDead ?shouldReport | VariantCase -> (WarningDeadType, "is a variant case which is never constructed") in - let shouldEmitWarning = - (not insideReportedValue) + let should_emit_warning = + (not inside_reported_value) && (match decl.path with - | name :: _ when name |> Name.isUnderscore -> Config.reportUnderscore + | name :: _ when name |> Name.is_underscore -> Config.report_underscore | _ -> true) - && (config.DceConfig.run.transitive || not (hasRefBelow decl)) + && (config.Dce_config.run.transitive || not (has_ref_below decl)) in - if shouldEmitWarning then - let moduleName = + if should_emit_warning then + let module_name = decl.path - |> DcePath.toModuleName ~isType:(decl.declKind |> Decl.Kind.isType) + |> Dce_path.to_module_name ~is_type:(decl.decl_kind |> Decl.Kind.is_type) in let dead_module_issue = - match checkModuleDead with - | Some f -> f ~fileName:decl.pos.pos_fname moduleName + match check_module_dead with + | Some f -> f ~file_name:decl.pos.pos_fname module_name | None -> - DeadModules.checkModuleDead ~config ~fileName:decl.pos.pos_fname - moduleName + Dead_modules.check_module_dead ~config ~file_name:decl.pos.pos_fname + module_name in - let dead_value_issue = makeDeadIssue ~decl ~message deadWarning in + let dead_value_issue = make_dead_issue ~decl ~message dead_warning in (* Return in order: dead module first (if any), then dead value *) match dead_module_issue with | Some mi -> [mi; dead_value_issue] | None -> [dead_value_issue] else [] -let doReportDead ~ann_store pos = - not (AnnotationStore.is_annotated_gentype_or_dead ann_store pos) +let do_report_dead ~ann_store pos = + not (Annotation_store.is_annotated_gentype_or_dead ann_store pos) (** Forward-based solver using refs_from direction. Computes liveness via forward propagation, then processes declarations. *) -let solveDeadForward ~ann_store ~config ~decl_store ~refs ~optional_args_state - ~checkOptionalArg: - (checkOptionalArgFn : - optional_args_state:OptionalArgsState.t -> - ann_store:AnnotationStore.t -> - config:DceConfig.t -> +let solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state + ~check_optional_arg: + (check_optional_arg_fn : + optional_args_state:Optional_args_state.t -> + ann_store:Annotation_store.t -> + config:Dce_config.t -> Decl.t -> - Issue.t list) : AnalysisResult.t = + Issue.t list) : Analysis_result.t = (* Compute liveness using forward propagation *) - let debug = config.DceConfig.cli.debug in - let transitive = config.DceConfig.run.transitive in + let debug = config.Dce_config.cli.debug in + let transitive = config.Dce_config.run.transitive in let live, decl_refs_index = Liveness.compute_forward ~debug ~decl_store ~refs ~ann_store in @@ -275,24 +276,24 @@ let solveDeadForward ~ann_store ~config ~decl_store ~refs ~optional_args_state (* For debug logging: invert decl_refs_index to get incoming deps between declarations. This is useful for understanding why something is dead ("who points to it?") even though the solver itself is forward. *) - let incoming_decl_deps : PosSet.t PosHash.t = - if not debug then PosHash.create 0 + let incoming_decl_deps : Pos_set.t Pos_hash.t = + if not debug then Pos_hash.create 0 else - let incoming = PosHash.create 256 in + let incoming = Pos_hash.create 256 in let add_incoming ~target ~source = let existing = - match PosHash.find_opt incoming target with + match Pos_hash.find_opt incoming target with | Some s -> s - | None -> PosSet.empty + | None -> Pos_set.empty in - PosHash.replace incoming target (PosSet.add source existing) + Pos_hash.replace incoming target (Pos_set.add source existing) in - PosHash.iter + Pos_hash.iter (fun source_pos (value_targets, type_targets) -> let add_targets targets = - PosSet.iter + Pos_set.iter (fun target_pos -> - match DeclarationStore.find_opt decl_store target_pos with + match Declaration_store.find_opt decl_store target_pos with | Some _ -> add_incoming ~target:target_pos ~source:source_pos | None -> ()) targets @@ -304,19 +305,19 @@ let solveDeadForward ~ann_store ~config ~decl_store ~refs ~optional_args_state in (* hasRefBelow uses on-demand search through refs_from *) - let hasRefBelow = + let has_ref_below = make_hasRefBelow ~transitive ~iter_value_refs_from:(References.iter_value_refs_from refs) in (* Process each declaration based on computed liveness *) - let deadDeclarations = ref [] in + let dead_declarations = ref [] in let inline_issues = ref [] in (* For consistent debug output, collect and sort declarations *) let all_decls = - DeclarationStore.fold (fun _pos decl acc -> decl :: acc) decl_store [] - |> List.fast_sort Decl.compareForReporting + Declaration_store.fold (fun _pos decl acc -> decl :: acc) decl_store [] + |> List.fast_sort Decl.compare_for_reporting in all_decls @@ -337,18 +338,18 @@ let solveDeadForward ~ann_store ~config ~decl_store ~refs ~optional_args_state Printf.sprintf "Live (%s)" (Liveness.reason_to_string reason) in Log_.item "%s %s %s@." status - (decl.declKind |> Decl.Kind.toString) - (decl.path |> DcePath.toString); + (decl.decl_kind |> Decl.Kind.to_string) + (decl.path |> Dce_path.to_string); (* Print dependency context to help understand why a decl is (not) live. This is declaration-to-declaration deps only, derived from refs_from. *) let outgoing_to_decls = - match PosHash.find_opt decl_refs_index pos with + match Pos_hash.find_opt decl_refs_index pos with | None -> 0 | Some (value_targets, type_targets) -> let count_targets targets = - PosSet.fold + Pos_set.fold (fun target acc -> - match DeclarationStore.find_opt decl_store target with + match Declaration_store.find_opt decl_store target with | Some _ -> acc + 1 | None -> acc) targets 0 @@ -356,14 +357,14 @@ let solveDeadForward ~ann_store ~config ~decl_store ~refs ~optional_args_state count_targets value_targets + count_targets type_targets in let incoming_from_decls, incoming_from_live_decls = - match PosHash.find_opt incoming_decl_deps pos with + match Pos_hash.find_opt incoming_decl_deps pos with | None -> (0, 0) | Some sources -> - let total = PosSet.cardinal sources in + let total = Pos_set.cardinal sources in let live_src = - PosSet.fold + Pos_set.fold (fun src acc -> - if PosHash.mem live src then acc + 1 else acc) + if Pos_hash.mem live src then acc + 1 else acc) sources 0 in (total, live_src) @@ -376,40 +377,41 @@ let solveDeadForward ~ann_store ~config ~decl_store ~refs ~optional_args_state (* For debugging, print a small sample of incoming/outgoing decl deps. This is meant to answer: "what would make this decl live?" *) let max_show = 3 in - (match PosHash.find_opt incoming_decl_deps pos with + (match Pos_hash.find_opt incoming_decl_deps pos with | None -> () | Some sources -> let shown = ref 0 in - PosSet.iter + Pos_set.iter (fun src_pos -> if !shown < max_show then ( incr shown; - match DeclarationStore.find_opt decl_store src_pos with + match Declaration_store.find_opt decl_store src_pos with | Some src_decl -> let src_status = - if PosHash.mem live src_pos then "live" else "dead" + if Pos_hash.mem live src_pos then "live" else "dead" in Log_.item " <- %s (%s)@." - (src_decl.path |> DcePath.toString) + (src_decl.path |> Dce_path.to_string) src_status | None -> ())) sources; - if PosSet.cardinal sources > max_show then + if Pos_set.cardinal sources > max_show then Log_.item " <- ... (%d more)@." - (PosSet.cardinal sources - max_show)); - match PosHash.find_opt decl_refs_index pos with + (Pos_set.cardinal sources - max_show)); + match Pos_hash.find_opt decl_refs_index pos with | None -> () | Some (value_targets, type_targets) -> let show_target target = - match DeclarationStore.find_opt decl_store target with + match Declaration_store.find_opt decl_store target with | None -> false | Some target_decl -> - Log_.item " -> %s@." (target_decl.path |> DcePath.toString); + Log_.item " -> %s@." + (target_decl.path |> Dce_path.to_string); true in let shown = ref 0 in let try_show targets = - PosSet.iter + Pos_set.iter (fun target -> if !shown < max_show then if show_target target then incr shown) @@ -421,70 +423,72 @@ let solveDeadForward ~ann_store ~config ~decl_store ~refs ~optional_args_state Log_.item " -> ... (%d more)@." (outgoing_to_decls - max_show)); - decl.resolvedDead <- Some is_dead; + decl.resolved_dead <- Some is_dead; if is_dead then ( decl.path - |> DeadModules.markDead ~config - ~isType:(decl.declKind |> Decl.Kind.isType) - ~loc:decl.moduleLoc; - if not (doReportDead ~ann_store decl.pos) then decl.report <- false; - deadDeclarations := decl :: !deadDeclarations) + |> Dead_modules.mark_dead ~config + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + ~loc:decl.module_loc; + if not (do_report_dead ~ann_store decl.pos) then decl.report <- false; + dead_declarations := decl :: !dead_declarations) else ( (* Collect optional args issues for live declarations *) - checkOptionalArgFn ~optional_args_state ~ann_store ~config decl + check_optional_arg_fn ~optional_args_state ~ann_store ~config decl |> List.iter (fun issue -> inline_issues := issue :: !inline_issues); decl.path - |> DeadModules.markLive ~config - ~isType:(decl.declKind |> Decl.Kind.isType) - ~loc:decl.moduleLoc; - if AnnotationStore.is_annotated_dead ann_store decl.pos then ( + |> Dead_modules.mark_live ~config + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + ~loc:decl.module_loc; + if Annotation_store.is_annotated_dead ann_store decl.pos then ( (* Collect incorrect @dead annotation issue *) let issue = - makeDeadIssue ~decl ~message:" is annotated @dead but is live" + make_dead_issue ~decl ~message:" is annotated @dead but is live" IncorrectDeadAnnotation in decl.path - |> DcePath.toModuleName ~isType:(decl.declKind |> Decl.Kind.isType) - |> DeadModules.checkModuleDead ~config ~fileName:decl.pos.pos_fname + |> Dce_path.to_module_name + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + |> Dead_modules.check_module_dead ~config + ~file_name:decl.pos.pos_fname |> Option.iter (fun mod_issue -> inline_issues := mod_issue :: !inline_issues); inline_issues := issue :: !inline_issues))); - let sortedDeadDeclarations = - !deadDeclarations |> List.fast_sort Decl.compareForReporting + let sorted_dead_declarations = + !dead_declarations |> List.fast_sort Decl.compare_for_reporting in (* Collect issues from dead declarations *) - let reporting_ctx = ReportingContext.create () in + let reporting_ctx = Reporting_context.create () in let dead_issues = - sortedDeadDeclarations + sorted_dead_declarations |> List.concat_map (fun decl -> - reportDeclaration ~config ~hasRefBelow reporting_ctx decl) + report_declaration ~config ~has_ref_below reporting_ctx decl) in let all_issues = List.rev !inline_issues @ dead_issues in - AnalysisResult.add_issues AnalysisResult.empty all_issues + Analysis_result.add_issues Analysis_result.empty all_issues (** Reactive solver using reactive liveness collection. [value_refs_from] is only needed when [transitive=false] for hasRefBelow. Pass [None] when [transitive=true] to avoid any refs computation. *) -let solveDeadReactive ~ann_store ~config ~decl_store ~value_refs_from +let solve_dead_reactive ~ann_store ~config ~decl_store ~value_refs_from ~(live : (Lexing.position, unit) Reactive.t) ~(roots : (Lexing.position, unit) Reactive.t) ~optional_args_state - ~checkOptionalArg: - (checkOptionalArgFn : - optional_args_state:OptionalArgsState.t -> - ann_store:AnnotationStore.t -> - config:DceConfig.t -> + ~check_optional_arg: + (check_optional_arg_fn : + optional_args_state:Optional_args_state.t -> + ann_store:Annotation_store.t -> + config:Dce_config.t -> Decl.t -> - Issue.t list) : AnalysisResult.t = + Issue.t list) : Analysis_result.t = let t0 = Unix.gettimeofday () in - let debug = config.DceConfig.cli.debug in - let transitive = config.DceConfig.run.transitive in + let debug = config.Dce_config.cli.debug in + let transitive = config.Dce_config.run.transitive in let is_live pos = Reactive.get live pos <> None in (* hasRefBelow uses on-demand search through value_refs_from *) - let hasRefBelow = + let has_ref_below = match value_refs_from with | None -> fun _ -> false | Some refs_from -> @@ -493,16 +497,16 @@ let solveDeadReactive ~ann_store ~config ~decl_store ~value_refs_from in (* Process each declaration based on computed liveness *) - let deadDeclarations = ref [] in + let dead_declarations = ref [] in let inline_issues = ref [] in let t1 = Unix.gettimeofday () in (* For consistent debug output, collect and sort declarations *) let all_decls = - DeclarationStore.fold (fun _pos decl acc -> decl :: acc) decl_store [] + Declaration_store.fold (fun _pos decl acc -> decl :: acc) decl_store [] in let t2 = Unix.gettimeofday () in - let all_decls = all_decls |> List.fast_sort Decl.compareForReporting in + let all_decls = all_decls |> List.fast_sort Decl.compare_for_reporting in let t3 = Unix.gettimeofday () in let num_decls = List.length all_decls in @@ -523,7 +527,7 @@ let solveDeadReactive ~ann_store ~config ~decl_store ~value_refs_from let live_reason : Liveness.live_reason option = if not is_live then None else if Reactive.get roots pos <> None then - if AnnotationStore.is_annotated_gentype_or_live ann_store pos + if Annotation_store.is_annotated_gentype_or_live ann_store pos then Some Liveness.Annotated else Some Liveness.ExternalRef else Some Liveness.Propagated @@ -535,53 +539,55 @@ let solveDeadReactive ~ann_store ~config ~decl_store ~value_refs_from Printf.sprintf "Live (%s)" (Liveness.reason_to_string reason) in Log_.item "%s %s %s@." status - (decl.declKind |> Decl.Kind.toString) - (decl.path |> DcePath.toString)); + (decl.decl_kind |> Decl.Kind.to_string) + (decl.path |> Dce_path.to_string)); - decl.resolvedDead <- Some is_dead; + decl.resolved_dead <- Some is_dead; if is_dead then ( incr num_dead; decl.path - |> DeadModules.markDead ~config - ~isType:(decl.declKind |> Decl.Kind.isType) - ~loc:decl.moduleLoc; - if not (doReportDead ~ann_store decl.pos) then decl.report <- false; - deadDeclarations := decl :: !deadDeclarations) + |> Dead_modules.mark_dead ~config + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + ~loc:decl.module_loc; + if not (do_report_dead ~ann_store decl.pos) then decl.report <- false; + dead_declarations := decl :: !dead_declarations) else ( incr num_live; (* Collect optional args issues for live declarations *) - checkOptionalArgFn ~optional_args_state ~ann_store ~config decl + check_optional_arg_fn ~optional_args_state ~ann_store ~config decl |> List.iter (fun issue -> inline_issues := issue :: !inline_issues); decl.path - |> DeadModules.markLive ~config - ~isType:(decl.declKind |> Decl.Kind.isType) - ~loc:decl.moduleLoc; - if AnnotationStore.is_annotated_dead ann_store decl.pos then ( + |> Dead_modules.mark_live ~config + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + ~loc:decl.module_loc; + if Annotation_store.is_annotated_dead ann_store decl.pos then ( (* Collect incorrect @dead annotation issue *) let issue = - makeDeadIssue ~decl ~message:" is annotated @dead but is live" + make_dead_issue ~decl ~message:" is annotated @dead but is live" IncorrectDeadAnnotation in decl.path - |> DcePath.toModuleName ~isType:(decl.declKind |> Decl.Kind.isType) - |> DeadModules.checkModuleDead ~config ~fileName:decl.pos.pos_fname + |> Dce_path.to_module_name + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + |> Dead_modules.check_module_dead ~config + ~file_name:decl.pos.pos_fname |> Option.iter (fun mod_issue -> inline_issues := mod_issue :: !inline_issues); inline_issues := issue :: !inline_issues))); let t4 = Unix.gettimeofday () in - let sortedDeadDeclarations = - !deadDeclarations |> List.fast_sort Decl.compareForReporting + let sorted_dead_declarations = + !dead_declarations |> List.fast_sort Decl.compare_for_reporting in let t5 = Unix.gettimeofday () in (* Collect issues from dead declarations *) - let reporting_ctx = ReportingContext.create () in + let reporting_ctx = Reporting_context.create () in let dead_issues = - sortedDeadDeclarations + sorted_dead_declarations |> List.concat_map (fun decl -> - reportDeclaration ~config ~hasRefBelow reporting_ctx decl) + report_declaration ~config ~has_ref_below reporting_ctx decl) in let t6 = Unix.gettimeofday () in let all_issues = List.rev !inline_issues @ dead_issues in @@ -609,15 +615,15 @@ let solveDeadReactive ~ann_store ~config ~decl_store ~value_refs_from ((t7 -. t6) *. 1000.0) ((t7 -. t0) *. 1000.0); - AnalysisResult.add_issues AnalysisResult.empty all_issues + Analysis_result.add_issues Analysis_result.empty all_issues (** Main entry point - uses forward solver. *) -let solveDead ~ann_store ~config ~decl_store ~ref_store ~optional_args_state - ~checkOptionalArg : AnalysisResult.t = - match ReferenceStore.get_refs_opt ref_store with +let solve_dead ~ann_store ~config ~decl_store ~ref_store ~optional_args_state + ~check_optional_arg : Analysis_result.t = + match Reference_store.get_refs_opt ref_store with | Some refs -> - solveDeadForward ~ann_store ~config ~decl_store ~refs ~optional_args_state - ~checkOptionalArg + solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state + ~check_optional_arg | None -> failwith "solveDead: ReferenceStore must be Frozen (use solveDeadReactive for \ diff --git a/analysis/reanalyze/src/dead_exception.ml b/analysis/reanalyze/src/dead_exception.ml new file mode 100644 index 00000000000..fd7ebca8061 --- /dev/null +++ b/analysis/reanalyze/src/dead_exception.ml @@ -0,0 +1,47 @@ +open Dead_common + +module Path_map = Map.Make (struct + type t = Dce_path.t + + let compare = Stdlib.compare +end) + +let find_exception_from_decls (decls : Declarations.t) : + Dce_path.t -> Location.t option = + let index = + Declarations.fold + (fun _pos (decl : Decl.t) acc -> + match decl.Decl.decl_kind with + | Exception -> + (* Use raw decl positions: reference graph keys are raw positions. *) + let loc : Location.t = + { + Location.loc_start = decl.pos; + loc_end = decl.pos_end; + loc_ghost = false; + } + in + Path_map.add decl.path loc acc + | _ -> acc) + decls Path_map.empty + in + fun path -> Path_map.find_opt path index + +let add ~config ~decls ~file ~path ~loc ~(str_loc : Location.t) + ~(module_loc : Location.t) name = + addDeclaration_ ~config ~decls ~file ~pos_end:str_loc.loc_end + ~pos_start:str_loc.loc_start ~decl_kind:Exception ~module_loc ~path ~loc + name; + name + +let mark_as_used ~config ~refs ~file_deps ~cross_file ~(binding : Location.t) + ~(loc_from : Location.t) ~(loc_to : Location.t) path_ = + if loc_to.loc_ghost then + (* Probably defined in another file, delay processing and check at the end *) + let exception_path = + path_ |> Dce_path.from_path_t |> Dce_path.module_to_implementation + in + Cross_file_items.add_exception_ref cross_file ~exception_path ~loc_from + else + add_value_reference ~config ~refs ~file_deps ~binding + ~add_file_reference:true ~loc_from ~loc_to diff --git a/analysis/reanalyze/src/dead_exception.mli b/analysis/reanalyze/src/dead_exception.mli new file mode 100644 index 00000000000..41a6f5d98cf --- /dev/null +++ b/analysis/reanalyze/src/dead_exception.mli @@ -0,0 +1,26 @@ +open Dead_common + +val find_exception_from_decls : + Declarations.t -> Dce_path.t -> Location.t option + +val add : + config:Dce_config.t -> + decls:Declarations.builder -> + file:File_context.t -> + path:Dce_path.t -> + loc:Location.t -> + str_loc:Location.t -> + module_loc:Location.t -> + Name.t -> + Name.t + +val mark_as_used : + config:Dce_config.t -> + refs:References.builder -> + file_deps:File_deps.builder -> + cross_file:Cross_file_items.builder -> + binding:Location.t -> + loc_from:Location.t -> + loc_to:Location.t -> + Path.t -> + unit diff --git a/analysis/reanalyze/src/dead_modules.ml b/analysis/reanalyze/src/dead_modules.ml new file mode 100644 index 00000000000..26a1fbe44d0 --- /dev/null +++ b/analysis/reanalyze/src/dead_modules.ml @@ -0,0 +1,40 @@ +let active ~config = + (* When transitive reporting is off, the only dead modules would be empty modules *) + config.Dce_config.run.transitive + +let table = Hashtbl.create 1 + +let mark_dead ~config ~is_type ~loc path = + if active ~config then + let module_name = path |> Dce_path.to_module_name ~is_type in + match Hashtbl.find_opt table module_name with + | Some _ -> () + | _ -> Hashtbl.replace table module_name (false, loc) + +let mark_live ~config ~is_type ~(loc : Location.t) path = + if active ~config then + let module_name = path |> Dce_path.to_module_name ~is_type in + match Hashtbl.find_opt table module_name with + | None -> Hashtbl.replace table module_name (true, loc) + | Some (false, loc) -> Hashtbl.replace table module_name (true, loc) + | Some (true, _) -> () + +(** Check if a module is dead and return issue if so. Pure - no logging. *) +let check_module_dead ~config ~file_name:pos_fname module_name : Issue.t option + = + if not (active ~config) then None + else + match Hashtbl.find_opt table module_name with + | Some (false, loc) -> + Hashtbl.remove table module_name; + (* only report once *) + let loc = + if loc.loc_ghost then + let pos = + {Lexing.pos_fname; pos_lnum = 0; pos_bol = 0; pos_cnum = 0} + in + {Location.loc_start = pos; loc_end = pos; loc_ghost = false} + else loc + in + Some (Analysis_result.make_dead_module_issue ~loc ~module_name) + | _ -> None diff --git a/analysis/reanalyze/src/dead_optional_args.ml b/analysis/reanalyze/src/dead_optional_args.ml new file mode 100644 index 00000000000..21311815398 --- /dev/null +++ b/analysis/reanalyze/src/dead_optional_args.ml @@ -0,0 +1,127 @@ +open Dead_common + +let active () = true + +let add_function_reference ~config ~decls ~cross_file ~(loc_from : Location.t) + ~(loc_to : Location.t) = + if active () then + let pos_to = loc_to.loc_start in + let pos_from = loc_from.loc_start in + (* Check if target has optional args - for filtering and debug logging *) + let should_add = + match Declarations.find_opt_builder decls pos_to with + | Some {decl_kind = Value {optional_args}} -> + not (Optional_args.is_empty optional_args) + | _ -> false + in + if should_add then ( + if config.Dce_config.cli.debug then + Log_.item "OptionalArgs.addFunctionReference %s %s@." + (pos_from |> Pos.to_string) + (pos_to |> Pos.to_string); + Cross_file_items.add_function_reference cross_file ~pos_from ~pos_to) + +let rec has_optional_args (texpr : Types.type_expr) = + match texpr.desc with + | _ when not (active ()) -> false + | Tarrow ({lbl = Optional _}, _tTo, _, _) -> true + | Tarrow (_, t_to, _, _) -> has_optional_args t_to + | Tlink t -> has_optional_args t + | Tsubst t -> has_optional_args t + | _ -> false + +let rec from_type_expr (texpr : Types.type_expr) = + match texpr.desc with + | _ when not (active ()) -> [] + | Tarrow ({lbl = Optional {txt = s}}, t_to, _, _) -> s :: from_type_expr t_to + | Tarrow (_, t_to, _, _) -> from_type_expr t_to + | Tlink t -> from_type_expr t + | Tsubst t -> from_type_expr t + | _ -> [] + +let add_references ~config ~cross_file ~(loc_from : Location.t) + ~(loc_to : Location.t) ~(binding : Location.t) ~path + (arg_names, arg_names_maybe) = + if active () then ( + let pos_to = loc_to.loc_start in + let pos_from = binding.loc_start in + Cross_file_items.add_optional_arg_call cross_file ~pos_from ~pos_to + ~arg_names ~arg_names_maybe; + if config.Dce_config.cli.debug then + let call_pos = loc_from.loc_start in + Log_.item + "DeadOptionalArgs.addReferences %s called with optional argNames:%s \ + argNamesMaybe:%s %s@." + (path |> Dce_path.from_path_t |> Dce_path.to_string) + (arg_names |> String.concat ", ") + (arg_names_maybe |> String.concat ", ") + (call_pos |> Pos.to_string)) + +(** Check for optional args issues. Returns issues instead of logging. + Uses optional_args_state map for final computed state. *) +let check ~optional_args_state ~ann_store ~config:_ decl : Issue.t list = + match decl with + | {Decl.decl_kind = Value {optional_args}} + when active () + && not + (Annotation_store.is_annotated_gentype_or_live ann_store decl.pos) + -> + (* Look up computed state from map, fall back to declaration's initial state *) + let state = + match Optional_args_state.find_opt optional_args_state decl.pos with + | Some s -> s + | None -> optional_args + in + let loc = decl |> decl_get_loc in + let unused_issues = + Optional_args.fold_unused + (fun s acc -> + let issue : Issue.t = + { + name = "Warning Unused Argument"; + severity = Warning; + loc; + description = + DeadOptional + { + dead_optional = WarningUnusedArgument; + message = + Format.asprintf + "optional argument @{%s@} of function \ + @{%s@} is never used" + s + (decl.path |> Dce_path.without_head); + }; + } + in + issue :: acc) + state [] + in + let redundant_issues = + Optional_args.fold_always_used + (fun s n_calls acc -> + let issue : Issue.t = + { + name = "Warning Redundant Optional Argument"; + severity = Warning; + loc; + description = + DeadOptional + { + dead_optional = WarningRedundantOptionalArgument; + message = + Format.asprintf + "optional argument @{%s@} of function \ + @{%s@} is always supplied (%d calls)" + s + (decl.path |> Dce_path.without_head) + n_calls; + }; + } + in + issue :: acc) + state [] + in + (* Reverse to maintain original order from iterUnused/iterAlwaysUsed *) + List.rev unused_issues @ List.rev redundant_issues + | _ -> [] diff --git a/analysis/reanalyze/src/dead_type.ml b/analysis/reanalyze/src/dead_type.ml new file mode 100644 index 00000000000..1bfad3e33a3 --- /dev/null +++ b/analysis/reanalyze/src/dead_type.ml @@ -0,0 +1,226 @@ +(* Adapted from https://github.com/LexiFi/dead_code_analyzer *) + +open Dead_common + +let add_type_reference ~config ~refs ~pos_from ~pos_to = + if config.Dce_config.cli.debug then + Log_.item "addTypeReference %s --> %s@." + (pos_from |> Pos.to_string) + (pos_to |> Pos.to_string); + References.add_type_ref refs ~pos_to ~pos_from + +let extend_type_dependencies ~config ~refs (loc1 : Location.t) + (loc2 : Location.t) = + let {Location.loc_start = pos_to; loc_ghost = ghost1} = loc1 in + let {Location.loc_start = pos_from; loc_ghost = ghost2} = loc2 in + if (not ghost1) && (not ghost2) && pos_to <> pos_from then ( + if config.Dce_config.cli.debug then + Log_.item "extendTypeDependencies %s --> %s@." (pos_to |> Pos.to_string) + (pos_from |> Pos.to_string); + add_type_reference ~config ~refs ~pos_from ~pos_to) + +let add_declaration ~config ~decls ~file ~(module_path : Module_path.t) + ~(type_id : Ident.t) ~(type_kind : Types.type_kind) + ~(manifest_type_path : Dce_path.t option) = + let module_context = + module_path.path @ [File_context.module_name_tagged file] + in + let path_to_type = (type_id |> Ident.name |> Name.create) :: module_context in + let process_type_label ?(pos_adjustment = Decl.Nothing) type_label_name + ~decl_kind ~(loc : Location.t) = + addDeclaration_ ~config ~decls ~file ~decl_kind ~path:path_to_type ~loc + ?manifest_type_path ~module_loc:module_path.loc ~pos_adjustment + type_label_name + in + match type_kind with + | Type_record (l, _) -> + List.iter + (fun {Types.ld_id; ld_loc} -> + Ident.name ld_id |> Name.create + |> process_type_label ~decl_kind:RecordLabel ~loc:ld_loc) + l + | Type_variant decls -> + List.iteri + (fun i {Types.cd_id; cd_loc; cd_args} -> + let _handle_inline_records = + match cd_args with + | Cstr_record lbls -> + List.iter + (fun {Types.ld_id; ld_loc} -> + Ident.name cd_id ^ "." ^ Ident.name ld_id + |> Name.create + |> process_type_label ~decl_kind:RecordLabel ~loc:ld_loc) + lbls + | Cstr_tuple _ -> () + in + let pos_adjustment = + (* In Res the variant loc can include the | and spaces after it *) + let is_res = + let fname = cd_loc.loc_start.pos_fname in + Filename.check_suffix fname ".res" + || Filename.check_suffix fname ".resi" + in + if is_res then if i = 0 then Decl.FirstVariant else OtherVariant + else Nothing + in + Ident.name cd_id |> Name.create + |> process_type_label ~decl_kind:VariantCase ~loc:cd_loc ~pos_adjustment) + decls + | _ -> () + +module Path_map = Map.Make (struct + type t = Dce_path.t + + let compare = Stdlib.compare +end) + +let process_type_label_dependencies ~config ~decls ~refs = + (* Use raw declaration positions, not [declGetLoc], because references are keyed + by raw positions (decl.pos). [declGetLoc] applies [posAdjustment] (e.g. +2 + for OtherVariant), which is intended for reporting locations, not for + reference graph keys. *) + let decl_raw_loc (decl : Decl.t) : Location.t = + {Location.loc_start = decl.pos; loc_end = decl.pos_end; loc_ghost = false} + in + (* Build an index from full label path -> list of locations *) + let index = + Declarations.fold + (fun _pos decl acc -> + match decl.Decl.decl_kind with + | RecordLabel | VariantCase -> + let loc = decl |> decl_raw_loc in + let path = decl.path in + let existing = + Path_map.find_opt path acc |> Option.value ~default:[] + in + Path_map.add path (loc :: existing) acc + | _ -> acc) + decls Path_map.empty + in + (* Inner-module duplicates: if the same full path appears multiple times (e.g. from signature+structure), + connect them together. *) + index + |> Path_map.iter (fun _key locs -> + match locs with + | [] | [_] -> () + | loc0 :: rest -> + rest + |> List.iter (fun loc -> + extend_type_dependencies ~config ~refs loc loc0; + if not Config.report_types_dead_only_in_interface then + extend_type_dependencies ~config ~refs loc0 loc)); + + (* Cross-file impl<->intf linking, modeled after the previous lookup logic. *) + let hd_opt = function + | [] -> None + | x :: _ -> Some x + in + let find_one path = + match Path_map.find_opt path index with + | None -> None + | Some locs -> hd_opt locs + in + + let is_interface_of_pathToType (path_to_type : Dce_path.t) = + match List.rev path_to_type with + | module_name_tag :: _ -> ( + try (module_name_tag |> Name.to_string).[0] <> '+' + with Invalid_argument _ -> true) + | [] -> true + in + + Declarations.iter + (fun _pos decl -> + match decl.Decl.decl_kind with + | RecordLabel | VariantCase -> ( + match decl.path with + | [] -> () + | type_label_name :: path_to_type -> ( + let loc = decl |> decl_raw_loc in + let is_interface = is_interface_of_pathToType path_to_type in + if not is_interface then + let path_1 = path_to_type |> Dce_path.module_to_interface in + let path_2 = path_1 |> Dce_path.type_to_interface in + let path1 = type_label_name :: path_1 in + let path2 = type_label_name :: path_2 in + match find_one path1 with + | Some loc1 -> + extend_type_dependencies ~config ~refs loc loc1; + if not Config.report_types_dead_only_in_interface then + extend_type_dependencies ~config ~refs loc1 loc + | None -> ( + match find_one path2 with + | Some loc2 -> + extend_type_dependencies ~config ~refs loc loc2; + if not Config.report_types_dead_only_in_interface then + extend_type_dependencies ~config ~refs loc2 loc + | None -> ()) + else + let path_1 = path_to_type |> Dce_path.module_to_implementation in + let path1 = type_label_name :: path_1 in + match find_one path1 with + | None -> () + | Some loc1 -> + extend_type_dependencies ~config ~refs loc1 loc; + if not Config.report_types_dead_only_in_interface then + extend_type_dependencies ~config ~refs loc loc1)) + | _ -> ()) + decls; + + (* Link fields of re-exported types (type y = x = {...}) to original type fields. + We store the manifest type path on the label declarations themselves, and + derive the set of re-export relationships here. To preserve stable output + ordering, we process types bottom-to-top (by their first label position) + and fields top-to-bottom (by their label position). *) + let compare_pos (p1 : Lexing.position) (p2 : Lexing.position) = + match compare p1.Lexing.pos_fname p2.Lexing.pos_fname with + | 0 -> compare p1.Lexing.pos_cnum p2.Lexing.pos_cnum + | c -> c + in + (* currentTypePath -> (rep_pos, manifestTypePath, (pos, fieldName, currentLoc) list) *) + let groups : + ( Dce_path.t, + Lexing.position + * Dce_path.t + * (Lexing.position * Name.t * Location.t) list ) + Hashtbl.t = + Hashtbl.create 32 + in + Declarations.iter + (fun _pos decl -> + match (decl.Decl.decl_kind, decl.manifest_type_path, decl.path) with + | ( (RecordLabel | VariantCase), + Some manifest_type_path, + field_name :: current_type_path ) -> ( + let item = (decl.pos, field_name, decl_raw_loc decl) in + match Hashtbl.find_opt groups current_type_path with + | None -> + Hashtbl.replace groups current_type_path + (decl.pos, manifest_type_path, [item]) + | Some (rep_pos, mtp0, items) -> + (* manifestTypePath should be stable for a given currentTypePath *) + let rep_pos = + if compare_pos decl.pos rep_pos < 0 then decl.pos else rep_pos + in + Hashtbl.replace groups current_type_path (rep_pos, mtp0, item :: items) + ) + | _ -> ()) + decls; + + groups |> Hashtbl.to_seq |> List.of_seq + |> List.map (fun (current_type_path, (rep_pos, manifest_type_path, items)) -> + (rep_pos, current_type_path, manifest_type_path, items)) + (* Later (lower) types first *) + |> List.fast_sort (fun (p1, _, _, _) (p2, _, _, _) -> compare_pos p2 p1) + |> List.iter (fun (_rep_pos, _currentTypePath, manifest_type_path, items) -> + items + |> List.fast_sort (fun (p1, _, _) (p2, _, _) -> compare_pos p1 p2) + |> List.iter (fun (_pos, field_name, current_loc) -> + let manifest_field_path = field_name :: manifest_type_path in + match find_one manifest_field_path with + | None -> () + | Some manifest_loc -> + extend_type_dependencies ~config ~refs current_loc + manifest_loc; + extend_type_dependencies ~config ~refs manifest_loc + current_loc)) diff --git a/analysis/reanalyze/src/dead_value.ml b/analysis/reanalyze/src/dead_value.ml new file mode 100644 index 00000000000..aa82de7f77d --- /dev/null +++ b/analysis/reanalyze/src/dead_value.ml @@ -0,0 +1,495 @@ +(* Adapted from https://github.com/LexiFi/dead_code_analyzer *) + +open Dead_common + +let check_any_value_binding_with_no_side_effects ~config ~decls ~file + ~(module_path : Module_path.t) + ({vb_pat = {pat_desc}; vb_expr = expr; vb_loc = loc} : + Typedtree.value_binding) = + match pat_desc with + | Tpat_any when (not (Side_effects.check_expr expr)) && not loc.loc_ghost -> + let name = "_" |> Name.create ~is_interface:false in + let path = module_path.path @ [File_context.module_name_tagged file] in + name + |> add_value_declaration ~config ~decls ~file ~path ~loc + ~module_loc:module_path.loc ~side_effects:false + | _ -> () + +let collect_value_binding ~config ~decls ~file ~(current_binding : Location.t) + ~(module_path : Module_path.t) (vb : Typedtree.value_binding) = + let old_last_binding = current_binding in + check_any_value_binding_with_no_side_effects ~config ~decls ~file ~module_path + vb; + let loc = + match vb.vb_pat.pat_desc with + | Tpat_var (id, {loc = {loc_start; loc_ghost} as loc}) + | Tpat_alias + ({pat_desc = Tpat_any}, id, {loc = {loc_start; loc_ghost} as loc}) + when (not loc_ghost) && not vb.vb_loc.loc_ghost -> + let name = Ident.name id |> Name.create ~is_interface:false in + let optional_args = + vb.vb_expr.exp_type |> Dead_optional_args.from_type_expr + |> Optional_args.from_list + in + let exists = + match Declarations.find_opt_builder decls loc_start with + | Some {decl_kind = Value r} -> + r.optional_args <- optional_args; + true + | _ -> false + in + let path = module_path.path @ [File_context.module_name_tagged file] in + let is_first_class_module = + match vb.vb_expr.exp_type.desc with + | Tpackage _ -> true + | _ -> false + in + (if (not exists) && not is_first_class_module then + (* This is never toplevel currently *) + let is_toplevel = old_last_binding = Location.none in + let side_effects = Side_effects.check_expr vb.vb_expr in + name + |> add_value_declaration ~config ~decls ~file ~is_toplevel ~loc + ~module_loc:module_path.loc ~optional_args ~path ~side_effects); + (match Declarations.find_opt_builder decls loc_start with + | None -> () + | Some decl -> + (* Value bindings contain the correct location for the entire declaration: update final position. + The previous value was taken from the signature, which only has positions for the id. *) + let decl_kind = + match decl.decl_kind with + | Value vk -> + Decl.Kind.Value + {vk with side_effects = Side_effects.check_expr vb.vb_expr} + | dk -> dk + in + Declarations.replace_builder decls loc_start + { + decl with + decl_kind; + pos_end = vb.vb_loc.loc_end; + pos_start = vb.vb_loc.loc_start; + }); + loc + | _ -> current_binding + in + loc + +let process_optional_args ~config ~cross_file ~exp_type ~(loc_from : Location.t) + ~(binding : Location.t) ~loc_to ~path args = + if exp_type |> Dead_optional_args.has_optional_args then ( + let supplied = ref [] in + let supplied_maybe = ref [] in + args + |> List.iter (fun (lbl, arg) -> + let arg_is_supplied = + match arg with + | Some + { + Typedtree.exp_desc = + Texp_construct (_, {cstr_name = "Some"}, _); + } -> + Some true + | Some + { + Typedtree.exp_desc = + Texp_construct (_, {cstr_name = "None"}, _); + } -> + Some false + | Some _ -> None + | None -> Some false + in + match lbl with + | Asttypes.Optional {txt = s} when not loc_from.loc_ghost -> + if arg_is_supplied <> Some false then supplied := s :: !supplied; + if arg_is_supplied = None then + supplied_maybe := s :: !supplied_maybe + | _ -> ()); + (!supplied, !supplied_maybe) + |> Dead_optional_args.add_references ~config ~cross_file ~loc_from ~loc_to + ~binding ~path) + +let rec collect_expr ~config ~refs ~file_deps ~cross_file + ~(last_binding : Location.t) super self (e : Typedtree.expression) = + let loc_from = e.exp_loc in + let binding = last_binding in + (match e.exp_desc with + | Texp_ident (_path, _, {Types.val_loc = {loc_ghost = false; _} as loc_to}) -> + (* if Path.name _path = "rc" then assert false; *) + if loc_from = loc_to && _path |> Path.name = "emptyArray" then ( + (* Work around lowercase jsx with no children producing an artifact `emptyArray` + which is called from its own location as many things are generated on the same location. *) + if config.Dce_config.cli.debug then + Log_.item "addDummyReference %s --> %s@." + (Location.none.loc_start |> Pos.to_string) + (loc_to.loc_start |> Pos.to_string); + References.add_value_ref refs ~pos_to:loc_to.loc_start + ~pos_from:Location.none.loc_start) + else + add_value_reference ~config ~refs ~file_deps ~binding + ~add_file_reference:true ~loc_from ~loc_to + | Texp_apply + { + funct = + { + exp_desc = + Texp_ident + (path, _, {Types.val_loc = {loc_ghost = false; _} as loc_to}); + exp_type; + }; + args; + } -> + args + |> process_optional_args ~config ~cross_file ~exp_type + ~loc_from:(loc_from : Location.t) + ~binding:last_binding ~loc_to ~path + | Texp_let + ( (* generated for functions with optional args *) + Nonrecursive, + [ + { + vb_pat = {pat_desc = Tpat_var (id_arg, _)}; + vb_expr = + { + exp_desc = + Texp_ident + (path, _, {Types.val_loc = {loc_ghost = false; _} as loc_to}); + exp_type; + }; + }; + ], + { + exp_desc = + Texp_function + { + case = + { + c_lhs = {pat_desc = Tpat_var (eta_arg, _)}; + c_rhs = + { + exp_desc = + Texp_apply + { + funct = {exp_desc = Texp_ident (id_arg2, _, _)}; + args; + }; + }; + }; + }; + } ) + when Ident.name id_arg = "arg" + && Ident.name eta_arg = "eta" + && Path.name id_arg2 = "arg" -> + args + |> process_optional_args ~config ~cross_file ~exp_type + ~loc_from:(loc_from : Location.t) + ~binding:last_binding ~loc_to ~path + | Texp_field + (_, _, {lbl_loc = {Location.loc_start = pos_to; loc_ghost = false}; _}) -> + if !Config.analyze_types then + Dead_type.add_type_reference ~config ~refs ~pos_to + ~pos_from:loc_from.loc_start + | Texp_construct + ( _, + { + cstr_loc = {Location.loc_start = pos_to; loc_ghost} as loc_to; + cstr_tag; + }, + _ ) -> + (match cstr_tag with + | Cstr_extension path -> + path + |> Dead_exception.mark_as_used ~config ~refs ~file_deps ~cross_file + ~binding ~loc_from ~loc_to + | _ -> ()); + if !Config.analyze_types && not loc_ghost then + Dead_type.add_type_reference ~config ~refs ~pos_to + ~pos_from:loc_from.loc_start + | Texp_record {fields} -> + fields + |> Array.iter (fun (_, record_label_definition, _) -> + match record_label_definition with + | Typedtree.Overridden (_, ({exp_loc} as e)) when exp_loc.loc_ghost + -> + (* Punned field in OCaml projects has ghost location in expression *) + let e = {e with exp_loc = {exp_loc with loc_ghost = false}} in + collect_expr ~config ~refs ~file_deps ~cross_file ~last_binding + super self e + |> ignore + | _ -> ()) + | _ -> ()); + super.Tast_mapper.expr self e + +(* + type k. is a locally abstract type + https://caml.inria.fr/pub/docs/manual-ocaml/locallyabstract.html + it is required because in ocaml >= 4.11 Typedtree.pattern and ADT is converted + in a GADT + https://github.com/ocaml/ocaml/commit/312253ce822c32740349e572498575cf2a82ee96 + in short: all branches of pattern matches aren't the same type. + With this annotation we declare a new type for each branch to allow the + function to be typed. + *) +let collect_pattern ~config ~refs : + _ -> _ -> Typedtree.pattern -> Typedtree.pattern = + fun super self pat -> + let pos_from = pat.Typedtree.pat_loc.loc_start in + (match pat.pat_desc with + | Typedtree.Tpat_record (cases, _clodsedFlag) -> + cases + |> List.iter (fun (_loc, {Types.lbl_loc = {loc_start = pos_to}}, _pat, _) -> + if !Config.analyze_types then + Dead_type.add_type_reference ~config ~refs ~pos_from ~pos_to) + | _ -> ()); + super.Tast_mapper.pat self pat + +let rec get_signature (module_type : Types.module_type) = + match module_type with + | Mty_signature signature -> signature + | Mty_functor (_, _mtParam, mt) -> get_signature mt + | _ -> [] + +let rec process_signature_item ~config ~decls ~file ~do_types ~do_values + ~module_loc ~(module_path : Module_path.t) ~path (si : Types.signature_item) + = + match si with + | Sig_type (id, t, _) when do_types -> + if !Config.analyze_types then + (* Extract manifest type path for type re-exports (type y = x = {...}). + Use full Path.t so cross-module re-exports work (Path.Pdot, aliases, etc.). *) + let manifest_type_path = + match t.type_manifest with + | Some {desc = Tconstr (path, _, _)} -> ( + let p = path |> Dce_path.from_path_t in + match p with + | [type_name] -> + let module_context = + module_path.path @ [File_context.module_name_tagged file] + in + Some (type_name :: module_context) + | _ -> + Some + (if File_context.is_interface file then + Dce_path.module_to_interface p + else Dce_path.module_to_implementation p)) + | _ -> None + in + Dead_type.add_declaration ~config ~decls ~file ~module_path ~type_id:id + ~type_kind:t.type_kind ~manifest_type_path + | Sig_value (id, {Types.val_loc = loc; val_kind = kind; val_type}) + when do_values -> + if not loc.Location.loc_ghost then + let is_primitive = + match kind with + | Val_prim _ -> true + | _ -> false + in + if (not is_primitive) || !Config.analyze_externals then + let optional_args = + val_type |> Dead_optional_args.from_type_expr + |> Optional_args.from_list + in + + (* if Ident.name id = "someValue" then + Printf.printf "XXX %s\n" (Ident.name id); *) + Ident.name id + |> Name.create ~is_interface:false + |> add_value_declaration ~config ~decls ~file ~loc ~module_loc + ~optional_args ~path ~side_effects:false + | Sig_module (id, {Types.md_type = module_type; md_loc = module_loc}, _) + | Sig_modtype (id, {Types.mtd_type = Some module_type; mtd_loc = module_loc}) + -> + let modulePath' = + Module_path.enter_module module_path + ~name:(id |> Ident.name |> Name.create) + ~loc:module_loc + in + let collect = + match si with + | Sig_modtype _ -> false + | _ -> true + in + if collect then + get_signature module_type + |> List.iter + (process_signature_item ~config ~decls ~file ~do_types ~do_values + ~module_loc ~module_path:modulePath' + ~path:((id |> Ident.name |> Name.create) :: path)) + | _ -> () + +(* Traverse the AST *) +let traverse_structure ~config ~decls ~refs ~file_deps ~cross_file ~file + ~do_types ~do_externals (structure : Typedtree.structure) : unit = + let rec create_mapper (last_binding : Location.t) + (module_path : Module_path.t) = + let super = Tast_mapper.default in + let rec mapper = + { + super with + expr = + (fun _self e -> + e + |> collect_expr ~config ~refs ~file_deps ~cross_file ~last_binding + super mapper); + pat = (fun _self p -> p |> collect_pattern ~config ~refs super mapper); + structure_item = + (fun _self (structure_item : Typedtree.structure_item) -> + let modulePath_for_item_opt = + match structure_item.str_desc with + | Tstr_module {mb_expr; mb_id; mb_loc} -> + let has_interface = + match mb_expr.mod_desc with + | Tmod_constraint _ -> true + | _ -> false + in + let modulePath' = + Module_path.enter_module module_path + ~name:(mb_id |> Ident.name |> Name.create) + ~loc:mb_loc + in + if has_interface then + match mb_expr.mod_type with + | Mty_signature signature -> + signature + |> List.iter + (process_signature_item ~config ~decls ~file ~do_types + ~do_values:false ~module_loc:mb_expr.mod_loc + ~module_path:modulePath' + ~path: + (modulePath'.path + @ [File_context.module_name_tagged file])) + | _ -> () + else (); + Some modulePath' + | Tstr_primitive vd when do_externals && !Config.analyze_externals + -> + let path = + module_path.path @ [File_context.module_name_tagged file] + in + let exists = + match + Declarations.find_opt_builder decls vd.val_loc.loc_start + with + | Some {decl_kind = Value _} -> true + | _ -> false + in + let id = vd.val_id |> Ident.name in + Printf.printf "Primitive %s\n" id; + if + (not exists) && id <> "unsafe_expr" + (* see https://github.com/BuckleScript/bucklescript/issues/4532 *) + then + id + |> Name.create ~is_interface:false + |> add_value_declaration ~config ~decls ~file ~path + ~loc:vd.val_loc ~module_loc:module_path.loc + ~side_effects:false; + None + | Tstr_type (_recFlag, type_declarations) when do_types -> + if !Config.analyze_types then + type_declarations + |> List.iter + (fun (type_declaration : Typedtree.type_declaration) -> + (* Extract manifest type path for type re-exports (type y = x = {...}). *) + let manifest_type_path = + match type_declaration.typ_manifest with + | Some {ctyp_desc = Ttyp_constr (path, _, _)} -> ( + let p = path |> Dce_path.from_path_t in + match p with + | [type_name] -> + let module_context = + module_path.path + @ [File_context.module_name_tagged file] + in + Some (type_name :: module_context) + | _ -> + Some + (if File_context.is_interface file then + Dce_path.module_to_interface p + else Dce_path.module_to_implementation p)) + | _ -> None + in + Dead_type.add_declaration ~config ~decls ~file + ~module_path ~type_id:type_declaration.typ_id + ~type_kind:type_declaration.typ_type.type_kind + ~manifest_type_path); + None + | Tstr_include {incl_mod; incl_type} -> + (match incl_mod.mod_desc with + | Tmod_ident (_path, _lid) -> + let current_path = + module_path.path @ [File_context.module_name_tagged file] + in + incl_type + |> List.iter + (process_signature_item ~config ~decls ~file ~do_types + ~do_values:false (* TODO: also values? *) + ~module_loc:incl_mod.mod_loc ~module_path + ~path:current_path) + | _ -> ()); + None + | Tstr_exception {ext_id = id; ext_loc = loc} -> + let path = + module_path.path @ [File_context.module_name_tagged file] + in + let name = id |> Ident.name |> Name.create in + ignore + (Dead_exception.add ~config ~decls ~file ~path ~loc + ~str_loc:structure_item.str_loc ~module_loc:module_path.loc + name); + None + | _ -> None + in + let mapper_for_item = + match modulePath_for_item_opt with + | None -> mapper + | Some modulePath_for_item -> + create_mapper last_binding modulePath_for_item + in + super.structure_item mapper_for_item structure_item); + value_binding = + (fun _self vb -> + let loc = + vb + |> collect_value_binding ~config ~decls ~file + ~current_binding:last_binding ~module_path + in + let nested_mapper = create_mapper loc module_path in + super.Tast_mapper.value_binding nested_mapper vb); + } + in + mapper + in + let mapper = create_mapper Location.none Module_path.initial in + mapper.structure mapper structure |> ignore + +(* Merge a location's references to another one's *) +let process_value_dependency ~config ~decls ~refs ~file_deps ~cross_file + ( ({ + val_loc = + {loc_start = {pos_fname = fn_to} as pos_to; loc_ghost = ghost1} as + loc_to; + } : + Types.value_description), + ({ + val_loc = + {loc_start = {pos_fname = fn_from} as pos_from; loc_ghost = ghost2} + as loc_from; + } : + Types.value_description) ) = + if (not ghost1) && (not ghost2) && pos_to <> pos_from then ( + let add_file_reference = file_is_implementation_of fn_to fn_from in + add_value_reference ~config ~refs ~file_deps ~binding:Location.none + ~add_file_reference ~loc_from ~loc_to; + Dead_optional_args.add_function_reference ~config ~decls ~cross_file + ~loc_from ~loc_to) + +let process_structure ~config ~decls ~refs ~file_deps ~cross_file ~file + ~cmt_value_dependencies ~do_types ~do_externals + (structure : Typedtree.structure) = + traverse_structure ~config ~decls ~refs ~file_deps ~cross_file ~file ~do_types + ~do_externals structure; + let value_dependencies = cmt_value_dependencies |> List.rev in + value_dependencies + |> List.iter + (process_value_dependency ~config ~decls ~refs ~file_deps ~cross_file) diff --git a/analysis/reanalyze/src/Decl.ml b/analysis/reanalyze/src/decl.ml similarity index 67% rename from analysis/reanalyze/src/Decl.ml rename to analysis/reanalyze/src/decl.ml index d36b825eb13..aa457b3f5b8 100644 --- a/analysis/reanalyze/src/Decl.ml +++ b/analysis/reanalyze/src/decl.ml @@ -6,17 +6,17 @@ module Kind = struct | RecordLabel | VariantCase | Value of { - isToplevel: bool; - mutable optionalArgs: OptionalArgs.t; - sideEffects: bool; + is_toplevel: bool; + mutable optional_args: Optional_args.t; + side_effects: bool; } - let isType dk = + let is_type dk = match dk with | RecordLabel | VariantCase -> true | Exception | Value _ -> false - let toString dk = + let to_string dk = match dk with | Exception -> "Exception" | RecordLabel -> "RecordLabel" @@ -24,68 +24,68 @@ module Kind = struct | Value _ -> "Value" end -type posAdjustment = FirstVariant | OtherVariant | Nothing +type pos_adjustment = FirstVariant | OtherVariant | Nothing type t = { - declKind: Kind.t; - moduleLoc: Location.t; - posAdjustment: posAdjustment; - path: DcePath.t; + decl_kind: Kind.t; + module_loc: Location.t; + pos_adjustment: pos_adjustment; + path: Dce_path.t; (** For type re-exports (e.g. [type y = x = {...}]), record/variant label declarations belonging to the re-exporting type can carry the manifest type path so [DeadType.process_type_label_dependencies] can link fields without needing the typed tree. *) - manifestTypePath: DcePath.t option; + manifest_type_path: Dce_path.t option; pos: Lexing.position; - posEnd: Lexing.position; - posStart: Lexing.position; - mutable resolvedDead: bool option; + pos_end: Lexing.position; + pos_start: Lexing.position; + mutable resolved_dead: bool option; mutable report: bool; } -let isValue decl = - match decl.declKind with +let is_value decl = + match decl.decl_kind with | Value _ (* | Exception *) -> true | _ -> false (** Check if a declaration is live (or unknown). Returns false only if resolved as dead. *) -let isLive decl = - match decl.resolvedDead with +let is_live decl = + match decl.resolved_dead with | Some true -> false | Some false | None -> true -let compareUsingDependencies ~orderedFiles +let compare_using_dependencies ~ordered_files { - declKind = kind1; + decl_kind = kind1; path = _path1; pos = {pos_fname = fname1; pos_lnum = lnum1; pos_bol = bol1; pos_cnum = cnum1}; } { - declKind = kind2; + decl_kind = kind2; path = _path2; pos = {pos_fname = fname2; pos_lnum = lnum2; pos_bol = bol2; pos_cnum = cnum2}; } = - let findPosition fn = Hashtbl.find orderedFiles fn [@@raises Not_found] in + let find_position fn = Hashtbl.find ordered_files fn [@@raises Not_found] in (* From the root of the file dependency DAG to the leaves. From the bottom of the file to the top. *) let position1, position2 = - try (fname1 |> findPosition, fname2 |> findPosition) + try (fname1 |> find_position, fname2 |> find_position) with Not_found -> (0, 0) in compare (position1, lnum2, bol2, cnum2, kind1) (position2, lnum1, bol1, cnum1, kind2) -let compareForReporting +let compare_for_reporting { - declKind = kind1; + decl_kind = kind1; pos = {pos_fname = fname1; pos_lnum = lnum1; pos_bol = bol1; pos_cnum = cnum1}; } { - declKind = kind2; + decl_kind = kind2; pos = {pos_fname = fname2; pos_lnum = lnum2; pos_bol = bol2; pos_cnum = cnum2}; } = diff --git a/analysis/reanalyze/src/DeclarationStore.ml b/analysis/reanalyze/src/declaration_store.ml similarity index 100% rename from analysis/reanalyze/src/DeclarationStore.ml rename to analysis/reanalyze/src/declaration_store.ml diff --git a/analysis/reanalyze/src/DeclarationStore.mli b/analysis/reanalyze/src/declaration_store.mli similarity index 100% rename from analysis/reanalyze/src/DeclarationStore.mli rename to analysis/reanalyze/src/declaration_store.mli diff --git a/analysis/reanalyze/src/Declarations.ml b/analysis/reanalyze/src/declarations.ml similarity index 50% rename from analysis/reanalyze/src/Declarations.ml rename to analysis/reanalyze/src/declarations.ml index 6b8dfedc7db..bcdee966ab7 100644 --- a/analysis/reanalyze/src/Declarations.ml +++ b/analysis/reanalyze/src/declarations.ml @@ -5,42 +5,44 @@ - [t] - immutable, for solver (read-only access) *) (* Both types have the same representation, but different semantics *) -type t = Decl.t PosHash.t -type builder = Decl.t PosHash.t +type t = Decl.t Pos_hash.t +type builder = Decl.t Pos_hash.t (* ===== Builder API ===== *) -let create_builder () : builder = PosHash.create 256 +let create_builder () : builder = Pos_hash.create 256 let add (builder : builder) (pos : Lexing.position) (decl : Decl.t) = - PosHash.replace builder pos decl + Pos_hash.replace builder pos decl -let find_opt_builder (builder : builder) pos = PosHash.find_opt builder pos +let find_opt_builder (builder : builder) pos = Pos_hash.find_opt builder pos let replace_builder (builder : builder) (pos : Lexing.position) (decl : Decl.t) = - PosHash.replace builder pos decl + Pos_hash.replace builder pos decl let merge_all (builders : builder list) : t = - let result = PosHash.create 256 in + let result = Pos_hash.create 256 in builders |> List.iter (fun builder -> - PosHash.iter (fun pos decl -> PosHash.replace result pos decl) builder); + Pos_hash.iter + (fun pos decl -> Pos_hash.replace result pos decl) + builder); result (* ===== Builder extraction for reactive merge ===== *) let builder_to_list (builder : builder) : (Lexing.position * Decl.t) list = - PosHash.fold (fun pos decl acc -> (pos, decl) :: acc) builder [] + Pos_hash.fold (fun pos decl acc -> (pos, decl) :: acc) builder [] -let create_from_hashtbl (h : Decl.t PosHash.t) : t = h +let create_from_hashtbl (h : Decl.t Pos_hash.t) : t = h (* ===== Read-only API ===== *) -let find_opt (t : t) pos = PosHash.find_opt t pos +let find_opt (t : t) pos = Pos_hash.find_opt t pos -let fold f (t : t) init = PosHash.fold f t init +let fold f (t : t) init = Pos_hash.fold f t init -let iter f (t : t) = PosHash.iter f t +let iter f (t : t) = Pos_hash.iter f t -let length (t : t) = PosHash.length t +let length (t : t) = Pos_hash.length t diff --git a/analysis/reanalyze/src/Declarations.mli b/analysis/reanalyze/src/declarations.mli similarity index 96% rename from analysis/reanalyze/src/Declarations.mli rename to analysis/reanalyze/src/declarations.mli index e6362ee2e99..4020a4f122b 100644 --- a/analysis/reanalyze/src/Declarations.mli +++ b/analysis/reanalyze/src/declarations.mli @@ -30,7 +30,7 @@ val merge_all : builder list -> t val builder_to_list : builder -> (Lexing.position * Decl.t) list (** Extract all declarations as a list for reactive merge *) -val create_from_hashtbl : Decl.t PosHash.t -> t +val create_from_hashtbl : Decl.t Pos_hash.t -> t (** Create from hashtable for reactive merge *) (** {2 Read-only API for t - for solver} *) diff --git a/analysis/reanalyze/src/emit_json.ml b/analysis/reanalyze/src/emit_json.ml new file mode 100644 index 00000000000..841f79e14b7 --- /dev/null +++ b/analysis/reanalyze/src/emit_json.ml @@ -0,0 +1,30 @@ +let items = ref 0 +let start () = + items := 0; + Printf.printf "[" +let finish () = Printf.printf "\n]\n" +let emit_close () = "\n}" +let json_string text = Yojson.Safe.to_string (`String text) + +let emit_item ~ppf ~name ~kind ~file ~range ~message = + let open Format in + items := !items + 1; + let start_line, start_character, end_line, end_character = range in + fprintf ppf "%s{\n" (if !items = 1 then "\n" else ",\n"); + fprintf ppf " \"name\": %s,\n" (json_string name); + fprintf ppf " \"kind\": %s,\n" (json_string kind); + fprintf ppf " \"file\": %s,\n" (json_string file); + fprintf ppf " \"range\": [%d,%d,%d,%d],\n" start_line start_character + end_line end_character; + fprintf ppf " \"message\": %s" (json_string message) + +let loc_to_pos (loc : Location.t) = + (loc.loc_start.pos_lnum - 1, loc.loc_start.pos_cnum - loc.loc_start.pos_bol) + +let emit_annotate ~pos ~text ~action = + let line, character = pos in + Format.asprintf + ",\n\ + \ \"annotate\": { \"line\": %d, \"character\": %d, \"text\": %s, \ + \"action\": %s}" + line character (json_string text) (json_string action) diff --git a/analysis/reanalyze/src/exception.ml b/analysis/reanalyze/src/exception.ml new file mode 100644 index 00000000000..271a27bd7a4 --- /dev/null +++ b/analysis/reanalyze/src/exception.ml @@ -0,0 +1,588 @@ +open Dead_common + +type values_builder = (Name.t, Exceptions.t) Hashtbl.t +(** Per-file mutable builder for exception values during AST processing *) + +type values_table = (string, (Name.t, Exceptions.t) Hashtbl.t) Hashtbl.t +(** Merged immutable table for cross-file lookups *) + +let create_values_builder () : values_builder = Hashtbl.create 15 + +let values_builder_add (builder : values_builder) ~module_path ~name exceptions + = + let path = (name |> Name.create) :: module_path.Module_path.path in + Hashtbl.replace builder (path |> Dce_path.to_name) exceptions + +(** Merge all per-file builders into a single lookup table *) +let merge_values_builders (builders : (string * values_builder) list) : + values_table = + let table = Hashtbl.create 15 in + builders + |> List.iter (fun (module_name, builder) -> + Hashtbl.replace table module_name builder); + table + +module Values = struct + let get_from_module (table : values_table) ~module_name ~module_path + (path_ : Dce_path.t) = + let name = path_ @ module_path |> Dce_path.to_name in + match Hashtbl.find_opt table (String.capitalize_ascii module_name) with + | Some tbl -> Hashtbl.find_opt tbl name + | None -> ( + match Hashtbl.find_opt table (String.uncapitalize_ascii module_name) with + | Some tbl -> Hashtbl.find_opt tbl name + | None -> None) + + let rec find_local (table : values_table) ~module_name ~module_path path = + match path |> get_from_module table ~module_name ~module_path with + | Some exceptions -> Some exceptions + | None -> ( + match module_path with + | [] -> None + | _ :: rest_module_path -> + path |> find_local table ~module_name ~module_path:rest_module_path) + + let find_path (table : values_table) ~module_name ~module_path path = + let find_external ~external_module_name ~path_rev = + path_rev |> List.rev + |> get_from_module table + ~module_name:(external_module_name |> Name.to_string) + ~module_path:[] + in + match path |> find_local table ~module_name ~module_path with + | None -> ( + (* Search in another file *) + match path |> List.rev with + | external_module_name :: path_rev -> ( + match (find_external ~external_module_name ~path_rev, path_rev) with + | (Some _ as found), _ -> found + | None, external_module_name2 :: path_rev2 + when !Cli.cmt_command && path_rev2 <> [] -> + (* Simplistic namespace resolution for dune namespace: skip the root of the path *) + find_external ~external_module_name:external_module_name2 + ~path_rev:path_rev2 + | None, _ -> None) + | [] -> None) + | Some exceptions -> Some exceptions +end + +module Event = struct + type kind = + | Catches of t list (* with | E => ... *) + | Call of {callee: Dce_path.t; module_path: Dce_path.t} (* foo() *) + | DoesNotThrow of + t list (* DoesNotThrow(events) where events come from an expression *) + | Throws (** throw E *) + + and t = {exceptions: Exceptions.t; kind: kind; loc: Location.t} + + let rec print ppf event = + match event with + | {kind = Call {callee; module_path}; exceptions; loc} -> + Format.fprintf ppf "%s Call(%s, modulePath:%s) %a@." + (loc.loc_start |> Pos.to_string) + (callee |> Dce_path.to_string) + (module_path |> Dce_path.to_string) + (Exceptions.pp ~exn_table:None) + exceptions + | {kind = DoesNotThrow nested_events; loc} -> + Format.fprintf ppf "%s DoesNotThrow(%a)@." + (loc.loc_start |> Pos.to_string) + (fun ppf () -> + nested_events |> List.iter (fun e -> Format.fprintf ppf "%a " print e)) + () + | {kind = Throws; exceptions; loc} -> + Format.fprintf ppf "%s throws %a@." + (loc.loc_start |> Pos.to_string) + (Exceptions.pp ~exn_table:None) + exceptions + | {kind = Catches nested_events; exceptions; loc} -> + Format.fprintf ppf "%s Catches exceptions:%a nestedEvents:%a@." + (loc.loc_start |> Pos.to_string) + (Exceptions.pp ~exn_table:None) + exceptions + (fun ppf () -> + nested_events |> List.iter (fun e -> Format.fprintf ppf "%a " print e)) + () + + let combine ~(values_table : values_table) ~config ~module_name events = + if config.Dce_config.cli.debug then ( + Log_.item "@."; + Log_.item "Events combine: #events %d@." (events |> List.length)); + let exn_table = Hashtbl.create 1 in + let extend_exn_table exn loc = + match Hashtbl.find_opt exn_table exn with + | Some loc_set -> Hashtbl.replace exn_table exn (Loc_set.add loc loc_set) + | None -> Hashtbl.replace exn_table exn (Loc_set.add loc Loc_set.empty) + in + let shrink_exn_table exn loc = + match Hashtbl.find_opt exn_table exn with + | Some loc_set -> + Hashtbl.replace exn_table exn (Loc_set.remove loc loc_set) + | None -> () + in + let rec loop exn_set events = + match events with + | ({kind = Throws; exceptions; loc} as ev) :: rest -> + if config.Dce_config.cli.debug then Log_.item "%a@." print ev; + exceptions |> Exceptions.iter (fun exn -> extend_exn_table exn loc); + loop (Exceptions.union exn_set exceptions) rest + | ({kind = Call {callee; module_path}; loc} as ev) :: rest -> + if config.Dce_config.cli.debug then Log_.item "%a@." print ev; + let exceptions = + match + callee |> Values.find_path values_table ~module_name ~module_path + with + | Some exceptions -> exceptions + | _ -> ( + match Exn_lib.find callee with + | Some exceptions -> exceptions + | None -> Exceptions.empty) + in + exceptions |> Exceptions.iter (fun exn -> extend_exn_table exn loc); + loop (Exceptions.union exn_set exceptions) rest + | ({kind = DoesNotThrow nested_events; loc} as ev) :: rest -> + if config.Dce_config.cli.debug then Log_.item "%a@." print ev; + let nested_exceptions = loop Exceptions.empty nested_events in + (if Exceptions.is_empty nested_exceptions (* catch-all *) then + let name = + match nested_events with + | {kind = Call {callee}} :: _ -> callee |> Dce_path.to_name + | _ -> "expression" |> Name.create + in + Log_.warning ~loc + (Issue.ExceptionAnalysis + { + message = + Format.asprintf + "@{%s@} does not throw and is annotated with \ + redundant @doesNotThrow" + (name |> Name.to_string); + })); + loop exn_set rest + | ({kind = Catches nested_events; exceptions} as ev) :: rest -> + if config.Dce_config.cli.debug then Log_.item "%a@." print ev; + if Exceptions.is_empty exceptions then loop exn_set rest + else + let nested_exceptions = loop Exceptions.empty nested_events in + let new_throws = Exceptions.diff nested_exceptions exceptions in + exceptions + |> Exceptions.iter (fun exn -> + nested_events + |> List.iter (fun event -> shrink_exn_table exn event.loc)); + loop (Exceptions.union exn_set new_throws) rest + | [] -> exn_set + in + let exn_set = loop Exceptions.empty events in + (exn_set, exn_table) +end + +type checks_builder = check list ref +(** Per-file mutable builder for checks during AST processing *) + +and check = { + events: Event.t list; + loc: Location.t; + loc_full: Location.t; + module_name: string; + exn_name: string; + exceptions: Exceptions.t; +} + +let create_checks_builder () : checks_builder = ref [] + +let checks_builder_add (builder : checks_builder) ~events ~exceptions ~loc + ?(loc_full = loc) ~module_name exn_name = + builder := + {events; exceptions; loc; loc_full; module_name; exn_name} :: !builder + +let checks_builder_to_list (builder : checks_builder) : check list = + !builder |> List.rev + +module Checks = struct + let do_check ~(values_table : values_table) ~config + {events; exceptions; loc; loc_full; module_name; exn_name} = + let throw_set, exn_table = + events |> Event.combine ~values_table ~config ~module_name + in + let missing_annotations = Exceptions.diff throw_set exceptions in + let redundant_annotations = Exceptions.diff exceptions throw_set in + (if not (Exceptions.is_empty missing_annotations) then + let description = + Issue.ExceptionAnalysisMissing + {exn_name; exn_table; throw_set; missing_annotations; loc_full} + in + Log_.warning ~loc description); + if not (Exceptions.is_empty redundant_annotations) then + Log_.warning ~loc + (Issue.ExceptionAnalysis + { + message = + (let throws_description ppf () = + if throw_set |> Exceptions.is_empty then + Format.fprintf ppf "throws nothing" + else + Format.fprintf ppf "might throw %a" + (Exceptions.pp ~exn_table:(Some exn_table)) + throw_set + in + Format.asprintf + "@{%s@} %a and is annotated with redundant @throws(%a)" + exn_name throws_description () + (Exceptions.pp ~exn_table:None) + redundant_annotations); + }) + + let do_checks ~values_table ~config (checks : check list) = + checks |> List.iter (do_check ~values_table ~config) +end + +let traverse_ast ~file ~values_builder ~checks_builder () = + let super = Tast_mapper.default in + let current_id = ref "" in + let current_events = ref [] in + (* For local lookups during AST processing, we look up in the current file's builder *) + let find_local_exceptions ~module_path path = + let name = path @ module_path |> Dce_path.to_name in + Hashtbl.find_opt values_builder name + in + let rec find_local_path ~module_path path = + match path |> find_local_exceptions ~module_path with + | Some exceptions -> Some exceptions + | None -> ( + match module_path with + | [] -> None + | _ :: rest_module_path -> + path |> find_local_path ~module_path:rest_module_path) + in + let exceptions_of_patterns patterns = + patterns + |> List.fold_left + (fun acc desc -> + match desc with + | Typedtree.Tpat_construct ({txt}, _, _) -> + Exceptions.add (Exn.from_lid txt) acc + | _ -> acc) + Exceptions.empty + in + let iter_expr self e = self.Tast_mapper.expr self e |> ignore in + let iter_expr_opt self eo = + match eo with + | None -> () + | Some e -> e |> iter_expr self + in + let iter_pat self p = self.Tast_mapper.pat self p |> ignore in + let iter_cases self cases = + cases + |> List.iter (fun case -> + case.Typedtree.c_lhs |> iter_pat self; + case.c_guard |> iter_expr_opt self; + case.c_rhs |> iter_expr self) + in + let is_throw s = s = "Pervasives.raise" || s = "Pervasives.throw" in + let throw_args args = + match args with + | [(_, Some {Typedtree.exp_desc = Texp_construct ({txt}, _, _)})] -> + [Exn.from_lid txt] |> Exceptions.from_list + | [(_, Some {Typedtree.exp_desc = Texp_ident _})] -> + [Exn.from_string "genericException"] |> Exceptions.from_list + | _ -> [Exn.from_string "TODO_from_raise1"] |> Exceptions.from_list + in + let does_not_throw attributes = + attributes + |> Annotation.get_attribute_payload (function + | "doesNotRaise" | "doesnotraise" | "DoesNoRaise" | "doesNotraise" + | "doNotRaise" | "donotraise" | "DoNoRaise" | "doNotraise" + | "doesNotThrow" | "doesnotthrow" | "DoesNoThrow" | "doesNotthrow" + | "doNotThrow" | "donotthrow" | "DoNoThrow" | "doNotthrow" -> + true + | _ -> false) + <> None + in + let expr ~(module_path : Module_path.t) (self : Tast_mapper.mapper) + (expr : Typedtree.expression) = + let loc = expr.exp_loc in + let is_does_no_throw = expr.exp_attributes |> does_not_throw in + let old_events = !current_events in + if is_does_no_throw then current_events := []; + (match expr.exp_desc with + | Texp_ident (callee_, _, _) -> + let callee = + callee_ |> Dce_path.from_path_t |> Module_path.resolve_alias module_path + in + let callee_name = callee |> Dce_path.to_name in + if callee_name |> Name.to_string |> is_throw then + Log_.warning ~loc + (Issue.ExceptionAnalysis + { + message = + Format.asprintf + "@{%s@} can be analyzed only if called directly" + (callee_name |> Name.to_string); + }); + current_events := + { + Event.exceptions = Exceptions.empty; + loc; + kind = Call {callee; module_path = module_path.path}; + } + :: !current_events + | Texp_apply + { + funct = {exp_desc = Texp_ident (atat, _, _)}; + args = [(_lbl1, Some {exp_desc = Texp_ident (callee, _, _)}); arg]; + } + when (* raise @@ Exn(...) *) + atat |> Path.name = "Pervasives.@@" + && callee |> Path.name |> is_throw -> + let exceptions = [arg] |> throw_args in + current_events := + {Event.exceptions; loc; kind = Throws} :: !current_events; + arg |> snd |> iter_expr_opt self + | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)} as e; args} -> + let callee_name = Path.name callee in + if callee_name |> is_throw then + let exceptions = args |> throw_args in + current_events := + {Event.exceptions; loc; kind = Throws} :: !current_events + else e |> iter_expr self; + args |> List.iter (fun (_, e_opt) -> e_opt |> iter_expr_opt self) + | Texp_match (e, cases_ok, cases_exn, partial) -> + let cases = cases_ok @ cases_exn in + let exception_patterns = + cases_exn + |> List.map (fun (case : Typedtree.case) -> case.c_lhs.pat_desc) + in + let exceptions = exception_patterns |> exceptions_of_patterns in + if exception_patterns <> [] then ( + let old_events = !current_events in + current_events := []; + e |> iter_expr self; + current_events := + {Event.exceptions; loc; kind = Catches !current_events} :: old_events) + else e |> iter_expr self; + cases |> iter_cases self; + if partial = Partial then + current_events := + { + Event.exceptions = [Exn.match_failure] |> Exceptions.from_list; + loc; + kind = Throws; + } + :: !current_events + | Texp_try (e, cases) -> + let exceptions = + cases + |> List.map (fun case -> case.Typedtree.c_lhs.pat_desc) + |> exceptions_of_patterns + in + let old_events = !current_events in + current_events := []; + e |> iter_expr self; + current_events := + {Event.exceptions; loc; kind = Catches !current_events} :: old_events; + cases |> iter_cases self + | _ -> super.expr self expr |> ignore); + (if is_does_no_throw then + let nested_events = !current_events in + current_events := + { + Event.exceptions = Exceptions.empty; + loc; + kind = DoesNotThrow nested_events; + } + :: old_events); + expr + in + let get_exceptions_from_annotations attributes = + let throws_annotation_payload = + attributes + |> Annotation.get_attribute_payload (fun s -> + s = "throws" || s = "throw" || s = "raises" || s = "raise") + in + let rec get_exceptions payload = + match payload with + | Annotation.StringPayload s -> + [Exn.from_string s] |> Exceptions.from_list + | Annotation.ConstructPayload s when s <> "::" -> + [Exn.from_string s] |> Exceptions.from_list + | Annotation.IdentPayload s -> + [Exn.from_string (s |> Longident.flatten |> String.concat ".")] + |> Exceptions.from_list + | Annotation.TuplePayload tuple -> + tuple + |> List.map (fun payload -> + payload |> get_exceptions |> Exceptions.to_list) + |> List.concat |> Exceptions.from_list + | _ -> Exceptions.empty + in + match throws_annotation_payload with + | None -> Exceptions.empty + | Some payload -> payload |> get_exceptions + in + let toplevel_eval (self : Tast_mapper.mapper) (expr : Typedtree.expression) + attributes = + let old_id = !current_id in + let old_events = !current_events in + let name = "Toplevel expression" in + current_id := name; + current_events := []; + let module_name = file.File_context.module_name in + self.expr self expr |> ignore; + checks_builder_add checks_builder ~events:!current_events + ~exceptions:(get_exceptions_from_annotations attributes) + ~loc:expr.exp_loc ~module_name name; + current_id := old_id; + current_events := old_events + in + let value_binding ~(module_path : Module_path.t) (self : Tast_mapper.mapper) + (vb : Typedtree.value_binding) = + let old_id = !current_id in + let old_events = !current_events in + let is_function = + match vb.vb_expr.exp_desc with + | Texp_function _ -> true + | _ -> false + in + let is_toplevel = !current_id = "" in + let process_binding name = + current_id := name; + current_events := []; + let exceptions_from_annotations = + get_exceptions_from_annotations vb.vb_attributes + in + values_builder_add values_builder ~module_path ~name + exceptions_from_annotations; + let res = super.value_binding self vb in + let module_name = file.File_context.module_name in + let path = [name |> Name.create] in + let exceptions = + match path |> find_local_path ~module_path:module_path.path with + | Some exceptions -> exceptions + | _ -> Exceptions.empty + in + checks_builder_add checks_builder ~events:!current_events ~exceptions + ~loc:vb.vb_pat.pat_loc ~loc_full:vb.vb_loc ~module_name name; + current_id := old_id; + current_events := old_events; + res + in + match vb.vb_pat.pat_desc with + | Tpat_any when is_toplevel && not vb.vb_loc.loc_ghost -> + process_binding "_" + | Tpat_construct ({txt}, _, _) + when is_toplevel && (not vb.vb_loc.loc_ghost) + && txt = Longident.Lident "()" -> + process_binding "()" + | Tpat_var (id, {loc = {loc_ghost}}) + when (is_function || is_toplevel) + && (not loc_ghost) && not vb.vb_loc.loc_ghost -> + process_binding (id |> Ident.name) + | _ -> super.value_binding self vb + in + let make_mapper (module_path : Module_path.t) : Tast_mapper.mapper = + let open Tast_mapper in + { + super with + expr = expr ~module_path; + value_binding = value_binding ~module_path; + } + in + let rec process_module_expr (module_path : Module_path.t) + (me : Typedtree.module_expr) = + match me.mod_desc with + | Tmod_structure structure -> process_structure module_path structure + | Tmod_constraint (me1, _mty, _mtc, _coercion) -> + process_module_expr module_path me1 + | Tmod_apply (me1, me2, _) -> + process_module_expr module_path me1; + process_module_expr module_path me2 + | _ -> + let mapper = make_mapper module_path in + super.module_expr mapper me |> ignore + and process_structure (module_path : Module_path.t) + (structure : Typedtree.structure) = + let rec loop (mp : Module_path.t) (items : Typedtree.structure_item list) = + match items with + | [] -> () + | structure_item :: rest -> + let mapper = make_mapper mp in + let mp' = + match structure_item.str_desc with + | Tstr_eval (expr, attributes) -> + toplevel_eval mapper expr attributes; + mp + | Tstr_module {mb_id; mb_loc; mb_expr} -> ( + let name = mb_id |> Ident.name |> Name.create in + let mp_inside = Module_path.enter_module mp ~name ~loc:mb_loc in + process_module_expr mp_inside mb_expr; + match mb_expr.mod_desc with + | Tmod_ident (path_, _lid) -> + Module_path.add_alias mp ~name + ~path:(path_ |> Dce_path.from_path_t) + | _ -> mp) + | Tstr_recmodule mbs -> + (* Process each module in the recursive group in the current scope; aliases are collected in the current scope too. *) + List.fold_left + (fun acc {Typedtree.mb_id; mb_loc; mb_expr} -> + let name = mb_id |> Ident.name |> Name.create in + let mp_inside = + Module_path.enter_module acc ~name ~loc:mb_loc + in + process_module_expr mp_inside mb_expr; + match mb_expr.mod_desc with + | Tmod_ident (path_, _lid) -> + Module_path.add_alias acc ~name + ~path:(path_ |> Dce_path.from_path_t) + | _ -> acc) + mp mbs + | _ -> + super.structure_item mapper structure_item |> ignore; + mp + in + loop mp' rest + in + loop module_path structure.str_items + in + fun (structure : Typedtree.structure) -> + process_structure Module_path.initial structure + +type file_result = { + module_name: string; + values_builder: values_builder; + checks: check list; +} +(** Result of processing a single file *) + +let process_structure ~file ~values_builder ~checks_builder + (structure : Typedtree.structure) = + let process = traverse_ast ~file ~values_builder ~checks_builder () in + process structure + +let process_cmt ~file (cmt_infos : Cmt_format.cmt_infos) : file_result option = + match cmt_infos.cmt_annots with + | Interface _ -> None + | Implementation structure -> + let values_builder = create_values_builder () in + let checks_builder = create_checks_builder () in + structure |> process_structure ~file ~values_builder ~checks_builder; + Some + { + module_name = file.File_context.module_name; + values_builder; + checks = checks_builder_to_list checks_builder; + } + | _ -> None + +(** Process all accumulated checks using merged values table *) +let run_checks ~config (all_results : file_result list) = + (* Merge all values builders *) + let values_table = + all_results + |> List.map (fun r -> (r.module_name, r.values_builder)) + |> merge_values_builders + in + (* Collect all checks *) + let all_checks = all_results |> List.concat_map (fun r -> r.checks) in + (* Run checks with merged table *) + Checks.do_checks ~values_table ~config all_checks diff --git a/analysis/reanalyze/src/exceptions.ml b/analysis/reanalyze/src/exceptions.ml new file mode 100644 index 00000000000..a5903143ad4 --- /dev/null +++ b/analysis/reanalyze/src/exceptions.ml @@ -0,0 +1,36 @@ +module Exn_set = Set.Make (Exn) + +type t = Exn_set.t + +let add = Exn_set.add +let diff = Exn_set.diff +let empty = Exn_set.empty +let from_list = Exn_set.of_list +let to_list = Exn_set.elements +let is_empty = Exn_set.is_empty +let iter = Exn_set.iter +let union = Exn_set.union + +let pp ~exn_table ppf exceptions = + let is_first = ref true in + let pp_exn exn = + let separator = if !is_first then "" else ", " in + is_first := false; + let name = Exn.to_string exn in + match exn_table with + | Some exn_table -> ( + match Hashtbl.find_opt exn_table exn with + | Some loc_set -> + let positions = + loc_set |> Loc_set.elements + |> List.map (fun loc -> loc.Location.loc_start) + in + Format.fprintf ppf "%s@{%s@} (@{%s@})" separator name + (positions |> List.map Pos.to_string |> String.concat " ") + | None -> Format.fprintf ppf "%s@{%s@}" separator name) + | None -> Format.fprintf ppf "%s@{%s@}" separator name + in + let is_list = exceptions |> Exn_set.cardinal > 1 in + if is_list then Format.fprintf ppf "["; + exceptions |> Exn_set.iter pp_exn; + if is_list then Format.fprintf ppf "]" diff --git a/analysis/reanalyze/src/exn.ml b/analysis/reanalyze/src/exn.ml new file mode 100644 index 00000000000..0f83bc988b1 --- /dev/null +++ b/analysis/reanalyze/src/exn.ml @@ -0,0 +1,19 @@ +type t = string + +let compare = String.compare +let decode_error = "DecodeError" +let assert_failure = "Assert_failure" +let division_by_zero = "Division_by_zero" +let end_of_file = "End_of_file" +let exit = "exit" +let failure = "Failure" +let invalid_argument = "Invalid_argument" +let js_exn = "JsExn" +let match_failure = "Match_failure" +let not_found = "Not_found" +let sys_error = "Sys_error" +let from_lid lid = lid |> Longident.flatten |> String.concat "." +let from_string s = s +let to_string s = s +let yojson_json_error = "Yojson.Json_error" +let yojson_type_error = "Yojson.Basic.Util.Type_error" diff --git a/analysis/reanalyze/src/exn.mli b/analysis/reanalyze/src/exn.mli new file mode 100644 index 00000000000..694e2ea4429 --- /dev/null +++ b/analysis/reanalyze/src/exn.mli @@ -0,0 +1,19 @@ +type t + +val compare : t -> t -> int +val assert_failure : t +val decode_error : t +val division_by_zero : t +val end_of_file : t +val exit : t +val failure : t +val from_lid : Longident.t -> t +val from_string : string -> t +val invalid_argument : t +val js_exn : t +val match_failure : t +val not_found : t +val sys_error : t +val to_string : t -> string +val yojson_json_error : t +val yojson_type_error : t diff --git a/analysis/reanalyze/src/exn_lib.ml b/analysis/reanalyze/src/exn_lib.ml new file mode 100644 index 00000000000..f6ce02723f4 --- /dev/null +++ b/analysis/reanalyze/src/exn_lib.ml @@ -0,0 +1,246 @@ +let raises_lib_table : (Name.t, Exceptions.t) Hashtbl.t = + let table = Hashtbl.create 15 in + let open Exn in + let belt_array = + [ + ("getExn", [assert_failure]); + ("getOrThrow", [assert_failure]); + ("setExn", [assert_failure]); + ("setOrThrow", [assert_failure]); + ] + in + let belt_list = + [ + ("getExn", [not_found]); + ("getOrThrow", [not_found]); + ("headExn", [not_found]); + ("headOrThrow", [not_found]); + ("tailExn", [not_found]); + ("tailOrThrow", [not_found]); + ] + in + let belt_map = [("getExn", [not_found]); ("getOrThrow", [not_found])] in + let belt_mutable_map = belt_map in + let belt_mutable_queue = + [ + ("peekExn", [not_found]); + ("peekOrThrow", [not_found]); + ("popExn", [not_found]); + ("popOrThrow", [not_found]); + ] + in + let belt_set = [("getExn", [not_found]); ("getOrThrow", [not_found])] in + let belt_mutable_set = belt_set in + let belt_option = [("getExn", [not_found]); ("getOrThrow", [not_found])] in + let belt_result = [("getExn", [not_found]); ("getOrThrow", [not_found])] in + let bs_json = + (* bs-json *) + [ + ("bool", [decode_error]); + ("float", [decode_error]); + ("int", [decode_error]); + ("string", [decode_error]); + ("char", [decode_error]); + ("date", [decode_error]); + ("nullable", [decode_error]); + ("nullAs", [decode_error]); + ("array", [decode_error]); + ("list", [decode_error]); + ("pair", [decode_error]); + ("tuple2", [decode_error]); + ("tuple3", [decode_error]); + ("tuple4", [decode_error]); + ("dict", [decode_error]); + ("field", [decode_error]); + ("at", [decode_error; invalid_argument]); + ("oneOf", [decode_error]); + ("either", [decode_error]); + ] + in + let stdlib = + [ + ("panic", [js_exn]); + ("assertEqual", [js_exn]); + ("invalid_arg", [invalid_argument]); + ("failwith", [failure]); + ("/", [division_by_zero]); + ("mod", [division_by_zero]); + ("char_of_int", [invalid_argument]); + ("bool_of_string", [invalid_argument]); + ("int_of_string", [failure]); + ("float_of_string", [failure]); + ] + in + let stdlib_big_int = + [ + ("fromStringExn", [js_exn]); + ("fromStringOrThrow", [js_exn]); + ("fromFloatOrThrow", [js_exn]); + ] + in + let stdlib_bool = + [ + ("fromStringExn", [invalid_argument]); + ("fromStringOrThrow", [invalid_argument]); + ] + in + let stdlib_js_error = + [ + ("EvalError.throwWithMessage", [js_exn]); + ("RangeError.throwWithMessage", [js_exn]); + ("ReferenceError.throwWithMessage", [js_exn]); + ("SyntaxError.throwWithMessage", [js_exn]); + ("TypeError.throwWithMessage", [js_exn]); + ("URIError.throwWithMessage", [js_exn]); + ("panic", [js_exn]); + ("throw", [js_exn]); + ("throwWithMessage", [js_exn]); + ] + in + let stdlib_error = + [("raise", [js_exn]); ("panic", [js_exn]); ("throw", [js_exn])] + in + let stdlib_exn = + [ + ("raiseError", [js_exn]); + ("raiseEvalError", [js_exn]); + ("raiseRangeError", [js_exn]); + ("raiseReferenceError", [js_exn]); + ("raiseSyntaxError", [js_exn]); + ("raiseTypeError", [js_exn]); + ("raiseUriError", [js_exn]); + ] + in + let stdlib_json = + [ + ("parseExn", [js_exn]); + ("parseExnWithReviver", [js_exn]); + ("parseOrThrow", [js_exn]); + ("stringifyAny", [js_exn]); + ("stringifyAnyWithIndent", [js_exn]); + ("stringifyAnyWithReplacer", [js_exn]); + ("stringifyAnyWithReplacerAndIndent", [js_exn]); + ("stringifyAnyWithFilter", [js_exn]); + ("stringifyAnyWithFilterAndIndent", [js_exn]); + ] + in + let stdlib_list = + [ + ("headExn", [not_found]); ("tailExn", [not_found]); ("getExn", [not_found]); + ] + in + let stdlib_null = [("getExn", [invalid_argument])] in + let stdlib_nullable = [("getExn", [invalid_argument])] in + let stdlib_option = [("getExn", [js_exn])] in + let stdlib_result = [("getExn", [not_found])] in + let yojson_basic = [("from_string", [yojson_json_error])] in + let yojson_basic_util = + [ + ("member", [yojson_type_error]); + ("to_assoc", [yojson_type_error]); + ("to_bool", [yojson_type_error]); + ("to_bool_option", [yojson_type_error]); + ("to_float", [yojson_type_error]); + ("to_float_option", [yojson_type_error]); + ("to_int", [yojson_type_error]); + ("to_list", [yojson_type_error]); + ("to_number", [yojson_type_error]); + ("to_number_option", [yojson_type_error]); + ("to_string", [yojson_type_error]); + ("to_string_option", [yojson_type_error]); + ] + in + [ + ("Belt.Array", belt_array); + ("Belt_Array", belt_array); + ("Belt.List", belt_list); + ("Belt_List", belt_list); + ("Belt.Map", belt_map); + ("Belt.Map.Int", belt_map); + ("Belt.Map.String", belt_map); + ("Belt_Map", belt_map); + ("Belt_Map.Int", belt_map); + ("Belt_Map.String", belt_map); + ("Belt_MapInt", belt_map); + ("Belt_MapString", belt_map); + ("Belt.MutableMap", belt_mutable_map); + ("Belt.MutableMap.Int", belt_mutable_map); + ("Belt.MutableMap.String", belt_mutable_map); + ("Belt_MutableMap", belt_mutable_map); + ("Belt_MutableMap.Int", belt_mutable_map); + ("Belt_MutableMap.String", belt_mutable_map); + ("Belt_MutableMapInt", belt_mutable_map); + ("Belt_MutableMapString", belt_mutable_map); + ("Belt.MutableQueue", belt_mutable_queue); + ("Belt_MutableQueue", belt_mutable_queue); + ("Belt_MutableSetInt", belt_mutable_set); + ("Belt_MutableSetString", belt_mutable_set); + ("Belt.MutableSet", belt_mutable_set); + ("Belt.MutableSet.Int", belt_mutable_set); + ("Belt.MutableSet.String", belt_mutable_set); + ("Belt.Option", belt_option); + ("Belt_Option", belt_option); + ("Belt.Result", belt_result); + ("Belt_Result", belt_result); + ("Belt.Set", belt_set); + ("Belt.Set.Int", belt_set); + ("Belt.Set.String", belt_set); + ("Belt_Set", belt_set); + ("Belt_Set.Int", belt_set); + ("Belt_Set.String", belt_set); + ("Belt_SetInt", belt_set); + ("Belt_SetString", belt_set); + ("BigInt", stdlib_big_int); + ("Bool", stdlib_bool); + ("Error", stdlib_error); + ("Exn", stdlib_exn); + ("JsError", stdlib_js_error); + ("Js.Json", [("parseExn", [js_exn])]); + ("JSON", stdlib_json); + ("Json_decode", bs_json); + ("Json.Decode", bs_json); + ("List", stdlib_list); + ("MutableSet", belt_mutable_set); + ("MutableSet.Int", belt_mutable_set); + ("MutableSet.String", belt_mutable_set); + ("Null", stdlib_null); + ("Nullable", stdlib_nullable); + ("Option", stdlib_option); + ("Pervasives", stdlib); + ("Result", stdlib_result); + ("Stdlib", stdlib); + ("Stdlib_BigInt", stdlib_big_int); + ("Stdlib.BigInt", stdlib_big_int); + ("Stdlib_Bool", stdlib_bool); + ("Stdlib.Bool", stdlib_bool); + ("Stdlib_Error", stdlib_error); + ("Stdlib.Error", stdlib_error); + ("Stdlib_Exn", stdlib_exn); + ("Stdlib.Exn", stdlib_exn); + ("Stdlib_JsError", stdlib_js_error); + ("Stdlib.JsError", stdlib_js_error); + ("Stdlib_JSON", stdlib_json); + ("Stdlib.JSON", stdlib_json); + ("Stdlib_List", stdlib_list); + ("Stdlib.List", stdlib_list); + ("Stdlib_Null", stdlib_null); + ("Stdlib.Null", stdlib_null); + ("Stdlib_Nullable", stdlib_nullable); + ("Stdlib.Nullable", stdlib_nullable); + ("Stdlib_Option", stdlib_option); + ("Stdlib.Option", stdlib_option); + ("Stdlib_Result", stdlib_result); + ("Stdlib.Result", stdlib_result); + ("Yojson.Basic", yojson_basic); + ("Yojson.Basic.Util", yojson_basic_util); + ] + |> List.iter (fun (name, group) -> + group + |> List.iter (fun (s, e) -> + Hashtbl.add table + (name ^ "." ^ s |> Name.create) + (e |> Exceptions.from_list))); + table + +let find (path : Dce_path.t) = + Hashtbl.find_opt raises_lib_table (path |> Dce_path.to_name) diff --git a/analysis/reanalyze/src/FileAnnotations.ml b/analysis/reanalyze/src/file_annotations.ml similarity index 59% rename from analysis/reanalyze/src/FileAnnotations.ml rename to analysis/reanalyze/src/file_annotations.ml index 60e78a0bb95..83cded03713 100644 --- a/analysis/reanalyze/src/FileAnnotations.ml +++ b/analysis/reanalyze/src/file_annotations.ml @@ -7,28 +7,28 @@ type annotated_as = GenType | Dead | Live (* Both types have the same representation, but different semantics *) -type t = annotated_as PosHash.t -type builder = annotated_as PosHash.t +type t = annotated_as Pos_hash.t +type builder = annotated_as Pos_hash.t (* ===== Builder API ===== *) -let create_builder () : builder = PosHash.create 1 +let create_builder () : builder = Pos_hash.create 1 let annotate_gentype (state : builder) (pos : Lexing.position) = - PosHash.replace state pos GenType + Pos_hash.replace state pos GenType let annotate_dead (state : builder) (pos : Lexing.position) = - PosHash.replace state pos Dead + Pos_hash.replace state pos Dead let annotate_live (state : builder) (pos : Lexing.position) = - PosHash.replace state pos Live + Pos_hash.replace state pos Live let merge_all (builders : builder list) : t = - let result = PosHash.create 1 in + let result = Pos_hash.create 1 in builders |> List.iter (fun builder -> - PosHash.iter - (fun pos value -> PosHash.replace result pos value) + Pos_hash.iter + (fun pos value -> Pos_hash.replace result pos value) builder); result @@ -36,24 +36,24 @@ let merge_all (builders : builder list) : t = let builder_to_list (builder : builder) : (Lexing.position * annotated_as) list = - PosHash.fold (fun pos value acc -> (pos, value) :: acc) builder [] + Pos_hash.fold (fun pos value acc -> (pos, value) :: acc) builder [] -let create_from_hashtbl (h : annotated_as PosHash.t) : t = h +let create_from_hashtbl (h : annotated_as Pos_hash.t) : t = h (* ===== Read-only API ===== *) -let is_annotated_dead (state : t) pos = PosHash.find_opt state pos = Some Dead +let is_annotated_dead (state : t) pos = Pos_hash.find_opt state pos = Some Dead let is_annotated_gentype_or_live (state : t) pos = - match PosHash.find_opt state pos with + match Pos_hash.find_opt state pos with | Some (Live | GenType) -> true | Some Dead | None -> false let is_annotated_gentype_or_dead (state : t) pos = - match PosHash.find_opt state pos with + match Pos_hash.find_opt state pos with | Some (Dead | GenType) -> true | Some Live | None -> false -let length (t : t) = PosHash.length t +let length (t : t) = Pos_hash.length t -let iter f (t : t) = PosHash.iter f t +let iter f (t : t) = Pos_hash.iter f t diff --git a/analysis/reanalyze/src/FileAnnotations.mli b/analysis/reanalyze/src/file_annotations.mli similarity index 96% rename from analysis/reanalyze/src/FileAnnotations.mli rename to analysis/reanalyze/src/file_annotations.mli index 292b5b5c129..3ca50fcacd2 100644 --- a/analysis/reanalyze/src/FileAnnotations.mli +++ b/analysis/reanalyze/src/file_annotations.mli @@ -32,7 +32,7 @@ val merge_all : builder list -> t val builder_to_list : builder -> (Lexing.position * annotated_as) list (** Extract all annotations as a list for reactive merge *) -val create_from_hashtbl : annotated_as PosHash.t -> t +val create_from_hashtbl : annotated_as Pos_hash.t -> t (** Create from hashtable for reactive merge *) (** {2 Read-only API for t - for solver} *) diff --git a/analysis/reanalyze/src/file_deps.ml b/analysis/reanalyze/src/file_deps.ml new file mode 100644 index 00000000000..d02a040a77b --- /dev/null +++ b/analysis/reanalyze/src/file_deps.ml @@ -0,0 +1,157 @@ +(** File dependencies collected during AST processing. + + Tracks which files reference which other files. *) + +(* File-keyed hashtable *) +module File_hash = Hashtbl.Make (struct + type t = string + + let hash (x : t) = Hashtbl.hash x + let equal (x : t) y = x = y +end) + +(** {2 Types} *) + +type t = { + files: File_set.t; + deps: File_set.t File_hash.t; (* from_file -> set of to_files *) +} + +type builder = {mutable files: File_set.t; deps: File_set.t File_hash.t} + +(** {2 Builder API} *) + +let create_builder () : builder = + {files = File_set.empty; deps = File_hash.create 256} + +let add_file (b : builder) file = + b.files <- File_set.add file b.files; + (* Ensure file has an entry even if no deps *) + if not (File_hash.mem b.deps file) then + File_hash.replace b.deps file File_set.empty + +let add_dep (b : builder) ~from_file ~to_file = + let set = + match File_hash.find_opt b.deps from_file with + | Some s -> s + | None -> File_set.empty + in + File_hash.replace b.deps from_file (File_set.add to_file set) + +(** {2 Merge API} *) + +let merge_into_builder ~(from : builder) ~(into : builder) = + into.files <- File_set.union into.files from.files; + File_hash.iter + (fun from_file to_files -> + let existing = + match File_hash.find_opt into.deps from_file with + | Some s -> s + | None -> File_set.empty + in + File_hash.replace into.deps from_file (File_set.union existing to_files)) + from.deps + +let freeze_builder (b : builder) : t = + (* This is a zero-copy operation, so it's "unsafe" if the builder is + subsequently mutated. However, the calling discipline is that the + builder is no longer used after freezing. *) + {files = b.files; deps = b.deps} + +let merge_all (builders : builder list) : t = + let merged_builder = create_builder () in + builders + |> List.iter (fun b -> merge_into_builder ~from:b ~into:merged_builder); + freeze_builder merged_builder + +(** {2 Builder extraction for reactive merge} *) + +let builder_files (builder : builder) : File_set.t = builder.files + +let builder_deps_to_list (builder : builder) : (string * File_set.t) list = + File_hash.fold + (fun from_file to_files acc -> (from_file, to_files) :: acc) + builder.deps [] + +let create ~files ~deps : t = {files; deps} + +(** {2 Read-only API} *) + +let get_files (t : t) = t.files + +let get_deps (t : t) file = + match File_hash.find_opt t.deps file with + | Some s -> s + | None -> File_set.empty + +let iter_deps (t : t) f = File_hash.iter f t.deps + +let file_exists (t : t) file = File_hash.mem t.deps file + +let files_count (t : t) = File_set.cardinal t.files + +let deps_count (t : t) = File_hash.length t.deps + +(** {2 Topological ordering} *) + +let iter_files_from_roots_to_leaves (t : t) iter_fun = + (* For each file, the number of incoming references *) + let inverse_references = (Hashtbl.create 256 : (string, int) Hashtbl.t) in + (* For each number of incoming references, the files *) + let references_by_number = + (Hashtbl.create 256 : (int, File_set.t) Hashtbl.t) + in + let get_num file_name = + try Hashtbl.find inverse_references file_name with Not_found -> 0 + in + let get_set num = + try Hashtbl.find references_by_number num with Not_found -> File_set.empty + in + let add_incoming_edge file_name = + let old_num = get_num file_name in + let new_num = old_num + 1 in + let old_set_at_num = get_set old_num in + let new_set_at_num = File_set.remove file_name old_set_at_num in + let old_set_at_new_num = get_set new_num in + let new_set_at_new_num = File_set.add file_name old_set_at_new_num in + Hashtbl.replace inverse_references file_name new_num; + Hashtbl.replace references_by_number old_num new_set_at_num; + Hashtbl.replace references_by_number new_num new_set_at_new_num + in + let remove_incoming_edge file_name = + let old_num = get_num file_name in + let new_num = old_num - 1 in + let old_set_at_num = get_set old_num in + let new_set_at_num = File_set.remove file_name old_set_at_num in + let old_set_at_new_num = get_set new_num in + let new_set_at_new_num = File_set.add file_name old_set_at_new_num in + Hashtbl.replace inverse_references file_name new_num; + Hashtbl.replace references_by_number old_num new_set_at_num; + Hashtbl.replace references_by_number new_num new_set_at_new_num + in + let add_edge from_file to_file = + if file_exists t from_file then add_incoming_edge to_file + in + let remove_edge from_file to_file = + if file_exists t from_file then remove_incoming_edge to_file + in + iter_deps t (fun from_file set -> + if get_num from_file = 0 then + Hashtbl.replace references_by_number 0 + (File_set.add from_file (get_set 0)); + set |> File_set.iter (fun to_file -> add_edge from_file to_file)); + while get_set 0 <> File_set.empty do + let files_with_no_incoming_references = get_set 0 in + Hashtbl.remove references_by_number 0; + files_with_no_incoming_references + |> File_set.iter (fun file_name -> + iter_fun file_name; + let references = get_deps t file_name in + references + |> File_set.iter (fun to_file -> remove_edge file_name to_file)) + done; + (* Process any remaining items in case of circular references *) + references_by_number + |> Hashtbl.iter (fun _num set -> + if File_set.is_empty set then () + else set |> File_set.iter (fun file_name -> iter_fun file_name)) diff --git a/analysis/reanalyze/src/FileDeps.mli b/analysis/reanalyze/src/file_deps.mli similarity index 84% rename from analysis/reanalyze/src/FileDeps.mli rename to analysis/reanalyze/src/file_deps.mli index 1536d664515..3e43a806e37 100644 --- a/analysis/reanalyze/src/FileDeps.mli +++ b/analysis/reanalyze/src/file_deps.mli @@ -37,29 +37,29 @@ val merge_all : builder list -> t (** {2 Builder extraction for reactive merge} *) -val builder_files : builder -> FileSet.t +val builder_files : builder -> File_set.t (** Get files set from builder *) -val builder_deps_to_list : builder -> (string * FileSet.t) list +val builder_deps_to_list : builder -> (string * File_set.t) list (** Extract all deps as a list for reactive merge *) (** {2 Internal types (for ReactiveMerge)} *) -module FileHash : Hashtbl.S with type key = string +module File_hash : Hashtbl.S with type key = string (** File-keyed hashtable *) -val create : files:FileSet.t -> deps:FileSet.t FileHash.t -> t +val create : files:File_set.t -> deps:File_set.t File_hash.t -> t (** Create a FileDeps.t from files set and deps hashtable *) (** {2 Read-only API for t - for analysis} *) -val get_files : t -> FileSet.t +val get_files : t -> File_set.t (** Get all files. *) -val get_deps : t -> string -> FileSet.t +val get_deps : t -> string -> File_set.t (** Get files that a given file depends on. *) -val iter_deps : t -> (string -> FileSet.t -> unit) -> unit +val iter_deps : t -> (string -> File_set.t -> unit) -> unit (** Iterate over all file dependencies. *) val file_exists : t -> string -> bool diff --git a/analysis/reanalyze/src/FileHash.ml b/analysis/reanalyze/src/file_hash.ml similarity index 100% rename from analysis/reanalyze/src/FileHash.ml rename to analysis/reanalyze/src/file_hash.ml diff --git a/analysis/reanalyze/src/FileSet.ml b/analysis/reanalyze/src/file_set.ml similarity index 100% rename from analysis/reanalyze/src/FileSet.ml rename to analysis/reanalyze/src/file_set.ml diff --git a/analysis/reanalyze/src/FindSourceFile.ml b/analysis/reanalyze/src/find_source_file.ml similarity index 100% rename from analysis/reanalyze/src/FindSourceFile.ml rename to analysis/reanalyze/src/find_source_file.ml diff --git a/analysis/reanalyze/src/Issue.ml b/analysis/reanalyze/src/issue.ml similarity index 58% rename from analysis/reanalyze/src/Issue.ml rename to analysis/reanalyze/src/issue.ml index ed9ab87b22f..4aa9bb76a69 100644 --- a/analysis/reanalyze/src/Issue.ml +++ b/analysis/reanalyze/src/issue.ml @@ -2,18 +2,18 @@ These types represent the various issues that can be reported. *) -module ExnSet = Set.Make (Exn) +module Exn_set = Set.Make (Exn) -type missingThrowInfo = { - exnName: string; - exnTable: (Exn.t, LocSet.t) Hashtbl.t; - locFull: Location.t; - missingAnnotations: ExnSet.t; - throwSet: ExnSet.t; +type missing_throw_info = { + exn_name: string; + exn_table: (Exn.t, Loc_set.t) Hashtbl.t; + loc_full: Location.t; + missing_annotations: Exn_set.t; + throw_set: Exn_set.t; } type severity = Warning | Error -type deadOptional = WarningUnusedArgument | WarningRedundantOptionalArgument +type dead_optional = WarningUnusedArgument | WarningRedundantOptionalArgument type termination = | ErrorHygiene @@ -21,7 +21,7 @@ type termination = | ErrorTermination | TerminationAnalysisInternal -type deadWarning = +type dead_warning = | WarningDeadException | WarningDeadType | WarningDeadValue @@ -31,10 +31,10 @@ type deadWarning = type description = | Circular of {message: string} | ExceptionAnalysis of {message: string} - | ExceptionAnalysisMissing of missingThrowInfo + | ExceptionAnalysisMissing of missing_throw_info | DeadModule of {message: string} - | DeadOptional of {deadOptional: deadOptional; message: string} - | DeadWarning of {deadWarning: deadWarning; path: string; message: string} + | DeadOptional of {dead_optional: dead_optional; message: string} + | DeadWarning of {dead_warning: dead_warning; path: string; message: string} | Termination of {termination: termination; message: string} type t = { diff --git a/analysis/reanalyze/src/issues.ml b/analysis/reanalyze/src/issues.ml new file mode 100644 index 00000000000..62f64523703 --- /dev/null +++ b/analysis/reanalyze/src/issues.ml @@ -0,0 +1,15 @@ +let error_hygiene = "Error Hygiene" +let error_not_implemented = "Error Not Implemented" +let error_termination = "Error Termination" +let exception_analysis = "Exception Analysis" +let incorrect_dead_annotation = "Incorrect Dead Annotation" +let termination_analysis_internal = "Termination Analysis Internal" +let warning_dead_analysis_cycle = "Warning Dead Analysis Cycle" +let warning_dead_exception = "Warning Dead Exception" +let warning_dead_module = "Warning Dead Module" +let warning_dead_type = "Warning Dead Type" +let warning_dead_value = "Warning Dead Value" +let warning_dead_value_with_side_effects = + "Warning Dead Value With Side Effects" +let warning_redundant_optional_argument = "Warning Redundant Optional Argument" +let warning_unused_argument = "Warning Unused Argument" diff --git a/analysis/reanalyze/src/Liveness.ml b/analysis/reanalyze/src/liveness.ml similarity index 63% rename from analysis/reanalyze/src/Liveness.ml rename to analysis/reanalyze/src/liveness.ml index ed80c436a4c..c40f4b3426e 100644 --- a/analysis/reanalyze/src/Liveness.ml +++ b/analysis/reanalyze/src/liveness.ml @@ -26,56 +26,56 @@ let reason_to_string = function (** Check if a position is within a declaration's range *) let pos_in_decl (pos : Lexing.position) (decl : Decl.t) : bool = pos.pos_fname = decl.pos.pos_fname - && pos.pos_cnum >= decl.posStart.pos_cnum - && pos.pos_cnum <= decl.posEnd.pos_cnum + && pos.pos_cnum >= decl.pos_start.pos_cnum + && pos.pos_cnum <= decl.pos_end.pos_cnum (** Build a hashtable mapping posTo -> bool indicating if it has external refs. External refs are refs where posFrom is NOT a declaration position. (Matching backward algorithm: it checks find_opt, not range containment) *) -let find_externally_referenced ~(decl_store : DeclarationStore.t) - ~(refs : References.t) : bool PosHash.t = - let externally_referenced = PosHash.create 256 in +let find_externally_referenced ~(decl_store : Declaration_store.t) + ~(refs : References.t) : bool Pos_hash.t = + let externally_referenced = Pos_hash.create 256 in (* Helper: check if posFrom is a declaration position *) - let is_decl_pos posFrom = - DeclarationStore.find_opt decl_store posFrom <> None + let is_decl_pos pos_from = + Declaration_store.find_opt decl_store pos_from <> None in (* Check value refs *) - References.iter_value_refs_from refs (fun posFrom posToSet -> - if not (is_decl_pos posFrom) then - PosSet.iter - (fun posTo -> PosHash.replace externally_referenced posTo true) - posToSet); + References.iter_value_refs_from refs (fun pos_from pos_to_set -> + if not (is_decl_pos pos_from) then + Pos_set.iter + (fun pos_to -> Pos_hash.replace externally_referenced pos_to true) + pos_to_set); (* Check type refs *) - References.iter_type_refs_from refs (fun posFrom posToSet -> - if not (is_decl_pos posFrom) then - PosSet.iter - (fun posTo -> PosHash.replace externally_referenced posTo true) - posToSet); + References.iter_type_refs_from refs (fun pos_from pos_to_set -> + if not (is_decl_pos pos_from) then + Pos_set.iter + (fun pos_to -> Pos_hash.replace externally_referenced pos_to true) + pos_to_set); externally_referenced (** Check if a declaration is inherently live (a root) *) let is_root ~ann_store ~externally_referenced (decl : Decl.t) = - AnnotationStore.is_annotated_gentype_or_live ann_store decl.pos - || PosHash.mem externally_referenced decl.pos + Annotation_store.is_annotated_gentype_or_live ann_store decl.pos + || Pos_hash.mem externally_referenced decl.pos (** Build index mapping declaration positions to their outgoing refs. Done once upfront to avoid O(worklist × refs) in the main loop. Optimized by grouping declarations by file first, so we only check declarations in the same file as each ref source. *) -let build_decl_refs_index ~(decl_store : DeclarationStore.t) - ~(refs : References.t) : (PosSet.t * PosSet.t) PosHash.t = - let index = PosHash.create 256 in +let build_decl_refs_index ~(decl_store : Declaration_store.t) + ~(refs : References.t) : (Pos_set.t * Pos_set.t) Pos_hash.t = + let index = Pos_hash.create 256 in (* Group declarations by file for efficient lookup *) let decls_by_file : (string, (Lexing.position * Decl.t) list) Hashtbl.t = Hashtbl.create 256 in - DeclarationStore.iter + Declaration_store.iter (fun pos decl -> let fname = pos.Lexing.pos_fname in let existing = @@ -87,44 +87,44 @@ let build_decl_refs_index ~(decl_store : DeclarationStore.t) (* Helper to add targets to a declaration's index entry *) let add_targets decl_pos targets ~is_type = let value_targets, type_targets = - match PosHash.find_opt index decl_pos with + match Pos_hash.find_opt index decl_pos with | Some pair -> pair - | None -> (PosSet.empty, PosSet.empty) + | None -> (Pos_set.empty, Pos_set.empty) in let new_pair = - if is_type then (value_targets, PosSet.union type_targets targets) - else (PosSet.union value_targets targets, type_targets) + if is_type then (value_targets, Pos_set.union type_targets targets) + else (Pos_set.union value_targets targets, type_targets) in - PosHash.replace index decl_pos new_pair + Pos_hash.replace index decl_pos new_pair in (* For each ref, find which declaration (in same file) contains its source *) - let process_ref posFrom posToSet ~is_type = - let fname = posFrom.Lexing.pos_fname in + let process_ref pos_from pos_to_set ~is_type = + let fname = pos_from.Lexing.pos_fname in match Hashtbl.find_opt decls_by_file fname with | None -> () (* No declarations in this file *) | Some decls_in_file -> List.iter (fun (decl_pos, decl) -> - if pos_in_decl posFrom decl then - add_targets decl_pos posToSet ~is_type) + if pos_in_decl pos_from decl then + add_targets decl_pos pos_to_set ~is_type) decls_in_file in - References.iter_value_refs_from refs (fun posFrom posToSet -> - process_ref posFrom posToSet ~is_type:false); - References.iter_type_refs_from refs (fun posFrom posToSet -> - process_ref posFrom posToSet ~is_type:true); + References.iter_value_refs_from refs (fun pos_from pos_to_set -> + process_ref pos_from pos_to_set ~is_type:false); + References.iter_type_refs_from refs (fun pos_from pos_to_set -> + process_ref pos_from pos_to_set ~is_type:true); index (** Compute liveness using forward propagation from roots. Returns a hashtable mapping positions to their live reason. *) -let compute_forward ~debug ~(decl_store : DeclarationStore.t) - ~(refs : References.t) ~(ann_store : AnnotationStore.t) : - live_reason PosHash.t * (PosSet.t * PosSet.t) PosHash.t = +let compute_forward ~debug ~(decl_store : Declaration_store.t) + ~(refs : References.t) ~(ann_store : Annotation_store.t) : + live_reason Pos_hash.t * (Pos_set.t * Pos_set.t) Pos_hash.t = let t0 = Unix.gettimeofday () in - let live = PosHash.create 256 in + let live = Pos_hash.create 256 in let worklist = Queue.create () in let root_count = ref 0 in let propagated_count = ref 0 in @@ -141,13 +141,13 @@ let compute_forward ~debug ~(decl_store : DeclarationStore.t) containing declaration). *) let decls_with_out = ref 0 in let out_edges_to_decls = ref 0 in - PosHash.iter + Pos_hash.iter (fun _decl_pos (value_targets, type_targets) -> incr decls_with_out; let count_targets targets = - PosSet.fold + Pos_set.fold (fun target acc -> - match DeclarationStore.find_opt decl_store target with + match Declaration_store.find_opt decl_store target with | Some _ -> acc + 1 | None -> acc) targets 0 @@ -159,28 +159,28 @@ let compute_forward ~debug ~(decl_store : DeclarationStore.t) decl_refs_index; Log_.item "@.Forward Liveness Analysis@.@."; Log_.item " decls: %d@." - (DeclarationStore.fold (fun _ _ acc -> acc + 1) decl_store 0); + (Declaration_store.fold (fun _ _ acc -> acc + 1) decl_store 0); Log_.item " roots(external targets): %d@." - (PosHash.length externally_referenced); + (Pos_hash.length externally_referenced); Log_.item " decl-deps: decls_with_out=%d edges_to_decls=%d@.@." !decls_with_out !out_edges_to_decls); (* Initialize with roots *) - DeclarationStore.iter + Declaration_store.iter (fun pos decl -> if is_root ~ann_store ~externally_referenced decl then ( incr root_count; let reason = - if AnnotationStore.is_annotated_gentype_or_live ann_store pos then + if Annotation_store.is_annotated_gentype_or_live ann_store pos then Annotated else ExternalRef in - PosHash.replace live pos reason; + Pos_hash.replace live pos reason; Queue.push (pos, decl) worklist; if debug then Log_.item " Root (%s): %s %s@." (reason_to_string reason) - (decl.declKind |> Decl.Kind.toString) - (decl.path |> DcePath.toString))) + (decl.decl_kind |> Decl.Kind.to_string) + (decl.path |> Dce_path.to_string))) decl_store; if debug then Log_.item "@. %d roots found@.@." !root_count; @@ -191,53 +191,53 @@ let compute_forward ~debug ~(decl_store : DeclarationStore.t) let pos, decl = Queue.pop worklist in (* Skip if this position is annotated @dead - don't propagate from it *) - if not (AnnotationStore.is_annotated_dead ann_store pos) then + if not (Annotation_store.is_annotated_dead ann_store pos) then (* Look up pre-computed targets for this declaration *) - match PosHash.find_opt decl_refs_index pos with + match Pos_hash.find_opt decl_refs_index pos with | None -> () (* No outgoing refs from this declaration *) | Some (value_targets, type_targets) -> (* Propagate to value targets that are value declarations *) - PosSet.iter + Pos_set.iter (fun target -> - if not (PosHash.mem live target) then - match DeclarationStore.find_opt decl_store target with + if not (Pos_hash.mem live target) then + match Declaration_store.find_opt decl_store target with | Some target_decl - when not (target_decl.declKind |> Decl.Kind.isType) -> + when not (target_decl.decl_kind |> Decl.Kind.is_type) -> incr propagated_count; - PosHash.replace live target Propagated; + Pos_hash.replace live target Propagated; Queue.push (target, target_decl) worklist; if debug then Log_.item " Propagate: %s -> %s@." - (decl.path |> DcePath.toString) - (target_decl.path |> DcePath.toString) + (decl.path |> Dce_path.to_string) + (target_decl.path |> Dce_path.to_string) | Some _ -> (* Type target from value ref - see below *) () | None -> (* External or non-declaration target *) - PosHash.replace live target Propagated) + Pos_hash.replace live target Propagated) value_targets; (* Propagate to type targets that are type declarations *) - PosSet.iter + Pos_set.iter (fun target -> - if not (PosHash.mem live target) then - match DeclarationStore.find_opt decl_store target with - | Some target_decl when target_decl.declKind |> Decl.Kind.isType + if not (Pos_hash.mem live target) then + match Declaration_store.find_opt decl_store target with + | Some target_decl when target_decl.decl_kind |> Decl.Kind.is_type -> incr propagated_count; - PosHash.replace live target Propagated; + Pos_hash.replace live target Propagated; Queue.push (target, target_decl) worklist; if debug then Log_.item " Propagate: %s -> %s@." - (decl.path |> DcePath.toString) - (target_decl.path |> DcePath.toString) + (decl.path |> Dce_path.to_string) + (target_decl.path |> Dce_path.to_string) | Some _ -> (* Value target from type ref - skip *) () | None -> (* External or non-declaration target *) - PosHash.replace live target Propagated) + Pos_hash.replace live target Propagated) type_targets done; @@ -251,16 +251,16 @@ let compute_forward ~debug ~(decl_store : DeclarationStore.t) " Liveness.compute_forward: %.3fms (roots=%d, propagated=%d, live=%d)\n\ %!" ((t1 -. t0) *. 1000.0) - !root_count !propagated_count (PosHash.length live); + !root_count !propagated_count (Pos_hash.length live); (live, decl_refs_index) (** Check if a position is live according to forward-computed liveness *) -let is_live_forward ~(live : live_reason PosHash.t) (pos : Lexing.position) : +let is_live_forward ~(live : live_reason Pos_hash.t) (pos : Lexing.position) : bool = - PosHash.mem live pos + Pos_hash.mem live pos (** Get the reason why a position is live, if it is *) -let get_live_reason ~(live : live_reason PosHash.t) (pos : Lexing.position) : +let get_live_reason ~(live : live_reason Pos_hash.t) (pos : Lexing.position) : live_reason option = - PosHash.find_opt live pos + Pos_hash.find_opt live pos diff --git a/analysis/reanalyze/src/Liveness.mli b/analysis/reanalyze/src/liveness.mli similarity index 81% rename from analysis/reanalyze/src/Liveness.mli rename to analysis/reanalyze/src/liveness.mli index 09a4819b69b..c2a3c2b3e77 100644 --- a/analysis/reanalyze/src/Liveness.mli +++ b/analysis/reanalyze/src/liveness.mli @@ -20,19 +20,19 @@ val reason_to_string : live_reason -> string val compute_forward : debug:bool -> - decl_store:DeclarationStore.t -> + decl_store:Declaration_store.t -> refs:References.t -> - ann_store:AnnotationStore.t -> - live_reason PosHash.t * (PosSet.t * PosSet.t) PosHash.t + ann_store:Annotation_store.t -> + live_reason Pos_hash.t * (Pos_set.t * Pos_set.t) Pos_hash.t (** Compute liveness using forward propagation. Returns a hashtable mapping live positions to their [live_reason]. Also returns the precomputed declaration dependency index: decl_pos -> (value_targets, type_targets). Pass [~debug:true] for verbose output. *) -val is_live_forward : live:live_reason PosHash.t -> Lexing.position -> bool +val is_live_forward : live:live_reason Pos_hash.t -> Lexing.position -> bool (** Check if a position is live according to forward-computed liveness *) val get_live_reason : - live:live_reason PosHash.t -> Lexing.position -> live_reason option + live:live_reason Pos_hash.t -> Lexing.position -> live_reason option (** Get the reason why a position is live, if it is *) diff --git a/analysis/reanalyze/src/LocSet.ml b/analysis/reanalyze/src/loc_set.ml similarity index 100% rename from analysis/reanalyze/src/LocSet.ml rename to analysis/reanalyze/src/loc_set.ml diff --git a/analysis/reanalyze/src/Log_.ml b/analysis/reanalyze/src/log_.ml similarity index 50% rename from analysis/reanalyze/src/Log_.ml rename to analysis/reanalyze/src/log_.ml index 19e03cf8aef..f365b1f1c6c 100644 --- a/analysis/reanalyze/src/Log_.ml +++ b/analysis/reanalyze/src/log_.ml @@ -1,7 +1,7 @@ module Color = struct let color_enabled = lazy (Unix.isatty Unix.stdout) - let forceColor = ref false - let get_color_enabled () = !forceColor || Lazy.force color_enabled + let force_color = ref false + let get_color_enabled () = !force_color || Lazy.force color_enabled type color = Red | Yellow | Magenta | Cyan type style = FG of color | Bold | Dim @@ -14,13 +14,13 @@ module Color = struct | Bold -> "1" | Dim -> "2" - let getStringTag s = + let get_string_tag s = match s with | Format.String_tag s -> s | _ -> "" let style_of_tag s = - match s |> getStringTag with + match s |> get_string_tag with | "error" -> [Bold; FG Red] | "warning" -> [Bold; FG Magenta] | "info" -> [Bold; FG Yellow] @@ -35,16 +35,16 @@ module Color = struct let reset_lit = "\027[0m" - let setOpenCloseTag openTag closeTag = + let set_open_close_tag open_tag close_tag = { - Format.mark_open_stag = openTag; - mark_close_stag = closeTag; + Format.mark_open_stag = open_tag; + mark_close_stag = close_tag; print_open_stag = (fun _ -> ()); print_close_stag = (fun _ -> ()); } let color_functions = - setOpenCloseTag + set_open_close_tag (fun s -> if get_color_enabled () then ansi_of_tag s else "") (fun _ -> if get_color_enabled () then reset_lit else "") @@ -63,10 +63,10 @@ module Loc = struct let print_loc ppf (loc : Location.t) = (* Change the range so it's on a single line. In this way, the line number is clickable in vscode. *) - let startChar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in - let endChar = startChar + loc.loc_end.pos_cnum - loc.loc_start.pos_cnum in + let start_char = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in + let end_char = start_char + loc.loc_end.pos_cnum - loc.loc_start.pos_cnum in let line = loc.loc_start.pos_lnum in - let processPos char (pos : Lexing.position) : Lexing.position = + let process_pos char (pos : Lexing.position) : Lexing.position = { pos_lnum = line; pos_bol = 0; @@ -82,8 +82,8 @@ module Loc = struct Location.print_loc ppf { loc with - loc_start = loc.loc_start |> processPos startChar; - loc_end = loc.loc_end |> processPos endChar; + loc_start = loc.loc_start |> process_pos start_char; + loc_end = loc.loc_end |> process_pos end_char; } let print ppf (loc : Location.t) = Format.fprintf ppf "@[%a@]" print_loc loc @@ -95,35 +95,35 @@ let item x = Format.fprintf Format.std_formatter " "; Format.fprintf Format.std_formatter x -let missingRaiseInfoToText {Issue.missingAnnotations; locFull} = - let missingTxt = - Format.asprintf "%a" (Exceptions.pp ~exnTable:None) missingAnnotations +let missing_raise_info_to_text {Issue.missing_annotations; loc_full} = + let missing_txt = + Format.asprintf "%a" (Exceptions.pp ~exn_table:None) missing_annotations in if !Cli.json then - EmitJson.emitAnnotate ~action:"Add @throws annotation" - ~pos:(EmitJson.locToPos locFull) - ~text:(Format.asprintf "@throws(%s)\\n" missingTxt) + Emit_json.emit_annotate ~action:"Add @throws annotation" + ~pos:(Emit_json.loc_to_pos loc_full) + ~text:(Format.asprintf "@throws(%s)\\n" missing_txt) else "" -let logAdditionalInfo ~(description : Issue.description) = +let log_additional_info ~(description : Issue.description) = match description with - | ExceptionAnalysisMissing missingRaiseInfo -> - missingRaiseInfoToText missingRaiseInfo + | ExceptionAnalysisMissing missing_raise_info -> + missing_raise_info_to_text missing_raise_info | _ -> "" -let missingThrowInfoToMessage - {Issue.exnTable; exnName; missingAnnotations; throwSet} = - let throwsTxt = - Format.asprintf "%a" (Exceptions.pp ~exnTable:(Some exnTable)) throwSet +let missing_throw_info_to_message + {Issue.exn_table; exn_name; missing_annotations; throw_set} = + let throws_txt = + Format.asprintf "%a" (Exceptions.pp ~exn_table:(Some exn_table)) throw_set in - let missingTxt = - Format.asprintf "%a" (Exceptions.pp ~exnTable:None) missingAnnotations + let missing_txt = + Format.asprintf "%a" (Exceptions.pp ~exn_table:None) missing_annotations in Format.asprintf - "@{%s@} might throw %s and is not annotated with @throws(%s)" exnName - throwsTxt missingTxt + "@{%s@} might throw %s and is not annotated with @throws(%s)" exn_name + throws_txt missing_txt -let descriptionToMessage (description : Issue.description) = +let description_to_message (description : Issue.description) = match description with | Circular {message} -> message | DeadModule {message} -> message @@ -131,58 +131,58 @@ let descriptionToMessage (description : Issue.description) = | DeadWarning {path; message} -> Format.asprintf "@{%s@} %s" path message | ExceptionAnalysis {message} -> message - | ExceptionAnalysisMissing missingRaiseInfo -> - missingThrowInfoToMessage missingRaiseInfo + | ExceptionAnalysisMissing missing_raise_info -> + missing_throw_info_to_message missing_raise_info | Termination {message} -> message -let descriptionToName (description : Issue.description) = +let description_to_name (description : Issue.description) = match description with - | Circular _ -> Issues.warningDeadAnalysisCycle - | DeadModule _ -> Issues.warningDeadModule - | DeadOptional {deadOptional = WarningUnusedArgument} -> - Issues.warningUnusedArgument - | DeadOptional {deadOptional = WarningRedundantOptionalArgument} -> - Issues.warningRedundantOptionalArgument - | DeadWarning {deadWarning = WarningDeadException} -> - Issues.warningDeadException - | DeadWarning {deadWarning = WarningDeadType} -> Issues.warningDeadType - | DeadWarning {deadWarning = WarningDeadValue} -> Issues.warningDeadValue - | DeadWarning {deadWarning = WarningDeadValueWithSideEffects} -> - Issues.warningDeadValueWithSideEffects - | DeadWarning {deadWarning = IncorrectDeadAnnotation} -> - Issues.incorrectDeadAnnotation - | ExceptionAnalysis _ -> Issues.exceptionAnalysis - | ExceptionAnalysisMissing _ -> Issues.exceptionAnalysis - | Termination {termination = ErrorHygiene} -> Issues.errorHygiene + | Circular _ -> Issues.warning_dead_analysis_cycle + | DeadModule _ -> Issues.warning_dead_module + | DeadOptional {dead_optional = WarningUnusedArgument} -> + Issues.warning_unused_argument + | DeadOptional {dead_optional = WarningRedundantOptionalArgument} -> + Issues.warning_redundant_optional_argument + | DeadWarning {dead_warning = WarningDeadException} -> + Issues.warning_dead_exception + | DeadWarning {dead_warning = WarningDeadType} -> Issues.warning_dead_type + | DeadWarning {dead_warning = WarningDeadValue} -> Issues.warning_dead_value + | DeadWarning {dead_warning = WarningDeadValueWithSideEffects} -> + Issues.warning_dead_value_with_side_effects + | DeadWarning {dead_warning = IncorrectDeadAnnotation} -> + Issues.incorrect_dead_annotation + | ExceptionAnalysis _ -> Issues.exception_analysis + | ExceptionAnalysisMissing _ -> Issues.exception_analysis + | Termination {termination = ErrorHygiene} -> Issues.error_hygiene | Termination {termination = ErrorNotImplemented} -> - Issues.errorNotImplemented - | Termination {termination = ErrorTermination} -> Issues.errorTermination + Issues.error_not_implemented + | Termination {termination = ErrorTermination} -> Issues.error_termination | Termination {termination = TerminationAnalysisInternal} -> - Issues.terminationAnalysisInternal + Issues.termination_analysis_internal -let logIssue ~config ~(issue : Issue.t) = +let log_issue ~config ~(issue : Issue.t) = let open Format in let loc = issue.loc in - if config.DceConfig.cli.json then + if config.Dce_config.cli.json then let file = loc.loc_start.pos_fname in - let startLine = loc.loc_start.pos_lnum - 1 in - let startCharacter = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in - let endLine = loc.loc_end.pos_lnum - 1 in - let endCharacter = loc.loc_end.pos_cnum - loc.loc_start.pos_bol in - let message = descriptionToMessage issue.description in + let start_line = loc.loc_start.pos_lnum - 1 in + let start_character = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in + let end_line = loc.loc_end.pos_lnum - 1 in + let end_character = loc.loc_end.pos_cnum - loc.loc_start.pos_bol in + let message = description_to_message issue.description in Format.asprintf "%a%s%s" (fun ppf () -> - EmitJson.emitItem ~ppf ~name:issue.name + Emit_json.emit_item ~ppf ~name:issue.name ~kind: (match issue.severity with | Warning -> "warning" | Error -> "error") ~file - ~range:(startLine, startCharacter, endLine, endCharacter) + ~range:(start_line, start_character, end_line, end_character) ~message) () - (logAdditionalInfo ~description:issue.description) - (if config.DceConfig.cli.json then EmitJson.emitClose () else "") + (log_additional_info ~description:issue.description) + (if config.Dce_config.cli.json then Emit_json.emit_close () else "") else let color = match issue.severity with @@ -190,16 +190,16 @@ let logIssue ~config ~(issue : Issue.t) = | Error -> Color.error in asprintf "@. %a@. %a@. %s%s@." color issue.name Loc.print issue.loc - (descriptionToMessage issue.description) - (logAdditionalInfo ~description:issue.description) + (description_to_message issue.description) + (log_additional_info ~description:issue.description) module Stats = struct let issues = ref [] - let addIssue (issue : Issue.t) = issues := issue :: !issues + let add_issue (issue : Issue.t) = issues := issue :: !issues let clear () = issues := [] let get_issue_count () = List.length !issues - let getSortedIssues () = + let get_sorted_issues () = let counters2 = Hashtbl.create 1 in !issues |> List.iter (fun (issue : Issue.t) -> @@ -212,38 +212,38 @@ module Stats = struct counter in incr counter); - let issues, nIssues = + let issues, n_issues = Hashtbl.fold - (fun name cnt (issues, nIssues) -> - ((name, cnt) :: issues, nIssues + !cnt)) + (fun name cnt (issues, n_issues) -> + ((name, cnt) :: issues, n_issues + !cnt)) counters2 ([], 0) in - (issues |> List.sort (fun (n1, _) (n2, _) -> String.compare n1 n2), nIssues) + (issues |> List.sort (fun (n1, _) (n2, _) -> String.compare n1 n2), n_issues) let report ~config = !issues |> List.rev - |> List.iter (fun issue -> logIssue ~config ~issue |> print_string); - let sortedIssues, nIssues = getSortedIssues () in - if not config.DceConfig.cli.json then ( - if sortedIssues <> [] then item "@."; - item "Analysis reported %d issues%s@." nIssues - (match sortedIssues with + |> List.iter (fun issue -> log_issue ~config ~issue |> print_string); + let sorted_issues, n_issues = get_sorted_issues () in + if not config.Dce_config.cli.json then ( + if sorted_issues <> [] then item "@."; + item "Analysis reported %d issues%s@." n_issues + (match sorted_issues with | [] -> "" | _ :: _ -> " (" - ^ (sortedIssues + ^ (sorted_issues |> List.map (fun (name, cnt) -> name ^ ":" ^ string_of_int !cnt) |> String.concat ", ") ^ ")")) end -let logIssue ~forStats ~severity ~(loc : Location.t) description = - let name = descriptionToName description in +let log_issue ~for_stats ~severity ~(loc : Location.t) description = + let name = description_to_name description in if Suppress.filter loc.loc_start then - if forStats then Stats.addIssue {name; severity; loc; description} + if for_stats then Stats.add_issue {name; severity; loc; description} -let warning ?(forStats = true) ~loc description = - description |> logIssue ~severity:Warning ~forStats ~loc +let warning ?(for_stats = true) ~loc description = + description |> log_issue ~severity:Warning ~for_stats ~loc let error ~loc description = - description |> logIssue ~severity:Error ~forStats:true ~loc + description |> log_issue ~severity:Error ~for_stats:true ~loc diff --git a/analysis/reanalyze/src/module_path.ml b/analysis/reanalyze/src/module_path.ml new file mode 100644 index 00000000000..451873db384 --- /dev/null +++ b/analysis/reanalyze/src/module_path.ml @@ -0,0 +1,33 @@ +module Name_map = Map.Make (Name) + +(* Keep track of the module path while traversing with Tast_mapper *) +type t = {aliases: Dce_path.t Name_map.t; loc: Location.t; path: Dce_path.t} + +let initial = ({aliases = Name_map.empty; loc = Location.none; path = []} : t) + +let normalize_path ~aliases path = + match path |> List.rev with + | name :: rest_rev when rest_rev <> [] -> ( + match aliases |> Name_map.find_opt name with + | None -> path + | Some path1 -> + let new_path = List.rev (path1 @ rest_rev) in + if !Cli.debug then + Log_.item "Resolve Alias: %s to %s@." + (path |> Dce_path.to_string) + (new_path |> Dce_path.to_string); + new_path) + | _ -> path + +let add_alias (t : t) ~name ~path : t = + let aliases = t.aliases in + let path_normalized = path |> normalize_path ~aliases in + if !Cli.debug then + Log_.item "Module Alias: %s = %s@." (name |> Name.to_string) + (Dce_path.to_string path_normalized); + {t with aliases = Name_map.add name path_normalized aliases} + +let resolve_alias (t : t) path = path |> normalize_path ~aliases:t.aliases + +let enter_module (t : t) ~(name : Name.t) ~(loc : Location.t) : t = + {t with loc; path = name :: t.path} diff --git a/analysis/reanalyze/src/Name.ml b/analysis/reanalyze/src/name.ml similarity index 50% rename from analysis/reanalyze/src/Name.ml rename to analysis/reanalyze/src/name.ml index 2f9565410dc..2ca477e8665 100644 --- a/analysis/reanalyze/src/Name.ml +++ b/analysis/reanalyze/src/name.ml @@ -2,28 +2,28 @@ type t = string let compare = String.compare -let create ?(isInterface = true) s = - match isInterface with +let create ?(is_interface = true) s = + match is_interface with | true -> s | false -> "+" ^ s -let isInterface s = try s.[0] <> '+' with Invalid_argument _ -> false -let isUnderscore s = s = "_" || s = "+_" +let is_interface s = try s.[0] <> '+' with Invalid_argument _ -> false +let is_underscore s = s = "_" || s = "+_" -let startsWithUnderscore s = +let starts_with_underscore s = s |> String.length >= 2 && try s.[0] = '_' || (s.[0] = '+' && s.[1] = '_') with Invalid_argument _ -> false -let toInterface s = - match isInterface s with +let to_interface s = + match is_interface s with | true -> s | false -> ( try String.sub s 1 (String.length s - 1) with Invalid_argument _ -> s) -let toImplementation s = - match isInterface s with +let to_implementation s = + match is_interface s with | true -> "+" ^ s | false -> s -let toString (s : t) = s +let to_string (s : t) = s diff --git a/analysis/reanalyze/src/name.mli b/analysis/reanalyze/src/name.mli new file mode 100644 index 00000000000..3837496415f --- /dev/null +++ b/analysis/reanalyze/src/name.mli @@ -0,0 +1,9 @@ +type t + +val compare : t -> t -> int +val create : ?is_interface:bool -> string -> t +val is_underscore : t -> bool +val starts_with_underscore : t -> bool +val to_implementation : t -> t +val to_interface : t -> t +val to_string : t -> string diff --git a/analysis/reanalyze/src/optional_args.ml b/analysis/reanalyze/src/optional_args.ml new file mode 100644 index 00000000000..6974f1580ec --- /dev/null +++ b/analysis/reanalyze/src/optional_args.ml @@ -0,0 +1,46 @@ +(** Immutable record tracking optional argument usage. + - unused: args that have never been passed + - alwaysUsed: args that are always passed (when count > 0) + - count: number of calls observed *) + +module String_set = Set.Make (String) + +type t = {count: int; unused: String_set.t; always_used: String_set.t} + +let empty = + {unused = String_set.empty; always_used = String_set.empty; count = 0} + +let from_list l = + {unused = String_set.of_list l; always_used = String_set.empty; count = 0} + +let is_empty x = String_set.is_empty x.unused + +(** Apply a call to the optional args state. Returns new state. *) +let apply_call ~arg_names ~arg_names_maybe x = + let name_set = arg_names |> String_set.of_list in + let name_set_maybe = arg_names_maybe |> String_set.of_list in + let name_set_always = String_set.diff name_set name_set_maybe in + let always_used = + if x.count = 0 then name_set_always + else String_set.inter name_set_always x.always_used + in + let unused = + arg_names + |> List.fold_left (fun acc name -> String_set.remove name acc) x.unused + in + {count = x.count + 1; unused; always_used} + +(** Combine two optional args states (for function references). + Returns a pair of updated states with intersected unused/alwaysUsed. *) +let combine_pair x y = + let unused = String_set.inter x.unused y.unused in + let always_used = String_set.inter x.always_used y.always_used in + ({x with unused; always_used}, {y with unused; always_used}) + +let iter_unused f x = String_set.iter f x.unused +let iter_always_used f x = String_set.iter (fun s -> f s x.count) x.always_used + +let fold_unused f x init = String_set.fold f x.unused init + +let fold_always_used f x init = + String_set.fold (fun s acc -> f s x.count acc) x.always_used init diff --git a/analysis/reanalyze/src/optional_args_state.ml b/analysis/reanalyze/src/optional_args_state.ml new file mode 100644 index 00000000000..3a53ab3de3f --- /dev/null +++ b/analysis/reanalyze/src/optional_args_state.ml @@ -0,0 +1,10 @@ +(** State map for computed OptionalArgs. + Maps declaration position to final state after all calls/combines. *) + +type t = Optional_args.t Pos_hash.t + +let create () : t = Pos_hash.create 256 + +let find_opt (state : t) pos = Pos_hash.find_opt state pos + +let set (state : t) pos value = Pos_hash.replace state pos value diff --git a/analysis/reanalyze/src/Paths.ml b/analysis/reanalyze/src/paths.ml similarity index 62% rename from analysis/reanalyze/src/Paths.ml rename to analysis/reanalyze/src/paths.ml index fe588385b67..b25b29e401c 100644 --- a/analysis/reanalyze/src/Paths.ml +++ b/analysis/reanalyze/src/paths.ml @@ -1,4 +1,4 @@ -let rescriptJson = "rescript.json" +let rescript_json = "rescript.json" (** If `t` is an object (`Assoc), get the value associated with the given string key *) let get key t = @@ -6,7 +6,7 @@ let get key t = | `Assoc items -> List.assoc_opt key items | _ -> None -let readFile filename = +let read_file filename = try (* windows can't use open_in *) let chan = open_in_bin filename in @@ -15,30 +15,30 @@ let readFile filename = Some content with _ -> None -let rec findProjectRoot ~dir = - let rescriptJsonFile = Filename.concat dir rescriptJson in - if Sys.file_exists rescriptJsonFile then dir +let rec find_project_root ~dir = + let rescript_json_file = Filename.concat dir rescript_json in + if Sys.file_exists rescript_json_file then dir else let parent = dir |> Filename.dirname in if parent = dir then ( prerr_endline - ("Error: cannot find project root containing " ^ rescriptJson ^ "."); + ("Error: cannot find project root containing " ^ rescript_json ^ "."); assert false) - else findProjectRoot ~dir:parent + else find_project_root ~dir:parent -let runConfig = RunConfig.runConfig +let run_config = Run_config.run_config -let setProjectRootFromCwd () = - runConfig.projectRoot <- findProjectRoot ~dir:(Sys.getcwd ()); - runConfig.bsbProjectRoot <- +let set_project_root_from_cwd () = + run_config.project_root <- find_project_root ~dir:(Sys.getcwd ()); + run_config.bsb_project_root <- (match Sys.getenv_opt "BSB_PROJECT_ROOT" with - | None -> runConfig.projectRoot + | None -> run_config.project_root | Some s -> s) -let setReScriptProjectRoot = lazy (setProjectRootFromCwd ()) +let set_re_script_project_root = lazy (set_project_root_from_cwd ()) module Config = struct - let readSuppress conf = + let read_suppress conf = match conf |> get "suppress" with | Some (`List elements) -> let names = @@ -48,10 +48,10 @@ module Config = struct | `String s -> Some s | _ -> None) in - runConfig.suppress <- names @ runConfig.suppress + run_config.suppress <- names @ run_config.suppress | _ -> () - let readUnsuppress conf = + let read_unsuppress conf = match conf |> get "unsuppress" with | Some (`List elements) -> let names = @@ -61,51 +61,51 @@ module Config = struct | `String s -> Some s | _ -> None) in - runConfig.unsuppress <- names @ runConfig.unsuppress + run_config.unsuppress <- names @ run_config.unsuppress | _ -> () - let readAnalysis conf = + let read_analysis conf = match conf |> get "analysis" with | Some (`List elements) -> elements |> List.iter (fun (x : Yojson.Safe.t) -> match x with - | `String "all" -> RunConfig.all () - | `String "dce" -> RunConfig.dce () - | `String "exception" -> RunConfig.exception_ () - | `String "termination" -> RunConfig.termination () + | `String "all" -> Run_config.all () + | `String "dce" -> Run_config.dce () + | `String "exception" -> Run_config.exception_ () + | `String "termination" -> Run_config.termination () | _ -> ()) | _ -> (* if no "analysis" specified, default to dce *) - RunConfig.dce () + Run_config.dce () - let readTransitive conf = + let read_transitive conf = match conf |> get "transitive" with - | Some (`Bool bool) -> RunConfig.transitive bool + | Some (`Bool bool) -> Run_config.transitive bool | _ -> () (* Read the config from rescript.json and apply it to runConfig and suppress and unsuppress *) - let processConfig () = - setProjectRootFromCwd (); - let rescriptFile = Filename.concat runConfig.projectRoot rescriptJson in + let process_config () = + set_project_root_from_cwd (); + let rescript_file = Filename.concat run_config.project_root rescript_json in - let processText text = + let process_text text = match try Some (Yojson.Safe.from_string text) with _ -> None with | Some json -> ( match get "reanalyze" json with | Some conf -> - readSuppress conf; - readUnsuppress conf; - readAnalysis conf; - readTransitive conf + read_suppress conf; + read_unsuppress conf; + read_analysis conf; + read_transitive conf | None -> (* if no "analysis" specified, default to dce *) - RunConfig.dce ()) + Run_config.dce ()) | _ -> () in - match readFile rescriptFile with - | Some text -> processText text + match read_file rescript_file with + | Some text -> process_text text | None -> () end @@ -113,22 +113,22 @@ end * Handle namespaces in cmt files. * E.g. src/Module-Project.cmt becomes src/Module *) -let handleNamespace cmt = - let cutAfterDash s = +let handle_namespace cmt = + let cut_after_dash s = match String.index s '-' with | n -> ( try String.sub s 0 n with Invalid_argument _ -> s) | exception Not_found -> s in - let noDir = Filename.basename cmt = cmt in - if noDir then cmt |> Filename.remove_extension |> cutAfterDash + let no_dir = Filename.basename cmt = cmt in + if no_dir then cmt |> Filename.remove_extension |> cut_after_dash else let dir = cmt |> Filename.dirname in let base = - cmt |> Filename.basename |> Filename.remove_extension |> cutAfterDash + cmt |> Filename.basename |> Filename.remove_extension |> cut_after_dash in Filename.concat dir base -let getModuleName cmt = cmt |> handleNamespace |> Filename.basename +let get_module_name cmt = cmt |> handle_namespace |> Filename.basename type cmt_scan_entry = { build_root: string; @@ -145,23 +145,23 @@ type cmt_scan_entry = { If missing, returns the empty list and callers should fall back to legacy behavior. *) -let readCmtScan () = - let sourceDirsFile = +let read_cmt_scan () = + let source_dirs_file = ["lib"; "bs"; ".sourcedirs.json"] - |> List.fold_left Filename.concat runConfig.bsbProjectRoot + |> List.fold_left Filename.concat run_config.bsb_project_root in let get_fn key fn json = get key json |> Option.to_list |> List.filter_map fn in let read_entry (json : Yojson.Safe.t) = - let build_root = json |> get_fn "build_root" YojsonHelpers.string_opt in + let build_root = json |> get_fn "build_root" Yojson_helpers.string_opt in let scan_dirs = match json |> get "scan_dirs" with - | Some (`List arr) -> arr |> List.filter_map YojsonHelpers.string_opt + | Some (`List arr) -> arr |> List.filter_map Yojson_helpers.string_opt | _ -> [] in let also_scan_build_root = - match json |> get_fn "also_scan_build_root" YojsonHelpers.bool_opt with + match json |> get_fn "also_scan_build_root" Yojson_helpers.bool_opt with | [b] -> b | _ -> false in @@ -169,7 +169,7 @@ let readCmtScan () = | [build_root] -> Some {build_root; scan_dirs; also_scan_build_root} | _ -> None in - match readFile sourceDirsFile with + match read_file source_dirs_file with | None -> [] | Some text -> ( match try Some (Yojson.Safe.from_string text) with _ -> None with diff --git a/analysis/reanalyze/src/Pos.ml b/analysis/reanalyze/src/pos.ml similarity index 87% rename from analysis/reanalyze/src/Pos.ml rename to analysis/reanalyze/src/pos.ml index 07b053bb4cd..87f9a919a9f 100644 --- a/analysis/reanalyze/src/Pos.ml +++ b/analysis/reanalyze/src/pos.ml @@ -1,7 +1,7 @@ (** Position utilities. *) (** Format a position as "filename:line:col" *) -let toString (pos : Lexing.position) = +let to_string (pos : Lexing.position) = let file = pos.Lexing.pos_fname in let line = pos.Lexing.pos_lnum in let col = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in diff --git a/analysis/reanalyze/src/PosHash.ml b/analysis/reanalyze/src/pos_hash.ml similarity index 100% rename from analysis/reanalyze/src/PosHash.ml rename to analysis/reanalyze/src/pos_hash.ml diff --git a/analysis/reanalyze/src/PosSet.ml b/analysis/reanalyze/src/pos_set.ml similarity index 100% rename from analysis/reanalyze/src/PosSet.ml rename to analysis/reanalyze/src/pos_set.ml diff --git a/analysis/reanalyze/src/ReactiveAnalysis.ml b/analysis/reanalyze/src/reactive_analysis.ml similarity index 62% rename from analysis/reanalyze/src/ReactiveAnalysis.ml rename to analysis/reanalyze/src/reactive_analysis.ml index eafd54a40ad..be535742286 100644 --- a/analysis/reanalyze/src/ReactiveAnalysis.ml +++ b/analysis/reanalyze/src/reactive_analysis.ml @@ -5,18 +5,19 @@ delta-based updates. *) type cmt_file_result = { - dce_data: DceFileProcessing.file_data option; + dce_data: Dce_file_processing.file_data option; exception_data: Exception.file_result option; } (** Result of processing a single CMT file *) type all_files_result = { - dce_data_list: DceFileProcessing.file_data list; + dce_data_list: Dce_file_processing.file_data list; exception_results: Exception.file_result list; } (** Result of processing all CMT files *) -type t = (Cmt_format.cmt_infos, cmt_file_result option) ReactiveFileCollection.t +type t = + (Cmt_format.cmt_infos, cmt_file_result option) Reactive_file_collection.t (** The reactive collection type *) type processing_stats = { @@ -27,76 +28,77 @@ type processing_stats = { (** Stats from a process_files call *) (** Process cmt_infos into a file result *) -let process_cmt_infos ~config ~cmtFilePath cmt_infos : cmt_file_result option = - let excludePath sourceFile = - config.DceConfig.cli.exclude_paths +let process_cmt_infos ~config ~cmt_file_path cmt_infos : cmt_file_result option + = + let exclude_path source_file = + config.Dce_config.cli.exclude_paths |> List.exists (fun prefix_ -> let prefix = - match Filename.is_relative sourceFile with + match Filename.is_relative source_file with | true -> prefix_ | false -> Filename.concat (Sys.getcwd ()) prefix_ in - String.length prefix <= String.length sourceFile + String.length prefix <= String.length source_file && - try String.sub sourceFile 0 (String.length prefix) = prefix + try String.sub source_file 0 (String.length prefix) = prefix with Invalid_argument _ -> false) in - match cmt_infos.Cmt_format.cmt_annots |> FindSourceFile.cmt with - | Some sourceFile when not (excludePath sourceFile) -> - let is_interface = + match cmt_infos.Cmt_format.cmt_annots |> Find_source_file.cmt with + | Some source_file when not (exclude_path source_file) -> + let is_interface_ = match cmt_infos.cmt_annots with | Interface _ -> true - | _ -> Filename.check_suffix sourceFile "i" + | _ -> Filename.check_suffix source_file "i" in - let module_name = sourceFile |> Paths.getModuleName in - let dce_file_context : DceFileProcessing.file_context = - {source_path = sourceFile; module_name; is_interface} + let module_name = source_file |> Paths.get_module_name in + let dce_file_context : Dce_file_processing.file_context = + {source_path = source_file; module_name; is_interface = is_interface_} in let file_context = - DeadCommon.FileContext. - {source_path = sourceFile; module_name; is_interface} + Dead_common.File_context. + {source_path = source_file; module_name; is_interface = is_interface_} in let dce_data = - if config.DceConfig.run.dce then + if config.Dce_config.run.dce then Some (cmt_infos - |> DceFileProcessing.process_cmt_file ~config ~file:dce_file_context - ~cmtFilePath) + |> Dce_file_processing.process_cmt_file ~config ~file:dce_file_context + ~cmt_file_path) else None in let exception_data = - if config.DceConfig.run.exception_ then - cmt_infos |> Exception.processCmt ~file:file_context + if config.Dce_config.run.exception_ then + cmt_infos |> Exception.process_cmt ~file:file_context else None in - if config.DceConfig.run.termination then - cmt_infos |> Arnold.processCmt ~config ~file:file_context; + if config.Dce_config.run.termination then + cmt_infos |> Arnold.process_cmt ~config ~file:file_context; Some {dce_data; exception_data} | _ -> None (** Create a new reactive collection *) let create ~config : t = - ReactiveFileCollection.create ~read_file:Cmt_format.read_cmt + Reactive_file_collection.create ~read_file:Cmt_format.read_cmt ~process:(fun path cmt_infos -> - process_cmt_infos ~config ~cmtFilePath:path cmt_infos) + process_cmt_infos ~config ~cmt_file_path:path cmt_infos) (** Process all files incrementally using ReactiveFileCollection. First run processes all files. Subsequent runs only process changed files. Uses batch processing to emit all changes as a single Batch delta. Returns (result, stats) where stats contains processing information. *) -let process_files ~(collection : t) ~config:_ cmtFilePaths : +let process_files ~(collection : t) ~config:_ cmt_file_paths : all_files_result * processing_stats = Timing.time_phase `FileLoading (fun () -> - let total_files = List.length cmtFilePaths in + let total_files = List.length cmt_file_paths in let cached_before = - cmtFilePaths - |> List.filter (fun p -> ReactiveFileCollection.mem collection p) + cmt_file_paths + |> List.filter (fun p -> Reactive_file_collection.mem collection p) |> List.length in (* Process all files as a batch - emits single Batch delta *) let processed = - ReactiveFileCollection.process_files_batch collection cmtFilePaths + Reactive_file_collection.process_files_batch collection cmt_file_paths in let from_cache = total_files - processed in let stats = {total_files; processed; from_cache} in @@ -110,7 +112,7 @@ let process_files ~(collection : t) ~config:_ cmtFilePaths : let dce_data_list = ref [] in let exception_results = ref [] in - ReactiveFileCollection.iter + Reactive_file_collection.iter (fun _path result_opt -> match result_opt with | Some {dce_data; exception_data} -> ( @@ -130,14 +132,14 @@ let process_files ~(collection : t) ~config:_ cmtFilePaths : stats )) (** Get collection length *) -let length (collection : t) = ReactiveFileCollection.length collection +let length (collection : t) = Reactive_file_collection.length collection (** Get the underlying reactive collection for composition. Returns (path, file_data option) suitable for ReactiveMerge. *) let to_file_data_collection (collection : t) : - (string, DceFileProcessing.file_data option) Reactive.t = - Reactive.flatMap ~name:"file_data_collection" - (ReactiveFileCollection.to_collection collection) + (string, Dce_file_processing.file_data option) Reactive.t = + Reactive.flat_map ~name:"file_data_collection" + (Reactive_file_collection.to_collection collection) ~f:(fun path result_opt -> match result_opt with | Some {dce_data = Some data; _} -> [(path, Some data)] @@ -145,9 +147,9 @@ let to_file_data_collection (collection : t) : () (** Iterate over all file_data in the collection *) -let iter_file_data (collection : t) (f : DceFileProcessing.file_data -> unit) : - unit = - ReactiveFileCollection.iter +let iter_file_data (collection : t) (f : Dce_file_processing.file_data -> unit) + : unit = + Reactive_file_collection.iter (fun _path result_opt -> match result_opt with | Some {dce_data = Some data; _} -> f data @@ -157,7 +159,7 @@ let iter_file_data (collection : t) (f : DceFileProcessing.file_data -> unit) : (** Collect all exception results from the collection *) let collect_exception_results (collection : t) : Exception.file_result list = let results = ref [] in - ReactiveFileCollection.iter + Reactive_file_collection.iter (fun _path result_opt -> match result_opt with | Some {exception_data = Some data; _} -> results := data :: !results diff --git a/analysis/reanalyze/src/ReactiveDeclRefs.ml b/analysis/reanalyze/src/reactive_decl_refs.ml similarity index 63% rename from analysis/reanalyze/src/ReactiveDeclRefs.ml rename to analysis/reanalyze/src/reactive_decl_refs.ml index 9f5a2ea26c9..dfa3e212a81 100644 --- a/analysis/reanalyze/src/ReactiveDeclRefs.ml +++ b/analysis/reanalyze/src/reactive_decl_refs.ml @@ -9,68 +9,68 @@ Uses pure reactive combinators - no internal hashtables. *) let create ~(decls : (Lexing.position, Decl.t) Reactive.t) - ~(value_refs_from : (Lexing.position, PosSet.t) Reactive.t) - ~(type_refs_from : (Lexing.position, PosSet.t) Reactive.t) : - (Lexing.position, PosSet.t * PosSet.t) Reactive.t = + ~(value_refs_from : (Lexing.position, Pos_set.t) Reactive.t) + ~(type_refs_from : (Lexing.position, Pos_set.t) Reactive.t) : + (Lexing.position, Pos_set.t * Pos_set.t) Reactive.t = (* Group declarations by file *) let decls_by_file : (string, (Lexing.position * Decl.t) list) Reactive.t = - Reactive.flatMap ~name:"decl_refs.decls_by_file" decls + Reactive.flat_map ~name:"decl_refs.decls_by_file" decls ~f:(fun pos decl -> [(pos.Lexing.pos_fname, [(pos, decl)])]) ~merge:( @ ) () in (* Check if posFrom is contained in decl's range *) - let pos_in_decl (posFrom : Lexing.position) (decl : Decl.t) : bool = - posFrom.pos_fname = decl.pos.pos_fname - && posFrom.pos_cnum >= decl.posStart.pos_cnum - && posFrom.pos_cnum <= decl.posEnd.pos_cnum + let pos_in_decl (pos_from : Lexing.position) (decl : Decl.t) : bool = + pos_from.pos_fname = decl.pos.pos_fname + && pos_from.pos_cnum >= decl.pos_start.pos_cnum + && pos_from.pos_cnum <= decl.pos_end.pos_cnum in (* For each ref, find which decl(s) contain it and output (decl_pos, targets) *) - let value_decl_refs : (Lexing.position, PosSet.t) Reactive.t = + let value_decl_refs : (Lexing.position, Pos_set.t) Reactive.t = Reactive.join ~name:"decl_refs.value_decl_refs" value_refs_from decls_by_file - ~key_of:(fun posFrom _targets -> posFrom.Lexing.pos_fname) - ~f:(fun posFrom targets decls_opt -> + ~key_of:(fun pos_from _targets -> pos_from.Lexing.pos_fname) + ~f:(fun pos_from targets decls_opt -> match decls_opt with | None -> [] | Some decls_in_file -> decls_in_file |> List.filter_map (fun (decl_pos, decl) -> - if pos_in_decl posFrom decl then Some (decl_pos, targets) + if pos_in_decl pos_from decl then Some (decl_pos, targets) else None)) - ~merge:PosSet.union () + ~merge:Pos_set.union () in - let type_decl_refs : (Lexing.position, PosSet.t) Reactive.t = + let type_decl_refs : (Lexing.position, Pos_set.t) Reactive.t = Reactive.join ~name:"decl_refs.type_decl_refs" type_refs_from decls_by_file - ~key_of:(fun posFrom _targets -> posFrom.Lexing.pos_fname) - ~f:(fun posFrom targets decls_opt -> + ~key_of:(fun pos_from _targets -> pos_from.Lexing.pos_fname) + ~f:(fun pos_from targets decls_opt -> match decls_opt with | None -> [] | Some decls_in_file -> decls_in_file |> List.filter_map (fun (decl_pos, decl) -> - if pos_in_decl posFrom decl then Some (decl_pos, targets) + if pos_in_decl pos_from decl then Some (decl_pos, targets) else None)) - ~merge:PosSet.union () + ~merge:Pos_set.union () in (* Combine value and type refs into (value_targets, type_targets) pairs. Use join to combine, with decls as the base to ensure all decls are present. *) - let with_value_refs : (Lexing.position, PosSet.t) Reactive.t = + let with_value_refs : (Lexing.position, Pos_set.t) Reactive.t = Reactive.join ~name:"decl_refs.with_value_refs" decls value_decl_refs ~key_of:(fun pos _decl -> pos) ~f:(fun pos _decl refs_opt -> - [(pos, Option.value refs_opt ~default:PosSet.empty)]) + [(pos, Option.value refs_opt ~default:Pos_set.empty)]) () in - let with_type_refs : (Lexing.position, PosSet.t) Reactive.t = + let with_type_refs : (Lexing.position, Pos_set.t) Reactive.t = Reactive.join ~name:"decl_refs.with_type_refs" decls type_decl_refs ~key_of:(fun pos _decl -> pos) ~f:(fun pos _decl refs_opt -> - [(pos, Option.value refs_opt ~default:PosSet.empty)]) + [(pos, Option.value refs_opt ~default:Pos_set.empty)]) () in @@ -78,6 +78,6 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) Reactive.join ~name:"decl_refs.combined" with_value_refs with_type_refs ~key_of:(fun pos _value_targets -> pos) ~f:(fun pos value_targets type_targets_opt -> - let type_targets = Option.value type_targets_opt ~default:PosSet.empty in + let type_targets = Option.value type_targets_opt ~default:Pos_set.empty in [(pos, (value_targets, type_targets))]) () diff --git a/analysis/reanalyze/src/ReactiveDeclRefs.mli b/analysis/reanalyze/src/reactive_decl_refs.mli similarity index 77% rename from analysis/reanalyze/src/ReactiveDeclRefs.mli rename to analysis/reanalyze/src/reactive_decl_refs.mli index e11f6510b6b..e2aa750c8b9 100644 --- a/analysis/reanalyze/src/ReactiveDeclRefs.mli +++ b/analysis/reanalyze/src/reactive_decl_refs.mli @@ -8,9 +8,9 @@ val create : decls:(Lexing.position, Decl.t) Reactive.t -> - value_refs_from:(Lexing.position, PosSet.t) Reactive.t -> - type_refs_from:(Lexing.position, PosSet.t) Reactive.t -> - (Lexing.position, PosSet.t * PosSet.t) Reactive.t + value_refs_from:(Lexing.position, Pos_set.t) Reactive.t -> + type_refs_from:(Lexing.position, Pos_set.t) Reactive.t -> + (Lexing.position, Pos_set.t * Pos_set.t) Reactive.t (** [create ~decls ~value_refs_from ~type_refs_from] creates a reactive index mapping each declaration position to its outgoing references. diff --git a/analysis/reanalyze/src/ReactiveExceptionRefs.ml b/analysis/reanalyze/src/reactive_exception_refs.ml similarity index 63% rename from analysis/reanalyze/src/ReactiveExceptionRefs.ml rename to analysis/reanalyze/src/reactive_exception_refs.ml index 81e23bfbe60..bafd2673f06 100644 --- a/analysis/reanalyze/src/ReactiveExceptionRefs.ml +++ b/analysis/reanalyze/src/reactive_exception_refs.ml @@ -10,9 +10,9 @@ (** {1 Types} *) type t = { - exception_decls: (DcePath.t, Location.t) Reactive.t; - resolved_refs: (Lexing.position, PosSet.t) Reactive.t; - resolved_refs_from: (Lexing.position, PosSet.t) Reactive.t; + exception_decls: (Dce_path.t, Location.t) Reactive.t; + resolved_refs: (Lexing.position, Pos_set.t) Reactive.t; + resolved_refs_from: (Lexing.position, Pos_set.t) Reactive.t; } (** Reactive exception ref collections *) @@ -23,17 +23,17 @@ type t = { [decls] is the reactive declarations collection. [exception_refs] is the reactive collection of (path, loc_from) from CrossFileItems. *) let create ~(decls : (Lexing.position, Decl.t) Reactive.t) - ~(exception_refs : (DcePath.t, Location.t) Reactive.t) : t = + ~(exception_refs : (Dce_path.t, Location.t) Reactive.t) : t = (* Step 1: Index exception declarations by path *) let exception_decls = - Reactive.flatMap ~name:"exc_refs.exception_decls" decls + Reactive.flat_map ~name:"exc_refs.exception_decls" decls ~f:(fun _pos (decl : Decl.t) -> - match decl.Decl.declKind with + match decl.Decl.decl_kind with | Exception -> let loc : Location.t = { Location.loc_start = decl.pos; - loc_end = decl.posEnd; + loc_end = decl.pos_end; loc_ghost = false; } in @@ -52,19 +52,19 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Add value reference: pos_to -> pos_from (refs_to direction) *) [ ( loc_to.Location.loc_start, - PosSet.singleton loc_from.Location.loc_start ); + Pos_set.singleton loc_from.Location.loc_start ); ] | None -> []) - ~merge:PosSet.union () + ~merge:Pos_set.union () in (* Step 3: Create refs_from direction by inverting *) let resolved_refs_from = - Reactive.flatMap ~name:"exc_refs.resolved_refs_from" resolved_refs - ~f:(fun posTo posFromSet -> - PosSet.elements posFromSet - |> List.map (fun posFrom -> (posFrom, PosSet.singleton posTo))) - ~merge:PosSet.union () + Reactive.flat_map ~name:"exc_refs.resolved_refs_from" resolved_refs + ~f:(fun pos_to pos_from_set -> + Pos_set.elements pos_from_set + |> List.map (fun pos_from -> (pos_from, Pos_set.singleton pos_to))) + ~merge:Pos_set.union () in {exception_decls; resolved_refs; resolved_refs_from} @@ -74,21 +74,21 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (** Add all resolved exception refs to a References.builder *) let add_to_refs_builder (t : t) ~(refs : References.builder) : unit = Reactive.iter - (fun posTo posFromSet -> - PosSet.iter - (fun posFrom -> References.add_value_ref refs ~posTo ~posFrom) - posFromSet) + (fun pos_to pos_from_set -> + Pos_set.iter + (fun pos_from -> References.add_value_ref refs ~pos_to ~pos_from) + pos_from_set) t.resolved_refs (** Add file dependencies for resolved refs *) -let add_to_file_deps_builder (t : t) ~(file_deps : FileDeps.builder) : unit = +let add_to_file_deps_builder (t : t) ~(file_deps : File_deps.builder) : unit = Reactive.iter - (fun posTo posFromSet -> - PosSet.iter - (fun posFrom -> - let from_file = posFrom.Lexing.pos_fname in - let to_file = posTo.Lexing.pos_fname in + (fun pos_to pos_from_set -> + Pos_set.iter + (fun pos_from -> + let from_file = pos_from.Lexing.pos_fname in + let to_file = pos_to.Lexing.pos_fname in if from_file <> to_file then - FileDeps.add_dep file_deps ~from_file ~to_file) - posFromSet) + File_deps.add_dep file_deps ~from_file ~to_file) + pos_from_set) t.resolved_refs diff --git a/analysis/reanalyze/src/ReactiveExceptionRefs.mli b/analysis/reanalyze/src/reactive_exception_refs.mli similarity index 83% rename from analysis/reanalyze/src/ReactiveExceptionRefs.mli rename to analysis/reanalyze/src/reactive_exception_refs.mli index 8f918d7cfec..c418057c598 100644 --- a/analysis/reanalyze/src/ReactiveExceptionRefs.mli +++ b/analysis/reanalyze/src/reactive_exception_refs.mli @@ -32,10 +32,10 @@ (** {1 Types} *) type t = { - exception_decls: (DcePath.t, Location.t) Reactive.t; - resolved_refs: (Lexing.position, PosSet.t) Reactive.t; + exception_decls: (Dce_path.t, Location.t) Reactive.t; + resolved_refs: (Lexing.position, Pos_set.t) Reactive.t; (** refs_to direction: target -> sources *) - resolved_refs_from: (Lexing.position, PosSet.t) Reactive.t; + resolved_refs_from: (Lexing.position, Pos_set.t) Reactive.t; (** refs_from direction: source -> targets (for forward solver) *) } (** Reactive exception ref collections *) @@ -44,7 +44,7 @@ type t = { val create : decls:(Lexing.position, Decl.t) Reactive.t -> - exception_refs:(DcePath.t, Location.t) Reactive.t -> + exception_refs:(Dce_path.t, Location.t) Reactive.t -> t (** Create reactive exception refs from decls and cross-file exception refs. @@ -55,5 +55,5 @@ val create : val add_to_refs_builder : t -> refs:References.builder -> unit (** Add all resolved exception refs to a References.builder. *) -val add_to_file_deps_builder : t -> file_deps:FileDeps.builder -> unit +val add_to_file_deps_builder : t -> file_deps:File_deps.builder -> unit (** Add file dependencies for resolved refs. *) diff --git a/analysis/reanalyze/src/ReactiveLiveness.ml b/analysis/reanalyze/src/reactive_liveness.ml similarity index 82% rename from analysis/reanalyze/src/ReactiveLiveness.ml rename to analysis/reanalyze/src/reactive_liveness.ml index 4322bd09926..0adb775737f 100644 --- a/analysis/reanalyze/src/ReactiveLiveness.ml +++ b/analysis/reanalyze/src/reactive_liveness.ml @@ -13,33 +13,33 @@ type t = { } (** Compute reactive liveness from ReactiveMerge.t *) -let create ~(merged : ReactiveMerge.t) : t = +let create ~(merged : Reactive_merge.t) : t = let decls = merged.decls in let annotations = merged.annotations in (* Combine value refs using union: per-file refs + exception refs *) - let value_refs_from : (Lexing.position, PosSet.t) Reactive.t = + let value_refs_from : (Lexing.position, Pos_set.t) Reactive.t = Reactive.union ~name:"liveness.value_refs_from" merged.value_refs_from - merged.exception_refs.resolved_refs_from ~merge:PosSet.union () + merged.exception_refs.resolved_refs_from ~merge:Pos_set.union () in (* Combine type refs using union: per-file refs + type deps from ReactiveTypeDeps *) - let type_refs_from : (Lexing.position, PosSet.t) Reactive.t = + let type_refs_from : (Lexing.position, Pos_set.t) Reactive.t = Reactive.union ~name:"liveness.type_refs_from" merged.type_refs_from - merged.type_deps.all_type_refs_from ~merge:PosSet.union () + merged.type_deps.all_type_refs_from ~merge:Pos_set.union () in (* Step 1: Build decl_refs_index - maps decl -> (value_targets, type_targets) *) let decl_refs_index = - ReactiveDeclRefs.create ~decls ~value_refs_from ~type_refs_from + Reactive_decl_refs.create ~decls ~value_refs_from ~type_refs_from in (* Step 2: Convert to edges format for fixpoint: decl -> successor list *) let edges : (Lexing.position, Lexing.position list) Reactive.t = - Reactive.flatMap ~name:"liveness.edges" decl_refs_index + Reactive.flat_map ~name:"liveness.edges" decl_refs_index ~f:(fun pos (value_targets, type_targets) -> - let all_targets = PosSet.union value_targets type_targets in - [(pos, PosSet.elements all_targets)]) + let all_targets = Pos_set.union value_targets type_targets in + [(pos, Pos_set.elements all_targets)]) () in @@ -56,7 +56,7 @@ let create ~(merged : ReactiveMerge.t) : t = position P arrives, any ref with posFrom=P will be reprocessed. *) let external_value_refs : (Lexing.position, unit) Reactive.t = Reactive.join ~name:"liveness.external_value_refs" value_refs_from decls - ~key_of:(fun posFrom _targets -> posFrom) + ~key_of:(fun pos_from _targets -> pos_from) ~f:(fun _posFrom targets decl_opt -> match decl_opt with | Some _ -> @@ -64,14 +64,14 @@ let create ~(merged : ReactiveMerge.t) : t = [] | None -> (* posFrom is NOT a decl position, targets are externally referenced *) - PosSet.elements targets |> List.map (fun posTo -> (posTo, ()))) + Pos_set.elements targets |> List.map (fun pos_to -> (pos_to, ()))) ~merge:(fun () () -> ()) () in let external_type_refs : (Lexing.position, unit) Reactive.t = Reactive.join ~name:"liveness.external_type_refs" type_refs_from decls - ~key_of:(fun posFrom _targets -> posFrom) + ~key_of:(fun pos_from _targets -> pos_from) ~f:(fun _posFrom targets decl_opt -> match decl_opt with | Some _ -> @@ -79,7 +79,7 @@ let create ~(merged : ReactiveMerge.t) : t = [] | None -> (* posFrom is NOT a decl position, targets are externally referenced *) - PosSet.elements targets |> List.map (fun posTo -> (posTo, ()))) + Pos_set.elements targets |> List.map (fun pos_to -> (pos_to, ()))) ~merge:(fun () () -> ()) () in @@ -97,7 +97,7 @@ let create ~(merged : ReactiveMerge.t) : t = ~key_of:(fun pos _decl -> pos) ~f:(fun pos _decl ann_opt -> match ann_opt with - | Some FileAnnotations.Live | Some FileAnnotations.GenType -> + | Some File_annotations.Live | Some File_annotations.GenType -> [(pos, ())] | _ -> []) ~merge:(fun () () -> ()) diff --git a/analysis/reanalyze/src/ReactiveLiveness.mli b/analysis/reanalyze/src/reactive_liveness.mli similarity index 94% rename from analysis/reanalyze/src/ReactiveLiveness.mli rename to analysis/reanalyze/src/reactive_liveness.mli index e0b5fcf53af..69524af4204 100644 --- a/analysis/reanalyze/src/ReactiveLiveness.mli +++ b/analysis/reanalyze/src/reactive_liveness.mli @@ -8,7 +8,7 @@ type t = { roots: (Lexing.position, unit) Reactive.t; } -val create : merged:ReactiveMerge.t -> t +val create : merged:Reactive_merge.t -> t (** [create ~merged] computes reactive liveness from merged DCE data. Returns a record containing: diff --git a/analysis/reanalyze/src/ReactiveMerge.ml b/analysis/reanalyze/src/reactive_merge.ml similarity index 54% rename from analysis/reanalyze/src/ReactiveMerge.ml rename to analysis/reanalyze/src/reactive_merge.ml index f0a340f6c15..6c376e0efa6 100644 --- a/analysis/reanalyze/src/ReactiveMerge.ml +++ b/analysis/reanalyze/src/reactive_merge.ml @@ -7,82 +7,83 @@ type t = { decls: (Lexing.position, Decl.t) Reactive.t; - annotations: (Lexing.position, FileAnnotations.annotated_as) Reactive.t; - value_refs_from: (Lexing.position, PosSet.t) Reactive.t; - type_refs_from: (Lexing.position, PosSet.t) Reactive.t; - cross_file_items: (string, CrossFileItems.t) Reactive.t; - file_deps_map: (string, FileSet.t) Reactive.t; + annotations: (Lexing.position, File_annotations.annotated_as) Reactive.t; + value_refs_from: (Lexing.position, Pos_set.t) Reactive.t; + type_refs_from: (Lexing.position, Pos_set.t) Reactive.t; + cross_file_items: (string, Cross_file_items.t) Reactive.t; + file_deps_map: (string, File_set.t) Reactive.t; files: (string, unit) Reactive.t; (* Reactive type/exception dependencies *) - type_deps: ReactiveTypeDeps.t; - exception_refs: ReactiveExceptionRefs.t; + type_deps: Reactive_type_deps.t; + exception_refs: Reactive_exception_refs.t; } (** All derived reactive collections from per-file data *) (** {1 Creation} *) -let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : - t = +let create (source : (string, Dce_file_processing.file_data option) Reactive.t) + : t = (* Declarations: (pos, Decl.t) with last-write-wins *) let decls = - Reactive.flatMap ~name:"decls" source + Reactive.flat_map ~name:"decls" source ~f:(fun _path file_data_opt -> match file_data_opt with | None -> [] | Some file_data -> - Declarations.builder_to_list file_data.DceFileProcessing.decls) + Declarations.builder_to_list file_data.Dce_file_processing.decls) () in (* Annotations: (pos, annotated_as) with last-write-wins *) let annotations = - Reactive.flatMap ~name:"annotations" source + Reactive.flat_map ~name:"annotations" source ~f:(fun _path file_data_opt -> match file_data_opt with | None -> [] | Some file_data -> - FileAnnotations.builder_to_list - file_data.DceFileProcessing.annotations) + File_annotations.builder_to_list + file_data.Dce_file_processing.annotations) () in (* Value refs_from: (posFrom, PosSet of targets) with PosSet.union merge *) let value_refs_from = - Reactive.flatMap ~name:"value_refs_from" source + Reactive.flat_map ~name:"value_refs_from" source ~f:(fun _path file_data_opt -> match file_data_opt with | None -> [] | Some file_data -> References.builder_value_refs_from_list - file_data.DceFileProcessing.refs) - ~merge:PosSet.union () + file_data.Dce_file_processing.refs) + ~merge:Pos_set.union () in (* Type refs_from: (posFrom, PosSet of targets) with PosSet.union merge *) let type_refs_from = - Reactive.flatMap ~name:"type_refs_from" source + Reactive.flat_map ~name:"type_refs_from" source ~f:(fun _path file_data_opt -> match file_data_opt with | None -> [] | Some file_data -> References.builder_type_refs_from_list - file_data.DceFileProcessing.refs) - ~merge:PosSet.union () + file_data.Dce_file_processing.refs) + ~merge:Pos_set.union () in (* Cross-file items: (path, CrossFileItems.t) with merge by concatenation *) let cross_file_items = - Reactive.flatMap ~name:"cross_file_items" source + Reactive.flat_map ~name:"cross_file_items" source ~f:(fun path file_data_opt -> match file_data_opt with | None -> [] | Some file_data -> let items = - CrossFileItems.builder_to_t file_data.DceFileProcessing.cross_file + Cross_file_items.builder_to_t + file_data.Dce_file_processing.cross_file in [(path, items)]) ~merge:(fun a b -> - CrossFileItems. + Cross_file_items. { exception_refs = a.exception_refs @ b.exception_refs; optional_arg_calls = a.optional_arg_calls @ b.optional_arg_calls; @@ -93,50 +94,50 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* File deps map: (from_file, FileSet of to_files) with FileSet.union merge *) let file_deps_map = - Reactive.flatMap ~name:"file_deps_map" source + Reactive.flat_map ~name:"file_deps_map" source ~f:(fun _path file_data_opt -> match file_data_opt with | None -> [] | Some file_data -> - FileDeps.builder_deps_to_list file_data.DceFileProcessing.file_deps) - ~merge:FileSet.union () + File_deps.builder_deps_to_list file_data.Dce_file_processing.file_deps) + ~merge:File_set.union () in (* Files set: (source_path, ()) - just track which source files exist *) let files = - Reactive.flatMap ~name:"files" source + Reactive.flat_map ~name:"files" source ~f:(fun _cmt_path file_data_opt -> match file_data_opt with | None -> [] | Some file_data -> (* Include all source files from file_deps (NOT the CMT path) *) let file_set = - FileDeps.builder_files file_data.DceFileProcessing.file_deps + File_deps.builder_files file_data.Dce_file_processing.file_deps in - FileSet.fold (fun f acc -> (f, ()) :: acc) file_set []) + File_set.fold (fun f acc -> (f, ()) :: acc) file_set []) () in (* Extract exception_refs from cross_file_items for ReactiveExceptionRefs *) let exception_refs_collection = - Reactive.flatMap ~name:"exception_refs_collection" cross_file_items + Reactive.flat_map ~name:"exception_refs_collection" cross_file_items ~f:(fun _path items -> - items.CrossFileItems.exception_refs - |> List.map (fun (r : CrossFileItems.exception_ref) -> + items.Cross_file_items.exception_refs + |> List.map (fun (r : Cross_file_items.exception_ref) -> (r.exception_path, r.loc_from))) () in (* Create reactive type-label dependencies *) let type_deps = - ReactiveTypeDeps.create ~decls + Reactive_type_deps.create ~decls ~report_types_dead_only_in_interface: - DeadCommon.Config.reportTypesDeadOnlyInInterface + Dead_common.Config.report_types_dead_only_in_interface in (* Create reactive exception refs resolution *) let exception_refs = - ReactiveExceptionRefs.create ~decls + Reactive_exception_refs.create ~decls ~exception_refs:exception_refs_collection in @@ -156,115 +157,115 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (** Convert reactive decls to Declarations.t for solver *) let freeze_decls (t : t) : Declarations.t = - let result = PosHash.create 256 in - Reactive.iter (fun pos decl -> PosHash.replace result pos decl) t.decls; + let result = Pos_hash.create 256 in + Reactive.iter (fun pos decl -> Pos_hash.replace result pos decl) t.decls; Declarations.create_from_hashtbl result (** Convert reactive annotations to FileAnnotations.t for solver *) -let freeze_annotations (t : t) : FileAnnotations.t = - let result = PosHash.create 256 in - Reactive.iter (fun pos ann -> PosHash.replace result pos ann) t.annotations; - FileAnnotations.create_from_hashtbl result +let freeze_annotations (t : t) : File_annotations.t = + let result = Pos_hash.create 256 in + Reactive.iter (fun pos ann -> Pos_hash.replace result pos ann) t.annotations; + File_annotations.create_from_hashtbl result (** Convert reactive refs to References.t for solver. Includes type-label deps and exception refs from reactive computations. *) let freeze_refs (t : t) : References.t = - let value_refs_from = PosHash.create 256 in - let type_refs_from = PosHash.create 256 in + let value_refs_from = Pos_hash.create 256 in + let type_refs_from = Pos_hash.create 256 in (* Helper to add to refs_from hashtable *) - let add_to_from tbl posFrom posTo = + let add_to_from tbl pos_from pos_to = let existing = - match PosHash.find_opt tbl posFrom with + match Pos_hash.find_opt tbl pos_from with | Some s -> s - | None -> PosSet.empty + | None -> Pos_set.empty in - PosHash.replace tbl posFrom (PosSet.add posTo existing) + Pos_hash.replace tbl pos_from (Pos_set.add pos_to existing) in (* Merge per-file value refs_from *) Reactive.iter - (fun posFrom posToSet -> - PosSet.iter - (fun posTo -> add_to_from value_refs_from posFrom posTo) - posToSet) + (fun pos_from pos_to_set -> + Pos_set.iter + (fun pos_to -> add_to_from value_refs_from pos_from pos_to) + pos_to_set) t.value_refs_from; (* Merge per-file type refs_from *) Reactive.iter - (fun posFrom posToSet -> - PosSet.iter - (fun posTo -> add_to_from type_refs_from posFrom posTo) - posToSet) + (fun pos_from pos_to_set -> + Pos_set.iter + (fun pos_to -> add_to_from type_refs_from pos_from pos_to) + pos_to_set) t.type_refs_from; (* Add type-label dependency refs from all sources *) let add_type_refs_from reactive = Reactive.iter - (fun posFrom posToSet -> - PosSet.iter - (fun posTo -> add_to_from type_refs_from posFrom posTo) - posToSet) + (fun pos_from pos_to_set -> + Pos_set.iter + (fun pos_to -> add_to_from type_refs_from pos_from pos_to) + pos_to_set) reactive in add_type_refs_from t.type_deps.all_type_refs_from; (* Add exception refs (to value refs_from) *) Reactive.iter - (fun posFrom posToSet -> - PosSet.iter - (fun posTo -> add_to_from value_refs_from posFrom posTo) - posToSet) + (fun pos_from pos_to_set -> + Pos_set.iter + (fun pos_to -> add_to_from value_refs_from pos_from pos_to) + pos_to_set) t.exception_refs.resolved_refs_from; References.create ~value_refs_from ~type_refs_from (** Collect all cross-file items *) -let collect_cross_file_items (t : t) : CrossFileItems.t = +let collect_cross_file_items (t : t) : Cross_file_items.t = let exception_refs = ref [] in let optional_arg_calls = ref [] in let function_refs = ref [] in Reactive.iter (fun _path items -> - exception_refs := items.CrossFileItems.exception_refs @ !exception_refs; + exception_refs := items.Cross_file_items.exception_refs @ !exception_refs; optional_arg_calls := - items.CrossFileItems.optional_arg_calls @ !optional_arg_calls; - function_refs := items.CrossFileItems.function_refs @ !function_refs) + items.Cross_file_items.optional_arg_calls @ !optional_arg_calls; + function_refs := items.Cross_file_items.function_refs @ !function_refs) t.cross_file_items; { - CrossFileItems.exception_refs = !exception_refs; + Cross_file_items.exception_refs = !exception_refs; optional_arg_calls = !optional_arg_calls; function_refs = !function_refs; } (** Convert reactive file deps to FileDeps.t for solver. Includes file deps from exception refs. *) -let freeze_file_deps (t : t) : FileDeps.t = +let freeze_file_deps (t : t) : File_deps.t = let files = - let result = ref FileSet.empty in - Reactive.iter (fun path () -> result := FileSet.add path !result) t.files; + let result = ref File_set.empty in + Reactive.iter (fun path () -> result := File_set.add path !result) t.files; !result in - let deps = FileDeps.FileHash.create 256 in + let deps = File_deps.File_hash.create 256 in Reactive.iter (fun from_file to_files -> - FileDeps.FileHash.replace deps from_file to_files) + File_deps.File_hash.replace deps from_file to_files) t.file_deps_map; (* Add file deps from exception refs - iterate value_refs_from *) Reactive.iter - (fun posFrom posToSet -> - PosSet.iter - (fun posTo -> - let from_file = posFrom.Lexing.pos_fname in - let to_file = posTo.Lexing.pos_fname in + (fun pos_from pos_to_set -> + Pos_set.iter + (fun pos_to -> + let from_file = pos_from.Lexing.pos_fname in + let to_file = pos_to.Lexing.pos_fname in if from_file <> to_file then let existing = - match FileDeps.FileHash.find_opt deps from_file with + match File_deps.File_hash.find_opt deps from_file with | Some s -> s - | None -> FileSet.empty + | None -> File_set.empty in - FileDeps.FileHash.replace deps from_file - (FileSet.add to_file existing)) - posToSet) + File_deps.File_hash.replace deps from_file + (File_set.add to_file existing)) + pos_to_set) t.exception_refs.resolved_refs_from; - FileDeps.create ~files ~deps + File_deps.create ~files ~deps diff --git a/analysis/reanalyze/src/ReactiveMerge.mli b/analysis/reanalyze/src/reactive_merge.mli similarity index 72% rename from analysis/reanalyze/src/ReactiveMerge.mli rename to analysis/reanalyze/src/reactive_merge.mli index 181c37a6953..d170b398407 100644 --- a/analysis/reanalyze/src/ReactiveMerge.mli +++ b/analysis/reanalyze/src/reactive_merge.mli @@ -26,23 +26,23 @@ type t = { decls: (Lexing.position, Decl.t) Reactive.t; - annotations: (Lexing.position, FileAnnotations.annotated_as) Reactive.t; - value_refs_from: (Lexing.position, PosSet.t) Reactive.t; + annotations: (Lexing.position, File_annotations.annotated_as) Reactive.t; + value_refs_from: (Lexing.position, Pos_set.t) Reactive.t; (** Value refs: source -> targets *) - type_refs_from: (Lexing.position, PosSet.t) Reactive.t; + type_refs_from: (Lexing.position, Pos_set.t) Reactive.t; (** Type refs: source -> targets *) - cross_file_items: (string, CrossFileItems.t) Reactive.t; - file_deps_map: (string, FileSet.t) Reactive.t; + cross_file_items: (string, Cross_file_items.t) Reactive.t; + file_deps_map: (string, File_set.t) Reactive.t; files: (string, unit) Reactive.t; (* Reactive type/exception dependencies *) - type_deps: ReactiveTypeDeps.t; - exception_refs: ReactiveExceptionRefs.t; + type_deps: Reactive_type_deps.t; + exception_refs: Reactive_exception_refs.t; } (** All derived reactive collections from per-file data *) (** {1 Creation} *) -val create : (string, DceFileProcessing.file_data option) Reactive.t -> t +val create : (string, Dce_file_processing.file_data option) Reactive.t -> t (** Create reactive merge from a file data collection. All derived collections update automatically when source changes. *) @@ -51,14 +51,14 @@ val create : (string, DceFileProcessing.file_data option) Reactive.t -> t val freeze_decls : t -> Declarations.t (** Convert reactive decls to Declarations.t for solver *) -val freeze_annotations : t -> FileAnnotations.t +val freeze_annotations : t -> File_annotations.t (** Convert reactive annotations to FileAnnotations.t for solver *) val freeze_refs : t -> References.t (** Convert reactive refs to References.t for solver *) -val collect_cross_file_items : t -> CrossFileItems.t +val collect_cross_file_items : t -> Cross_file_items.t (** Collect all cross-file items *) -val freeze_file_deps : t -> FileDeps.t +val freeze_file_deps : t -> File_deps.t (** Convert reactive file deps to FileDeps.t for solver *) diff --git a/analysis/reanalyze/src/ReactiveSolver.ml b/analysis/reanalyze/src/reactive_solver.ml similarity index 80% rename from analysis/reanalyze/src/ReactiveSolver.ml rename to analysis/reanalyze/src/reactive_solver.ml index dbe21b2b43c..e0b7456b555 100644 --- a/analysis/reanalyze/src/ReactiveSolver.ml +++ b/analysis/reanalyze/src/reactive_solver.ml @@ -27,8 +27,8 @@ type t = { live: (Lexing.position, unit) Reactive.t; dead_decls: (Lexing.position, Decl.t) Reactive.t; live_decls: (Lexing.position, Decl.t) Reactive.t; - annotations: (Lexing.position, FileAnnotations.annotated_as) Reactive.t; - value_refs_from: (Lexing.position, PosSet.t) Reactive.t option; + annotations: (Lexing.position, File_annotations.annotated_as) Reactive.t; + value_refs_from: (Lexing.position, Pos_set.t) Reactive.t option; dead_modules: (Name.t, Location.t * string) Reactive.t; (** Modules where all declarations are dead. Value is (loc, fileName). Reactive anti-join. *) dead_decls_by_file: (string, Decl.t list) Reactive.t; @@ -41,18 +41,19 @@ type t = { (** Live declarations with @dead annotation. Reactive join of live_decls + annotations. *) dead_module_issues: (Name.t, Issue.t) Reactive.t; (** Dead module issues. Reactive join of dead_modules + modules_with_reported. *) - config: DceConfig.t; + config: Dce_config.t; } (** Extract module name from a declaration *) let decl_module_name (decl : Decl.t) : Name.t = - decl.path |> DcePath.toModuleName ~isType:(decl.declKind |> Decl.Kind.isType) + decl.path + |> Dce_path.to_module_name ~is_type:(decl.decl_kind |> Decl.Kind.is_type) let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~(live : (Lexing.position, unit) Reactive.t) - ~(annotations : (Lexing.position, FileAnnotations.annotated_as) Reactive.t) - ~(value_refs_from : (Lexing.position, PosSet.t) Reactive.t option) - ~(config : DceConfig.t) : t = + ~(annotations : (Lexing.position, File_annotations.annotated_as) Reactive.t) + ~(value_refs_from : (Lexing.position, Pos_set.t) Reactive.t option) + ~(config : Dce_config.t) : t = (* dead_decls = decls where NOT in live (reactive join) *) let dead_decls = Reactive.join ~name:"solver.dead_decls" decls live @@ -77,49 +78,49 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Reactive dead modules: modules with dead decls but no live decls *) let dead_modules = - if not config.DceConfig.run.transitive then + if not config.Dce_config.run.transitive then (* Dead modules only reported in transitive mode *) - Reactive.flatMap ~name:"solver.dead_modules_empty" dead_decls + Reactive.flat_map ~name:"solver.dead_modules_empty" dead_decls ~f:(fun _ _ -> []) () else (* modules_with_dead: (moduleName, (loc, fileName)) for each module with dead decls *) let modules_with_dead = - Reactive.flatMap ~name:"solver.modules_with_dead" dead_decls + Reactive.flat_map ~name:"solver.modules_with_dead" dead_decls ~f:(fun _pos decl -> [ ( decl_module_name decl, - (decl.moduleLoc, decl.pos.Lexing.pos_fname) ); + (decl.module_loc, decl.pos.Lexing.pos_fname) ); ]) ~merge:(fun v1 _v2 -> v1) (* keep first *) () in (* modules_with_live: (moduleName, ()) for each module with live decls *) let modules_with_live = - Reactive.flatMap ~name:"solver.modules_with_live" live_decls + Reactive.flat_map ~name:"solver.modules_with_live" live_decls ~f:(fun _pos decl -> [(decl_module_name decl, ())]) () in (* Anti-join: modules in dead but not in live *) Reactive.join ~name:"solver.dead_modules" modules_with_dead modules_with_live - ~key_of:(fun modName (_loc, _fileName) -> modName) - ~f:(fun modName (loc, fileName) live_opt -> + ~key_of:(fun mod_name (_loc, _fileName) -> mod_name) + ~f:(fun mod_name (loc, file_name) live_opt -> match live_opt with - | None -> [(modName, (loc, fileName))] (* dead: no live decls *) + | None -> [(mod_name, (loc, file_name))] (* dead: no live decls *) | Some () -> []) (* live: has at least one live decl *) () in (* Reactive per-file grouping of dead declarations *) let dead_decls_by_file = - Reactive.flatMap ~name:"solver.dead_decls_by_file" dead_decls + Reactive.flat_map ~name:"solver.dead_decls_by_file" dead_decls ~f:(fun _pos decl -> [(decl.pos.Lexing.pos_fname, [decl])]) ~merge:(fun decls1 decls2 -> decls1 @ decls2) () in - let transitive = config.DceConfig.run.transitive in + let transitive = config.Dce_config.run.transitive in (* Reactive per-file issues. IMPORTANT: in non-transitive mode, warning emission depends on hasRefBelow, @@ -129,37 +130,37 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Track modules that have reported values *) let modules_with_values : (Name.t, unit) Hashtbl.t = Hashtbl.create 8 in (* shouldReport checks annotations reactively *) - let shouldReport (decl : Decl.t) = + let should_report (decl : Decl.t) = match Reactive.get annotations decl.pos with - | Some FileAnnotations.Live -> false - | Some FileAnnotations.GenType -> false - | Some FileAnnotations.Dead -> false + | Some File_annotations.Live -> false + | Some File_annotations.GenType -> false + | Some File_annotations.Dead -> false | None -> true in (* Don't emit module issues here - track modules for later *) - let checkModuleDead ~fileName:_ moduleName = - Hashtbl.replace modules_with_values moduleName (); + let check_module_dead ~file_name:_ module_name = + Hashtbl.replace modules_with_values module_name (); None (* Module issues generated separately *) in (* hasRefBelow: check if decl has any ref from "below" (including cross-file refs) *) - let hasRefBelow = + let has_ref_below = if transitive then fun _ -> false else match value_refs_from with | None -> fun _ -> false | Some refs_from -> (* Must iterate ALL refs since cross-file refs also count as "below" *) - DeadCommon.make_hasRefBelow ~transitive + Dead_common.make_hasRefBelow ~transitive ~iter_value_refs_from:(fun f -> Reactive.iter f refs_from) in (* Sort within file and generate issues *) - let sorted = decls |> List.fast_sort Decl.compareForReporting in - let reporting_ctx = DeadCommon.ReportingContext.create () in + let sorted = decls |> List.fast_sort Decl.compare_for_reporting in + let reporting_ctx = Dead_common.Reporting_context.create () in let file_issues = sorted |> List.concat_map (fun decl -> - DeadCommon.reportDeclaration ~config ~hasRefBelow ~checkModuleDead - ~shouldReport reporting_ctx decl) + Dead_common.report_declaration ~config ~has_ref_below + ~check_module_dead ~should_report reporting_ctx decl) in let modules_list = Hashtbl.fold (fun m () acc -> m :: acc) modules_with_values [] @@ -169,14 +170,14 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let issues_by_file = match (transitive, value_refs_from) with | true, _ | false, None -> - Reactive.flatMap ~name:"solver.issues_by_file" dead_decls_by_file + Reactive.flat_map ~name:"solver.issues_by_file" dead_decls_by_file ~f:(fun file decls -> [(file, issues_for_file file decls)]) () | false, Some refs_from -> (* Create a singleton "refs token" that changes whenever refs_from changes, and join every file against it so per-file issues recompute. *) let refs_token = - Reactive.flatMap ~name:"solver.refs_token" refs_from + Reactive.flat_map ~name:"solver.refs_token" refs_from ~f:(fun _posFrom _targets -> [((), ())]) ~merge:(fun _ _ -> ()) () @@ -193,14 +194,14 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~key_of:(fun pos _decl -> pos) ~f:(fun pos decl ann_opt -> match ann_opt with - | Some FileAnnotations.Dead -> [(pos, decl)] + | Some File_annotations.Dead -> [(pos, decl)] | _ -> []) () in (* Reactive modules_with_reported: modules that have at least one reported dead value *) let modules_with_reported = - Reactive.flatMap ~name:"solver.modules_with_reported" issues_by_file + Reactive.flat_map ~name:"solver.modules_with_reported" issues_by_file ~f:(fun _file (_issues, modules_list) -> List.map (fun m -> (m, ())) modules_list) () @@ -210,15 +211,15 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let dead_module_issues = Reactive.join ~name:"solver.dead_module_issues" dead_modules modules_with_reported - ~key_of:(fun moduleName (_loc, _fileName) -> moduleName) - ~f:(fun moduleName (loc, fileName) has_reported_opt -> + ~key_of:(fun module_name (_loc, _fileName) -> module_name) + ~f:(fun module_name (loc, file_name) has_reported_opt -> match has_reported_opt with | Some () -> let loc = if loc.Location.loc_ghost then let pos = { - Lexing.pos_fname = fileName; + Lexing.pos_fname = file_name; pos_lnum = 0; pos_bol = 0; pos_cnum = 0; @@ -227,7 +228,10 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) {Location.loc_start = pos; loc_end = pos; loc_ghost = false} else loc in - [(moduleName, AnalysisResult.make_dead_module_issue ~loc ~moduleName)] + [ + ( module_name, + Analysis_result.make_dead_module_issue ~loc ~module_name ); + ] | None -> []) () in @@ -250,31 +254,31 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (** Check if a module is dead using reactive collection. Returns issue if dead. Uses reported_modules set to avoid duplicate reports. *) let check_module_dead ~(dead_modules : (Name.t, Location.t * string) Reactive.t) - ~(reported_modules : (Name.t, unit) Hashtbl.t) ~fileName:pos_fname - moduleName : Issue.t option = - if Hashtbl.mem reported_modules moduleName then None + ~(reported_modules : (Name.t, unit) Hashtbl.t) ~file_name:pos_fname + module_name : Issue.t option = + if Hashtbl.mem reported_modules module_name then None else - match Reactive.get dead_modules moduleName with - | Some (loc, fileName) -> - Hashtbl.replace reported_modules moduleName (); + match Reactive.get dead_modules module_name with + | Some (loc, file_name) -> + Hashtbl.replace reported_modules module_name (); let loc = if loc.Location.loc_ghost then (* Use fileName from dead_modules, fallback to pos_fname *) - let fname = if fileName <> "" then fileName else pos_fname in + let fname = if file_name <> "" then file_name else pos_fname in let pos = {Lexing.pos_fname = fname; pos_lnum = 0; pos_bol = 0; pos_cnum = 0} in {Location.loc_start = pos; loc_end = pos; loc_ghost = false} else loc in - Some (AnalysisResult.make_dead_module_issue ~loc ~moduleName) + Some (Analysis_result.make_dead_module_issue ~loc ~module_name) | None -> None (** Collect issues from reactive issues_by_file. Only iterates the pre-computed reactive issues collection. Deduplicates module issues across files. *) -let collect_issues ~(t : t) ~(config : DceConfig.t) - ~(ann_store : AnnotationStore.t) : Issue.t list = +let collect_issues ~(t : t) ~(config : Dce_config.t) + ~(ann_store : Annotation_store.t) : Issue.t list = ignore (config, ann_store); (* config is stored in t, ann_store used via reactive annotations *) let t0 = Unix.gettimeofday () in @@ -286,13 +290,13 @@ let collect_issues ~(t : t) ~(config : DceConfig.t) Reactive.iter (fun _pos (decl : Decl.t) -> let issue = - DeadCommon.makeDeadIssue ~decl + Dead_common.make_dead_issue ~decl ~message:" is annotated @dead but is live" Issue.IncorrectDeadAnnotation in (* Check if module is dead using reactive collection *) check_module_dead ~dead_modules:t.dead_modules ~reported_modules - ~fileName:decl.pos.pos_fname (decl_module_name decl) + ~file_name:decl.pos.pos_fname (decl_module_name decl) |> Option.iter (fun mod_issue -> incorrect_dead_issues := mod_issue :: !incorrect_dead_issues); incorrect_dead_issues := issue :: !incorrect_dead_issues) diff --git a/analysis/reanalyze/src/ReactiveSolver.mli b/analysis/reanalyze/src/reactive_solver.mli similarity index 77% rename from analysis/reanalyze/src/ReactiveSolver.mli rename to analysis/reanalyze/src/reactive_solver.mli index 0c5e5e1d0f1..7666b29fc1e 100644 --- a/analysis/reanalyze/src/ReactiveSolver.mli +++ b/analysis/reanalyze/src/reactive_solver.mli @@ -10,13 +10,13 @@ type t val create : decls:(Lexing.position, Decl.t) Reactive.t -> live:(Lexing.position, unit) Reactive.t -> - annotations:(Lexing.position, FileAnnotations.annotated_as) Reactive.t -> - value_refs_from:(Lexing.position, PosSet.t) Reactive.t option -> - config:DceConfig.t -> + annotations:(Lexing.position, File_annotations.annotated_as) Reactive.t -> + value_refs_from:(Lexing.position, Pos_set.t) Reactive.t option -> + config:Dce_config.t -> t val collect_issues : - t:t -> config:DceConfig.t -> ann_store:AnnotationStore.t -> Issue.t list + t:t -> config:Dce_config.t -> ann_store:Annotation_store.t -> Issue.t list (** Collect issues. O(dead_decls + live_decls). *) val iter_live_decls : t:t -> (Decl.t -> unit) -> unit diff --git a/analysis/reanalyze/src/ReactiveTypeDeps.ml b/analysis/reanalyze/src/reactive_type_deps.ml similarity index 73% rename from analysis/reanalyze/src/ReactiveTypeDeps.ml rename to analysis/reanalyze/src/reactive_type_deps.ml index 5fd0694405b..233f37e67b6 100644 --- a/analysis/reanalyze/src/ReactiveTypeDeps.ml +++ b/analysis/reanalyze/src/reactive_type_deps.ml @@ -12,35 +12,36 @@ type decl_info = { pos: Lexing.position; pos_end: Lexing.position; - path: DcePath.t; + path: Dce_path.t; is_interface: bool; } (** Simplified decl info for type-label processing *) let decl_to_info (decl : Decl.t) : decl_info option = - match decl.declKind with + match decl.decl_kind with | RecordLabel | VariantCase -> let is_interface = match List.rev decl.path with | [] -> true - | moduleNameTag :: _ -> ( - try (moduleNameTag |> Name.toString).[0] <> '+' with _ -> true) + | module_name_tag :: _ -> ( + try (module_name_tag |> Name.to_string).[0] <> '+' with _ -> true) in - Some {pos = decl.pos; pos_end = decl.posEnd; path = decl.path; is_interface} + Some + {pos = decl.pos; pos_end = decl.pos_end; path = decl.path; is_interface} | _ -> None (** {1 Reactive Collections} *) type t = { - decl_by_path: (DcePath.t, decl_info list) Reactive.t; + decl_by_path: (Dce_path.t, decl_info list) Reactive.t; (* refs_to direction: target -> sources *) - same_path_refs: (Lexing.position, PosSet.t) Reactive.t; - cross_file_refs: (Lexing.position, PosSet.t) Reactive.t; - all_type_refs: (Lexing.position, PosSet.t) Reactive.t; - impl_to_intf_refs_path2: (Lexing.position, PosSet.t) Reactive.t; - intf_to_impl_refs: (Lexing.position, PosSet.t) Reactive.t; + same_path_refs: (Lexing.position, Pos_set.t) Reactive.t; + cross_file_refs: (Lexing.position, Pos_set.t) Reactive.t; + all_type_refs: (Lexing.position, Pos_set.t) Reactive.t; + impl_to_intf_refs_path2: (Lexing.position, Pos_set.t) Reactive.t; + intf_to_impl_refs: (Lexing.position, Pos_set.t) Reactive.t; (* refs_from direction: source -> targets (for forward solver) *) - all_type_refs_from: (Lexing.position, PosSet.t) Reactive.t; + all_type_refs_from: (Lexing.position, Pos_set.t) Reactive.t; } (** All reactive collections for type-label dependencies *) @@ -49,7 +50,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~(report_types_dead_only_in_interface : bool) : t = (* Step 1: Index decls by path *) let decl_by_path = - Reactive.flatMap ~name:"type_deps.decl_by_path" decls + Reactive.flat_map ~name:"type_deps.decl_by_path" decls ~f:(fun _pos decl -> match decl_to_info decl with | Some info -> [(info.path, [info])] @@ -59,7 +60,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Step 2: Same-path refs - connect all decls at the same path *) let same_path_refs = - Reactive.flatMap ~name:"type_deps.same_path_refs" decl_by_path + Reactive.flat_map ~name:"type_deps.same_path_refs" decl_by_path ~f:(fun _path decls -> match decls with | [] | [_] -> [] @@ -70,29 +71,29 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) rest |> List.concat_map (fun other -> (* Always add: other -> first (posTo=other, posFrom=first) *) - let refs = [(other.pos, PosSet.singleton first.pos)] in + let refs = [(other.pos, Pos_set.singleton first.pos)] in if report_types_dead_only_in_interface then refs else (* Also add: first -> other (posTo=first, posFrom=other) *) - (first.pos, PosSet.singleton other.pos) :: refs)) - ~merge:PosSet.union () + (first.pos, Pos_set.singleton other.pos) :: refs)) + ~merge:Pos_set.union () in (* Step 3: Cross-file refs - connect impl decls to intf decls *) (* First, extract impl decls that need to look up intf *) let impl_decls = - Reactive.flatMap ~name:"type_deps.impl_decls" decls + Reactive.flat_map ~name:"type_deps.impl_decls" decls ~f:(fun _pos decl -> match decl_to_info decl with | Some info when not info.is_interface -> ( match info.path with | [] -> [] - | typeLabelName :: pathToType -> + | type_label_name :: path_to_type -> (* Try two intf paths *) - let path_1 = pathToType |> DcePath.moduleToInterface in - let path_2 = path_1 |> DcePath.typeToInterface in - let intf_path1 = typeLabelName :: path_1 in - let intf_path2 = typeLabelName :: path_2 in + let path_1 = path_to_type |> Dce_path.module_to_interface in + let path_2 = path_1 |> Dce_path.type_to_interface in + let intf_path1 = type_label_name :: path_1 in + let intf_path2 = type_label_name :: path_2 in [(info.pos, (info, intf_path1, intf_path2))]) | _ -> []) () @@ -108,13 +109,13 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) match intf_decls_opt with | Some (intf_info :: _) -> (* Found at path1: posTo=impl, posFrom=intf *) - let refs = [(info.pos, PosSet.singleton intf_info.pos)] in + let refs = [(info.pos, Pos_set.singleton intf_info.pos)] in if report_types_dead_only_in_interface then refs else (* Also: posTo=intf, posFrom=impl *) - (intf_info.pos, PosSet.singleton info.pos) :: refs + (intf_info.pos, Pos_set.singleton info.pos) :: refs | _ -> []) - ~merge:PosSet.union () + ~merge:Pos_set.union () in (* Second join for path2 fallback *) @@ -136,11 +137,11 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) match intf_decls_opt with | Some (intf_info :: _) -> (* posTo=impl, posFrom=intf *) - let refs = [(info.pos, PosSet.singleton intf_info.pos)] in + let refs = [(info.pos, Pos_set.singleton intf_info.pos)] in if report_types_dead_only_in_interface then refs - else (intf_info.pos, PosSet.singleton info.pos) :: refs + else (intf_info.pos, Pos_set.singleton info.pos) :: refs | _ -> []) - ~merge:PosSet.union () + ~merge:Pos_set.union () in (* Also handle intf -> impl direction. @@ -149,15 +150,15 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) The intf->impl code in original only runs when isInterface=true, and the lookup is for finding the impl. *) let intf_decls = - Reactive.flatMap ~name:"type_deps.intf_decls" decls + Reactive.flat_map ~name:"type_deps.intf_decls" decls ~f:(fun _pos decl -> match decl_to_info decl with | Some info when info.is_interface -> ( match info.path with | [] -> [] - | typeLabelName :: pathToType -> + | type_label_name :: path_to_type -> let impl_path = - typeLabelName :: DcePath.moduleToImplementation pathToType + type_label_name :: Dce_path.module_to_implementation path_to_type in [(info.pos, (info, impl_path))]) | _ -> []) @@ -184,11 +185,11 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) Here loc is the current intf decl, loc1 is the found impl. So extendTypeDependencies loc1 loc means posTo=loc1=impl, posFrom=loc=intf *) - let refs = [(impl_info.pos, PosSet.singleton intf_info.pos)] in + let refs = [(impl_info.pos, Pos_set.singleton intf_info.pos)] in if report_types_dead_only_in_interface then refs - else (intf_info.pos, PosSet.singleton impl_info.pos) :: refs + else (intf_info.pos, Pos_set.singleton impl_info.pos) :: refs | _ -> []) - ~merge:PosSet.union () + ~merge:Pos_set.union () in (* Cross-file refs are the combination of: @@ -208,21 +209,21 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let combined_refs_to = let u1 = Reactive.union ~name:"type_deps.u1" same_path_refs cross_file_refs - ~merge:PosSet.union () + ~merge:Pos_set.union () in let u2 = Reactive.union ~name:"type_deps.u2" u1 impl_to_intf_refs_path2 - ~merge:PosSet.union () + ~merge:Pos_set.union () in Reactive.union ~name:"type_deps.combined_refs_to" u2 intf_to_impl_refs - ~merge:PosSet.union () + ~merge:Pos_set.union () in (* Invert the combined refs_to to refs_from *) - Reactive.flatMap ~name:"type_deps.all_type_refs_from" combined_refs_to - ~f:(fun posTo posFromSet -> - PosSet.elements posFromSet - |> List.map (fun posFrom -> (posFrom, PosSet.singleton posTo))) - ~merge:PosSet.union () + Reactive.flat_map ~name:"type_deps.all_type_refs_from" combined_refs_to + ~f:(fun pos_to pos_from_set -> + Pos_set.elements pos_from_set + |> List.map (fun pos_from -> (pos_from, Pos_set.singleton pos_to))) + ~merge:Pos_set.union () in { @@ -240,8 +241,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (** Add all type refs to a References.builder *) let add_to_refs_builder (t : t) ~(refs : References.builder) : unit = Reactive.iter - (fun posTo posFromSet -> - PosSet.iter - (fun posFrom -> References.add_type_ref refs ~posTo ~posFrom) - posFromSet) + (fun pos_to pos_from_set -> + Pos_set.iter + (fun pos_from -> References.add_type_ref refs ~pos_to ~pos_from) + pos_from_set) t.all_type_refs diff --git a/analysis/reanalyze/src/ReactiveTypeDeps.mli b/analysis/reanalyze/src/reactive_type_deps.mli similarity index 80% rename from analysis/reanalyze/src/ReactiveTypeDeps.mli rename to analysis/reanalyze/src/reactive_type_deps.mli index ac6c9ff2aa8..c563ec19717 100644 --- a/analysis/reanalyze/src/ReactiveTypeDeps.mli +++ b/analysis/reanalyze/src/reactive_type_deps.mli @@ -30,22 +30,22 @@ (** {1 Types} *) type t = { - decl_by_path: (DcePath.t, decl_info list) Reactive.t; + decl_by_path: (Dce_path.t, decl_info list) Reactive.t; (* refs_to direction: target -> sources *) - same_path_refs: (Lexing.position, PosSet.t) Reactive.t; - cross_file_refs: (Lexing.position, PosSet.t) Reactive.t; - all_type_refs: (Lexing.position, PosSet.t) Reactive.t; - impl_to_intf_refs_path2: (Lexing.position, PosSet.t) Reactive.t; - intf_to_impl_refs: (Lexing.position, PosSet.t) Reactive.t; + same_path_refs: (Lexing.position, Pos_set.t) Reactive.t; + cross_file_refs: (Lexing.position, Pos_set.t) Reactive.t; + all_type_refs: (Lexing.position, Pos_set.t) Reactive.t; + impl_to_intf_refs_path2: (Lexing.position, Pos_set.t) Reactive.t; + intf_to_impl_refs: (Lexing.position, Pos_set.t) Reactive.t; (* refs_from direction: source -> targets (for forward solver) *) - all_type_refs_from: (Lexing.position, PosSet.t) Reactive.t; + all_type_refs_from: (Lexing.position, Pos_set.t) Reactive.t; } (** Reactive type-label dependency collections *) and decl_info = { pos: Lexing.position; pos_end: Lexing.position; - path: DcePath.t; + path: Dce_path.t; is_interface: bool; } (** Simplified decl info for type-label processing *) diff --git a/analysis/reanalyze/src/Reanalyze.ml b/analysis/reanalyze/src/reanalyze.ml similarity index 66% rename from analysis/reanalyze/src/Reanalyze.ml rename to analysis/reanalyze/src/reanalyze.ml index 68aa938993b..652716f0fb4 100644 --- a/analysis/reanalyze/src/Reanalyze.ml +++ b/analysis/reanalyze/src/reanalyze.ml @@ -1,114 +1,115 @@ -let runConfig = RunConfig.runConfig +let run_config = Run_config.run_config type cmt_file_result = { - dce_data: DceFileProcessing.file_data option; + dce_data: Dce_file_processing.file_data option; exception_data: Exception.file_result option; } (** Result of processing a single cmt file *) (** Process a cmt file and return its results. Conceptually: map over files, then merge results. *) -let loadCmtFile ~config cmtFilePath : cmt_file_result option = - let cmt_infos = Cmt_format.read_cmt cmtFilePath in - let excludePath sourceFile = - config.DceConfig.cli.exclude_paths +let load_cmt_file ~config cmt_file_path : cmt_file_result option = + let cmt_infos = Cmt_format.read_cmt cmt_file_path in + let exclude_path source_file = + config.Dce_config.cli.exclude_paths |> List.exists (fun prefix_ -> let prefix = - match Filename.is_relative sourceFile with + match Filename.is_relative source_file with | true -> prefix_ | false -> Filename.concat (Sys.getcwd ()) prefix_ in - String.length prefix <= String.length sourceFile + String.length prefix <= String.length source_file && - try String.sub sourceFile 0 (String.length prefix) = prefix + try String.sub source_file 0 (String.length prefix) = prefix with Invalid_argument _ -> false) in - match cmt_infos.cmt_annots |> FindSourceFile.cmt with - | Some sourceFile when not (excludePath sourceFile) -> - let is_interface = + match cmt_infos.cmt_annots |> Find_source_file.cmt with + | Some source_file when not (exclude_path source_file) -> + let is_interface_ = match cmt_infos.cmt_annots with | Interface _ -> true - | _ -> Filename.check_suffix sourceFile "i" + | _ -> Filename.check_suffix source_file "i" in - let module_name = sourceFile |> Paths.getModuleName in + let module_name = source_file |> Paths.get_module_name in (* File context for DceFileProcessing (breaks cycle with DeadCommon) *) - let dce_file_context : DceFileProcessing.file_context = - {source_path = sourceFile; module_name; is_interface} + let dce_file_context : Dce_file_processing.file_context = + {source_path = source_file; module_name; is_interface = is_interface_} in (* File context for Exception/Arnold (uses DeadCommon.FileContext) *) let file_context = - DeadCommon.FileContext. - {source_path = sourceFile; module_name; is_interface} + Dead_common.File_context. + {source_path = source_file; module_name; is_interface = is_interface_} in if config.cli.debug then Log_.item "Scanning %s Source:%s@." - (match config.cli.ci && not (Filename.is_relative cmtFilePath) with - | true -> Filename.basename cmtFilePath - | false -> cmtFilePath) - (match config.cli.ci && not (Filename.is_relative sourceFile) with - | true -> sourceFile |> Filename.basename - | false -> sourceFile); + (match config.cli.ci && not (Filename.is_relative cmt_file_path) with + | true -> Filename.basename cmt_file_path + | false -> cmt_file_path) + (match config.cli.ci && not (Filename.is_relative source_file) with + | true -> source_file |> Filename.basename + | false -> source_file); (* Process file for DCE - return file_data *) let dce_data = - if config.DceConfig.run.dce then + if config.Dce_config.run.dce then Some (cmt_infos - |> DceFileProcessing.process_cmt_file ~config ~file:dce_file_context - ~cmtFilePath) + |> Dce_file_processing.process_cmt_file ~config ~file:dce_file_context + ~cmt_file_path) else None in (* Process file for Exception analysis *) let exception_data = - if config.DceConfig.run.exception_ then - cmt_infos |> Exception.processCmt ~file:file_context + if config.Dce_config.run.exception_ then + cmt_infos |> Exception.process_cmt ~file:file_context else None in - if config.DceConfig.run.termination then - cmt_infos |> Arnold.processCmt ~config ~file:file_context; + if config.Dce_config.run.termination then + cmt_infos |> Arnold.process_cmt ~config ~file:file_context; Some {dce_data; exception_data} | _ -> None type all_files_result = { - dce_data_list: DceFileProcessing.file_data list; + dce_data_list: Dce_file_processing.file_data list; exception_results: Exception.file_result list; } (** Result of processing all cmt files *) (** Collect all cmt file paths to process *) -let collectCmtFilePaths ~cmtRoot : string list = +let collect_cmt_file_paths ~cmt_root : string list = let ( +++ ) = Filename.concat in let paths = ref [] in - (match cmtRoot with + (match cmt_root with | Some root -> - Cli.cmtCommand := true; - let rec walkSubDirs dir = - let absDir = + Cli.cmt_command := true; + let rec walk_sub_dirs dir = + let abs_dir = match dir = "" with | true -> root | false -> root +++ dir in - let skipDir = + let skip_dir = let base = Filename.basename dir in base = "node_modules" || base = "_esy" in - if (not skipDir) && Sys.file_exists absDir then - if Sys.is_directory absDir then - absDir |> Sys.readdir |> Array.iter (fun d -> walkSubDirs (dir +++ d)) + if (not skip_dir) && Sys.file_exists abs_dir then + if Sys.is_directory abs_dir then + abs_dir |> Sys.readdir + |> Array.iter (fun d -> walk_sub_dirs (dir +++ d)) else if - Filename.check_suffix absDir ".cmt" - || Filename.check_suffix absDir ".cmti" - then paths := absDir :: !paths + Filename.check_suffix abs_dir ".cmt" + || Filename.check_suffix abs_dir ".cmti" + then paths := abs_dir :: !paths in - walkSubDirs "" + walk_sub_dirs "" | None -> - Lazy.force Paths.setReScriptProjectRoot; + Lazy.force Paths.set_re_script_project_root; (* Prefer explicit scan plan emitted by rewatch (v2 `.sourcedirs.json`). This supports monorepos without reanalyze-side package resolution. *) - let scan_plan = Paths.readCmtScan () in + let scan_plan = Paths.read_cmt_scan () in let seen = Hashtbl.create 256 in - let add_dir (absDir : string) = + let add_dir (abs_dir : string) = let files = - match Sys.readdir absDir |> Array.to_list with + match Sys.readdir abs_dir |> Array.to_list with | files -> files | exception Sys_error _ -> [] in @@ -117,7 +118,7 @@ let collectCmtFilePaths ~cmtRoot : string list = Filename.check_suffix x ".cmt" || Filename.check_suffix x ".cmti") |> List.sort String.compare |> List.iter (fun f -> - let p = Filename.concat absDir f in + let p = Filename.concat abs_dir f in if not (Hashtbl.mem seen p) then ( Hashtbl.add seen p (); paths := p :: !paths)) @@ -125,7 +126,7 @@ let collectCmtFilePaths ~cmtRoot : string list = scan_plan |> List.iter (fun (entry : Paths.cmt_scan_entry) -> let build_root_abs = - Filename.concat runConfig.projectRoot entry.build_root + Filename.concat run_config.project_root entry.build_root in (* Scan configured subdirs. *) entry.scan_dirs @@ -135,14 +136,14 @@ let collectCmtFilePaths ~cmtRoot : string list = !paths |> List.rev (** Process files sequentially *) -let processFilesSequential ~config (cmtFilePaths : string list) : +let process_files_sequential ~config (cmt_file_paths : string list) : all_files_result = Timing.time_phase `FileLoading (fun () -> let dce_data_list = ref [] in let exception_results = ref [] in - cmtFilePaths - |> List.iter (fun cmtFilePath -> - match loadCmtFile ~config cmtFilePath with + cmt_file_paths + |> List.iter (fun cmt_file_path -> + match load_cmt_file ~config cmt_file_path with | Some {dce_data; exception_data} -> ( (match dce_data with | Some data -> dce_data_list := data :: !dce_data_list @@ -156,11 +157,11 @@ let processFilesSequential ~config (cmtFilePaths : string list) : (** Process all cmt files and return results for DCE and Exception analysis. Conceptually: map process_cmt_file over all files. If file_stats is provided, it will be updated with processing statistics. *) -let processCmtFiles ~config ~cmtRoot ~reactive_collection ~skip_file - ?(file_stats : ReactiveAnalysis.processing_stats option) () : +let process_cmt_files ~config ~cmt_root ~reactive_collection ~skip_file + ?(file_stats : Reactive_analysis.processing_stats option) () : all_files_result = - let cmtFilePaths = - let all = collectCmtFilePaths ~cmtRoot in + let cmt_file_paths = + let all = collect_cmt_file_paths ~cmt_root in match skip_file with | Some should_skip -> List.filter (fun p -> not (should_skip p)) all | None -> all @@ -169,7 +170,7 @@ let processCmtFiles ~config ~cmtRoot ~reactive_collection ~skip_file match reactive_collection with | Some collection -> let result, stats = - ReactiveAnalysis.process_files ~collection ~config cmtFilePaths + Reactive_analysis.process_files ~collection ~config cmt_file_paths in (match file_stats with | Some fs -> @@ -181,7 +182,7 @@ let processCmtFiles ~config ~cmtRoot ~reactive_collection ~skip_file dce_data_list = result.dce_data_list; exception_results = result.exception_results; } - | None -> processFilesSequential ~config cmtFilePaths + | None -> process_files_sequential ~config cmt_file_paths (* Shuffle a list using Fisher-Yates algorithm *) let shuffle_list lst = @@ -195,31 +196,31 @@ let shuffle_list lst = done; Array.to_list arr -let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge +let run_analysis ~dce_config ~cmt_root ~reactive_collection ~reactive_merge ~reactive_liveness ~reactive_solver ~skip_file ?file_stats () = (* Map: process each file -> list of file_data *) let {dce_data_list; exception_results} = - processCmtFiles ~config:dce_config ~cmtRoot ~reactive_collection ~skip_file - ?file_stats () + process_cmt_files ~config:dce_config ~cmt_root ~reactive_collection + ~skip_file ?file_stats () in (* Get exception results from reactive collection if available *) let exception_results = match reactive_collection with - | Some collection -> ReactiveAnalysis.collect_exception_results collection + | Some collection -> Reactive_analysis.collect_exception_results collection | None -> exception_results in (* Optionally shuffle for order-independence testing *) let dce_data_list = - if !Cli.testShuffle then ( + if !Cli.test_shuffle then ( Random.self_init (); - if dce_config.DceConfig.cli.debug then + if dce_config.Dce_config.cli.debug then Log_.item "Shuffling file order for order-independence test@."; shuffle_list dce_data_list) else dce_data_list in (* Analysis phase: merge data and solve *) let analysis_result = - if dce_config.DceConfig.run.dce then + if dce_config.Dce_config.run.dce then (* Merging phase: combine all builders -> immutable data *) let ann_store, decl_store, cross_file_store, ref_store = Timing.time_phase `Merging (fun () -> @@ -228,28 +229,28 @@ let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge match reactive_merge with | Some merged -> (* Reactive mode: use stores directly, skip freeze! *) - ( AnnotationStore.of_reactive merged.ReactiveMerge.annotations, - DeclarationStore.of_reactive merged.ReactiveMerge.decls, - CrossFileItemsStore.of_reactive - merged.ReactiveMerge.cross_file_items ) + ( Annotation_store.of_reactive merged.Reactive_merge.annotations, + Declaration_store.of_reactive merged.Reactive_merge.decls, + Cross_file_items_store.of_reactive + merged.Reactive_merge.cross_file_items ) | None -> (* Non-reactive mode: freeze into data, wrap in store *) let decls = Declarations.merge_all (dce_data_list - |> List.map (fun fd -> fd.DceFileProcessing.decls)) + |> List.map (fun fd -> fd.Dce_file_processing.decls)) in - ( AnnotationStore.of_frozen - (FileAnnotations.merge_all + ( Annotation_store.of_frozen + (File_annotations.merge_all (dce_data_list - |> List.map (fun fd -> fd.DceFileProcessing.annotations) - )), - DeclarationStore.of_frozen decls, - CrossFileItemsStore.of_frozen - (CrossFileItems.merge_all + |> List.map (fun fd -> + fd.Dce_file_processing.annotations))), + Declaration_store.of_frozen decls, + Cross_file_items_store.of_frozen + (Cross_file_items.merge_all (dce_data_list - |> List.map (fun fd -> fd.DceFileProcessing.cross_file))) - ) + |> List.map (fun fd -> fd.Dce_file_processing.cross_file) + )) ) in (* Compute refs. In reactive mode, use stores directly (skip freeze!). @@ -258,7 +259,7 @@ let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge match reactive_merge with | Some merged -> (* Reactive mode: use stores directly *) - ReferenceStore.of_reactive + Reference_store.of_reactive ~value_refs_from:merged.value_refs_from ~type_refs_from:merged.type_refs_from ~type_deps:merged.type_deps @@ -268,50 +269,50 @@ let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge (* Need Declarations.t for type deps processing *) let decls = match decl_store with - | DeclarationStore.Frozen d -> d - | DeclarationStore.Reactive _ -> + | Declaration_store.Frozen d -> d + | Declaration_store.Reactive _ -> failwith "unreachable: non-reactive path with reactive store" in (* Need CrossFileItems.t for exception refs processing *) let cross_file = match cross_file_store with - | CrossFileItemsStore.Frozen cfi -> cfi - | CrossFileItemsStore.Reactive _ -> + | Cross_file_items_store.Frozen cfi -> cfi + | Cross_file_items_store.Reactive _ -> failwith "unreachable: non-reactive path with reactive store" in let refs_builder = References.create_builder () in - let file_deps_builder = FileDeps.create_builder () in + let file_deps_builder = File_deps.create_builder () in (match reactive_collection with | Some collection -> - ReactiveAnalysis.iter_file_data collection (fun fd -> + Reactive_analysis.iter_file_data collection (fun fd -> References.merge_into_builder - ~from:fd.DceFileProcessing.refs ~into:refs_builder; - FileDeps.merge_into_builder - ~from:fd.DceFileProcessing.file_deps + ~from:fd.Dce_file_processing.refs ~into:refs_builder; + File_deps.merge_into_builder + ~from:fd.Dce_file_processing.file_deps ~into:file_deps_builder) | None -> dce_data_list |> List.iter (fun fd -> References.merge_into_builder - ~from:fd.DceFileProcessing.refs ~into:refs_builder; - FileDeps.merge_into_builder - ~from:fd.DceFileProcessing.file_deps + ~from:fd.Dce_file_processing.refs ~into:refs_builder; + File_deps.merge_into_builder + ~from:fd.Dce_file_processing.file_deps ~into:file_deps_builder)); (* Compute type-label dependencies after merge *) - DeadType.process_type_label_dependencies ~config:dce_config + Dead_type.process_type_label_dependencies ~config:dce_config ~decls ~refs:refs_builder; let find_exception = - DeadException.find_exception_from_decls decls + Dead_exception.find_exception_from_decls decls in (* Process cross-file exception refs *) - CrossFileItems.process_exception_refs cross_file + Cross_file_items.process_exception_refs cross_file ~refs:refs_builder ~file_deps:file_deps_builder ~find_exception ~config:dce_config; (* Freeze refs for solver *) let refs = References.freeze_builder refs_builder in - ReferenceStore.of_frozen refs + Reference_store.of_frozen refs in (ann_store, decl_store, cross_file_store, ref_store)) in @@ -322,7 +323,7 @@ let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge (* Reactive solver: iterate dead_decls + live_decls *) let t0 = Unix.gettimeofday () in let dead_code_issues = - ReactiveSolver.collect_issues ~t:solver ~config:dce_config + Reactive_solver.collect_issues ~t:solver ~config:dce_config ~ann_store in let t1 = Unix.gettimeofday () in @@ -332,25 +333,25 @@ let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge | Some merged -> (* Create CrossFileItemsStore from reactive collection *) let cross_file_store = - CrossFileItemsStore.of_reactive - merged.ReactiveMerge.cross_file_items + Cross_file_items_store.of_reactive + merged.Reactive_merge.cross_file_items in (* Compute optional args state using reactive liveness check. Uses ReactiveSolver.is_pos_live which checks the reactive live collection instead of mutable resolvedDead field. *) - let is_live pos = ReactiveSolver.is_pos_live ~t:solver pos in + let is_live pos = Reactive_solver.is_pos_live ~t:solver pos in let find_decl pos = - Reactive.get merged.ReactiveMerge.decls pos + Reactive.get merged.Reactive_merge.decls pos in let optional_args_state = - CrossFileItemsStore.compute_optional_args_state + Cross_file_items_store.compute_optional_args_state cross_file_store ~find_decl ~is_live in (* Iterate live declarations and check for optional args issues *) let issues = ref [] in - ReactiveSolver.iter_live_decls ~t:solver (fun decl -> + Reactive_solver.iter_live_decls ~t:solver (fun decl -> let decl_issues = - DeadOptionalArgs.check ~optional_args_state ~ann_store + Dead_optional_args.check ~optional_args_state ~ann_store ~config:dce_config decl in issues := List.rev_append decl_issues !issues); @@ -359,7 +360,7 @@ let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge in let t2 = Unix.gettimeofday () in let all_issues = dead_code_issues @ optional_args_issues in - let num_dead, num_live = ReactiveSolver.stats ~t:solver in + let num_dead, num_live = Reactive_solver.stats ~t:solver in if !Cli.timing then ( Printf.eprintf " ReactiveSolver: dead_code=%.3fms opt_args=%.3fms (dead=%d, \ @@ -368,42 +369,43 @@ let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge ((t2 -. t1) *. 1000.0) num_dead num_live (List.length all_issues); (match reactive_liveness with - | Some liveness -> ReactiveLiveness.print_stats ~t:liveness + | Some liveness -> Reactive_liveness.print_stats ~t:liveness | None -> ()); - ReactiveSolver.print_stats ~t:solver; + Reactive_solver.print_stats ~t:solver; (* Print full reactive node stats, including Top-N by time. *) Reactive.print_stats ()); if !Cli.mermaid then Printf.eprintf "\n%s\n" (Reactive.to_mermaid ()); - Some (AnalysisResult.add_issues AnalysisResult.empty all_issues) + Some (Analysis_result.add_issues Analysis_result.empty all_issues) | None -> (* Non-reactive path: use old solver with optional args *) - let empty_optional_args_state = OptionalArgsState.create () in + let empty_optional_args_state = Optional_args_state.create () in let analysis_result_core = - DeadCommon.solveDead ~ann_store ~decl_store ~ref_store + Dead_common.solve_dead ~ann_store ~decl_store ~ref_store ~optional_args_state:empty_optional_args_state ~config:dce_config - ~checkOptionalArg:(fun + ~check_optional_arg:(fun ~optional_args_state:_ ~ann_store:_ ~config:_ _ -> []) in (* Compute liveness-aware optional args state *) let is_live pos = - match DeclarationStore.find_opt decl_store pos with - | Some decl -> Decl.isLive decl + match Declaration_store.find_opt decl_store pos with + | Some decl -> Decl.is_live decl | None -> true in let optional_args_state = - CrossFileItemsStore.compute_optional_args_state cross_file_store - ~find_decl:(DeclarationStore.find_opt decl_store) + Cross_file_items_store.compute_optional_args_state + cross_file_store + ~find_decl:(Declaration_store.find_opt decl_store) ~is_live in (* Collect optional args issues only for live declarations *) let optional_args_issues = - DeclarationStore.fold + Declaration_store.fold (fun _pos decl acc -> - if Decl.isLive decl then + if Decl.is_live decl then let issues = - DeadOptionalArgs.check ~optional_args_state ~ann_store + Dead_optional_args.check ~optional_args_state ~ann_store ~config:dce_config decl in List.rev_append issues acc @@ -412,7 +414,7 @@ let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge |> List.rev in Some - (AnalysisResult.add_issues analysis_result_core + (Analysis_result.add_issues analysis_result_core optional_args_issues)) else None in @@ -420,27 +422,28 @@ let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge Timing.time_phase `Reporting (fun () -> (match analysis_result with | Some result -> - AnalysisResult.get_issues result + Analysis_result.get_issues result |> List.iter (fun (issue : Issue.t) -> Log_.warning ~loc:issue.loc issue.description) | None -> ()); - if dce_config.DceConfig.run.exception_ then - Exception.runChecks ~config:dce_config exception_results; - if dce_config.DceConfig.run.termination && dce_config.DceConfig.cli.debug - then Arnold.reportStats ~config:dce_config) + if dce_config.Dce_config.run.exception_ then + Exception.run_checks ~config:dce_config exception_results; + if + dce_config.Dce_config.run.termination && dce_config.Dce_config.cli.debug + then Arnold.report_stats ~config:dce_config) -let runAnalysisAndReport ~cmtRoot = +let run_analysis_and_report ~cmt_root = Log_.Color.setup (); Timing.enabled := !Cli.timing; (* Reactive scheduler debug output: keep surface area minimal by reusing -timing. (-debug is already very verbose for DCE per-decl logging.) *) Reactive.set_debug !Cli.timing; - if !Cli.json then EmitJson.start (); - let dce_config = DceConfig.current () in - let numRuns = max 1 !Cli.runs in + if !Cli.json then Emit_json.start (); + let dce_config = Dce_config.current () in + let num_runs = max 1 !Cli.runs in (* Create reactive collection once, reuse across runs *) let reactive_collection = - if !Cli.reactive then Some (ReactiveAnalysis.create ~config:dce_config) + if !Cli.reactive then Some (Reactive_analysis.create ~config:dce_config) else None in (* Create reactive merge once if reactive mode is enabled. @@ -449,16 +452,16 @@ let runAnalysisAndReport ~cmtRoot = match reactive_collection with | Some collection -> let file_data_collection = - ReactiveAnalysis.to_file_data_collection collection + Reactive_analysis.to_file_data_collection collection in - Some (ReactiveMerge.create file_data_collection) + Some (Reactive_merge.create file_data_collection) | None -> None in (* Create reactive liveness. This is created before files are processed, so it receives deltas as files are processed incrementally. *) let reactive_liveness = match reactive_merge with - | Some merged -> Some (ReactiveLiveness.create ~merged) + | Some merged -> Some (Reactive_liveness.create ~merged) | None -> None in (* Create reactive solver once - sets up the reactive pipeline: @@ -469,19 +472,19 @@ let runAnalysisAndReport ~cmtRoot = | Some merged, Some liveness_result -> (* Pass value_refs_from for hasRefBelow (needed when transitive=false) *) let value_refs_from = - if dce_config.DceConfig.run.transitive then None - else Some merged.ReactiveMerge.value_refs_from + if dce_config.Dce_config.run.transitive then None + else Some merged.Reactive_merge.value_refs_from in Some - (ReactiveSolver.create ~decls:merged.ReactiveMerge.decls - ~live:liveness_result.ReactiveLiveness.live - ~annotations:merged.ReactiveMerge.annotations ~value_refs_from + (Reactive_solver.create ~decls:merged.Reactive_merge.decls + ~live:liveness_result.Reactive_liveness.live + ~annotations:merged.Reactive_merge.annotations ~value_refs_from ~config:dce_config) | _ -> None in (* Collect CMT file paths once for churning *) - let cmtFilePaths = - if !Cli.churn > 0 then Some (collectCmtFilePaths ~cmtRoot) else None + let cmt_file_paths = + if !Cli.churn > 0 then Some (collect_cmt_file_paths ~cmt_root) else None in (* Track previous issue count for diff reporting *) let prev_issue_count = ref 0 in @@ -493,16 +496,16 @@ let runAnalysisAndReport ~cmtRoot = let churn_times = ref [] in let issues_added_list = ref [] in let issues_removed_list = ref [] in - for run = 1 to numRuns do + for run = 1 to num_runs do Timing.reset (); (* Clear stats at start of each run to avoid accumulation *) if run > 1 then Log_.Stats.clear (); (* Print run header first *) - if numRuns > 1 && !Cli.timing then - Printf.eprintf "\n=== Run %d/%d ===\n%!" run numRuns; + if num_runs > 1 && !Cli.timing then + Printf.eprintf "\n=== Run %d/%d ===\n%!" run num_runs; (* Churn: alternate between remove and add phases *) (if !Cli.churn > 0 then - match (reactive_collection, cmtFilePaths) with + match (reactive_collection, cmt_file_paths) with | Some collection, Some paths -> Reactive.reset_stats (); if run > 1 && !removed_files <> [] then ( @@ -513,10 +516,10 @@ let runAnalysisAndReport ~cmtRoot = List.iter (fun p -> Hashtbl.remove removed_set p) to_add; let t0 = Unix.gettimeofday () in let processed = - ReactiveFileCollection.process_files_batch + Reactive_file_collection.process_files_batch (collection - : ReactiveAnalysis.t - :> (_, _) ReactiveFileCollection.t) + : Reactive_analysis.t + :> (_, _) Reactive_file_collection.t) to_add in let elapsed = Unix.gettimeofday () -. t0 in @@ -526,25 +529,25 @@ let runAnalysisAndReport ~cmtRoot = Printf.eprintf " Added back %d files (%.3fs)\n%!" processed elapsed; (match reactive_liveness with - | Some liveness -> ReactiveLiveness.print_stats ~t:liveness + | Some liveness -> Reactive_liveness.print_stats ~t:liveness | None -> ()); match reactive_solver with - | Some solver -> ReactiveSolver.print_stats ~t:solver + | Some solver -> Reactive_solver.print_stats ~t:solver | None -> ())) else if run > 1 then ( (* Remove new random files *) - let numChurn = min !Cli.churn (List.length paths) in + let num_churn = min !Cli.churn (List.length paths) in let shuffled = shuffle_list paths in - let to_remove = List.filteri (fun i _ -> i < numChurn) shuffled in + let to_remove = List.filteri (fun i _ -> i < num_churn) shuffled in removed_files := to_remove; (* Mark as removed so processCmtFiles skips them *) List.iter (fun p -> Hashtbl.replace removed_set p ()) to_remove; let t0 = Unix.gettimeofday () in let removed = - ReactiveFileCollection.remove_batch + Reactive_file_collection.remove_batch (collection - : ReactiveAnalysis.t - :> (_, _) ReactiveFileCollection.t) + : Reactive_analysis.t + :> (_, _) Reactive_file_collection.t) to_remove in let elapsed = Unix.gettimeofday () -. t0 in @@ -553,10 +556,10 @@ let runAnalysisAndReport ~cmtRoot = if !Cli.timing then ( Printf.eprintf " Removed %d files (%.3fs)\n%!" removed elapsed; (match reactive_liveness with - | Some liveness -> ReactiveLiveness.print_stats ~t:liveness + | Some liveness -> Reactive_liveness.print_stats ~t:liveness | None -> ()); match reactive_solver with - | Some solver -> ReactiveSolver.print_stats ~t:solver + | Some solver -> Reactive_solver.print_stats ~t:solver | None -> ())) | _ -> ()); (* Skip removed files in reactive mode *) @@ -565,7 +568,7 @@ let runAnalysisAndReport ~cmtRoot = Some (fun path -> Hashtbl.mem removed_set path) else None in - runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge + run_analysis ~dce_config ~cmt_root ~reactive_collection ~reactive_merge ~reactive_liveness ~reactive_solver ~skip_file (); (* Report issue count with diff *) let current_count = Log_.Stats.get_issue_count () in @@ -586,7 +589,7 @@ let runAnalysisAndReport ~cmtRoot = if !Cli.timing then Printf.eprintf " Total issues: %d%s\n%!" current_count diff_str; prev_issue_count := current_count) - else if run = numRuns then + else if run = num_runs then (* Only report on last run for non-churn mode *) Log_.Stats.report ~config:dce_config; Log_.Stats.clear (); @@ -614,47 +617,47 @@ let runAnalysisAndReport ~cmtRoot = Printf.eprintf " Issues added: mean=%.0f std=%.0f\n" added_mean added_std; Printf.eprintf " Issues removed: mean=%.0f std=%.0f\n" removed_mean removed_std); - if !Cli.json then EmitJson.finish () + if !Cli.json then Emit_json.finish () let parse_argv (argv : string array) : string option = - let analysisKindSet = ref false in - let cmtRootRef = ref None in + let analysis_kind_set = ref false in + let cmt_root_ref = ref None in (* CLI override for transitive mode (overrides rescript.json if provided). *) let transitive_override : bool option ref = ref None in let usage = "reanalyze version " ^ Version.version in - let versionAndExit () = + let version_and_exit () = print_endline usage; exit 0 [@@raises exit] in - let rec setAll cmtRoot = - RunConfig.all (); - cmtRootRef := cmtRoot; - analysisKindSet := true - and setConfig () = - Paths.Config.processConfig (); - analysisKindSet := true - and setDCE cmtRoot = - RunConfig.dce (); - cmtRootRef := cmtRoot; - analysisKindSet := true - and setException cmtRoot = - RunConfig.exception_ (); - cmtRootRef := cmtRoot; - analysisKindSet := true - and setTermination cmtRoot = - RunConfig.termination (); - cmtRootRef := cmtRoot; - analysisKindSet := true + let rec set_all cmt_root = + Run_config.all (); + cmt_root_ref := cmt_root; + analysis_kind_set := true + and set_config () = + Paths.Config.process_config (); + analysis_kind_set := true + and set_d_c_e cmt_root = + Run_config.dce (); + cmt_root_ref := cmt_root; + analysis_kind_set := true + and set_exception cmt_root = + Run_config.exception_ (); + cmt_root_ref := cmt_root; + analysis_kind_set := true + and set_termination cmt_root = + Run_config.termination (); + cmt_root_ref := cmt_root; + analysis_kind_set := true and speclist = [ - ("-all", Arg.Unit (fun () -> setAll None), "Run all the analyses."); + ("-all", Arg.Unit (fun () -> set_all None), "Run all the analyses."); ( "-all-cmt", - String (fun s -> setAll (Some s)), + String (fun s -> set_all (Some s)), "root_path Run all the analyses for all the .cmt files under the root \ path" ); ("-ci", Unit (fun () -> Cli.ci := true), "Internal flag for use in CI"); - ("-config", Unit setConfig, "Read the analysis mode from rescript.json"); + ("-config", Unit set_config, "Read the analysis mode from rescript.json"); ( "-transitive", Unit (fun () -> transitive_override := Some true), "Force transitive reporting (overrides rescript.json \ @@ -663,71 +666,71 @@ let parse_argv (argv : string array) : string option = Unit (fun () -> transitive_override := Some false), "Disable transitive reporting (overrides rescript.json \ reanalyze.transitive)" ); - ("-dce", Unit (fun () -> setDCE None), "Eperimental DCE"); + ("-dce", Unit (fun () -> set_d_c_e None), "Eperimental DCE"); ("-debug", Unit (fun () -> Cli.debug := true), "Print debug information"); ( "-dce-cmt", - String (fun s -> setDCE (Some s)), + String (fun s -> set_d_c_e (Some s)), "root_path Experimental DCE for all the .cmt files under the root path" ); ( "-exception", - Unit (fun () -> setException None), + Unit (fun () -> set_exception None), "Experimental exception analysis" ); ( "-exception-cmt", - String (fun s -> setException (Some s)), + String (fun s -> set_exception (Some s)), "root_path Experimental exception analysis for all the .cmt files \ under the root path" ); ( "-exclude-paths", String (fun s -> let paths = s |> String.split_on_char ',' in - Cli.excludePaths := paths @ Cli.excludePaths.contents), + Cli.exclude_paths := paths @ Cli.exclude_paths.contents), "comma-separated-path-prefixes Exclude from analysis files whose path \ has a prefix in the list" ); ( "-experimental", Set Cli.experimental, "Turn on experimental analyses (this option is currently unused)" ); ( "-externals", - Set DeadCommon.Config.analyzeExternals, + Set Dead_common.Config.analyze_externals, "Report on externals in dead code analysis" ); ("-json", Set Cli.json, "Print reports in json format"); ( "-live-names", String (fun s -> let names = s |> String.split_on_char ',' in - Cli.liveNames := names @ Cli.liveNames.contents), + Cli.live_names := names @ Cli.live_names.contents), "comma-separated-names Consider all values with the given names as live" ); ( "-live-paths", String (fun s -> let paths = s |> String.split_on_char ',' in - Cli.livePaths := paths @ Cli.livePaths.contents), + Cli.live_paths := paths @ Cli.live_paths.contents), "comma-separated-path-prefixes Consider all values whose path has a \ prefix in the list as live" ); ( "-suppress", String (fun s -> let names = s |> String.split_on_char ',' in - runConfig.suppress <- names @ runConfig.suppress), + run_config.suppress <- names @ run_config.suppress), "comma-separated-path-prefixes Don't report on files whose path has a \ prefix in the list" ); ( "-termination", - Unit (fun () -> setTermination None), + Unit (fun () -> set_termination None), "Experimental termination analysis" ); ( "-termination-cmt", - String (fun s -> setTermination (Some s)), + String (fun s -> set_termination (Some s)), "root_path Experimental termination analysis for all the .cmt files \ under the root path" ); ( "-unsuppress", String (fun s -> let names = s |> String.split_on_char ',' in - runConfig.unsuppress <- names @ runConfig.unsuppress), + run_config.unsuppress <- names @ run_config.unsuppress), "comma-separated-path-prefixes Report on files whose path has a prefix \ in the list, overriding -suppress (no-op if -suppress is not \ specified)" ); ( "-test-shuffle", - Set Cli.testShuffle, + Set Cli.test_shuffle, "Test flag: shuffle file processing order to verify order-independence" ); ("-timing", Set Cli.timing, "Report internal timing of analysis phases"); @@ -745,17 +748,17 @@ let parse_argv (argv : string array) : string option = Int (fun n -> Cli.churn := n), "n Remove and re-add n random files between runs (tests incremental \ correctness)" ); - ("-version", Unit versionAndExit, "Show version information and exit"); - ("--version", Unit versionAndExit, "Show version information and exit"); + ("-version", Unit version_and_exit, "Show version information and exit"); + ("--version", Unit version_and_exit, "Show version information and exit"); ] in let current = ref 0 in Arg.parse_argv ~current argv speclist print_endline usage; - if !analysisKindSet = false then setConfig (); + if !analysis_kind_set = false then set_config (); (match !transitive_override with | None -> () - | Some b -> RunConfig.transitive b); - !cmtRootRef + | Some b -> Run_config.transitive b); + !cmt_root_ref (** Default socket location invariant: - the socket lives in the project root @@ -764,16 +767,16 @@ let parse_argv (argv : string array) : string option = Project root detection reuses the same logic as reanalyze config discovery: walk up from a directory until we find rescript.json. *) let cli () = - let cmtRoot = parse_argv Sys.argv in - runAnalysisAndReport ~cmtRoot + let cmt_root = parse_argv Sys.argv in + run_analysis_and_report ~cmt_root [@@raises exit] (* Re-export server module for external callers (e.g. tools/bin/main.ml). This keeps the wrapped-library layering intact: Reanalyze depends on internal modules, not the other way around. *) -module ReanalyzeServer = ReanalyzeServer +module Reanalyze_server = Reanalyze_server -module RunConfig = RunConfig -module DceConfig = DceConfig +module Run_config = Run_config +module Dce_config = Dce_config module Log_ = Log_ -module YojsonHelpers = YojsonHelpers +module Yojson_helpers = Yojson_helpers diff --git a/analysis/reanalyze/src/ReanalyzeServer.ml b/analysis/reanalyze/src/reanalyze_server.ml similarity index 82% rename from analysis/reanalyze/src/ReanalyzeServer.ml rename to analysis/reanalyze/src/reanalyze_server.ml index 09ceb3f5ec5..5e17554ca61 100644 --- a/analysis/reanalyze/src/ReanalyzeServer.ml +++ b/analysis/reanalyze/src/reanalyze_server.ml @@ -10,7 +10,7 @@ let default_socket_filename = ".rescript-reanalyze.sock" let project_root_from_dir (dir : string) : string option = - try Some (Paths.findProjectRoot ~dir) with _ -> None + try Some (Paths.find_project_root ~dir) with _ -> None let with_cwd_dir (cwd : string) (f : unit -> 'a) : 'a = let old = Sys.getcwd () in @@ -27,7 +27,7 @@ let default_socket_for_dir_exn (dir : string) : string * string = | None -> (* Match reanalyze behavior: it cannot run outside a project root. *) Printf.eprintf "Error: cannot find project root containing %s.\n%!" - Paths.rescriptJson; + Paths.rescript_json; exit 2 let default_socket_for_current_project_exn () : string * string = @@ -97,31 +97,31 @@ module Server = struct mb_of_words s.live_words type reactive_pipeline = { - dce_config: DceConfig.t; - reactive_collection: ReactiveAnalysis.t; - reactive_merge: ReactiveMerge.t; - reactive_liveness: ReactiveLiveness.t; - reactive_solver: ReactiveSolver.t; + dce_config: Dce_config.t; + reactive_collection: Reactive_analysis.t; + reactive_merge: Reactive_merge.t; + reactive_liveness: Reactive_liveness.t; + reactive_solver: Reactive_solver.t; } type server_state = { parse_argv: string array -> string option; run_analysis: - dce_config:DceConfig.t -> - cmtRoot:string option -> - reactive_collection:ReactiveAnalysis.t option -> - reactive_merge:ReactiveMerge.t option -> - reactive_liveness:ReactiveLiveness.t option -> - reactive_solver:ReactiveSolver.t option -> + dce_config:Dce_config.t -> + cmt_root:string option -> + reactive_collection:Reactive_analysis.t option -> + reactive_merge:Reactive_merge.t option -> + reactive_liveness:Reactive_liveness.t option -> + reactive_solver:Reactive_solver.t option -> skip_file:(string -> bool) option -> - ?file_stats:ReactiveAnalysis.processing_stats -> + ?file_stats:Reactive_analysis.processing_stats -> unit -> unit; config: server_config; - cmtRoot: string option; + cmt_root: string option; mutable pipeline: reactive_pipeline; stats: server_stats; - mutable config_snapshot: RunConfig.snapshot; + mutable config_snapshot: Run_config.snapshot; } type request_info = { @@ -267,21 +267,21 @@ Examples: run let create_reactive_pipeline () : reactive_pipeline = - let dce_config = DceConfig.current () in - let reactive_collection = ReactiveAnalysis.create ~config:dce_config in + let dce_config = Dce_config.current () in + let reactive_collection = Reactive_analysis.create ~config:dce_config in let file_data_collection = - ReactiveAnalysis.to_file_data_collection reactive_collection + Reactive_analysis.to_file_data_collection reactive_collection in - let reactive_merge = ReactiveMerge.create file_data_collection in - let reactive_liveness = ReactiveLiveness.create ~merged:reactive_merge in + let reactive_merge = Reactive_merge.create file_data_collection in + let reactive_liveness = Reactive_liveness.create ~merged:reactive_merge in let value_refs_from = - if dce_config.DceConfig.run.transitive then None - else Some reactive_merge.ReactiveMerge.value_refs_from + if dce_config.Dce_config.run.transitive then None + else Some reactive_merge.Reactive_merge.value_refs_from in let reactive_solver = - ReactiveSolver.create ~decls:reactive_merge.ReactiveMerge.decls - ~live:reactive_liveness.ReactiveLiveness.live - ~annotations:reactive_merge.ReactiveMerge.annotations ~value_refs_from + Reactive_solver.create ~decls:reactive_merge.Reactive_merge.decls + ~live:reactive_liveness.Reactive_liveness.live + ~annotations:reactive_merge.Reactive_merge.annotations ~value_refs_from ~config:dce_config in { @@ -294,20 +294,20 @@ Examples: let init_state ~(parse_argv : string array -> string option) ~(run_analysis : - dce_config:DceConfig.t -> - cmtRoot:string option -> - reactive_collection:ReactiveAnalysis.t option -> - reactive_merge:ReactiveMerge.t option -> - reactive_liveness:ReactiveLiveness.t option -> - reactive_solver:ReactiveSolver.t option -> + dce_config:Dce_config.t -> + cmt_root:string option -> + reactive_collection:Reactive_analysis.t option -> + reactive_merge:Reactive_merge.t option -> + reactive_liveness:Reactive_liveness.t option -> + reactive_solver:Reactive_solver.t option -> skip_file:(string -> bool) option -> - ?file_stats:ReactiveAnalysis.processing_stats -> + ?file_stats:Reactive_analysis.processing_stats -> unit -> unit) (config : server_config) : (server_state, string) result = Printexc.record_backtrace true; with_cwd config.cwd (fun () -> (* Editor mode only: the server always behaves like `reanalyze -json`. *) - let cmtRoot = parse_argv [|"reanalyze"; "-json"|] in + let cmt_root = parse_argv [|"reanalyze"; "-json"|] in (* Force reactive mode in server. *) Cli.reactive := true; (* Keep server requests single-run and deterministic. *) @@ -328,10 +328,10 @@ Examples: parse_argv; run_analysis; config; - cmtRoot; + cmt_root; pipeline; stats = {request_count = 0}; - config_snapshot = RunConfig.snapshot (); + config_snapshot = Run_config.snapshot (); }) let run_one_request (state : server_state) (_req : request) : @@ -347,7 +347,7 @@ Examples: let issue_count = ref 0 in let dead_count = ref 0 in let live_count = ref 0 in - let file_stats : ReactiveAnalysis.processing_stats = + let file_stats : Reactive_analysis.processing_stats = {total_files = 0; processed = 0; from_cache = 0} in let resp = @@ -357,12 +357,12 @@ Examples: capture_stdout_stderr (fun () -> (* Re-read config from rescript.json to detect changes. If changed, recreate the entire reactive pipeline from scratch. *) - RunConfig.reset (); - Paths.Config.processConfig (); - let new_snapshot = RunConfig.snapshot () in + Run_config.reset (); + Paths.Config.process_config (); + let new_snapshot = Run_config.snapshot () in if not - (RunConfig.equal_snapshot state.config_snapshot new_snapshot) + (Run_config.equal_snapshot state.config_snapshot new_snapshot) then ( state.pipeline <- create_reactive_pipeline (); state.config_snapshot <- new_snapshot); @@ -375,21 +375,22 @@ Examples: Cli.json := true; (* Match direct CLI output (a leading newline before the JSON array). *) Printf.printf "\n"; - EmitJson.start (); + Emit_json.start (); let p = state.pipeline in - state.run_analysis ~dce_config:p.dce_config ~cmtRoot:state.cmtRoot + state.run_analysis ~dce_config:p.dce_config + ~cmt_root:state.cmt_root ~reactive_collection:(Some p.reactive_collection) ~reactive_merge:(Some p.reactive_merge) ~reactive_liveness:(Some p.reactive_liveness) ~reactive_solver:(Some p.reactive_solver) ~skip_file:None ~file_stats (); issue_count := Log_.Stats.get_issue_count (); - let d, l = ReactiveSolver.stats ~t:p.reactive_solver in + let d, l = Reactive_solver.stats ~t:p.reactive_solver in dead_count := d; live_count := l; Log_.Stats.report ~config:p.dce_config; Log_.Stats.clear (); - EmitJson.finish ()) + Emit_json.finish ()) |> response_of_result) in let t_end = Unix.gettimeofday () in @@ -452,14 +453,14 @@ Examples: let cli ~(parse_argv : string array -> string option) ~(run_analysis : - dce_config:DceConfig.t -> - cmtRoot:string option -> - reactive_collection:ReactiveAnalysis.t option -> - reactive_merge:ReactiveMerge.t option -> - reactive_liveness:ReactiveLiveness.t option -> - reactive_solver:ReactiveSolver.t option -> + dce_config:Dce_config.t -> + cmt_root:string option -> + reactive_collection:Reactive_analysis.t option -> + reactive_merge:Reactive_merge.t option -> + reactive_liveness:Reactive_liveness.t option -> + reactive_solver:Reactive_solver.t option -> skip_file:(string -> bool) option -> - ?file_stats:ReactiveAnalysis.processing_stats -> + ?file_stats:Reactive_analysis.processing_stats -> unit -> unit) () = match parse_cli_args () with @@ -478,14 +479,14 @@ end let server_cli ~(parse_argv : string array -> string option) ~(run_analysis : - dce_config:DceConfig.t -> - cmtRoot:string option -> - reactive_collection:ReactiveAnalysis.t option -> - reactive_merge:ReactiveMerge.t option -> - reactive_liveness:ReactiveLiveness.t option -> - reactive_solver:ReactiveSolver.t option -> + dce_config:Dce_config.t -> + cmt_root:string option -> + reactive_collection:Reactive_analysis.t option -> + reactive_merge:Reactive_merge.t option -> + reactive_liveness:Reactive_liveness.t option -> + reactive_solver:Reactive_solver.t option -> skip_file:(string -> bool) option -> - ?file_stats:ReactiveAnalysis.processing_stats -> + ?file_stats:Reactive_analysis.processing_stats -> unit -> unit) () = Server.cli ~parse_argv ~run_analysis () diff --git a/analysis/reanalyze/src/ReferenceStore.ml b/analysis/reanalyze/src/reference_store.ml similarity index 67% rename from analysis/reanalyze/src/ReferenceStore.ml rename to analysis/reanalyze/src/reference_store.ml index 86b6d4afffc..f8a185c8bd8 100644 --- a/analysis/reanalyze/src/ReferenceStore.ml +++ b/analysis/reanalyze/src/reference_store.ml @@ -10,12 +10,12 @@ type t = | Frozen of References.t | Reactive of { (* Per-file refs_from *) - value_refs_from: (Lexing.position, PosSet.t) Reactive.t; - type_refs_from: (Lexing.position, PosSet.t) Reactive.t; + value_refs_from: (Lexing.position, Pos_set.t) Reactive.t; + type_refs_from: (Lexing.position, Pos_set.t) Reactive.t; (* Type deps refs_from *) - all_type_refs_from: (Lexing.position, PosSet.t) Reactive.t; + all_type_refs_from: (Lexing.position, Pos_set.t) Reactive.t; (* Exception refs_from *) - exception_value_refs_from: (Lexing.position, PosSet.t) Reactive.t; + exception_value_refs_from: (Lexing.position, Pos_set.t) Reactive.t; } let of_frozen refs = Frozen refs @@ -25,9 +25,9 @@ let of_reactive ~value_refs_from ~type_refs_from ~type_deps ~exception_refs = { value_refs_from; type_refs_from; - all_type_refs_from = type_deps.ReactiveTypeDeps.all_type_refs_from; + all_type_refs_from = type_deps.Reactive_type_deps.all_type_refs_from; exception_value_refs_from = - exception_refs.ReactiveExceptionRefs.resolved_refs_from; + exception_refs.Reactive_exception_refs.resolved_refs_from; } (** Get underlying References.t for Frozen stores. Used for forward liveness. *) diff --git a/analysis/reanalyze/src/ReferenceStore.mli b/analysis/reanalyze/src/reference_store.mli similarity index 75% rename from analysis/reanalyze/src/ReferenceStore.mli rename to analysis/reanalyze/src/reference_store.mli index cfc266fad35..c102e6fc6f9 100644 --- a/analysis/reanalyze/src/ReferenceStore.mli +++ b/analysis/reanalyze/src/reference_store.mli @@ -13,10 +13,10 @@ val of_frozen : References.t -> t (** Wrap a frozen [References.t] *) val of_reactive : - value_refs_from:(Lexing.position, PosSet.t) Reactive.t -> - type_refs_from:(Lexing.position, PosSet.t) Reactive.t -> - type_deps:ReactiveTypeDeps.t -> - exception_refs:ReactiveExceptionRefs.t -> + value_refs_from:(Lexing.position, Pos_set.t) Reactive.t -> + type_refs_from:(Lexing.position, Pos_set.t) Reactive.t -> + type_deps:Reactive_type_deps.t -> + exception_refs:Reactive_exception_refs.t -> t (** Wrap reactive collections directly (no copy) *) diff --git a/analysis/reanalyze/src/References.ml b/analysis/reanalyze/src/references.ml similarity index 62% rename from analysis/reanalyze/src/References.ml rename to analysis/reanalyze/src/references.ml index fd324ed4342..8b917dce9e0 100644 --- a/analysis/reanalyze/src/References.ml +++ b/analysis/reanalyze/src/references.ml @@ -10,12 +10,12 @@ This is what the forward liveness algorithm needs. *) (* Helper to add to a set in a hashtable *) -let addSet h k v = - let set = try PosHash.find h k with Not_found -> PosSet.empty in - PosHash.replace h k (PosSet.add v set) +let add_set h k v = + let set = try Pos_hash.find h k with Not_found -> Pos_set.empty in + Pos_hash.replace h k (Pos_set.add v set) (* Internal representation: two hashtables (refs_from for value and type) *) -type refs_table = PosSet.t PosHash.t +type refs_table = Pos_set.t Pos_hash.t type builder = {value_refs_from: refs_table; type_refs_from: refs_table} @@ -24,22 +24,24 @@ type t = {value_refs_from: refs_table; type_refs_from: refs_table} (* ===== Builder API ===== *) let create_builder () : builder = - {value_refs_from = PosHash.create 256; type_refs_from = PosHash.create 256} + {value_refs_from = Pos_hash.create 256; type_refs_from = Pos_hash.create 256} -let add_value_ref (builder : builder) ~posTo ~posFrom = - addSet builder.value_refs_from posFrom posTo +let add_value_ref (builder : builder) ~pos_to ~pos_from = + add_set builder.value_refs_from pos_from pos_to -let add_type_ref (builder : builder) ~posTo ~posFrom = - addSet builder.type_refs_from posFrom posTo +let add_type_ref (builder : builder) ~pos_to ~pos_from = + add_set builder.type_refs_from pos_from pos_to let merge_into_builder ~(from : builder) ~(into : builder) = - PosHash.iter + Pos_hash.iter (fun pos refs -> - refs |> PosSet.iter (fun toPos -> addSet into.value_refs_from pos toPos)) + refs + |> Pos_set.iter (fun to_pos -> add_set into.value_refs_from pos to_pos)) from.value_refs_from; - PosHash.iter + Pos_hash.iter (fun pos refs -> - refs |> PosSet.iter (fun toPos -> addSet into.type_refs_from pos toPos)) + refs + |> Pos_set.iter (fun to_pos -> add_set into.type_refs_from pos to_pos)) from.type_refs_from let merge_all (builders : builder list) : t = @@ -61,14 +63,14 @@ let freeze_builder (builder : builder) : t = (* ===== Builder extraction for reactive merge ===== *) let builder_value_refs_from_list (builder : builder) : - (Lexing.position * PosSet.t) list = - PosHash.fold + (Lexing.position * Pos_set.t) list = + Pos_hash.fold (fun pos refs acc -> (pos, refs) :: acc) builder.value_refs_from [] let builder_type_refs_from_list (builder : builder) : - (Lexing.position * PosSet.t) list = - PosHash.fold + (Lexing.position * Pos_set.t) list = + Pos_hash.fold (fun pos refs acc -> (pos, refs) :: acc) builder.type_refs_from [] @@ -77,8 +79,8 @@ let create ~value_refs_from ~type_refs_from : t = (* ===== Read-only API ===== *) -let iter_value_refs_from (t : t) f = PosHash.iter f t.value_refs_from -let iter_type_refs_from (t : t) f = PosHash.iter f t.type_refs_from +let iter_value_refs_from (t : t) f = Pos_hash.iter f t.value_refs_from +let iter_type_refs_from (t : t) f = Pos_hash.iter f t.type_refs_from -let value_refs_from_length (t : t) = PosHash.length t.value_refs_from -let type_refs_from_length (t : t) = PosHash.length t.type_refs_from +let value_refs_from_length (t : t) = Pos_hash.length t.value_refs_from +let type_refs_from_length (t : t) = Pos_hash.length t.type_refs_from diff --git a/analysis/reanalyze/src/References.mli b/analysis/reanalyze/src/references.mli similarity index 79% rename from analysis/reanalyze/src/References.mli rename to analysis/reanalyze/src/references.mli index 84939aa2f1e..d4b9ef9b762 100644 --- a/analysis/reanalyze/src/References.mli +++ b/analysis/reanalyze/src/references.mli @@ -22,11 +22,11 @@ type builder val create_builder : unit -> builder val add_value_ref : - builder -> posTo:Lexing.position -> posFrom:Lexing.position -> unit + builder -> pos_to:Lexing.position -> pos_from:Lexing.position -> unit (** Add a value reference. *) val add_type_ref : - builder -> posTo:Lexing.position -> posFrom:Lexing.position -> unit + builder -> pos_to:Lexing.position -> pos_from:Lexing.position -> unit (** Add a type reference. *) val merge_into_builder : from:builder -> into:builder -> unit @@ -40,22 +40,24 @@ val freeze_builder : builder -> t (** {2 Builder extraction for reactive merge} *) -val builder_value_refs_from_list : builder -> (Lexing.position * PosSet.t) list +val builder_value_refs_from_list : builder -> (Lexing.position * Pos_set.t) list (** Extract value refs (posFrom -> targets) *) -val builder_type_refs_from_list : builder -> (Lexing.position * PosSet.t) list +val builder_type_refs_from_list : builder -> (Lexing.position * Pos_set.t) list (** Extract type refs (posFrom -> targets) *) val create : - value_refs_from:PosSet.t PosHash.t -> type_refs_from:PosSet.t PosHash.t -> t + value_refs_from:Pos_set.t Pos_hash.t -> + type_refs_from:Pos_set.t Pos_hash.t -> + t (** Create a References.t from hashtables *) (** {2 Read-only API - for liveness} *) -val iter_value_refs_from : t -> (Lexing.position -> PosSet.t -> unit) -> unit +val iter_value_refs_from : t -> (Lexing.position -> Pos_set.t -> unit) -> unit (** Iterate all value refs *) -val iter_type_refs_from : t -> (Lexing.position -> PosSet.t -> unit) -> unit +val iter_type_refs_from : t -> (Lexing.position -> Pos_set.t -> unit) -> unit (** Iterate all type refs *) (** {2 Length} *) diff --git a/analysis/reanalyze/src/run_config.ml b/analysis/reanalyze/src/run_config.ml new file mode 100644 index 00000000000..1fe02a6d445 --- /dev/null +++ b/analysis/reanalyze/src/run_config.ml @@ -0,0 +1,62 @@ +type t = { + mutable bsb_project_root: string; + mutable dce: bool; + mutable exception_: bool; + mutable project_root: string; + mutable suppress: string list; + mutable termination: bool; + mutable transitive: bool; + mutable unsuppress: string list; +} + +let run_config = + { + bsb_project_root = ""; + dce = false; + exception_ = false; + project_root = ""; + suppress = []; + termination = false; + transitive = false; + unsuppress = []; + } + +let reset () = + run_config.dce <- false; + run_config.exception_ <- false; + run_config.suppress <- []; + run_config.termination <- false; + run_config.transitive <- false; + run_config.unsuppress <- [] + +let all () = + run_config.dce <- true; + run_config.exception_ <- true; + run_config.termination <- true + +let dce () = run_config.dce <- true +let exception_ () = run_config.exception_ <- true +let termination () = run_config.termination <- true + +let transitive b = run_config.transitive <- b + +type snapshot = { + dce: bool; + exception_: bool; + suppress: string list; + termination: bool; + transitive: bool; + unsuppress: string list; +} + +let snapshot () = + { + dce = run_config.dce; + exception_ = run_config.exception_; + suppress = run_config.suppress; + termination = run_config.termination; + transitive = run_config.transitive; + unsuppress = run_config.unsuppress; + } + +let equal_snapshot (a : snapshot) (b : snapshot) = a = b diff --git a/analysis/reanalyze/src/side_effects.ml b/analysis/reanalyze/src/side_effects.ml new file mode 100644 index 00000000000..421efa07737 --- /dev/null +++ b/analysis/reanalyze/src/side_effects.ml @@ -0,0 +1,89 @@ +let white_list_side_effects = + [ + "Pervasives./."; + "Pervasives.ref"; + "Int64.mul"; + "Int64.neg"; + "Int64.sub"; + "Int64.shift_left"; + "Int64.one"; + "String.length"; + ] + +let white_table_side_effects = + lazy + (let tbl = Hashtbl.create 11 in + white_list_side_effects |> List.iter (fun s -> Hashtbl.add tbl s ()); + tbl) + +let path_is_whitelisted_for_side_effects path = + path + |> Dce_path.on_ok_path ~when_contains_apply:false ~f:(fun s -> + Hashtbl.mem (Lazy.force white_table_side_effects) s) + +let rec expr_no_side_effects (expr : Typedtree.expression) = + match expr.exp_desc with + | Texp_ident _ | Texp_constant _ -> true + | Texp_construct (_, _, el) -> el |> List.for_all expr_no_side_effects + | Texp_function _ -> true + (* Loop control changes whether subsequent code in the enclosing loop runs, + so it should not be treated as a removable pure expression. *) + | Texp_break | Texp_continue -> false + | Texp_apply {funct = {exp_desc = Texp_ident (path, _, _)}; args} + when path |> path_is_whitelisted_for_side_effects -> + args |> List.for_all (fun (_, eo) -> eo |> expr_opt_no_side_effects) + | Texp_apply _ -> false + | Texp_sequence (e1, e2) -> + e1 |> expr_no_side_effects && e2 |> expr_no_side_effects + | Texp_let (_, vbs, e) -> + vbs + |> List.for_all (fun (vb : Typedtree.value_binding) -> + vb.vb_expr |> expr_no_side_effects) + && e |> expr_no_side_effects + | Texp_record {fields; extended_expression} -> + fields |> Array.for_all field_no_side_effects + && extended_expression |> expr_opt_no_side_effects + | Texp_assert _ -> false + | Texp_match (e, cases_ok, cases_exn, partial) -> + let cases = cases_ok @ cases_exn in + partial = Total && e |> expr_no_side_effects + && cases |> List.for_all case_no_side_effects + | Texp_letmodule _ -> false + | Texp_try (e, cases) -> + e |> expr_no_side_effects && cases |> List.for_all case_no_side_effects + | Texp_tuple el -> el |> List.for_all expr_no_side_effects + | Texp_variant (_lbl, eo) -> eo |> expr_opt_no_side_effects + | Texp_field (e, _lid, _ld) -> e |> expr_no_side_effects + | Texp_setfield _ -> false + | Texp_array el -> el |> List.for_all expr_no_side_effects + | Texp_ifthenelse (e1, e2, eo) -> + e1 |> expr_no_side_effects && e2 |> expr_no_side_effects + && eo |> expr_opt_no_side_effects + | Texp_while (e1, e2) -> + e1 |> expr_no_side_effects && e2 |> expr_no_side_effects + | Texp_for (_id, _pat, e1, e2, _dir, e3) -> + e1 |> expr_no_side_effects && e2 |> expr_no_side_effects + && e3 |> expr_no_side_effects + | Texp_for_of _ | Texp_for_await_of _ -> false + | Texp_send _ -> false + | Texp_letexception (_ec, e) -> e |> expr_no_side_effects + | Texp_pack _ -> false + | Texp_extension_constructor _ when true -> true + | _ -> (* on ocaml 4.08: Texp_letop | Texp_open *) true + +and expr_opt_no_side_effects eo = + match eo with + | None -> true + | Some e -> e |> expr_no_side_effects + +and field_no_side_effects + ((_ld, rld, _) : _ * Typedtree.record_label_definition * _) = + match rld with + | Kept _typeExpr -> true + | Overridden (_lid, e) -> e |> expr_no_side_effects + +and case_no_side_effects : Typedtree.case -> _ = + fun {c_guard; c_rhs} -> + c_guard |> expr_opt_no_side_effects && c_rhs |> expr_no_side_effects + +let check_expr e = not (expr_no_side_effects e) diff --git a/analysis/reanalyze/src/StringSet.ml b/analysis/reanalyze/src/string_set.ml similarity index 100% rename from analysis/reanalyze/src/StringSet.ml rename to analysis/reanalyze/src/string_set.ml diff --git a/analysis/reanalyze/src/Suppress.ml b/analysis/reanalyze/src/suppress.ml similarity index 67% rename from analysis/reanalyze/src/Suppress.ml rename to analysis/reanalyze/src/suppress.ml index b40d6af2c73..d9a8c161687 100644 --- a/analysis/reanalyze/src/Suppress.ml +++ b/analysis/reanalyze/src/suppress.ml @@ -1,4 +1,4 @@ -let runConfig = RunConfig.runConfig +let run_config = Run_config.run_config let normalize_separators s = if Sys.win32 then String.map (fun c -> if c = '\\' then '/' else c) s else s @@ -49,43 +49,43 @@ and glob_segment pattern segment = in aux 0 0 -let checkPattern pattern_ = +let check_pattern pattern_ = let is_glob = has_glob_char pattern_ in let pattern = - match runConfig.projectRoot = "" with + match run_config.project_root = "" with | true -> pattern_ - | false -> Filename.concat runConfig.projectRoot pattern_ + | false -> Filename.concat run_config.project_root pattern_ in let pattern = normalize_separators pattern in if is_glob then let pattern_segs = split_on_slash pattern in - fun sourceDir -> - let path_segs = split_on_slash (normalize_separators sourceDir) in + fun source_dir -> + let path_segs = split_on_slash (normalize_separators source_dir) in glob_match pattern_segs path_segs else - let prefixLen = pattern |> String.length in - fun sourceDir -> - let sourceDir = normalize_separators sourceDir in - try String.sub sourceDir 0 prefixLen = pattern + let prefix_len = pattern |> String.length in + fun source_dir -> + let source_dir = normalize_separators source_dir in + try String.sub source_dir 0 prefix_len = pattern with Invalid_argument _ -> false -let suppressSourceDir = +let suppress_source_dir = lazy - (fun sourceDir -> - runConfig.suppress - |> List.exists (fun pattern -> checkPattern pattern sourceDir)) + (fun source_dir -> + run_config.suppress + |> List.exists (fun pattern -> check_pattern pattern source_dir)) -let unsuppressSourceDir = +let unsuppress_source_dir = lazy - (fun sourceDir -> - runConfig.unsuppress - |> List.exists (fun pattern -> checkPattern pattern sourceDir)) + (fun source_dir -> + run_config.unsuppress + |> List.exists (fun pattern -> check_pattern pattern source_dir)) -let posInSuppress (pos : Lexing.position) = - pos.pos_fname |> Lazy.force suppressSourceDir +let pos_in_suppress (pos : Lexing.position) = + pos.pos_fname |> Lazy.force suppress_source_dir -let posInUnsuppress (pos : Lexing.position) = - pos.pos_fname |> Lazy.force unsuppressSourceDir +let pos_in_unsuppress (pos : Lexing.position) = + pos.pos_fname |> Lazy.force unsuppress_source_dir (** First suppress list, then override with unsuppress list *) -let filter pos = (not (posInSuppress pos)) || posInUnsuppress pos +let filter pos = (not (pos_in_suppress pos)) || pos_in_unsuppress pos diff --git a/analysis/reanalyze/src/Timing.ml b/analysis/reanalyze/src/timing.ml similarity index 100% rename from analysis/reanalyze/src/Timing.ml rename to analysis/reanalyze/src/timing.ml diff --git a/analysis/reanalyze/src/Version.ml b/analysis/reanalyze/src/version.ml similarity index 100% rename from analysis/reanalyze/src/Version.ml rename to analysis/reanalyze/src/version.ml diff --git a/analysis/reanalyze/src/YojsonHelpers.ml b/analysis/reanalyze/src/yojson_helpers.ml similarity index 100% rename from analysis/reanalyze/src/YojsonHelpers.ml rename to analysis/reanalyze/src/yojson_helpers.ml diff --git a/analysis/src/Cache.ml b/analysis/src/Cache.ml deleted file mode 100644 index 5e7b3203fc6..00000000000 --- a/analysis/src/Cache.ml +++ /dev/null @@ -1,41 +0,0 @@ -open SharedTypes - -type cached = { - projectFiles: FileSet.t; - dependenciesFiles: FileSet.t; - pathsForModule: (file, paths) Hashtbl.t; -} - -let writeCache filename (data : cached) = - let oc = open_out_bin filename in - Marshal.to_channel oc data []; - close_out oc - -let readCache filename = - if !Cfg.readProjectConfigCache && Sys.file_exists filename then - try - let ic = open_in_bin filename in - let data : cached = Marshal.from_channel ic in - close_in ic; - Some data - with _ -> None - else None - -let deleteCache filename = try Sys.remove filename with _ -> () - -let targetFileFromLibBs libBs = Filename.concat libBs ".project-files-cache" - -let cacheProject (package : package) = - let cached = - { - projectFiles = package.projectFiles; - dependenciesFiles = package.dependenciesFiles; - pathsForModule = package.pathsForModule; - } - in - match BuildSystem.getLibBs package.rootPath with - | None -> print_endline "\"ERR\"" - | Some libBs -> - let targetFile = targetFileFromLibBs libBs in - writeCache targetFile cached; - print_endline "\"OK\"" diff --git a/analysis/src/Cmt.ml b/analysis/src/Cmt.ml deleted file mode 100644 index ac1d5ae595f..00000000000 --- a/analysis/src/Cmt.ml +++ /dev/null @@ -1,67 +0,0 @@ -open SharedTypes - -let fullForCmt ~moduleName ~package ~uri cmt = - match Shared.tryReadCmt cmt with - | None -> None - | Some infos -> - let file = ProcessCmt.fileForCmtInfos ~moduleName ~uri infos in - let extra = ProcessExtra.getExtra ~file ~infos in - Some {file; extra; package} - -let fullFromUri ~uri = - let path = Uri.toPath uri in - match Packages.getPackage ~uri with - | None -> None - | Some package -> ( - let moduleName = - BuildSystem.namespacedName package.namespace (FindFiles.getName path) - in - let incremental = - if !Cfg.inIncrementalTypecheckingMode then - let incrementalCmtPath = - package.rootPath ^ "/lib/bs/___incremental" ^ "/" ^ moduleName - ^ - match Files.classifySourceFile path with - | Resi -> ".cmti" - | _ -> ".cmt" - in - fullForCmt ~moduleName ~package ~uri incrementalCmtPath - else None - in - match incremental with - | Some cmtInfo -> - if Debug.verbose () then Printf.printf "[cmt] Found incremental cmt\n"; - Some cmtInfo - | None -> ( - match Hashtbl.find_opt package.pathsForModule moduleName with - | Some paths -> - let cmt = getCmtPath ~uri paths in - fullForCmt ~moduleName ~package ~uri cmt - | None -> - prerr_endline ("can't find module " ^ moduleName); - None)) - -let fullsFromModule ~package ~moduleName = - if Hashtbl.mem package.pathsForModule moduleName then - let paths = Hashtbl.find package.pathsForModule moduleName in - let uris = getUris paths in - uris |> List.filter_map (fun uri -> fullFromUri ~uri) - else [] - -let loadFullCmtFromPath ~path = - let uri = Uri.fromPath path in - fullFromUri ~uri - -let loadCmtInfosFromPath ~path = - let uri = Uri.fromPath path in - match Packages.getPackage ~uri with - | None -> None - | Some package -> ( - let moduleName = - BuildSystem.namespacedName package.namespace (FindFiles.getName path) - in - match Hashtbl.find_opt package.pathsForModule moduleName with - | Some paths -> - let cmt = getCmtPath ~uri paths in - Shared.tryReadCmt cmt - | None -> None) diff --git a/analysis/src/CodeActions.ml b/analysis/src/CodeActions.ml deleted file mode 100644 index 8f64eaba9a7..00000000000 --- a/analysis/src/CodeActions.ml +++ /dev/null @@ -1,23 +0,0 @@ -(* This is the return that's expected when resolving code actions *) - -let make ~title ~kind ~uri ~newText ~range = - let textDocument = - Lsp.Types.OptionalVersionedTextDocumentIdentifier.create - ~uri:(Uri.fromString uri) () - in - let edit = - Lsp.Types.WorkspaceEdit.create - ~documentChanges: - [ - `TextDocumentEdit - (Lsp.Types.TextDocumentEdit.create - ~edits:[`TextEdit (Lsp.Types.TextEdit.create ~range ~newText)] - ~textDocument); - ] - () - in - Lsp.Types.CodeAction.create ~title ~kind ~edit () - -let makeWithDocumentChanges ~title ~kind ~documentChanges = - let edit = Lsp.Types.WorkspaceEdit.create ~documentChanges () in - Lsp.Types.CodeAction.create ~title ~kind ~edit () diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml deleted file mode 100644 index 78d35a331b3..00000000000 --- a/analysis/src/Commands.ml +++ /dev/null @@ -1,313 +0,0 @@ -let completion ~debug ~source ~kindFile ~pos ~full = - match - Completions.getCompletions ~debug ~source ~kindFile ~pos ~full - ~forHover:false - with - | None -> [] - | Some (completions, full, _) -> - completions |> List.map (CompletionBackEnd.completionToItem ~full) - -let completionResolve ~(full : SharedTypes.full option) ~modulePath = - (* We ignore the internal module path as of now because there's currently - no use case for it. But, if we wanted to move resolving documentation - for regular modules and not just file modules to the completionResolve - hook as well, it'd be easy to implement here. *) - let moduleName, _innerModulePath = - match modulePath |> String.split_on_char '.' with - | [moduleName] -> (moduleName, []) - | moduleName :: rest -> (moduleName, rest) - | [] -> raise (Failure "Invalid module path.") - in - let docstring = - match full with - | None -> - if Debug.verbose () then - Printf.printf "[completion_resolve] Could not load cmt\n"; - None - | Some full -> ( - match ProcessCmt.fileForModule ~package:full.package moduleName with - | None -> - if Debug.verbose () then - Printf.printf "[completion_resolve] Did not find file for module %s\n" - moduleName; - None - | Some file -> Some (file.structure.docstring |> String.concat "\n\n")) - in - match docstring with - | None -> None - | Some value -> - Some - (`MarkupContent - (Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown - ~value)) - -let hover ~source ~kindFile ~pos ~supportsMarkdownLinks ~full ~debug = - let result = - match full with - | None -> None - | Some full -> ( - match References.getLocItem ~full ~pos ~debug with - | None -> ( - if debug then - Printf.printf - "Nothing at that position. Now trying to use completion.\n"; - match - Hover.getHoverViaCompletions ~debug ~source ~kindFile ~pos - ~forHover:true ~supportsMarkdownLinks ~full:(Some full) - with - | None -> None - | Some hover -> Some hover) - | Some locItem -> - let isModule = - match locItem.locType with - | LModule _ | TopLevelModule _ -> true - | TypeDefinition _ | Typed _ | Constant _ -> false - in - let uriLocOpt = References.definitionForLocItem ~full locItem in - let skipZero = - match uriLocOpt with - | None -> false - | Some (_, loc) -> - let isInterface = full.file.uri |> Uri.isInterface in - let posIsZero {Lexing.pos_lnum; pos_bol; pos_cnum} = - (not isInterface) && pos_lnum = 1 && pos_cnum - pos_bol = 0 - in - (* Skip if range is all zero, unless it's a module *) - (not isModule) && posIsZero loc.loc_start && posIsZero loc.loc_end - in - if skipZero then None - else Hover.newHover ~supportsMarkdownLinks ~full locItem) - in - match result with - | None -> None - | Some value -> - Some - (Lsp.Types.Hover.create - ~contents: - (`MarkupContent - (Lsp.Types.MarkupContent.create - ~kind:Lsp.Types.MarkupKind.Markdown ~value)) - ()) - -let signatureHelp ~source ~kindFile ~pos ~allowForConstructorPayloads ~full - ~debug = - SignatureHelp.signatureHelp ~debug ~source ~kindFile ~pos - ~allowForConstructorPayloads ~full - -let definition ~full ~pos ~debug = - let locationOpt = - match full with - | None -> None - | Some full -> ( - match References.getLocItem ~full ~pos ~debug with - | None -> None - | Some locItem -> ( - match References.definitionForLocItem ~full locItem with - | None -> None - | Some (uri, loc) when not loc.loc_ghost -> - let isInterface = full.file.uri |> Uri.isInterface in - let posIsZero {Lexing.pos_lnum; pos_bol; pos_cnum} = - (* range is zero *) - pos_lnum = 1 && pos_cnum - pos_bol = 0 - in - let isModule = - match locItem.locType with - | LModule _ | TopLevelModule _ -> true - | TypeDefinition _ | Typed _ | Constant _ -> false - in - let skipLoc = - (not isModule) && (not isInterface) && posIsZero loc.loc_start - && posIsZero loc.loc_end - in - if skipLoc then None - else - Some - (Lsp.Types.Location.create ~range:(Utils.cmtLocToRange loc) - ~uri:(Files.canonicalizeUri uri |> Uri.fromString)) - | Some _ -> None)) - in - locationOpt - -let typeDefinition ~full ~pos ~debug = - let maybeLocation = - match full with - | None -> None - | Some full -> ( - match References.getLocItem ~full ~pos ~debug with - | None -> None - | Some locItem -> ( - match References.typeDefinitionForLocItem ~full locItem with - | None -> None - | Some (uri, loc) -> - Some - (Lsp.Types.Location.create ~range:(Utils.cmtLocToRange loc) - ~uri:(Files.canonicalizeUri uri |> Uri.fromString)))) - in - maybeLocation - -let references ~full ~pos ~debug = - let allLocs = - match full with - | None -> [] - | Some full -> ( - match References.getLocItem ~full ~pos ~debug with - | None -> [] - | Some locItem -> - let allReferences = References.allReferencesForLocItem ~full locItem in - allReferences - |> List.fold_left - (fun acc {References.uri = uri2; locOpt} -> - let loc = - match locOpt with - | Some loc -> loc - | None -> Uri.toTopLevelLoc uri2 - in - - Lsp.Types.Location.create ~range:(Utils.cmtLocToRange loc) - ~uri:(Uri.toString uri2 |> Uri.fromString) - :: acc) - []) - in - allLocs - -let rename ~full ~pos ~newName ~debug = - let result = - match full with - | None -> None - | Some full -> ( - match References.getLocItem ~full ~pos ~debug with - | None -> None - | Some locItem -> - let allReferences = References.allReferencesForLocItem ~full locItem in - let referencesToToplevelModules = - allReferences - |> Utils.filterMap (fun {References.uri = uri2; locOpt} -> - if locOpt = None then Some uri2 else None) - in - let referencesToItems = - allReferences - |> Utils.filterMap (function - | {References.uri = uri2; locOpt = Some loc} -> Some (uri2, loc) - | {locOpt = None} -> None) - in - let fileRenames = - referencesToToplevelModules - |> List.map (fun uri -> - let path = Uri.toPath uri in - let dir = - match Filename.dirname path with - | "." -> "" - | other -> other - in - let newPath = - Filename.concat dir (newName ^ Filename.extension path) - in - `RenameFile - (Lsp.Types.RenameFile.create - ~newUri: - (newPath |> Uri.fromPath |> Uri.toString |> Uri.fromPath) - ~oldUri:(uri |> Uri.toString |> Uri.fromString) - ())) - in - let textDocumentEdits = - let module StringMap = Misc.StringMap in - let textEditsByUri = - referencesToItems - |> List.map (fun (uri, loc) -> (Uri.toString uri, loc)) - |> List.fold_left - (fun acc (uri, loc) -> - let textEdit = - `TextEdit - (Lsp.Types.TextEdit.create ~newText:newName - ~range:(Utils.cmtLocToRange loc)) - in - match StringMap.find_opt uri acc with - | None -> StringMap.add uri [textEdit] acc - | Some prevEdits -> - StringMap.add uri (textEdit :: prevEdits) acc) - StringMap.empty - in - StringMap.fold - (fun uri edits acc -> - let textDocument = - Lsp.Types.OptionalVersionedTextDocumentIdentifier.create - ~version:0 ~uri:(Uri.fromString uri) () - in - let textDocumentEdit = - `TextDocumentEdit - (Lsp.Types.TextDocumentEdit.create ~edits ~textDocument) - in - textDocumentEdit :: acc) - textEditsByUri [] - in - let documentChanges = fileRenames @ textDocumentEdits in - Some (Lsp.Types.WorkspaceEdit.create ~documentChanges ())) - in - result - -type prepareRenameResult = { - range: Lsp.Types.Range.t; - placeholder: string option; -} - -let prepareRename ~full ~pos ~debug = - match full with - | None -> None - | Some full -> ( - match References.getLocItem ~full ~pos ~debug with - | None -> None - | Some locItem -> - let range = Utils.cmtLocToRange locItem.loc in - let placeholderOpt = - match locItem.locType with - | Typed (name, _, _) | TopLevelModule name | TypeDefinition (name, _, _) - -> - Some name - | _ -> None - in - Some {range; placeholder = placeholderOpt}) - -let format ~source ~kindFile = - let create_range text = - let lines = text |> String.split_on_char '\n' in - let lines_len = List.length lines in - let character = - match List.nth_opt lines lines_len with - | Some line -> String.length line - | None -> 0 - in - let range = - Lsp.Types.Range.create - ~start:(Lsp.Types.Position.create ~line:0 ~character:0) - ~end_:(Lsp.Types.Position.create ~line:(lines_len - 1) ~character) - in - Lsp.Types.TextEdit.create ~newText:text ~range - in - - let result = - match kindFile with - | Files.Res -> ( - let {Res_driver.parsetree = structure; comments; diagnostics} = - Res_driver.parsing_engine.parse_implementation_from_source - ~for_printer:true ~source - in - match List.length diagnostics > 0 with - | true -> Error "Document has syntax errors" - | false -> - Ok (Res_printer.print_implementation ~comments structure |> create_range) - ) - | Resi -> ( - let {Res_driver.parsetree = signature; comments; diagnostics} = - Res_driver.parsing_engine.parse_interface_from_source ~for_printer:true - ~source - in - match List.length diagnostics > 0 with - | true -> Error "Document has syntax errors" - | false -> - Ok (Res_printer.print_interface ~comments signature |> create_range)) - | Other -> Error "Failed to format, file not supported" - in - - match result with - | Ok textEdit -> Ok [textEdit] - | Error e -> Error e diff --git a/analysis/src/CompletionBackEnd.ml b/analysis/src/CompletionBackEnd.ml deleted file mode 100644 index 8d934ca165d..00000000000 --- a/analysis/src/CompletionBackEnd.ml +++ /dev/null @@ -1,2488 +0,0 @@ -open SharedTypes - -let showConstructor {Constructor.cname = {txt}; args; res} = - txt - ^ (match args with - | Args [] -> "" - | InlineRecord fields -> - "({" - ^ (fields - |> List.map (fun (field : field) -> - Printf.sprintf "%s%s: %s" field.fname.txt - (if field.optional then "?" else "") - (Shared.typeToString - (if field.optional then Utils.unwrapIfOption field.typ - else field.typ))) - |> String.concat ", ") - ^ "})" - | Args args -> - "(" - ^ (args - |> List.map (fun (typ, _) -> typ |> Shared.typeToString) - |> String.concat ", ") - ^ ")") - ^ - match res with - | None -> "" - | Some typ -> "\n" ^ (typ |> Shared.typeToString) - -(* TODO: local opens *) -let resolveOpens ~env opens ~package = - List.fold_left - (fun previous path -> - (* Finding an open, first trying to find it in previoulsly resolved opens *) - let rec loop prev = - match prev with - | [] -> ( - match path with - | [] | [_] -> previous - | name :: path -> ( - match ProcessCmt.fileForModule ~package name with - | None -> - Log.log ("Could not get module " ^ name); - previous (* TODO: warn? *) - | Some file -> ( - match - ResolvePath.resolvePath ~env:(QueryEnv.fromFile file) ~package - ~path - with - | None -> - Log.log ("Could not resolve in " ^ name); - previous - | Some (env, _placeholder) -> previous @ [env]))) - | env :: rest -> ( - match ResolvePath.resolvePath ~env ~package ~path with - | None -> loop rest - | Some (env, _placeholder) -> previous @ [env]) - in - Log.log ("resolving open " ^ pathToString path); - match ResolvePath.resolvePath ~env ~package ~path with - | None -> - Log.log "Not local"; - loop previous - | Some (env, _) -> - Log.log "Was local"; - previous @ [env]) - (* loop(previous) *) - [] opens - -let completionForExporteds iterExported getDeclared ~prefix ~exact ~env - ~namesUsed transformContents = - let res = ref [] in - iterExported (fun name stamp -> - (* Log.log("checking exported: " ++ name); *) - if Utils.checkName name ~prefix ~exact then - match getDeclared stamp with - | Some (declared : _ Declared.t) - when not (Hashtbl.mem namesUsed declared.name.txt) -> - Hashtbl.add namesUsed declared.name.txt (); - res := - { - (Completion.create declared.name.txt ~env - ~kind:(transformContents declared)) - with - deprecated = declared.deprecated; - docstring = declared.docstring; - } - :: !res - | _ -> ()); - !res - -let completionForExportedModules ~env ~prefix ~exact ~namesUsed = - completionForExporteds (Exported.iter env.QueryEnv.exported Exported.Module) - (Stamps.findModule env.file.stamps) ~prefix ~exact ~env ~namesUsed - (fun declared -> - Completion.Module - {docstring = declared.docstring; module_ = declared.item}) - -let completionForExportedValues ~env ~prefix ~exact ~namesUsed = - completionForExporteds (Exported.iter env.QueryEnv.exported Exported.Value) - (Stamps.findValue env.file.stamps) ~prefix ~exact ~env ~namesUsed - (fun declared -> Completion.Value declared.item) - -let completionForExportedTypes ~env ~prefix ~exact ~namesUsed = - completionForExporteds (Exported.iter env.QueryEnv.exported Exported.Type) - (Stamps.findType env.file.stamps) ~prefix ~exact ~env ~namesUsed - (fun declared -> Completion.Type declared.item) - -let completionsForExportedConstructors ~(env : QueryEnv.t) ~prefix ~exact - ~namesUsed = - let res = ref [] in - Exported.iter env.exported Exported.Type (fun _name stamp -> - match Stamps.findType env.file.stamps stamp with - | Some ({item = {kind = Type.Variant constructors}} as t) -> - res := - (constructors - |> List.filter (fun c -> - Utils.checkName c.Constructor.cname.txt ~prefix ~exact) - |> Utils.filterMap (fun c -> - let name = c.Constructor.cname.txt in - if not (Hashtbl.mem namesUsed name) then - let () = Hashtbl.add namesUsed name () in - Some - (Completion.create name ~env ~docstring:c.docstring - ?deprecated:c.deprecated - ~kind: - (Completion.Constructor - (c, t.item.decl |> Shared.declToString t.name.txt))) - else None)) - @ !res - | _ -> ()); - !res - -let completionForExportedFields ~(env : QueryEnv.t) ~prefix ~exact ~namesUsed = - let res = ref [] in - Exported.iter env.exported Exported.Type (fun _name stamp -> - match Stamps.findType env.file.stamps stamp with - | Some ({item = {kind = Record fields}} as t) -> - res := - (fields - |> List.filter (fun f -> Utils.checkName f.fname.txt ~prefix ~exact) - |> Utils.filterMap (fun f -> - let name = f.fname.txt in - if not (Hashtbl.mem namesUsed name) then - let () = Hashtbl.add namesUsed name () in - Some - (Completion.create name ~env ~docstring:f.docstring - ?deprecated:f.deprecated - ~kind: - (Completion.Field - (f, t.item.decl |> Shared.declToString t.name.txt))) - else None)) - @ !res - | _ -> ()); - !res - -let findModuleInScope ~env ~moduleName ~scope = - let modulesTable = Hashtbl.create 10 in - env.QueryEnv.file.stamps - |> Stamps.iterModules (fun _ declared -> - Hashtbl.replace modulesTable - (declared.name.txt, declared.extentLoc |> Loc.start) - declared); - let result = ref None in - let processModule name loc = - if name = moduleName && !result = None then - match Hashtbl.find_opt modulesTable (name, Loc.start loc) with - | Some declared -> result := Some declared - | None -> - Log.log - (Printf.sprintf "Module Not Found %s loc:%s\n" name (Loc.toString loc)) - in - scope |> Scope.iterModulesBeforeFirstOpen processModule; - scope |> Scope.iterModulesAfterFirstOpen processModule; - !result - -let rec moduleItemToStructureEnv ~(env : QueryEnv.t) ~package (item : Module.t) - = - match item with - | Module.Structure structure -> Some (env, structure) - | Module.Constraint (_, moduleType) -> - moduleItemToStructureEnv ~env ~package moduleType - | Module.Ident p -> ( - match ResolvePath.resolveModuleFromCompilerPath ~env ~package p with - | Some (env2, Some declared2) -> - moduleItemToStructureEnv ~env:env2 ~package declared2.item - | _ -> None) - -(* Given a declared module, return the env entered into its concrete structure - and the structure itself. Follows constraints and aliases *) -let enterStructureFromDeclared ~(env : QueryEnv.t) ~package - (declared : Module.t Declared.t) = - match moduleItemToStructureEnv ~env ~package declared.item with - | Some (env, s) -> Some (QueryEnv.enterStructure env s, s) - | None -> None - -let completionsFromStructureItems ~(env : QueryEnv.t) - (structure : Module.structure) = - StructureUtils.unique_items structure - |> List.filter_map (fun (it : Module.item) -> - match it.kind with - | Module.Value typ -> - Some - (Completion.create ~env ~docstring:it.docstring - ~kind:(Completion.Value typ) it.name) - | Module.Module {type_ = m} -> - Some - (Completion.create ~env ~docstring:it.docstring - ~kind: - (Completion.Module {docstring = it.docstring; module_ = m}) - it.name) - | Module.Type (t, _recStatus) -> - Some - (Completion.create ~env ~docstring:it.docstring - ~kind:(Completion.Type t) it.name)) - -let resolvePathFromStamps ~(env : QueryEnv.t) ~package ~scope ~moduleName ~path - = - (* Log.log("Finding from stamps " ++ name); *) - match findModuleInScope ~env ~moduleName ~scope with - | None -> None - | Some declared -> ( - (* Log.log("found it"); *) - (* [""] means completion after `ModuleName.` (trailing dot). *) - match path with - | [""] -> ( - match moduleItemToStructureEnv ~env ~package declared.item with - | Some (env, structure) -> Some (QueryEnv.enterStructure env structure, "") - | None -> None) - | _ -> ( - match ResolvePath.findInModule ~env declared.item path with - | None -> None - | Some res -> ( - match res with - | `Local (env, name) -> Some (env, name) - | `Global (moduleName, fullPath) -> ( - match ProcessCmt.fileForModule ~package moduleName with - | None -> None - | Some file -> - ResolvePath.resolvePath ~env:(QueryEnv.fromFile file) ~path:fullPath - ~package)))) - -let resolveModuleWithOpens ~opens ~package ~moduleName = - let rec loop opens = - match opens with - | (env : QueryEnv.t) :: rest -> ( - Log.log ("Looking for env in " ^ Uri.toString env.file.uri); - match ResolvePath.resolvePath ~env ~package ~path:[moduleName; ""] with - | Some (env, _) -> Some env - | None -> loop rest) - | [] -> None - in - loop opens - -let resolveFileModule ~moduleName ~package = - Log.log ("Getting module " ^ moduleName); - match ProcessCmt.fileForModule ~package moduleName with - | None -> None - | Some file -> - Log.log "got it"; - let env = QueryEnv.fromFile file in - Some env - -let getEnvWithOpens ~scope ~(env : QueryEnv.t) ~package - ~(opens : QueryEnv.t list) ~moduleName (path : string list) = - (* TODO: handle interleaving of opens and local modules correctly *) - match resolvePathFromStamps ~env ~scope ~moduleName ~path ~package with - | Some x -> Some x - | None -> ( - let env_opt = - match resolveModuleWithOpens ~opens ~package ~moduleName with - | Some envOpens -> Some envOpens - | None -> resolveFileModule ~moduleName ~package - in - match env_opt with - | None -> None - | Some env -> ( - match path with - | [""] -> Some (env, "") - | _ -> ResolvePath.resolvePath ~env ~package ~path)) - -let rec expandTypeExpr ~env ~package typeExpr = - match typeExpr |> Shared.digConstructor with - | Some path -> ( - match References.digConstructor ~env ~package path with - | None -> None - | Some (env, {item = {decl = {type_manifest = Some t}}}) -> - expandTypeExpr ~env ~package t - | Some (_, {docstring; item}) -> Some (docstring, item)) - | None -> None - -let kindToDocumentation ~env ~full ~currentDocstring name - (kind : Completion.kind) = - let docsFromKind = - match kind with - | ObjLabel _ | Label _ | FileModule _ | Snippet _ | FollowContextPath _ -> - [] - | Module {docstring} -> docstring - | Type {decl; name} -> - [decl |> Shared.declToString name |> Markdown.codeBlock] - | Value typ -> ( - match expandTypeExpr ~env ~package:full.package typ with - | None -> [] - | Some (docstrings, {decl; name; kind}) -> - docstrings - @ [ - (match kind with - | Record _ | Tuple _ | Variant _ -> - Markdown.codeBlock (Shared.declToString name decl) - | _ -> ""); - ]) - | Field ({typ; optional; docstring}, s) -> - (* Handle optional fields. Checking for "?" is because sometimes optional - fields are prefixed with "?" when completing, and at that point we don't - need to _also_ add a "?" after the field name, as that looks weird. *) - docstring - @ [ - Markdown.codeBlock - (if optional && Utils.startsWith name "?" = false then - name ^ "?: " - ^ (typ |> Utils.unwrapIfOption |> Shared.typeToString) - else name ^ ": " ^ (typ |> Shared.typeToString)); - Markdown.codeBlock s; - ] - | Constructor (c, s) -> - [Markdown.codeBlock (showConstructor c); Markdown.codeBlock s] - | PolyvariantConstructor ({displayName; args}, s) -> - [ - Markdown.codeBlock - ("#" ^ displayName - ^ - match args with - | [] -> "" - | typeExprs -> - "(" - ^ (typeExprs - |> List.map (fun typeExpr -> typeExpr |> Shared.typeToString) - |> String.concat ", ") - ^ ")"); - Markdown.codeBlock s; - ] - | ExtractedType (extractedType, _) -> - [Markdown.codeBlock (TypeUtils.extractedTypeToString extractedType)] - in - currentDocstring @ docsFromKind - |> List.filter (fun s -> s <> "") - |> String.concat "\n\n" - -let kindToDetail name (kind : Completion.kind) = - match kind with - | Type {name} -> "type " ^ name - | Value typ -> typ |> Shared.typeToString - | ObjLabel typ -> typ |> Shared.typeToString - | Label typString -> typString - | Module _ -> "module " ^ name - | FileModule f -> "module " ^ f - | Field ({typ; optional}, _) -> - (* Handle optional fields. Checking for "?" is because sometimes optional - fields are prefixed with "?" when completing, and at that point we don't - need to _also_ add a "?" after the field name, as that looks weird. *) - if optional && Utils.startsWith name "?" = false then - typ |> Utils.unwrapIfOption |> Shared.typeToString - else typ |> Shared.typeToString - | Constructor (c, _) -> showConstructor c - | PolyvariantConstructor ({displayName; args}, _) -> ( - "#" ^ displayName - ^ - match args with - | [] -> "" - | typeExprs -> - "(" - ^ (typeExprs - |> List.map (fun typeExpr -> typeExpr |> Shared.typeToString) - |> String.concat ", ") - ^ ")") - | Snippet s -> s - | FollowContextPath _ -> "" - | ExtractedType (extractedType, _) -> - TypeUtils.extractedTypeToString ~nameOnly:true extractedType - -let kindToData filePath (kind : Completion.kind) = - match kind with - | FileModule f -> - Some (`Assoc [("modulePath", `String f); ("filePath", `String filePath)]) - | _ -> Some `Null - -let findAllCompletions ~(env : QueryEnv.t) ~prefix ~exact ~namesUsed - ~(completionContext : Completable.completionContext) = - Log.log ("findAllCompletions uri:" ^ Uri.toString env.file.uri); - match completionContext with - | Value -> - completionForExportedValues ~env ~prefix ~exact ~namesUsed - @ completionsForExportedConstructors ~env ~prefix ~exact ~namesUsed - @ completionForExportedModules ~env ~prefix ~exact ~namesUsed - | Type -> - completionForExportedTypes ~env ~prefix ~exact ~namesUsed - @ completionForExportedModules ~env ~prefix ~exact ~namesUsed - | Module -> completionForExportedModules ~env ~prefix ~exact ~namesUsed - | Field -> - completionForExportedFields ~env ~prefix ~exact ~namesUsed - @ completionForExportedModules ~env ~prefix ~exact ~namesUsed - | ValueOrField -> - completionForExportedValues ~env ~prefix ~exact ~namesUsed - @ completionForExportedFields ~env ~prefix ~exact ~namesUsed - @ completionForExportedModules ~env ~prefix ~exact ~namesUsed - -let processLocalValue name loc contextPath scope ~prefix ~exact ~env - ~(localTables : LocalTables.t) = - if Utils.checkName name ~prefix ~exact then - match Hashtbl.find_opt localTables.valueTable (name, Loc.start loc) with - | Some declared -> - if not (Hashtbl.mem localTables.namesUsed name) then ( - Hashtbl.add localTables.namesUsed name (); - localTables.resultRev <- - { - (Completion.create declared.name.txt ~env ~kind:(Value declared.item)) - with - deprecated = declared.deprecated; - docstring = declared.docstring; - } - :: localTables.resultRev) - | None -> - if !Cfg.debugFollowCtxPath then - Printf.printf "Completion Value Not Found %s loc:%s\n" name - (Loc.toString loc); - localTables.resultRev <- - Completion.create name ~env - ~kind: - (match contextPath with - | Some contextPath -> FollowContextPath (contextPath, scope) - | None -> - Value - (Ctype.newconstr - (Path.Pident (Ident.create "Type Not Known")) - [])) - :: localTables.resultRev - -let processLocalConstructor name loc ~prefix ~exact ~env - ~(localTables : LocalTables.t) = - if Utils.checkName name ~prefix ~exact then - match - Hashtbl.find_opt localTables.constructorTable (name, Loc.start loc) - with - | Some declared -> - if not (Hashtbl.mem localTables.namesUsed name) then ( - Hashtbl.add localTables.namesUsed name (); - localTables.resultRev <- - { - (Completion.create declared.name.txt ~env - ~kind: - (Constructor - ( declared.item, - snd declared.item.typeDecl - |> Shared.declToString (fst declared.item.typeDecl) ))) - with - deprecated = declared.deprecated; - docstring = declared.docstring; - } - :: localTables.resultRev) - | None -> - Log.log - (Printf.sprintf "Completion Constructor Not Found %s loc:%s\n" name - (Loc.toString loc)) - -let processLocalType name loc ~prefix ~exact ~env ~(localTables : LocalTables.t) - = - if Utils.checkName name ~prefix ~exact then - match Hashtbl.find_opt localTables.typesTable (name, Loc.start loc) with - | Some declared -> - if not (Hashtbl.mem localTables.namesUsed name) then ( - Hashtbl.add localTables.namesUsed name (); - localTables.resultRev <- - { - (Completion.create declared.name.txt ~env ~kind:(Type declared.item)) - with - deprecated = declared.deprecated; - docstring = declared.docstring; - } - :: localTables.resultRev) - | None -> - Log.log - (Printf.sprintf "Completion Type Not Found %s loc:%s\n" name - (Loc.toString loc)) - -let processLocalModule name loc ~prefix ~exact ~env - ~(localTables : LocalTables.t) = - if Utils.checkName name ~prefix ~exact then - match Hashtbl.find_opt localTables.modulesTable (name, Loc.start loc) with - | Some declared -> - if not (Hashtbl.mem localTables.namesUsed name) then ( - Hashtbl.add localTables.namesUsed name (); - localTables.resultRev <- - { - (Completion.create declared.name.txt ~env - ~kind: - (Module - {docstring = declared.docstring; module_ = declared.item})) - with - deprecated = declared.deprecated; - docstring = declared.docstring; - } - :: localTables.resultRev) - | None -> - Log.log - (Printf.sprintf "Completion Module Not Found %s loc:%s\n" name - (Loc.toString loc)) - -let processLocalInclude includePath _loc ~prefix ~exact ~(env : QueryEnv.t) - ~(localTables : LocalTables.t) = - (* process only values for now *) - localTables.includedValueTable - |> Hashtbl.iter - (fun (name, _) (declared : (string * Types.type_expr) Declared.t) -> - (* We check all the values if their origin is the same as the include path. *) - let source_module_path = fst declared.item in - if String.ends_with ~suffix:includePath source_module_path then - (* If this is the case we perform a similar check for the prefix *) - if Utils.checkName name ~prefix ~exact then - if not (Hashtbl.mem localTables.namesUsed name) then ( - Hashtbl.add localTables.namesUsed name (); - localTables.resultRev <- - { - (Completion.create declared.name.txt ~env - ~kind:(Value (snd declared.item))) - with - deprecated = declared.deprecated; - docstring = declared.docstring; - synthetic = true; - } - :: localTables.resultRev)) - -let getItemsFromOpens ~opens ~localTables ~prefix ~exact ~completionContext = - opens - |> List.fold_left - (fun results env -> - let completionsFromThisOpen = - findAllCompletions ~env ~prefix ~exact - ~namesUsed:localTables.LocalTables.namesUsed ~completionContext - in - completionsFromThisOpen @ results) - [] - -let findLocalCompletionsForValuesAndConstructors ~(localTables : LocalTables.t) - ~env ~prefix ~exact ~opens ~scope = - localTables |> LocalTables.populateValues ~env; - localTables |> LocalTables.populateIncludedValues ~env; - localTables |> LocalTables.populateConstructors ~env; - localTables |> LocalTables.populateModules ~env; - - scope - |> Scope.iterValuesBeforeFirstOpen - (processLocalValue ~prefix ~exact ~env ~localTables); - scope - |> Scope.iterConstructorsBeforeFirstOpen - (processLocalConstructor ~prefix ~exact ~env ~localTables); - scope - |> Scope.iterModulesBeforeFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); - - let valuesFromOpens = - getItemsFromOpens ~opens ~localTables ~prefix ~exact - ~completionContext:Value - in - - scope - |> Scope.iterValuesAfterFirstOpen - (processLocalValue ~prefix ~exact ~env ~localTables); - scope - |> Scope.iterConstructorsAfterFirstOpen - (processLocalConstructor ~prefix ~exact ~env ~localTables); - scope - |> Scope.iterModulesAfterFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); - - scope - |> Scope.iterIncludes (processLocalInclude ~prefix ~exact ~env ~localTables); - - List.rev_append localTables.resultRev valuesFromOpens - -let findLocalCompletionsForValues ~(localTables : LocalTables.t) ~env ~prefix - ~exact ~opens ~scope = - localTables |> LocalTables.populateValues ~env; - localTables |> LocalTables.populateIncludedValues ~env; - localTables |> LocalTables.populateModules ~env; - scope - |> Scope.iterValuesBeforeFirstOpen - (processLocalValue ~prefix ~exact ~env ~localTables); - scope - |> Scope.iterModulesBeforeFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); - - let valuesFromOpens = - getItemsFromOpens ~opens ~localTables ~prefix ~exact - ~completionContext:Value - in - - scope - |> Scope.iterValuesAfterFirstOpen - (processLocalValue ~prefix ~exact ~env ~localTables); - scope - |> Scope.iterModulesAfterFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); - - scope - |> Scope.iterIncludes (processLocalInclude ~prefix ~exact ~env ~localTables); - - List.rev_append localTables.resultRev valuesFromOpens - -let findLocalCompletionsForTypes ~(localTables : LocalTables.t) ~env ~prefix - ~exact ~opens ~scope = - localTables |> LocalTables.populateTypes ~env; - localTables |> LocalTables.populateModules ~env; - scope - |> Scope.iterTypesBeforeFirstOpen - (processLocalType ~prefix ~exact ~env ~localTables); - scope - |> Scope.iterModulesBeforeFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); - - let valuesFromOpens = - getItemsFromOpens ~opens ~localTables ~prefix ~exact ~completionContext:Type - in - - scope - |> Scope.iterTypesAfterFirstOpen - (processLocalType ~prefix ~exact ~env ~localTables); - scope - |> Scope.iterModulesAfterFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); - List.rev_append localTables.resultRev valuesFromOpens - -let findLocalCompletionsForModules ~(localTables : LocalTables.t) ~env ~prefix - ~exact ~opens ~scope = - localTables |> LocalTables.populateModules ~env; - scope - |> Scope.iterModulesBeforeFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); - - let valuesFromOpens = - getItemsFromOpens ~opens ~localTables ~prefix ~exact - ~completionContext:Module - in - - scope - |> Scope.iterModulesAfterFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); - List.rev_append localTables.resultRev valuesFromOpens - -let findLocalCompletionsWithOpens ~pos ~(env : QueryEnv.t) ~prefix ~exact ~opens - ~scope ~(completionContext : Completable.completionContext) = - (* TODO: handle arbitrary interleaving of opens and local bindings correctly *) - Log.log - ("findLocalCompletionsWithOpens uri:" ^ Uri.toString env.file.uri ^ " pos:" - ^ Pos.toString pos); - let localTables = LocalTables.create () in - match completionContext with - | Value | ValueOrField -> - findLocalCompletionsForValuesAndConstructors ~localTables ~env ~prefix - ~exact ~opens ~scope - | Type -> - findLocalCompletionsForTypes ~localTables ~env ~prefix ~exact ~opens ~scope - | Module -> - findLocalCompletionsForModules ~localTables ~env ~prefix ~exact ~opens - ~scope - | Field -> - (* There's no local completion for fields *) - [] - -let getComplementaryCompletionsForTypedValue ~opens ~allFiles ~scope ~env prefix - = - let exact = false in - let localCompletionsWithOpens = - let localTables = LocalTables.create () in - findLocalCompletionsForValues ~localTables ~env ~prefix ~exact ~opens ~scope - in - let fileModules = - allFiles |> FileSet.elements - |> Utils.filterMap (fun name -> - if - Utils.checkName name ~prefix ~exact - && not - (* TODO complete the namespaced name too *) - (Utils.fileNameHasUnallowedChars name) - then - Some - (Completion.create name ~synthetic:true ~env - ~kind:(Completion.FileModule name)) - else None) - in - localCompletionsWithOpens @ fileModules - -let getCompletionsForPath ~debug ~opens ~full ~pos ~exact ~scope - ~completionContext ~env path = - if debug then Printf.printf "Path %s\n" (path |> String.concat "."); - let allFiles = allFilesInPackage full.package in - match path with - | [] -> [] - | [prefix] -> - let localCompletionsWithOpens = - findLocalCompletionsWithOpens ~pos ~env ~prefix ~exact ~opens ~scope - ~completionContext - in - let fileModules = - allFiles |> FileSet.elements - |> Utils.filterMap (fun name -> - if - Utils.checkName name ~prefix ~exact - && not - (* TODO complete the namespaced name too *) - (Utils.fileNameHasUnallowedChars name) - then - Some - (Completion.create name ~env ~kind:(Completion.FileModule name)) - else None) - in - localCompletionsWithOpens @ fileModules - | moduleName :: path -> ( - Log.log ("Path " ^ pathToString path); - (* [""] is trailing dot completion (`ModuleName.`). *) - match path with - | [""] -> ( - let envFile = env in - let declaredOpt = - match findModuleInScope ~env:envFile ~moduleName ~scope with - | Some d -> Some d - | None -> ( - match Exported.find envFile.exported Exported.Module moduleName with - | Some stamp -> Stamps.findModule envFile.file.stamps stamp - | None -> None) - in - match declaredOpt with - | Some (declared : Module.t Declared.t) when declared.isExported = false - -> ( - match - enterStructureFromDeclared ~env:envFile ~package:full.package declared - with - | None -> [] - | Some (envInModule, structure) -> - completionsFromStructureItems ~env:envInModule structure) - | _ -> ( - match - getEnvWithOpens ~scope ~env ~package:full.package ~opens ~moduleName - path - with - | Some (env, prefix) -> - Log.log "Got the env"; - let namesUsed = Hashtbl.create 10 in - findAllCompletions ~env ~prefix ~exact ~namesUsed ~completionContext - | None -> [])) - | _ -> ( - match - getEnvWithOpens ~scope ~env ~package:full.package ~opens ~moduleName - path - with - | Some (env, prefix) -> - Log.log "Got the env"; - let namesUsed = Hashtbl.create 10 in - findAllCompletions ~env ~prefix ~exact ~namesUsed ~completionContext - | None -> [])) - -(** Completions intended for piping, from a completion path. *) -let completionsForPipeFromCompletionPath ~envCompletionIsMadeFrom ~opens ~pos - ~scope ~debug ~prefix ~env ~rawOpens ~full completionPath = - let completionPathWithoutCurrentModule = - TypeUtils.removeCurrentModuleIfNeeded ~envCompletionIsMadeFrom - completionPath - in - let completionPathMinusOpens = - TypeUtils.removeOpensFromCompletionPath ~rawOpens ~package:full.package - completionPathWithoutCurrentModule - |> String.concat "." - in - let completionName name = - if completionPathMinusOpens = "" then name - else completionPathMinusOpens ^ "." ^ name - in - let completions = - completionPath @ [prefix] - |> getCompletionsForPath ~debug ~completionContext:Value ~exact:false ~opens - ~full ~pos ~env ~scope - in - let completions = - completions - |> List.map (fun (completion : Completion.t) -> - {completion with name = completionName completion.name}) - in - completions - -let rec digToRecordFieldsForCompletion ~debug ~package ~opens ~full ~pos ~env - ~scope path = - match - path - |> getCompletionsForPath ~debug ~completionContext:Type ~exact:true ~opens - ~full ~pos ~env ~scope - with - | {kind = Type {kind = Abstract (Some (p, _))}} :: _ -> - (* This case happens when what we're looking for is a type alias. - This is the case in newer rescript-react versions where - ReactDOM.domProps is an alias for JsxEvent.t. *) - let pathRev = p |> Utils.expandPath in - pathRev |> List.rev - |> digToRecordFieldsForCompletion ~debug ~package ~opens ~full ~pos ~env - ~scope - | {kind = Type {kind = Record fields}} :: _ -> Some fields - | _ -> None - -let mkItem ?data ?additionalTextEdits name ~kind ~detail ~deprecated ~docstring - = - let docContent = - (match deprecated with - | None -> "" - | Some s -> "Deprecated: " ^ s ^ "\n\n") - ^ - match docstring with - | [] -> "" - | _ :: _ -> docstring |> String.concat "\n" - in - let tags = - match deprecated with - | None -> [] - | Some _ -> [Lsp.Types.CompletionItemTag.Deprecated (* deprecated *)] - in - - let documentation = - match String.length docContent > 0 with - | true -> - Some - (`MarkupContent - (Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown - ~value:docContent)) - | false -> None - in - - let deprecated = if Option.is_some deprecated then Some true else None in - let data = - match data with - | Some `Null | None -> None - | Some other -> Some other - in - - Lsp.Types.CompletionItem.create ~label:name ~kind ~tags ~detail ?documentation - ?deprecated ?data ?additionalTextEdits ?sortText:None ?insertText:None - ?insertTextFormat:None ?filterText:None () - -let completionToItem - { - Completion.name; - deprecated; - docstring; - kind; - sortText; - insertText; - insertTextFormat; - filterText; - detail; - env; - additionalTextEdits; - } ~full = - let item = - mkItem name ?additionalTextEdits - ?data:(kindToData (full.file.uri |> Uri.toPath) kind) - ~kind:(Completion.kindToLspCompletionItem kind) - ~deprecated - ~detail: - (match detail with - | None -> kindToDetail name kind - | Some detail -> detail) - ~docstring: - (match - kindToDocumentation ~currentDocstring:docstring ~full ~env name kind - with - | "" -> [] - | docstring -> [docstring]) - in - {item with sortText; insertText; insertTextFormat; filterText} - -let completionsGetTypeEnv = function - | {Completion.kind = Value typ; env} :: _ -> Some (typ, env) - | {Completion.kind = ObjLabel typ; env} :: _ -> Some (typ, env) - | {Completion.kind = Field ({typ}, _); env} :: _ -> Some (typ, env) - | _ -> None - -type getCompletionsForContextPathMode = Regular | Pipe - -let completionsGetCompletionType ~full completions = - let firstNonSyntheticCompletion = - List.find_opt (fun c -> not c.Completion.synthetic) completions - in - match firstNonSyntheticCompletion with - | Some {Completion.kind = Value typ; env} - | Some {Completion.kind = ObjLabel typ; env} - | Some {Completion.kind = Field ({typ}, _); env} -> - typ - |> TypeUtils.extractType ~env ~package:full.package - |> Option.map (fun (typ, _) -> (typ, env)) - | Some {Completion.kind = Type typ; env} -> ( - match TypeUtils.extractTypeFromResolvedType typ ~env ~full with - | None -> None - | Some extractedType -> Some (extractedType, env)) - | Some {Completion.kind = ExtractedType (typ, _); env} -> Some (typ, env) - | _ -> None - -let rec completionsGetCompletionType2 ~debug ~full ~opens ~rawOpens ~pos - completions = - let firstNonSyntheticCompletion = - List.find_opt (fun c -> not c.Completion.synthetic) completions - in - match firstNonSyntheticCompletion with - | Some - ( {Completion.kind = Value typ; env} - | {Completion.kind = ObjLabel typ; env} - | {Completion.kind = Field ({typ}, _); env} ) -> - Some (TypeExpr typ, env) - | Some {Completion.kind = FollowContextPath (ctxPath, scope); env} -> - ctxPath - |> getCompletionsForContextPath ~debug ~full ~env ~exact:true ~opens - ~rawOpens ~pos ~scope - |> completionsGetCompletionType2 ~debug ~full ~opens ~rawOpens ~pos - | Some {Completion.kind = Type typ; env} -> ( - match TypeUtils.extractTypeFromResolvedType typ ~env ~full with - | None -> None - | Some extractedType -> Some (ExtractedType extractedType, env)) - | Some {Completion.kind = ExtractedType (typ, _); env} -> - Some (ExtractedType typ, env) - | _ -> None - -and completionsGetTypeEnv2 ~debug (completions : Completion.t list) ~full ~opens - ~rawOpens ~pos = - let firstNonSyntheticCompletion = - List.find_opt (fun c -> not c.Completion.synthetic) completions - in - match firstNonSyntheticCompletion with - | Some {Completion.kind = Value typ; env} -> Some (typ, env) - | Some {Completion.kind = ObjLabel typ; env} -> Some (typ, env) - | Some {Completion.kind = Field ({typ}, _); env} -> Some (typ, env) - | Some {Completion.kind = FollowContextPath (ctxPath, scope); env} -> - ctxPath - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:true ~scope - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos - | _ -> None - -and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact - ~scope ?(mode = Regular) contextPath = - let envCompletionIsMadeFrom = env in - if debug then - Printf.printf "ContextPath %s\n" - (Completable.contextPathToString contextPath); - let package = full.package in - match contextPath with - | CPString -> - if Debug.verbose () then print_endline "[ctx_path]--> CPString"; - [Completion.create "dummy" ~env ~kind:(Completion.Value Predef.type_string)] - | CPBool -> - if Debug.verbose () then print_endline "[ctx_path]--> CPBool"; - [Completion.create "dummy" ~env ~kind:(Completion.Value Predef.type_bool)] - | CPInt -> - if Debug.verbose () then print_endline "[ctx_path]--> CPInt"; - [Completion.create "dummy" ~env ~kind:(Completion.Value Predef.type_int)] - | CPFloat -> - if Debug.verbose () then print_endline "[ctx_path]--> CPFloat"; - [Completion.create "dummy" ~env ~kind:(Completion.Value Predef.type_float)] - | CPArray None -> - if Debug.verbose () then print_endline "[ctx_path]--> CPArray (no payload)"; - [ - Completion.create "array" ~env - ~kind:(Completion.Value (Ctype.newconstr Predef.path_array [])); - ] - | CPArray (Some cp) -> ( - if Debug.verbose () then - print_endline "[ctx_path]--> CPArray (with payload)"; - match mode with - | Regular -> ( - match - cp - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:true ~scope - |> completionsGetCompletionType ~full - with - | None -> [] - | Some (typ, env) -> - [ - Completion.create "dummy" ~env - ~kind: - (Completion.ExtractedType (Tarray (env, ExtractedType typ), `Type)); - ]) - | Pipe -> - (* Pipe completion with array just needs to know that it's an array, not - what inner type it has. *) - [ - Completion.create "dummy" ~env - ~kind:(Completion.Value (Ctype.newconstr Predef.path_array [])); - ]) - | CPOption cp -> ( - if Debug.verbose () then print_endline "[ctx_path]--> CPOption"; - match - cp - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:true ~scope - |> completionsGetCompletionType ~full - with - | None -> [] - | Some (typ, env) -> - [ - Completion.create "dummy" ~env - ~kind: - (Completion.ExtractedType (Toption (env, ExtractedType typ), `Type)); - ]) - | CPAwait cp -> ( - if Debug.verbose () then print_endline "[ctx_path]--> CPAwait"; - match - cp - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:true ~scope - |> completionsGetCompletionType ~full - with - | Some (Tpromise (env, typ), _env) -> - [Completion.create "dummy" ~env ~kind:(Completion.Value typ)] - | _ -> []) - | CPId {path; completionContext; loc} -> - if Debug.verbose () then print_endline "[ctx_path]--> CPId"; - (* Looks up the type of an identifier. - - Because of reasons we sometimes don't get enough type - information when looking up identifiers where the type - has type parameters. This in turn means less completions. - - There's a heuristic below that tries to look up the type - of the ID in the usual way first. But if the type found - still has uninstantiated type parameters, we check the - location for the identifier from the compiler type artifacts. - That type usually has the type params instantiated, if they are. - This leads to better completion. - - However, we only do it in incremental type checking mode, - because more type information is always available in that mode. *) - let useTvarLookup = !Cfg.inIncrementalTypecheckingMode in - let byPath = - path - |> getCompletionsForPath ~debug ~opens ~full ~pos ~exact - ~completionContext ~env ~scope - in - let hasTvars = - if useTvarLookup then - match byPath with - | [{kind = Value typ}] when TypeUtils.hasTvar typ -> true - | _ -> false - else false - in - let result = - if hasTvars then - let byLoc = TypeUtils.findTypeViaLoc loc ~full ~debug in - match (byLoc, byPath) with - | Some t, [({kind = Value _} as item)] -> [{item with kind = Value t}] - | _ -> byPath - else byPath - in - result - | CPApply (cp, labels) -> ( - if Debug.verbose () then print_endline "[ctx_path]--> CPApply"; - match - cp - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:true ~scope - |> completionsGetCompletionType2 ~debug ~full ~opens ~rawOpens ~pos - with - | Some ((TypeExpr typ | ExtractedType (Tfunction {typ})), env) -> ( - let rec reconstructFunctionType args tRet = - match args with - | [] -> tRet - | (label, tArg) :: rest -> - let restType = reconstructFunctionType rest tRet in - { - typ with - desc = Tarrow ({lbl = label; typ = tArg}, restType, Cok, None); - } - in - let rec processApply args labels = - match (args, labels) with - | _, [] -> args - | _, label :: (_ :: _ as nextLabels) -> - (* compute the application of the first label, then the next ones *) - let args = processApply args [label] in - processApply args nextLabels - | (Asttypes.Nolabel, _) :: nextArgs, [Asttypes.Nolabel] -> nextArgs - | ((Labelled _, _) as arg) :: nextArgs, [Nolabel] -> - arg :: processApply nextArgs labels - | (Optional _, _) :: nextArgs, [Nolabel] -> processApply nextArgs labels - | ( (((Labelled {txt = s1} | Optional {txt = s1}), _) as arg) :: nextArgs, - [(Labelled {txt = s2} | Optional {txt = s2})] ) -> - if s1 = s2 then nextArgs else arg :: processApply nextArgs labels - | ((Nolabel, _) as arg) :: nextArgs, [(Labelled _ | Optional _)] -> - arg :: processApply nextArgs labels - | [], [(Nolabel | Labelled _ | Optional _)] -> - (* should not happen, but just ignore extra arguments *) [] - in - - match TypeUtils.extractFunctionType ~env ~package ~digInto:false typ with - | args, tRet when args <> [] -> - let args = processApply args labels in - let retType = reconstructFunctionType args tRet in - [Completion.create "dummy" ~env ~kind:(Completion.Value retType)] - | _ -> []) - | _ -> []) - | CPField {contextPath = CPId {path; completionContext = Module}; fieldName} - -> - if Debug.verbose () then print_endline "[ctx_path]--> CPField: M.field"; - (* M.field *) - path @ [fieldName] - |> getCompletionsForPath ~debug ~opens ~full ~pos ~exact - ~completionContext:Field ~env ~scope - | CPField {contextPath = cp; fieldName; posOfDot; exprLoc; inJsx} -> ( - if Debug.verbose () then print_endline "[dot_completion]--> Triggered"; - let completionsFromCtxPath = - cp - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:true ~scope - in - let mainTypeCompletionEnv = - completionsFromCtxPath - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos - in - match mainTypeCompletionEnv with - | None -> - if Debug.verbose () then - Printf.printf - "[dot_completion] Could not extract main type completion env.\n"; - [] - | Some (typ, env) -> - let fieldCompletions = - DotCompletionUtils.fieldCompletionsForDotCompletion typ ~env ~package - ~prefix:fieldName ?posOfDot ~exact - in - (* Get additional completions acting as if this field completion was actually a pipe completion. *) - let cpAsPipeCompletion = - Completable.CPPipe - { - synthetic = true; - contextPath = - (match cp with - | CPApply (c, args) -> CPApply (c, args @ [Asttypes.Nolabel]) - | CPId _ when TypeUtils.isFunctionType ~env ~package typ -> - CPApply (cp, [Asttypes.Nolabel]) - | _ -> cp); - id = fieldName; - inJsx; - lhsLoc = exprLoc; - } - in - let pipeCompletions = - cpAsPipeCompletion - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos - ~env:envCompletionIsMadeFrom ~exact ~scope - |> List.filter_map (fun c -> - TypeUtils.transformCompletionToPipeCompletion ~synthetic:true - ~env ?posOfDot c) - in - fieldCompletions @ pipeCompletions) - | CPObj (cp, label) -> ( - (* TODO: Also needs to support ExtractedType *) - if Debug.verbose () then print_endline "[ctx_path]--> CPObj"; - match - cp - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:true ~scope - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos - with - | Some (typ, env) -> ( - match typ |> TypeUtils.extractObjectType ~env ~package with - | Some (env, tObj) -> - tObj |> TypeUtils.getObjFields - |> Utils.filterMap (fun (field, typ) -> - if Utils.checkName field ~prefix:label ~exact then - Some - (Completion.create field ~env ~kind:(Completion.ObjLabel typ)) - else None) - | None -> []) - | None -> []) - | CPPipe {contextPath = cp; id = prefix; lhsLoc; inJsx; synthetic} -> ( - if Debug.verbose () then print_endline "[ctx_path]--> CPPipe"; - (* The environment at the cursor is the environment we're completing from. *) - let env_at_cursor = env in - match - cp - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:true ~scope ~mode:Pipe - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos - with - | None -> - if Debug.verbose () then - print_endline "[CPPipe]--> Could not resolve type env"; - [] - | Some (typ, env) -> ( - let env, typ = - typ - |> TypeUtils.resolveTypeForPipeCompletion ~env ~package:full.package - ~full ~lhsLoc - in - let mainTypeId = TypeUtils.findRootTypeId ~full ~env typ in - let typePath = TypeUtils.pathFromTypeExpr typ in - match mainTypeId with - | None -> - if Debug.verbose () then - Printf.printf - "[pipe_completion] Could not find mainTypeId. Aborting pipe \ - completions.\n"; - [] - | Some mainTypeId -> - if Debug.verbose () then - Printf.printf "[pipe_completion] mainTypeId: %s\n" mainTypeId; - let pipeCompletions = - (* We now need a completion path from where to look up the module for our dot completion type. - This is from where we pull all of the functions we want to complete for the pipe. - - A completion path here could be one of two things: - 1. A module path to the main module for the type we've found - 2. A module path to a builtin module, like `Int` for `int`, or `Array` for `array` - - The below code will deliberately _not_ dig into type aliases for the main type when we're looking - for what _module_ to complete from. This is because you should be able to control where completions - come from even if your type is an alias. - *) - let completeAsBuiltin = - match typePath with - | Some t -> TypeUtils.completionPathFromMaybeBuiltin t - | None -> None - in - let completionPath = - match (completeAsBuiltin, typePath) with - | Some completionPathForBuiltin, _ -> - Some (false, completionPathForBuiltin) - | _, Some p -> ( - (* If this isn't a builtin, but we have a path, we try to resolve the - module path relative to the env we're completing from. This ensures that - what we get here is a module path we can find completions for regardless of - of the current scope for the position we're at.*) - match - TypeUtils.getModulePathRelativeToEnv ~debug - ~env:envCompletionIsMadeFrom ~envFromItem:env - (Utils.expandPath p) - with - | None -> Some (true, [env.file.moduleName]) - | Some p -> Some (false, p)) - | _ -> None - in - match completionPath with - | None -> [] - | Some (isFromCurrentModule, completionPath) -> - completionsForPipeFromCompletionPath ~envCompletionIsMadeFrom ~opens - ~pos ~scope ~debug ~prefix ~env ~rawOpens ~full completionPath - |> TypeUtils.filterPipeableFunctions ~env ~full ~synthetic - ~targetTypeId:mainTypeId - |> List.filter (fun (c : Completion.t) -> - (* If we're completing from the current module then we need to care about scope. - This is automatically taken care of in other cases. *) - if isFromCurrentModule then - match c.kind with - | Value _ -> - scope - |> List.find_opt (fun (item : ScopeTypes.item) -> - match item with - | Value (scopeItemName, _, _, _) -> - scopeItemName = c.name - | _ -> false) - |> Option.is_some - | _ -> false - else true) - in - - let globallyConfiguredCompletionsForType = - match package.autocomplete |> Misc.StringMap.find_opt mainTypeId with - | None -> [] - | Some completionPaths -> - completionPaths |> List.map (fun p -> String.split_on_char '.' p) - in - - let globallyConfiguredCompletions = - globallyConfiguredCompletionsForType - |> List.map (fun completionPath -> - completionsForPipeFromCompletionPath ~envCompletionIsMadeFrom - ~opens ~pos ~scope ~debug ~prefix ~env ~rawOpens ~full - completionPath) - |> List.flatten - |> TypeUtils.filterPipeableFunctions ~synthetic:true ~env ~full - ~targetTypeId:mainTypeId - in - - (* Extra completions can be drawn from the @editor.completeFrom attribute. Here we - find and add those completions as well. *) - let extraCompletions = - TypeUtils.getExtraModulesToCompleteFromForType ~env ~full typ - |> List.map (fun completionPath -> - completionsForPipeFromCompletionPath ~envCompletionIsMadeFrom - ~opens ~pos ~scope ~debug ~prefix ~env ~rawOpens ~full - completionPath) - |> List.flatten - |> TypeUtils.filterPipeableFunctions ~synthetic:true ~env ~full - ~targetTypeId:mainTypeId - in - (* Add JSX completion items if we're in a JSX context. *) - let jsxCompletions = - if inJsx then - PipeCompletionUtils.addJsxCompletionItems ~env ~mainTypeId ~prefix - ~full ~rawOpens typ - else [] - in - (* Add completions from the current module. *) - let currentModuleCompletions = - getCompletionsForPath ~debug ~completionContext:Value ~exact:false - ~opens:[] ~full ~pos ~env:env_at_cursor ~scope [prefix] - |> TypeUtils.filterPipeableFunctions ~synthetic:true ~env ~full - ~targetTypeId:mainTypeId - in - jsxCompletions @ pipeCompletions @ extraCompletions - @ currentModuleCompletions @ globallyConfiguredCompletions)) - | CTuple ctxPaths -> - if Debug.verbose () then print_endline "[ctx_path]--> CTuple"; - (* Turn a list of context paths into a list of type expressions. *) - let typeExrps = - ctxPaths - |> List.map (fun contextPath -> - contextPath - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos - ~env ~exact:true ~scope) - |> List.filter_map (fun completionItems -> - match completionItems with - | {Completion.kind = Value typ} :: _ -> Some typ - | _ -> None) - in - if List.length ctxPaths = List.length typeExrps then - [ - Completion.create "dummy" ~env - ~kind:(Completion.Value (Ctype.newty (Ttuple typeExrps))); - ] - else [] - | CJsxPropValue {pathToComponent; propName; emptyJsxPropNameHint} -> ( - if Debug.verbose () then print_endline "[ctx_path]--> CJsxPropValue"; - let findTypeOfValue path = - path - |> getCompletionsForPath ~debug ~completionContext:Value ~exact:true - ~opens ~full ~pos ~env ~scope - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos - in - let lowercaseComponent = - match pathToComponent with - | [elName] when Char.lowercase_ascii elName.[0] = elName.[0] -> true - | _ -> false - in - (* TODO(env-stuff) Does this need to potentially be instantiated with type args too? *) - let labels = - if lowercaseComponent then - let rec digToTypeForCompletion path = - match - path - |> getCompletionsForPath ~debug ~completionContext:Type ~exact:true - ~opens ~full ~pos ~env ~scope - with - | {kind = Type {kind = Abstract (Some (p, _))}} :: _ -> - (* This case happens when what we're looking for is a type alias. - This is the case in newer rescript-react versions where - ReactDOM.domProps is an alias for JsxEvent.t. *) - let pathRev = p |> Utils.expandPath in - pathRev |> List.rev |> digToTypeForCompletion - | {kind = Type {kind = Record fields}} :: _ -> - fields |> List.map (fun f -> (f.fname.txt, f.typ, env)) - | _ -> [] - in - TypeUtils.pathToElementProps package |> digToTypeForCompletion - else - CompletionJsx.getJsxLabels ~componentPath:pathToComponent - ~findTypeOfValue ~package - in - (* We have a heuristic that kicks in when completing empty prop expressions in the middle of a JSX element, - like third=123 />. - The parser turns that broken JSX into: third />, 123. - - So, we use a heuristic that covers this scenario by picking up on the cursor being between - the prop name and the prop expression, and the prop expression being an ident that's a - _valid prop name_ for that JSX element. - - This works because the ident itself will always be the next prop name (since that's what the - parser eats). So, we do a simple lookup of that hint here if it exists, to make sure the hint - is indeed a valid label for this JSX element. *) - let emptyJsxPropNameHintIsCorrect = - match emptyJsxPropNameHint with - | Some identName when identName != propName -> - labels - |> List.find_opt (fun (f, _, _) -> f = identName) - |> Option.is_some - | Some _ -> false - | None -> true - in - let targetLabel = - if emptyJsxPropNameHintIsCorrect then - labels |> List.find_opt (fun (f, _, _) -> f = propName) - else None - in - match targetLabel with - | None -> [] - | Some (_, typ, env) -> - [ - Completion.create "dummy" ~env - ~kind:(Completion.Value (Utils.unwrapIfOption typ)); - ]) - | CArgument {functionContextPath; argumentLabel} -> ( - if Debug.verbose () then print_endline "[ctx_path]--> CArgument"; - if Debug.verbose () then - Printf.printf "--> function argument: %s\n" - (match argumentLabel with - | Labelled n | Optional n -> n - | Unlabelled {argumentPosition} -> "$" ^ string_of_int argumentPosition); - - let labels, env = - match - functionContextPath - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:true ~scope - |> completionsGetCompletionType2 ~debug ~full ~opens ~rawOpens ~pos - with - | Some ((TypeExpr typ | ExtractedType (Tfunction {typ})), env) -> - if Debug.verbose () then print_endline "--> found function type"; - (typ |> TypeUtils.getArgs ~full ~env, env) - | _ -> - if Debug.verbose () then - print_endline "--> could not find function type"; - ([], env) - in - let targetLabel = - labels - |> List.find_opt (fun (label, _) -> - match (argumentLabel, label) with - | ( Unlabelled {argumentPosition = pos1}, - Completable.Unlabelled {argumentPosition = pos2} ) -> - pos1 = pos2 - | ( (Labelled name1 | Optional name1), - (Labelled name2 | Optional name2) ) -> - name1 = name2 - | _ -> false) - in - let expandOption = - match targetLabel with - | None | Some ((Unlabelled _ | Labelled _), _) -> false - | Some (Optional _, _) -> true - in - match targetLabel with - | None -> - if Debug.verbose () then - print_endline "--> could not look up function argument"; - [] - | Some (_, typ) -> - if Debug.verbose () then print_endline "--> found function argument!"; - [ - Completion.create "dummy" ~env - ~kind: - (Completion.Value - (if expandOption then Utils.unwrapIfOption typ else typ)); - ]) - | CPatternPath {rootCtxPath; nested} -> ( - if Debug.verbose () then print_endline "[ctx_path]--> CPatternPath"; - (* TODO(env-stuff) Get rid of innerType etc *) - match - rootCtxPath - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:true ~scope - |> completionsGetCompletionType2 ~debug ~full ~opens ~rawOpens ~pos - with - | Some (typ, env) -> ( - match typ |> TypeUtils.resolveNestedPatternPath ~env ~full ~nested with - | Some (typ, env) -> - [Completion.create "dummy" ~env ~kind:(kindFromInnerType typ)] - | None -> []) - | None -> []) - | CTypeAtPos loc -> ( - if Debug.verbose () then print_endline "[ctx_path]--> CTypeAtPos"; - match TypeUtils.findTypeViaLoc loc ~full ~debug with - | None -> [] - | Some typExpr -> [Completion.create "dummy" ~env ~kind:(Value typExpr)]) - -let getOpens ~debug ~rawOpens ~package ~env = - if debug && rawOpens <> [] then - Printf.printf "%s\n" - ("Raw opens: " - ^ string_of_int (List.length rawOpens) - ^ " " - ^ String.concat " ... " (rawOpens |> List.map pathToString)); - let packageOpens = package.opens in - if debug && packageOpens <> [] then - Printf.printf "%s\n" - ("Package opens " - ^ String.concat " " (packageOpens |> List.map (fun p -> p |> pathToString)) - ); - let resolvedOpens = - resolveOpens ~env (List.rev (rawOpens @ packageOpens)) ~package - in - if debug && resolvedOpens <> [] then - Printf.printf "%s\n" - ("Resolved opens " - ^ string_of_int (List.length resolvedOpens) - ^ " " - ^ String.concat " " - (resolvedOpens |> List.map (fun (e : QueryEnv.t) -> e.file.moduleName)) - ); - (* Last open takes priority *) - List.rev resolvedOpens - -let filterItems items ~prefix = - if prefix = "" then items - else - items - |> List.filter (fun (item : Completion.t) -> - Utils.startsWith item.name prefix) - -type completionMode = Pattern of Completable.patternMode | Expression - -let emptyCase ~mode num = - match mode with - | Expression -> "$" ^ string_of_int (num - 1) - | Pattern _ -> "${" ^ string_of_int num ^ ":_}" - -let printConstructorArgs ~mode ~asSnippet argsLen = - let args = ref [] in - for argNum = 1 to argsLen do - args := - !args - @ [ - (match (asSnippet, argsLen) with - | true, l when l > 1 -> Printf.sprintf "${%i:_}" argNum - | true, l when l > 0 -> emptyCase ~mode argNum - | _ -> "_"); - ] - done; - if List.length !args > 0 then "(" ^ (!args |> String.concat ", ") ^ ")" - else "" - -let rec completeTypedValue ?(typeArgContext : typeArgContext option) ~rawOpens - ~full ~prefix ~completionContext ~mode (t : SharedTypes.completionType) = - let emptyCase = emptyCase ~mode in - let printConstructorArgs = printConstructorArgs ~mode in - let create = Completion.create ?typeArgContext in - let getRecordCompletions ~env ~fields ~extractedType = - (* As we're completing for a record, we'll need a hint (completionContext) - here to figure out whether we should complete for a record field, or - the record body itself. *) - match completionContext with - | Some (Completable.RecordField {seenFields}) -> - fields - |> List.filter (fun (field : field) -> - List.mem field.fname.txt seenFields = false) - |> List.map (fun (field : field) -> - match (field.optional, mode) with - | true, Pattern Destructuring -> - create ("?" ^ field.fname.txt) ?deprecated:field.deprecated - ~docstring: - [ - field.fname.txt - ^ " is an optional field, and needs to be destructured \ - using '?'."; - ] - ~kind: - (Field (field, TypeUtils.extractedTypeToString extractedType)) - ~env - | _ -> - create field.fname.txt ?deprecated:field.deprecated - ~kind: - (Field (field, TypeUtils.extractedTypeToString extractedType)) - ~env) - |> filterItems ~prefix - | _ -> - if prefix = "" then - [ - create "{}" ~includesSnippets:true ~insertText:"{$0}" ~sortText:"A" - ~kind: - (ExtractedType - ( extractedType, - match mode with - | Pattern _ -> `Type - | Expression -> `Value )) - ~env; - ] - else [] - in - match t with - | TtypeT {env; path} when mode = Expression -> - if Debug.verbose () then - print_endline "[complete_typed_value]--> TtypeT (Expression)"; - (* Find all values in the module with type t *) - let valueWithTypeT t = - match t.Types.desc with - | Tconstr (Pident {name = "t"}, [], _) -> true - | _ -> false - in - (* Find all functions in the module that returns type t *) - let rec fnReturnsTypeT t = - match t.Types.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> fnReturnsTypeT t1 - | Tarrow _ -> ( - match TypeUtils.extractFunctionType ~env ~package:full.package t with - | ( (Nolabel, {desc = Tconstr (Path.Pident {name = "t"}, _, _)}) :: _, - {desc = Tconstr (Path.Pident {name = "t"}, _, _)} ) -> - (* Filter out functions that take type t first. These are often - @send style functions that we don't want to have here because - they usually aren't meant to create a type t from scratch. *) - false - | _args, {desc = Tconstr (Path.Pident {name = "t"}, _, _)} -> true - | _ -> false) - | _ -> false - in - let getCompletionName exportedValueName = - let fnNname = - TypeUtils.getModulePathRelativeToEnv ~debug:false - ~env:(QueryEnv.fromFile full.file) - ~envFromItem:env (Utils.expandPath path) - in - match fnNname with - | None -> None - | Some base -> - let base = - TypeUtils.removeOpensFromCompletionPath ~rawOpens - ~package:full.package base - in - Some ((base |> String.concat ".") ^ "." ^ exportedValueName) - in - let getExportedValueCompletion name (declared : Types.type_expr Declared.t) - = - let typeExpr = declared.item in - if valueWithTypeT typeExpr then - getCompletionName name - |> Option.map (fun name -> - create name ~includesSnippets:true ~insertText:name - ~kind:(Value typeExpr) ~env) - else if fnReturnsTypeT typeExpr then - getCompletionName name - |> Option.map (fun name -> - create - (Printf.sprintf "%s()" name) - ~includesSnippets:true ~insertText:(name ^ "($0)") - ~kind:(Value typeExpr) ~env) - else None - in - let completionItems = - Hashtbl.fold - (fun name stamp all -> - match Stamps.findValue env.file.stamps stamp with - | None -> all - | Some declaredTypeExpr -> ( - match getExportedValueCompletion name declaredTypeExpr with - | None -> all - | Some completion -> completion :: all)) - env.exported.values_ [] - in - - (* Special casing for things where we want extra things in the completions *) - let completionItems = - match path with - | Pdot (Pdot (Pident {name = "Js"}, "Re", _), "t", _) - | Pdot (Pdot (Pident {name = "Stdlib"}, "RegExp", _), "t", _) - | Pdot (Pident {name = "RegExp"}, "t", _) -> - (* regexps *) - create "//g" ~insertText:"/$0/g" ~includesSnippets:true - ~kind:(Label "Regular expression") ~env - :: completionItems - | _ -> completionItems - in - completionItems - | Tbool env -> - if Debug.verbose () then print_endline "[complete_typed_value]--> Tbool"; - [ - create "true" ~kind:(Label "bool") ~env; - create "false" ~kind:(Label "bool") ~env; - ] - |> filterItems ~prefix - | TtypeT {env; path} -> - if Debug.verbose () then - print_endline "[complete_typed_value]--> TtypeT (Pattern)"; - (* This is in patterns. Emit an alias/binding with the module name as a value name. *) - if prefix <> "" then [] - else - let moduleName = - match path |> Utils.expandPath with - | _t :: moduleName :: _rest -> String.uncapitalize_ascii moduleName - | _ -> "value" - in - [ - create moduleName ~kind:(Label moduleName) ~env - ~insertText:("${0:" ^ moduleName ^ "}") - ~includesSnippets:true; - ] - | Tvariant {env; constructors; variantDecl; variantName} -> - if Debug.verbose () then print_endline "[complete_typed_value]--> Tvariant"; - constructors - |> List.map (fun (constructor : Constructor.t) -> - let numArgs = - match constructor.args with - | InlineRecord _ -> 1 - | Args args -> List.length args - in - create ?deprecated:constructor.deprecated ~includesSnippets:true - (constructor.cname.txt - ^ printConstructorArgs numArgs ~asSnippet:false) - ~insertText: - (constructor.cname.txt - ^ printConstructorArgs numArgs ~asSnippet:true) - ~kind: - (Constructor - (constructor, variantDecl |> Shared.declToString variantName)) - ~env) - |> filterItems ~prefix - | Tpolyvariant {env; constructors; typeExpr} -> - if Debug.verbose () then - print_endline "[complete_typed_value]--> Tpolyvariant"; - constructors - |> List.map (fun (constructor : polyVariantConstructor) -> - create - ("#" ^ constructor.displayName - ^ printConstructorArgs - (List.length constructor.args) - ~asSnippet:false) - ~includesSnippets:true - ~insertText: - ((if Utils.startsWith prefix "#" then "" else "#") - ^ constructor.displayName - ^ printConstructorArgs - (List.length constructor.args) - ~asSnippet:true) - ~kind: - (PolyvariantConstructor - (constructor, typeExpr |> Shared.typeToString)) - ~env) - |> filterItems - ~prefix:(if Utils.startsWith prefix "#" then prefix else "#" ^ prefix) - | Toption (env, t) -> - if Debug.verbose () then print_endline "[complete_typed_value]--> Toption"; - let innerType = - match t with - | ExtractedType t -> Some (t, None) - | TypeExpr t -> t |> TypeUtils.extractType ~env ~package:full.package - in - let expandedCompletions = - match innerType with - | None -> [] - | Some (innerType, _typeArgsContext) -> - innerType - |> completeTypedValue ~rawOpens ~full ~prefix ~completionContext ~mode - |> List.map (fun (c : Completion.t) -> - { - c with - name = "Some(" ^ c.name ^ ")"; - sortText = None; - insertText = - (match c.insertText with - | None -> None - | Some insertText -> Some ("Some(" ^ insertText ^ ")")); - }) - in - let noneCase = Completion.create "None" ~kind:(kindFromInnerType t) ~env in - let someAnyCase = - create "Some(_)" ~includesSnippets:true ~kind:(kindFromInnerType t) ~env - ~insertText:(Printf.sprintf "Some(%s)" (emptyCase 1)) - in - let completions = - match completionContext with - | Some (Completable.CameFromRecordField fieldName) -> - [ - create - ("Some(" ^ fieldName ^ ")") - ~includesSnippets:true ~kind:(kindFromInnerType t) ~env - ~insertText:("Some(" ^ fieldName ^ ")$0"); - someAnyCase; - noneCase; - ] - | _ -> [noneCase; someAnyCase] - in - completions @ expandedCompletions |> filterItems ~prefix - | Tresult {env; okType; errorType} -> - if Debug.verbose () then print_endline "[complete_typed_value]--> Tresult"; - let okInnerType = - okType |> TypeUtils.extractType ~env ~package:full.package - in - let errorInnerType = - errorType |> TypeUtils.extractType ~env ~package:full.package - in - let expandedOkCompletions = - match okInnerType with - | None -> [] - | Some (innerType, _) -> - innerType - |> completeTypedValue ~rawOpens ~full ~prefix ~completionContext ~mode - |> List.map (fun (c : Completion.t) -> - { - c with - name = "Ok(" ^ c.name ^ ")"; - sortText = None; - insertText = - (match c.insertText with - | None -> None - | Some insertText -> Some ("Ok(" ^ insertText ^ ")")); - }) - in - let expandedErrorCompletions = - match errorInnerType with - | None -> [] - | Some (innerType, _) -> - innerType - |> completeTypedValue ~rawOpens ~full ~prefix ~completionContext ~mode - |> List.map (fun (c : Completion.t) -> - { - c with - name = "Error(" ^ c.name ^ ")"; - sortText = None; - insertText = - (match c.insertText with - | None -> None - | Some insertText -> Some ("Error(" ^ insertText ^ ")")); - }) - in - let okAnyCase = - create "Ok(_)" ~includesSnippets:true ~kind:(Value okType) ~env - ~insertText:(Printf.sprintf "Ok(%s)" (emptyCase 1)) - in - let errorAnyCase = - create "Error(_)" ~includesSnippets:true ~kind:(Value errorType) ~env - ~insertText:(Printf.sprintf "Error(%s)" (emptyCase 1)) - in - let completions = - match completionContext with - | Some (Completable.CameFromRecordField fieldName) -> - [ - create - ("Ok(" ^ fieldName ^ ")") - ~includesSnippets:true ~kind:(Value okType) ~env - ~insertText:("Ok(" ^ fieldName ^ ")$0"); - okAnyCase; - errorAnyCase; - ] - | _ -> [okAnyCase; errorAnyCase] - in - completions @ expandedOkCompletions @ expandedErrorCompletions - |> filterItems ~prefix - | Tuple (env, exprs, typ) -> - if Debug.verbose () then print_endline "[complete_typed_value]--> Tuple"; - let numExprs = List.length exprs in - [ - create - (printConstructorArgs numExprs ~asSnippet:false) - ~includesSnippets:true - ~insertText:(printConstructorArgs numExprs ~asSnippet:true) - ~kind:(Value typ) ~env; - ] - | Trecord {env; fields} as extractedType -> - if Debug.verbose () then print_endline "[complete_typed_value]--> Trecord"; - getRecordCompletions ~env ~fields ~extractedType - | TinlineRecord {env; fields} as extractedType -> - if Debug.verbose () then - print_endline "[complete_typed_value]--> TinlineRecord"; - getRecordCompletions ~env ~fields ~extractedType - | Tarray (env, typ) -> - if Debug.verbose () then print_endline "[complete_typed_value]--> Tarray"; - if prefix = "" then - [ - create "[]" ~includesSnippets:true ~insertText:"[$0]" ~sortText:"A" - ~kind: - (match typ with - | ExtractedType typ -> - ExtractedType - ( typ, - match mode with - | Pattern _ -> `Type - | Expression -> `Value ) - | TypeExpr typ -> Value typ) - ~env; - ] - else [] - | Tstring env -> - if Debug.verbose () then print_endline "[complete_typed_value]--> Tstring"; - if prefix = "" then - [ - create "\"\"" ~includesSnippets:true ~insertText:"\"$0\"" ~sortText:"A" - ~kind:(Value Predef.type_string) ~env; - ] - else [] - | Tfunction {env; typ; args; returnType} when prefix = "" && mode = Expression - -> - if Debug.verbose () then - print_endline "[complete_typed_value]--> Tfunction #1"; - let mkFnArgs ~asSnippet = - match args with - | [(Nolabel, argTyp)] when TypeUtils.typeIsUnit argTyp -> "()" - | [(Nolabel, argTyp)] -> - let varName = - CompletionExpressions.prettyPrintFnTemplateArgName ~env ~full argTyp - in - if asSnippet then "${1:" ^ varName ^ "}" else varName - | _ -> - let currentUnlabelledIndex = ref 0 in - let argsText = - args - |> List.map (fun ((label, typ) : typedFnArg) -> - match label with - | Optional {txt = name} -> "~" ^ name ^ "=?" - | Labelled {txt = name} -> "~" ^ name - | Nolabel -> - if TypeUtils.typeIsUnit typ then "()" - else ( - currentUnlabelledIndex := !currentUnlabelledIndex + 1; - let num = !currentUnlabelledIndex in - let varName = - CompletionExpressions.prettyPrintFnTemplateArgName - ~currentIndex:num ~env ~full typ - in - if asSnippet then - "${" ^ string_of_int num ^ ":" ^ varName ^ "}" - else varName)) - |> String.concat ", " - in - "(" ^ argsText ^ ")" - in - let isAsync = - match TypeUtils.extractType ~env ~package:full.package returnType with - | Some (Tpromise _, _) -> true - | _ -> false - in - let asyncPrefix = if isAsync then "async " else "" in - let functionBody, functionBodyInsertText = - match args with - | [(Nolabel, argTyp)] -> - let varName = - CompletionExpressions.prettyPrintFnTemplateArgName ~env ~full argTyp - in - ( (" => " ^ if varName = "()" then "{}" else varName), - " => ${0:" ^ varName ^ "}" ) - | _ -> (" => {}", " => {${0:()}}") - in - [ - create - (asyncPrefix ^ mkFnArgs ~asSnippet:false ^ functionBody) - ~includesSnippets:true - ~insertText: - (asyncPrefix ^ mkFnArgs ~asSnippet:true ^ functionBodyInsertText) - ~sortText:"A" ~kind:(Value typ) ~env; - ] - | Tfunction _ -> - if Debug.verbose () then - print_endline "[complete_typed_value]--> Tfunction #other"; - [] - | Texn env -> - if Debug.verbose () then print_endline "[complete_typed_value]--> Texn"; - [ - create - (["Exn"; "Error(error)"] |> ident) - ~kind:(Label "Catches errors from JavaScript errors.") - ~docstring: - [ - "Matches on a JavaScript error. Read more in the [documentation on \ - catching JS \ - exceptions](https://rescript-lang.org/docs/manual/latest/exception#catching-js-exceptions)."; - ] - ~env; - ] - | Tpromise _ -> - if Debug.verbose () then print_endline "[complete_typed_value]--> Tpromise"; - [] - -module StringSet = Set.Make (String) - -let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover completable = - if debug then - Printf.printf "Completable: %s\n" (Completable.toString completable); - let package = full.package in - let rawOpens = Scope.getRawOpens scope in - let opens = getOpens ~debug ~rawOpens ~package ~env in - let allFiles = allFilesInPackage package in - let findTypeOfValue path = - path - |> getCompletionsForPath ~debug ~completionContext:Value ~exact:true ~opens - ~full ~pos ~env ~scope - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos - in - match completable with - | Cnone -> [] - | Cpath contextPath -> - contextPath - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:forHover ~scope - | Cjsx ([id], prefix, identsSeen) when String.uncapitalize_ascii id = id -> ( - (* Lowercase JSX tag means builtin *) - let mkLabel (name, typString) = - Completion.create name ~kind:(Label typString) ~env - in - let keyLabels = - if Utils.startsWith "key" prefix then [mkLabel ("key", "string")] else [] - in - let pathToElementProps = TypeUtils.pathToElementProps package in - if Debug.verbose () then - Printf.printf - "[completing-lowercase-jsx] Attempting to complete from type at %s\n" - (pathToElementProps |> String.concat "."); - let fromElementProps = - match - pathToElementProps - |> digToRecordFieldsForCompletion ~debug ~package ~opens ~full ~pos ~env - ~scope - with - | None -> None - | Some fields -> - Some - (fields - |> List.filter_map (fun (f : field) -> - if - Utils.startsWith f.fname.txt prefix - && (forHover || not (List.mem f.fname.txt identsSeen)) - then - Some - ( f.fname.txt, - Shared.typeToString (Utils.unwrapIfOption f.typ) ) - else None) - |> List.map mkLabel) - in - match fromElementProps with - | Some elementProps -> elementProps - | None -> - if debug then - Printf.printf - "[completing-lowercase-jsx] could not find element props to complete \ - from.\n"; - keyLabels) - | Cjsx (componentPath, prefix, identsSeen) -> - let labels = - CompletionJsx.getJsxLabels ~componentPath ~findTypeOfValue ~package - in - let mkLabel_ name typString = - Completion.create name ~kind:(Label typString) ~env - in - let mkLabel (name, typ, _env) = - mkLabel_ name (typ |> Shared.typeToString) - in - let keyLabels = - if Utils.startsWith "key" prefix then [mkLabel_ "key" "string"] else [] - in - if labels = [] then [] - else - (labels - |> List.filter (fun (name, _t, _env) -> - Utils.startsWith name prefix - && name <> "key" - && (forHover || not (List.mem name identsSeen))) - |> List.map mkLabel) - @ keyLabels - | CdecoratorPayload (JsxConfig {prefix; nested}) -> ( - let mkField ~name ~primitive = - { - stamp = -1; - fname = {loc = Location.none; txt = name}; - optional = true; - typ = Ctype.newconstr primitive []; - docstring = []; - deprecated = None; - } - in - let typ : completionType = - Trecord - { - env; - definition = `NameOnly "jsxConfig"; - fields = - [ - mkField ~name:"version" ~primitive:Predef.path_int; - mkField ~name:"module_" ~primitive:Predef.path_string; - mkField ~name:"mode" ~primitive:Predef.path_string; - ]; - } - in - match typ |> TypeUtils.resolveNested ~env ~full ~nested with - | None -> [] - | Some (typ, _env, completionContext, typeArgContext) -> - typ - |> completeTypedValue ?typeArgContext ~rawOpens ~mode:Expression ~full - ~prefix ~completionContext) - | CdecoratorPayload (ModuleWithImportAttributes {prefix; nested}) -> ( - let mkField ~name ~primitive = - { - stamp = -1; - fname = {loc = Location.none; txt = name}; - optional = true; - typ = Ctype.newconstr primitive []; - docstring = []; - deprecated = None; - } - in - let importAttributesConfig : completionType = - Trecord - { - env; - definition = `NameOnly "importAttributesConfig"; - fields = [mkField ~name:"type_" ~primitive:Predef.path_string]; - } - in - let rootConfig : completionType = - Trecord - { - env; - definition = `NameOnly "moduleConfig"; - fields = - [ - mkField ~name:"from" ~primitive:Predef.path_string; - mkField ~name:"with" ~primitive:Predef.path_string; - ]; - } - in - let nested, typ = - match nested with - | NFollowRecordField {fieldName = "with"} :: rest -> - (rest, importAttributesConfig) - | _ -> (nested, rootConfig) - in - match typ |> TypeUtils.resolveNested ~env ~full ~nested with - | None -> [] - | Some (typ, _env, completionContext, typeArgContext) -> - typ - |> completeTypedValue ?typeArgContext ~rawOpens ~mode:Expression ~full - ~prefix ~completionContext) - | CdecoratorPayload (Module prefix) -> - let packageJsonPath = - Utils.findPackageJson (full.package.rootPath |> Uri.fromPath) - in - let itemsFromPackageJson = - match packageJsonPath with - | None -> - if debug then - Printf.printf - "Did not find package.json, started looking (going upwards) from: %s\n" - full.package.rootPath; - [] - | Some path -> ( - match Files.readFile path with - | None -> - if debug then print_endline "Could not read package.json"; - [] - | Some s -> ( - match YojsonHelpers.from_string_opt s with - | Some (`Assoc items) -> - items - |> List.filter_map (fun (key, t) -> - match (key, t) with - | ("dependencies" | "devDependencies"), `Assoc o -> - Some - (o - |> List.filter_map (fun (pkgName, _) -> - match pkgName with - | "rescript" -> None - | pkgName -> Some pkgName)) - | _ -> None) - |> List.flatten - | _ -> - if debug then print_endline "Could not parse package.json"; - [])) - in - (* TODO: Resolve relatives? *) - let localItems = - try - let files = - Sys.readdir (Filename.dirname (env.file.uri |> Uri.toPath)) - |> Array.to_list - in - (* Filter out generated build artifacts from in-source builds. *) - let resFiles = - StringSet.of_list - (files - |> List.filter_map (fun f -> - if Filename.extension f = ".res" then - Some (try Filename.chop_extension f with _ -> f) - else None)) - in - let is_internal_artifact_extension = function - | ".ast" | ".cmi" | ".cmj" | ".cmt" | ".cmti" | ".iast" -> true - | _ -> false - in - files - |> List.filter_map (fun fileName -> - let withoutExtension = - try Filename.chop_extension fileName with _ -> fileName - in - if - String.ends_with fileName ~suffix:package.suffix - && resFiles |> StringSet.mem withoutExtension - then None - else - match Filename.extension fileName with - | ".res" | ".resi" | "" -> None - | ext when is_internal_artifact_extension ext -> None - | _ -> Some ("./" ^ fileName)) - |> List.sort String.compare - with _ -> - if debug then print_endline "Could not read relative directory"; - [] - in - let items = itemsFromPackageJson @ localItems in - items - |> List.filter (fun name -> Utils.startsWith name prefix) - |> List.map (fun name -> - let isLocal = Utils.startsWith name "./" in - Completion.create name - ~kind:(Label (if isLocal then "Local file" else "Package")) - ~env) - | Cdecorator prefix -> - let mkDecorator (name, docstring, maybeInsertText) = - { - (Completion.create name ~synthetic:true ~includesSnippets:true - ~kind:(Label "") ~env ?insertText:maybeInsertText) - with - docstring; - } - in - let isTopLevel = String.starts_with ~prefix:"@" prefix in - let prefix = - if isTopLevel then String.sub prefix 1 (String.length prefix - 1) - else prefix - in - let decorators = - if isTopLevel then CompletionDecorators.toplevel - else CompletionDecorators.local - in - decorators - |> List.filter (fun (decorator, _, _) -> Utils.startsWith decorator prefix) - |> List.map (fun (decorator, maybeInsertText, doc) -> - let parts = String.split_on_char '.' prefix in - let len = String.length prefix in - let dec2 = - if List.length parts > 1 then - String.sub decorator len (String.length decorator - len) - else decorator - in - (dec2, doc, maybeInsertText)) - |> List.map mkDecorator - | CnamedArg (cp, prefix, identsSeen) -> - let labels = - match - cp - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:true ~scope - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos - with - | Some (typ, _env) -> - if debug then - Printf.printf "Found type for function %s\n" - (typ |> Shared.typeToString); - - typ - |> TypeUtils.getArgs ~full ~env - |> List.filter_map (fun arg -> - match arg with - | SharedTypes.Completable.Labelled name, a -> Some (name, a) - | Optional name, a -> Some (name, a) - | _ -> None) - | None -> [] - in - let mkLabel (name, typ) = - Completion.create name ~kind:(Label (typ |> Shared.typeToString)) ~env - in - labels - |> List.filter (fun (name, _t) -> - Utils.startsWith name prefix - && (forHover || not (List.mem name identsSeen))) - |> List.map mkLabel - | Cpattern {contextPath; prefix; nested; fallback; patternMode} -> ( - let fallbackOrEmpty ?items () = - match (fallback, items) with - | Some fallback, (None | Some []) -> - fallback |> processCompletable ~debug ~full ~scope ~env ~pos ~forHover - | _, Some items -> items - | None, None -> [] - in - match - contextPath - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:true ~scope - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos - with - | Some (typ, env) -> ( - match - typ - |> TypeUtils.extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (typ, typeArgContext) -> - typ |> TypeUtils.resolveNested ?typeArgContext ~env ~full ~nested) - with - | None -> fallbackOrEmpty () - | Some (typ, _env, completionContext, typeArgContext) -> - let items = - typ - |> completeTypedValue ?typeArgContext ~rawOpens - ~mode:(Pattern patternMode) ~full ~prefix ~completionContext - in - fallbackOrEmpty ~items ()) - | None -> fallbackOrEmpty ()) - | Cexpression {contextPath; prefix; nested} -> ( - let isAmbigiousRecordBodyOrJsxWrap = - match (contextPath, nested) with - | CJsxPropValue _, [NRecordBody _] -> true - | _ -> false - in - if Debug.verbose () then - (* This happens in this scenario: `}` - Here, we don't know whether `{}` is just wraps for the type of - `someProp`, or if it's a record body where we want to complete - for the fields in the record. We need to look up what the type is - first before deciding what completions to show. So we do that here.*) - if isAmbigiousRecordBodyOrJsxWrap then - print_endline - "[process_completable]--> Cexpression special case: JSX prop value \ - that might be record body or JSX wrap" - else print_endline "[process_completable]--> Cexpression"; - (* Completions for local things like variables in scope, modules in the - project, etc. We only add completions when there's a prefix of some sort - we can filter on, since we know we're in some sort of context, and - therefore don't want to overwhelm the user with completion items. *) - let regularCompletions = - if prefix = "" then [] - else - prefix - |> getComplementaryCompletionsForTypedValue ~opens ~allFiles ~env ~scope - in - match - contextPath - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:true ~scope - |> completionsGetCompletionType ~full - with - | None -> - if Debug.verbose () then - print_endline - "[process_completable]--> could not get completions for context path"; - regularCompletions - | Some (typ, env) -> ( - match typ |> TypeUtils.resolveNested ~env ~full ~nested with - | None -> - if Debug.verbose () then - print_endline - "[process_completable]--> could not resolve nested expression path"; - if isAmbigiousRecordBodyOrJsxWrap then ( - if Debug.verbose () then - print_endline - "[process_completable]--> case is ambigious Jsx prop vs record \ - body case, complete also for the JSX prop value directly"; - let itemsForRawJsxPropValue = - typ - |> completeTypedValue ~rawOpens ~mode:Expression ~full ~prefix - ~completionContext:None - in - itemsForRawJsxPropValue @ regularCompletions) - else regularCompletions - | Some (typ, _env, completionContext, typeArgContext) -> ( - if Debug.verbose () then - print_endline - "[process_completable]--> found type in nested expression \ - completion"; - (* Wrap the insert text in braces when we're completing the root of a - JSX prop value. *) - let wrapInsertTextInBraces = - if List.length nested > 0 then false - else - match contextPath with - | CJsxPropValue _ -> true - | _ -> false - in - let items = - typ - |> completeTypedValue ?typeArgContext ~rawOpens ~mode:Expression ~full - ~prefix ~completionContext - |> List.map (fun (c : Completion.t) -> - if wrapInsertTextInBraces then - { - c with - insertText = - (match c.insertText with - | None -> None - | Some text -> Some ("{" ^ text ^ "}")); - } - else c) - in - match (prefix, completionContext) with - | "", _ -> items - | _, None -> - let items = - if List.length regularCompletions > 0 then - (* The client will occasionally sort the list of completions alphabetically, disregarding the order - in which we send it. This fixes that by providing a sort text making the typed completions - guaranteed to end up on top. *) - items - |> List.map (fun (c : Completion.t) -> - {c with sortText = Some ("A" ^ " " ^ c.name)}) - else items - in - items @ regularCompletions - | _ -> items))) - | CexhaustiveSwitch {contextPath; exprLoc} -> - let range = Utils.rangeOfLoc exprLoc in - let printFailwithStr num = "${" ^ string_of_int num ^ ":%todo}" in - let withExhaustiveItem ~cases ?(startIndex = 0) (c : Completion.t) = - (* We don't need to write out `switch` here since we know that's what the - user has already written. Just complete for the rest. *) - let newText = - c.name ^ " {\n" - ^ (cases - |> List.mapi (fun index caseText -> - "| " ^ caseText ^ " => " - ^ printFailwithStr (startIndex + index + 1)) - |> String.concat "\n") - ^ "\n}" - |> Utils.indent range.start.character - in - [ - c; - { - c with - name = c.name ^ " (exhaustive switch)"; - filterText = Some c.name; - insertTextFormat = Some Snippet; - insertText = Some newText; - kind = Snippet "insert exhaustive switch for value"; - }; - ] - in - let completionsForContextPath = - contextPath - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:forHover ~scope - in - completionsForContextPath - |> List.map (fun (c : Completion.t) -> - match c.kind with - | Value typExpr -> ( - match typExpr |> TypeUtils.extractType ~env:c.env ~package with - | Some (Tvariant v, _) -> - withExhaustiveItem c - ~cases: - (v.constructors - |> List.map (fun (constructor : Constructor.t) -> - constructor.cname.txt - ^ - match constructor.args with - | Args [] -> "" - | _ -> "(_)")) - | Some (Tpolyvariant v, _) -> - withExhaustiveItem c - ~cases: - (v.constructors - |> List.map (fun (constructor : polyVariantConstructor) -> - "#" ^ constructor.displayName - ^ - match constructor.args with - | [] -> "" - | _ -> "(_)")) - | Some (Toption (_env, _typ), _) -> - withExhaustiveItem c ~cases:["Some($1)"; "None"] ~startIndex:1 - | Some (Tresult _, _) -> - withExhaustiveItem c ~cases:["Ok($1)"; "Error($1)"] ~startIndex:1 - | Some (Tbool _, _) -> - withExhaustiveItem c ~cases:["true"; "false"] - | _ -> [c]) - | _ -> [c]) - |> List.flatten - | ChtmlElement {prefix} -> - CompletionJsx.htmlElements - |> List.filter_map (fun (elementName, description, deprecated) -> - if Utils.startsWith elementName prefix then - let name = "<" ^ elementName ^ ">" in - Some - (Completion.create name ~synthetic:true ~kind:(Label name) - ~detail:description ~env ~docstring:[description] - ~insertText:elementName - ?deprecated: - (match deprecated with - | true -> Some "true" - | false -> None)) - else None) - | CextensionNode prefix -> - if Utils.startsWith "todo" prefix then - let detail = - "`%todo` is used to tell the compiler that some code still needs to be \ - implemented." - in - [ - Completion.create "todo" ~synthetic:true ~kind:(Label "todo") ~detail - ~env ~insertText:"todo"; - Completion.create "todo (with payload)" ~synthetic:true - ~includesSnippets:true ~kind:(Label "todo") - ~detail:(detail ^ " With a payload.") - ~env ~insertText:"todo(\"${0:TODO}\")"; - ] - else [] diff --git a/analysis/src/CompletionExpressions.ml b/analysis/src/CompletionExpressions.ml deleted file mode 100644 index 8356a48cfd2..00000000000 --- a/analysis/src/CompletionExpressions.ml +++ /dev/null @@ -1,302 +0,0 @@ -open SharedTypes - -let isExprHole exp = - match exp.Parsetree.pexp_desc with - | Pexp_extension ({txt = "rescript.exprhole"}, _) -> true - | _ -> false - -let isExprTuple expr = - match expr.Parsetree.pexp_desc with - | Pexp_tuple _ -> true - | _ -> false - -let rec traverseExpr (exp : Parsetree.expression) ~exprPath ~pos - ~firstCharBeforeCursorNoWhite = - let locHasCursor loc = loc |> CursorPosition.locHasCursor ~pos in - let someIfHasCursor v = if locHasCursor exp.pexp_loc then Some v else None in - match exp.pexp_desc with - | Pexp_ident {txt = Lident txt} when Utils.hasBraces exp.pexp_attributes -> - (* An ident with braces attribute corresponds to for example `{n}`. - Looks like a record but is parsed as an ident with braces. *) - someIfHasCursor (txt, [Completable.NRecordBody {seenFields = []}] @ exprPath) - | Pexp_ident {txt = Lident txt} -> someIfHasCursor (txt, exprPath) - | Pexp_construct ({txt = Lident "()"}, _) -> someIfHasCursor ("", exprPath) - | Pexp_construct ({txt = Lident txt}, None) -> someIfHasCursor (txt, exprPath) - | Pexp_variant (label, None) -> someIfHasCursor ("#" ^ label, exprPath) - | Pexp_array arrayPatterns -> ( - let nextExprPath = [Completable.NArray] @ exprPath in - (* No fields but still has cursor = empty completion *) - if List.length arrayPatterns = 0 && locHasCursor exp.pexp_loc then - Some ("", nextExprPath) - else - let arrayItemWithCursor = - arrayPatterns - |> List.find_map (fun e -> - e - |> traverseExpr ~exprPath:nextExprPath - ~firstCharBeforeCursorNoWhite ~pos) - in - - match (arrayItemWithCursor, locHasCursor exp.pexp_loc) with - | Some arrayItemWithCursor, _ -> Some arrayItemWithCursor - | None, true when firstCharBeforeCursorNoWhite = Some ',' -> - (* No item had the cursor, but the entire expr still has the cursor (so - the cursor is in the array somewhere), and the first char before the - cursor is a comma = interpret as compleing for a new value (example: - `[None, , None]`) *) - Some ("", nextExprPath) - | _ -> None) - | Pexp_tuple tupleItems when locHasCursor exp.pexp_loc -> - tupleItems - |> traverseExprTupleItems ~firstCharBeforeCursorNoWhite ~pos - ~nextExprPath:(fun itemNum -> - [Completable.NTupleItem {itemNum}] @ exprPath) - ~resultFromFoundItemNum:(fun itemNum -> - [Completable.NTupleItem {itemNum = itemNum + 1}] @ exprPath) - | Pexp_record ([], _) -> - (* Empty fields means we're in a record body `{}`. Complete for the fields. *) - someIfHasCursor ("", [Completable.NRecordBody {seenFields = []}] @ exprPath) - | Pexp_record (fields, _) -> ( - let fieldWithCursor = ref None in - let fieldWithExprHole = ref None in - Ext_list.iter fields (fun {lid = fname; x = exp} -> - match - ( fname.Location.txt, - exp.Parsetree.pexp_loc |> CursorPosition.classifyLoc ~pos ) - with - | Longident.Lident fname, HasCursor -> - fieldWithCursor := Some (fname, exp) - | Lident fname, _ when isExprHole exp -> - fieldWithExprHole := Some (fname, exp) - | _ -> ()); - let seenFields = - Ext_list.filter_map fields (fun {lid = fieldName} -> - match fieldName with - | {Location.txt = Longident.Lident fieldName} -> Some fieldName - | _ -> None) - in - match (!fieldWithCursor, !fieldWithExprHole) with - | Some (fname, f), _ | None, Some (fname, f) -> ( - match f.pexp_desc with - | Pexp_extension ({txt = "rescript.exprhole"}, _) -> - (* An expression hole means for example `{someField: }`. We want to complete for the type of `someField`. *) - someIfHasCursor - ("", [Completable.NFollowRecordField {fieldName = fname}] @ exprPath) - | Pexp_ident {txt = Lident txt} when fname = txt -> - (* This is a heuristic for catching writing field names. ReScript has punning for record fields, but the AST doesn't, - so punning is represented as the record field name and identifier being the same: {someField}. *) - someIfHasCursor (txt, [Completable.NRecordBody {seenFields}] @ exprPath) - | Pexp_ident {txt = Lident txt} -> - (* A var means `{someField: s}` or similar. Complete for identifiers or values. *) - someIfHasCursor (txt, exprPath) - | _ -> - f - |> traverseExpr ~firstCharBeforeCursorNoWhite ~pos - ~exprPath: - ([Completable.NFollowRecordField {fieldName = fname}] @ exprPath) - ) - | None, None -> ( - if Debug.verbose () then ( - Printf.printf "[traverse_expr] No field with cursor and no expr hole.\n"; - - match firstCharBeforeCursorNoWhite with - | None -> () - | Some c -> - Printf.printf "[traverse_expr] firstCharBeforeCursorNoWhite: %c.\n" c); - - (* Figure out if we're completing for a new field. - If the cursor is inside of the record body, but no field has the cursor, - and there's no pattern hole. Check the first char to the left of the cursor, - ignoring white space. If that's a comma or {, we assume you're completing for a new field, - since you're either between 2 fields (comma to the left) or at the start of the record ({). *) - match firstCharBeforeCursorNoWhite with - | Some (',' | '{') -> - someIfHasCursor ("", [Completable.NRecordBody {seenFields}] @ exprPath) - | _ -> None)) - | Pexp_construct - ( {txt}, - Some {pexp_loc; pexp_desc = Pexp_construct ({txt = Lident "()"}, _)} ) - when locHasCursor pexp_loc -> - (* Empty payload with cursor, like: Test() *) - Some - ( "", - [ - Completable.NVariantPayload - {constructorName = Utils.getUnqualifiedName txt; itemNum = 0}; - ] - @ exprPath ) - | Pexp_construct ({txt}, Some e) - when pos >= (e.pexp_loc |> Loc.end_) - && firstCharBeforeCursorNoWhite = Some ',' - && isExprTuple e = false -> - (* Empty payload with trailing ',', like: Test(true, ) *) - Some - ( "", - [ - Completable.NVariantPayload - {constructorName = Utils.getUnqualifiedName txt; itemNum = 1}; - ] - @ exprPath ) - | Pexp_construct ({txt}, Some {pexp_loc; pexp_desc = Pexp_tuple tupleItems}) - when locHasCursor pexp_loc -> - tupleItems - |> traverseExprTupleItems ~firstCharBeforeCursorNoWhite ~pos - ~nextExprPath:(fun itemNum -> - [ - Completable.NVariantPayload - {constructorName = Utils.getUnqualifiedName txt; itemNum}; - ] - @ exprPath) - ~resultFromFoundItemNum:(fun itemNum -> - [ - Completable.NVariantPayload - { - constructorName = Utils.getUnqualifiedName txt; - itemNum = itemNum + 1; - }; - ] - @ exprPath) - | Pexp_construct ({txt}, Some p) when locHasCursor exp.pexp_loc -> - p - |> traverseExpr ~firstCharBeforeCursorNoWhite ~pos - ~exprPath: - ([ - Completable.NVariantPayload - {constructorName = Utils.getUnqualifiedName txt; itemNum = 0}; - ] - @ exprPath) - | Pexp_variant - (txt, Some {pexp_loc; pexp_desc = Pexp_construct ({txt = Lident "()"}, _)}) - when locHasCursor pexp_loc -> - (* Empty payload with cursor, like: #test() *) - Some - ( "", - [Completable.NPolyvariantPayload {constructorName = txt; itemNum = 0}] - @ exprPath ) - | Pexp_variant (txt, Some e) - when pos >= (e.pexp_loc |> Loc.end_) - && firstCharBeforeCursorNoWhite = Some ',' - && isExprTuple e = false -> - (* Empty payload with trailing ',', like: #test(true, ) *) - Some - ( "", - [Completable.NPolyvariantPayload {constructorName = txt; itemNum = 1}] - @ exprPath ) - | Pexp_variant (txt, Some {pexp_loc; pexp_desc = Pexp_tuple tupleItems}) - when locHasCursor pexp_loc -> - tupleItems - |> traverseExprTupleItems ~firstCharBeforeCursorNoWhite ~pos - ~nextExprPath:(fun itemNum -> - [Completable.NPolyvariantPayload {constructorName = txt; itemNum}] - @ exprPath) - ~resultFromFoundItemNum:(fun itemNum -> - [ - Completable.NPolyvariantPayload - {constructorName = txt; itemNum = itemNum + 1}; - ] - @ exprPath) - | Pexp_variant (txt, Some p) when locHasCursor exp.pexp_loc -> - p - |> traverseExpr ~firstCharBeforeCursorNoWhite ~pos - ~exprPath: - ([ - Completable.NPolyvariantPayload - {constructorName = txt; itemNum = 0}; - ] - @ exprPath) - | _ -> None - -and traverseExprTupleItems tupleItems ~nextExprPath ~resultFromFoundItemNum ~pos - ~firstCharBeforeCursorNoWhite = - let itemNum = ref (-1) in - let itemWithCursor = - tupleItems - |> List.find_map (fun e -> - itemNum := !itemNum + 1; - e - |> traverseExpr ~exprPath:(nextExprPath !itemNum) - ~firstCharBeforeCursorNoWhite ~pos) - in - match (itemWithCursor, firstCharBeforeCursorNoWhite) with - | None, Some ',' -> - (* No tuple item has the cursor, but there's a comma before the cursor. - Figure out what arg we're trying to complete. Example: (true, , None) *) - let posNum = ref (-1) in - tupleItems - |> List.iteri (fun index e -> - if pos >= Loc.start e.Parsetree.pexp_loc then posNum := index); - if !posNum > -1 then Some ("", resultFromFoundItemNum !posNum) else None - | v, _ -> v - -let prettyPrintFnTemplateArgName ?currentIndex ~env ~full - (argTyp : Types.type_expr) = - let indexText = - match currentIndex with - | None -> "" - | Some i -> string_of_int i - in - let defaultVarName = "v" ^ indexText in - let argTyp, suffix, _env = - TypeUtils.digToRelevantTemplateNameType ~env ~package:full.package argTyp - in - match argTyp |> TypeUtils.pathFromTypeExpr with - | None -> defaultVarName - | Some p -> ( - let trailingElementsOfPath = - p |> Utils.expandPath |> List.rev |> Utils.lastElements - in - match trailingElementsOfPath with - | [] | ["t"] -> defaultVarName - | ["unit"] -> "()" - (* Special treatment for JsxEvent, since that's a common enough thing - used in event handlers. *) - | ["JsxEvent"; "synthetic"] -> "event" - | ["synthetic"] -> "event" - (* Ignore `t` types, and go for its module name instead. *) - | [someName; "t"] | [_; someName] | [someName] -> ( - match someName with - | "string" | "int" | "float" | "array" | "option" | "bool" -> - defaultVarName - | someName when String.length someName < 30 -> - if someName = "synthetic" then - Printf.printf "synthetic! %s\n" - (trailingElementsOfPath |> SharedTypes.ident); - (* We cap how long the name can be, so we don't end up with super - long type names. *) - (someName |> Utils.lowercaseFirstChar) ^ suffix - | _ -> defaultVarName) - | _ -> defaultVarName) - -let completeConstructorPayload ~posBeforeCursor ~firstCharBeforeCursorNoWhite - (constructorLid : Longident.t Location.loc) expr = - match - traverseExpr expr ~exprPath:[] ~pos:posBeforeCursor - ~firstCharBeforeCursorNoWhite - with - | None -> None - | Some (prefix, nested) -> - (* The nested path must start with the constructor name found, plus - the target argument number for the constructor. We translate to - that here, because we need to account for multi arg constructors - being represented as tuples. *) - let nested = - match List.rev nested with - | Completable.NTupleItem {itemNum} :: rest -> - [ - Completable.NVariantPayload - {constructorName = Longident.last constructorLid.txt; itemNum}; - ] - @ rest - | nested -> - [ - Completable.NVariantPayload - {constructorName = Longident.last constructorLid.txt; itemNum = 0}; - ] - @ nested - in - let variantCtxPath = - Completable.CTypeAtPos - {constructorLid.loc with loc_start = constructorLid.loc.loc_end} - in - Some - (Completable.Cexpression {contextPath = variantCtxPath; prefix; nested}) diff --git a/analysis/src/CompletionPatterns.ml b/analysis/src/CompletionPatterns.ml deleted file mode 100644 index 8755c48457f..00000000000 --- a/analysis/src/CompletionPatterns.ml +++ /dev/null @@ -1,257 +0,0 @@ -open SharedTypes - -let isPatternHole pat = - match pat.Parsetree.ppat_desc with - | Ppat_extension ({txt = "rescript.patternhole"}, _) -> true - | _ -> false - -let isPatternTuple pat = - match pat.Parsetree.ppat_desc with - | Ppat_tuple _ -> true - | _ -> false - -let rec traverseTupleItems tupleItems ~nextPatternPath ~resultFromFoundItemNum - ~locHasCursor ~firstCharBeforeCursorNoWhite ~posBeforeCursor = - let itemNum = ref (-1) in - let itemWithCursor = - tupleItems - |> List.find_map (fun pat -> - itemNum := !itemNum + 1; - pat - |> traversePattern ~patternPath:(nextPatternPath !itemNum) - ~locHasCursor ~firstCharBeforeCursorNoWhite ~posBeforeCursor) - in - match (itemWithCursor, firstCharBeforeCursorNoWhite) with - | None, Some ',' -> - (* No tuple item has the cursor, but there's a comma before the cursor. - Figure out what arg we're trying to complete. Example: (true, , None) *) - let posNum = ref (-1) in - tupleItems - |> List.iteri (fun index pat -> - if posBeforeCursor >= Loc.start pat.Parsetree.ppat_loc then - posNum := index); - if !posNum > -1 then Some ("", resultFromFoundItemNum !posNum) else None - | v, _ -> v - -and traversePattern (pat : Parsetree.pattern) ~patternPath ~locHasCursor - ~firstCharBeforeCursorNoWhite ~posBeforeCursor = - let someIfHasCursor v debugId = - if locHasCursor pat.Parsetree.ppat_loc then ( - if Debug.verbose () then - Printf.printf - "[traversePattern:someIfHasCursor] '%s' has cursor, returning \n" - debugId; - Some v) - else None - in - match pat.ppat_desc with - | Ppat_constant _ | Ppat_interval _ -> None - | Ppat_constraint (p, _) - | Ppat_alias (p, _) - | Ppat_exception p - | Ppat_open (_, p) -> - p - |> traversePattern ~patternPath ~locHasCursor ~firstCharBeforeCursorNoWhite - ~posBeforeCursor - | Ppat_or (p1, p2) -> ( - let orPatWithItem = - [p1; p2] - |> List.find_map (fun p -> - p - |> traversePattern ~patternPath ~locHasCursor - ~firstCharBeforeCursorNoWhite ~posBeforeCursor) - in - match orPatWithItem with - | None when isPatternHole p1 || isPatternHole p2 -> - if Debug.verbose () then - Printf.printf - "[traversePattern] found or-pattern that was pattern hole\n"; - Some ("", patternPath) - | v -> v) - | Ppat_any -> - (* We treat any `_` as an empty completion. This is mainly because we're - inserting `_` in snippets and automatically put the cursor there. So - letting it trigger an empty completion improves the ergonomics by a - lot. *) - someIfHasCursor ("", patternPath) "Ppat_any" - | Ppat_var {txt} -> someIfHasCursor (txt, patternPath) "Ppat_var" - | Ppat_construct ({txt = Lident "()"}, None) -> - (* switch s { | () }*) - someIfHasCursor - ("", patternPath @ [Completable.NTupleItem {itemNum = 0}]) - "Ppat_construct()" - | Ppat_construct ({txt = Lident prefix}, None) -> - someIfHasCursor (prefix, patternPath) "Ppat_construct(Lident)" - | Ppat_variant (prefix, None) -> - someIfHasCursor ("#" ^ prefix, patternPath) "Ppat_variant" - | Ppat_array arrayPatterns -> - let nextPatternPath = [Completable.NArray] @ patternPath in - if List.length arrayPatterns = 0 && locHasCursor pat.ppat_loc then - Some ("", nextPatternPath) - else - arrayPatterns - |> List.find_map (fun pat -> - pat - |> traversePattern ~patternPath:nextPatternPath ~locHasCursor - ~firstCharBeforeCursorNoWhite ~posBeforeCursor) - | Ppat_tuple tupleItems when locHasCursor pat.ppat_loc -> - tupleItems - |> traverseTupleItems ~firstCharBeforeCursorNoWhite ~posBeforeCursor - ~locHasCursor - ~nextPatternPath:(fun itemNum -> - [Completable.NTupleItem {itemNum}] @ patternPath) - ~resultFromFoundItemNum:(fun itemNum -> - [Completable.NTupleItem {itemNum = itemNum + 1}] @ patternPath) - | Ppat_record ([], _) -> - (* Empty fields means we're in a record body `{}`. Complete for the fields. *) - someIfHasCursor - ("", [Completable.NRecordBody {seenFields = []}] @ patternPath) - "Ppat_record(empty)" - | Ppat_record (fields, _) -> ( - let fieldWithCursor = ref None in - let fieldWithPatHole = ref None in - Ext_list.iter fields (fun {lid = fname; x = f} -> - match - ( fname.Location.txt, - f.Parsetree.ppat_loc - |> CursorPosition.classifyLoc ~pos:posBeforeCursor ) - with - | Longident.Lident fname, HasCursor -> fieldWithCursor := Some (fname, f) - | Lident fname, _ when isPatternHole f -> - fieldWithPatHole := Some (fname, f) - | _ -> ()); - let seenFields = - Ext_list.filter_map fields (fun {lid = fieldName} -> - match fieldName with - | {Location.txt = Longident.Lident fieldName} -> Some fieldName - | _ -> None) - in - match (!fieldWithCursor, !fieldWithPatHole) with - | Some (fname, f), _ | None, Some (fname, f) -> ( - match f.ppat_desc with - | Ppat_extension ({txt = "rescript.patternhole"}, _) -> - (* A pattern hole means for example `{someField: }`. We want to complete for the type of `someField`. *) - someIfHasCursor - ( "", - [Completable.NFollowRecordField {fieldName = fname}] @ patternPath - ) - "patternhole" - | Ppat_var {txt} -> - (* A var means `{s}` or similar. Complete for fields. *) - someIfHasCursor - (txt, [Completable.NRecordBody {seenFields}] @ patternPath) - "Ppat_var #2" - | _ -> - f - |> traversePattern - ~patternPath: - ([Completable.NFollowRecordField {fieldName = fname}] - @ patternPath) - ~locHasCursor ~firstCharBeforeCursorNoWhite ~posBeforeCursor) - | None, None -> ( - (* Figure out if we're completing for a new field. - If the cursor is inside of the record body, but no field has the cursor, - and there's no pattern hole. Check the first char to the left of the cursor, - ignoring white space. If that's a comma, we assume you're completing for a new field. *) - match firstCharBeforeCursorNoWhite with - | Some ',' -> - someIfHasCursor - ("", [Completable.NRecordBody {seenFields}] @ patternPath) - "firstCharBeforeCursorNoWhite:," - | _ -> None)) - | Ppat_construct - ( {txt}, - Some {ppat_loc; ppat_desc = Ppat_construct ({txt = Lident "()"}, _)} ) - when locHasCursor ppat_loc -> - (* Empty payload with cursor, like: Test() *) - Some - ( "", - [ - Completable.NVariantPayload - {constructorName = Utils.getUnqualifiedName txt; itemNum = 0}; - ] - @ patternPath ) - | Ppat_construct ({txt}, Some pat) - when posBeforeCursor >= (pat.ppat_loc |> Loc.end_) - && firstCharBeforeCursorNoWhite = Some ',' - && isPatternTuple pat = false -> - (* Empty payload with trailing ',', like: Test(true, ) *) - Some - ( "", - [ - Completable.NVariantPayload - {constructorName = Utils.getUnqualifiedName txt; itemNum = 1}; - ] - @ patternPath ) - | Ppat_construct ({txt}, Some {ppat_loc; ppat_desc = Ppat_tuple tupleItems}) - when locHasCursor ppat_loc -> - tupleItems - |> traverseTupleItems ~locHasCursor ~firstCharBeforeCursorNoWhite - ~posBeforeCursor - ~nextPatternPath:(fun itemNum -> - [ - Completable.NVariantPayload - {constructorName = Utils.getUnqualifiedName txt; itemNum}; - ] - @ patternPath) - ~resultFromFoundItemNum:(fun itemNum -> - [ - Completable.NVariantPayload - { - constructorName = Utils.getUnqualifiedName txt; - itemNum = itemNum + 1; - }; - ] - @ patternPath) - | Ppat_construct ({txt}, Some p) when locHasCursor pat.ppat_loc -> - p - |> traversePattern ~locHasCursor ~firstCharBeforeCursorNoWhite - ~posBeforeCursor - ~patternPath: - ([ - Completable.NVariantPayload - {constructorName = Utils.getUnqualifiedName txt; itemNum = 0}; - ] - @ patternPath) - | Ppat_variant - (txt, Some {ppat_loc; ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}) - when locHasCursor ppat_loc -> - (* Empty payload with cursor, like: #test() *) - Some - ( "", - [Completable.NPolyvariantPayload {constructorName = txt; itemNum = 0}] - @ patternPath ) - | Ppat_variant (txt, Some pat) - when posBeforeCursor >= (pat.ppat_loc |> Loc.end_) - && firstCharBeforeCursorNoWhite = Some ',' - && isPatternTuple pat = false -> - (* Empty payload with trailing ',', like: #test(true, ) *) - Some - ( "", - [Completable.NPolyvariantPayload {constructorName = txt; itemNum = 1}] - @ patternPath ) - | Ppat_variant (txt, Some {ppat_loc; ppat_desc = Ppat_tuple tupleItems}) - when locHasCursor ppat_loc -> - tupleItems - |> traverseTupleItems ~locHasCursor ~firstCharBeforeCursorNoWhite - ~posBeforeCursor - ~nextPatternPath:(fun itemNum -> - [Completable.NPolyvariantPayload {constructorName = txt; itemNum}] - @ patternPath) - ~resultFromFoundItemNum:(fun itemNum -> - [ - Completable.NPolyvariantPayload - {constructorName = txt; itemNum = itemNum + 1}; - ] - @ patternPath) - | Ppat_variant (txt, Some p) when locHasCursor pat.ppat_loc -> - p - |> traversePattern ~locHasCursor ~firstCharBeforeCursorNoWhite - ~posBeforeCursor - ~patternPath: - ([ - Completable.NPolyvariantPayload - {constructorName = txt; itemNum = 0}; - ] - @ patternPath) - | _ -> None diff --git a/analysis/src/CreateInterface.ml b/analysis/src/CreateInterface.ml deleted file mode 100644 index c78548e0d9c..00000000000 --- a/analysis/src/CreateInterface.ml +++ /dev/null @@ -1,326 +0,0 @@ -module SourceFileExtractor = struct - let create ~path = - match Files.readFile path with - | None -> [||] - | Some text -> text |> String.split_on_char '\n' |> Array.of_list - - let extract lines ~posStart ~posEnd = - let lineStart, colStart = posStart in - let lineEnd, colEnd = posEnd in - let res = ref [] in - if lineStart < 0 || lineStart > lineEnd || lineEnd >= Array.length lines - then [] - else ( - for n = lineEnd downto lineStart do - let line = lines.(n) in - let len = String.length line in - if n = lineStart && n = lineEnd then ( - if colStart >= 0 && colStart < colEnd && colEnd <= len then - let indent = String.make colStart ' ' in - res := - (indent ^ String.sub line colStart (colEnd - colStart)) :: !res) - else if n = lineStart then ( - if colStart >= 0 && colStart < len then - let indent = String.make colStart ' ' in - res := (indent ^ String.sub line colStart (len - colStart)) :: !res) - else if n = lineEnd then ( - if colEnd > 0 && colEnd <= len then - res := String.sub line 0 colEnd :: !res) - else res := line :: !res - done; - !res) -end - -module AttributesUtils : sig - type t - - val make : string list -> t - - val contains : string -> t -> bool - - val toString : t -> string -end = struct - type attribute = {line: int; offset: int; name: string} - type t = attribute list - type parseState = Search | Collect of int - - let make lines = - let makeAttr lineIdx attrOffsetStart attrOffsetEnd line = - { - line = lineIdx; - offset = attrOffsetStart; - name = String.sub line attrOffsetStart (attrOffsetEnd - attrOffsetStart); - } - in - let res = ref [] in - lines - |> List.iteri (fun lineIdx line -> - let state = ref Search in - for i = 0 to String.length line - 1 do - let ch = line.[i] in - match (!state, ch) with - | Search, '@' -> state := Collect i - | Collect attrOffset, ' ' -> - res := makeAttr lineIdx attrOffset i line :: !res; - state := Search - | Search, _ | Collect _, _ -> () - done; - - match !state with - | Collect attrOffset -> - res := - makeAttr lineIdx attrOffset (String.length line) line :: !res - | _ -> ()); - !res |> List.rev - - let contains attributeForSearch t = - t |> List.exists (fun {name} -> name = attributeForSearch) - - let toString t = - match t with - | [] -> "" - | {line} :: _ -> - let prevLine = ref line in - let buffer = ref "" in - let res = ref [] in - t - |> List.iter (fun attr -> - let {line; offset; name} = attr in - - if line <> !prevLine then ( - res := !buffer :: !res; - buffer := ""; - prevLine := line); - - let indent = String.make (offset - String.length !buffer) ' ' in - buffer := !buffer ^ indent ^ name); - res := !buffer :: !res; - !res |> List.rev |> String.concat "\n" -end - -let printSignature ~extractor ~signature = - Printtyp.reset_names (); - let sigItemToString (item : Outcometree.out_sig_item) = - item |> Res_outcome_printer.print_out_sig_item_doc - |> Res_doc.to_string ~width:Res_printer.default_print_width - in - - let genSigStrForInlineAttr lines attributes id vd = - let divider = if List.length lines > 1 then "\n" else " " in - - let sigStr = - sigItemToString - (Printtyp.tree_of_value_description id {vd with val_kind = Val_reg}) - in - - (attributes |> AttributesUtils.toString) ^ divider ^ sigStr ^ "\n" - in - - let buf = Buffer.create 10 in - - let getComponentType (typ : Types.type_expr) = - let reactElement = - Ctype.newconstr (Pdot (Pident (Ident.create "React"), "element", 0)) [] - in - match typ.desc with - | Tarrow - ( {typ = {desc = Tconstr (Path.Pident propsId, typeArgs, _)}}, - retType, - _, - _ ) - when Ident.name propsId = "props" -> - Some (typeArgs, retType) - | Tconstr - ( Pdot (Pident {name = "React"}, "component", _), - [{desc = Tconstr (Path.Pident propsId, typeArgs, _)}], - _ ) - when Ident.name propsId = "props" -> - Some (typeArgs, reactElement) - | Tconstr - ( Pdot (Pident {name = "React"}, "componentLike", _), - [{desc = Tconstr (Path.Pident propsId, typeArgs, _)}; retType], - _ ) - when Ident.name propsId = "props" -> - Some (typeArgs, retType) - | _ -> None - in - - let rec processSignature ~indent (signature : Types.signature) : unit = - match signature with - | Sig_type - (propsId, {type_params; type_kind = Type_record (labelDecls, _)}, _) - :: Sig_value (makeId (* make *), makeValueDesc) - :: rest - when Ident.name propsId = "props" - && getComponentType makeValueDesc.val_type <> None -> - (* PPX V4 component declaration: - type props = {...} - let v = ... - *) - let newItemStr = - let typeArgs, retType = - match getComponentType makeValueDesc.val_type with - | Some x -> x - | None -> assert false - in - let rec mkFunType (labelDecls : Types.label_declaration list) = - match labelDecls with - | [] -> retType - | labelDecl :: rest -> - let propType = - TypeUtils.instantiateType ~typeParams:type_params ~typeArgs - labelDecl.ld_type - in - let lblName = labelDecl.ld_id |> Ident.name in - let lbl = - if labelDecl.ld_optional then - Asttypes.Optional {txt = lblName; loc = Location.none} - else Asttypes.Labelled {txt = lblName; loc = Location.none} - in - { - retType with - desc = Tarrow ({lbl; typ = propType}, mkFunType rest, Cok, None); - } - in - let funType = - if List.length labelDecls = 0 (* No props *) then - let tUnit = - Ctype.newconstr (Path.Pident (Ident.create "unit")) [] - in - { - retType with - desc = Tarrow ({lbl = Nolabel; typ = tUnit}, retType, Cok, None); - } - else mkFunType labelDecls - in - sigItemToString - (Printtyp.tree_of_value_description makeId - {makeValueDesc with val_type = funType}) - in - Buffer.add_string buf (indent ^ "@react.component\n"); - Buffer.add_string buf (indent ^ newItemStr ^ "\n"); - processSignature ~indent rest - | Sig_module (id, modDecl, recStatus) :: rest -> - let colonOrEquals = - match modDecl.md_type with - | Mty_alias _ -> " = " - | _ -> ": " - in - Buffer.add_string buf - (indent - ^ (match recStatus with - | Trec_not -> "module " - | Trec_first -> "module rec " - | Trec_next -> "and ") - ^ Ident.name id ^ colonOrEquals); - processModuleType ~indent modDecl.md_type; - Buffer.add_string buf "\n"; - processSignature ~indent rest - | Sig_modtype (id, mtd) :: rest -> - let () = - match mtd.mtd_type with - | None -> - Buffer.add_string buf (indent ^ "module type " ^ Ident.name id ^ "\n") - | Some mt -> - Buffer.add_string buf (indent ^ "module type " ^ Ident.name id ^ " = "); - processModuleType ~indent mt; - Buffer.add_string buf "\n" - in - processSignature ~indent rest - | Sig_value (id, ({val_kind = Val_prim prim; val_loc} as vd)) :: items - when prim.prim_native_name <> "" && prim.prim_native_name.[0] = '\132' -> - (* Rescript primitive name, e.g. @val external ... *) - let lines = - let posStart, posEnd = Loc.range val_loc in - extractor |> SourceFileExtractor.extract ~posStart ~posEnd - in - let attributes = AttributesUtils.make lines in - - if AttributesUtils.contains "@inline" attributes then - (* Generate type signature for @inline declaration *) - Buffer.add_string buf (genSigStrForInlineAttr lines attributes id vd) - else - (* Copy the external declaration verbatim from the implementation file *) - Buffer.add_string buf ((lines |> String.concat "\n") ^ "\n"); - - processSignature ~indent items - | Sig_value (id, vd) :: items -> - let newItemStr = - sigItemToString (Printtyp.tree_of_value_description id vd) - in - Buffer.add_string buf (indent ^ newItemStr ^ "\n"); - processSignature ~indent items - | Sig_type (_id, typeDecl, _recStatus) :: items -> - let lines = - let posStart, posEnd = Loc.range typeDecl.type_loc in - extractor |> SourceFileExtractor.extract ~posStart ~posEnd - in - (* Copy the type declaration verbatim to preserve attributes *) - Buffer.add_string buf ((lines |> String.concat "\n") ^ "\n"); - processSignature ~indent items - | Sig_typext (id, extConstr, extStatus) :: items -> - let newItemStr = - sigItemToString - (Printtyp.tree_of_extension_constructor id extConstr extStatus) - in - Buffer.add_string buf (indent ^ newItemStr ^ "\n"); - processSignature ~indent items - | Sig_class _ :: items -> - (* not needed *) - processSignature ~indent items - | Sig_class_type _ :: items -> - (* not needed *) - processSignature ~indent items - | [] -> () - and processModuleType ~indent (mt : Types.module_type) = - match mt with - | Mty_signature signature -> - Buffer.add_string buf "{\n"; - processSignature ~indent:(indent ^ " ") signature; - Buffer.add_string buf (indent ^ "}") - | Mty_functor _ -> - let rec collectFunctorArgs ~args (mt : Types.module_type) = - match mt with - | Mty_functor (id, None, mt) when Ident.name id = "*" -> - (* AST encoding of functor with no arguments *) - collectFunctorArgs ~args mt - | Mty_functor (id, mto, mt) -> - collectFunctorArgs ~args:((id, mto) :: args) mt - | mt -> (List.rev args, mt) - in - let args, retMt = collectFunctorArgs ~args:[] mt in - Buffer.add_string buf "("; - args - |> List.iter (fun (id, mto) -> - Buffer.add_string buf ("\n" ^ indent ^ " "); - (match mto with - | None -> Buffer.add_string buf (Ident.name id) - | Some mt -> - Buffer.add_string buf (Ident.name id ^ ": "); - processModuleType ~indent:(indent ^ " ") mt); - Buffer.add_string buf ","); - if args <> [] then Buffer.add_string buf ("\n" ^ indent); - Buffer.add_string buf (") =>\n" ^ indent); - processModuleType ~indent retMt - | Mty_ident path | Mty_alias (_, path) -> - let rec outIdentToString (ident : Outcometree.out_ident) = - match ident with - | Oide_ident s -> s - | Oide_dot (ident, s) -> outIdentToString ident ^ "." ^ s - | Oide_apply (call, arg) -> - outIdentToString call ^ "(" ^ outIdentToString arg ^ ")" - in - Buffer.add_string buf (outIdentToString (Printtyp.tree_of_path path)) - in - - processSignature ~indent:"" signature; - Buffer.contents buf - -let command ~path ~cmiFile = - match Shared.tryReadCmi cmiFile with - | Some cmi_info -> - (* For reading the config *) - let _ = Cmt.loadFullCmtFromPath ~path in - let extractor = SourceFileExtractor.create ~path in - printSignature ~extractor ~signature:cmi_info.cmi_sign - | None -> "" diff --git a/analysis/src/Debug.ml b/analysis/src/Debug.ml deleted file mode 100644 index d19d7dfa5a9..00000000000 --- a/analysis/src/Debug.ml +++ /dev/null @@ -1,13 +0,0 @@ -type debugLevel = Off | Regular | Verbose - -let debugLevel = ref Off - -let log s = - match !debugLevel with - | Regular | Verbose -> print_endline s - | Off -> () - -let debugPrintEnv (env : SharedTypes.QueryEnv.t) = - env.pathRev @ [env.file.moduleName] |> List.rev |> String.concat "." - -let verbose () = !debugLevel = Verbose diff --git a/analysis/src/DotCompletionUtils.ml b/analysis/src/DotCompletionUtils.ml deleted file mode 100644 index fc257427901..00000000000 --- a/analysis/src/DotCompletionUtils.ml +++ /dev/null @@ -1,42 +0,0 @@ -let filterRecordFields ~env ~recordAsString ~prefix ~exact fields = - fields - |> Utils.filterMap (fun (field : SharedTypes.field) -> - if Utils.checkName field.fname.txt ~prefix ~exact then - Some - (SharedTypes.Completion.create field.fname.txt ~env - ?deprecated:field.deprecated ~docstring:field.docstring - ~kind:(SharedTypes.Completion.Field (field, recordAsString))) - else None) - -let fieldCompletionsForDotCompletion ?posOfDot typ ~env ~package ~prefix ~exact - = - let asObject = typ |> TypeUtils.extractObjectType ~env ~package in - match asObject with - | Some (objEnv, obj) -> - (* Handle obj completion via dot *) - if Debug.verbose () then - Printf.printf "[dot_completion]--> Obj type found:\n"; - obj |> TypeUtils.getObjFields - |> Utils.filterMap (fun (field, _typ) -> - if Utils.checkName field ~prefix ~exact then - let fullObjFieldName = Printf.sprintf "[\"%s\"]" field in - Some - (SharedTypes.Completion.create fullObjFieldName ~synthetic:true - ~insertText:fullObjFieldName ~env:objEnv - ~kind:(SharedTypes.Completion.ObjLabel typ) - ?additionalTextEdits: - (match posOfDot with - | None -> None - | Some posOfDot -> - Some - (TypeUtils.makeAdditionalTextEditsForRemovingDot - posOfDot))) - else None) - | None -> ( - match typ |> TypeUtils.extractRecordType ~env ~package with - | Some (env, fields, typDecl) -> - fields - |> filterRecordFields ~env ~prefix ~exact - ~recordAsString: - (typDecl.item.decl |> Shared.declToString typDecl.name.txt) - | None -> []) diff --git a/analysis/src/DumpAst.ml b/analysis/src/DumpAst.ml deleted file mode 100644 index c21cff6b66d..00000000000 --- a/analysis/src/DumpAst.ml +++ /dev/null @@ -1,323 +0,0 @@ -open SharedTypes -(* This is intended to be a debug tool. It's by no means complete. Rather, you're encouraged to extend this with printing whatever types you need printing. *) - -let emptyLocDenom = "" -let hasCursorDenom = "<*>" -let noCursorDenom = "" - -let printLocDenominator loc ~pos = - match loc |> CursorPosition.classifyLoc ~pos with - | EmptyLoc -> emptyLocDenom - | HasCursor -> hasCursorDenom - | NoCursor -> noCursorDenom - -let printLocDenominatorLoc loc ~pos = - match loc |> CursorPosition.classifyLocationLoc ~pos with - | CursorPosition.EmptyLoc -> emptyLocDenom - | HasCursor -> hasCursorDenom - | NoCursor -> noCursorDenom - -let printLocDenominatorPos pos ~posStart ~posEnd = - match CursorPosition.classifyPositions pos ~posStart ~posEnd with - | CursorPosition.EmptyLoc -> emptyLocDenom - | HasCursor -> hasCursorDenom - | NoCursor -> noCursorDenom - -let addIndentation indentation = - let rec indent str indentation = - if indentation < 1 then str else indent (str ^ " ") (indentation - 1) - in - indent "" indentation - -let printAttributes attributes = - match List.length attributes with - | 0 -> "" - | _ -> - "[" - ^ (attributes - |> List.map (fun ({Location.txt}, _payload) -> "@" ^ txt) - |> String.concat ",") - ^ "]" - -let printConstant const = - match const with - | Parsetree.Pconst_integer (s, _) -> "Pconst_integer(" ^ s ^ ")" - | Pconst_char c -> "Pconst_char(" ^ String.make 1 (Char.chr c) ^ ")" - | Pconst_string (s, delim) -> - let delim = - match delim with - | None -> "" - | Some delim -> delim ^ " " - in - "Pconst_string(" ^ delim ^ s ^ delim ^ ")" - | Pconst_float (s, _) -> "Pconst_float(" ^ s ^ ")" - -let printCoreType typ ~pos = - printAttributes typ.Parsetree.ptyp_attributes - ^ (typ.ptyp_loc |> printLocDenominator ~pos) - ^ - match typ.ptyp_desc with - | Ptyp_any -> "Ptyp_any" - | Ptyp_var name -> "Ptyp_var(" ^ str name ^ ")" - | Ptyp_constr (lid, _types) -> - "Ptyp_constr(" - ^ (lid |> printLocDenominatorLoc ~pos) - ^ (Utils.flattenLongIdent lid.txt |> ident |> str) - ^ ")" - | Ptyp_variant _ -> "Ptyp_variant()" - | _ -> "" - -let rec printPattern pattern ~pos ~indentation = - printAttributes pattern.Parsetree.ppat_attributes - ^ (pattern.ppat_loc |> printLocDenominator ~pos) - ^ - match pattern.Parsetree.ppat_desc with - | Ppat_or (pat1, pat2) -> - "Ppat_or(\n" - ^ addIndentation (indentation + 1) - ^ printPattern pat1 ~pos ~indentation:(indentation + 2) - ^ ",\n" - ^ addIndentation (indentation + 1) - ^ printPattern pat2 ~pos ~indentation:(indentation + 2) - ^ "\n" ^ addIndentation indentation ^ ")" - | Ppat_extension (({txt} as loc), _) -> - "Ppat_extension(%" ^ (loc |> printLocDenominatorLoc ~pos) ^ txt ^ ")" - | Ppat_var ({txt} as loc) -> - "Ppat_var(" ^ (loc |> printLocDenominatorLoc ~pos) ^ txt ^ ")" - | Ppat_constant const -> "Ppat_constant(" ^ printConstant const ^ ")" - | Ppat_construct (({txt} as loc), maybePat) -> - "Ppat_construct(" - ^ (loc |> printLocDenominatorLoc ~pos) - ^ (Utils.flattenLongIdent txt |> ident |> str) - ^ (match maybePat with - | None -> "" - | Some pat -> "," ^ printPattern pat ~pos ~indentation) - ^ ")" - | Ppat_variant (label, maybePat) -> - "Ppat_variant(" ^ str label - ^ (match maybePat with - | None -> "" - | Some pat -> "," ^ printPattern pat ~pos ~indentation) - ^ ")" - | Ppat_record (fields, _) -> - "Ppat_record(\n" - ^ addIndentation (indentation + 1) - ^ "fields:\n" - ^ (Ext_list.map fields (fun {lid; x = pat} -> - addIndentation (indentation + 2) - ^ (lid |> printLocDenominatorLoc ~pos) - ^ (Utils.flattenLongIdent lid.txt |> ident |> str) - ^ ": " - ^ printPattern pat ~pos ~indentation:(indentation + 2)) - |> String.concat "\n") - ^ "\n" ^ addIndentation indentation ^ ")" - | Ppat_tuple patterns -> - "Ppat_tuple(\n" - ^ (patterns - |> List.map (fun pattern -> - addIndentation (indentation + 2) - ^ (pattern |> printPattern ~pos ~indentation:(indentation + 2))) - |> String.concat ",\n") - ^ "\n" ^ addIndentation indentation ^ ")" - | Ppat_any -> "Ppat_any" - | Ppat_constraint (pattern, typ) -> - "Ppat_constraint(\n" - ^ addIndentation (indentation + 1) - ^ printCoreType typ ~pos ^ ",\n" - ^ addIndentation (indentation + 1) - ^ (pattern |> printPattern ~pos ~indentation:(indentation + 1)) - ^ "\n" ^ addIndentation indentation ^ ")" - | v -> Printf.sprintf "" (Utils.identifyPpat v) - -and printCase case ~pos ~indentation ~caseNum = - addIndentation indentation - ^ Printf.sprintf "case %i:\n" caseNum - ^ addIndentation (indentation + 1) - ^ "pattern" - ^ (case.Parsetree.pc_lhs.ppat_loc |> printLocDenominator ~pos) - ^ ":\n" - ^ addIndentation (indentation + 2) - ^ printPattern case.Parsetree.pc_lhs ~pos ~indentation - ^ "\n" - ^ addIndentation (indentation + 1) - ^ "expr" - ^ (case.Parsetree.pc_rhs.pexp_loc |> printLocDenominator ~pos) - ^ ":\n" - ^ addIndentation (indentation + 2) - ^ printExprItem case.pc_rhs ~pos ~indentation:(indentation + 2) - -and printExprItem expr ~pos ~indentation = - printAttributes expr.Parsetree.pexp_attributes - ^ (expr.pexp_loc |> printLocDenominator ~pos) - ^ - match expr.Parsetree.pexp_desc with - | Pexp_array exprs -> - "Pexp_array(\n" - ^ addIndentation (indentation + 1) - ^ (exprs - |> List.map (fun expr -> - expr |> printExprItem ~pos ~indentation:(indentation + 1)) - |> String.concat ("\n" ^ addIndentation (indentation + 1))) - ^ "\n" ^ addIndentation indentation ^ ")" - | Pexp_match (matchExpr, cases) -> - "Pexp_match(" - ^ printExprItem matchExpr ~pos ~indentation:0 - ^ ")\n" - ^ (cases - |> List.mapi (fun caseNum case -> - printCase case ~pos ~caseNum:(caseNum + 1) - ~indentation:(indentation + 1)) - |> String.concat "\n") - | Pexp_ident {txt} -> - "Pexp_ident:" ^ (Utils.flattenLongIdent txt |> SharedTypes.ident) - | Pexp_break -> "Pexp_break" - | Pexp_continue -> "Pexp_continue" - | Pexp_apply {funct = expr; args} -> - let printLabel labelled ~pos = - match labelled with - | None -> "" - | Some labelled -> - printLocDenominatorPos pos ~posStart:labelled.posStart - ~posEnd:labelled.posEnd - ^ "~" - ^ if labelled.opt then "?" else "" ^ labelled.name - in - let args = extractExpApplyArgs ~args in - "Pexp_apply(\n" - ^ addIndentation (indentation + 1) - ^ "expr:\n" - ^ addIndentation (indentation + 2) - ^ printExprItem expr ~pos ~indentation:(indentation + 2) - ^ "\n" - ^ addIndentation (indentation + 1) - ^ "args:\n" - ^ (args - |> List.map (fun arg -> - addIndentation (indentation + 2) - ^ printLabel arg.label ~pos ^ "=\n" - ^ addIndentation (indentation + 3) - ^ printExprItem arg.exp ~pos ~indentation:(indentation + 3)) - |> String.concat ",\n") - ^ "\n" ^ addIndentation indentation ^ ")" - | Pexp_constant constant -> "Pexp_constant(" ^ printConstant constant ^ ")" - | Pexp_construct (({txt} as loc), maybeExpr) -> - "Pexp_construct(" - ^ (loc |> printLocDenominatorLoc ~pos) - ^ (Utils.flattenLongIdent txt |> ident |> str) - ^ (match maybeExpr with - | None -> "" - | Some expr -> ", " ^ printExprItem expr ~pos ~indentation) - ^ ")" - | Pexp_variant (label, maybeExpr) -> - "Pexp_variant(" ^ str label - ^ (match maybeExpr with - | None -> "" - | Some expr -> "," ^ printExprItem expr ~pos ~indentation) - ^ ")" - | Pexp_fun {arg_label = arg; lhs = pattern; rhs = nextExpr} -> - "Pexp_fun(\n" - ^ addIndentation (indentation + 1) - ^ "arg: " - ^ (match arg with - | Nolabel -> "Nolabel" - | Labelled {txt = name} -> "Labelled(" ^ name ^ ")" - | Optional {txt = name} -> "Optional(" ^ name ^ ")") - ^ ",\n" - ^ addIndentation (indentation + 2) - ^ "pattern: " - ^ printPattern pattern ~pos ~indentation:(indentation + 2) - ^ ",\n" - ^ addIndentation (indentation + 1) - ^ "next expr:\n" - ^ addIndentation (indentation + 2) - ^ printExprItem nextExpr ~pos ~indentation:(indentation + 2) - ^ "\n" ^ addIndentation indentation ^ ")" - | Pexp_extension (({txt} as loc), _) -> - "Pexp_extension(%" ^ (loc |> printLocDenominatorLoc ~pos) ^ txt ^ ")" - | Pexp_assert expr -> - "Pexp_assert(" ^ printExprItem expr ~pos ~indentation ^ ")" - | Pexp_field (exp, loc) -> - "Pexp_field(" - ^ (loc |> printLocDenominatorLoc ~pos) - ^ printExprItem exp ~pos ~indentation - ^ ")" - | Pexp_record (fields, _) -> - "Pexp_record(\n" - ^ addIndentation (indentation + 1) - ^ "fields:\n" - ^ (Ext_list.map fields (fun {lid; x = expr} -> - addIndentation (indentation + 2) - ^ (lid |> printLocDenominatorLoc ~pos) - ^ (Utils.flattenLongIdent lid.txt |> ident |> str) - ^ ": " - ^ printExprItem expr ~pos ~indentation:(indentation + 2)) - |> String.concat "\n") - ^ "\n" ^ addIndentation indentation ^ ")" - | Pexp_tuple exprs -> - "Pexp_tuple(\n" - ^ (exprs - |> List.map (fun expr -> - addIndentation (indentation + 2) - ^ (expr |> printExprItem ~pos ~indentation:(indentation + 2))) - |> String.concat ",\n") - ^ "\n" ^ addIndentation indentation ^ ")" - | v -> Printf.sprintf "" (Utils.identifyPexp v) - -let printValueBinding value ~pos ~indentation = - printAttributes value.Parsetree.pvb_attributes - ^ "value" ^ ":\n" - ^ addIndentation (indentation + 1) - ^ (value.pvb_pat |> printPattern ~pos ~indentation:(indentation + 1)) - ^ "\n" ^ addIndentation indentation ^ "expr:\n" - ^ addIndentation (indentation + 1) - ^ printExprItem value.pvb_expr ~pos ~indentation:(indentation + 1) - -let printStructItem structItem ~pos ~source = - match structItem.Parsetree.pstr_loc |> CursorPosition.classifyLoc ~pos with - | HasCursor -> ( - let startOffset = - match Pos.positionToOffset source (structItem.pstr_loc |> Loc.start) with - | None -> 0 - | Some offset -> offset - in - let endOffset = - (* Include the next line of the source since that will hold the ast comment pointing to the position. - Caveat: this only works for single line sources with a comment on the next line. Will need to be - adapted if that's not the only use case.*) - let line, _col = structItem.pstr_loc |> Loc.end_ in - match Pos.positionToOffset source (line + 2, 0) with - | None -> 0 - | Some offset -> offset - in - - ("\nSource:\n// " - ^ String.sub source startOffset (endOffset - startOffset) - ^ "\n") - ^ printLocDenominator structItem.pstr_loc ~pos - ^ - match structItem.pstr_desc with - | Pstr_eval (expr, _attributes) -> - "Pstr_eval(\n" ^ printExprItem expr ~pos ~indentation:1 ^ "\n)" - | Pstr_value (recFlag, values) -> - "Pstr_value(\n" - ^ (match recFlag with - | Recursive -> " rec,\n" - | Nonrecursive -> "") - ^ (values - |> List.map (fun value -> - addIndentation 1 ^ printValueBinding value ~pos ~indentation:1) - |> String.concat ",\n") - ^ "\n)" - | _ -> "") - | _ -> "" - -let dump ~currentFile ~pos = - let {Res_driver.parsetree = structure; source} = - Res_driver.parsing_engine.parse_implementation ~for_printer:true - ~filename:currentFile - in - - print_endline - (structure - |> List.map (fun structItem -> printStructItem structItem ~pos ~source) - |> String.concat "") diff --git a/analysis/src/FindFiles.ml b/analysis/src/FindFiles.ml deleted file mode 100644 index 07a5a35eda8..00000000000 --- a/analysis/src/FindFiles.ml +++ /dev/null @@ -1,342 +0,0 @@ -let ifDebug debug name fn v = if debug then Log.log (name ^ ": " ^ fn v) -let ( /+ ) = Filename.concat -let bind f x = Option.bind x f - -(* Returns a list of paths, relative to the provided `base` *) -let getSourceDirectories ~includeDev ~baseDir config = - let rec handleItem current item = - match item with - | `List contents -> List.map (handleItem current) contents |> List.concat - | `String text -> [current /+ text] - | `Assoc _ -> ( - let dir = - item |> YojsonHelpers.get "dir" - |> bind YojsonHelpers.string_opt - |> Option.value ~default:"Must specify directory" - in - let typ = - if includeDev then "lib" - else - item |> YojsonHelpers.get "type" - |> bind YojsonHelpers.string_opt - |> Option.value ~default:"lib" - in - - if typ = "dev" then [] - else - match item |> YojsonHelpers.get "subdirs" with - | None | Some (`Bool false) -> [current /+ dir] - | Some (`Bool true) -> - Files.collectDirs (baseDir /+ current /+ dir) - |> List.filter (fun name -> name <> Filename.current_dir_name) - |> List.map (Files.relpath baseDir) - | Some item -> (current /+ dir) :: handleItem (current /+ dir) item) - | _ -> failwith "Invalid subdirs entry" - in - match config |> YojsonHelpers.get "sources" with - | None -> [] - | Some item -> handleItem "" item - -let isCompiledFile name = - Filename.check_suffix name ".cmt" || Filename.check_suffix name ".cmti" - -let isImplementation name = - Filename.check_suffix name ".re" - || Filename.check_suffix name ".res" - || Filename.check_suffix name ".ml" - -let isInterface name = - Filename.check_suffix name ".rei" - || Filename.check_suffix name ".resi" - || Filename.check_suffix name ".mli" - -let isSourceFile name = isImplementation name || isInterface name - -let compiledNameSpace name = - String.split_on_char '-' name - |> List.map String.capitalize_ascii - |> String.concat "" - (* Remove underscores??? Whyyy bucklescript, whyyyy *) - |> String.split_on_char '_' - |> String.concat "" - -let compiledBaseName ~namespace name = - Filename.chop_extension name - ^ - match namespace with - | None -> "" - | Some n -> "-" ^ compiledNameSpace n - -let getName x = - Filename.basename x |> Filename.chop_extension |> String.capitalize_ascii - -let filterDuplicates cmts = - (* Remove .cmt's that have .cmti's *) - let intfs = Hashtbl.create 100 in - cmts - |> List.iter (fun path -> - if - Filename.check_suffix path ".rei" - || Filename.check_suffix path ".mli" - || Filename.check_suffix path ".cmti" - then Hashtbl.add intfs (getName path) true); - cmts - |> List.filter (fun path -> - not - ((Filename.check_suffix path ".re" - || Filename.check_suffix path ".ml" - || Filename.check_suffix path ".cmt") - && Hashtbl.mem intfs (getName path))) - -let nameSpaceToName n = - n - |> Str.split (Str.regexp "[-/@]") - |> List.map String.capitalize_ascii - |> String.concat "" - -type namespace_config = - | NamespaceDisabled - | NamespaceFromPackageName - | NamespaceExplicit of string - -let getNamespaceConfig config = - match config |> YojsonHelpers.get "namespace" with - | None | Some (`Bool false) -> NamespaceDisabled - | Some (`Bool true) -> NamespaceFromPackageName - | Some (`String namespace) -> NamespaceExplicit namespace - | Some _ -> NamespaceDisabled - -let getNamespace config = - match getNamespaceConfig config with - | NamespaceDisabled -> None - | NamespaceExplicit namespace -> Some (nameSpaceToName namespace) - | NamespaceFromPackageName -> - let fromName = - config |> YojsonHelpers.get "name" |> bind YojsonHelpers.string_opt - in - fromName |> Option.map nameSpaceToName - -module StringSet = Set.Make (String) - -let getPublic config = - let public = config |> YojsonHelpers.get "public" in - match public with - | None -> None - | Some public -> ( - match public |> YojsonHelpers.to_list_opt with - | None -> None - | Some public -> - Some - (public |> List.filter_map YojsonHelpers.string_opt |> StringSet.of_list) - ) - -let collectFiles directory = - let allFiles = Files.readDirectory directory in - let compileds = allFiles |> List.filter isCompiledFile |> filterDuplicates in - let sources = allFiles |> List.filter isSourceFile |> filterDuplicates in - compileds - |> Utils.filterMap (fun path -> - let modName = getName path in - let cmt = directory /+ path in - let resOpt = - Utils.find - (fun name -> - if getName name = modName then Some (directory /+ name) else None) - sources - in - match resOpt with - | None -> None - | Some res -> Some (modName, SharedTypes.Impl {cmt; res})) - -(* Dependency resolution uses the package graph recorded by the build system in - .sourcedirs.json when available. If a package is not listed there, analysis - falls back to walking up node_modules from the project root. *) -let readSourcedirsPackageRoots base = - let sourceDirsFile = base /+ "lib" /+ "bs" /+ ".sourcedirs.json" in - let readPackageEntry = function - | `List [`String name; `String path] -> - let path = if Filename.is_relative path then base /+ path else path in - Some (name, path) - | _ -> None - in - match Files.readFile sourceDirsFile with - | None -> [] - | Some text -> ( - match YojsonHelpers.from_string_opt text with - | None -> [] - | Some json -> ( - match - json |> YojsonHelpers.get "pkgs" |> bind YojsonHelpers.to_list_opt - with - | None -> [] - | Some packages -> packages |> List.filter_map readPackageEntry)) - -let findPackageRoot ~base ~sourcedirsPackageRoots name = - match List.assoc_opt name sourcedirsPackageRoots with - | Some path when Files.exists path -> Some path - | _ -> ModuleResolution.resolveNodeModulePath ~startPath:base name - -(* returns a list of (absolute path to cmt(i), relative path from base to source file) *) -let findProjectFiles ~public ~namespace ~path ~sourceDirectories ~libBs = - let dirs = - sourceDirectories |> List.map (Filename.concat path) |> StringSet.of_list - in - let files = - (* Use maxDepth to prevent infinite recursion where `rescript` depends on `@rescript/runtime`, - but `@rescript/runtime` also has `rescript` as a dev dependency *) - dirs |> StringSet.elements - |> List.map (fun name -> Files.collect ~maxDepth:2 name isSourceFile) - |> List.concat |> StringSet.of_list - in - dirs - |> ifDebug true "Source directories" (fun s -> - s |> StringSet.elements |> List.map Utils.dumpPath |> String.concat " "); - files - |> ifDebug true "Source files" (fun s -> - s |> StringSet.elements |> List.map Utils.dumpPath |> String.concat " "); - - let interfaces = Hashtbl.create 100 in - files - |> StringSet.iter (fun path -> - if isInterface path then Hashtbl.replace interfaces (getName path) path); - - let normals = - files |> StringSet.elements - |> Utils.filterMap (fun file -> - if isImplementation file then ( - let moduleName = getName file in - let resi = Hashtbl.find_opt interfaces moduleName in - Hashtbl.remove interfaces moduleName; - let base = compiledBaseName ~namespace (Files.relpath path file) in - match resi with - | Some resi -> - let cmti = (libBs /+ base) ^ ".cmti" in - let cmt = (libBs /+ base) ^ ".cmt" in - if Files.exists cmti then - if Files.exists cmt then - (* Log.log("Intf and impl " ++ cmti ++ " " ++ cmt) *) - Some - ( moduleName, - SharedTypes.IntfAndImpl {cmti; resi; cmt; res = file} ) - else None - else ( - (* Log.log("Just intf " ++ cmti) *) - Log.log ("Bad source file (no cmt/cmti/cmi) " ^ (libBs /+ base)); - None) - | None -> - let cmt = (libBs /+ base) ^ ".cmt" in - if Files.exists cmt then Some (moduleName, Impl {cmt; res = file}) - else ( - Log.log ("Bad source file (no cmt/cmi) " ^ (libBs /+ base)); - None)) - else None) - in - let result = - normals - |> List.filter_map (fun (name, paths) -> - let originalName = name in - let name = - match namespace with - | None -> name - | Some namespace -> name ^ "-" ^ namespace - in - match public with - | Some public -> - if public |> StringSet.mem originalName then Some (name, paths) - else None - | None -> Some (name, paths)) - in - match namespace with - | None -> result - | Some namespace -> - let moduleName = nameSpaceToName namespace in - let cmt = (libBs /+ namespace) ^ ".cmt" in - Log.log ("adding namespace " ^ namespace ^ " : " ^ moduleName ^ " : " ^ cmt); - (moduleName, Namespace {cmt}) :: result - -let findDependencyFiles base config = - let deps = - match - ( config - |> YojsonHelpers.get "dependencies" - |> bind YojsonHelpers.to_list_opt, - config - |> YojsonHelpers.get "bs-dependencies" - |> bind YojsonHelpers.to_list_opt ) - with - | None, None -> [] - | Some deps, None | _, Some deps -> - deps |> List.filter_map YojsonHelpers.string_opt - in - let devDeps = - match - ( config - |> YojsonHelpers.get "dev-dependencies" - |> bind YojsonHelpers.to_list_opt, - config - |> YojsonHelpers.get "bs-dev-dependencies" - |> bind YojsonHelpers.to_list_opt ) - with - | None, None -> [] - | Some devDeps, None | _, Some devDeps -> - devDeps |> List.filter_map YojsonHelpers.string_opt - in - let deps = deps @ devDeps in - Log.log ("Dependencies: " ^ String.concat " " deps); - let sourcedirsPackageRoots = readSourcedirsPackageRoots base in - let depFiles = - deps - |> List.map (fun name -> - let result = - bind - (fun path -> - let rescriptJsonPath = path /+ "rescript.json" in - - let parseText text = - match YojsonHelpers.from_string_opt text with - | Some inner -> ( - let namespace = getNamespace inner in - let sourceDirectories = - getSourceDirectories ~includeDev:false ~baseDir:path - inner - in - match BuildSystem.getLibBs path with - | None -> None - | Some libBs -> - let compiledDirectories = - sourceDirectories |> List.map (Filename.concat libBs) - in - let compiledDirectories = - match namespace with - | None -> compiledDirectories - | Some _ -> libBs :: compiledDirectories - in - let projectFiles = - findProjectFiles ~public:(getPublic inner) ~namespace - ~path ~sourceDirectories ~libBs - in - Some (compiledDirectories, projectFiles)) - | None -> None - in - - match Files.readFile rescriptJsonPath with - | Some text -> parseText text - | None -> None) - (findPackageRoot ~base ~sourcedirsPackageRoots name) - in - - match result with - | Some (files, directories) -> (files, directories) - | None -> - Log.log ("Skipping nonexistent dependency: " ^ name); - ([], [])) - in - match BuildSystem.getStdlib base with - | None -> None - | Some stdlibDirectory -> - let compiledDirectories, projectFiles = - let files, directories = List.split depFiles in - (List.concat files, List.concat directories) - in - let allFiles = projectFiles @ collectFiles stdlibDirectory in - Some (compiledDirectories, allFiles) diff --git a/analysis/src/Hover.ml b/analysis/src/Hover.ml deleted file mode 100644 index 4f1a98da27f..00000000000 --- a/analysis/src/Hover.ml +++ /dev/null @@ -1,317 +0,0 @@ -open SharedTypes - -module StringSet = Set.Make (String) - -let showModuleTopLevel ~docstring ~isType ~name (topLevel : Module.item list) = - let contents = - topLevel - |> List.map (fun item -> - match item.Module.kind with - (* TODO pretty print module contents *) - | Type ({decl}, recStatus) -> - " " ^ (decl |> Shared.declToString ~recStatus item.name) - | Module _ -> " module " ^ item.name - | Value typ -> - " let " ^ item.name ^ ": " ^ (typ |> Shared.typeToString)) - (* TODO indent *) - |> String.concat "\n" - in - let name = Utils.cutAfterDash name in - let full = - Markdown.codeBlock - ("module " - ^ (if isType then "type " ^ name ^ " = " else name ^ ": ") - ^ "{" ^ "\n" ^ contents ^ "\n}") - in - let doc = - match docstring with - | [] -> "" - | _ :: _ -> - "\n" - ^ (docstring |> String.concat "\n") - ^ Markdown.divider ^ Markdown.spacing - in - Some (doc ^ full) - -let rec showModule ~docstring ~(file : File.t) ~package ~name - (declared : Module.t Declared.t option) = - match declared with - | None -> - showModuleTopLevel ~docstring ~isType:false ~name file.structure.items - | Some {item = Structure {items}; modulePath} -> - let isType = - match modulePath with - | ExportedModule {isType} -> isType - | _ -> false - in - showModuleTopLevel ~docstring ~isType ~name items - | Some ({item = Constraint (_moduleItem, moduleTypeItem)} as declared) -> - (* show the interface *) - showModule ~docstring ~file ~name ~package - (Some {declared with item = moduleTypeItem}) - | Some ({item = Ident path} as declared) -> ( - match References.resolveModuleReference ~file ~package declared with - | None -> Some ("Unable to resolve module reference " ^ Path.name path) - | Some (_, declared) -> showModule ~docstring ~file ~name ~package declared) - -type extractedType = { - name: string; - path: Path.t; - decl: Types.type_declaration; - env: SharedTypes.QueryEnv.t; - loc: Warnings.loc; -} - -let findRelevantTypesFromType ~file ~package typ = - (* Expand definitions of types mentioned in typ. - If typ itself is a record or variant, search its body *) - let env = QueryEnv.fromFile file in - let envToSearch, typesToSearch = - match typ |> Shared.digConstructor with - | Some path -> ( - let labelDeclarationsTypes lds = - lds |> List.map (fun (ld : Types.label_declaration) -> ld.ld_type) - in - match References.digConstructor ~env ~package path with - | None -> (env, [typ]) - | Some (env1, {item = {decl}}) -> ( - match decl.type_kind with - | Type_record (lds, _) -> (env1, typ :: (lds |> labelDeclarationsTypes)) - | Type_variant cds -> - ( env1, - cds - |> List.map (fun (cd : Types.constructor_declaration) -> - let fromArgs = - match cd.cd_args with - | Cstr_tuple ts -> ts - | Cstr_record lds -> lds |> labelDeclarationsTypes - in - typ - :: - (match cd.cd_res with - | None -> fromArgs - | Some t -> t :: fromArgs)) - |> List.flatten ) - | _ -> (env, [typ]))) - | None -> (env, [typ]) - in - let fromConstructorPath ~env path = - match References.digConstructor ~env ~package path with - | None -> None - | Some (env, {name = {txt}; extentLoc; item = {decl}}) -> - if Utils.isUncurriedInternal path then None - else Some {name = txt; env; loc = extentLoc; decl; path} - in - let constructors = Shared.findTypeConstructors typesToSearch in - constructors |> List.filter_map (fromConstructorPath ~env:envToSearch) - -let expandTypes ~file ~package ~supportsMarkdownLinks typ = - match findRelevantTypesFromType typ ~file ~package with - | {decl; path} :: _ - when Res_parsetree_viewer.has_inline_record_definition_attribute - decl.type_attributes -> - (* We print inline record types just with their definition, not the constr pointing - to them, since that doesn't make sense to show the user. *) - ( [ - Markdown.codeBlock - (decl - |> Shared.declToString ~printNameAsIs:true - (SharedTypes.pathIdentToString path)); - ], - `InlineType ) - | all -> - let typesSeen = ref StringSet.empty in - let typeId ~(env : QueryEnv.t) ~name = - env.file.moduleName :: List.rev (name :: env.pathRev) |> String.concat "." - in - ( all - (* Don't produce duplicate type definitions for recursive types *) - |> List.filter (fun {env; name} -> - let typeId = typeId ~env ~name in - if StringSet.mem typeId !typesSeen then false - else ( - typesSeen := StringSet.add typeId !typesSeen; - true)) - |> List.map (fun {decl; env; loc; path} -> - let linkToTypeDefinitionStr = - if - supportsMarkdownLinks - && not - (Res_parsetree_viewer - .has_inline_record_definition_attribute - decl.type_attributes) - then Markdown.goToDefinitionText ~env ~pos:loc.Warnings.loc_start - else "" - in - Markdown.divider - ^ (if supportsMarkdownLinks then Markdown.spacing else "") - ^ Markdown.codeBlock - (decl - |> Shared.declToString ~printNameAsIs:true - (SharedTypes.pathIdentToString path)) - ^ linkToTypeDefinitionStr ^ "\n"), - `Default ) - -(* Produces a hover with relevant types expanded in the main type being hovered. *) -let hoverWithExpandedTypes ~file ~package ~supportsMarkdownLinks ?docstring - ?constructor typ = - let expandedTypes, expansionType = - expandTypes ~file ~package ~supportsMarkdownLinks typ - in - match expansionType with - | `Default -> - let typeString = Shared.typeToString typ in - let typeString = - match constructor with - | Some constructor -> - typeString ^ "\n" ^ CompletionBackEnd.showConstructor constructor - | None -> typeString - in - let typeString = - match docstring with - | Some [] | None -> Markdown.codeBlock typeString - | Some docstring -> - Markdown.codeBlock typeString - ^ Markdown.divider - ^ (docstring |> String.concat "\n") - in - typeString :: expandedTypes |> String.concat "\n" - | `InlineType -> expandedTypes |> String.concat "\n" - -(* Leverages autocomplete functionality to produce a hover for a position. This - makes it (most often) work with unsaved content. *) -let getHoverViaCompletions ~debug ~source ~kindFile ~pos ~forHover - ~supportsMarkdownLinks ~full = - match - Completions.getCompletions ~debug ~source ~kindFile ~pos ~forHover ~full - with - | None -> None - | Some (completions, ({file; package} as full), scope) -> ( - let rawOpens = Scope.getRawOpens scope in - match completions with - | {kind = Label typString; docstring} :: _ -> - let parts = - docstring - @ if typString = "" then [] else [Markdown.codeBlock typString] - in - - Some (String.concat "\n\n" parts) - | {kind = Field _; env; docstring} :: _ -> ( - let opens = CompletionBackEnd.getOpens ~debug ~rawOpens ~package ~env in - match - CompletionBackEnd.completionsGetTypeEnv2 ~debug ~full ~rawOpens ~opens - ~pos completions - with - | Some (typ, _env) -> - let typeString = - hoverWithExpandedTypes ~file ~package ~docstring - ~supportsMarkdownLinks typ - in - Some typeString - | None -> None) - | {env} :: _ -> ( - let opens = CompletionBackEnd.getOpens ~debug ~rawOpens ~package ~env in - match - CompletionBackEnd.completionsGetTypeEnv2 ~debug ~full ~rawOpens ~opens - ~pos completions - with - | Some (typ, _env) -> - let typeString = - hoverWithExpandedTypes ~file ~package ~supportsMarkdownLinks typ - in - Some typeString - | None -> None) - | _ -> None) - -let newHover ~full:{file; package} ~supportsMarkdownLinks locItem = - match locItem.locType with - | TypeDefinition (name, decl, _stamp) -> ( - let typeDef = Markdown.codeBlock (Shared.declToString name decl) in - match decl.type_manifest with - | None -> Some typeDef - | Some typ -> ( - let expandedTypes, expansionType = - expandTypes ~file ~package ~supportsMarkdownLinks typ - in - match expansionType with - | `Default -> Some (typeDef :: expandedTypes |> String.concat "\n") - | `InlineType -> Some (expandedTypes |> String.concat "\n"))) - | LModule (Definition (stamp, _tip)) | LModule (LocalReference (stamp, _tip)) - -> ( - match Stamps.findModule file.stamps stamp with - | None -> None - | Some md -> ( - match References.resolveModuleReference ~file ~package md with - | None -> None - | Some (file, declared) -> - let name, docstring = - match declared with - | Some d -> (d.name.txt, d.docstring) - | None -> (file.moduleName, file.structure.docstring) - in - showModule ~docstring ~name ~file declared ~package)) - | LModule (GlobalReference (moduleName, path, tip)) -> ( - match ProcessCmt.fileForModule ~package moduleName with - | None -> None - | Some file -> ( - let env = QueryEnv.fromFile file in - match References.exportedForTip ~env ~path ~package ~tip with - | None -> None - | Some (_env, _name, stamp) -> ( - match Stamps.findModule file.stamps stamp with - | None -> None - | Some md -> ( - match References.resolveModuleReference ~file ~package md with - | None -> None - | Some (file, declared) -> - let name, docstring = - match declared with - | Some d -> (d.name.txt, d.docstring) - | None -> (file.moduleName, file.structure.docstring) - in - showModule ~docstring ~name ~file ~package declared)))) - | LModule NotFound -> None - | TopLevelModule name -> ( - match ProcessCmt.fileForModule ~package name with - | None -> None - | Some file -> - showModule ~docstring:file.structure.docstring ~name:file.moduleName ~file - ~package None) - | Typed (_, _, Definition (_, (Field _ | Constructor _))) -> None - | Constant t -> - Some - (Markdown.codeBlock - (match t with - | Const_int _ -> "int" - | Const_char _ -> "char" - | Const_string _ -> "string" - | Const_float _ -> "float" - | Const_int32 _ -> "int32" - | Const_int64 _ -> "int64" - | Const_bigint _ -> "bigint")) - | Typed (_, t, locKind) -> ( - let fromType ?docstring ?constructor typ = - hoverWithExpandedTypes ~file ~package ~supportsMarkdownLinks ?docstring - ?constructor typ - in - (* Expand first-class modules to the underlying module type signature. *) - let t = Shared.dig t in - match t.desc with - | Tpackage (path, _lids, _tys) -> ( - let env = QueryEnv.fromFile file in - match ResolvePath.resolveModuleFromCompilerPath ~env ~package path with - | None -> Some (fromType t) - | Some (envForModule, Some declared) -> - let name = Path.name path in - showModule ~docstring:declared.docstring ~name ~file:envForModule.file - ~package (Some declared) - | Some (_, None) -> Some (fromType t)) - | _ -> - Some - (match References.definedForLoc ~file ~package locKind with - | None -> t |> fromType - | Some (docstring, res) -> ( - match res with - | `Declared | `Field -> t |> fromType ~docstring - | `Constructor constructor -> - t |> fromType ~docstring:constructor.docstring ~constructor))) diff --git a/analysis/src/JsxHacks.ml b/analysis/src/JsxHacks.ml deleted file mode 100644 index 81ffe200a80..00000000000 --- a/analysis/src/JsxHacks.ml +++ /dev/null @@ -1,5 +0,0 @@ -let pathIsFragment path = Path.name path = "ReasonReact.fragment" - -let primitiveIsFragment (vd : Typedtree.value_description) = - vd.val_name.txt = "fragment" - && vd.val_loc.loc_start.pos_fname |> Filename.basename = "ReasonReact.res" diff --git a/analysis/src/LocalTables.ml b/analysis/src/LocalTables.ml deleted file mode 100644 index d690d969d18..00000000000 --- a/analysis/src/LocalTables.ml +++ /dev/null @@ -1,65 +0,0 @@ -open SharedTypes - -type 'a table = (string * (int * int), 'a Declared.t) Hashtbl.t -type namesUsed = (string, unit) Hashtbl.t - -type t = { - namesUsed: namesUsed; - mutable resultRev: Completion.t list; - constructorTable: Constructor.t table; - modulesTable: Module.t table; - typesTable: Type.t table; - valueTable: Types.type_expr table; - includedValueTable: (string * Types.type_expr) table; -} - -let create () = - { - namesUsed = Hashtbl.create 1; - resultRev = []; - constructorTable = Hashtbl.create 1; - modulesTable = Hashtbl.create 1; - typesTable = Hashtbl.create 1; - valueTable = Hashtbl.create 1; - includedValueTable = Hashtbl.create 1; - } - -let populateValues ~env localTables = - env.QueryEnv.file.stamps - |> Stamps.iterValues (fun _ declared -> - Hashtbl.replace localTables.valueTable - (declared.name.txt, declared.name.loc |> Loc.start) - declared) - -let populateIncludedValues ~env localTables = - env.QueryEnv.file.stamps - |> Stamps.iterValues (fun _ declared -> - match declared.modulePath with - | ModulePath.IncludedModule (source, _) -> - let path = Path.name source in - let declared = {declared with item = (path, declared.item)} in - Hashtbl.replace localTables.includedValueTable - (declared.name.txt, declared.name.loc |> Loc.start) - declared - | _ -> ()) - -let populateConstructors ~env localTables = - env.QueryEnv.file.stamps - |> Stamps.iterConstructors (fun _ declared -> - Hashtbl.replace localTables.constructorTable - (declared.name.txt, declared.extentLoc |> Loc.start) - declared) - -let populateTypes ~env localTables = - env.QueryEnv.file.stamps - |> Stamps.iterTypes (fun _ declared -> - Hashtbl.replace localTables.typesTable - (declared.name.txt, declared.name.loc |> Loc.start) - declared) - -let populateModules ~env localTables = - env.QueryEnv.file.stamps - |> Stamps.iterModules (fun _ declared -> - Hashtbl.replace localTables.modulesTable - (declared.name.txt, declared.extentLoc |> Loc.start) - declared) diff --git a/analysis/src/Markdown.ml b/analysis/src/Markdown.ml deleted file mode 100644 index 16d7f0c7a26..00000000000 --- a/analysis/src/Markdown.ml +++ /dev/null @@ -1,23 +0,0 @@ -let spacing = "\n```\n \n```\n" -let codeBlock code = Printf.sprintf "```rescript\n%s\n```" code -let divider = "\n---\n" - -type link = {startPos: Lsp.Types.Position.t; file: string; label: string} - -let linkToCommandArgs link = - Printf.sprintf "[\"%s\",%i,%i]" link.file link.startPos.line - link.startPos.character - -let makeGotoCommand link = - Printf.sprintf "[%s](command:rescript-vscode.go_to_location?%s)" link.label - (Uri.encodeURIComponent (linkToCommandArgs link)) - -let goToDefinitionText ~env ~pos = - let startLine, startCol = Pos.ofLexing pos in - "\nGo to: " - ^ makeGotoCommand - { - label = "Type definition"; - file = Uri.toString env.SharedTypes.QueryEnv.file.uri; - startPos = {line = startLine; character = startCol}; - } diff --git a/analysis/src/Packages.ml b/analysis/src/Packages.ml deleted file mode 100644 index d07bfa17850..00000000000 --- a/analysis/src/Packages.ml +++ /dev/null @@ -1,227 +0,0 @@ -open SharedTypes - -(* Creates the `pathsForModule` hashtbl, which maps a `moduleName` to it's `paths` (the ml/re, mli/rei, cmt, and cmti files) *) -let makePathsForModule ~projectFilesAndPaths ~dependenciesFilesAndPaths = - let pathsForModule = Hashtbl.create 30 in - dependenciesFilesAndPaths - |> List.iter (fun (modName, paths) -> - Hashtbl.replace pathsForModule modName paths); - projectFilesAndPaths - |> List.iter (fun (modName, paths) -> - Hashtbl.replace pathsForModule modName paths); - pathsForModule - -let overrideRescriptVersion = ref None - -let getReScriptVersion () = - match !overrideRescriptVersion with - | Some overrideRescriptVersion -> overrideRescriptVersion - | None -> ( - (* TODO: Include patch stuff when needed *) - let defaultVersion = (11, 0) in - try - let value = Sys.getenv "RESCRIPT_VERSION" in - let version = - match value |> String.split_on_char '.' with - | major :: minor :: _rest -> ( - match (int_of_string_opt major, int_of_string_opt minor) with - | Some major, Some minor -> (major, minor) - | _ -> defaultVersion) - | _ -> defaultVersion - in - version - with Not_found -> defaultVersion) - -let newBsPackage ~rootPath = - let rescriptJson = Filename.concat rootPath "rescript.json" in - - let parseRaw raw = - let libBs = - match !Cfg.isDocGenFromCompiler with - | true -> BuildSystem.getStdlib rootPath - | false -> BuildSystem.getLibBs rootPath - in - match YojsonHelpers.from_string_opt raw with - | Some config -> ( - let namespace = FindFiles.getNamespace config in - let rescriptVersion = getReScriptVersion () in - let suffix = - match config |> YojsonHelpers.get "suffix" with - | Some (`String suffix) -> suffix - | _ -> ".js" - in - let genericJsxModule = - let jsxConfig = config |> YojsonHelpers.get "jsx" in - match jsxConfig with - | Some jsxConfig -> ( - match jsxConfig |> YojsonHelpers.get "module" with - | Some (`String m) when String.lowercase_ascii m <> "react" -> Some m - | _ -> None) - | None -> None - in - let autocomplete = - match config |> YojsonHelpers.get "editor" with - | Some editorConfig -> ( - match editorConfig |> YojsonHelpers.get "autocomplete" with - | Some (`Assoc map) -> - map - |> List.fold_left - (fun acc (key, value) -> - match value with - | `List items -> - let values = - items - |> List.filter_map (function - | `String s -> Some s - | _ -> None) - in - Misc.StringMap.add key values acc - | _ -> acc) - Misc.StringMap.empty - | _ -> Misc.StringMap.empty) - | None -> Misc.StringMap.empty - in - match libBs with - | None -> None - | Some libBs -> - let cached = Cache.readCache (Cache.targetFileFromLibBs libBs) in - let projectFiles, dependenciesFiles, pathsForModule = - match cached with - | Some cached -> - ( cached.projectFiles, - cached.dependenciesFiles, - cached.pathsForModule ) - | None -> - let dependenciesFilesAndPaths = - match FindFiles.findDependencyFiles rootPath config with - | None -> [] - | Some (_dependencyDirectories, dependenciesFilesAndPaths) -> - dependenciesFilesAndPaths - in - let sourceDirectories = - FindFiles.getSourceDirectories ~includeDev:true ~baseDir:rootPath - config - in - let projectFilesAndPaths = - FindFiles.findProjectFiles - ~public:(FindFiles.getPublic config) - ~namespace ~path:rootPath ~sourceDirectories ~libBs - in - let pathsForModule = - makePathsForModule ~projectFilesAndPaths - ~dependenciesFilesAndPaths - in - let projectFiles = - projectFilesAndPaths |> List.map fst |> FileSet.of_list - in - let dependenciesFiles = - dependenciesFilesAndPaths |> List.map fst |> FileSet.of_list - in - (projectFiles, dependenciesFiles, pathsForModule) - in - Some - (let opens_from_namespace = - match namespace with - | None -> [] - | Some namespace -> - let cmt = Filename.concat libBs namespace ^ ".cmt" in - Hashtbl.replace pathsForModule namespace (Namespace {cmt}); - let path = [FindFiles.nameSpaceToName namespace] in - [path] - in - let bind f x = Option.bind x f in - let compiler_flags = - match - ( YojsonHelpers.get "compiler-flags" config - |> bind YojsonHelpers.to_list_opt, - YojsonHelpers.get "bsc-flags" config - |> bind YojsonHelpers.to_list_opt ) - with - | Some compiler_flags, None | _, Some compiler_flags -> - compiler_flags - | None, None -> [] - in - let no_pervasives = - compiler_flags - |> List.exists (fun s -> - match s with - | `String s -> s = "-nopervasives" - | _ -> false) - in - let opens_from_compiler_flags = - List.fold_left - (fun opens item -> - match item |> YojsonHelpers.string_opt with - | None -> opens - | Some s -> ( - let parts = String.split_on_char ' ' s in - match parts with - | "-open" :: name :: _ -> - let path = name |> String.split_on_char '.' in - path :: opens - | _ -> opens)) - [] compiler_flags - in - let opens_from_pervasives = - if no_pervasives then [] - else [["Stdlib"]; ["Pervasives"; "JsxModules"]] - in - let opens = - opens_from_pervasives @ opens_from_namespace - |> List.rev_append opens_from_compiler_flags - |> List.map (fun path -> path @ ["place holder"]) - in - { - genericJsxModule; - suffix; - rescriptVersion; - rootPath; - projectFiles; - dependenciesFiles; - pathsForModule; - opens; - namespace; - autocomplete; - })) - | None -> None - in - - match Files.readFile rescriptJson with - | Some raw -> parseRaw raw - | None -> - Log.log ("Unable to read " ^ rescriptJson); - None - -let findRoot ~uri packagesByRoot = - let path = Uri.toPath uri in - let rec loop path = - if path = "/" then None - else if Hashtbl.mem packagesByRoot path then Some (`Root path) - else if Files.exists (Filename.concat path "rescript.json") then - Some (`Bs path) - else - let parent = Filename.dirname path in - if parent = path then (* reached root *) None else loop parent - in - loop (if Sys.is_directory path then path else Filename.dirname path) - -let getPackage ~uri = - let open SharedTypes in - if Hashtbl.mem state.rootForUri uri then - Some (Hashtbl.find state.packagesByRoot (Hashtbl.find state.rootForUri uri)) - else - match findRoot ~uri state.packagesByRoot with - | None -> - Log.log "No root directory found"; - None - | Some (`Root rootPath) -> - Hashtbl.replace state.rootForUri uri rootPath; - Some - (Hashtbl.find state.packagesByRoot (Hashtbl.find state.rootForUri uri)) - | Some (`Bs rootPath) -> ( - match newBsPackage ~rootPath with - | None -> None - | Some package -> - Hashtbl.replace state.rootForUri uri package.rootPath; - Hashtbl.replace state.packagesByRoot package.rootPath package; - Some package) diff --git a/analysis/src/PipeCompletionUtils.ml b/analysis/src/PipeCompletionUtils.ml deleted file mode 100644 index f66c93e2315..00000000000 --- a/analysis/src/PipeCompletionUtils.ml +++ /dev/null @@ -1,26 +0,0 @@ -let addJsxCompletionItems ~mainTypeId ~env ~prefix ~(full : SharedTypes.full) - ~rawOpens typ = - match mainTypeId with - | ("array" | "float" | "string" | "int") as builtinNameToComplete -> - if Utils.checkName builtinNameToComplete ~prefix ~exact:false then - let name = - match full.package.genericJsxModule with - | None -> "React." ^ builtinNameToComplete - | Some g -> - g ^ "." ^ builtinNameToComplete - |> String.split_on_char '.' - |> TypeUtils.removeOpensFromCompletionPath ~rawOpens - ~package:full.package - |> String.concat "." - in - [ - SharedTypes.Completion.create name ~synthetic:true - ~includesSnippets:true ~kind:(Value typ) ~env ~sortText:"A" - ~docstring: - [ - "Turns `" ^ builtinNameToComplete - ^ "` into a JSX element so it can be used inside of JSX."; - ]; - ] - else [] - | _ -> [] diff --git a/analysis/src/Range.ml b/analysis/src/Range.ml deleted file mode 100644 index a7434907579..00000000000 --- a/analysis/src/Range.ml +++ /dev/null @@ -1,6 +0,0 @@ -type t = Pos.t * Pos.t - -let toString ((posStart, posEnd) : t) = - Printf.sprintf "[%s->%s]" (Pos.toString posStart) (Pos.toString posEnd) - -let hasPos ~pos ((posStart, posEnd) : t) = posStart <= pos && pos < posEnd diff --git a/analysis/src/References.ml b/analysis/src/References.ml deleted file mode 100644 index e047a2ba182..00000000000 --- a/analysis/src/References.ml +++ /dev/null @@ -1,573 +0,0 @@ -open SharedTypes - -let debugReferences = ref true -let maybeLog m = if !debugReferences then Log.log ("[ref] " ^ m) - -let checkPos (line, char) - {Location.loc_start = {pos_lnum; pos_bol; pos_cnum}; loc_end} = - if line < pos_lnum || (line = pos_lnum && char < pos_cnum - pos_bol) then - false - else if - line > loc_end.pos_lnum - || (line = loc_end.pos_lnum && char > loc_end.pos_cnum - loc_end.pos_bol) - then false - else true - -let locItemsForPos ~extra pos = - extra.locItems |> List.filter (fun {loc; locType = _} -> checkPos pos loc) - -let lineColToCmtLoc ~pos:(line, col) = (line + 1, col) - -let getLocItem ~full ~pos ~debug = - let log n msg = if debug then Printf.printf "getLocItem #%d: %s\n" n msg in - let pos = lineColToCmtLoc ~pos in - let locItems = locItemsForPos ~extra:full.extra pos in - if !Log.verbose then - print_endline - ("locItems:\n " - ^ (locItems |> List.map locItemToString |> String.concat "\n ")); - let nameOf li = - match li.locType with - | Typed (n, _, _) -> n - | _ -> "NotFound" - in - match locItems with - | li1 :: li2 :: li3 :: ({locType = Typed ("makeProps", _, _)} as li4) :: _ - when full.file.uri |> Uri.isInterface -> - log 1 "heuristic for makeProps in interface files"; - if debug then - Printf.printf "n1:%s n2:%s n3:%s\n" (nameOf li1) (nameOf li2) (nameOf li3); - Some li4 - | [ - {locType = Constant _}; - ({locType = Typed ("createDOMElementVariadic", _, _)} as li2); - ] -> - log 3 "heuristic for
"; - Some li2 - | {locType = Typed ("makeProps", _, _)} - :: ({locType = Typed ("make", _, _)} as li2) - :: _ -> - log 4 - "heuristic for within fragments: take make as makeProps does not \ - work\n\ - the type is not great but jump to definition works"; - Some li2 - | [ - ({locType = Typed (_, _, LocalReference _)} as li1); - ({locType = Typed (_, _, _)} as li2); - ] - when li1.loc = li2.loc -> - log 5 - "heuristic for JSX and compiler combined:\n\ - ~x becomes Props#x\n\ - heuristic for: [Props, x], give loc of `x`"; - if debug then Printf.printf "n1:%s n2:%s\n" (nameOf li1) (nameOf li2); - Some li2 - | [ - ({locType = Typed (_, _, LocalReference _)} as li1); - ({locType = Typed (_, _, GlobalReference ("Js_OO", ["unsafe_downgrade"], _))} - as li2); - li3; - ] - (* For older compiler 9.0 or earlier *) - when li1.loc = li2.loc && li2.loc = li3.loc -> - (* Not currently testable on 9.1.4 *) - log 6 - "heuristic for JSX and compiler combined:\n\ - ~x becomes Js_OO.unsafe_downgrade(Props)#x\n\ - heuristic for: [Props, unsafe_downgrade, x], give loc of `x`"; - Some li3 - | [ - ({locType = Typed (_, _, LocalReference (_, Value))} as li1); - ({locType = Typed (_, _, Definition (_, Value))} as li2); - ] -> - log 7 - "heuristic for JSX on type-annotated labeled (~arg:t):\n\ - (~arg:t) becomes Props#arg\n\ - Props has the location range of arg:t\n\ - arg has the location range of arg\n\ - heuristic for: [Props, arg], give loc of `arg`"; - if debug then Printf.printf "n1:%s n2:%s\n" (nameOf li1) (nameOf li2); - Some li2 - | [li1; li2; li3] when li1.loc = li2.loc && li2.loc = li3.loc -> - (* Not currently testable on 9.1.4 *) - log 8 - "heuristic for JSX with at most one child\n\ - heuristic for: [makeProps, make, createElement], give the loc of `make` "; - Some li2 - | [li1; li2; li3; li4] - when li1.loc = li2.loc && li2.loc = li3.loc && li3.loc = li4.loc -> - log 9 - "heuristic for JSX variadic, e.g. {x} {y} \n\ - heuristic for: [React.null, makeProps, make, createElementVariadic], \ - give the loc of `make`"; - if debug then - Printf.printf "n1:%s n2:%s n3:%s n4:%s\n" (nameOf li1) (nameOf li2) - (nameOf li3) (nameOf li4); - Some li3 - | {locType = Typed (_, {desc = Tconstr (path, _, _)}, _)} :: li :: _ - when Utils.isUncurriedInternal path -> - Some li - | li :: _ -> Some li - | _ -> None - -let declaredForTip ~(stamps : Stamps.t) stamp (tip : Tip.t) = - match tip with - | Value -> - Stamps.findValue stamps stamp - |> Option.map (fun x -> {x with Declared.item = ()}) - | Field _ | Constructor _ | Type -> - Stamps.findType stamps stamp - |> Option.map (fun x -> {x with Declared.item = ()}) - | Module -> - Stamps.findModule stamps stamp - |> Option.map (fun x -> {x with Declared.item = ()}) - -let getField (file : File.t) stamp name = - match Stamps.findType file.stamps stamp with - | None -> None - | Some {item = {kind}} -> ( - match kind with - | Record fields -> fields |> List.find_opt (fun f -> f.fname.txt = name) - | _ -> None) - -let getConstructor (file : File.t) stamp name = - match Stamps.findType file.stamps stamp with - | None -> None - | Some {item = {kind}} -> ( - match kind with - | Variant constructors -> ( - match - constructors - |> List.find_opt (fun const -> const.Constructor.cname.txt = name) - with - | None -> None - | Some const -> Some const) - | _ -> None) - -let exportedForTip ~env ~path ~package ~(tip : Tip.t) = - match ResolvePath.resolvePath ~env ~path ~package with - | None -> - Log.log ("Cannot resolve path " ^ pathToString path); - None - | Some (env, name) -> ( - let kind = - match tip with - | Value -> Exported.Value - | Field _ | Constructor _ | Type -> Exported.Type - | Module -> Exported.Module - in - match Exported.find env.exported kind name with - | None -> - Log.log ("Exported not found for tip " ^ name ^ " > " ^ Tip.toString tip); - None - | Some stamp -> Some (env, name, stamp)) - -let definedForLoc ~file ~package locKind = - let inner ~file stamp (tip : Tip.t) = - match tip with - | Constructor name -> ( - match getConstructor file stamp name with - | None -> None - | Some constructor -> - Some (constructor.docstring, `Constructor constructor)) - | Field name -> - Some - ( (match getField file stamp name with - | None -> [] - | Some field -> field.docstring), - `Field ) - | _ -> ( - maybeLog - ("Trying for declared " ^ Tip.toString tip ^ " " ^ string_of_int stamp - ^ " in file " ^ Uri.toString file.uri); - match declaredForTip ~stamps:file.stamps stamp tip with - | None -> None - | Some declared -> Some (declared.docstring, `Declared)) - in - match locKind with - | NotFound -> None - | LocalReference (stamp, tip) | Definition (stamp, tip) -> - inner ~file stamp tip - | GlobalReference (moduleName, path, tip) -> ( - maybeLog ("Getting global " ^ moduleName); - match ProcessCmt.fileForModule ~package moduleName with - | None -> - Log.log ("Cannot get module " ^ moduleName); - None - | Some file -> ( - let env = QueryEnv.fromFile file in - match exportedForTip ~env ~path ~package ~tip with - | None -> None - | Some (env, name, stamp) -> ( - maybeLog ("Getting for " ^ string_of_int stamp ^ " in " ^ name); - match inner ~file:env.file stamp tip with - | None -> - Log.log "could not get defined"; - None - | Some res -> - maybeLog "Yes!! got it"; - Some res))) - -(** Find alternative declaration: from res in case of interface, or from resi in case of implementation *) -let alternateDeclared ~(file : File.t) ~package (declared : _ Declared.t) tip = - match Hashtbl.find_opt package.pathsForModule file.moduleName with - | None -> None - | Some paths -> ( - match paths with - | IntfAndImpl {resi; res} -> ( - maybeLog - ("alternateDeclared for " ^ file.moduleName ^ " has both resi and res"); - let alternateUri = if Uri.isInterface file.uri then res else resi in - match Cmt.fullFromUri ~uri:(Uri.fromPath alternateUri) with - | None -> None - | Some {file; extra} -> ( - let env = QueryEnv.fromFile file in - let path = ModulePath.toPath declared.modulePath declared.name.txt in - maybeLog ("find declared for path " ^ pathToString path); - let declaredOpt = - match exportedForTip ~env ~path ~package ~tip with - | None -> None - | Some (_env, _name, stamp) -> - declaredForTip ~stamps:file.stamps stamp tip - in - match declaredOpt with - | None -> None - | Some declared -> Some (file, extra, declared))) - | _ -> - maybeLog ("alternateDeclared for " ^ file.moduleName ^ " not found"); - - None) - -let rec resolveModuleReference ?(pathsSeen = []) ~file ~package - (declared : Module.t Declared.t) = - match declared.item with - | Structure _ -> Some (file, Some declared) - | Constraint (_moduleItem, moduleTypeItem) -> - resolveModuleReference ~pathsSeen ~file ~package - {declared with item = moduleTypeItem} - | Ident path -> ( - let env = QueryEnv.fromFile file in - match ResolvePath.fromCompilerPath ~env path with - | NotFound -> None - | Exported (env, name) -> ( - match Exported.find env.exported Exported.Module name with - | None -> None - | Some stamp -> ( - match Stamps.findModule env.file.stamps stamp with - | None -> None - | Some md -> Some (env.file, Some md))) - | Global (moduleName, path) -> ( - match ProcessCmt.fileForModule ~package moduleName with - | None -> None - | Some file -> ( - let env = QueryEnv.fromFile file in - match ResolvePath.resolvePath ~env ~package ~path with - | None -> None - | Some (env, name) -> ( - match Exported.find env.exported Exported.Module name with - | None -> None - | Some stamp -> ( - match Stamps.findModule env.file.stamps stamp with - | None -> None - | Some md -> Some (env.file, Some md))))) - | Stamp stamp -> ( - match Stamps.findModule file.stamps stamp with - | None -> None - | Some ({item = Ident path} as md) when not (List.mem path pathsSeen) -> - (* avoid possible infinite loops *) - resolveModuleReference ~file ~package ~pathsSeen:(path :: pathsSeen) md - | Some md -> Some (file, Some md)) - | GlobalMod name -> ( - match ProcessCmt.fileForModule ~package name with - | None -> None - | Some file -> Some (file, None))) - -let validateLoc (loc : Location.t) (backup : Location.t) = - if loc.loc_start.pos_cnum = -1 then - if backup.loc_start.pos_cnum = -1 then - { - Location.loc_ghost = true; - loc_start = {pos_cnum = 0; pos_lnum = 1; pos_bol = 0; pos_fname = ""}; - loc_end = {pos_cnum = 0; pos_lnum = 1; pos_bol = 0; pos_fname = ""}; - } - else backup - else loc - -let resolveModuleDefinition ~(file : File.t) ~package stamp = - match Stamps.findModule file.stamps stamp with - | None -> None - | Some md -> ( - match resolveModuleReference ~file ~package md with - | None -> None - | Some (file, declared) -> - let loc = - match declared with - | None -> Uri.toTopLevelLoc file.uri - | Some declared -> validateLoc declared.name.loc declared.extentLoc - in - Some (file.uri, loc)) - -let definition ~file ~package stamp (tip : Tip.t) = - match tip with - | Constructor name -> ( - match getConstructor file stamp name with - | None -> None - | Some constructor -> Some (file.uri, constructor.cname.loc)) - | Field name -> ( - match getField file stamp name with - | None -> None - | Some field -> Some (file.uri, field.fname.loc)) - | Module -> resolveModuleDefinition ~file ~package stamp - | _ -> ( - match declaredForTip ~stamps:file.stamps stamp tip with - | None -> None - | Some declared -> - let fileImpl, declaredImpl = - match alternateDeclared ~package ~file declared tip with - | Some (fileImpl, _extra, declaredImpl) when Uri.isInterface file.uri -> - (fileImpl, declaredImpl) - | _ -> (file, declared) - in - let loc = validateLoc declaredImpl.name.loc declaredImpl.extentLoc in - let env = QueryEnv.fromFile fileImpl in - let uri = - ResolvePath.getSourceUri ~env ~package declaredImpl.modulePath - in - maybeLog ("Inner uri " ^ Uri.toString uri); - Some (uri, loc)) - -let definitionForLocItem ~full:{file; package} locItem = - match locItem.locType with - | Typed (_, _, Definition (stamp, tip)) -> ( - maybeLog - ("Typed Definition stamp:" ^ string_of_int stamp ^ " tip:" - ^ Tip.toString tip); - match declaredForTip ~stamps:file.stamps stamp tip with - | None -> None - | Some declared -> - maybeLog ("Declared " ^ declared.name.txt); - if declared.isExported then ( - maybeLog ("exported, looking for alternate " ^ file.moduleName); - match alternateDeclared ~package ~file declared tip with - | None -> None - | Some (file, _extra, declared) -> - let loc = validateLoc declared.name.loc declared.extentLoc in - Some (file.uri, loc)) - else None) - | Typed (_, _, NotFound) - | LModule (NotFound | Definition (_, _)) - | TypeDefinition (_, _, _) - | Constant _ -> - None - | TopLevelModule name -> ( - maybeLog ("Toplevel " ^ name); - match Hashtbl.find_opt package.pathsForModule name with - | None -> None - | Some paths -> - let uri = getUri paths in - Some (uri, Uri.toTopLevelLoc uri)) - | LModule (LocalReference (stamp, tip)) - | Typed (_, _, LocalReference (stamp, tip)) -> - maybeLog ("Local defn " ^ Tip.toString tip); - definition ~file ~package stamp tip - | LModule (GlobalReference (moduleName, path, tip)) - | Typed (_, _, GlobalReference (moduleName, path, tip)) -> ( - maybeLog - ("Typed GlobalReference moduleName:" ^ moduleName ^ " path:" - ^ pathToString path ^ " tip:" ^ Tip.toString tip); - match ProcessCmt.fileForModule ~package moduleName with - | None -> None - | Some file -> ( - let env = QueryEnv.fromFile file in - match exportedForTip ~env ~path ~package ~tip with - | None -> None - | Some (env, _name, stamp) -> - (* oooh wht do I do if the stamp is inside a pseudo-file? *) - maybeLog ("Got stamp " ^ string_of_int stamp); - definition ~file:env.file ~package stamp tip)) - -let digConstructor ~env ~package path = - match ResolvePath.resolveFromCompilerPath ~env ~package path with - | NotFound -> None - | Stamp stamp -> ( - match Stamps.findType env.file.stamps stamp with - | None -> None - | Some t -> Some (env, t)) - | Exported (env, name) -> ( - match Exported.find env.exported Exported.Type name with - | None -> None - | Some stamp -> ( - match Stamps.findType env.file.stamps stamp with - | None -> None - | Some t -> Some (env, t))) - | _ -> None - -let typeDefinitionForLocItem ~full:{file; package} locItem = - match locItem.locType with - | Constant _ | TopLevelModule _ | LModule _ -> None - | TypeDefinition _ -> Some (file.uri, locItem.loc) - | Typed (_, typ, _) -> ( - let env = QueryEnv.fromFile file in - match Shared.digConstructor typ with - | None -> None - | Some path -> ( - match digConstructor ~env ~package path with - | Some (env, declared) -> Some (env.file.uri, declared.item.decl.type_loc) - | None -> None)) - -let isVisible (declared : _ Declared.t) = - declared.isExported - && - let rec loop (v : ModulePath.t) = - match v with - | File _ -> true - | NotVisible -> false - | IncludedModule (_, inner) -> loop inner - | ExportedModule {modulePath = inner} -> loop inner - in - loop declared.modulePath - -type references = { - uri: Uri.t; - locOpt: Location.t option; (* None: reference to a toplevel module *) -} - -let forLocalStamp ~full:{file; extra; package} stamp (tip : Tip.t) = - let env = QueryEnv.fromFile file in - match - match tip with - | Constructor name -> - getConstructor file stamp name - |> Option.map (fun x -> x.Constructor.stamp) - | Field name -> getField file stamp name |> Option.map (fun x -> x.stamp) - | _ -> Some stamp - with - | None -> [] - | Some localStamp -> ( - match Hashtbl.find_opt extra.internalReferences localStamp with - | None -> [] - | Some locs -> - maybeLog ("Checking externals: " ^ string_of_int stamp); - let externals = - match declaredForTip ~stamps:env.file.stamps stamp tip with - | None -> [] - | Some declared -> - if isVisible declared then ( - let alternativeReferences = - match alternateDeclared ~package ~file declared tip with - | None -> [] - | Some (file, extra, {stamp}) -> ( - match - match tip with - | Constructor name -> - getConstructor file stamp name - |> Option.map (fun x -> x.Constructor.stamp) - | Field name -> - getField file stamp name |> Option.map (fun x -> x.stamp) - | _ -> Some stamp - with - | None -> [] - | Some localStamp -> ( - match - Hashtbl.find_opt extra.internalReferences localStamp - with - | None -> [] - | Some locs -> - locs - |> List.map (fun loc -> {uri = file.uri; locOpt = Some loc}) - )) - (* if this file has a corresponding interface or implementation file - also find the references in that file *) - in - let path = - ModulePath.toPath declared.modulePath declared.name.txt - in - maybeLog ("Now checking path " ^ pathToString path); - let thisModuleName = file.moduleName in - let externals = - package.projectFiles |> FileSet.elements - |> List.filter (fun name -> name <> file.moduleName) - |> List.map (fun moduleName -> - Cmt.fullsFromModule ~package ~moduleName - |> List.map (fun {file; extra} -> - match - Hashtbl.find_opt extra.externalReferences - thisModuleName - with - | None -> [] - | Some refs -> - let locs = - refs - |> Utils.filterMap (fun (p, t, locs) -> - if p = path && t = tip then Some locs - else None) - in - locs - |> List.map (fun loc -> - {uri = file.uri; locOpt = Some loc}))) - |> List.concat |> List.concat - in - alternativeReferences @ externals) - else ( - maybeLog "Not visible"; - []) - in - List.append - (locs |> List.map (fun loc -> {uri = file.uri; locOpt = Some loc})) - externals) - -let allReferencesForLocItem ~full:({file; package} as full) locItem = - match locItem.locType with - | TopLevelModule moduleName -> - let otherModulesReferences = - package.projectFiles |> FileSet.elements - |> Utils.filterMap (fun name -> - match ProcessCmt.fileForModule ~package name with - | None -> None - | Some file -> Cmt.fullFromUri ~uri:file.uri) - |> List.map (fun full -> - match Hashtbl.find_opt full.extra.fileReferences moduleName with - | None -> [] - | Some locs -> - locs |> LocationSet.elements - |> List.map (fun loc -> - { - uri = Uri.fromPath loc.Location.loc_start.pos_fname; - locOpt = Some loc; - })) - |> List.flatten - in - let targetModuleReferences = - match Hashtbl.find_opt package.pathsForModule moduleName with - | None -> [] - | Some paths -> - let moduleSrcToRef src = {uri = Uri.fromPath src; locOpt = None} in - getSrc paths |> List.map moduleSrcToRef - in - List.append targetModuleReferences otherModulesReferences - | Typed (_, _, NotFound) | LModule NotFound | Constant _ -> [] - | TypeDefinition (_, _, stamp) -> forLocalStamp ~full stamp Type - | Typed (_, _, (LocalReference (stamp, tip) | Definition (stamp, tip))) - | LModule (LocalReference (stamp, tip) | Definition (stamp, tip)) -> - maybeLog - ("Finding references for " ^ Uri.toString file.uri ^ " and stamp " - ^ string_of_int stamp ^ " and tip " ^ Tip.toString tip); - forLocalStamp ~full stamp tip - | LModule (GlobalReference (moduleName, path, tip)) - | Typed (_, _, GlobalReference (moduleName, path, tip)) -> ( - match ProcessCmt.fileForModule ~package moduleName with - | None -> [] - | Some file -> ( - let env = QueryEnv.fromFile file in - match exportedForTip ~env ~path ~package ~tip with - | None -> [] - | Some (env, _name, stamp) -> ( - match Cmt.fullFromUri ~uri:env.file.uri with - | None -> [] - | Some full -> - maybeLog - ("Finding references for (global) " ^ Uri.toString env.file.uri - ^ " and stamp " ^ string_of_int stamp ^ " and tip " - ^ Tip.toString tip); - forLocalStamp ~full stamp tip))) diff --git a/analysis/src/ResolvePath.ml b/analysis/src/ResolvePath.ml deleted file mode 100644 index 877e273fe8f..00000000000 --- a/analysis/src/ResolvePath.ml +++ /dev/null @@ -1,148 +0,0 @@ -open SharedTypes - -type resolution = - | Exported of QueryEnv.t * filePath - | Global of filePath * filePath list - | GlobalMod of filePath - | NotFound - | Stamp of int - -let rec joinPaths modulePath path = - match modulePath with - | Path.Pident ident -> (ident.stamp, ident.name, path) - | Papply (fnPath, _argPath) -> joinPaths fnPath path - | Pdot (inner, name, _) -> joinPaths inner (name :: path) - -let rec makePath ~(env : QueryEnv.t) modulePath = - match modulePath with - | Path.Pident ident when ident.stamp == 0 -> GlobalMod ident.name - | Pident ident -> Stamp ident.stamp - | Papply (fnPath, _argPath) -> makePath ~env fnPath - | Pdot (inner, name, _) -> ( - match joinPaths inner [name] with - | 0, moduleName, path -> Global (moduleName, path) - | stamp, _moduleName, path -> ( - let res = - match Stamps.findModule env.file.stamps stamp with - | None -> None - | Some {item = kind} -> findInModule ~env kind path - in - match res with - | None -> NotFound - | Some (`Local (env, name)) -> Exported (env, name) - | Some (`Global (moduleName, fullPath)) -> Global (moduleName, fullPath))) - -and resolvePathInner ~(env : QueryEnv.t) ~path = - match path with - | [] -> None - | [name] -> Some (`Local (env, name)) - | subName :: subPath -> ( - match Exported.find env.exported Exported.Module subName with - | None -> None - | Some stamp -> ( - match Stamps.findModule env.file.stamps stamp with - | None -> None - | Some {item} -> findInModule ~env item subPath)) - -and findInModule ~(env : QueryEnv.t) module_ path = - match module_ with - | Structure structure -> - resolvePathInner ~env:(QueryEnv.enterStructure env structure) ~path - | Constraint (_, module1) -> findInModule ~env module1 path - | Ident modulePath -> ( - let stamp, moduleName, fullPath = joinPaths modulePath path in - if stamp = 0 then Some (`Global (moduleName, fullPath)) - else - match Stamps.findModule env.file.stamps stamp with - | None -> None - | Some {item} -> findInModule ~env item fullPath) - -let rec resolvePath ~env ~path ~package = - Log.log ("resolvePath path:" ^ pathToString path); - match resolvePathInner ~env ~path with - | None -> None - | Some result -> ( - match result with - | `Local (env, name) -> Some (env, name) - | `Global (moduleName, fullPath) -> ( - Log.log - ("resolvePath Global path:" ^ pathToString fullPath ^ " module:" - ^ moduleName); - match ProcessCmt.fileForModule ~package moduleName with - | None -> None - | Some file -> - resolvePath ~env:(QueryEnv.fromFile file) ~path:fullPath ~package)) - -let fromCompilerPath ~(env : QueryEnv.t) path : resolution = - match makePath ~env path with - | Stamp stamp -> Stamp stamp - | GlobalMod name -> GlobalMod name - | NotFound -> NotFound - | Exported (env, name) -> Exported (env, name) - | Global (moduleName, fullPath) -> Global (moduleName, fullPath) - -let resolveModuleFromCompilerPath ~env ~package path = - match fromCompilerPath ~env path with - | Global (moduleName, path) -> ( - match ProcessCmt.fileForModule ~package moduleName with - | None -> None - | Some file -> ( - let env = QueryEnv.fromFile file in - match resolvePath ~env ~package ~path with - | None -> None - | Some (env, name) -> ( - match Exported.find env.exported Exported.Module name with - | None -> None - | Some stamp -> ( - match Stamps.findModule env.file.stamps stamp with - | None -> None - | Some declared -> Some (env, Some declared))))) - | Stamp stamp -> ( - match Stamps.findModule env.file.stamps stamp with - | None -> None - | Some declared -> Some (env, Some declared)) - | GlobalMod moduleName -> ( - match ProcessCmt.fileForModule ~package moduleName with - | None -> None - | Some file -> - let env = QueryEnv.fromFile file in - Some (env, None)) - | NotFound -> None - | Exported (env, name) -> ( - match Exported.find env.exported Exported.Module name with - | None -> None - | Some stamp -> ( - match Stamps.findModule env.file.stamps stamp with - | None -> None - | Some declared -> Some (env, Some declared))) - -let resolveFromCompilerPath ~env ~package path = - match fromCompilerPath ~env path with - | Global (moduleName, path) -> ( - let res = - match ProcessCmt.fileForModule ~package moduleName with - | None -> None - | Some file -> - let env = QueryEnv.fromFile file in - resolvePath ~env ~package ~path - in - match res with - | None -> NotFound - | Some (env, name) -> Exported (env, name)) - | Stamp stamp -> Stamp stamp - | GlobalMod _ -> NotFound - | NotFound -> NotFound - | Exported (env, name) -> Exported (env, name) - -let rec getSourceUri ~(env : QueryEnv.t) ~package (path : ModulePath.t) = - match path with - | File (uri, _moduleName) -> uri - | NotVisible -> env.file.uri - | IncludedModule (path, inner) -> ( - Log.log "INCLUDED MODULE"; - match resolveModuleFromCompilerPath ~env ~package path with - | None -> - Log.log "NOT FOUND"; - getSourceUri ~env ~package inner - | Some (env, _declared) -> env.file.uri) - | ExportedModule {modulePath = inner} -> getSourceUri ~env ~package inner diff --git a/analysis/src/Scope.ml b/analysis/src/Scope.ml deleted file mode 100644 index 33e850bc027..00000000000 --- a/analysis/src/Scope.ml +++ /dev/null @@ -1,149 +0,0 @@ -type item = SharedTypes.ScopeTypes.item - -type t = item list - -open SharedTypes.ScopeTypes - -let itemToString item = - let str s = if s = "" then "\"\"" else s in - let list l = "[" ^ (l |> List.map str |> String.concat ", ") ^ "]" in - match item with - | Constructor (s, loc) -> "Constructor " ^ s ^ " " ^ Loc.toString loc - | Field (s, loc) -> "Field " ^ s ^ " " ^ Loc.toString loc - | Open sl -> "Open " ^ list sl - | Module (s, loc) -> "Module " ^ s ^ " " ^ Loc.toString loc - | Value (s, loc, _, _) -> "Value " ^ s ^ " " ^ Loc.toString loc - | Type (s, loc) -> "Type " ^ s ^ " " ^ Loc.toString loc - | Include (s, loc) -> "Include " ^ s ^ " " ^ Loc.toString loc -[@@live] - -let create () : t = [] -let addConstructor ~name ~loc x = Constructor (name, loc) :: x -let addField ~name ~loc x = Field (name, loc) :: x -let addModule ~name ~loc x = Module (name, loc) :: x -let addOpen ~lid x = Open (Utils.flattenLongIdent lid @ ["place holder"]) :: x -let addValue ~name ~loc ?contextPath x = - let showDebug = !Cfg.debugFollowCtxPath in - (if showDebug then - match contextPath with - | None -> Printf.printf "adding value '%s', no ctxPath\n" name - | Some contextPath -> - if showDebug then - Printf.printf "adding value '%s' with ctxPath: %s\n" name - (SharedTypes.Completable.contextPathToString contextPath)); - Value (name, loc, contextPath, x) :: x -let addType ~name ~loc x = Type (name, loc) :: x -let addInclude ~name ~loc x = Include (name, loc) :: x - -let iterValuesBeforeFirstOpen f x = - let rec loop items = - match items with - | Value (s, loc, contextPath, scope) :: rest -> - f s loc contextPath scope; - loop rest - | Open _ :: _ -> () - | _ :: rest -> loop rest - | [] -> () - in - loop x - -let iterValuesAfterFirstOpen f x = - let rec loop foundOpen items = - match items with - | Value (s, loc, contextPath, scope) :: rest -> - if foundOpen then f s loc contextPath scope; - loop foundOpen rest - | Open _ :: rest -> loop true rest - | _ :: rest -> loop foundOpen rest - | [] -> () - in - loop false x - -let iterConstructorsBeforeFirstOpen f x = - let rec loop items = - match items with - | Constructor (s, loc) :: rest -> - f s loc; - loop rest - | Open _ :: _ -> () - | _ :: rest -> loop rest - | [] -> () - in - loop x - -let iterConstructorsAfterFirstOpen f x = - let rec loop foundOpen items = - match items with - | Constructor (s, loc) :: rest -> - if foundOpen then f s loc; - loop foundOpen rest - | Open _ :: rest -> loop true rest - | _ :: rest -> loop foundOpen rest - | [] -> () - in - loop false x - -let iterTypesBeforeFirstOpen f x = - let rec loop items = - match items with - | Type (s, loc) :: rest -> - f s loc; - loop rest - | Open _ :: _ -> () - | _ :: rest -> loop rest - | [] -> () - in - loop x - -let iterTypesAfterFirstOpen f x = - let rec loop foundOpen items = - match items with - | Type (s, loc) :: rest -> - if foundOpen then f s loc; - loop foundOpen rest - | Open _ :: rest -> loop true rest - | _ :: rest -> loop foundOpen rest - | [] -> () - in - loop false x - -let iterModulesBeforeFirstOpen f x = - let rec loop items = - match items with - | Module (s, loc) :: rest -> - f s loc; - loop rest - | Open _ :: _ -> () - | _ :: rest -> loop rest - | [] -> () - in - loop x - -let iterModulesAfterFirstOpen f x = - let rec loop foundOpen items = - match items with - | Module (s, loc) :: rest -> - if foundOpen then f s loc; - loop foundOpen rest - | Open _ :: rest -> loop true rest - | _ :: rest -> loop foundOpen rest - | [] -> () - in - loop false x - -let iterIncludes f x = - let rec loop items = - match items with - | [] -> () - | Include (s, loc) :: rest -> - f s loc; - loop rest - | _ :: rest -> loop rest - in - loop x - -let getRawOpens x = - x - |> Utils.filterMap (function - | Open path -> Some path - | _ -> None) diff --git a/analysis/src/SharedTypes.ml b/analysis/src/SharedTypes.ml deleted file mode 100644 index cce06e969e9..00000000000 --- a/analysis/src/SharedTypes.ml +++ /dev/null @@ -1,954 +0,0 @@ -let str s = if s = "" then "\"\"" else s -let list l = "[" ^ (l |> List.map str |> String.concat ", ") ^ "]" -let ident l = l |> List.map str |> String.concat "." - -type path = string list - -type typedFnArg = Asttypes.arg_label * Types.type_expr - -let pathToString (path : path) = path |> String.concat "." - -module ModulePath = struct - type t = - | File of Uri.t * string - | NotVisible - | IncludedModule of Path.t * t - | ExportedModule of {name: string; modulePath: t; isType: bool} - - let toPath modulePath tipName : path = - let rec loop modulePath current = - match modulePath with - | File _ -> current - | IncludedModule (_, inner) -> loop inner current - | ExportedModule {name; modulePath = inner} -> loop inner (name :: current) - | NotVisible -> current - in - loop modulePath [tipName] - - let toPathWithPrefix modulePath prefix : path = - let rec loop modulePath current = - match modulePath with - | File _ -> current - | IncludedModule (_, inner) -> loop inner current - | ExportedModule {name; modulePath = inner} -> loop inner (name :: current) - | NotVisible -> current - in - prefix :: loop modulePath [] -end - -type field = { - stamp: int; - fname: string Location.loc; - typ: Types.type_expr; - optional: bool; - docstring: string list; - deprecated: string option; -} - -type constructorArgs = - | InlineRecord of field list - | Args of (Types.type_expr * Location.t) list - -module Constructor = struct - type t = { - stamp: int; - cname: string Location.loc; - args: constructorArgs; - res: Types.type_expr option; - typeDecl: string * Types.type_declaration; - docstring: string list; - deprecated: string option; - } -end - -module Type = struct - type kind = - | Abstract of (Path.t * Types.type_expr list) option - | Open - | Tuple of Types.type_expr list - | Record of field list - | Variant of Constructor.t list - - type t = { - kind: kind; - decl: Types.type_declaration; - name: string; - attributes: Parsetree.attributes; - } -end - -module Exported = struct - type namedStampMap = (string, int) Hashtbl.t - - type t = { - types_: namedStampMap; - values_: namedStampMap; - modules_: namedStampMap; - } - - type kind = Type | Value | Module - - let init () = - { - types_ = Hashtbl.create 10; - values_ = Hashtbl.create 10; - modules_ = Hashtbl.create 10; - } - - let add t kind name x = - let tbl = - match kind with - | Type -> t.types_ - | Value -> t.values_ - | Module -> t.modules_ - in - if Hashtbl.mem tbl name then false - else - let () = Hashtbl.add tbl name x in - true - - let find t kind name = - let tbl = - match kind with - | Type -> t.types_ - | Value -> t.values_ - | Module -> t.modules_ - in - Hashtbl.find_opt tbl name - - let iter t kind f = - let tbl = - match kind with - | Type -> t.types_ - | Value -> t.values_ - | Module -> t.modules_ - in - Hashtbl.iter f tbl -end - -module Module = struct - type kind = - | Value of Types.type_expr - | Type of Type.t * Types.rec_status - | Module of {type_: t; isModuleType: bool} - - and item = { - kind: kind; - name: string; - loc: Location.t; - docstring: string list; - deprecated: string option; - } - - and structure = { - name: string; - docstring: string list; - exported: Exported.t; - items: item list; - deprecated: string option; - } - - and t = Ident of Path.t | Structure of structure | Constraint of t * t -end - -module Declared = struct - type 'item t = { - name: string Location.loc; - extentLoc: Location.t; - stamp: int; - modulePath: ModulePath.t; - isExported: bool; - deprecated: string option; - docstring: string list; - item: 'item; - } -end - -module Stamps : sig - type kind = - | KType of Type.t Declared.t - | KValue of Types.type_expr Declared.t - | KModule of Module.t Declared.t - | KConstructor of Constructor.t Declared.t - - val locOfKind : kind -> Warnings.loc - - type t - - val addConstructor : t -> int -> Constructor.t Declared.t -> unit - val addModule : t -> int -> Module.t Declared.t -> unit - val addType : t -> int -> Type.t Declared.t -> unit - val addValue : t -> int -> Types.type_expr Declared.t -> unit - val findModule : t -> int -> Module.t Declared.t option - val findType : t -> int -> Type.t Declared.t option - val findValue : t -> int -> Types.type_expr Declared.t option - val init : unit -> t - val iterConstructors : (int -> Constructor.t Declared.t -> unit) -> t -> unit - val iterModules : (int -> Module.t Declared.t -> unit) -> t -> unit - val iterTypes : (int -> Type.t Declared.t -> unit) -> t -> unit - val iterValues : (int -> Types.type_expr Declared.t -> unit) -> t -> unit - val getEntries : t -> (int * kind) list -end = struct - type 't stampMap = (int, 't Declared.t) Hashtbl.t - - type kind = - | KType of Type.t Declared.t - | KValue of Types.type_expr Declared.t - | KModule of Module.t Declared.t - | KConstructor of Constructor.t Declared.t - - let locOfKind = function - | KType declared -> declared.extentLoc - | KValue declared -> declared.extentLoc - | KModule declared -> declared.extentLoc - | KConstructor declared -> declared.extentLoc - - type t = (int, kind) Hashtbl.t - - let init () = Hashtbl.create 10 - - let addConstructor (stamps : t) stamp declared = - Hashtbl.add stamps stamp (KConstructor declared) - - let addModule stamps stamp declared = - Hashtbl.add stamps stamp (KModule declared) - - let addType stamps stamp declared = Hashtbl.add stamps stamp (KType declared) - - let addValue stamps stamp declared = - Hashtbl.add stamps stamp (KValue declared) - - let findModule stamps stamp = - match Hashtbl.find_opt stamps stamp with - | Some (KModule declared) -> Some declared - | _ -> None - - let findType stamps stamp = - match Hashtbl.find_opt stamps stamp with - | Some (KType declared) -> Some declared - | _ -> None - - let findValue stamps stamp = - match Hashtbl.find_opt stamps stamp with - | Some (KValue declared) -> Some declared - | _ -> None - - let iterModules f stamps = - Hashtbl.iter - (fun stamp d -> - match d with - | KModule d -> f stamp d - | _ -> ()) - stamps - - let iterTypes f stamps = - Hashtbl.iter - (fun stamp d -> - match d with - | KType d -> f stamp d - | _ -> ()) - stamps - - let iterValues f stamps = - Hashtbl.iter - (fun stamp d -> - match d with - | KValue d -> f stamp d - | _ -> ()) - stamps - - let iterConstructors f stamps = - Hashtbl.iter - (fun stamp d -> - match d with - | KConstructor d -> f stamp d - | _ -> ()) - stamps - - let getEntries t = t |> Hashtbl.to_seq |> List.of_seq -end - -module File = struct - type t = { - uri: Uri.t; - stamps: Stamps.t; - moduleName: string; - structure: Module.structure; - } - - let create moduleName uri = - { - uri; - stamps = Stamps.init (); - moduleName; - structure = - { - name = moduleName; - docstring = []; - exported = Exported.init (); - items = []; - deprecated = None; - }; - } -end - -module QueryEnv : sig - type t = private { - file: File.t; - exported: Exported.t; - pathRev: path; - parent: t option; - } - val fromFile : File.t -> t - val enterStructure : t -> Module.structure -> t - - (* Express a path starting from the module represented by the env. - E.g. the env is at A.B.C and the path is D. - The result is A.B.C.D if D is inside C. - Or A.B.D or A.D or D if it's in one of its parents. *) - val pathFromEnv : t -> path -> bool * path - - val toString : t -> string -end = struct - type t = {file: File.t; exported: Exported.t; pathRev: path; parent: t option} - - let toString {file; pathRev} = - file.moduleName :: List.rev pathRev |> String.concat "." - - let fromFile (file : File.t) = - {file; exported = file.structure.exported; pathRev = []; parent = None} - - (* Prune a path and find a parent environment that contains the module name *) - let rec prunePath pathRev env name = - if Exported.find env.exported Module name <> None then (true, pathRev) - else - match (pathRev, env.parent) with - | _ :: rest, Some env -> prunePath rest env name - | _ -> (false, []) - - let pathFromEnv env path = - match path with - | [] -> (true, env.pathRev |> List.rev) - | name :: _ -> - let found, prunedPathRev = prunePath env.pathRev env name in - (found, List.rev_append prunedPathRev path) - - let enterStructure env (structure : Module.structure) = - let name = structure.name in - let pathRev = name :: snd (prunePath env.pathRev env name) in - {env with exported = structure.exported; pathRev; parent = Some env} -end - -type typeArgContext = { - env: QueryEnv.t; - typeArgs: Types.type_expr list; - typeParams: Types.type_expr list; -} - -type polyVariantConstructor = { - name: string; - displayName: string; - args: Types.type_expr list; -} - -(* TODO(env-stuff) All envs for bool string etc can be removed. *) -type innerType = TypeExpr of Types.type_expr | ExtractedType of completionType -and completionType = - | Tuple of QueryEnv.t * Types.type_expr list * Types.type_expr - | Texn of QueryEnv.t - | Tpromise of QueryEnv.t * Types.type_expr - | Toption of QueryEnv.t * innerType - | Tresult of { - env: QueryEnv.t; - okType: Types.type_expr; - errorType: Types.type_expr; - } - | Tbool of QueryEnv.t - | Tarray of QueryEnv.t * innerType - | Tstring of QueryEnv.t - | TtypeT of {env: QueryEnv.t; path: Path.t} - | Tvariant of { - env: QueryEnv.t; - constructors: Constructor.t list; - variantDecl: Types.type_declaration; - variantName: string; - } - | Tpolyvariant of { - env: QueryEnv.t; - constructors: polyVariantConstructor list; - typeExpr: Types.type_expr; - } - | Trecord of { - env: QueryEnv.t; - fields: field list; - definition: - [ `NameOnly of string - (** When we only have the name, like when pulling the record from a declared type. *) - | `TypeExpr of Types.type_expr - (** When we have the full type expr from the compiler. *) ]; - } - | TinlineRecord of {env: QueryEnv.t; fields: field list} - | Tfunction of { - env: QueryEnv.t; - args: typedFnArg list; - typ: Types.type_expr; - returnType: Types.type_expr; - } - -module Env = struct - type t = {stamps: Stamps.t; modulePath: ModulePath.t} - let addExportedModule ~name ~isType env = - { - env with - modulePath = ExportedModule {name; modulePath = env.modulePath; isType}; - } - let addModule ~name env = env |> addExportedModule ~name ~isType:false - let addModuleType ~name env = env |> addExportedModule ~name ~isType:true -end - -type filePath = string - -type paths = - | Impl of {cmt: filePath; res: filePath} - | Namespace of {cmt: filePath} - | IntfAndImpl of { - cmti: filePath; - resi: filePath; - cmt: filePath; - res: filePath; - } - -let showPaths paths = - match paths with - | Impl {cmt; res} -> - Printf.sprintf "Impl cmt:%s res:%s" (Utils.dumpPath cmt) - (Utils.dumpPath res) - | Namespace {cmt} -> Printf.sprintf "Namespace cmt:%s" (Utils.dumpPath cmt) - | IntfAndImpl {cmti; resi; cmt; res} -> - Printf.sprintf "IntfAndImpl cmti:%s resi:%s cmt:%s res:%s" - (Utils.dumpPath cmti) (Utils.dumpPath resi) (Utils.dumpPath cmt) - (Utils.dumpPath res) - -let getSrc p = - match p with - | Impl {res} -> [res] - | Namespace _ -> [] - | IntfAndImpl {resi; res} -> [resi; res] - -let getUri p = - match p with - | Impl {res} -> Uri.fromPath res - | Namespace {cmt} -> Uri.fromPath cmt - | IntfAndImpl {resi} -> Uri.fromPath resi - -let getUris p = - match p with - | Impl {res} -> [Uri.fromPath res] - | Namespace {cmt} -> [Uri.fromPath cmt] - | IntfAndImpl {res; resi} -> [Uri.fromPath res; Uri.fromPath resi] - -let getCmtPath ~uri p = - match p with - | Impl {cmt} -> cmt - | Namespace {cmt} -> cmt - | IntfAndImpl {cmti; cmt} -> - let interface = Utils.endsWith (Uri.toPath uri) "i" in - if interface then cmti else cmt - -module Tip = struct - type t = Value | Type | Field of string | Constructor of string | Module - - let toString tip = - match tip with - | Value -> "Value" - | Type -> "Type" - | Field f -> "Field(" ^ f ^ ")" - | Constructor a -> "Constructor(" ^ a ^ ")" - | Module -> "Module" -end - -let rec pathIdentToString (p : Path.t) = - match p with - | Pident {name} -> name - | Pdot (nextPath, id, _) -> - Printf.sprintf "%s.%s" (pathIdentToString nextPath) id - | Papply _ -> "" - -type locKind = - | LocalReference of int * Tip.t - | GlobalReference of string * string list * Tip.t - | NotFound - | Definition of int * Tip.t - -type locType = - | Typed of string * Types.type_expr * locKind - | Constant of Asttypes.constant - | LModule of locKind - | TopLevelModule of string - | TypeDefinition of string * Types.type_declaration * int - -type locItem = {loc: Location.t; locType: locType} - -module LocationSet = Set.Make (struct - include Location - - let compare loc1 loc2 = compare loc2 loc1 - - (* polymorphic compare should be OK *) -end) - -type extra = { - internalReferences: (int, Location.t list) Hashtbl.t; - externalReferences: - (string, (string list * Tip.t * Location.t) list) Hashtbl.t; - fileReferences: (string, LocationSet.t) Hashtbl.t; - mutable locItems: locItem list; -} - -type file = string - -module FileSet = Set.Make (String) - -type package = { - genericJsxModule: string option; - suffix: string; - rootPath: filePath; - projectFiles: FileSet.t; - dependenciesFiles: FileSet.t; - pathsForModule: (file, paths) Hashtbl.t; - namespace: string option; - opens: path list; - rescriptVersion: int * int; - autocomplete: file list Misc.StringMap.t; -} - -let allFilesInPackage package = - FileSet.union package.projectFiles package.dependenciesFiles - -type full = {extra: extra; file: File.t; package: package} - -let initExtra () = - { - internalReferences = Hashtbl.create 10; - externalReferences = Hashtbl.create 10; - fileReferences = Hashtbl.create 10; - locItems = []; - } - -type state = { - packagesByRoot: (string, package) Hashtbl.t; - rootForUri: (Uri.t, string) Hashtbl.t; - cmtCache: (filePath, File.t) Hashtbl.t; -} - -(* There's only one state, so it can as well be global *) -let state = - { - packagesByRoot = Hashtbl.create 1; - rootForUri = Hashtbl.create 30; - cmtCache = Hashtbl.create 30; - } - -let locKindToString = function - | LocalReference (_, tip) -> "(LocalReference " ^ Tip.toString tip ^ ")" - | GlobalReference _ -> "GlobalReference" - | NotFound -> "NotFound" - | Definition (_, tip) -> "(Definition " ^ Tip.toString tip ^ ")" - -let locTypeToString = function - | Typed (name, e, locKind) -> - "Typed " ^ name ^ " " ^ Shared.typeToString e ^ " " - ^ locKindToString locKind - | Constant _ -> "Constant" - | LModule locKind -> "LModule " ^ locKindToString locKind - | TopLevelModule _ -> "TopLevelModule" - | TypeDefinition _ -> "TypeDefinition" - -let locItemToString {loc = {Location.loc_start; loc_end}; locType} = - let pos1 = Utils.cmtPosToPosition loc_start in - let pos2 = Utils.cmtPosToPosition loc_end in - Printf.sprintf "%d:%d-%d:%d %s" pos1.line pos1.character pos2.line - pos2.character (locTypeToString locType) - -(* needed for debugging *) -let _ = locItemToString - -module Completable = struct - (* Completion context *) - type completionContext = Type | Value | Module | Field | ValueOrField - - type argumentLabel = - | Unlabelled of {argumentPosition: int} - | Labelled of string - | Optional of string - - (** Additional context for nested completion where needed. *) - type nestedContext = - | RecordField of {seenFields: string list} - (** Completing for a record field, and we already saw the following fields... *) - | CameFromRecordField of string - (** We just came from this field (we leverage use this for better - completion names etc) *) - - type nestedPath = - | NTupleItem of {itemNum: int} - | NFollowRecordField of {fieldName: string} - | NRecordBody of {seenFields: string list} - | NVariantPayload of {constructorName: string; itemNum: int} - | NPolyvariantPayload of {constructorName: string; itemNum: int} - | NArray - - let nestedPathToString p = - match p with - | NTupleItem {itemNum} -> "tuple($" ^ string_of_int itemNum ^ ")" - | NFollowRecordField {fieldName} -> "recordField(" ^ fieldName ^ ")" - | NRecordBody _ -> "recordBody" - | NVariantPayload {constructorName; itemNum} -> - "variantPayload::" ^ constructorName ^ "($" ^ string_of_int itemNum ^ ")" - | NPolyvariantPayload {constructorName; itemNum} -> - "polyvariantPayload::" ^ constructorName ^ "($" ^ string_of_int itemNum - ^ ")" - | NArray -> "array" - - type contextPath = - | CPString - | CPArray of contextPath option - | CPInt - | CPFloat - | CPBool - | CPOption of contextPath - | CPApply of contextPath * Asttypes.arg_label list - | CPId of { - path: string list; - completionContext: completionContext; - loc: Location.t; - } - | CPField of { - contextPath: contextPath; - fieldName: string; - posOfDot: (int * int) option; - exprLoc: Location.t; - inJsx: bool; - (** Whether this field access was found in a JSX context. *) - } - | CPObj of contextPath * string - | CPAwait of contextPath - | CPPipe of { - synthetic: bool; (** Whether this pipe completion is synthetic. *) - contextPath: contextPath; - id: string; - inJsx: bool; (** Whether this pipe was found in a JSX context. *) - lhsLoc: Location.t; - (** The loc item for the left hand side of the pipe. *) - } - | CTuple of contextPath list - | CArgument of { - functionContextPath: contextPath; - argumentLabel: argumentLabel; - } - | CJsxPropValue of { - pathToComponent: string list; - propName: string; - emptyJsxPropNameHint: string option; - (* This helps handle a special case in JSX prop completion. More info where this is used. *) - } - | CPatternPath of {rootCtxPath: contextPath; nested: nestedPath list} - | CTypeAtPos of Location.t - (** A position holding something that might have a *compiled* type. *) - - type patternMode = Default | Destructuring - - type decoratorPayload = - | Module of string - | ModuleWithImportAttributes of {nested: nestedPath list; prefix: string} - | JsxConfig of {nested: nestedPath list; prefix: string} - - type t = - | Cdecorator of string (** e.g. @module *) - | CdecoratorPayload of decoratorPayload - | CextensionNode of string (** e.g. %todo *) - | CnamedArg of contextPath * string * string list - (** e.g. (..., "label", ["l1", "l2"]) for ...(...~l1...~l2...~label...) *) - | Cnone (** e.g. don't complete inside strings *) - | Cpath of contextPath - | Cjsx of string list * string * string list - (** E.g. (["M", "Comp"], "id", ["id1", "id2"]) for "Value" - | Type -> "Type" - | Module -> "Module" - | Field -> "Field" - | ValueOrField -> "ValueOrField" - - let rec contextPathToString = function - | CPString -> "string" - | CPInt -> "int" - | CPFloat -> "float" - | CPBool -> "bool" - | CPAwait ctxPath -> "await " ^ contextPathToString ctxPath - | CPOption ctxPath -> "option<" ^ contextPathToString ctxPath ^ ">" - | CPApply (cp, labels) -> - contextPathToString cp ^ "(" - ^ (labels - |> List.map (function - | Asttypes.Nolabel -> "Nolabel" - | Labelled {txt} -> "~" ^ txt - | Optional {txt} -> "?" ^ txt) - |> String.concat ", ") - ^ ")" - | CPArray (Some ctxPath) -> "array<" ^ contextPathToString ctxPath ^ ">" - | CPArray None -> "array" - | CPId {path; completionContext} -> - completionContextToString completionContext ^ list path - | CPField {contextPath = cp; fieldName = s} -> - contextPathToString cp ^ "." ^ str s - | CPObj (cp, s) -> contextPathToString cp ^ "[\"" ^ s ^ "\"]" - | CPPipe {contextPath; id; inJsx} -> - contextPathToString contextPath - ^ "->" ^ id - ^ if inJsx then " <>" else "" - | CTuple ctxPaths -> - "CTuple(" - ^ (ctxPaths |> List.map contextPathToString |> String.concat ", ") - ^ ")" - | CArgument {functionContextPath; argumentLabel} -> - "CArgument " - ^ contextPathToString functionContextPath - ^ "(" - ^ (match argumentLabel with - | Unlabelled {argumentPosition} -> "$" ^ string_of_int argumentPosition - | Labelled name -> "~" ^ name - | Optional name -> "~" ^ name ^ "=?") - ^ ")" - | CJsxPropValue {pathToComponent; propName} -> - "CJsxPropValue " ^ (pathToComponent |> list) ^ " " ^ propName - | CPatternPath {rootCtxPath; nested} -> - "CPatternPath(" - ^ contextPathToString rootCtxPath - ^ ")" ^ "->" - ^ (nested - |> List.map (fun nestedPath -> nestedPathToString nestedPath) - |> String.concat "->") - | CTypeAtPos _loc -> "CTypeAtPos()" - - let toString = function - | Cpath cp -> "Cpath " ^ contextPathToString cp - | Cdecorator s -> "Cdecorator(" ^ str s ^ ")" - | CextensionNode s -> "CextensionNode(" ^ str s ^ ")" - | CdecoratorPayload (Module s) -> "CdecoratorPayload(module=" ^ s ^ ")" - | CdecoratorPayload (ModuleWithImportAttributes _) -> - "CdecoratorPayload(moduleWithImportAttributes)" - | CdecoratorPayload (JsxConfig _) -> "JsxConfig" - | CnamedArg (cp, s, sl2) -> - "CnamedArg(" - ^ (cp |> contextPathToString) - ^ ", " ^ str s ^ ", " ^ (sl2 |> list) ^ ")" - | Cnone -> "Cnone" - | Cjsx (sl1, s, sl2) -> - "Cjsx(" ^ (sl1 |> list) ^ ", " ^ str s ^ ", " ^ (sl2 |> list) ^ ")" - | Cpattern {contextPath; nested; prefix} -> ( - "Cpattern " - ^ contextPathToString contextPath - ^ (if prefix = "" then "" else "=" ^ prefix) - ^ - match nested with - | [] -> "" - | nestedPaths -> - "->" - ^ (nestedPaths - |> List.map (fun nestedPath -> nestedPathToString nestedPath) - |> String.concat ", ")) - | Cexpression {contextPath; nested; prefix} -> ( - "Cexpression " - ^ contextPathToString contextPath - ^ (if prefix = "" then "" else "=" ^ prefix) - ^ - match nested with - | [] -> "" - | nestedPaths -> - "->" - ^ (nestedPaths - |> List.map (fun nestedPath -> nestedPathToString nestedPath) - |> String.concat ", ")) - | CexhaustiveSwitch {contextPath} -> - "CexhaustiveSwitch " ^ contextPathToString contextPath - | ChtmlElement {prefix} -> "ChtmlElement <" ^ prefix -end - -module ScopeTypes = struct - type item = - | Constructor of string * Location.t - | Field of string * Location.t - | Module of string * Location.t - | Open of string list - | Type of string * Location.t - | Value of string * Location.t * Completable.contextPath option * item list - | Include of string * Location.t - - let item_to_string = function - | Constructor (name, loc) -> - "Constructor " ^ name ^ " " ^ Warnings.loc_to_string loc - | Field (name, loc) -> "Field " ^ name ^ " " ^ Warnings.loc_to_string loc - | Module (name, loc) -> "Module " ^ name ^ " " ^ Warnings.loc_to_string loc - | Open path -> "Open " ^ (path |> String.concat ".") - | Type (name, loc) -> "Type " ^ name ^ " " ^ Warnings.loc_to_string loc - | Value (name, loc, _, _) -> - "Value " ^ name ^ " " ^ Warnings.loc_to_string loc - | Include (name, loc) -> - "Include " ^ name ^ " " ^ Warnings.loc_to_string loc -end - -module Completion = struct - type kind = - | Module of {docstring: string list; module_: Module.t} - | Value of Types.type_expr - | ObjLabel of Types.type_expr - | Label of string - | Type of Type.t - | Constructor of Constructor.t * string - | PolyvariantConstructor of polyVariantConstructor * string - | Field of field * string - | FileModule of string - | Snippet of string - | ExtractedType of completionType * [`Value | `Type] - | FollowContextPath of Completable.contextPath * ScopeTypes.item list - - type t = { - name: string; - sortText: string option; - insertText: string option; - filterText: string option; - insertTextFormat: Lsp.Types.InsertTextFormat.t option; - env: QueryEnv.t; - deprecated: string option; - docstring: string list; - kind: kind; - detail: string option; - typeArgContext: typeArgContext option; - data: (string * string) list option; - additionalTextEdits: Lsp.Types.TextEdit.t list option; - synthetic: bool; - (** Whether this item is an made up, synthetic item or not. *) - } - - let create ?(synthetic = false) ?additionalTextEdits ?data ?typeArgContext - ?(includesSnippets = false) ?insertText ~kind ~env ?sortText ?deprecated - ?filterText ?detail ?(docstring = []) name = - { - name; - env; - deprecated; - docstring; - kind; - sortText; - insertText; - insertTextFormat = - (if includesSnippets then Some Lsp.Types.InsertTextFormat.Snippet - else None); - filterText; - detail; - typeArgContext; - data; - additionalTextEdits; - synthetic; - } - - (* https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_completion *) - (* https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#completionItemKind *) - let kindToLspCompletionItem kind = - match kind with - | Module _ -> Lsp.Types.CompletionItemKind.Module - | FileModule _ -> Lsp.Types.CompletionItemKind.Module - | Constructor (_, _) | PolyvariantConstructor (_, _) -> - Lsp.Types.CompletionItemKind.Constructor - | ObjLabel _ -> Lsp.Types.CompletionItemKind.Constructor - | Label _ -> Lsp.Types.CompletionItemKind.Constructor - | Field (_, _) -> Lsp.Types.CompletionItemKind.Field - | Type _ | ExtractedType (_, `Type) -> Lsp.Types.CompletionItemKind.Struct - | Value _ | ExtractedType (_, `Value) -> Lsp.Types.CompletionItemKind.Value - | Snippet _ | FollowContextPath _ -> Lsp.Types.CompletionItemKind.Snippet -end - -let kindFromInnerType (t : innerType) = - match t with - | ExtractedType extractedType -> - Completion.ExtractedType (extractedType, `Value) - | TypeExpr typ -> Value typ - -module CursorPosition = struct - type t = NoCursor | HasCursor | EmptyLoc - - let classifyLoc loc ~pos = - if loc |> Loc.hasPos ~pos then HasCursor - else if loc |> Loc.end_ = (Location.none |> Loc.end_) then EmptyLoc - else NoCursor - - let classifyLocationLoc (loc : 'a Location.loc) ~pos = - if Loc.start loc.Location.loc <= pos && pos <= Loc.end_ loc.loc then - HasCursor - else if loc.loc |> Loc.end_ = (Location.none |> Loc.end_) then EmptyLoc - else NoCursor - - let classifyPositions pos ~posStart ~posEnd = - if posStart <= pos && pos <= posEnd then HasCursor - else if posEnd = (Location.none |> Loc.end_) then EmptyLoc - else NoCursor - - let locHasCursor loc ~pos = loc |> classifyLoc ~pos = HasCursor - - let locIsEmpty loc ~pos = loc |> classifyLoc ~pos = EmptyLoc -end - -type labelled = { - name: string; - opt: bool; - posStart: int * int; - posEnd: int * int; -} - -type label = labelled option -type arg = {label: label; exp: Parsetree.expression} - -let extractExpApplyArgs ~args = - let rec processArgs ~acc args = - match args with - | ( ((Asttypes.Labelled {txt = s; loc} | Optional {txt = s; loc}) as label), - (e : Parsetree.expression) ) - :: rest -> ( - let namedArgLoc = if loc = Location.none then None else Some loc in - match namedArgLoc with - | Some loc -> - let labelled = - { - name = s; - opt = - (match label with - | Optional _ -> true - | _ -> false); - posStart = Loc.start loc; - posEnd = Loc.end_ loc; - } - in - processArgs ~acc:({label = Some labelled; exp = e} :: acc) rest - | None -> processArgs ~acc rest) - | (Nolabel, (e : Parsetree.expression)) :: rest -> - if e.pexp_loc.loc_ghost then processArgs ~acc rest - else processArgs ~acc:({label = None; exp = e} :: acc) rest - | [] -> List.rev acc - in - args |> processArgs ~acc:[] diff --git a/analysis/src/TypeUtils.ml b/analysis/src/TypeUtils.ml deleted file mode 100644 index fa85e92e417..00000000000 --- a/analysis/src/TypeUtils.ml +++ /dev/null @@ -1,1294 +0,0 @@ -open SharedTypes - -let modulePathFromEnv env = - let moduleName = env.QueryEnv.file.moduleName in - let transformedModuleName = - (* Transform namespaced module names from internal format (Context-Kaplay) - to user-facing format (Kaplay.Context) *) - match String.rindex_opt moduleName '-' with - | None -> moduleName - | Some i -> - let namespace = - String.sub moduleName (i + 1) (String.length moduleName - i - 1) - in - let module_ = String.sub moduleName 0 i in - namespace ^ "." ^ module_ - in - transformedModuleName :: List.rev env.pathRev - -let fullTypeIdFromDecl ~env ~name ~modulePath = - env.QueryEnv.file.moduleName :: ModulePath.toPath modulePath name - |> String.concat "." - -let debugLogTypeArgContext {env; typeArgs; typeParams} = - Printf.sprintf "Type arg context. env: %s, typeArgs: %s, typeParams: %s\n" - (Debug.debugPrintEnv env) - (typeArgs |> List.map Shared.typeToString |> String.concat ", ") - (typeParams |> List.map Shared.typeToString |> String.concat ", ") - -(** Checks whether this type has any uninstantiated type parameters. *) -let rec hasTvar (ty : Types.type_expr) : bool = - match ty.desc with - | Tvar _ -> true - | Tarrow (arg, ret, _, _) -> hasTvar arg.typ || hasTvar ret - | Ttuple tyl -> List.exists hasTvar tyl - | Tconstr (_, tyl, _) -> List.exists hasTvar tyl - | Tobject (ty, _) -> hasTvar ty - | Tfield (_, _, ty1, ty2) -> hasTvar ty1 || hasTvar ty2 - | Tnil -> false - | Tlink ty -> hasTvar ty - | Tsubst ty -> hasTvar ty - | Tvariant {row_fields; _} -> - List.exists - (function - | _, Types.Rpresent (Some ty) -> hasTvar ty - | _, Reither (_, tyl, _, _) -> List.exists hasTvar tyl - | _ -> false) - row_fields - | Tunivar _ -> true - | Tpoly (ty, tyl) -> hasTvar ty || List.exists hasTvar tyl - | Tpackage (_, _, tyl) -> List.exists hasTvar tyl - -let findTypeViaLoc ~full ~debug (loc : Location.t) = - match References.getLocItem ~full ~pos:(Pos.ofLexing loc.loc_end) ~debug with - | Some {locType = Typed (_, typExpr, _)} -> Some typExpr - | _ -> None - -let pathFromTypeExpr (t : Types.type_expr) = - match t.desc with - | Tconstr (path, _typeArgs, _) - | Tlink {desc = Tconstr (path, _typeArgs, _)} - | Tsubst {desc = Tconstr (path, _typeArgs, _)} - | Tpoly ({desc = Tconstr (path, _typeArgs, _)}, []) -> - Some path - | _ -> None - -let printRecordFromFields ?name (fields : field list) = - (match name with - | None -> "" - | Some name -> "type " ^ name ^ " = ") - ^ "{" - ^ (fields - |> List.map (fun f -> f.fname.txt ^ ": " ^ Shared.typeToString f.typ) - |> String.concat ", ") - ^ "}" - -let rec extractedTypeToString ?(nameOnly = false) ?(inner = false) = function - | Tuple (_, _, typ) | Tpolyvariant {typeExpr = typ} | Tfunction {typ} -> - if inner then - try typ |> pathFromTypeExpr |> Option.get |> SharedTypes.pathIdentToString - with _ -> "" - else Shared.typeToString typ - | Trecord {definition; fields} -> - let name = - match definition with - | `TypeExpr typ -> ( - try - typ |> pathFromTypeExpr |> Option.get |> SharedTypes.pathIdentToString - with _ -> "") - | `NameOnly name -> name - in - if inner || nameOnly then name else printRecordFromFields ~name fields - | Tbool _ -> "bool" - | Tstring _ -> "string" - | TtypeT _ -> "type t" - | Tarray (_, TypeExpr innerTyp) -> - "array<" ^ Shared.typeToString innerTyp ^ ">" - | Tarray (_, ExtractedType innerTyp) -> - "array<" ^ extractedTypeToString ~inner:true innerTyp ^ ">" - | Toption (_, TypeExpr innerTyp) -> - "option<" ^ Shared.typeToString innerTyp ^ ">" - | Tresult {okType; errorType} -> - "result<" ^ Shared.typeToString okType ^ ", " - ^ Shared.typeToString errorType - ^ ">" - | Toption (_, ExtractedType innerTyp) -> - "option<" ^ extractedTypeToString ~inner:true innerTyp ^ ">" - | Tpromise (_, innerTyp) -> "promise<" ^ Shared.typeToString innerTyp ^ ">" - | Tvariant {variantDecl; variantName} -> - if inner || nameOnly then variantName - else Shared.declToString variantName variantDecl - | TinlineRecord {fields} -> printRecordFromFields fields - | Texn _ -> "exn" - -let getExtractedType maybeRes = - match maybeRes with - | None -> None - | Some (extractedType, _) -> Some extractedType - -let instantiateType ~typeParams ~typeArgs (t : Types.type_expr) = - if typeParams = [] || typeArgs = [] then t - else - let rec applySub tp ta t = - match (tp, ta) with - | t1 :: tRest1, t2 :: tRest2 -> - if t1 = t then t2 else applySub tRest1 tRest2 t - | [], _ | _, [] -> t - in - let rec loop (t : Types.type_expr) = - match t.desc with - | Tlink t -> loop t - | Tvar _ -> applySub typeParams typeArgs t - | Tunivar _ -> t - | Tconstr (path, args, memo) -> - {t with desc = Tconstr (path, args |> List.map loop, memo)} - | Tsubst t -> loop t - | Tvariant rd -> {t with desc = Tvariant (rowDesc rd)} - | Tnil -> t - | Tarrow (arg, ret, c, arity) -> - { - t with - desc = Tarrow ({arg with typ = loop arg.typ}, loop ret, c, arity); - } - | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} - | Tobject (t, r) -> {t with desc = Tobject (loop t, r)} - | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} - | Tpoly (t, []) -> loop t - | Tpoly (t, tl) -> {t with desc = Tpoly (loop t, tl |> List.map loop)} - | Tpackage (p, l, tl) -> - {t with desc = Tpackage (p, l, tl |> List.map loop)} - and rowDesc (rd : Types.row_desc) = - let row_fields = - rd.row_fields |> List.map (fun (l, rf) -> (l, rowField rf)) - in - let row_more = loop rd.row_more in - let row_name = - match rd.row_name with - | None -> None - | Some (p, tl) -> Some (p, tl |> List.map loop) - in - {rd with row_fields; row_more; row_name} - and rowField (rf : Types.row_field) = - match rf with - | Rpresent None -> rf - | Rpresent (Some t) -> Rpresent (Some (loop t)) - | Reither (b1, tl, b2, r) -> Reither (b1, tl |> List.map loop, b2, r) - | Rabsent -> Rabsent - in - loop t - -let instantiateType2 ?(typeArgContext : typeArgContext option) - (t : Types.type_expr) = - match typeArgContext with - | None | Some {typeArgs = []} | Some {typeParams = []} -> t - | Some {typeArgs; typeParams} -> - let rec applySub tp ta name = - match (tp, ta) with - | {Types.desc = Tvar (Some varName)} :: tRest1, t2 :: tRest2 -> - if varName = name then t2 else applySub tRest1 tRest2 name - | _ :: tRest1, _ :: tRest2 -> applySub tRest1 tRest2 name - | [], _ | _, [] -> t - in - - let rec loop (t : Types.type_expr) = - match t.desc with - | Tlink t -> loop t - | Tvar (Some name) -> applySub typeParams typeArgs name - | Tvar _ -> t - | Tunivar _ -> t - | Tconstr (path, args, memo) -> - {t with desc = Tconstr (path, args |> List.map loop, memo)} - | Tsubst t -> loop t - | Tvariant rd -> {t with desc = Tvariant (rowDesc rd)} - | Tnil -> t - | Tarrow (arg, ret, c, arity) -> - { - t with - desc = Tarrow ({arg with typ = loop arg.typ}, loop ret, c, arity); - } - | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} - | Tobject (t, r) -> {t with desc = Tobject (loop t, r)} - | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} - | Tpoly (t, []) -> loop t - | Tpoly (t, tl) -> {t with desc = Tpoly (loop t, tl |> List.map loop)} - | Tpackage (p, l, tl) -> - {t with desc = Tpackage (p, l, tl |> List.map loop)} - and rowDesc (rd : Types.row_desc) = - let row_fields = - rd.row_fields |> List.map (fun (l, rf) -> (l, rowField rf)) - in - let row_more = loop rd.row_more in - let row_name = - match rd.row_name with - | None -> None - | Some (p, tl) -> Some (p, tl |> List.map loop) - in - {rd with row_fields; row_more; row_name} - and rowField (rf : Types.row_field) = - match rf with - | Rpresent None -> rf - | Rpresent (Some t) -> Rpresent (Some (loop t)) - | Reither (b1, tl, b2, r) -> Reither (b1, tl |> List.map loop, b2, r) - | Rabsent -> Rabsent - in - loop t - -let rec extractRecordType ~env ~package (t : Types.type_expr) = - match t.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> extractRecordType ~env ~package t1 - | Tconstr (path, typeArgs, _) -> ( - match References.digConstructor ~env ~package path with - | Some (env, ({item = {kind = Record fields}} as typ)) -> - let typeParams = typ.item.decl.type_params in - let fields = - fields - |> List.map (fun field -> - let fieldTyp = - field.typ |> instantiateType ~typeParams ~typeArgs - in - {field with typ = fieldTyp}) - in - Some (env, fields, typ) - | Some - ( env, - {item = {decl = {type_manifest = Some t1; type_params = typeParams}}} - ) -> - let t1 = t1 |> instantiateType ~typeParams ~typeArgs in - extractRecordType ~env ~package t1 - | _ -> None) - | _ -> None - -let rec extractObjectType ~env ~package (t : Types.type_expr) = - match t.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> extractObjectType ~env ~package t1 - | Tobject (tObj, _) -> Some (env, tObj) - | Tconstr (path, typeArgs, _) -> ( - match References.digConstructor ~env ~package path with - | Some - ( env, - {item = {decl = {type_manifest = Some t1; type_params = typeParams}}} - ) -> - let t1 = t1 |> instantiateType ~typeParams ~typeArgs in - extractObjectType ~env ~package t1 - | _ -> None) - | _ -> None - -let extractFunctionType ~env ~package ?(digInto = true) typ = - let rec loop ~env acc (t : Types.type_expr) = - match t.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ~env acc t1 - | Tarrow (arg, tRet, _, _) -> loop ~env ((arg.lbl, arg.typ) :: acc) tRet - | Tconstr (path, typeArgs, _) when digInto -> ( - match References.digConstructor ~env ~package path with - | Some - ( env, - { - item = {decl = {type_manifest = Some t1; type_params = typeParams}}; - } ) -> - let t1 = t1 |> instantiateType ~typeParams ~typeArgs in - loop ~env acc t1 - | _ -> (List.rev acc, t)) - | _ -> (List.rev acc, t) - in - loop ~env [] typ - -let extractFunctionTypeWithEnv ~env ~package typ = - let rec loop ~env acc (t : Types.type_expr) = - match t.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ~env acc t1 - | Tarrow (arg, tRet, _, _) -> loop ~env ((arg.lbl, arg.typ) :: acc) tRet - | Tconstr (path, typeArgs, _) -> ( - match References.digConstructor ~env ~package path with - | Some - ( _env, - { - item = {decl = {type_manifest = Some t1; type_params = typeParams}}; - } ) -> - let t1 = t1 |> instantiateType ~typeParams ~typeArgs in - loop ~env acc t1 - | Some _ -> (List.rev acc, t, env) - | _ -> (List.rev acc, t, env)) - | _ -> (List.rev acc, t, env) - in - loop ~env [] typ - -let maybeSetTypeArgCtx ?typeArgContextFromTypeManifest ~typeParams ~typeArgs env - = - match typeArgContextFromTypeManifest with - | Some typeArgContextFromTypeManifest -> Some typeArgContextFromTypeManifest - | None -> - let typeArgContext = - if List.length typeParams > 0 then Some {env; typeParams; typeArgs} - else None - in - (match typeArgContext with - | None -> () - | Some typeArgContext -> - if Debug.verbose () then - Printf.printf "[#type_arg_ctx]--> setting new type arg ctx: %s" - (debugLogTypeArgContext typeArgContext)); - typeArgContext - -(* TODO(env-stuff) Maybe this could be removed entirely if we can guarantee that we don't have to look up functions from in here. *) -let extractFunctionType2 ?typeArgContext ~env ~package typ = - let rec loop ?typeArgContext ~env acc (t : Types.type_expr) = - match t.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ?typeArgContext ~env acc t1 - | Tarrow (arg, tRet, _, _) -> - loop ?typeArgContext ~env ((arg.lbl, arg.typ) :: acc) tRet - | Tconstr (path, typeArgs, _) -> ( - match References.digConstructor ~env ~package path with - | Some - ( env, - { - item = {decl = {type_manifest = Some t1; type_params = typeParams}}; - } ) -> - let typeArgContext = maybeSetTypeArgCtx ~typeParams ~typeArgs env in - loop ?typeArgContext ~env acc t1 - | _ -> (List.rev acc, t, typeArgContext)) - | _ -> (List.rev acc, t, typeArgContext) - in - loop ?typeArgContext ~env [] typ - -let rec extractType ?(printOpeningDebug = true) - ?(typeArgContext : typeArgContext option) - ?(typeArgContextFromTypeManifest : typeArgContext option) ~env ~package - (t : Types.type_expr) = - let maybeSetTypeArgCtx = maybeSetTypeArgCtx ?typeArgContextFromTypeManifest in - if Debug.verbose () && printOpeningDebug then - Printf.printf - "[extract_type]--> starting extraction of type: %s, in env: %s. Has type \ - arg ctx: %b\n" - (Shared.typeToString t) (Debug.debugPrintEnv env) - (Option.is_some typeArgContext); - (match typeArgContext with - | None -> () - | Some typeArgContext -> - if Debug.verbose () && printOpeningDebug then - Printf.printf "[extract_type]--> %s" - (debugLogTypeArgContext typeArgContext)); - let instantiateType = instantiateType2 in - match t.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> - extractType ?typeArgContext ~printOpeningDebug:false ~env ~package t1 - | Tconstr (Path.Pident {name = "option"}, [payloadTypeExpr], _) -> - Some (Toption (env, TypeExpr payloadTypeExpr), typeArgContext) - | Tconstr (Path.Pident {name = "promise"}, [payloadTypeExpr], _) -> - Some (Tpromise (env, payloadTypeExpr), typeArgContext) - | Tconstr (Path.Pident {name = "array"}, [payloadTypeExpr], _) -> - Some (Tarray (env, TypeExpr payloadTypeExpr), typeArgContext) - | Tconstr (Path.Pident {name = "result"}, [okType; errorType], _) -> - Some (Tresult {env; okType; errorType}, typeArgContext) - | Tconstr (Path.Pident {name = "bool"}, [], _) -> - Some (Tbool env, typeArgContext) - | Tconstr (Path.Pident {name = "string"}, [], _) -> - Some (Tstring env, typeArgContext) - | Tconstr (Path.Pident {name = "exn"}, [], _) -> - Some (Texn env, typeArgContext) - | Tarrow _ -> ( - match extractFunctionType2 ?typeArgContext t ~env ~package with - | args, tRet, typeArgContext when args <> [] -> - Some (Tfunction {env; args; typ = t; returnType = tRet}, typeArgContext) - | _args, _tRet, _typeArgContext -> None) - | Tconstr (path, typeArgs, _) -> ( - if Debug.verbose () then - Printf.printf "[extract_type]--> digging for type %s in %s\n" - (Path.name path) (Debug.debugPrintEnv env); - match References.digConstructor ~env ~package path with - | Some - ( envFromDeclaration, - {item = {decl = {type_manifest = Some t1; type_params}}} ) -> - if Debug.verbose () then - print_endline "[extract_type]--> found type manifest"; - - (* Type manifests inherit the last type args ctx that wasn't for a type manifest. - This is because the manifest itself doesn't have type args and an env that can - be used to instantiate. *) - let typeArgContext = - maybeSetTypeArgCtx ~typeParams:type_params ~typeArgs env - in - t1 - |> extractType ?typeArgContextFromTypeManifest:typeArgContext - ~env:envFromDeclaration ~package - | Some (envFromItem, {name; item = {decl; kind = Type.Variant constructors}}) - -> - if Debug.verbose () then print_endline "[extract_type]--> found variant"; - let typeArgContext = - maybeSetTypeArgCtx ~typeParams:decl.type_params ~typeArgs env - in - Some - ( Tvariant - { - env = envFromItem; - constructors; - variantName = name.txt; - variantDecl = decl; - }, - typeArgContext ) - | Some (envFromDeclaration, {item = {kind = Record fields; decl}}) -> - if Debug.verbose () then print_endline "[extract_type]--> found record"; - (* Need to create a new type arg context here because we're sending along a type expr that might have type vars. *) - let typeArgContext = - maybeSetTypeArgCtx ~typeParams:decl.type_params ~typeArgs env - in - Some - ( Trecord {env = envFromDeclaration; fields; definition = `TypeExpr t}, - typeArgContext ) - | Some (envFromDeclaration, {item = {name = "t"; decl = {type_params}}}) -> - let typeArgContext = - maybeSetTypeArgCtx ~typeParams:type_params ~typeArgs env - in - Some (TtypeT {env = envFromDeclaration; path}, typeArgContext) - | None -> - if Debug.verbose () then - print_endline "[extract_type]--> found nothing when digging"; - None - | _ -> - if Debug.verbose () then - print_endline "[extract_type]--> found something else when digging"; - None) - | Ttuple expressions -> Some (Tuple (env, expressions, t), typeArgContext) - | Tvariant {row_fields} -> - let constructors = - row_fields - |> List.map (fun (label, field) -> - { - name = label; - displayName = Utils.printMaybeExoticIdent ~allowUident:true label; - args = - (* Multiple arguments are represented as a Ttuple, while a single argument is just the type expression itself. *) - (match field with - | Types.Rpresent (Some typeExpr) -> ( - match typeExpr.desc with - | Ttuple args -> args - | _ -> [typeExpr]) - | _ -> []); - }) - in - Some (Tpolyvariant {env; constructors; typeExpr = t}, typeArgContext) - | Tvar (Some varName) -> ( - if Debug.verbose () then - Printf.printf - "[extract_type]--> found type variable: '%s. Trying to instantiate %s" - varName - (match typeArgContext with - | None -> "with no type args ctx\n" - | Some typeArgContext -> - Printf.sprintf "with %s" (debugLogTypeArgContext typeArgContext)); - - let instantiated = t |> instantiateType ?typeArgContext in - let rec extractInstantiated t = - match t.Types.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> extractInstantiated t1 - | _ -> t - in - match extractInstantiated instantiated with - | {desc = Tvar _} -> - if Debug.verbose () then - Printf.printf "[extract_type]--> could not instantiate '%s. Skipping.\n" - varName; - None - | _ -> - if Debug.verbose () then - Printf.printf - "[extract_type]--> SUCCEEDED instantiation, new type is: %s\n" - (Shared.typeToString instantiated); - - (* Use the env from instantiation if we managed to instantiate the type param *) - let nextEnv = - match typeArgContext with - | Some {env} -> env - | None -> env - in - instantiated |> extractType ?typeArgContext ~env:nextEnv ~package) - | _ -> - if Debug.verbose () then print_endline "[extract_type]--> miss"; - None - -let isFunctionType ~env ~package t = - match extractType ~env ~package t with - | Some (Tfunction _, _) -> true - | _ -> false - -let findReturnTypeOfFunctionAtLoc loc ~(env : QueryEnv.t) ~full ~debug = - match References.getLocItem ~full ~pos:(loc |> Loc.end_) ~debug with - | Some {locType = Typed (_, typExpr, _)} -> ( - match extractFunctionType ~env ~package:full.package typExpr with - | args, tRet when args <> [] -> Some tRet - | _ -> None) - | _ -> None - -let rec digToRelevantTemplateNameType ~env ~package ?(suffix = "") - (t : Types.type_expr) = - match t.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> - digToRelevantTemplateNameType ~suffix ~env ~package t1 - | Tconstr (Path.Pident {name = "option"}, [t1], _) -> - digToRelevantTemplateNameType ~suffix ~env ~package t1 - | Tconstr (Path.Pident {name = "array"}, [t1], _) -> - digToRelevantTemplateNameType ~suffix:"s" ~env ~package t1 - | Tconstr (path, _, _) -> ( - match References.digConstructor ~env ~package path with - | Some (env, {item = {decl = {type_manifest = Some typ}}}) -> - digToRelevantTemplateNameType ~suffix ~env ~package typ - | _ -> (t, suffix, env)) - | _ -> (t, suffix, env) - -let rec resolveTypeForPipeCompletion ~env ~package ~lhsLoc ~full - (t : Types.type_expr) = - (* If the type we're completing on is a type parameter, we won't be able to - do completion unless we know what that type parameter is compiled as. - This attempts to look up the compiled type for that type parameter by - looking for compiled information at the loc of that expression. *) - let typFromLoc = - match t with - | {Types.desc = Tvar _} -> - findReturnTypeOfFunctionAtLoc lhsLoc ~env ~full ~debug:false - | _ -> None - in - match typFromLoc with - | Some ({desc = Tvar _} as t) -> (env, t) - | Some typFromLoc -> - typFromLoc |> resolveTypeForPipeCompletion ~lhsLoc ~env ~package ~full - | None -> - let rec digToRelevantType ~env ~package (t : Types.type_expr) = - match t.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> - digToRelevantType ~env ~package t1 - (* Don't descend into types named "t". Type t is a convention in the ReScript ecosystem. *) - | Tconstr (path, _, _) when path |> Path.last = "t" -> (env, t) - | Tconstr (path, _, _) -> ( - match References.digConstructor ~env ~package path with - | Some (env, {item = {decl = {type_manifest = Some typ}}}) -> - digToRelevantType ~env ~package typ - | _ -> (env, t)) - | _ -> (env, t) - in - digToRelevantType ~env ~package t - -let extractTypeFromResolvedType (typ : Type.t) ~env ~full = - match typ.kind with - | Tuple items -> Some (Tuple (env, items, Ctype.newty (Ttuple items))) - | Record fields -> - Some (Trecord {env; fields; definition = `NameOnly typ.name}) - | Variant constructors -> - Some - (Tvariant - {env; constructors; variantName = typ.name; variantDecl = typ.decl}) - | Abstract _ | Open -> ( - match typ.decl.type_manifest with - | None -> None - | Some t -> t |> extractType ~env ~package:full.package |> getExtractedType) - -(** The context we just came from as we resolve the nested structure. *) -type ctx = Rfield of string (** A record field of name *) - -let rec resolveNested ?typeArgContext ~env ~full ~nested ?ctx - (typ : completionType) = - let extractType = extractType ?typeArgContext in - if Debug.verbose () then - Printf.printf - "[nested]--> running nested in env: %s. Has type arg ctx: %b\n" - (Debug.debugPrintEnv env) - (Option.is_some typeArgContext); - (match typeArgContext with - | None -> () - | Some typeArgContext -> - if Debug.verbose () then - Printf.printf "[nested]--> %s" (debugLogTypeArgContext typeArgContext)); - match nested with - | [] -> - if Debug.verbose () then - print_endline "[nested]--> reached end of pattern, returning type"; - Some - ( typ, - env, - (match ctx with - | None -> None - | Some (Rfield fieldName) -> - Some (Completable.CameFromRecordField fieldName)), - typeArgContext ) - | patternPath :: nested -> ( - match (patternPath, typ) with - | Completable.NTupleItem {itemNum}, Tuple (env, tupleItems, _) -> ( - if Debug.verbose () then - print_endline "[nested]--> trying to move into tuple"; - match List.nth_opt tupleItems itemNum with - | None -> - if Debug.verbose () then - print_endline "[nested]--> tuple element not found"; - None - | Some typ -> - typ - |> extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (typ, typeArgContext) -> - typ |> resolveNested ?typeArgContext ~env ~full ~nested)) - | ( NFollowRecordField {fieldName}, - (TinlineRecord {env; fields} | Trecord {env; fields}) ) -> ( - if Debug.verbose () then - print_endline "[nested]--> trying to move into record field"; - match - fields - |> List.find_opt (fun (field : field) -> field.fname.txt = fieldName) - with - | None -> - if Debug.verbose () then - print_endline "[nested]--> did not find record field"; - None - | Some {typ; optional} -> - if Debug.verbose () then - print_endline "[nested]--> found record field type"; - let typ = if optional then Utils.unwrapIfOption typ else typ in - - if Debug.verbose () then - Printf.printf "[nested]--> extracting from type %s in env %s\n" - (Shared.typeToString typ) (Debug.debugPrintEnv env); - typ - |> extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (typ, typeArgContext) -> - typ - |> resolveNested ?typeArgContext ~ctx:(Rfield fieldName) ~env - ~full ~nested)) - | NRecordBody {seenFields}, Trecord {env; definition = `TypeExpr typeExpr} - -> - typeExpr - |> extractType ~env ~package:full.package - |> Option.map (fun (typ, typeArgContext) -> - ( typ, - env, - Some (Completable.RecordField {seenFields}), - typeArgContext )) - | ( NRecordBody {seenFields}, - (Trecord {env; definition = `NameOnly _} as extractedType) ) -> - Some - ( extractedType, - env, - Some (Completable.RecordField {seenFields}), - typeArgContext ) - | NRecordBody {seenFields}, TinlineRecord {env; fields} -> - Some - ( TinlineRecord {fields; env}, - env, - Some (Completable.RecordField {seenFields}), - typeArgContext ) - | ( NVariantPayload {constructorName = "Some"; itemNum = 0}, - Toption (env, ExtractedType typ) ) -> - if Debug.verbose () then - print_endline "[nested]--> moving into option Some"; - typ |> resolveNested ?typeArgContext ~env ~full ~nested - | ( NVariantPayload {constructorName = "Some"; itemNum = 0}, - Toption (env, TypeExpr typ) ) -> - if Debug.verbose () then - print_endline "[nested]--> moving into option Some"; - typ - |> extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (t, typeArgContext) -> - t |> resolveNested ?typeArgContext ~env ~full ~nested) - | NVariantPayload {constructorName = "Ok"; itemNum = 0}, Tresult {okType} -> - if Debug.verbose () then print_endline "[nested]--> moving into result Ok"; - okType - |> extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (t, typeArgContext) -> - t |> resolveNested ?typeArgContext ~env ~full ~nested) - | ( NVariantPayload {constructorName = "Error"; itemNum = 0}, - Tresult {errorType} ) -> - if Debug.verbose () then - print_endline "[nested]--> moving into result Error"; - errorType - |> extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (t, typeArgContext) -> - t |> resolveNested ?typeArgContext ~env ~full ~nested) - | NVariantPayload {constructorName; itemNum}, Tvariant {env; constructors} - -> ( - if Debug.verbose () then - Printf.printf - "[nested]--> trying to move into variant payload $%i of constructor \ - '%s'\n" - itemNum constructorName; - match - constructors - |> List.find_opt (fun (c : Constructor.t) -> - c.cname.txt = constructorName) - with - | Some {args = Args args} -> ( - if Debug.verbose () then - print_endline "[nested]--> found constructor (Args type)"; - match List.nth_opt args itemNum with - | None -> - if Debug.verbose () then - print_endline "[nested]--> did not find relevant args num"; - None - | Some (typ, _) -> - if Debug.verbose () then - Printf.printf "[nested]--> found arg of type: %s\n" - (Shared.typeToString typ); - - typ - |> extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (typ, typeArgContext) -> - if Debug.verbose () then - Printf.printf - "[nested]--> extracted %s, continuing descent of %i items\n" - (extractedTypeToString typ) - (List.length nested); - typ |> resolveNested ?typeArgContext ~env ~full ~nested)) - | Some {args = InlineRecord fields} when itemNum = 0 -> - if Debug.verbose () then - print_endline "[nested]--> found constructor (inline record)"; - TinlineRecord {env; fields} - |> resolveNested ?typeArgContext ~env ~full ~nested - | _ -> None) - | ( NPolyvariantPayload {constructorName; itemNum}, - Tpolyvariant {env; constructors} ) -> ( - match - constructors - |> List.find_opt (fun (c : polyVariantConstructor) -> - c.name = constructorName) - with - | None -> None - | Some constructor -> ( - match List.nth_opt constructor.args itemNum with - | None -> None - | Some typ -> - typ - |> extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (typ, typeArgContext) -> - typ |> resolveNested ?typeArgContext ~env ~full ~nested))) - | NArray, Tarray (env, ExtractedType typ) -> - typ |> resolveNested ?typeArgContext ~env ~full ~nested - | NArray, Tarray (env, TypeExpr typ) -> - typ - |> extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (typ, typeArgContext) -> - typ |> resolveNested ?typeArgContext ~env ~full ~nested) - | _ -> None) - -let findTypeOfRecordField fields ~fieldName = - match - fields |> List.find_opt (fun (field : field) -> field.fname.txt = fieldName) - with - | None -> None - | Some {typ; optional} -> - let typ = if optional then Utils.unwrapIfOption typ else typ in - Some typ - -let findTypeOfConstructorArg constructors ~constructorName ~payloadNum ~env = - match - constructors - |> List.find_opt (fun (c : Constructor.t) -> c.cname.txt = constructorName) - with - | Some {args = Args args} -> ( - match List.nth_opt args payloadNum with - | None -> None - | Some (typ, _) -> Some (TypeExpr typ)) - | Some {args = InlineRecord fields} when payloadNum = 0 -> - Some (ExtractedType (TinlineRecord {env; fields})) - | _ -> None - -let findTypeOfPolyvariantArg constructors ~constructorName ~payloadNum = - match - constructors - |> List.find_opt (fun (c : polyVariantConstructor) -> - c.name = constructorName) - with - | Some {args} -> ( - match List.nth_opt args payloadNum with - | None -> None - | Some typ -> Some typ) - | None -> None - -let rec resolveNestedPatternPath (typ : innerType) ~env ~full ~nested = - if Debug.verbose () then print_endline "[nested_pattern_path]"; - let t = - match typ with - | TypeExpr t -> - t |> extractType ~env ~package:full.package |> getExtractedType - | ExtractedType t -> Some t - in - match nested with - | [] -> None - | [finalPatternPath] -> ( - match t with - | None -> None - | Some completionType -> ( - match (finalPatternPath, completionType) with - | ( Completable.NFollowRecordField {fieldName}, - (TinlineRecord {fields} | Trecord {fields}) ) -> ( - match fields |> findTypeOfRecordField ~fieldName with - | None -> None - | Some typ -> Some (TypeExpr typ, env)) - | NTupleItem {itemNum}, Tuple (env, tupleItems, _) -> ( - match List.nth_opt tupleItems itemNum with - | None -> None - | Some typ -> Some (TypeExpr typ, env)) - | NVariantPayload {constructorName; itemNum}, Tvariant {env; constructors} - -> ( - match - constructors - |> findTypeOfConstructorArg ~constructorName ~payloadNum:itemNum ~env - with - | Some typ -> Some (typ, env) - | None -> None) - | ( NPolyvariantPayload {constructorName; itemNum}, - Tpolyvariant {env; constructors} ) -> ( - match - constructors - |> findTypeOfPolyvariantArg ~constructorName ~payloadNum:itemNum - with - | Some typ -> Some (TypeExpr typ, env) - | None -> None) - | ( NVariantPayload {constructorName = "Some"; itemNum = 0}, - Toption (env, typ) ) -> - Some (typ, env) - | ( NVariantPayload {constructorName = "Ok"; itemNum = 0}, - Tresult {env; okType} ) -> - Some (TypeExpr okType, env) - | ( NVariantPayload {constructorName = "Error"; itemNum = 0}, - Tresult {env; errorType} ) -> - Some (TypeExpr errorType, env) - | NArray, Tarray (env, typ) -> Some (typ, env) - | _ -> None)) - | patternPath :: nested -> ( - match t with - | None -> None - | Some completionType -> ( - match (patternPath, completionType) with - | ( Completable.NFollowRecordField {fieldName}, - (TinlineRecord {env; fields} | Trecord {env; fields}) ) -> ( - match fields |> findTypeOfRecordField ~fieldName with - | None -> None - | Some typ -> - typ - |> extractType ~env ~package:full.package - |> getExtractedType - |> Utils.Option.flatMap (fun typ -> - ExtractedType typ - |> resolveNestedPatternPath ~env ~full ~nested)) - | NTupleItem {itemNum}, Tuple (env, tupleItems, _) -> ( - match List.nth_opt tupleItems itemNum with - | None -> None - | Some typ -> - typ - |> extractType ~env ~package:full.package - |> getExtractedType - |> Utils.Option.flatMap (fun typ -> - ExtractedType typ - |> resolveNestedPatternPath ~env ~full ~nested)) - | NVariantPayload {constructorName; itemNum}, Tvariant {env; constructors} - -> ( - match - constructors - |> findTypeOfConstructorArg ~constructorName ~payloadNum:itemNum ~env - with - | Some typ -> typ |> resolveNestedPatternPath ~env ~full ~nested - | None -> None) - | ( NPolyvariantPayload {constructorName; itemNum}, - Tpolyvariant {env; constructors} ) -> ( - match - constructors - |> findTypeOfPolyvariantArg ~constructorName ~payloadNum:itemNum - with - | Some typ -> - TypeExpr typ |> resolveNestedPatternPath ~env ~full ~nested - | None -> None) - | ( NVariantPayload {constructorName = "Some"; itemNum = 0}, - Toption (env, typ) ) -> - typ |> resolveNestedPatternPath ~env ~full ~nested - | ( NVariantPayload {constructorName = "Ok"; itemNum = 0}, - Tresult {env; okType} ) -> - TypeExpr okType |> resolveNestedPatternPath ~env ~full ~nested - | ( NVariantPayload {constructorName = "Error"; itemNum = 0}, - Tresult {env; errorType} ) -> - TypeExpr errorType |> resolveNestedPatternPath ~env ~full ~nested - | NArray, Tarray (env, typ) -> - typ |> resolveNestedPatternPath ~env ~full ~nested - | _ -> None)) - -let getArgs ~env (t : Types.type_expr) ~full = - let rec getArgsLoop ~env (t : Types.type_expr) ~full ~currentArgumentPosition - = - match t.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> - getArgsLoop ~full ~env ~currentArgumentPosition t1 - | Tarrow ({lbl = Labelled {txt = l}; typ = tArg}, tRet, _, _) -> - (SharedTypes.Completable.Labelled l, tArg) - :: getArgsLoop ~full ~env ~currentArgumentPosition tRet - | Tarrow ({lbl = Optional {txt = l}; typ = tArg}, tRet, _, _) -> - (Optional l, tArg) :: getArgsLoop ~full ~env ~currentArgumentPosition tRet - | Tarrow ({lbl = Nolabel; typ = tArg}, tRet, _, _) -> - (Unlabelled {argumentPosition = currentArgumentPosition}, tArg) - :: getArgsLoop ~full ~env - ~currentArgumentPosition:(currentArgumentPosition + 1) - tRet - | Tconstr (path, typeArgs, _) -> ( - match References.digConstructor ~env ~package:full.package path with - | Some - ( env, - { - item = {decl = {type_manifest = Some t1; type_params = typeParams}}; - } ) -> - let t1 = t1 |> instantiateType ~typeParams ~typeArgs in - getArgsLoop ~full ~env ~currentArgumentPosition t1 - | _ -> []) - | _ -> [] - in - t |> getArgsLoop ~env ~full ~currentArgumentPosition:0 - -let typeIsUnit (typ : Types.type_expr) = - match typ.desc with - | Tconstr (Pident id, _typeArgs, _) - | Tlink {desc = Tconstr (Pident id, _typeArgs, _)} - | Tsubst {desc = Tconstr (Pident id, _typeArgs, _)} - | Tpoly ({desc = Tconstr (Pident id, _typeArgs, _)}, []) - when Ident.name id = "unit" -> - true - | _ -> false - -let rec contextPathFromCoreType (coreType : Parsetree.core_type) = - match coreType.ptyp_desc with - | Ptyp_constr ({txt = Lident "option"}, [innerTyp]) -> - innerTyp |> contextPathFromCoreType - |> Option.map (fun innerTyp -> Completable.CPOption innerTyp) - | Ptyp_constr ({txt = Lident "array"}, [innerTyp]) -> - Some (Completable.CPArray (innerTyp |> contextPathFromCoreType)) - | Ptyp_constr (lid, _) -> - Some - (CPId - { - path = lid.txt |> Utils.flattenLongIdent; - completionContext = Type; - loc = lid.loc; - }) - | _ -> None - -let unwrapCompletionTypeIfOption (t : SharedTypes.completionType) = - match t with - | Toption (_, ExtractedType unwrapped) -> unwrapped - | _ -> t - -module Codegen = struct - let mkFailWithExp () = - Ast_helper.Exp.apply - (Ast_helper.Exp.ident {txt = Lident "failwith"; loc = Location.none}) - [(Nolabel, Ast_helper.Exp.constant (Pconst_string ("TODO", None)))] - - let mkConstructPat ?payload name = - Ast_helper.Pat.construct - {Asttypes.txt = Longident.Lident name; loc = Location.none} - payload - - let mkTagPat ?payload name = Ast_helper.Pat.variant name payload - - let any () = Ast_helper.Pat.any () - - let rec extractedTypeToExhaustivePatterns ~env ~full extractedType = - match extractedType with - | Tvariant v -> - Some - (v.constructors - |> List.map (fun (c : SharedTypes.Constructor.t) -> - mkConstructPat - ?payload: - (match c.args with - | Args [] -> None - | _ -> Some (any ())) - c.cname.txt)) - | Tpolyvariant v -> - Some - (v.constructors - |> List.map (fun (c : SharedTypes.polyVariantConstructor) -> - mkTagPat - ?payload: - (match c.args with - | [] -> None - | _ -> Some (any ())) - c.displayName)) - | Toption (_, innerType) -> - let extractedType = - match innerType with - | ExtractedType t -> Some t - | TypeExpr t -> - extractType t ~env ~package:full.package |> getExtractedType - in - let expandedBranches = - match extractedType with - | None -> [] - | Some extractedType -> ( - match extractedTypeToExhaustivePatterns ~env ~full extractedType with - | None -> [] - | Some patterns -> patterns) - in - Some - ([ - mkConstructPat "None"; - mkConstructPat ~payload:(Ast_helper.Pat.any ()) "Some"; - ] - @ (expandedBranches - |> List.map (fun (pat : Parsetree.pattern) -> - mkConstructPat ~payload:pat "Some"))) - | Tresult {okType; errorType} -> - let extractedOkType = - okType |> extractType ~env ~package:full.package |> getExtractedType - in - let extractedErrorType = - errorType |> extractType ~env ~package:full.package |> getExtractedType - in - let expandedOkBranches = - match extractedOkType with - | None -> [] - | Some extractedType -> ( - match extractedTypeToExhaustivePatterns ~env ~full extractedType with - | None -> [] - | Some patterns -> patterns) - in - let expandedErrorBranches = - match extractedErrorType with - | None -> [] - | Some extractedType -> ( - match extractedTypeToExhaustivePatterns ~env ~full extractedType with - | None -> [] - | Some patterns -> patterns) - in - Some - ((expandedOkBranches - |> List.map (fun (pat : Parsetree.pattern) -> - mkConstructPat ~payload:pat "Ok")) - @ (expandedErrorBranches - |> List.map (fun (pat : Parsetree.pattern) -> - mkConstructPat ~payload:pat "Error"))) - | Tbool _ -> Some [mkConstructPat "true"; mkConstructPat "false"] - | _ -> None - - let extractedTypeToExhaustiveCases ~env ~full extractedType = - let patterns = extractedTypeToExhaustivePatterns ~env ~full extractedType in - - match patterns with - | None -> None - | Some patterns -> - Some - (patterns - |> List.map (fun (pat : Parsetree.pattern) -> - Ast_helper.Exp.case pat (mkFailWithExp ()))) -end - -let getModulePathRelativeToEnv ~debug ~(env : QueryEnv.t) ~envFromItem path = - match path with - | _ :: pathRev -> - (* type path is relative to the completion environment - express it from the root of the file *) - let found, pathFromEnv = - QueryEnv.pathFromEnv envFromItem (List.rev pathRev) - in - if debug then - Printf.printf "CPPipe pathFromEnv:%s found:%b\n" - (pathFromEnv |> String.concat ".") - found; - if pathFromEnv = [] then None - else if - env.file.moduleName <> envFromItem.file.moduleName && found - (* If the module names are different, then one needs to qualify the path. - But only if the path belongs to the env from completion *) - then Some (envFromItem.file.moduleName :: pathFromEnv) - else Some pathFromEnv - | _ -> None - -let removeOpensFromCompletionPath ~rawOpens ~package completionPath = - let rec removeRawOpen rawOpen modulePath = - match (rawOpen, modulePath) with - | [_], _ -> Some modulePath - | s :: inner, first :: restPath when s = first -> - removeRawOpen inner restPath - | _ -> None - in - let rec removeRawOpens rawOpens modulePath = - match rawOpens with - | rawOpen :: restOpens -> ( - let newModulePath = removeRawOpens restOpens modulePath in - match removeRawOpen rawOpen newModulePath with - | None -> newModulePath - | Some mp -> mp) - | [] -> modulePath - in - let completionPathMinusOpens = - completionPath |> Utils.flattenAnyNamespaceInPath - |> removeRawOpens package.opens - |> removeRawOpens rawOpens - in - completionPathMinusOpens - -let pathToElementProps package = - match package.genericJsxModule with - | None -> ["ReactDOM"; "domProps"] - | Some g -> (g |> String.split_on_char '.') @ ["Elements"; "props"] - -module StringSet = Set.Make (String) - -let getExtraModulesToCompleteFromForType ~env ~full (t : Types.type_expr) = - let foundModulePaths = ref StringSet.empty in - let addToModulePaths attributes = - ProcessAttributes.findEditorCompleteFromAttribute attributes - |> List.iter (fun e -> - foundModulePaths := - StringSet.add (e |> String.concat ".") !foundModulePaths) - in - let rec inner ~env ~full (t : Types.type_expr) = - match t |> Shared.digConstructor with - | Some path -> ( - match References.digConstructor ~env ~package:full.package path with - | None -> () - | Some (env, {item = {decl = {type_manifest = Some t}; attributes}}) -> - addToModulePaths attributes; - inner ~env ~full t - | Some (_, {item = {attributes}}) -> addToModulePaths attributes) - | None -> () - in - inner ~env ~full t; - !foundModulePaths |> StringSet.elements - |> List.map (fun l -> String.split_on_char '.' l) - -let getFirstFnUnlabelledArgType ~env ~full t = - let labels, _, env = - extractFunctionTypeWithEnv ~env ~package:full.package t - in - let rec findFirstUnlabelledArgType labels = - match labels with - | (Asttypes.Nolabel, t) :: _ -> Some t - | _ :: rest -> findFirstUnlabelledArgType rest - | [] -> None - in - match findFirstUnlabelledArgType labels with - | Some t -> Some (t, env) - | _ -> None - -let makeAdditionalTextEditsForRemovingDot posOfDot = - let start = - Lsp.Types.Position.create ~line:(fst posOfDot) ~character:(snd posOfDot - 1) - in - let end_ = - Lsp.Types.Position.create ~line:(fst posOfDot) ~character:(snd posOfDot) - in - [ - Lsp.Types.TextEdit.create ~newText:"" - ~range:(Lsp.Types.Range.create ~start ~end_); - ] - -(** Turns a completion into a pipe completion. *) -let transformCompletionToPipeCompletion ?(synthetic = false) ~env ?posOfDot - (completion : Completion.t) = - let name = completion.name in - let nameWithPipe = "->" ^ name in - Some - { - completion with - name = nameWithPipe; - sortText = - (match completion.sortText with - | Some _ -> completion.sortText - | None -> Some (name |> String.split_on_char '.' |> List.rev |> List.hd)); - insertText = Some nameWithPipe; - env; - synthetic; - additionalTextEdits = - (match posOfDot with - | None -> None - | Some posOfDot -> Some (makeAdditionalTextEditsForRemovingDot posOfDot)); - } - -(** This takes a type expr and the env that type expr was found in, and produces a globally unique - id for that specific type. The globally unique id is the full path to the type as seen from the root - of the project. Example: type x in module SomeModule in file SomeFile would get the globally - unique id `SomeFile.SomeModule.x`.*) -let rec findRootTypeId ~full ~env (t : Types.type_expr) = - let debug = false in - match t.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> findRootTypeId ~full ~env t1 - | Tconstr (path, _, _) -> ( - (* We have a path. Try to dig to its declaration *) - if debug then - Printf.printf "[findRootTypeId] path %s, dig\n" (Path.name path); - match References.digConstructor ~env ~package:full.package path with - | Some (env, {item = {decl = {type_manifest = Some t1}}}) -> - if debug then - Printf.printf "[findRootTypeId] dug up type alias at module path %s \n" - (modulePathFromEnv env |> String.concat "."); - findRootTypeId ~full ~env t1 - | Some (env, {item = {name}; modulePath}) -> - (* if it's a named type, then we know its name will be its module path from the env + its name.*) - if debug then - Printf.printf - "[findRootTypeId] dug up named type at module path %s, from item: %s \n" - (modulePathFromEnv env |> String.concat ".") - (ModulePath.toPath modulePath name |> String.concat "."); - Some (fullTypeIdFromDecl ~env ~name ~modulePath) - | None -> - (* If we didn't find anything, then it might be a builtin type. Check it.*) - if debug then Printf.printf "[findRootTypeId] dug up non-type alias\n"; - if - Predef.builtin_idents - |> List.find_opt (fun (_, i) -> Ident.same i (Path.head path)) - |> Option.is_some - then - Some - (if debug then Printf.printf "[findRootTypeId] returning builtin\n"; - Path.name path) - else None) - | _ -> None - -(** Filters out completions that are not pipeable from a list of completions. *) -let filterPipeableFunctions ~env ~full ?synthetic ?targetTypeId ?posOfDot - completions = - match targetTypeId with - | None -> completions - | Some targetTypeId -> - completions - |> List.filter_map (fun (completion : Completion.t) -> - let thisCompletionItemTypeId = - match completion.kind with - | Value t -> ( - match - getFirstFnUnlabelledArgType ~full ~env:completion.env t - with - | None -> None - | Some (t, envFromLabelledArg) -> - findRootTypeId ~full ~env:envFromLabelledArg t) - | _ -> None - in - match thisCompletionItemTypeId with - | Some mainTypeId when mainTypeId = targetTypeId -> ( - match posOfDot with - | None -> Some completion - | Some posOfDot -> - transformCompletionToPipeCompletion ?synthetic ~env ~posOfDot - completion) - | _ -> None) - -let removeCurrentModuleIfNeeded ~envCompletionIsMadeFrom completionPath = - if - List.length completionPath > 0 - && List.hd completionPath = envCompletionIsMadeFrom.QueryEnv.file.moduleName - then List.tl completionPath - else completionPath - -let rec getObjFields (texp : Types.type_expr) = - match texp.desc with - | Tfield (name, _, t1, t2) -> - let fields = t2 |> getObjFields in - (name, t1) :: fields - | Tlink te | Tsubst te | Tpoly (te, []) -> te |> getObjFields - | Tvar None -> [] - | _ -> [] - -let pathToBuiltin path = - Predef.builtin_idents - |> List.find_opt (fun (_, i) -> Ident.same i (Path.head path)) - -let completionPathFromMaybeBuiltin path = - match pathToBuiltin path with - | Some ("array", _) -> Some ["Stdlib"; "Array"] - | Some ("option", _) -> Some ["Stdlib"; "Option"] - | Some ("string", _) -> Some ["Stdlib"; "String"] - | Some ("int", _) -> Some ["Stdlib"; "Int"] - | Some ("float", _) -> Some ["Stdlib"; "Float"] - | Some ("promise", _) -> Some ["Stdlib"; "Promise"] - | Some ("list", _) -> Some ["Stdlib"; "List"] - | Some ("result", _) -> Some ["Stdlib"; "Result"] - | Some ("dict", _) -> Some ["Stdlib"; "Dict"] - | Some ("char", _) -> Some ["Stdlib"; "Char"] - | _ -> ( - match path |> Utils.expandPath |> List.rev with - | [mainModule; "t"] when String.starts_with ~prefix:"Stdlib_" mainModule -> - (* Route Stdlib_X to Stdlib.X for proper completions without the Stdlib_ prefix *) - Some (String.split_on_char '_' mainModule) - | ["Primitive_js_extern"; "null"] -> Some ["Stdlib"; "Null"] - | ["Primitive_js_extern"; "nullable"] -> Some ["Stdlib"; "Nullable"] - | _ -> None) diff --git a/analysis/src/Uri.mli b/analysis/src/Uri.mli deleted file mode 100644 index 9079b6323c8..00000000000 --- a/analysis/src/Uri.mli +++ /dev/null @@ -1,10 +0,0 @@ -type t = Lsp.Uri.t - -val fromPath : string -> t -val fromString : string -> t -val isInterface : t -> bool -val stripPath : bool ref -val toPath : t -> string -val toString : t -> string -val toTopLevelLoc : t -> Location.t -val encodeURIComponent : string -> string diff --git a/analysis/src/Xform.ml b/analysis/src/Xform.ml deleted file mode 100644 index a9ca37d8bc4..00000000000 --- a/analysis/src/Xform.ml +++ /dev/null @@ -1,936 +0,0 @@ -(** Code transformations using the parser/printer and ast operations *) - -let isBracedExpr = Res_parsetree_viewer.is_braced_expr - -let extractTypeFromExpr expr ~debug ~source ~kindFile ~full ~pos = - match - expr.Parsetree.pexp_loc - |> CompletionFrontEnd.findTypeOfExpressionAtLoc ~debug ~source ~kindFile - ~posCursor:(Pos.ofLexing expr.Parsetree.pexp_loc.loc_start) - with - | Some (completable, scope) -> ( - let env = SharedTypes.QueryEnv.fromFile full.SharedTypes.file in - let completions = - completable - |> CompletionBackEnd.processCompletable ~debug ~full ~pos ~scope ~env - ~forHover:true - in - let rawOpens = Scope.getRawOpens scope in - match completions with - | {env} :: _ -> ( - let opens = - CompletionBackEnd.getOpens ~debug ~rawOpens ~package:full.package ~env - in - match - CompletionBackEnd.completionsGetCompletionType2 ~debug ~full ~rawOpens - ~opens ~pos completions - with - | Some (typ, _env) -> - let extractedType = - match typ with - | ExtractedType t -> Some t - | TypeExpr t -> - TypeUtils.extractType t ~env ~package:full.package - |> TypeUtils.getExtractedType - in - extractedType - | None -> None) - | _ -> None) - | _ -> None - -module IfThenElse = struct - (* Convert if-then-else to switch *) - - let rec listToPat ~itemToPat = function - | [] -> Some [] - | x :: xList -> ( - match (itemToPat x, listToPat ~itemToPat xList) with - | Some p, Some pList -> Some (p :: pList) - | _ -> None) - - let rec expToPat (exp : Parsetree.expression) = - let mkPat ppat_desc = - Ast_helper.Pat.mk ~loc:exp.pexp_loc ~attrs:exp.pexp_attributes ppat_desc - in - match exp.pexp_desc with - | Pexp_construct (lid, None) -> Some (mkPat (Ppat_construct (lid, None))) - | Pexp_construct (lid, Some e1) -> ( - match expToPat e1 with - | None -> None - | Some p1 -> Some (mkPat (Ppat_construct (lid, Some p1)))) - | Pexp_variant (label, None) -> Some (mkPat (Ppat_variant (label, None))) - | Pexp_variant (label, Some e1) -> ( - match expToPat e1 with - | None -> None - | Some p1 -> Some (mkPat (Ppat_variant (label, Some p1)))) - | Pexp_constant c -> Some (mkPat (Ppat_constant c)) - | Pexp_tuple eList -> ( - match listToPat ~itemToPat:expToPat eList with - | None -> None - | Some patList -> Some (mkPat (Ppat_tuple patList))) - | Pexp_record (items, None) -> ( - let itemToPat {Parsetree.lid; x = e; opt} = - match expToPat e with - | None -> None - | Some p -> Some {Parsetree.lid; x = p; opt} - in - match listToPat ~itemToPat items with - | None -> None - | Some patItems -> Some (mkPat (Ppat_record (patItems, Closed)))) - | Pexp_record (_, Some _) -> None - | _ -> None - - let mkIterator ~pos ~changed = - let expr (iterator : Ast_iterator.iterator) (e : Parsetree.expression) = - let newExp = - match e.pexp_desc with - | Pexp_ifthenelse - ( { - pexp_desc = - Pexp_apply - { - funct = - { - pexp_desc = - Pexp_ident - {txt = Longident.Lident (("==" | "!=") as op)}; - }; - args = [(Nolabel, arg1); (Nolabel, arg2)]; - }; - }, - e1, - Some e2 ) - when Loc.hasPos ~pos e.pexp_loc -> ( - let e1, e2 = if op = "==" then (e1, e2) else (e2, e1) in - let mkMatch ~arg ~pat = - let cases = - [ - Ast_helper.Exp.case pat e1; - Ast_helper.Exp.case (Ast_helper.Pat.any ()) e2; - ] - in - Ast_helper.Exp.match_ ~loc:e.pexp_loc ~attrs:e.pexp_attributes arg - cases - in - - match expToPat arg2 with - | None -> ( - match expToPat arg1 with - | None -> None - | Some pat1 -> - let newExp = mkMatch ~arg:arg2 ~pat:pat1 in - Some newExp) - | Some pat2 -> - let newExp = mkMatch ~arg:arg1 ~pat:pat2 in - Some newExp) - | _ -> None - in - match newExp with - | Some newExp -> changed := Some newExp - | None -> Ast_iterator.default_iterator.expr iterator e - in - - {Ast_iterator.default_iterator with expr} - - let xform ~pos ~codeActions ~printExpr ~path structure = - let changed = ref None in - let iterator = mkIterator ~pos ~changed in - iterator.structure iterator structure; - match !changed with - | None -> () - | Some newExpr -> - let range = Loc.rangeOfLoc newExpr.pexp_loc in - let newText = printExpr ~range newExpr in - let codeAction = - CodeActions.make ~title:"Replace with switch" ~kind:RefactorRewrite - ~uri:path ~newText ~range - in - codeActions := codeAction :: !codeActions -end - -module ModuleToFile = struct - let mkIterator ~pos ~changed ~path ~printStandaloneStructure = - let structure_item (iterator : Ast_iterator.iterator) - (structure_item : Parsetree.structure_item) = - (match structure_item.pstr_desc with - | Pstr_module - {pmb_loc; pmb_name; pmb_expr = {pmod_desc = Pmod_structure structure}} - when structure_item.pstr_loc |> Loc.hasPos ~pos -> - let range = Loc.rangeOfLoc structure_item.pstr_loc in - let newTextInCurrentFile = "" in - let textForExtractedFile = - printStandaloneStructure ~loc:pmb_loc structure - in - let moduleName = pmb_name.txt in - let newFilePath = - Filename.concat (Filename.dirname path) moduleName ^ ".res" - in - let uri = Uri.fromString newFilePath in - let documentChanges = - [ - `CreateFile - (Lsp.Types.CreateFile.create ~uri - ~options: - (Lsp.Types.CreateFileOptions.create ~overwrite:false - ~ignoreIfExists:true ()) - ()); - `TextDocumentEdit - (Lsp.Types.TextDocumentEdit.create - ~edits: - [ - `TextEdit - (Lsp.Types.TextEdit.create ~range - ~newText:textForExtractedFile); - ] - ~textDocument: - (Lsp.Types.OptionalVersionedTextDocumentIdentifier.create - ~uri ())); - `TextDocumentEdit - (Lsp.Types.TextDocumentEdit.create - ~edits: - [ - `TextEdit - (Lsp.Types.TextEdit.create ~range - ~newText:newTextInCurrentFile); - ] - ~textDocument: - (Lsp.Types.OptionalVersionedTextDocumentIdentifier.create - ~uri:(Uri.fromString path) ())); - ] - in - changed := - Some - (CodeActions.makeWithDocumentChanges - ~title: - (Printf.sprintf "Extract local module \"%s\" to file \"%s\"" - moduleName (moduleName ^ ".res")) - ~kind:RefactorRewrite ~documentChanges); - () - | _ -> ()); - Ast_iterator.default_iterator.structure_item iterator structure_item - in - - {Ast_iterator.default_iterator with structure_item} - - let xform ~pos ~codeActions ~path ~printStandaloneStructure structure = - let changed = ref None in - let iterator = mkIterator ~pos ~path ~changed ~printStandaloneStructure in - iterator.structure iterator structure; - match !changed with - | None -> () - | Some codeAction -> codeActions := codeAction :: !codeActions -end - -module AddBracesToFn = struct - (* Add braces to fn without braces *) - - let mkIterator ~pos ~changed = - (* While iterating the AST, keep info on which structure item we are in. - Printing from the structure item, rather than the body of the function, - gives better local pretty printing *) - let currentStructureItem = ref None in - - let structure_item (iterator : Ast_iterator.iterator) - (item : Parsetree.structure_item) = - let saved = !currentStructureItem in - currentStructureItem := Some item; - Ast_iterator.default_iterator.structure_item iterator item; - currentStructureItem := saved - in - let expr (iterator : Ast_iterator.iterator) (e : Parsetree.expression) = - let bracesAttribute = - let loc = - { - Location.none with - loc_start = Lexing.dummy_pos; - loc_end = - { - Lexing.dummy_pos with - pos_lnum = Lexing.dummy_pos.pos_lnum + 1 (* force line break *); - }; - } - in - (Location.mkloc "res.braces" loc, Parsetree.PStr []) - in - let isFunction = function - | {Parsetree.pexp_desc = Pexp_fun _} -> true - | _ -> false - in - (match e.pexp_desc with - | Pexp_fun {rhs = bodyExpr} - when Loc.hasPos ~pos bodyExpr.pexp_loc - && isBracedExpr bodyExpr = false - && isFunction bodyExpr = false -> - bodyExpr.pexp_attributes <- bracesAttribute :: bodyExpr.pexp_attributes; - changed := !currentStructureItem - | _ -> ()); - Ast_iterator.default_iterator.expr iterator e - in - - {Ast_iterator.default_iterator with expr; structure_item} - - let xform ~pos ~codeActions ~path ~printStructureItem structure = - let changed = ref None in - let iterator = mkIterator ~pos ~changed in - iterator.structure iterator structure; - match !changed with - | None -> () - | Some newStructureItem -> - let range = Loc.rangeOfLoc newStructureItem.pstr_loc in - let newText = printStructureItem ~range newStructureItem in - let codeAction = - CodeActions.make ~title:"Add braces to function" ~kind:RefactorRewrite - ~uri:path ~newText ~range - in - codeActions := codeAction :: !codeActions -end - -module AddTypeAnnotation = struct - (* Add type annotation to value declaration *) - - type annotation = Plain | WithParens - - let mkIterator ~pos ~result = - let processPattern ?(isUnlabeledOnlyArg = false) (pat : Parsetree.pattern) = - match pat.ppat_desc with - | Ppat_var {loc} when Loc.hasPos ~pos loc -> - result := Some (if isUnlabeledOnlyArg then WithParens else Plain) - | _ -> () - in - let rec processFunction ~argNum (e : Parsetree.expression) = - match e.pexp_desc with - | Pexp_fun {arg_label; lhs = pat; rhs = e} -> - let isUnlabeledOnlyArg = - argNum = 1 && arg_label = Nolabel - && - match e.pexp_desc with - | Pexp_fun _ -> false - | _ -> true - in - processPattern ~isUnlabeledOnlyArg pat; - processFunction ~argNum:(argNum + 1) e - | _ -> () - in - let structure_item (iterator : Ast_iterator.iterator) - (si : Parsetree.structure_item) = - match si.pstr_desc with - | Pstr_value (_recFlag, bindings) -> - let processBinding (vb : Parsetree.value_binding) = - (* Can't add a type annotation to a jsx component, or the compiler crashes *) - let isJsxComponent = Utils.isJsxComponent vb in - if not isJsxComponent then processPattern vb.pvb_pat; - processFunction vb.pvb_expr - in - bindings |> List.iter (processBinding ~argNum:1); - Ast_iterator.default_iterator.structure_item iterator si - | _ -> Ast_iterator.default_iterator.structure_item iterator si - in - {Ast_iterator.default_iterator with structure_item} - - let xform ~path ~pos ~full ~structure ~codeActions ~debug = - let result = ref None in - let iterator = mkIterator ~pos ~result in - iterator.structure iterator structure; - match !result with - | None -> () - | Some annotation -> ( - match References.getLocItem ~full ~pos ~debug with - | None -> () - | Some locItem -> ( - match locItem.locType with - | Typed (name, typ, _) -> - let range, newText = - match annotation with - | Plain -> - ( Loc.rangeOfLoc {locItem.loc with loc_start = locItem.loc.loc_end}, - ": " ^ (typ |> Shared.typeToString) ) - | WithParens -> - ( Loc.rangeOfLoc locItem.loc, - "(" ^ name ^ ": " ^ (typ |> Shared.typeToString) ^ ")" ) - in - let codeAction = - CodeActions.make ~title:"Add type annotation" ~kind:RefactorRewrite - ~uri:path ~newText ~range - in - codeActions := codeAction :: !codeActions - | _ -> ())) -end - -module ExpandCatchAllForVariants = struct - let mkIterator ~pos ~result = - let expr (iterator : Ast_iterator.iterator) (e : Parsetree.expression) = - (if e.pexp_loc |> Loc.hasPos ~pos then - match e.pexp_desc with - | Pexp_match (switchExpr, cases) -> ( - let catchAllCase = - cases - |> List.find_opt (fun (c : Parsetree.case) -> - match c with - | {pc_lhs = {ppat_desc = Ppat_any}} -> true - | _ -> false) - in - match catchAllCase with - | None -> () - | Some catchAllCase -> - result := Some (switchExpr, catchAllCase, cases)) - | _ -> ()); - Ast_iterator.default_iterator.expr iterator e - in - {Ast_iterator.default_iterator with expr} - - let xform ~source ~kindFile ~path ~pos ~full ~structure ~codeActions ~debug = - let result = ref None in - let iterator = mkIterator ~pos ~result in - iterator.structure iterator structure; - match !result with - | None -> () - | Some (switchExpr, catchAllCase, cases) -> ( - if Debug.verbose () then - print_endline - "[codeAction - ExpandCatchAllForVariants] Found target switch"; - let rec findAllConstructorNames ?(mode : [`option | `default] = `default) - ?(constructorNames = []) (p : Parsetree.pattern) = - match p.ppat_desc with - | Ppat_construct ({txt = Lident "Some"}, Some payload) - when mode = `option -> - findAllConstructorNames ~mode ~constructorNames payload - | Ppat_construct ({txt}, _) -> Longident.last txt :: constructorNames - | Ppat_variant (name, _) -> name :: constructorNames - | Ppat_or (a, b) -> - findAllConstructorNames ~mode ~constructorNames a - @ findAllConstructorNames ~mode ~constructorNames b - @ constructorNames - | _ -> constructorNames - in - let getCurrentConstructorNames ?mode cases = - cases - |> List.map (fun (c : Parsetree.case) -> - if Option.is_some c.pc_guard then [] - else findAllConstructorNames ?mode c.pc_lhs) - |> List.flatten - in - let currentConstructorNames = getCurrentConstructorNames cases in - match - switchExpr - |> extractTypeFromExpr ~debug ~source ~kindFile ~full - ~pos:(Pos.ofLexing switchExpr.pexp_loc.loc_end) - with - | Some (Tvariant {constructors}) -> - let missingConstructors = - constructors - |> List.filter (fun (c : SharedTypes.Constructor.t) -> - currentConstructorNames |> List.mem c.cname.txt = false) - in - if List.length missingConstructors > 0 then - let newText = - missingConstructors - |> List.map (fun (c : SharedTypes.Constructor.t) -> - c.cname.txt - ^ - match c.args with - | Args [] -> "" - | Args _ | InlineRecord _ -> "(_)") - |> String.concat " | " - in - let range = Loc.rangeOfLoc catchAllCase.pc_lhs.ppat_loc in - let codeAction = - CodeActions.make ~title:"Expand catch-all" ~kind:RefactorRewrite - ~uri:path ~newText ~range - in - codeActions := codeAction :: !codeActions - else () - | Some (Tpolyvariant {constructors}) -> - let missingConstructors = - constructors - |> List.filter (fun (c : SharedTypes.polyVariantConstructor) -> - currentConstructorNames |> List.mem c.name = false) - in - if List.length missingConstructors > 0 then - let newText = - missingConstructors - |> List.map (fun (c : SharedTypes.polyVariantConstructor) -> - Res_printer.polyvar_ident_to_string c.name - ^ - match c.args with - | [] -> "" - | _ -> "(_)") - |> String.concat " | " - in - let range = Loc.rangeOfLoc catchAllCase.pc_lhs.ppat_loc in - let codeAction = - CodeActions.make ~title:"Expand catch-all" ~kind:RefactorRewrite - ~uri:path ~newText ~range - in - codeActions := codeAction :: !codeActions - else () - | Some (Toption (env, innerType)) -> ( - if Debug.verbose () then - print_endline - "[codeAction - ExpandCatchAllForVariants] Found option type"; - let innerType = - match innerType with - | ExtractedType t -> Some t - | TypeExpr t -> ( - match TypeUtils.extractType ~env ~package:full.package t with - | None -> None - | Some (t, _) -> Some t) - in - match innerType with - | Some ((Tvariant _ | Tpolyvariant _) as variant) -> - let currentConstructorNames = - getCurrentConstructorNames ~mode:`option cases - in - let hasNoneCase = - cases - |> List.exists (fun (c : Parsetree.case) -> - match c.pc_lhs.ppat_desc with - | Ppat_construct ({txt = Lident "None"}, _) -> true - | _ -> false) - in - let missingConstructors = - match variant with - | Tvariant {constructors} -> - constructors - |> List.filter_map (fun (c : SharedTypes.Constructor.t) -> - if currentConstructorNames |> List.mem c.cname.txt = false - then - Some - ( c.cname.txt, - match c.args with - | Args [] -> false - | _ -> true ) - else None) - | Tpolyvariant {constructors} -> - constructors - |> List.filter_map - (fun (c : SharedTypes.polyVariantConstructor) -> - if currentConstructorNames |> List.mem c.name = false then - Some - ( Res_printer.polyvar_ident_to_string c.name, - match c.args with - | [] -> false - | _ -> true ) - else None) - | _ -> [] - in - if List.length missingConstructors > 0 || not hasNoneCase then - let newText = - "Some(" - ^ (missingConstructors - |> List.map (fun (name, hasArgs) -> - name ^ if hasArgs then "(_)" else "") - |> String.concat " | ") - ^ ")" - in - let newText = - if hasNoneCase then newText else newText ^ " | None" - in - let range = Loc.rangeOfLoc catchAllCase.pc_lhs.ppat_loc in - let codeAction = - CodeActions.make ~title:"Expand catch-all" ~kind:RefactorRewrite - ~uri:path ~newText ~range - in - codeActions := codeAction :: !codeActions - else () - | _ -> ()) - | _ -> ()) -end - -module ExhaustiveSwitch = struct - (* Expand expression to be an exhaustive switch of the underlying value *) - type posType = Single of Pos.t | Range of Pos.t * Pos.t - - type completionType = - | Switch of { - pos: Pos.t; - switchExpr: Parsetree.expression; - completionExpr: Parsetree.expression; - } - | Selection of {expr: Parsetree.expression} - - let mkIteratorSingle ~pos ~result = - let expr (iterator : Ast_iterator.iterator) (exp : Parsetree.expression) = - (match exp.pexp_desc with - | Pexp_ident _ when Loc.hasPosInclusiveEnd ~pos exp.pexp_loc -> - (* Exhaustive switch for having the cursor on an identifier. *) - result := Some (Selection {expr = exp}) - | Pexp_match (completionExpr, []) - when Loc.hasPosInclusiveEnd ~pos exp.pexp_loc -> - (* No cases means there's no `|` yet in the switch, so `switch someExpr` *) - result := Some (Switch {pos; switchExpr = exp; completionExpr}) - | _ -> ()); - Ast_iterator.default_iterator.expr iterator exp - in - {Ast_iterator.default_iterator with expr} - - let mkIteratorRange ~startPos ~endPos ~foundSelection = - let expr (iterator : Ast_iterator.iterator) (exp : Parsetree.expression) = - let expStartPos = Pos.ofLexing exp.pexp_loc.loc_start in - let expEndPos = Pos.ofLexing exp.pexp_loc.loc_end in - - (if expStartPos = startPos then - match !foundSelection with - | None, endExpr -> foundSelection := (Some exp, endExpr) - | _ -> ()); - - (if expEndPos = endPos then - match !foundSelection with - | startExp, _ -> foundSelection := (startExp, Some exp)); - - Ast_iterator.default_iterator.expr iterator exp - in - {Ast_iterator.default_iterator with expr} - - let xform ~printExpr ~path ~source ~kindFile ~pos ~full ~structure - ~codeActions ~debug = - (* TODO: Adapt to '(' as leading/trailing character (skip one col, it's not included in the AST) *) - let result = ref None in - let foundSelection = ref (None, None) in - let iterator = - match pos with - | Single pos -> mkIteratorSingle ~pos ~result - | Range (startPos, endPos) -> - mkIteratorRange ~startPos ~endPos ~foundSelection - in - iterator.structure iterator structure; - (match !foundSelection with - | Some startExp, Some endExp -> - if debug then - Printf.printf "found selection: %s -> %s\n" - (Loc.toString startExp.pexp_loc) - (Loc.toString endExp.pexp_loc); - result := Some (Selection {expr = startExp}) - | _ -> ()); - match !result with - | None -> () - | Some (Selection {expr}) -> ( - match - expr - |> extractTypeFromExpr ~debug ~source ~kindFile ~full - ~pos:(Pos.ofLexing expr.pexp_loc.loc_start) - with - | None -> () - | Some extractedType -> ( - let open TypeUtils.Codegen in - let exhaustiveSwitch = - extractedTypeToExhaustiveCases - ~env:(SharedTypes.QueryEnv.fromFile full.file) - ~full extractedType - in - match exhaustiveSwitch with - | None -> () - | Some cases -> - let range = Loc.rangeOfLoc expr.pexp_loc in - let newText = - printExpr ~range {expr with pexp_desc = Pexp_match (expr, cases)} - in - let codeAction = - CodeActions.make ~title:"Exhaustive switch" ~kind:RefactorRewrite - ~uri:path ~newText ~range - in - codeActions := codeAction :: !codeActions)) - | Some (Switch {switchExpr; completionExpr; pos}) -> ( - match - completionExpr - |> extractTypeFromExpr ~debug ~source ~kindFile ~full ~pos - with - | None -> () - | Some extractedType -> ( - let open TypeUtils.Codegen in - let exhaustiveSwitch = - extractedTypeToExhaustiveCases - ~env:(SharedTypes.QueryEnv.fromFile full.file) - ~full extractedType - in - match exhaustiveSwitch with - | None -> () - | Some cases -> - let range = Loc.rangeOfLoc switchExpr.pexp_loc in - let newText = - printExpr ~range - {switchExpr with pexp_desc = Pexp_match (completionExpr, cases)} - in - let codeAction = - CodeActions.make ~title:"Exhaustive switch" ~kind:RefactorRewrite - ~uri:path ~newText ~range - in - codeActions := codeAction :: !codeActions)) -end - -module AddDocTemplate = struct - let createTemplate () = - let docContent = ["\n"; "\n"] in - let expression = - Ast_helper.Exp.constant - (Parsetree.Pconst_string (String.concat "" docContent, None)) - in - let structureItemDesc = Parsetree.Pstr_eval (expression, []) in - let structureItem = Ast_helper.Str.mk structureItemDesc in - let attrLoc = - { - Location.none with - loc_start = Lexing.dummy_pos; - loc_end = - { - Lexing.dummy_pos with - pos_lnum = Lexing.dummy_pos.pos_lnum (* force line break *); - }; - } - in - (Location.mkloc "res.doc" attrLoc, Parsetree.PStr [structureItem]) - - module Interface = struct - let mkIterator ~pos ~result = - let signature_item (iterator : Ast_iterator.iterator) - (item : Parsetree.signature_item) = - match item.psig_desc with - | Psig_value value_description as r - when Loc.hasPos ~pos value_description.pval_loc - && ProcessAttributes.findDocAttribute - value_description.pval_attributes - = None -> - result := Some (r, item.psig_loc) - | Psig_type (_, hd :: _) as r - when Loc.hasPos ~pos hd.ptype_loc - && ProcessAttributes.findDocAttribute hd.ptype_attributes = None - -> - result := Some (r, item.psig_loc) - | Psig_module {pmd_name = {loc}} as r -> - if Loc.start loc = pos then result := Some (r, item.psig_loc) - else Ast_iterator.default_iterator.signature_item iterator item - | _ -> Ast_iterator.default_iterator.signature_item iterator item - in - {Ast_iterator.default_iterator with signature_item} - - let processSigValue (valueDesc : Parsetree.value_description) loc = - let attr = createTemplate () in - let newValueBinding = - {valueDesc with pval_attributes = attr :: valueDesc.pval_attributes} - in - let signature_item_desc = Parsetree.Psig_value newValueBinding in - Ast_helper.Sig.mk ~loc signature_item_desc - - let processTypeDecl (typ : Parsetree.type_declaration) = - let attr = createTemplate () in - let newTypeDeclaration = - {typ with ptype_attributes = attr :: typ.ptype_attributes} - in - newTypeDeclaration - - let processModDecl (modDecl : Parsetree.module_declaration) loc = - let attr = createTemplate () in - let newModDecl = - {modDecl with pmd_attributes = attr :: modDecl.pmd_attributes} - in - Ast_helper.Sig.mk ~loc (Parsetree.Psig_module newModDecl) - - let xform ~path ~pos ~codeActions ~signature ~printSignatureItem = - let result = ref None in - let iterator = mkIterator ~pos ~result in - iterator.signature iterator signature; - match !result with - | Some (signatureItem, loc) -> ( - let newSignatureItem = - match signatureItem with - | Psig_value value_desc -> - Some (processSigValue value_desc value_desc.pval_loc) (* Some loc *) - | Psig_type (flag, hd :: tl) -> - let newFirstTypeDecl = processTypeDecl hd in - Some - (Ast_helper.Sig.mk ~loc - (Parsetree.Psig_type (flag, newFirstTypeDecl :: tl))) - | Psig_module modDecl -> Some (processModDecl modDecl loc) - | _ -> None - in - - match newSignatureItem with - | Some signatureItem -> - let range = Loc.rangeOfLoc signatureItem.psig_loc in - let newText = printSignatureItem ~range signatureItem in - let codeAction = - CodeActions.make ~title:"Add Documentation template" - ~kind:RefactorRewrite ~uri:path ~newText ~range - in - codeActions := codeAction :: !codeActions - | None -> ()) - | None -> () - end - - module Implementation = struct - let mkIterator ~pos ~result = - let structure_item (iterator : Ast_iterator.iterator) - (si : Parsetree.structure_item) = - match si.pstr_desc with - | Pstr_value (_, {pvb_pat = {ppat_loc}; pvb_attributes} :: _) as r - when Loc.hasPos ~pos ppat_loc - && ProcessAttributes.findDocAttribute pvb_attributes = None -> - result := Some (r, si.pstr_loc) - | Pstr_primitive value_description as r - when Loc.hasPos ~pos value_description.pval_loc - && ProcessAttributes.findDocAttribute - value_description.pval_attributes - = None -> - result := Some (r, si.pstr_loc) - | Pstr_module {pmb_name = {loc}} as r -> - if Loc.start loc = pos then result := Some (r, si.pstr_loc) - else Ast_iterator.default_iterator.structure_item iterator si - | Pstr_type (_, hd :: _) as r - when Loc.hasPos ~pos hd.ptype_loc - && ProcessAttributes.findDocAttribute hd.ptype_attributes = None - -> - result := Some (r, si.pstr_loc) - | _ -> Ast_iterator.default_iterator.structure_item iterator si - in - {Ast_iterator.default_iterator with structure_item} - - let processValueBinding (valueBinding : Parsetree.value_binding) = - let attr = createTemplate () in - let newValueBinding = - {valueBinding with pvb_attributes = attr :: valueBinding.pvb_attributes} - in - newValueBinding - - let processPrimitive (valueDesc : Parsetree.value_description) loc = - let attr = createTemplate () in - let newValueDesc = - {valueDesc with pval_attributes = attr :: valueDesc.pval_attributes} - in - Ast_helper.Str.primitive ~loc newValueDesc - - let processModuleBinding (modBind : Parsetree.module_binding) loc = - let attr = createTemplate () in - let newModBinding = - {modBind with pmb_attributes = attr :: modBind.pmb_attributes} - in - Ast_helper.Str.module_ ~loc newModBinding - - let xform ~pos ~codeActions ~path ~printStructureItem ~structure = - let result = ref None in - let iterator = mkIterator ~pos ~result in - iterator.structure iterator structure; - match !result with - | None -> () - | Some (structureItem, loc) -> ( - let newStructureItem = - match structureItem with - | Pstr_value (flag, hd :: tl) -> - let newValueBinding = processValueBinding hd in - Some - (Ast_helper.Str.mk ~loc - (Parsetree.Pstr_value (flag, newValueBinding :: tl))) - | Pstr_primitive valueDesc -> Some (processPrimitive valueDesc loc) - | Pstr_module modBind -> Some (processModuleBinding modBind loc) - | Pstr_type (flag, hd :: tl) -> - let newFirstTypeDecl = Interface.processTypeDecl hd in - Some - (Ast_helper.Str.mk ~loc - (Parsetree.Pstr_type (flag, newFirstTypeDecl :: tl))) - | _ -> None - in - - match newStructureItem with - | Some structureItem -> - let range = Loc.rangeOfLoc structureItem.pstr_loc in - let newText = printStructureItem ~range structureItem in - let codeAction = - CodeActions.make ~title:"Add Documentation template" - ~kind:RefactorRewrite ~uri:path ~newText ~range - in - codeActions := codeAction :: !codeActions - | None -> ()) - end -end - -let parseImplementation ~source = - let {Res_driver.parsetree = structure; comments} = - Res_driver.parsing_engine.parse_implementation_from_source - ~for_printer:false ~source - in - let filterComments ~loc comments = - (* Relevant comments in the range of the expression *) - let filter comment = - Loc.hasPos ~pos:(Loc.start (Res_comment.loc comment)) loc - in - comments |> List.filter filter - in - let printExpr ~(range : Lsp.Types.Range.t) (expr : Parsetree.expression) = - let structure = [Ast_helper.Str.eval ~loc:expr.pexp_loc expr] in - structure - |> Res_printer.print_implementation - ~comments:(comments |> filterComments ~loc:expr.pexp_loc) - |> Utils.indent range.start.character - in - let printStructureItem ~(range : Lsp.Types.Range.t) - (item : Parsetree.structure_item) = - let structure = [item] in - structure - |> Res_printer.print_implementation - ~comments:(comments |> filterComments ~loc:item.pstr_loc) - |> Utils.indent range.start.character - in - let printStandaloneStructure ~(loc : Location.t) structure = - structure - |> Res_printer.print_implementation - ~comments:(comments |> filterComments ~loc) - in - (structure, printExpr, printStructureItem, printStandaloneStructure) - -let parseInterface ~source = - let {Res_driver.parsetree = structure; comments} = - Res_driver.parsing_engine.parse_interface_from_source ~for_printer:false - ~source - in - let filterComments ~loc comments = - (* Relevant comments in the range of the expression *) - let filter comment = - Loc.hasPos ~pos:(Loc.start (Res_comment.loc comment)) loc - in - comments |> List.filter filter - in - let printSignatureItem ~(range : Lsp.Types.Range.t) - (item : Parsetree.signature_item) = - let signature_item = [item] in - signature_item - |> Res_printer.print_interface - ~comments:(comments |> filterComments ~loc:item.psig_loc) - |> Utils.indent range.start.character - in - (structure, printSignatureItem) - -let extractCodeActions ~path ~startPos ~endPos ~source ~kindFile ~debug = - let pos = startPos in - let codeActions = ref [] in - match kindFile with - | Files.Res -> - let structure, printExpr, printStructureItem, printStandaloneStructure = - parseImplementation ~source - in - IfThenElse.xform ~pos ~codeActions ~printExpr ~path structure; - ModuleToFile.xform ~pos ~codeActions ~path ~printStandaloneStructure - structure; - AddBracesToFn.xform ~pos ~codeActions ~path ~printStructureItem structure; - AddDocTemplate.Implementation.xform ~pos ~codeActions ~path - ~printStructureItem ~structure; - - (* This Code Action needs type info *) - let () = - match Cmt.loadFullCmtFromPath ~path with - | Some full -> - AddTypeAnnotation.xform ~path ~pos ~full ~structure ~codeActions ~debug; - ExpandCatchAllForVariants.xform ~path ~source ~kindFile ~pos ~full - ~structure ~codeActions ~debug; - ExhaustiveSwitch.xform ~printExpr ~path ~source ~kindFile - ~pos: - (if startPos = endPos then Single startPos - else Range (startPos, endPos)) - ~full ~structure ~codeActions ~debug - | None -> () - in - - !codeActions - | Resi -> - let signature, printSignatureItem = parseInterface ~source in - AddDocTemplate.Interface.xform ~pos ~codeActions ~path ~signature - ~printSignatureItem; - !codeActions - | Other -> [] diff --git a/analysis/src/YojsonHelpers.ml b/analysis/src/YojsonHelpers.ml deleted file mode 100644 index bca4f707ebe..00000000000 --- a/analysis/src/YojsonHelpers.ml +++ /dev/null @@ -1 +0,0 @@ -include Reanalyze.YojsonHelpers diff --git a/analysis/src/BuildSystem.ml b/analysis/src/build_system.ml similarity index 70% rename from analysis/src/BuildSystem.ml rename to analysis/src/build_system.ml index de8f9c9bbeb..50c0d2a7d62 100644 --- a/analysis/src/BuildSystem.ml +++ b/analysis/src/build_system.ml @@ -1,4 +1,4 @@ -let namespacedName namespace name = +let namespaced_name namespace name = match namespace with | None -> name | Some namespace -> name ^ "-" ^ namespace @@ -10,18 +10,18 @@ Editor tooling can more accurately resolve the runtime path and will try and pas Example path: "test-stdlib/node_modules/.pnpm/@rescript+runtime@12.0.0-rc.4/node_modules/@rescript/runtime" *) -let getRuntimeDir rootPath = - match !Cfg.isDocGenFromCompiler with +let get_runtime_dir root_path = + match !Cfg.is_doc_gen_from_compiler with | false -> ( (* First check RESCRIPT_RUNTIME environment variable, like bsc does *) match Sys.getenv_opt "RESCRIPT_RUNTIME" with - | Some envPath -> + | Some env_path -> if Debug.verbose () then - Printf.printf "[getRuntimeDir] Using RESCRIPT_RUNTIME=%s\n" envPath; - Some envPath + Printf.printf "[getRuntimeDir] Using RESCRIPT_RUNTIME=%s\n" env_path; + Some env_path | None -> ( let result = - ModuleResolution.resolveNodeModulePath ~startPath:rootPath + Module_resolution.resolve_node_module_path ~start_path:root_path "@rescript/runtime" in match result with @@ -36,13 +36,13 @@ let getRuntimeDir rootPath = Printf.printf "[getRuntimeDir] Failed to resolve @rescript/runtime from \ rootPath=%s\n" - rootPath; + root_path; None)) - | true -> Some rootPath + | true -> Some root_path -let getLibBs path = Files.ifExists (path /+ "lib" /+ "bs") +let get_lib_bs path = Files.if_exists (path /+ "lib" /+ "bs") -let getStdlib base = - match getRuntimeDir base with +let get_stdlib base = + match get_runtime_dir base with | None -> None - | Some runtimeDir -> Some (runtimeDir /+ "lib" /+ "ocaml") + | Some runtime_dir -> Some (runtime_dir /+ "lib" /+ "ocaml") diff --git a/analysis/src/cache.ml b/analysis/src/cache.ml new file mode 100644 index 00000000000..a70f46c5029 --- /dev/null +++ b/analysis/src/cache.ml @@ -0,0 +1,42 @@ +open Shared_types + +type cached = { + project_files: File_set.t; + dependencies_files: File_set.t; + paths_for_module: (file, paths) Hashtbl.t; +} + +let write_cache filename (data : cached) = + let oc = open_out_bin filename in + Marshal.to_channel oc data []; + close_out oc + +let read_cache filename = + if !Cfg.read_project_config_cache && Sys.file_exists filename then + try + let ic = open_in_bin filename in + let data : cached = Marshal.from_channel ic in + close_in ic; + Some data + with _ -> None + else None + +let delete_cache filename = try Sys.remove filename with _ -> () + +let target_file_from_lib_bs lib_bs = + Filename.concat lib_bs ".project-files-cache" + +let cache_project (package : package) = + let cached = + { + project_files = package.project_files; + dependencies_files = package.dependencies_files; + paths_for_module = package.paths_for_module; + } + in + match Build_system.get_lib_bs package.root_path with + | None -> print_endline "\"ERR\"" + | Some lib_bs -> + let target_file = target_file_from_lib_bs lib_bs in + write_cache target_file cached; + print_endline "\"OK\"" diff --git a/analysis/src/Cfg.ml b/analysis/src/cfg.ml similarity index 65% rename from analysis/src/Cfg.ml rename to analysis/src/cfg.ml index bd4166d5ab0..f4bf9d05744 100644 --- a/analysis/src/Cfg.ml +++ b/analysis/src/cfg.ml @@ -1,8 +1,8 @@ -let debugFollowCtxPath = ref false +let debug_follow_ctx_path = ref false -let isDocGenFromCompiler = ref false +let is_doc_gen_from_compiler = ref false -let inIncrementalTypecheckingMode = +let in_incremental_typechecking_mode = ref (try match Sys.getenv "RESCRIPT_INCREMENTAL_TYPECHECKING" with @@ -10,7 +10,7 @@ let inIncrementalTypecheckingMode = | _ -> false with _ -> false) -let readProjectConfigCache = +let read_project_config_cache = ref (try match Sys.getenv "RESCRIPT_PROJECT_CONFIG_CACHE" with diff --git a/analysis/src/Cli.ml b/analysis/src/cli.ml similarity index 58% rename from analysis/src/Cli.ml rename to analysis/src/cli.ml index 727313cb800..4277934fc7e 100644 --- a/analysis/src/Cli.ml +++ b/analysis/src/cli.ml @@ -3,107 +3,110 @@ let print_string json = let print_null () = `Null |> print_string let print_list l = `List l |> print_string -let completion ~debug ~path ~pos ~currentFile = - let full = Cmt.loadFullCmtFromPath ~path in - let kindFile = Files.classifySourceFile currentFile in - match Files.readFile currentFile with +let completion ~debug ~path ~pos ~current_file = + let full = Cmt.load_full_cmt_from_path ~path in + let kind_file = Files.classify_source_file current_file in + match Files.read_file current_file with | None | Some "" -> print_null () | Some source -> - Commands.completion ~debug ~source ~kindFile ~pos ~full + Commands.completion ~debug ~source ~kind_file ~pos ~full |> List.map (fun c -> Lsp.Types.CompletionItem.yojson_of_t c) |> print_list -let completionResolve ~path ~modulePath = - let full = Cmt.loadFullCmtFromPath ~path in - match Commands.completionResolve ~full ~modulePath with +let completion_resolve ~path ~module_path = + let full = Cmt.load_full_cmt_from_path ~path in + match Commands.completion_resolve ~full ~module_path with | None -> print_null () | Some (`MarkupContent {value}) -> `String value |> print_string -let inlayhint ~path ~pos ~maxLength ~debug = - let full = Cmt.loadFullCmtFromPath ~path in - let kindFile = Files.classifySourceFile path in - match Files.readFile path with +let inlayhint ~path ~pos ~max_length ~debug = + let full = Cmt.load_full_cmt_from_path ~path in + let kind_file = Files.classify_source_file path in + match Files.read_file path with | None -> print_null () | Some source -> ( - match Hint.inlay ~source ~kindFile ~pos ~maxLength ~full ~debug with + match Hint.inlay ~source ~kind_file ~pos ~max_length ~full ~debug with | Some hints -> hints |> List.map (fun h -> Lsp.Types.InlayHint.yojson_of_t h) |> print_list | None -> print_null ()) -let codeLens ~path ~debug = - let full = Cmt.loadFullCmtFromPath ~path in - let kindFile = Files.classifySourceFile path in - match Files.readFile path with +let code_lens ~path ~debug = + let full = Cmt.load_full_cmt_from_path ~path in + let kind_file = Files.classify_source_file path in + match Files.read_file path with | None -> print_null () | Some source -> ( - match Hint.codeLens ~source ~kindFile ~full ~debug with + match Hint.code_lens ~source ~kind_file ~full ~debug with | Some lens -> lens |> List.map (fun l -> Lsp.Types.CodeLens.yojson_of_t l) |> print_list | None -> print_null ()) -let hover ~path ~pos ~currentFile ~debug ~supportsMarkdownLinks = - let full = Cmt.loadFullCmtFromPath ~path in - let kindFile = Files.classifySourceFile currentFile in - match Files.readFile currentFile with +let hover ~path ~pos ~current_file ~debug ~supports_markdown_links = + let full = Cmt.load_full_cmt_from_path ~path in + let kind_file = Files.classify_source_file current_file in + match Files.read_file current_file with | None -> print_null () | Some source -> ( match - Commands.hover ~source ~kindFile ~pos ~debug ~supportsMarkdownLinks ~full + Commands.hover ~source ~kind_file ~pos ~debug ~supports_markdown_links + ~full with | Some value -> Lsp.Types.Hover.yojson_of_t value |> print_string | None -> print_null ()) -let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = - let full = Cmt.loadFullCmtFromPath ~path in - let kindFile = Files.classifySourceFile currentFile in - match Files.readFile currentFile with +let signature_help ~path ~pos ~current_file ~debug + ~allow_for_constructor_payloads = + let full = Cmt.load_full_cmt_from_path ~path in + let kind_file = Files.classify_source_file current_file in + match Files.read_file current_file with | None -> print_null () | Some source -> ( match - SignatureHelp.signatureHelp ~source ~kindFile ~pos - ~allowForConstructorPayloads ~full ~debug + Signature_help.signature_help ~source ~kind_file ~pos + ~allow_for_constructor_payloads ~full ~debug with | None -> print_null () | Some s -> Lsp.Types.SignatureHelp.yojson_of_t s |> print_string) -let codeAction ~path ~startPos ~endPos ~currentFile ~debug = - let kindFile = Files.classifySourceFile currentFile in - match Files.readFile currentFile with +let code_action ~path ~start_pos ~end_pos ~current_file ~debug = + let kind_file = Files.classify_source_file current_file in + match Files.read_file current_file with | None -> print_null () | Some source -> - Xform.extractCodeActions ~path ~startPos ~endPos ~source ~kindFile ~debug + Xform.extract_code_actions ~path ~start_pos ~end_pos ~source ~kind_file + ~debug |> List.map (fun c -> Lsp.Types.CodeAction.yojson_of_t c) |> print_list let definition ~path ~pos ~debug = - let full = Cmt.loadFullCmtFromPath ~path in + let full = Cmt.load_full_cmt_from_path ~path in match Commands.definition ~full ~pos ~debug with | None -> print_null () | Some location -> location |> Lsp.Types.Location.yojson_of_t |> print_string -let typeDefinition ~path ~pos ~debug = - let full = Cmt.loadFullCmtFromPath ~path in - match Commands.typeDefinition ~full ~pos ~debug with +let type_definition ~path ~pos ~debug = + let full = Cmt.load_full_cmt_from_path ~path in + match Commands.type_definition ~full ~pos ~debug with | None -> print_null () | Some location -> location |> Lsp.Types.Location.yojson_of_t |> print_string let references ~path ~pos ~debug = - let full = Cmt.loadFullCmtFromPath ~path in - let allLocs = Commands.references ~full ~pos ~debug in - if allLocs = [] then print_null () + let full = Cmt.load_full_cmt_from_path ~path in + let all_locs = Commands.references ~full ~pos ~debug in + if all_locs = [] then print_null () else - allLocs + all_locs |> List.map (fun l -> Lsp.Types.Location.yojson_of_t l) |> print_list -let rename ~path ~pos ~newName ~debug = - let full = Cmt.loadFullCmtFromPath ~path in - match Commands.rename ~full ~pos ~newName ~debug with - | Some {documentChanges = Some documentChanges} -> - documentChanges +let rename ~path ~pos ~new_name ~debug = + let full = Cmt.load_full_cmt_from_path ~path in + match Commands.rename ~full ~pos ~new_name ~debug with + | Some {documentChanges = Some document_changes} -> + document_changes |> List.map (fun c -> match c with | `RenameFile r -> Lsp.Types.RenameFile.yojson_of_t r @@ -113,9 +116,9 @@ let rename ~path ~pos ~newName ~debug = |> print_list | _ -> print_null () -let prepareRename ~path ~pos ~debug = - let full = Cmt.loadFullCmtFromPath ~path in - match Commands.prepareRename ~full ~pos ~debug with +let prepare_rename ~path ~pos ~debug = + let full = Cmt.load_full_cmt_from_path ~path in + match Commands.prepare_rename ~full ~pos ~debug with | None -> print_null () | Some {range; placeholder = None} -> Lsp.Types.Range.yojson_of_t range |> print_string @@ -128,46 +131,46 @@ let prepareRename ~path ~pos ~debug = |> print_string let format ~path = - match Files.readFile path with + match Files.read_file path with | None -> print_null () | Some source -> ( - let kindFile = Files.classifySourceFile path in - match Commands.format ~source ~kindFile with - | Ok textEdits -> ( - match textEdits with + let kind_file = Files.classify_source_file path in + match Commands.format ~source ~kind_file with + | Ok text_edits -> ( + match text_edits with | {newText} :: _ -> print_string (`String newText) | _ -> print_null ()) | Error _ -> print_null ()) -let diagnosticSyntax ~path = - match Files.readFile path with +let diagnostic_syntax ~path = + match Files.read_file path with | None -> print_list [] | Some source -> - let kindFile = Files.classifySourceFile path in - Diagnostics.document_syntax ~source ~kindFile + let kind_file = Files.classify_source_file path in + Diagnostics.document_syntax ~source ~kind_file |> List.map Lsp.Types.Diagnostic.yojson_of_t |> print_list -let semanticTokens ~path = - match Files.readFile path with +let semantic_tokens ~path = + match Files.read_file path with | None -> print_null () | Some source -> - let kindFile = Files.classifySourceFile path in - let tokens = SemanticTokens.semanticTokens ~source ~kindFile in + let kind_file = Files.classify_source_file path in + let tokens = Semantic_tokens.semantic_tokens ~source ~kind_file in Lsp.Types.SemanticTokens.yojson_of_t tokens |> print_string let test ~path = - Uri.stripPath := true; - match Files.readFile path with + Uri.strip_path := true; + match Files.read_file path with | None -> assert false | Some text -> let lines = text |> String.split_on_char '\n' in - let processLine i line = - let createCurrentFile () = - let currentFile, cout = + let process_line i line = + let create_current_file () = + let current_file, cout = Filename.open_temp_file "def" ("txt." ^ Filename.extension path) in - let removeLineComment l = + let remove_line_comment l = let len = String.length l in let rec loop i = if i + 2 <= len && l.[i] = '/' && l.[i + 1] = '/' then Some (i + 2) @@ -176,18 +179,18 @@ let test ~path = in match loop 0 with | None -> l - | Some indexAfterComment -> - String.make indexAfterComment ' ' - ^ String.sub l indexAfterComment (len - indexAfterComment) + | Some index_after_comment -> + String.make index_after_comment ' ' + ^ String.sub l index_after_comment (len - index_after_comment) in lines |> List.iteri (fun j l -> - let lineToOutput = - if j == i - 1 then removeLineComment l else l + let line_to_output = + if j == i - 1 then remove_line_comment l else l in - Printf.fprintf cout "%s\n" lineToOutput); + Printf.fprintf cout "%s\n" line_to_output); close_out cout; - currentFile + current_file in if Str.string_match (Str.regexp "^ *//[ ]*\\^") line 0 then let matched = Str.matched_string line in @@ -200,21 +203,23 @@ let test ~path = (match String.sub rest 0 3 with | "db+" -> Log.verbose := true | "db-" -> Log.verbose := false - | "dv+" -> Debug.debugLevel := Verbose - | "dv-" -> Debug.debugLevel := Off - | "in+" -> Cfg.inIncrementalTypecheckingMode := true - | "in-" -> Cfg.inIncrementalTypecheckingMode := false + | "dv+" -> Debug.debug_level := Verbose + | "dv-" -> Debug.debug_level := Off + | "in+" -> Cfg.in_incremental_typechecking_mode := true + | "in-" -> Cfg.in_incremental_typechecking_mode := false | "ve+" -> ( let version = String.sub rest 3 (String.length rest - 3) in let version = String.trim version in if Debug.verbose () then Printf.printf "Setting version: %s\n" version; match String.split_on_char '.' version with - | [majorRaw; minorRaw] -> - let version = (int_of_string majorRaw, int_of_string minorRaw) in - Packages.overrideRescriptVersion := Some version + | [major_raw; minor_raw] -> + let version = + (int_of_string major_raw, int_of_string minor_raw) + in + Packages.override_rescript_version := Some version | _ -> ()) - | "ve-" -> Packages.overrideRescriptVersion := None + | "ve-" -> Packages.override_rescript_version := None | "def" -> print_endline ("Definition " ^ path ^ " " ^ string_of_int line ^ ":" @@ -224,57 +229,57 @@ let test ~path = print_endline ("Complete " ^ path ^ " " ^ string_of_int line ^ ":" ^ string_of_int col); - let currentFile = createCurrentFile () in - completion ~debug:true ~path ~pos:(line, col) ~currentFile; - Sys.remove currentFile + let current_file = create_current_file () in + completion ~debug:true ~path ~pos:(line, col) ~current_file; + Sys.remove current_file | "cre" -> - let modulePath = String.sub rest 3 (String.length rest - 3) in - let modulePath = String.trim modulePath in - print_endline ("Completion resolve: " ^ modulePath); - completionResolve ~path ~modulePath + let module_path = String.sub rest 3 (String.length rest - 3) in + let module_path = String.trim module_path in + print_endline ("Completion resolve: " ^ module_path); + completion_resolve ~path ~module_path | "dce" -> print_endline ("DCE " ^ path); - Reanalyze.RunConfig.runConfig.suppress <- ["src"]; - Reanalyze.RunConfig.runConfig.unsuppress <- + Reanalyze.Run_config.run_config.suppress <- ["src"]; + Reanalyze.Run_config.run_config.unsuppress <- [Filename.concat "src" "dce"]; - DceCommand.command () + Dce_command.command () | "doc" -> print_endline ("DocumentSymbol " ^ path); - DocumentSymbol.command ~path + Document_symbol.command ~path | "hig" -> print_endline ("Highlight " ^ path); - let source = Files.readFile path |> Option.get in - let kindFile = Files.classifySourceFile path in + let source = Files.read_file path |> Option.get in + let kind_file = Files.classify_source_file path in - SemanticTokens.command ~debug:true - ~emitter:(SemanticTokens.Token.createEmitter ()) - ~source ~kindFile + Semantic_tokens.command ~debug:true + ~emitter:(Semantic_tokens.Token.create_emitter ()) + ~source ~kind_file | "hov" -> print_endline ("Hover " ^ path ^ " " ^ string_of_int line ^ ":" ^ string_of_int col); - let currentFile = createCurrentFile () in - hover ~supportsMarkdownLinks:true ~path ~pos:(line, col) - ~currentFile ~debug:true; - Sys.remove currentFile + let current_file = create_current_file () in + hover ~supports_markdown_links:true ~path ~pos:(line, col) + ~current_file ~debug:true; + Sys.remove current_file | "she" -> print_endline ("Signature help " ^ path ^ " " ^ string_of_int line ^ ":" ^ string_of_int col); - let currentFile = createCurrentFile () in - signatureHelp ~path ~pos:(line, col) ~currentFile ~debug:true - ~allowForConstructorPayloads:true; - Sys.remove currentFile + let current_file = create_current_file () in + signature_help ~path ~pos:(line, col) ~current_file ~debug:true + ~allow_for_constructor_payloads:true; + Sys.remove current_file | "int" -> print_endline ("Create Interface " ^ path); - let cmiFile = + let cmi_file = let open Filename in let ( ++ ) = concat in let name = chop_extension (basename path) ^ ".cmi" in let dir = dirname path in dir ++ parent_dir_name ++ "lib" ++ "bs" ++ "src" ++ name in - Printf.printf "%s" (CreateInterface.command ~path ~cmiFile) + Printf.printf "%s" (Create_interface.command ~path ~cmi_file) | "ref" -> print_endline ("References " ^ path ^ " " ^ string_of_int line ^ ":" @@ -284,45 +289,45 @@ let test ~path = print_endline ("PrepareRename " ^ path ^ " " ^ string_of_int line ^ ":" ^ string_of_int col); - prepareRename ~path ~pos:(line, col) ~debug:true + prepare_rename ~path ~pos:(line, col) ~debug:true | "ren" -> - let newName = String.sub rest 4 (len - mlen - 4) in + let new_name = String.sub rest 4 (len - mlen - 4) in let () = print_endline ("Rename " ^ path ^ " " ^ string_of_int line ^ ":" - ^ string_of_int col ^ " " ^ newName) + ^ string_of_int col ^ " " ^ new_name) in - rename ~path ~pos:(line, col) ~newName ~debug:true + rename ~path ~pos:(line, col) ~new_name ~debug:true | "typ" -> print_endline ("TypeDefinition " ^ path ^ " " ^ string_of_int line ^ ":" ^ string_of_int col); - typeDefinition ~path ~pos:(line, col) ~debug:true + type_definition ~path ~pos:(line, col) ~debug:true | "xfm" -> - let currentFile = createCurrentFile () in + let current_file = create_current_file () in (* +2 is to ensure that the character ^ points to is what's considered the end of the selection. *) - let endCol = col + try String.index rest '^' + 2 with _ -> 0 in - let endPos = (line, endCol) in - let startPos = (line, col) in - if startPos = endPos then + let end_col = col + try String.index rest '^' + 2 with _ -> 0 in + let end_pos = (line, end_col) in + let start_pos = (line, col) in + if start_pos = end_pos then print_endline ("Xform " ^ path ^ " " ^ string_of_int line ^ ":" ^ string_of_int col) else print_endline - ("Xform " ^ path ^ " start: " ^ Pos.toString startPos - ^ ", end: " ^ Pos.toString endPos); + ("Xform " ^ path ^ " start: " ^ Pos.to_string start_pos + ^ ", end: " ^ Pos.to_string end_pos); let source = - Files.readFile currentFile |> Option.value ~default:"" + Files.read_file current_file |> Option.value ~default:"" in - let kindFile = Files.classifySourceFile currentFile in - let codeActions = - Xform.extractCodeActions ~path ~startPos ~endPos ~source ~kindFile - ~debug:true + let kind_file = Files.classify_source_file current_file in + let code_actions = + Xform.extract_code_actions ~path ~start_pos ~end_pos ~source + ~kind_file ~debug:true in - Sys.remove currentFile; - codeActions + Sys.remove current_file; + code_actions |> List.iter (fun {Lsp.Types.CodeAction.title; edit} -> Printf.printf "Hit: %s\n" title; match edit with @@ -340,7 +345,7 @@ let test ~path = match dc with | `TextDocumentEdit tde -> let filename = - tde.textDocument.uri |> Uri.toPath + tde.textDocument.uri |> Uri.to_path |> Filename.basename in Printf.printf "\nTextDocumentEdit: %s\n" filename; @@ -353,7 +358,7 @@ let test ~path = Lsp.Types.AnnotatedTextEdit.t | `TextEdit of Lsp.Types.TextEdit.t ]) -> - let start_char, newText, range = + let start_char, new_text, range = match edit with | `TextEdit te -> ( te.range.start.character, @@ -369,10 +374,10 @@ let test ~path = "%s\nnewText:\n%s<--here\n%s%s\n" (Lsp.Types.Range.yojson_of_t range |> Yojson.Safe.pretty_to_string) - indent indent newText) + indent indent new_text) | `CreateFile cf -> let filename = - cf.uri |> Uri.toPath |> Filename.basename + cf.uri |> Uri.to_path |> Filename.basename in Printf.printf "\nCreateFile: %s\n" filename | _ -> @@ -383,11 +388,11 @@ let test ~path = print_endline ("Codemod AddMissingCases" ^ path ^ " " ^ string_of_int line ^ ":" ^ string_of_int col); - let source = Files.readFile path |> Option.value ~default:"" in + let source = Files.read_file path |> Option.value ~default:"" in Codemod.transform ~source ~pos:(line, col) ~debug:true ~typ:AddMissingCases ~hint |> print_endline - | "dia" -> diagnosticSyntax ~path + | "dia" -> diagnostic_syntax ~path | "hin" -> (* Get all inlay Hint between line 1 and n. Don't get the first line = 0. @@ -397,20 +402,20 @@ let test ~path = print_endline ("Inlay Hint " ^ path ^ " " ^ string_of_int line_start ^ ":" ^ string_of_int line_end); - inlayhint ~path ~pos:(line_start, line_end) ~maxLength:"25" + inlayhint ~path ~pos:(line_start, line_end) ~max_length:"25" ~debug:false | "cle" -> print_endline ("Code Lens " ^ path); - codeLens ~path ~debug:false + code_lens ~path ~debug:false | "ast" -> print_endline ("Dump AST " ^ path ^ " " ^ string_of_int line ^ ":" ^ string_of_int col); - let currentFile = createCurrentFile () in - DumpAst.dump ~pos:(line, col) ~currentFile; - Sys.remove currentFile - | "sem" -> semanticTokens ~path + let current_file = create_current_file () in + Dump_ast.dump ~pos:(line, col) ~current_file; + Sys.remove current_file + | "sem" -> semantic_tokens ~path | _ -> ()); print_newline ()) in - lines |> List.iteri processLine + lines |> List.iteri process_line diff --git a/analysis/src/cmt.ml b/analysis/src/cmt.ml new file mode 100644 index 00000000000..7c0f8343f9f --- /dev/null +++ b/analysis/src/cmt.ml @@ -0,0 +1,67 @@ +open Shared_types + +let full_for_cmt ~module_name ~package ~uri cmt = + match Shared.try_read_cmt cmt with + | None -> None + | Some infos -> + let file = Process_cmt.file_for_cmt_infos ~module_name ~uri infos in + let extra = Process_extra.get_extra ~file ~infos in + Some {file; extra; package} + +let full_from_uri ~uri = + let path = Uri.to_path uri in + match Packages.get_package ~uri with + | None -> None + | Some package -> ( + let module_name = + Build_system.namespaced_name package.namespace (Find_files.get_name path) + in + let incremental = + if !Cfg.in_incremental_typechecking_mode then + let incremental_cmt_path = + package.root_path ^ "/lib/bs/___incremental" ^ "/" ^ module_name + ^ + match Files.classify_source_file path with + | Resi -> ".cmti" + | _ -> ".cmt" + in + full_for_cmt ~module_name ~package ~uri incremental_cmt_path + else None + in + match incremental with + | Some cmt_info -> + if Debug.verbose () then Printf.printf "[cmt] Found incremental cmt\n"; + Some cmt_info + | None -> ( + match Hashtbl.find_opt package.paths_for_module module_name with + | Some paths -> + let cmt = get_cmt_path ~uri paths in + full_for_cmt ~module_name ~package ~uri cmt + | None -> + prerr_endline ("can't find module " ^ module_name); + None)) + +let fulls_from_module ~package ~module_name = + if Hashtbl.mem package.paths_for_module module_name then + let paths = Hashtbl.find package.paths_for_module module_name in + let uris = get_uris paths in + uris |> List.filter_map (fun uri -> full_from_uri ~uri) + else [] + +let load_full_cmt_from_path ~path = + let uri = Uri.from_path path in + full_from_uri ~uri + +let load_cmt_infos_from_path ~path = + let uri = Uri.from_path path in + match Packages.get_package ~uri with + | None -> None + | Some package -> ( + let module_name = + Build_system.namespaced_name package.namespace (Find_files.get_name path) + in + match Hashtbl.find_opt package.paths_for_module module_name with + | Some paths -> + let cmt = get_cmt_path ~uri paths in + Shared.try_read_cmt cmt + | None -> None) diff --git a/analysis/src/CmtViewer.ml b/analysis/src/cmt_viewer.ml similarity index 62% rename from analysis/src/CmtViewer.ml rename to analysis/src/cmt_viewer.ml index 99e71b95373..39bf9f544f8 100644 --- a/analysis/src/CmtViewer.ml +++ b/analysis/src/cmt_viewer.ml @@ -17,36 +17,38 @@ let filter_by_cursor cursor (loc : Warnings.loc) : bool = type filter = Cursor of (int * int) | Loc of Loc.t let dump ?filter rescript_json cmt_path = - let uri = Uri.fromPath (Filename.remove_extension cmt_path ^ ".res") in + let uri = Uri.from_path (Filename.remove_extension cmt_path ^ ".res") in let package = - let uri = Uri.fromPath rescript_json in - Packages.getPackage ~uri |> Option.get + let uri = Uri.from_path rescript_json in + Packages.get_package ~uri |> Option.get in - let moduleName = - BuildSystem.namespacedName package.namespace (FindFiles.getName cmt_path) + let module_name = + Build_system.namespaced_name package.namespace + (Find_files.get_name cmt_path) in - match Cmt.fullForCmt ~moduleName ~package ~uri cmt_path with + match Cmt.full_for_cmt ~module_name ~package ~uri cmt_path with | None -> failwith (Format.sprintf "Could not load cmt for %s" cmt_path) | Some full -> - let open SharedTypes in - let open SharedTypes.Stamps in - let applyFilter = + let open Shared_types in + let open Shared_types.Stamps in + let apply_filter = match filter with | None -> fun _ -> true - | Some (Cursor cursor) -> Loc.hasPos ~pos:cursor - | Some (Loc loc) -> Loc.isInside loc + | Some (Cursor cursor) -> Loc.has_pos ~pos:cursor + | Some (Loc loc) -> Loc.is_inside loc in (match filter with | None -> () | Some (Cursor (line, col)) -> Printf.printf "Filtering by cursor %d,%d\n" line col - | Some (Loc loc) -> Printf.printf "Filtering by loc %s\n" (Loc.toString loc)); + | Some (Loc loc) -> + Printf.printf "Filtering by loc %s\n" (Loc.to_string loc)); - Printf.printf "file moduleName: %s\n\n" full.file.moduleName; + Printf.printf "file moduleName: %s\n\n" full.file.module_name; let stamps = - full.file.stamps |> getEntries - |> List.filter (fun (_, stamp) -> applyFilter (locOfKind stamp)) + full.file.stamps |> get_entries + |> List.filter (fun (_, stamp) -> apply_filter (loc_of_kind stamp)) in let total_stamps = List.length stamps in @@ -55,25 +57,25 @@ let dump ?filter rescript_json cmt_path = stamps |> List.sort (fun (_, a) (_, b) -> - let aLoc = locOfKind a in - let bLoc = locOfKind b in - match compare aLoc.loc_start.pos_lnum bLoc.loc_start.pos_lnum with - | 0 -> compare aLoc.loc_start.pos_cnum bLoc.loc_start.pos_cnum + let a_loc = loc_of_kind a in + let b_loc = loc_of_kind b in + match compare a_loc.loc_start.pos_lnum b_loc.loc_start.pos_lnum with + | 0 -> compare a_loc.loc_start.pos_cnum b_loc.loc_start.pos_cnum | c -> c) |> List.iter (fun (stamp, kind) -> match kind with | KType t -> Printf.printf "%d ktype %s\n" stamp - (Warnings.loc_to_string t.extentLoc) + (Warnings.loc_to_string t.extent_loc) | KValue t -> Printf.printf "%d kvalue %s\n" stamp - (Warnings.loc_to_string t.extentLoc) + (Warnings.loc_to_string t.extent_loc) | KModule t -> Printf.printf "%d kmodule %s\n" stamp - (Warnings.loc_to_string t.extentLoc) + (Warnings.loc_to_string t.extent_loc) | KConstructor t -> Printf.printf "%d kconstructor %s\n" stamp - (Warnings.loc_to_string t.extentLoc)); + (Warnings.loc_to_string t.extent_loc)); (* dump the structure *) let rec dump_structure indent (structure : Module.structure) = @@ -106,23 +108,23 @@ let dump ?filter rescript_json cmt_path = dump_structure 0 full.file.structure; (* Dump all locItems (typed nodes) *) - let locItems = + let loc_items = match full.extra with - | {locItems} -> - locItems |> List.filter (fun locItem -> applyFilter locItem.loc) + | {loc_items} -> + loc_items |> List.filter (fun loc_item -> apply_filter loc_item.loc) in Printf.printf "\nFound %d locItems (typed nodes):\n\n" - (List.length locItems); + (List.length loc_items); - locItems + loc_items |> List.sort (fun a b -> - let aLoc = a.loc.Location.loc_start in - let bLoc = b.loc.Location.loc_start in - match compare aLoc.pos_lnum bLoc.pos_lnum with - | 0 -> compare aLoc.pos_cnum bLoc.pos_cnum + let a_loc = a.loc.Location.loc_start in + let b_loc = b.loc.Location.loc_start in + match compare a_loc.pos_lnum b_loc.pos_lnum with + | 0 -> compare a_loc.pos_cnum b_loc.pos_cnum | c -> c) - |> List.iter (fun {loc; locType} -> - let locStr = Warnings.loc_to_string loc in - let kindStr = SharedTypes.locTypeToString locType in - Printf.printf "%s %s\n" locStr kindStr) + |> List.iter (fun {loc; loc_type} -> + let loc_str = Warnings.loc_to_string loc in + let kind_str = Shared_types.loc_type_to_string loc_type in + Printf.printf "%s %s\n" loc_str kind_str) diff --git a/analysis/src/code_actions.ml b/analysis/src/code_actions.ml new file mode 100644 index 00000000000..c876bc7e52e --- /dev/null +++ b/analysis/src/code_actions.ml @@ -0,0 +1,28 @@ +(* This is the return that's expected when resolving code actions *) + +let make ~title ~kind ~uri ~new_text ~range = + let text_document = + Lsp.Types.OptionalVersionedTextDocumentIdentifier.create + ~uri:(Uri.from_string uri) () + in + let edit = + Lsp.Types.WorkspaceEdit.create + ~documentChanges: + [ + `TextDocumentEdit + (Lsp.Types.TextDocumentEdit.create + ~edits: + [ + `TextEdit (Lsp.Types.TextEdit.create ~range ~newText:new_text); + ] + ~textDocument:text_document); + ] + () + in + Lsp.Types.CodeAction.create ~title ~kind ~edit () + +let make_with_document_changes ~title ~kind ~document_changes = + let edit = + Lsp.Types.WorkspaceEdit.create ~documentChanges:document_changes () + in + Lsp.Types.CodeAction.create ~title ~kind ~edit () diff --git a/analysis/src/Codemod.ml b/analysis/src/codemod.ml similarity index 60% rename from analysis/src/Codemod.ml rename to analysis/src/codemod.ml index 970dfb79413..9b0812dd9a7 100644 --- a/analysis/src/Codemod.ml +++ b/analysis/src/codemod.ml @@ -1,47 +1,47 @@ -type transformType = AddMissingCases +type transform_type = AddMissingCases -let rec collectPatterns p = +let rec collect_patterns p = match p.Parsetree.ppat_desc with - | Ppat_or (p1, p2) -> collectPatterns p1 @ [p2] + | Ppat_or (p1, p2) -> collect_patterns p1 @ [p2] | _ -> [p] let transform ~source ~pos ~debug ~typ ~hint = - let structure, printExpr, _, _ = Xform.parseImplementation ~source in + let structure, print_expr, _, _ = Xform.parse_implementation ~source in match typ with | AddMissingCases -> ( let source = "let " ^ hint ^ " = ()" in - let {Res_driver.parsetree = hintStructure} = + let {Res_driver.parsetree = hint_structure} = Res_driver.parse_implementation_from_source ~for_printer:false ~display_filename:"" ~source in - match hintStructure with + match hint_structure with | [{pstr_desc = Pstr_value (_, [{pvb_pat = pattern}])}] -> ( let cases = - collectPatterns pattern + collect_patterns pattern |> List.map (fun (p : Parsetree.pattern) -> - Ast_helper.Exp.case p (TypeUtils.Codegen.mkFailWithExp ())) + Ast_helper.Exp.case p (Type_utils.Codegen.mk_fail_with_exp ())) in let result = ref None in - let mkIterator ~pos ~result = + let mk_iterator ~pos ~result = let expr (iterator : Ast_iterator.iterator) (exp : Parsetree.expression) = match exp.pexp_desc with - | Pexp_match (e, existingCases) - when Pos.ofLexing exp.pexp_loc.loc_start = pos -> + | Pexp_match (e, existing_cases) + when Pos.of_lexing exp.pexp_loc.loc_start = pos -> result := - Some {exp with pexp_desc = Pexp_match (e, existingCases @ cases)} + Some {exp with pexp_desc = Pexp_match (e, existing_cases @ cases)} | _ -> Ast_iterator.default_iterator.expr iterator exp in {Ast_iterator.default_iterator with expr} in - let iterator = mkIterator ~pos ~result in + let iterator = mk_iterator ~pos ~result in iterator.structure iterator structure; match !result with | None -> if debug then print_endline "Found no result"; exit 1 - | Some switchExpr -> - printExpr ~range:(Loc.rangeOfLoc switchExpr.pexp_loc) switchExpr) + | Some switch_expr -> + print_expr ~range:(Loc.range_of_loc switch_expr.pexp_loc) switch_expr) | _ -> if debug then print_endline "Mismatch in expected structure"; exit 1) diff --git a/analysis/src/commands.ml b/analysis/src/commands.ml new file mode 100644 index 00000000000..be6c0a83c46 --- /dev/null +++ b/analysis/src/commands.ml @@ -0,0 +1,324 @@ +let completion ~debug ~source ~kind_file ~pos ~full = + match + Completions.get_completions ~debug ~source ~kind_file ~pos ~full + ~for_hover:false + with + | None -> [] + | Some (completions, full, _) -> + completions |> List.map (Completion_back_end.completion_to_item ~full) + +let completion_resolve ~(full : Shared_types.full option) ~module_path = + (* We ignore the internal module path as of now because there's currently + no use case for it. But, if we wanted to move resolving documentation + for regular modules and not just file modules to the completionResolve + hook as well, it'd be easy to implement here. *) + let module_name, _innerModulePath = + match module_path |> String.split_on_char '.' with + | [module_name] -> (module_name, []) + | module_name :: rest -> (module_name, rest) + | [] -> raise (Failure "Invalid module path.") + in + let docstring = + match full with + | None -> + if Debug.verbose () then + Printf.printf "[completion_resolve] Could not load cmt\n"; + None + | Some full -> ( + match Process_cmt.file_for_module ~package:full.package module_name with + | None -> + if Debug.verbose () then + Printf.printf "[completion_resolve] Did not find file for module %s\n" + module_name; + None + | Some file -> Some (file.structure.docstring |> String.concat "\n\n")) + in + match docstring with + | None -> None + | Some value -> + Some + (`MarkupContent + (Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown + ~value)) + +let hover ~source ~kind_file ~pos ~supports_markdown_links ~full ~debug = + let result = + match full with + | None -> None + | Some full -> ( + match References.get_loc_item ~full ~pos ~debug with + | None -> ( + if debug then + Printf.printf + "Nothing at that position. Now trying to use completion.\n"; + match + Hover.get_hover_via_completions ~debug ~source ~kind_file ~pos + ~for_hover:true ~supports_markdown_links ~full:(Some full) + with + | None -> None + | Some hover -> Some hover) + | Some loc_item -> + let is_module = + match loc_item.loc_type with + | LModule _ | TopLevelModule _ -> true + | TypeDefinition _ | Typed _ | Constant _ -> false + in + let uri_loc_opt = References.definition_for_loc_item ~full loc_item in + let skip_zero = + match uri_loc_opt with + | None -> false + | Some (_, loc) -> + let is_interface = full.file.uri |> Uri.is_interface in + let pos_is_zero {Lexing.pos_lnum; pos_bol; pos_cnum} = + (not is_interface) && pos_lnum = 1 && pos_cnum - pos_bol = 0 + in + (* Skip if range is all zero, unless it's a module *) + (not is_module) && pos_is_zero loc.loc_start + && pos_is_zero loc.loc_end + in + if skip_zero then None + else Hover.new_hover ~supports_markdown_links ~full loc_item) + in + match result with + | None -> None + | Some value -> + Some + (Lsp.Types.Hover.create + ~contents: + (`MarkupContent + (Lsp.Types.MarkupContent.create + ~kind:Lsp.Types.MarkupKind.Markdown ~value)) + ()) + +let signature_help ~source ~kind_file ~pos ~allow_for_constructor_payloads ~full + ~debug = + Signature_help.signature_help ~debug ~source ~kind_file ~pos + ~allow_for_constructor_payloads ~full + +let definition ~full ~pos ~debug = + let location_opt = + match full with + | None -> None + | Some full -> ( + match References.get_loc_item ~full ~pos ~debug with + | None -> None + | Some loc_item -> ( + match References.definition_for_loc_item ~full loc_item with + | None -> None + | Some (uri, loc) when not loc.loc_ghost -> + let is_interface = full.file.uri |> Uri.is_interface in + let pos_is_zero {Lexing.pos_lnum; pos_bol; pos_cnum} = + (* range is zero *) + pos_lnum = 1 && pos_cnum - pos_bol = 0 + in + let is_module = + match loc_item.loc_type with + | LModule _ | TopLevelModule _ -> true + | TypeDefinition _ | Typed _ | Constant _ -> false + in + let skip_loc = + (not is_module) && (not is_interface) && pos_is_zero loc.loc_start + && pos_is_zero loc.loc_end + in + if skip_loc then None + else + Some + (Lsp.Types.Location.create + ~range:(Utils.cmt_loc_to_range loc) + ~uri:(Files.canonicalize_uri uri |> Uri.from_string)) + | Some _ -> None)) + in + location_opt + +let type_definition ~full ~pos ~debug = + let maybe_location = + match full with + | None -> None + | Some full -> ( + match References.get_loc_item ~full ~pos ~debug with + | None -> None + | Some loc_item -> ( + match References.type_definition_for_loc_item ~full loc_item with + | None -> None + | Some (uri, loc) -> + Some + (Lsp.Types.Location.create + ~range:(Utils.cmt_loc_to_range loc) + ~uri:(Files.canonicalize_uri uri |> Uri.from_string)))) + in + maybe_location + +let references ~full ~pos ~debug = + let all_locs = + match full with + | None -> [] + | Some full -> ( + match References.get_loc_item ~full ~pos ~debug with + | None -> [] + | Some loc_item -> + let all_references = + References.all_references_for_loc_item ~full loc_item + in + all_references + |> List.fold_left + (fun acc {References.uri = uri2; loc_opt} -> + let loc = + match loc_opt with + | Some loc -> loc + | None -> Uri.to_top_level_loc uri2 + in + + Lsp.Types.Location.create + ~range:(Utils.cmt_loc_to_range loc) + ~uri:(Uri.to_string uri2 |> Uri.from_string) + :: acc) + []) + in + all_locs + +let rename ~full ~pos ~new_name ~debug = + let result = + match full with + | None -> None + | Some full -> ( + match References.get_loc_item ~full ~pos ~debug with + | None -> None + | Some loc_item -> + let all_references = + References.all_references_for_loc_item ~full loc_item + in + let references_to_toplevel_modules = + all_references + |> Utils.filter_map (fun {References.uri = uri2; loc_opt} -> + if loc_opt = None then Some uri2 else None) + in + let references_to_items = + all_references + |> Utils.filter_map (function + | {References.uri = uri2; loc_opt = Some loc} -> Some (uri2, loc) + | {loc_opt = None} -> None) + in + let file_renames = + references_to_toplevel_modules + |> List.map (fun uri -> + let path = Uri.to_path uri in + let dir = + match Filename.dirname path with + | "." -> "" + | other -> other + in + let new_path = + Filename.concat dir (new_name ^ Filename.extension path) + in + `RenameFile + (Lsp.Types.RenameFile.create + ~newUri: + (new_path |> Uri.from_path |> Uri.to_string + |> Uri.from_path) + ~oldUri:(uri |> Uri.to_string |> Uri.from_string) + ())) + in + let text_document_edits = + let module String_map = Misc.String_map in + let text_edits_by_uri = + references_to_items + |> List.map (fun (uri, loc) -> (Uri.to_string uri, loc)) + |> List.fold_left + (fun acc (uri, loc) -> + let text_edit = + `TextEdit + (Lsp.Types.TextEdit.create ~newText:new_name + ~range:(Utils.cmt_loc_to_range loc)) + in + match String_map.find_opt uri acc with + | None -> String_map.add uri [text_edit] acc + | Some prev_edits -> + String_map.add uri (text_edit :: prev_edits) acc) + String_map.empty + in + String_map.fold + (fun uri edits acc -> + let text_document = + Lsp.Types.OptionalVersionedTextDocumentIdentifier.create + ~version:0 ~uri:(Uri.from_string uri) () + in + let text_document_edit = + `TextDocumentEdit + (Lsp.Types.TextDocumentEdit.create ~edits + ~textDocument:text_document) + in + text_document_edit :: acc) + text_edits_by_uri [] + in + let document_changes = file_renames @ text_document_edits in + Some + (Lsp.Types.WorkspaceEdit.create ~documentChanges:document_changes ())) + in + result + +type prepare_rename_result = { + range: Lsp.Types.Range.t; + placeholder: string option; +} + +let prepare_rename ~full ~pos ~debug = + match full with + | None -> None + | Some full -> ( + match References.get_loc_item ~full ~pos ~debug with + | None -> None + | Some loc_item -> + let range = Utils.cmt_loc_to_range loc_item.loc in + let placeholder_opt = + match loc_item.loc_type with + | Typed (name, _, _) | TopLevelModule name | TypeDefinition (name, _, _) + -> + Some name + | _ -> None + in + Some {range; placeholder = placeholder_opt}) + +let format ~source ~kind_file = + let create_range text = + let lines = text |> String.split_on_char '\n' in + let lines_len = List.length lines in + let character = + match List.nth_opt lines lines_len with + | Some line -> String.length line + | None -> 0 + in + let range = + Lsp.Types.Range.create + ~start:(Lsp.Types.Position.create ~line:0 ~character:0) + ~end_:(Lsp.Types.Position.create ~line:(lines_len - 1) ~character) + in + Lsp.Types.TextEdit.create ~newText:text ~range + in + + let result = + match kind_file with + | Files.Res -> ( + let {Res_driver.parsetree = structure; comments; diagnostics} = + Res_driver.parsing_engine.parse_implementation_from_source + ~for_printer:true ~source + in + match List.length diagnostics > 0 with + | true -> Error "Document has syntax errors" + | false -> + Ok (Res_printer.print_implementation ~comments structure |> create_range) + ) + | Resi -> ( + let {Res_driver.parsetree = signature; comments; diagnostics} = + Res_driver.parsing_engine.parse_interface_from_source ~for_printer:true + ~source + in + match List.length diagnostics > 0 with + | true -> Error "Document has syntax errors" + | false -> + Ok (Res_printer.print_interface ~comments signature |> create_range)) + | Other -> Error "Failed to format, file not supported" + in + + match result with + | Ok text_edit -> Ok [text_edit] + | Error e -> Error e diff --git a/analysis/src/completion_back_end.ml b/analysis/src/completion_back_end.ml new file mode 100644 index 00000000000..66524705675 --- /dev/null +++ b/analysis/src/completion_back_end.ml @@ -0,0 +1,2537 @@ +open Shared_types + +let show_constructor {Constructor.cname = {txt}; args; res} = + txt + ^ (match args with + | Args [] -> "" + | InlineRecord fields -> + "({" + ^ (fields + |> List.map (fun (field : field) -> + Printf.sprintf "%s%s: %s" field.fname.txt + (if field.optional then "?" else "") + (Shared.type_to_string + (if field.optional then Utils.unwrap_if_option field.typ + else field.typ))) + |> String.concat ", ") + ^ "})" + | Args args -> + "(" + ^ (args + |> List.map (fun (typ, _) -> typ |> Shared.type_to_string) + |> String.concat ", ") + ^ ")") + ^ + match res with + | None -> "" + | Some typ -> "\n" ^ (typ |> Shared.type_to_string) + +(* TODO: local opens *) +let resolve_opens ~env opens ~package = + List.fold_left + (fun previous path -> + (* Finding an open, first trying to find it in previoulsly resolved opens *) + let rec loop prev = + match prev with + | [] -> ( + match path with + | [] | [_] -> previous + | name :: path -> ( + match Process_cmt.file_for_module ~package name with + | None -> + Log.log ("Could not get module " ^ name); + previous (* TODO: warn? *) + | Some file -> ( + match + Resolve_path.resolve_path ~env:(Query_env.from_file file) + ~package ~path + with + | None -> + Log.log ("Could not resolve in " ^ name); + previous + | Some (env, _placeholder) -> previous @ [env]))) + | env :: rest -> ( + match Resolve_path.resolve_path ~env ~package ~path with + | None -> loop rest + | Some (env, _placeholder) -> previous @ [env]) + in + Log.log ("resolving open " ^ path_to_string path); + match Resolve_path.resolve_path ~env ~package ~path with + | None -> + Log.log "Not local"; + loop previous + | Some (env, _) -> + Log.log "Was local"; + previous @ [env]) + (* loop(previous) *) + [] opens + +let completion_for_exporteds iter_exported get_declared ~prefix ~exact ~env + ~names_used transform_contents = + let res = ref [] in + iter_exported (fun name stamp -> + (* Log.log("checking exported: " ++ name); *) + if Utils.check_name name ~prefix ~exact then + match get_declared stamp with + | Some (declared : _ Declared.t) + when not (Hashtbl.mem names_used declared.name.txt) -> + Hashtbl.add names_used declared.name.txt (); + res := + { + (Completion.create declared.name.txt ~env + ~kind:(transform_contents declared)) + with + deprecated = declared.deprecated; + docstring = declared.docstring; + } + :: !res + | _ -> ()); + !res + +let completion_for_exported_modules ~env ~prefix ~exact ~names_used = + completion_for_exporteds + (Exported.iter env.Query_env.exported Exported.Module) + (Stamps.find_module env.file.stamps) ~prefix ~exact ~env ~names_used + (fun declared -> + Completion.Module + {docstring = declared.docstring; module_ = declared.item}) + +let completion_for_exported_values ~env ~prefix ~exact ~names_used = + completion_for_exporteds (Exported.iter env.Query_env.exported Exported.Value) + (Stamps.find_value env.file.stamps) ~prefix ~exact ~env ~names_used + (fun declared -> Completion.Value declared.item) + +let completion_for_exported_types ~env ~prefix ~exact ~names_used = + completion_for_exporteds (Exported.iter env.Query_env.exported Exported.Type) + (Stamps.find_type env.file.stamps) ~prefix ~exact ~env ~names_used + (fun declared -> Completion.Type declared.item) + +let completions_for_exported_constructors ~(env : Query_env.t) ~prefix ~exact + ~names_used = + let res = ref [] in + Exported.iter env.exported Exported.Type (fun _name stamp -> + match Stamps.find_type env.file.stamps stamp with + | Some ({item = {kind = Type.Variant constructors}} as t) -> + res := + (constructors + |> List.filter (fun c -> + Utils.check_name c.Constructor.cname.txt ~prefix ~exact) + |> Utils.filter_map (fun c -> + let name = c.Constructor.cname.txt in + if not (Hashtbl.mem names_used name) then + let () = Hashtbl.add names_used name () in + Some + (Completion.create name ~env ~docstring:c.docstring + ?deprecated:c.deprecated + ~kind: + (Completion.Constructor + (c, t.item.decl |> Shared.decl_to_string t.name.txt))) + else None)) + @ !res + | _ -> ()); + !res + +let completion_for_exported_fields ~(env : Query_env.t) ~prefix ~exact + ~names_used = + let res = ref [] in + Exported.iter env.exported Exported.Type (fun _name stamp -> + match Stamps.find_type env.file.stamps stamp with + | Some ({item = {kind = Record fields}} as t) -> + res := + (fields + |> List.filter (fun f -> Utils.check_name f.fname.txt ~prefix ~exact) + |> Utils.filter_map (fun f -> + let name = f.fname.txt in + if not (Hashtbl.mem names_used name) then + let () = Hashtbl.add names_used name () in + Some + (Completion.create name ~env ~docstring:f.docstring + ?deprecated:f.deprecated + ~kind: + (Completion.Field + (f, t.item.decl |> Shared.decl_to_string t.name.txt))) + else None)) + @ !res + | _ -> ()); + !res + +let find_module_in_scope ~env ~module_name ~scope = + let modules_table = Hashtbl.create 10 in + env.Query_env.file.stamps + |> Stamps.iter_modules (fun _ declared -> + Hashtbl.replace modules_table + (declared.name.txt, declared.extent_loc |> Loc.start) + declared); + let result = ref None in + let process_module name loc = + if name = module_name && !result = None then + match Hashtbl.find_opt modules_table (name, Loc.start loc) with + | Some declared -> result := Some declared + | None -> + Log.log + (Printf.sprintf "Module Not Found %s loc:%s\n" name + (Loc.to_string loc)) + in + scope |> Scope.iter_modules_before_first_open process_module; + scope |> Scope.iter_modules_after_first_open process_module; + !result + +let rec module_item_to_structure_env ~(env : Query_env.t) ~package + (item : Module.t) = + match item with + | Module.Structure structure -> Some (env, structure) + | Module.Constraint (_, module_type) -> + module_item_to_structure_env ~env ~package module_type + | Module.Ident p -> ( + match Resolve_path.resolve_module_from_compiler_path ~env ~package p with + | Some (env2, Some declared2) -> + module_item_to_structure_env ~env:env2 ~package declared2.item + | _ -> None) + +(* Given a declared module, return the env entered into its concrete structure + and the structure itself. Follows constraints and aliases *) +let enter_structure_from_declared ~(env : Query_env.t) ~package + (declared : Module.t Declared.t) = + match module_item_to_structure_env ~env ~package declared.item with + | Some (env, s) -> Some (Query_env.enter_structure env s, s) + | None -> None + +let completions_from_structure_items ~(env : Query_env.t) + (structure : Module.structure) = + Structure_utils.unique_items structure + |> List.filter_map (fun (it : Module.item) -> + match it.kind with + | Module.Value typ -> + Some + (Completion.create ~env ~docstring:it.docstring + ~kind:(Completion.Value typ) it.name) + | Module.Module {type_ = m} -> + Some + (Completion.create ~env ~docstring:it.docstring + ~kind: + (Completion.Module {docstring = it.docstring; module_ = m}) + it.name) + | Module.Type (t, _recStatus) -> + Some + (Completion.create ~env ~docstring:it.docstring + ~kind:(Completion.Type t) it.name)) + +let resolve_path_from_stamps ~(env : Query_env.t) ~package ~scope ~module_name + ~path = + (* Log.log("Finding from stamps " ++ name); *) + match find_module_in_scope ~env ~module_name ~scope with + | None -> None + | Some declared -> ( + (* Log.log("found it"); *) + (* [""] means completion after `ModuleName.` (trailing dot). *) + match path with + | [""] -> ( + match module_item_to_structure_env ~env ~package declared.item with + | Some (env, structure) -> + Some (Query_env.enter_structure env structure, "") + | None -> None) + | _ -> ( + match Resolve_path.find_in_module ~env declared.item path with + | None -> None + | Some res -> ( + match res with + | `Local (env, name) -> Some (env, name) + | `Global (module_name, full_path) -> ( + match Process_cmt.file_for_module ~package module_name with + | None -> None + | Some file -> + Resolve_path.resolve_path ~env:(Query_env.from_file file) + ~path:full_path ~package)))) + +let resolve_module_with_opens ~opens ~package ~module_name = + let rec loop opens = + match opens with + | (env : Query_env.t) :: rest -> ( + Log.log ("Looking for env in " ^ Uri.to_string env.file.uri); + match Resolve_path.resolve_path ~env ~package ~path:[module_name; ""] with + | Some (env, _) -> Some env + | None -> loop rest) + | [] -> None + in + loop opens + +let resolve_file_module ~module_name ~package = + Log.log ("Getting module " ^ module_name); + match Process_cmt.file_for_module ~package module_name with + | None -> None + | Some file -> + Log.log "got it"; + let env = Query_env.from_file file in + Some env + +let get_env_with_opens ~scope ~(env : Query_env.t) ~package + ~(opens : Query_env.t list) ~module_name (path : string list) = + (* TODO: handle interleaving of opens and local modules correctly *) + match resolve_path_from_stamps ~env ~scope ~module_name ~path ~package with + | Some x -> Some x + | None -> ( + let env_opt = + match resolve_module_with_opens ~opens ~package ~module_name with + | Some env_opens -> Some env_opens + | None -> resolve_file_module ~module_name ~package + in + match env_opt with + | None -> None + | Some env -> ( + match path with + | [""] -> Some (env, "") + | _ -> Resolve_path.resolve_path ~env ~package ~path)) + +let rec expand_type_expr ~env ~package type_expr = + match type_expr |> Shared.dig_constructor with + | Some path -> ( + match References.dig_constructor ~env ~package path with + | None -> None + | Some (env, {item = {decl = {type_manifest = Some t}}}) -> + expand_type_expr ~env ~package t + | Some (_, {docstring; item}) -> Some (docstring, item)) + | None -> None + +let kind_to_documentation ~env ~full ~current_docstring name + (kind : Completion.kind) = + let docs_from_kind = + match kind with + | ObjLabel _ | Label _ | FileModule _ | Snippet _ | FollowContextPath _ -> + [] + | Module {docstring} -> docstring + | Type {decl; name} -> + [decl |> Shared.decl_to_string name |> Markdown.code_block] + | Value typ -> ( + match expand_type_expr ~env ~package:full.package typ with + | None -> [] + | Some (docstrings, {decl; name; kind}) -> + docstrings + @ [ + (match kind with + | Record _ | Tuple _ | Variant _ -> + Markdown.code_block (Shared.decl_to_string name decl) + | _ -> ""); + ]) + | Field ({typ; optional; docstring}, s) -> + (* Handle optional fields. Checking for "?" is because sometimes optional + fields are prefixed with "?" when completing, and at that point we don't + need to _also_ add a "?" after the field name, as that looks weird. *) + docstring + @ [ + Markdown.code_block + (if optional && Utils.starts_with name "?" = false then + name ^ "?: " + ^ (typ |> Utils.unwrap_if_option |> Shared.type_to_string) + else name ^ ": " ^ (typ |> Shared.type_to_string)); + Markdown.code_block s; + ] + | Constructor (c, s) -> + [Markdown.code_block (show_constructor c); Markdown.code_block s] + | PolyvariantConstructor ({display_name; args}, s) -> + [ + Markdown.code_block + ("#" ^ display_name + ^ + match args with + | [] -> "" + | type_exprs -> + "(" + ^ (type_exprs + |> List.map (fun type_expr -> type_expr |> Shared.type_to_string) + |> String.concat ", ") + ^ ")"); + Markdown.code_block s; + ] + | ExtractedType (extracted_type, _) -> + [Markdown.code_block (Type_utils.extracted_type_to_string extracted_type)] + in + current_docstring @ docs_from_kind + |> List.filter (fun s -> s <> "") + |> String.concat "\n\n" + +let kind_to_detail name (kind : Completion.kind) = + match kind with + | Type {name} -> "type " ^ name + | Value typ -> typ |> Shared.type_to_string + | ObjLabel typ -> typ |> Shared.type_to_string + | Label typ_string -> typ_string + | Module _ -> "module " ^ name + | FileModule f -> "module " ^ f + | Field ({typ; optional}, _) -> + (* Handle optional fields. Checking for "?" is because sometimes optional + fields are prefixed with "?" when completing, and at that point we don't + need to _also_ add a "?" after the field name, as that looks weird. *) + if optional && Utils.starts_with name "?" = false then + typ |> Utils.unwrap_if_option |> Shared.type_to_string + else typ |> Shared.type_to_string + | Constructor (c, _) -> show_constructor c + | PolyvariantConstructor ({display_name; args}, _) -> ( + "#" ^ display_name + ^ + match args with + | [] -> "" + | type_exprs -> + "(" + ^ (type_exprs + |> List.map (fun type_expr -> type_expr |> Shared.type_to_string) + |> String.concat ", ") + ^ ")") + | Snippet s -> s + | FollowContextPath _ -> "" + | ExtractedType (extracted_type, _) -> + Type_utils.extracted_type_to_string ~name_only:true extracted_type + +let kind_to_data file_path (kind : Completion.kind) = + match kind with + | FileModule f -> + Some (`Assoc [("modulePath", `String f); ("filePath", `String file_path)]) + | _ -> Some `Null + +let find_all_completions ~(env : Query_env.t) ~prefix ~exact ~names_used + ~(completion_context : Completable.completion_context) = + Log.log ("findAllCompletions uri:" ^ Uri.to_string env.file.uri); + match completion_context with + | Value -> + completion_for_exported_values ~env ~prefix ~exact ~names_used + @ completions_for_exported_constructors ~env ~prefix ~exact ~names_used + @ completion_for_exported_modules ~env ~prefix ~exact ~names_used + | Type -> + completion_for_exported_types ~env ~prefix ~exact ~names_used + @ completion_for_exported_modules ~env ~prefix ~exact ~names_used + | Module -> completion_for_exported_modules ~env ~prefix ~exact ~names_used + | Field -> + completion_for_exported_fields ~env ~prefix ~exact ~names_used + @ completion_for_exported_modules ~env ~prefix ~exact ~names_used + | ValueOrField -> + completion_for_exported_values ~env ~prefix ~exact ~names_used + @ completion_for_exported_fields ~env ~prefix ~exact ~names_used + @ completion_for_exported_modules ~env ~prefix ~exact ~names_used + +let process_local_value name loc context_path scope ~prefix ~exact ~env + ~(local_tables : Local_tables.t) = + if Utils.check_name name ~prefix ~exact then + match Hashtbl.find_opt local_tables.value_table (name, Loc.start loc) with + | Some declared -> + if not (Hashtbl.mem local_tables.names_used name) then ( + Hashtbl.add local_tables.names_used name (); + local_tables.result_rev <- + { + (Completion.create declared.name.txt ~env ~kind:(Value declared.item)) + with + deprecated = declared.deprecated; + docstring = declared.docstring; + } + :: local_tables.result_rev) + | None -> + if !Cfg.debug_follow_ctx_path then + Printf.printf "Completion Value Not Found %s loc:%s\n" name + (Loc.to_string loc); + local_tables.result_rev <- + Completion.create name ~env + ~kind: + (match context_path with + | Some context_path -> FollowContextPath (context_path, scope) + | None -> + Value + (Ctype.newconstr + (Path.Pident (Ident.create "Type Not Known")) + [])) + :: local_tables.result_rev + +let process_local_constructor name loc ~prefix ~exact ~env + ~(local_tables : Local_tables.t) = + if Utils.check_name name ~prefix ~exact then + match + Hashtbl.find_opt local_tables.constructor_table (name, Loc.start loc) + with + | Some declared -> + if not (Hashtbl.mem local_tables.names_used name) then ( + Hashtbl.add local_tables.names_used name (); + local_tables.result_rev <- + { + (Completion.create declared.name.txt ~env + ~kind: + (Constructor + ( declared.item, + snd declared.item.type_decl + |> Shared.decl_to_string (fst declared.item.type_decl) ))) + with + deprecated = declared.deprecated; + docstring = declared.docstring; + } + :: local_tables.result_rev) + | None -> + Log.log + (Printf.sprintf "Completion Constructor Not Found %s loc:%s\n" name + (Loc.to_string loc)) + +let process_local_type name loc ~prefix ~exact ~env + ~(local_tables : Local_tables.t) = + if Utils.check_name name ~prefix ~exact then + match Hashtbl.find_opt local_tables.types_table (name, Loc.start loc) with + | Some declared -> + if not (Hashtbl.mem local_tables.names_used name) then ( + Hashtbl.add local_tables.names_used name (); + local_tables.result_rev <- + { + (Completion.create declared.name.txt ~env ~kind:(Type declared.item)) + with + deprecated = declared.deprecated; + docstring = declared.docstring; + } + :: local_tables.result_rev) + | None -> + Log.log + (Printf.sprintf "Completion Type Not Found %s loc:%s\n" name + (Loc.to_string loc)) + +let process_local_module name loc ~prefix ~exact ~env + ~(local_tables : Local_tables.t) = + if Utils.check_name name ~prefix ~exact then + match Hashtbl.find_opt local_tables.modules_table (name, Loc.start loc) with + | Some declared -> + if not (Hashtbl.mem local_tables.names_used name) then ( + Hashtbl.add local_tables.names_used name (); + local_tables.result_rev <- + { + (Completion.create declared.name.txt ~env + ~kind: + (Module + {docstring = declared.docstring; module_ = declared.item})) + with + deprecated = declared.deprecated; + docstring = declared.docstring; + } + :: local_tables.result_rev) + | None -> + Log.log + (Printf.sprintf "Completion Module Not Found %s loc:%s\n" name + (Loc.to_string loc)) + +let process_local_include include_path _loc ~prefix ~exact ~(env : Query_env.t) + ~(local_tables : Local_tables.t) = + (* process only values for now *) + local_tables.included_value_table + |> Hashtbl.iter + (fun (name, _) (declared : (string * Types.type_expr) Declared.t) -> + (* We check all the values if their origin is the same as the include path. *) + let source_module_path = fst declared.item in + if String.ends_with ~suffix:include_path source_module_path then + (* If this is the case we perform a similar check for the prefix *) + if Utils.check_name name ~prefix ~exact then + if not (Hashtbl.mem local_tables.names_used name) then ( + Hashtbl.add local_tables.names_used name (); + local_tables.result_rev <- + { + (Completion.create declared.name.txt ~env + ~kind:(Value (snd declared.item))) + with + deprecated = declared.deprecated; + docstring = declared.docstring; + synthetic = true; + } + :: local_tables.result_rev)) + +let get_items_from_opens ~opens ~local_tables ~prefix ~exact ~completion_context + = + opens + |> List.fold_left + (fun results env -> + let completions_from_this_open = + find_all_completions ~env ~prefix ~exact + ~names_used:local_tables.Local_tables.names_used + ~completion_context + in + completions_from_this_open @ results) + [] + +let find_local_completions_for_values_and_constructors + ~(local_tables : Local_tables.t) ~env ~prefix ~exact ~opens ~scope = + local_tables |> Local_tables.populate_values ~env; + local_tables |> Local_tables.populate_included_values ~env; + local_tables |> Local_tables.populate_constructors ~env; + local_tables |> Local_tables.populate_modules ~env; + + scope + |> Scope.iter_values_before_first_open + (process_local_value ~prefix ~exact ~env ~local_tables); + scope + |> Scope.iter_constructors_before_first_open + (process_local_constructor ~prefix ~exact ~env ~local_tables); + scope + |> Scope.iter_modules_before_first_open + (process_local_module ~prefix ~exact ~env ~local_tables); + + let values_from_opens = + get_items_from_opens ~opens ~local_tables ~prefix ~exact + ~completion_context:Value + in + + scope + |> Scope.iter_values_after_first_open + (process_local_value ~prefix ~exact ~env ~local_tables); + scope + |> Scope.iter_constructors_after_first_open + (process_local_constructor ~prefix ~exact ~env ~local_tables); + scope + |> Scope.iter_modules_after_first_open + (process_local_module ~prefix ~exact ~env ~local_tables); + + scope + |> Scope.iter_includes + (process_local_include ~prefix ~exact ~env ~local_tables); + + List.rev_append local_tables.result_rev values_from_opens + +let find_local_completions_for_values ~(local_tables : Local_tables.t) ~env + ~prefix ~exact ~opens ~scope = + local_tables |> Local_tables.populate_values ~env; + local_tables |> Local_tables.populate_included_values ~env; + local_tables |> Local_tables.populate_modules ~env; + scope + |> Scope.iter_values_before_first_open + (process_local_value ~prefix ~exact ~env ~local_tables); + scope + |> Scope.iter_modules_before_first_open + (process_local_module ~prefix ~exact ~env ~local_tables); + + let values_from_opens = + get_items_from_opens ~opens ~local_tables ~prefix ~exact + ~completion_context:Value + in + + scope + |> Scope.iter_values_after_first_open + (process_local_value ~prefix ~exact ~env ~local_tables); + scope + |> Scope.iter_modules_after_first_open + (process_local_module ~prefix ~exact ~env ~local_tables); + + scope + |> Scope.iter_includes + (process_local_include ~prefix ~exact ~env ~local_tables); + + List.rev_append local_tables.result_rev values_from_opens + +let find_local_completions_for_types ~(local_tables : Local_tables.t) ~env + ~prefix ~exact ~opens ~scope = + local_tables |> Local_tables.populate_types ~env; + local_tables |> Local_tables.populate_modules ~env; + scope + |> Scope.iter_types_before_first_open + (process_local_type ~prefix ~exact ~env ~local_tables); + scope + |> Scope.iter_modules_before_first_open + (process_local_module ~prefix ~exact ~env ~local_tables); + + let values_from_opens = + get_items_from_opens ~opens ~local_tables ~prefix ~exact + ~completion_context:Type + in + + scope + |> Scope.iter_types_after_first_open + (process_local_type ~prefix ~exact ~env ~local_tables); + scope + |> Scope.iter_modules_after_first_open + (process_local_module ~prefix ~exact ~env ~local_tables); + List.rev_append local_tables.result_rev values_from_opens + +let find_local_completions_for_modules ~(local_tables : Local_tables.t) ~env + ~prefix ~exact ~opens ~scope = + local_tables |> Local_tables.populate_modules ~env; + scope + |> Scope.iter_modules_before_first_open + (process_local_module ~prefix ~exact ~env ~local_tables); + + let values_from_opens = + get_items_from_opens ~opens ~local_tables ~prefix ~exact + ~completion_context:Module + in + + scope + |> Scope.iter_modules_after_first_open + (process_local_module ~prefix ~exact ~env ~local_tables); + List.rev_append local_tables.result_rev values_from_opens + +let find_local_completions_with_opens ~pos ~(env : Query_env.t) ~prefix ~exact + ~opens ~scope ~(completion_context : Completable.completion_context) = + (* TODO: handle arbitrary interleaving of opens and local bindings correctly *) + Log.log + ("findLocalCompletionsWithOpens uri:" ^ Uri.to_string env.file.uri ^ " pos:" + ^ Pos.to_string pos); + let local_tables = Local_tables.create () in + match completion_context with + | Value | ValueOrField -> + find_local_completions_for_values_and_constructors ~local_tables ~env + ~prefix ~exact ~opens ~scope + | Type -> + find_local_completions_for_types ~local_tables ~env ~prefix ~exact ~opens + ~scope + | Module -> + find_local_completions_for_modules ~local_tables ~env ~prefix ~exact ~opens + ~scope + | Field -> + (* There's no local completion for fields *) + [] + +let get_complementary_completions_for_typed_value ~opens ~all_files ~scope ~env + prefix = + let exact = false in + let local_completions_with_opens = + let local_tables = Local_tables.create () in + find_local_completions_for_values ~local_tables ~env ~prefix ~exact ~opens + ~scope + in + let file_modules = + all_files |> File_set.elements + |> Utils.filter_map (fun name -> + if + Utils.check_name name ~prefix ~exact + && not + (* TODO complete the namespaced name too *) + (Utils.file_name_has_unallowed_chars name) + then + Some + (Completion.create name ~synthetic:true ~env + ~kind:(Completion.FileModule name)) + else None) + in + local_completions_with_opens @ file_modules + +let get_completions_for_path ~debug ~opens ~full ~pos ~exact ~scope + ~completion_context ~env path = + if debug then Printf.printf "Path %s\n" (path |> String.concat "."); + let all_files = all_files_in_package full.package in + match path with + | [] -> [] + | [prefix] -> + let local_completions_with_opens = + find_local_completions_with_opens ~pos ~env ~prefix ~exact ~opens ~scope + ~completion_context + in + let file_modules = + all_files |> File_set.elements + |> Utils.filter_map (fun name -> + if + Utils.check_name name ~prefix ~exact + && not + (* TODO complete the namespaced name too *) + (Utils.file_name_has_unallowed_chars name) + then + Some + (Completion.create name ~env ~kind:(Completion.FileModule name)) + else None) + in + local_completions_with_opens @ file_modules + | module_name :: path -> ( + Log.log ("Path " ^ path_to_string path); + (* [""] is trailing dot completion (`ModuleName.`). *) + match path with + | [""] -> ( + let env_file = env in + let declared_opt = + match find_module_in_scope ~env:env_file ~module_name ~scope with + | Some d -> Some d + | None -> ( + match Exported.find env_file.exported Exported.Module module_name with + | Some stamp -> Stamps.find_module env_file.file.stamps stamp + | None -> None) + in + match declared_opt with + | Some (declared : Module.t Declared.t) when declared.is_exported = false + -> ( + match + enter_structure_from_declared ~env:env_file ~package:full.package + declared + with + | None -> [] + | Some (env_in_module, structure) -> + completions_from_structure_items ~env:env_in_module structure) + | _ -> ( + match + get_env_with_opens ~scope ~env ~package:full.package ~opens + ~module_name path + with + | Some (env, prefix) -> + Log.log "Got the env"; + let names_used = Hashtbl.create 10 in + find_all_completions ~env ~prefix ~exact ~names_used + ~completion_context + | None -> [])) + | _ -> ( + match + get_env_with_opens ~scope ~env ~package:full.package ~opens ~module_name + path + with + | Some (env, prefix) -> + Log.log "Got the env"; + let names_used = Hashtbl.create 10 in + find_all_completions ~env ~prefix ~exact ~names_used ~completion_context + | None -> [])) + +(** Completions intended for piping, from a completion path. *) +let completions_for_pipe_from_completion_path ~env_completion_is_made_from + ~opens ~pos ~scope ~debug ~prefix ~env ~raw_opens ~full completion_path = + let completion_path_without_current_module = + Type_utils.remove_current_module_if_needed ~env_completion_is_made_from + completion_path + in + let completion_path_minus_opens = + Type_utils.remove_opens_from_completion_path ~raw_opens + ~package:full.package completion_path_without_current_module + |> String.concat "." + in + let completion_name name = + if completion_path_minus_opens = "" then name + else completion_path_minus_opens ^ "." ^ name + in + let completions = + completion_path @ [prefix] + |> get_completions_for_path ~debug ~completion_context:Value ~exact:false + ~opens ~full ~pos ~env ~scope + in + let completions = + completions + |> List.map (fun (completion : Completion.t) -> + {completion with name = completion_name completion.name}) + in + completions + +let rec dig_to_record_fields_for_completion ~debug ~package ~opens ~full ~pos + ~env ~scope path = + match + path + |> get_completions_for_path ~debug ~completion_context:Type ~exact:true + ~opens ~full ~pos ~env ~scope + with + | {kind = Type {kind = Abstract (Some (p, _))}} :: _ -> + (* This case happens when what we're looking for is a type alias. + This is the case in newer rescript-react versions where + ReactDOM.domProps is an alias for JsxEvent.t. *) + let path_rev = p |> Utils.expand_path in + path_rev |> List.rev + |> dig_to_record_fields_for_completion ~debug ~package ~opens ~full ~pos + ~env ~scope + | {kind = Type {kind = Record fields}} :: _ -> Some fields + | _ -> None + +let mk_item ?data ?additional_text_edits name ~kind ~detail ~deprecated + ~docstring = + let doc_content = + (match deprecated with + | None -> "" + | Some s -> "Deprecated: " ^ s ^ "\n\n") + ^ + match docstring with + | [] -> "" + | _ :: _ -> docstring |> String.concat "\n" + in + let tags = + match deprecated with + | None -> [] + | Some _ -> [Lsp.Types.CompletionItemTag.Deprecated (* deprecated *)] + in + + let documentation = + match String.length doc_content > 0 with + | true -> + Some + (`MarkupContent + (Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown + ~value:doc_content)) + | false -> None + in + + let deprecated = if Option.is_some deprecated then Some true else None in + let data = + match data with + | Some `Null | None -> None + | Some other -> Some other + in + + Lsp.Types.CompletionItem.create ~label:name ~kind ~tags ~detail ?documentation + ?deprecated ?data ?additionalTextEdits:additional_text_edits ?sortText:None + ?insertText:None ?insertTextFormat:None ?filterText:None () + +let completion_to_item + { + Completion.name; + deprecated; + docstring; + kind; + sort_text; + insert_text; + insert_text_format; + filter_text; + detail; + env; + additional_text_edits; + } ~full = + let item = + mk_item name ?additional_text_edits + ?data:(kind_to_data (full.file.uri |> Uri.to_path) kind) + ~kind:(Completion.kind_to_lsp_completion_item kind) + ~deprecated + ~detail: + (match detail with + | None -> kind_to_detail name kind + | Some detail -> detail) + ~docstring: + (match + kind_to_documentation ~current_docstring:docstring ~full ~env name + kind + with + | "" -> [] + | docstring -> [docstring]) + in + { + item with + sortText = sort_text; + insertText = insert_text; + insertTextFormat = insert_text_format; + filterText = filter_text; + } + +let completions_get_type_env = function + | {Completion.kind = Value typ; env} :: _ -> Some (typ, env) + | {Completion.kind = ObjLabel typ; env} :: _ -> Some (typ, env) + | {Completion.kind = Field ({typ}, _); env} :: _ -> Some (typ, env) + | _ -> None + +type get_completions_for_context_path_mode = Regular | Pipe + +let completions_get_completion_type ~full completions = + let first_non_synthetic_completion = + List.find_opt (fun c -> not c.Completion.synthetic) completions + in + match first_non_synthetic_completion with + | Some {Completion.kind = Value typ; env} + | Some {Completion.kind = ObjLabel typ; env} + | Some {Completion.kind = Field ({typ}, _); env} -> + typ + |> Type_utils.extract_type ~env ~package:full.package + |> Option.map (fun (typ, _) -> (typ, env)) + | Some {Completion.kind = Type typ; env} -> ( + match Type_utils.extract_type_from_resolved_type typ ~env ~full with + | None -> None + | Some extracted_type -> Some (extracted_type, env)) + | Some {Completion.kind = ExtractedType (typ, _); env} -> Some (typ, env) + | _ -> None + +let rec completions_get_completion_type2 ~debug ~full ~opens ~raw_opens ~pos + completions = + let first_non_synthetic_completion = + List.find_opt (fun c -> not c.Completion.synthetic) completions + in + match first_non_synthetic_completion with + | Some + ( {Completion.kind = Value typ; env} + | {Completion.kind = ObjLabel typ; env} + | {Completion.kind = Field ({typ}, _); env} ) -> + Some (TypeExpr typ, env) + | Some {Completion.kind = FollowContextPath (ctx_path, scope); env} -> + ctx_path + |> get_completions_for_context_path ~debug ~full ~env ~exact:true ~opens + ~raw_opens ~pos ~scope + |> completions_get_completion_type2 ~debug ~full ~opens ~raw_opens ~pos + | Some {Completion.kind = Type typ; env} -> ( + match Type_utils.extract_type_from_resolved_type typ ~env ~full with + | None -> None + | Some extracted_type -> Some (ExtractedType extracted_type, env)) + | Some {Completion.kind = ExtractedType (typ, _); env} -> + Some (ExtractedType typ, env) + | _ -> None + +and completions_get_type_env2 ~debug (completions : Completion.t list) ~full + ~opens ~raw_opens ~pos = + let first_non_synthetic_completion = + List.find_opt (fun c -> not c.Completion.synthetic) completions + in + match first_non_synthetic_completion with + | Some {Completion.kind = Value typ; env} -> Some (typ, env) + | Some {Completion.kind = ObjLabel typ; env} -> Some (typ, env) + | Some {Completion.kind = Field ({typ}, _); env} -> Some (typ, env) + | Some {Completion.kind = FollowContextPath (ctx_path, scope); env} -> + ctx_path + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env + ~exact:true ~scope + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~pos + | _ -> None + +and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env + ~exact ~scope ?(mode = Regular) context_path = + let env_completion_is_made_from = env in + if debug then + Printf.printf "ContextPath %s\n" + (Completable.context_path_to_string context_path); + let package = full.package in + match context_path with + | CPString -> + if Debug.verbose () then print_endline "[ctx_path]--> CPString"; + [Completion.create "dummy" ~env ~kind:(Completion.Value Predef.type_string)] + | CPBool -> + if Debug.verbose () then print_endline "[ctx_path]--> CPBool"; + [Completion.create "dummy" ~env ~kind:(Completion.Value Predef.type_bool)] + | CPInt -> + if Debug.verbose () then print_endline "[ctx_path]--> CPInt"; + [Completion.create "dummy" ~env ~kind:(Completion.Value Predef.type_int)] + | CPFloat -> + if Debug.verbose () then print_endline "[ctx_path]--> CPFloat"; + [Completion.create "dummy" ~env ~kind:(Completion.Value Predef.type_float)] + | CPArray None -> + if Debug.verbose () then print_endline "[ctx_path]--> CPArray (no payload)"; + [ + Completion.create "array" ~env + ~kind:(Completion.Value (Ctype.newconstr Predef.path_array [])); + ] + | CPArray (Some cp) -> ( + if Debug.verbose () then + print_endline "[ctx_path]--> CPArray (with payload)"; + match mode with + | Regular -> ( + match + cp + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope + |> completions_get_completion_type ~full + with + | None -> [] + | Some (typ, env) -> + [ + Completion.create "dummy" ~env + ~kind: + (Completion.ExtractedType (Tarray (env, ExtractedType typ), `Type)); + ]) + | Pipe -> + (* Pipe completion with array just needs to know that it's an array, not + what inner type it has. *) + [ + Completion.create "dummy" ~env + ~kind:(Completion.Value (Ctype.newconstr Predef.path_array [])); + ]) + | CPOption cp -> ( + if Debug.verbose () then print_endline "[ctx_path]--> CPOption"; + match + cp + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope + |> completions_get_completion_type ~full + with + | None -> [] + | Some (typ, env) -> + [ + Completion.create "dummy" ~env + ~kind: + (Completion.ExtractedType (Toption (env, ExtractedType typ), `Type)); + ]) + | CPAwait cp -> ( + if Debug.verbose () then print_endline "[ctx_path]--> CPAwait"; + match + cp + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope + |> completions_get_completion_type ~full + with + | Some (Tpromise (env, typ), _env) -> + [Completion.create "dummy" ~env ~kind:(Completion.Value typ)] + | _ -> []) + | CPId {path; completion_context; loc} -> + if Debug.verbose () then print_endline "[ctx_path]--> CPId"; + (* Looks up the type of an identifier. + + Because of reasons we sometimes don't get enough type + information when looking up identifiers where the type + has type parameters. This in turn means less completions. + + There's a heuristic below that tries to look up the type + of the ID in the usual way first. But if the type found + still has uninstantiated type parameters, we check the + location for the identifier from the compiler type artifacts. + That type usually has the type params instantiated, if they are. + This leads to better completion. + + However, we only do it in incremental type checking mode, + because more type information is always available in that mode. *) + let use_tvar_lookup = !Cfg.in_incremental_typechecking_mode in + let by_path = + path + |> get_completions_for_path ~debug ~opens ~full ~pos ~exact + ~completion_context ~env ~scope + in + let has_tvars = + if use_tvar_lookup then + match by_path with + | [{kind = Value typ}] when Type_utils.has_tvar typ -> true + | _ -> false + else false + in + let result = + if has_tvars then + let by_loc = Type_utils.find_type_via_loc loc ~full ~debug in + match (by_loc, by_path) with + | Some t, [({kind = Value _} as item)] -> [{item with kind = Value t}] + | _ -> by_path + else by_path + in + result + | CPApply (cp, labels) -> ( + if Debug.verbose () then print_endline "[ctx_path]--> CPApply"; + match + cp + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope + |> completions_get_completion_type2 ~debug ~full ~opens ~raw_opens ~pos + with + | Some ((TypeExpr typ | ExtractedType (Tfunction {typ})), env) -> ( + let rec reconstruct_function_type args t_ret = + match args with + | [] -> t_ret + | (label, t_arg) :: rest -> + let rest_type = reconstruct_function_type rest t_ret in + { + typ with + desc = Tarrow ({lbl = label; typ = t_arg}, rest_type, Cok, None); + } + in + let rec process_apply args labels = + match (args, labels) with + | _, [] -> args + | _, label :: (_ :: _ as next_labels) -> + (* compute the application of the first label, then the next ones *) + let args = process_apply args [label] in + process_apply args next_labels + | (Asttypes.Nolabel, _) :: next_args, [Asttypes.Nolabel] -> next_args + | ((Labelled _, _) as arg) :: next_args, [Nolabel] -> + arg :: process_apply next_args labels + | (Optional _, _) :: next_args, [Nolabel] -> + process_apply next_args labels + | ( (((Labelled {txt = s1} | Optional {txt = s1}), _) as arg) + :: next_args, + [(Labelled {txt = s2} | Optional {txt = s2})] ) -> + if s1 = s2 then next_args else arg :: process_apply next_args labels + | ((Nolabel, _) as arg) :: next_args, [(Labelled _ | Optional _)] -> + arg :: process_apply next_args labels + | [], [(Nolabel | Labelled _ | Optional _)] -> + (* should not happen, but just ignore extra arguments *) [] + in + + match + Type_utils.extract_function_type ~env ~package ~dig_into:false typ + with + | args, t_ret when args <> [] -> + let args = process_apply args labels in + let ret_type = reconstruct_function_type args t_ret in + [Completion.create "dummy" ~env ~kind:(Completion.Value ret_type)] + | _ -> []) + | _ -> []) + | CPField + {context_path = CPId {path; completion_context = Module}; field_name} -> + if Debug.verbose () then print_endline "[ctx_path]--> CPField: M.field"; + (* M.field *) + path @ [field_name] + |> get_completions_for_path ~debug ~opens ~full ~pos ~exact + ~completion_context:Field ~env ~scope + | CPField {context_path = cp; field_name; pos_of_dot; expr_loc; in_jsx} -> ( + if Debug.verbose () then print_endline "[dot_completion]--> Triggered"; + let completions_from_ctx_path = + cp + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope + in + let main_type_completion_env = + completions_from_ctx_path + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~pos + in + match main_type_completion_env with + | None -> + if Debug.verbose () then + Printf.printf + "[dot_completion] Could not extract main type completion env.\n"; + [] + | Some (typ, env) -> + let field_completions = + Dot_completion_utils.field_completions_for_dot_completion typ ~env + ~package ~prefix:field_name ?pos_of_dot ~exact + in + (* Get additional completions acting as if this field completion was actually a pipe completion. *) + let cp_as_pipe_completion = + Completable.CPPipe + { + synthetic = true; + context_path = + (match cp with + | CPApply (c, args) -> CPApply (c, args @ [Asttypes.Nolabel]) + | CPId _ when Type_utils.is_function_type ~env ~package typ -> + CPApply (cp, [Asttypes.Nolabel]) + | _ -> cp); + id = field_name; + in_jsx; + lhs_loc = expr_loc; + } + in + let pipe_completions = + cp_as_pipe_completion + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env:env_completion_is_made_from ~exact ~scope + |> List.filter_map (fun c -> + Type_utils.transform_completion_to_pipe_completion + ~synthetic:true ~env ?pos_of_dot c) + in + field_completions @ pipe_completions) + | CPObj (cp, label) -> ( + (* TODO: Also needs to support ExtractedType *) + if Debug.verbose () then print_endline "[ctx_path]--> CPObj"; + match + cp + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~pos + with + | Some (typ, env) -> ( + match typ |> Type_utils.extract_object_type ~env ~package with + | Some (env, t_obj) -> + t_obj |> Type_utils.get_obj_fields + |> Utils.filter_map (fun (field, typ) -> + if Utils.check_name field ~prefix:label ~exact then + Some + (Completion.create field ~env ~kind:(Completion.ObjLabel typ)) + else None) + | None -> []) + | None -> []) + | CPPipe {context_path = cp; id = prefix; lhs_loc; in_jsx; synthetic} -> ( + if Debug.verbose () then print_endline "[ctx_path]--> CPPipe"; + (* The environment at the cursor is the environment we're completing from. *) + let env_at_cursor = env in + match + cp + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope ~mode:Pipe + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~pos + with + | None -> + if Debug.verbose () then + print_endline "[CPPipe]--> Could not resolve type env"; + [] + | Some (typ, env) -> ( + let env, typ = + typ + |> Type_utils.resolve_type_for_pipe_completion ~env + ~package:full.package ~full ~lhs_loc + in + let main_type_id = Type_utils.find_root_type_id ~full ~env typ in + let type_path = Type_utils.path_from_type_expr typ in + match main_type_id with + | None -> + if Debug.verbose () then + Printf.printf + "[pipe_completion] Could not find mainTypeId. Aborting pipe \ + completions.\n"; + [] + | Some main_type_id -> + if Debug.verbose () then + Printf.printf "[pipe_completion] mainTypeId: %s\n" main_type_id; + let pipe_completions = + (* We now need a completion path from where to look up the module for our dot completion type. + This is from where we pull all of the functions we want to complete for the pipe. + + A completion path here could be one of two things: + 1. A module path to the main module for the type we've found + 2. A module path to a builtin module, like `Int` for `int`, or `Array` for `array` + + The below code will deliberately _not_ dig into type aliases for the main type when we're looking + for what _module_ to complete from. This is because you should be able to control where completions + come from even if your type is an alias. + *) + let complete_as_builtin = + match type_path with + | Some t -> Type_utils.completion_path_from_maybe_builtin t + | None -> None + in + let completion_path = + match (complete_as_builtin, type_path) with + | Some completion_path_for_builtin, _ -> + Some (false, completion_path_for_builtin) + | _, Some p -> ( + (* If this isn't a builtin, but we have a path, we try to resolve the + module path relative to the env we're completing from. This ensures that + what we get here is a module path we can find completions for regardless of + of the current scope for the position we're at.*) + match + Type_utils.get_module_path_relative_to_env ~debug + ~env:env_completion_is_made_from ~env_from_item:env + (Utils.expand_path p) + with + | None -> Some (true, [env.file.module_name]) + | Some p -> Some (false, p)) + | _ -> None + in + match completion_path with + | None -> [] + | Some (is_from_current_module, completion_path) -> + completions_for_pipe_from_completion_path + ~env_completion_is_made_from ~opens ~pos ~scope ~debug ~prefix + ~env ~raw_opens ~full completion_path + |> Type_utils.filter_pipeable_functions ~env ~full ~synthetic + ~target_type_id:main_type_id + |> List.filter (fun (c : Completion.t) -> + (* If we're completing from the current module then we need to care about scope. + This is automatically taken care of in other cases. *) + if is_from_current_module then + match c.kind with + | Value _ -> + scope + |> List.find_opt (fun (item : Scope_types.item) -> + match item with + | Value (scope_item_name, _, _, _) -> + scope_item_name = c.name + | _ -> false) + |> Option.is_some + | _ -> false + else true) + in + + let globally_configured_completions_for_type = + match + package.autocomplete |> Misc.String_map.find_opt main_type_id + with + | None -> [] + | Some completion_paths -> + completion_paths |> List.map (fun p -> String.split_on_char '.' p) + in + + let globally_configured_completions = + globally_configured_completions_for_type + |> List.map (fun completion_path -> + completions_for_pipe_from_completion_path + ~env_completion_is_made_from ~opens ~pos ~scope ~debug + ~prefix ~env ~raw_opens ~full completion_path) + |> List.flatten + |> Type_utils.filter_pipeable_functions ~synthetic:true ~env ~full + ~target_type_id:main_type_id + in + + (* Extra completions can be drawn from the @editor.completeFrom attribute. Here we + find and add those completions as well. *) + let extra_completions = + Type_utils.get_extra_modules_to_complete_from_for_type ~env ~full typ + |> List.map (fun completion_path -> + completions_for_pipe_from_completion_path + ~env_completion_is_made_from ~opens ~pos ~scope ~debug + ~prefix ~env ~raw_opens ~full completion_path) + |> List.flatten + |> Type_utils.filter_pipeable_functions ~synthetic:true ~env ~full + ~target_type_id:main_type_id + in + (* Add JSX completion items if we're in a JSX context. *) + let jsx_completions = + if in_jsx then + Pipe_completion_utils.add_jsx_completion_items ~env ~main_type_id + ~prefix ~full ~raw_opens typ + else [] + in + (* Add completions from the current module. *) + let current_module_completions = + get_completions_for_path ~debug ~completion_context:Value ~exact:false + ~opens:[] ~full ~pos ~env:env_at_cursor ~scope [prefix] + |> Type_utils.filter_pipeable_functions ~synthetic:true ~env ~full + ~target_type_id:main_type_id + in + jsx_completions @ pipe_completions @ extra_completions + @ current_module_completions @ globally_configured_completions)) + | CTuple ctx_paths -> + if Debug.verbose () then print_endline "[ctx_path]--> CTuple"; + (* Turn a list of context paths into a list of type expressions. *) + let type_exrps = + ctx_paths + |> List.map (fun context_path -> + context_path + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens + ~pos ~env ~exact:true ~scope) + |> List.filter_map (fun completion_items -> + match completion_items with + | {Completion.kind = Value typ} :: _ -> Some typ + | _ -> None) + in + if List.length ctx_paths = List.length type_exrps then + [ + Completion.create "dummy" ~env + ~kind:(Completion.Value (Ctype.newty (Ttuple type_exrps))); + ] + else [] + | CJsxPropValue {path_to_component; prop_name; empty_jsx_prop_name_hint} -> ( + if Debug.verbose () then print_endline "[ctx_path]--> CJsxPropValue"; + let find_type_of_value path = + path + |> get_completions_for_path ~debug ~completion_context:Value ~exact:true + ~opens ~full ~pos ~env ~scope + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~pos + in + let lowercase_component = + match path_to_component with + | [el_name] when Char.lowercase_ascii el_name.[0] = el_name.[0] -> true + | _ -> false + in + (* TODO(env-stuff) Does this need to potentially be instantiated with type args too? *) + let labels = + if lowercase_component then + let rec dig_to_type_for_completion path = + match + path + |> get_completions_for_path ~debug ~completion_context:Type + ~exact:true ~opens ~full ~pos ~env ~scope + with + | {kind = Type {kind = Abstract (Some (p, _))}} :: _ -> + (* This case happens when what we're looking for is a type alias. + This is the case in newer rescript-react versions where + ReactDOM.domProps is an alias for JsxEvent.t. *) + let path_rev = p |> Utils.expand_path in + path_rev |> List.rev |> dig_to_type_for_completion + | {kind = Type {kind = Record fields}} :: _ -> + fields |> List.map (fun f -> (f.fname.txt, f.typ, env)) + | _ -> [] + in + Type_utils.path_to_element_props package |> dig_to_type_for_completion + else + Completion_jsx.get_jsx_labels ~component_path:path_to_component + ~find_type_of_value ~package + in + (* We have a heuristic that kicks in when completing empty prop expressions in the middle of a JSX element, + like third=123 />. + The parser turns that broken JSX into: third />, 123. + + So, we use a heuristic that covers this scenario by picking up on the cursor being between + the prop name and the prop expression, and the prop expression being an ident that's a + _valid prop name_ for that JSX element. + + This works because the ident itself will always be the next prop name (since that's what the + parser eats). So, we do a simple lookup of that hint here if it exists, to make sure the hint + is indeed a valid label for this JSX element. *) + let empty_jsx_prop_name_hint_is_correct = + match empty_jsx_prop_name_hint with + | Some ident_name when ident_name != prop_name -> + labels + |> List.find_opt (fun (f, _, _) -> f = ident_name) + |> Option.is_some + | Some _ -> false + | None -> true + in + let target_label = + if empty_jsx_prop_name_hint_is_correct then + labels |> List.find_opt (fun (f, _, _) -> f = prop_name) + else None + in + match target_label with + | None -> [] + | Some (_, typ, env) -> + [ + Completion.create "dummy" ~env + ~kind:(Completion.Value (Utils.unwrap_if_option typ)); + ]) + | CArgument {function_context_path; argument_label} -> ( + if Debug.verbose () then print_endline "[ctx_path]--> CArgument"; + if Debug.verbose () then + Printf.printf "--> function argument: %s\n" + (match argument_label with + | Labelled n | Optional n -> n + | Unlabelled {argument_position} -> + "$" ^ string_of_int argument_position); + + let labels, env = + match + function_context_path + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope + |> completions_get_completion_type2 ~debug ~full ~opens ~raw_opens ~pos + with + | Some ((TypeExpr typ | ExtractedType (Tfunction {typ})), env) -> + if Debug.verbose () then print_endline "--> found function type"; + (typ |> Type_utils.get_args ~full ~env, env) + | _ -> + if Debug.verbose () then + print_endline "--> could not find function type"; + ([], env) + in + let target_label = + labels + |> List.find_opt (fun (label, _) -> + match (argument_label, label) with + | ( Unlabelled {argument_position = pos1}, + Completable.Unlabelled {argument_position = pos2} ) -> + pos1 = pos2 + | ( (Labelled name1 | Optional name1), + (Labelled name2 | Optional name2) ) -> + name1 = name2 + | _ -> false) + in + let expand_option = + match target_label with + | None | Some ((Unlabelled _ | Labelled _), _) -> false + | Some (Optional _, _) -> true + in + match target_label with + | None -> + if Debug.verbose () then + print_endline "--> could not look up function argument"; + [] + | Some (_, typ) -> + if Debug.verbose () then print_endline "--> found function argument!"; + [ + Completion.create "dummy" ~env + ~kind: + (Completion.Value + (if expand_option then Utils.unwrap_if_option typ else typ)); + ]) + | CPatternPath {root_ctx_path; nested} -> ( + if Debug.verbose () then print_endline "[ctx_path]--> CPatternPath"; + (* TODO(env-stuff) Get rid of innerType etc *) + match + root_ctx_path + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope + |> completions_get_completion_type2 ~debug ~full ~opens ~raw_opens ~pos + with + | Some (typ, env) -> ( + match + typ |> Type_utils.resolve_nested_pattern_path ~env ~full ~nested + with + | Some (typ, env) -> + [Completion.create "dummy" ~env ~kind:(kind_from_inner_type typ)] + | None -> []) + | None -> []) + | CTypeAtPos loc -> ( + if Debug.verbose () then print_endline "[ctx_path]--> CTypeAtPos"; + match Type_utils.find_type_via_loc loc ~full ~debug with + | None -> [] + | Some typ_expr -> [Completion.create "dummy" ~env ~kind:(Value typ_expr)]) + +let get_opens ~debug ~raw_opens ~package ~env = + if debug && raw_opens <> [] then + Printf.printf "%s\n" + ("Raw opens: " + ^ string_of_int (List.length raw_opens) + ^ " " + ^ String.concat " ... " (raw_opens |> List.map path_to_string)); + let package_opens = package.opens in + if debug && package_opens <> [] then + Printf.printf "%s\n" + ("Package opens " + ^ String.concat " " + (package_opens |> List.map (fun p -> p |> path_to_string))); + let resolved_opens = + resolve_opens ~env (List.rev (raw_opens @ package_opens)) ~package + in + if debug && resolved_opens <> [] then + Printf.printf "%s\n" + ("Resolved opens " + ^ string_of_int (List.length resolved_opens) + ^ " " + ^ String.concat " " + (resolved_opens + |> List.map (fun (e : Query_env.t) -> e.file.module_name))); + (* Last open takes priority *) + List.rev resolved_opens + +let filter_items items ~prefix = + if prefix = "" then items + else + items + |> List.filter (fun (item : Completion.t) -> + Utils.starts_with item.name prefix) + +type completion_mode = Pattern of Completable.pattern_mode | Expression + +let empty_case ~mode num = + match mode with + | Expression -> "$" ^ string_of_int (num - 1) + | Pattern _ -> "${" ^ string_of_int num ^ ":_}" + +let print_constructor_args ~mode ~as_snippet args_len = + let args = ref [] in + for arg_num = 1 to args_len do + args := + !args + @ [ + (match (as_snippet, args_len) with + | true, l when l > 1 -> Printf.sprintf "${%i:_}" arg_num + | true, l when l > 0 -> empty_case ~mode arg_num + | _ -> "_"); + ] + done; + if List.length !args > 0 then "(" ^ (!args |> String.concat ", ") ^ ")" + else "" + +let rec complete_typed_value ?(type_arg_context : type_arg_context option) + ~raw_opens ~full ~prefix ~completion_context ~mode + (t : Shared_types.completion_type) = + let empty_case = empty_case ~mode in + let print_constructor_args = print_constructor_args ~mode in + let create = Completion.create ?type_arg_context in + let get_record_completions ~env ~fields ~extracted_type = + (* As we're completing for a record, we'll need a hint (completionContext) + here to figure out whether we should complete for a record field, or + the record body itself. *) + match completion_context with + | Some (Completable.RecordField {seen_fields}) -> + fields + |> List.filter (fun (field : field) -> + List.mem field.fname.txt seen_fields = false) + |> List.map (fun (field : field) -> + match (field.optional, mode) with + | true, Pattern Destructuring -> + create ("?" ^ field.fname.txt) ?deprecated:field.deprecated + ~docstring: + [ + field.fname.txt + ^ " is an optional field, and needs to be destructured \ + using '?'."; + ] + ~kind: + (Field + (field, Type_utils.extracted_type_to_string extracted_type)) + ~env + | _ -> + create field.fname.txt ?deprecated:field.deprecated + ~kind: + (Field + (field, Type_utils.extracted_type_to_string extracted_type)) + ~env) + |> filter_items ~prefix + | _ -> + if prefix = "" then + [ + create "{}" ~includes_snippets:true ~insert_text:"{$0}" ~sort_text:"A" + ~kind: + (ExtractedType + ( extracted_type, + match mode with + | Pattern _ -> `Type + | Expression -> `Value )) + ~env; + ] + else [] + in + match t with + | TtypeT {env; path} when mode = Expression -> + if Debug.verbose () then + print_endline "[complete_typed_value]--> TtypeT (Expression)"; + (* Find all values in the module with type t *) + let value_with_type_t t = + match t.Types.desc with + | Tconstr (Pident {name = "t"}, [], _) -> true + | _ -> false + in + (* Find all functions in the module that returns type t *) + let rec fn_returns_type_t t = + match t.Types.desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> fn_returns_type_t t1 + | Tarrow _ -> ( + match Type_utils.extract_function_type ~env ~package:full.package t with + | ( (Nolabel, {desc = Tconstr (Path.Pident {name = "t"}, _, _)}) :: _, + {desc = Tconstr (Path.Pident {name = "t"}, _, _)} ) -> + (* Filter out functions that take type t first. These are often + @send style functions that we don't want to have here because + they usually aren't meant to create a type t from scratch. *) + false + | _args, {desc = Tconstr (Path.Pident {name = "t"}, _, _)} -> true + | _ -> false) + | _ -> false + in + let get_completion_name exported_value_name = + let fn_nname = + Type_utils.get_module_path_relative_to_env ~debug:false + ~env:(Query_env.from_file full.file) + ~env_from_item:env (Utils.expand_path path) + in + match fn_nname with + | None -> None + | Some base -> + let base = + Type_utils.remove_opens_from_completion_path ~raw_opens + ~package:full.package base + in + Some ((base |> String.concat ".") ^ "." ^ exported_value_name) + in + let get_exported_value_completion name + (declared : Types.type_expr Declared.t) = + let type_expr = declared.item in + if value_with_type_t type_expr then + get_completion_name name + |> Option.map (fun name -> + create name ~includes_snippets:true ~insert_text:name + ~kind:(Value type_expr) ~env) + else if fn_returns_type_t type_expr then + get_completion_name name + |> Option.map (fun name -> + create + (Printf.sprintf "%s()" name) + ~includes_snippets:true ~insert_text:(name ^ "($0)") + ~kind:(Value type_expr) ~env) + else None + in + let completion_items = + Hashtbl.fold + (fun name stamp all -> + match Stamps.find_value env.file.stamps stamp with + | None -> all + | Some declared_type_expr -> ( + match get_exported_value_completion name declared_type_expr with + | None -> all + | Some completion -> completion :: all)) + env.exported.values_ [] + in + + (* Special casing for things where we want extra things in the completions *) + let completion_items = + match path with + | Pdot (Pdot (Pident {name = "Js"}, "Re", _), "t", _) + | Pdot (Pdot (Pident {name = "Stdlib"}, "RegExp", _), "t", _) + | Pdot (Pident {name = "RegExp"}, "t", _) -> + (* regexps *) + create "//g" ~insert_text:"/$0/g" ~includes_snippets:true + ~kind:(Label "Regular expression") ~env + :: completion_items + | _ -> completion_items + in + completion_items + | Tbool env -> + if Debug.verbose () then print_endline "[complete_typed_value]--> Tbool"; + [ + create "true" ~kind:(Label "bool") ~env; + create "false" ~kind:(Label "bool") ~env; + ] + |> filter_items ~prefix + | TtypeT {env; path} -> + if Debug.verbose () then + print_endline "[complete_typed_value]--> TtypeT (Pattern)"; + (* This is in patterns. Emit an alias/binding with the module name as a value name. *) + if prefix <> "" then [] + else + let module_name = + match path |> Utils.expand_path with + | _t :: module_name :: _rest -> String.uncapitalize_ascii module_name + | _ -> "value" + in + [ + create module_name ~kind:(Label module_name) ~env + ~insert_text:("${0:" ^ module_name ^ "}") + ~includes_snippets:true; + ] + | Tvariant {env; constructors; variant_decl; variant_name} -> + if Debug.verbose () then print_endline "[complete_typed_value]--> Tvariant"; + constructors + |> List.map (fun (constructor : Constructor.t) -> + let num_args = + match constructor.args with + | InlineRecord _ -> 1 + | Args args -> List.length args + in + create ?deprecated:constructor.deprecated ~includes_snippets:true + (constructor.cname.txt + ^ print_constructor_args num_args ~as_snippet:false) + ~insert_text: + (constructor.cname.txt + ^ print_constructor_args num_args ~as_snippet:true) + ~kind: + (Constructor + ( constructor, + variant_decl |> Shared.decl_to_string variant_name )) + ~env) + |> filter_items ~prefix + | Tpolyvariant {env; constructors; type_expr} -> + if Debug.verbose () then + print_endline "[complete_typed_value]--> Tpolyvariant"; + constructors + |> List.map (fun (constructor : poly_variant_constructor) -> + create + ("#" ^ constructor.display_name + ^ print_constructor_args + (List.length constructor.args) + ~as_snippet:false) + ~includes_snippets:true + ~insert_text: + ((if Utils.starts_with prefix "#" then "" else "#") + ^ constructor.display_name + ^ print_constructor_args + (List.length constructor.args) + ~as_snippet:true) + ~kind: + (PolyvariantConstructor + (constructor, type_expr |> Shared.type_to_string)) + ~env) + |> filter_items + ~prefix:(if Utils.starts_with prefix "#" then prefix else "#" ^ prefix) + | Toption (env, t) -> + if Debug.verbose () then print_endline "[complete_typed_value]--> Toption"; + let inner_type = + match t with + | ExtractedType t -> Some (t, None) + | TypeExpr t -> t |> Type_utils.extract_type ~env ~package:full.package + in + let expanded_completions = + match inner_type with + | None -> [] + | Some (inner_type, _typeArgsContext) -> + inner_type + |> complete_typed_value ~raw_opens ~full ~prefix ~completion_context + ~mode + |> List.map (fun (c : Completion.t) -> + { + c with + name = "Some(" ^ c.name ^ ")"; + sort_text = None; + insert_text = + (match c.insert_text with + | None -> None + | Some insert_text -> Some ("Some(" ^ insert_text ^ ")")); + }) + in + let none_case = + Completion.create "None" ~kind:(kind_from_inner_type t) ~env + in + let some_any_case = + create "Some(_)" ~includes_snippets:true ~kind:(kind_from_inner_type t) + ~env + ~insert_text:(Printf.sprintf "Some(%s)" (empty_case 1)) + in + let completions = + match completion_context with + | Some (Completable.CameFromRecordField field_name) -> + [ + create + ("Some(" ^ field_name ^ ")") + ~includes_snippets:true ~kind:(kind_from_inner_type t) ~env + ~insert_text:("Some(" ^ field_name ^ ")$0"); + some_any_case; + none_case; + ] + | _ -> [none_case; some_any_case] + in + completions @ expanded_completions |> filter_items ~prefix + | Tresult {env; ok_type; error_type} -> + if Debug.verbose () then print_endline "[complete_typed_value]--> Tresult"; + let ok_inner_type = + ok_type |> Type_utils.extract_type ~env ~package:full.package + in + let error_inner_type = + error_type |> Type_utils.extract_type ~env ~package:full.package + in + let expanded_ok_completions = + match ok_inner_type with + | None -> [] + | Some (inner_type, _) -> + inner_type + |> complete_typed_value ~raw_opens ~full ~prefix ~completion_context + ~mode + |> List.map (fun (c : Completion.t) -> + { + c with + name = "Ok(" ^ c.name ^ ")"; + sort_text = None; + insert_text = + (match c.insert_text with + | None -> None + | Some insert_text -> Some ("Ok(" ^ insert_text ^ ")")); + }) + in + let expanded_error_completions = + match error_inner_type with + | None -> [] + | Some (inner_type, _) -> + inner_type + |> complete_typed_value ~raw_opens ~full ~prefix ~completion_context + ~mode + |> List.map (fun (c : Completion.t) -> + { + c with + name = "Error(" ^ c.name ^ ")"; + sort_text = None; + insert_text = + (match c.insert_text with + | None -> None + | Some insert_text -> Some ("Error(" ^ insert_text ^ ")")); + }) + in + let ok_any_case = + create "Ok(_)" ~includes_snippets:true ~kind:(Value ok_type) ~env + ~insert_text:(Printf.sprintf "Ok(%s)" (empty_case 1)) + in + let error_any_case = + create "Error(_)" ~includes_snippets:true ~kind:(Value error_type) ~env + ~insert_text:(Printf.sprintf "Error(%s)" (empty_case 1)) + in + let completions = + match completion_context with + | Some (Completable.CameFromRecordField field_name) -> + [ + create + ("Ok(" ^ field_name ^ ")") + ~includes_snippets:true ~kind:(Value ok_type) ~env + ~insert_text:("Ok(" ^ field_name ^ ")$0"); + ok_any_case; + error_any_case; + ] + | _ -> [ok_any_case; error_any_case] + in + completions @ expanded_ok_completions @ expanded_error_completions + |> filter_items ~prefix + | Tuple (env, exprs, typ) -> + if Debug.verbose () then print_endline "[complete_typed_value]--> Tuple"; + let num_exprs = List.length exprs in + [ + create + (print_constructor_args num_exprs ~as_snippet:false) + ~includes_snippets:true + ~insert_text:(print_constructor_args num_exprs ~as_snippet:true) + ~kind:(Value typ) ~env; + ] + | Trecord {env; fields} as extracted_type -> + if Debug.verbose () then print_endline "[complete_typed_value]--> Trecord"; + get_record_completions ~env ~fields ~extracted_type + | TinlineRecord {env; fields} as extracted_type -> + if Debug.verbose () then + print_endline "[complete_typed_value]--> TinlineRecord"; + get_record_completions ~env ~fields ~extracted_type + | Tarray (env, typ) -> + if Debug.verbose () then print_endline "[complete_typed_value]--> Tarray"; + if prefix = "" then + [ + create "[]" ~includes_snippets:true ~insert_text:"[$0]" ~sort_text:"A" + ~kind: + (match typ with + | ExtractedType typ -> + ExtractedType + ( typ, + match mode with + | Pattern _ -> `Type + | Expression -> `Value ) + | TypeExpr typ -> Value typ) + ~env; + ] + else [] + | Tstring env -> + if Debug.verbose () then print_endline "[complete_typed_value]--> Tstring"; + if prefix = "" then + [ + create "\"\"" ~includes_snippets:true ~insert_text:"\"$0\"" + ~sort_text:"A" ~kind:(Value Predef.type_string) ~env; + ] + else [] + | Tfunction {env; typ; args; return_type} + when prefix = "" && mode = Expression -> + if Debug.verbose () then + print_endline "[complete_typed_value]--> Tfunction #1"; + let mk_fn_args ~as_snippet = + match args with + | [(Nolabel, arg_typ)] when Type_utils.type_is_unit arg_typ -> "()" + | [(Nolabel, arg_typ)] -> + let var_name = + Completion_expressions.pretty_print_fn_template_arg_name ~env ~full + arg_typ + in + if as_snippet then "${1:" ^ var_name ^ "}" else var_name + | _ -> + let current_unlabelled_index = ref 0 in + let args_text = + args + |> List.map (fun ((label, typ) : typed_fn_arg) -> + match label with + | Optional {txt = name} -> "~" ^ name ^ "=?" + | Labelled {txt = name} -> "~" ^ name + | Nolabel -> + if Type_utils.type_is_unit typ then "()" + else ( + current_unlabelled_index := !current_unlabelled_index + 1; + let num = !current_unlabelled_index in + let var_name = + Completion_expressions.pretty_print_fn_template_arg_name + ~current_index:num ~env ~full typ + in + if as_snippet then + "${" ^ string_of_int num ^ ":" ^ var_name ^ "}" + else var_name)) + |> String.concat ", " + in + "(" ^ args_text ^ ")" + in + let is_async = + match Type_utils.extract_type ~env ~package:full.package return_type with + | Some (Tpromise _, _) -> true + | _ -> false + in + let async_prefix = if is_async then "async " else "" in + let function_body, function_body_insert_text = + match args with + | [(Nolabel, arg_typ)] -> + let var_name = + Completion_expressions.pretty_print_fn_template_arg_name ~env ~full + arg_typ + in + ( (" => " ^ if var_name = "()" then "{}" else var_name), + " => ${0:" ^ var_name ^ "}" ) + | _ -> (" => {}", " => {${0:()}}") + in + [ + create + (async_prefix ^ mk_fn_args ~as_snippet:false ^ function_body) + ~includes_snippets:true + ~insert_text: + (async_prefix + ^ mk_fn_args ~as_snippet:true + ^ function_body_insert_text) + ~sort_text:"A" ~kind:(Value typ) ~env; + ] + | Tfunction _ -> + if Debug.verbose () then + print_endline "[complete_typed_value]--> Tfunction #other"; + [] + | Texn env -> + if Debug.verbose () then print_endline "[complete_typed_value]--> Texn"; + [ + create + (["Exn"; "Error(error)"] |> ident) + ~kind:(Label "Catches errors from JavaScript errors.") + ~docstring: + [ + "Matches on a JavaScript error. Read more in the [documentation on \ + catching JS \ + exceptions](https://rescript-lang.org/docs/manual/latest/exception#catching-js-exceptions)."; + ] + ~env; + ] + | Tpromise _ -> + if Debug.verbose () then print_endline "[complete_typed_value]--> Tpromise"; + [] + +module String_set = Set.Make (String) + +let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable + = + if debug then + Printf.printf "Completable: %s\n" (Completable.to_string completable); + let package = full.package in + let raw_opens = Scope.get_raw_opens scope in + let opens = get_opens ~debug ~raw_opens ~package ~env in + let all_files = all_files_in_package package in + let find_type_of_value path = + path + |> get_completions_for_path ~debug ~completion_context:Value ~exact:true + ~opens ~full ~pos ~env ~scope + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~pos + in + match completable with + | Cnone -> [] + | Cpath context_path -> + context_path + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env + ~exact:for_hover ~scope + | Cjsx ([id], prefix, idents_seen) when String.uncapitalize_ascii id = id -> ( + (* Lowercase JSX tag means builtin *) + let mk_label (name, typ_string) = + Completion.create name ~kind:(Label typ_string) ~env + in + let key_labels = + if Utils.starts_with "key" prefix then [mk_label ("key", "string")] + else [] + in + let path_to_element_props = Type_utils.path_to_element_props package in + if Debug.verbose () then + Printf.printf + "[completing-lowercase-jsx] Attempting to complete from type at %s\n" + (path_to_element_props |> String.concat "."); + let from_element_props = + match + path_to_element_props + |> dig_to_record_fields_for_completion ~debug ~package ~opens ~full ~pos + ~env ~scope + with + | None -> None + | Some fields -> + Some + (fields + |> List.filter_map (fun (f : field) -> + if + Utils.starts_with f.fname.txt prefix + && (for_hover || not (List.mem f.fname.txt idents_seen)) + then + Some + ( f.fname.txt, + Shared.type_to_string (Utils.unwrap_if_option f.typ) ) + else None) + |> List.map mk_label) + in + match from_element_props with + | Some element_props -> element_props + | None -> + if debug then + Printf.printf + "[completing-lowercase-jsx] could not find element props to complete \ + from.\n"; + key_labels) + | Cjsx (component_path, prefix, idents_seen) -> + let labels = + Completion_jsx.get_jsx_labels ~component_path ~find_type_of_value ~package + in + let mkLabel_ name typ_string = + Completion.create name ~kind:(Label typ_string) ~env + in + let mk_label (name, typ, _env) = + mkLabel_ name (typ |> Shared.type_to_string) + in + let key_labels = + if Utils.starts_with "key" prefix then [mkLabel_ "key" "string"] else [] + in + if labels = [] then [] + else + (labels + |> List.filter (fun (name, _t, _env) -> + Utils.starts_with name prefix + && name <> "key" + && (for_hover || not (List.mem name idents_seen))) + |> List.map mk_label) + @ key_labels + | CdecoratorPayload (JsxConfig {prefix; nested}) -> ( + let mk_field ~name ~primitive = + { + stamp = -1; + fname = {loc = Location.none; txt = name}; + optional = true; + typ = Ctype.newconstr primitive []; + docstring = []; + deprecated = None; + } + in + let typ : completion_type = + Trecord + { + env; + definition = `NameOnly "jsxConfig"; + fields = + [ + mk_field ~name:"version" ~primitive:Predef.path_int; + mk_field ~name:"module_" ~primitive:Predef.path_string; + mk_field ~name:"mode" ~primitive:Predef.path_string; + ]; + } + in + match typ |> Type_utils.resolve_nested ~env ~full ~nested with + | None -> [] + | Some (typ, _env, completion_context, type_arg_context) -> + typ + |> complete_typed_value ?type_arg_context ~raw_opens ~mode:Expression + ~full ~prefix ~completion_context) + | CdecoratorPayload (ModuleWithImportAttributes {prefix; nested}) -> ( + let mk_field ~name ~primitive = + { + stamp = -1; + fname = {loc = Location.none; txt = name}; + optional = true; + typ = Ctype.newconstr primitive []; + docstring = []; + deprecated = None; + } + in + let import_attributes_config : completion_type = + Trecord + { + env; + definition = `NameOnly "importAttributesConfig"; + fields = [mk_field ~name:"type_" ~primitive:Predef.path_string]; + } + in + let root_config : completion_type = + Trecord + { + env; + definition = `NameOnly "moduleConfig"; + fields = + [ + mk_field ~name:"from" ~primitive:Predef.path_string; + mk_field ~name:"with" ~primitive:Predef.path_string; + ]; + } + in + let nested, typ = + match nested with + | NFollowRecordField {field_name = "with"} :: rest -> + (rest, import_attributes_config) + | _ -> (nested, root_config) + in + match typ |> Type_utils.resolve_nested ~env ~full ~nested with + | None -> [] + | Some (typ, _env, completion_context, type_arg_context) -> + typ + |> complete_typed_value ?type_arg_context ~raw_opens ~mode:Expression + ~full ~prefix ~completion_context) + | CdecoratorPayload (Module prefix) -> + let package_json_path = + Utils.find_package_json (full.package.root_path |> Uri.from_path) + in + let items_from_package_json = + match package_json_path with + | None -> + if debug then + Printf.printf + "Did not find package.json, started looking (going upwards) from: %s\n" + full.package.root_path; + [] + | Some path -> ( + match Files.read_file path with + | None -> + if debug then print_endline "Could not read package.json"; + [] + | Some s -> ( + match Yojson_helpers.from_string_opt s with + | Some (`Assoc items) -> + items + |> List.filter_map (fun (key, t) -> + match (key, t) with + | ("dependencies" | "devDependencies"), `Assoc o -> + Some + (o + |> List.filter_map (fun (pkg_name, _) -> + match pkg_name with + | "rescript" -> None + | pkg_name -> Some pkg_name)) + | _ -> None) + |> List.flatten + | _ -> + if debug then print_endline "Could not parse package.json"; + [])) + in + (* TODO: Resolve relatives? *) + let local_items = + try + let files = + Sys.readdir (Filename.dirname (env.file.uri |> Uri.to_path)) + |> Array.to_list + in + (* Filter out generated build artifacts from in-source builds. *) + let res_files = + String_set.of_list + (files + |> List.filter_map (fun f -> + if Filename.extension f = ".res" then + Some (try Filename.chop_extension f with _ -> f) + else None)) + in + let is_internal_artifact_extension = function + | ".ast" | ".cmi" | ".cmj" | ".cmt" | ".cmti" | ".iast" -> true + | _ -> false + in + files + |> List.filter_map (fun file_name -> + let without_extension = + try Filename.chop_extension file_name with _ -> file_name + in + if + String.ends_with file_name ~suffix:package.suffix + && res_files |> String_set.mem without_extension + then None + else + match Filename.extension file_name with + | ".res" | ".resi" | "" -> None + | ext when is_internal_artifact_extension ext -> None + | _ -> Some ("./" ^ file_name)) + |> List.sort String.compare + with _ -> + if debug then print_endline "Could not read relative directory"; + [] + in + let items = items_from_package_json @ local_items in + items + |> List.filter (fun name -> Utils.starts_with name prefix) + |> List.map (fun name -> + let is_local = Utils.starts_with name "./" in + Completion.create name + ~kind:(Label (if is_local then "Local file" else "Package")) + ~env) + | Cdecorator prefix -> + let mk_decorator (name, docstring, maybe_insert_text) = + { + (Completion.create name ~synthetic:true ~includes_snippets:true + ~kind:(Label "") ~env ?insert_text:maybe_insert_text) + with + docstring; + } + in + let is_top_level = String.starts_with ~prefix:"@" prefix in + let prefix = + if is_top_level then String.sub prefix 1 (String.length prefix - 1) + else prefix + in + let decorators = + if is_top_level then Completion_decorators.toplevel + else Completion_decorators.local + in + decorators + |> List.filter (fun (decorator, _, _) -> Utils.starts_with decorator prefix) + |> List.map (fun (decorator, maybe_insert_text, doc) -> + let parts = String.split_on_char '.' prefix in + let len = String.length prefix in + let dec2 = + if List.length parts > 1 then + String.sub decorator len (String.length decorator - len) + else decorator + in + (dec2, doc, maybe_insert_text)) + |> List.map mk_decorator + | CnamedArg (cp, prefix, idents_seen) -> + let labels = + match + cp + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~pos + with + | Some (typ, _env) -> + if debug then + Printf.printf "Found type for function %s\n" + (typ |> Shared.type_to_string); + + typ + |> Type_utils.get_args ~full ~env + |> List.filter_map (fun arg -> + match arg with + | Shared_types.Completable.Labelled name, a -> Some (name, a) + | Optional name, a -> Some (name, a) + | _ -> None) + | None -> [] + in + let mk_label (name, typ) = + Completion.create name ~kind:(Label (typ |> Shared.type_to_string)) ~env + in + labels + |> List.filter (fun (name, _t) -> + Utils.starts_with name prefix + && (for_hover || not (List.mem name idents_seen))) + |> List.map mk_label + | Cpattern {context_path; prefix; nested; fallback; pattern_mode} -> ( + let fallback_or_empty ?items () = + match (fallback, items) with + | Some fallback, (None | Some []) -> + fallback |> process_completable ~debug ~full ~scope ~env ~pos ~for_hover + | _, Some items -> items + | None, None -> [] + in + match + context_path + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~pos + with + | Some (typ, env) -> ( + match + typ + |> Type_utils.extract_type ~env ~package:full.package + |> Utils.Option.flat_map (fun (typ, type_arg_context) -> + typ + |> Type_utils.resolve_nested ?type_arg_context ~env ~full ~nested) + with + | None -> fallback_or_empty () + | Some (typ, _env, completion_context, type_arg_context) -> + let items = + typ + |> complete_typed_value ?type_arg_context ~raw_opens + ~mode:(Pattern pattern_mode) ~full ~prefix ~completion_context + in + fallback_or_empty ~items ()) + | None -> fallback_or_empty ()) + | Cexpression {context_path; prefix; nested} -> ( + let is_ambigious_record_body_or_jsx_wrap = + match (context_path, nested) with + | CJsxPropValue _, [NRecordBody _] -> true + | _ -> false + in + if Debug.verbose () then + (* This happens in this scenario: `}` + Here, we don't know whether `{}` is just wraps for the type of + `someProp`, or if it's a record body where we want to complete + for the fields in the record. We need to look up what the type is + first before deciding what completions to show. So we do that here.*) + if is_ambigious_record_body_or_jsx_wrap then + print_endline + "[process_completable]--> Cexpression special case: JSX prop value \ + that might be record body or JSX wrap" + else print_endline "[process_completable]--> Cexpression"; + (* Completions for local things like variables in scope, modules in the + project, etc. We only add completions when there's a prefix of some sort + we can filter on, since we know we're in some sort of context, and + therefore don't want to overwhelm the user with completion items. *) + let regular_completions = + if prefix = "" then [] + else + prefix + |> get_complementary_completions_for_typed_value ~opens ~all_files ~env + ~scope + in + match + context_path + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope + |> completions_get_completion_type ~full + with + | None -> + if Debug.verbose () then + print_endline + "[process_completable]--> could not get completions for context path"; + regular_completions + | Some (typ, env) -> ( + match typ |> Type_utils.resolve_nested ~env ~full ~nested with + | None -> + if Debug.verbose () then + print_endline + "[process_completable]--> could not resolve nested expression path"; + if is_ambigious_record_body_or_jsx_wrap then ( + if Debug.verbose () then + print_endline + "[process_completable]--> case is ambigious Jsx prop vs record \ + body case, complete also for the JSX prop value directly"; + let items_for_raw_jsx_prop_value = + typ + |> complete_typed_value ~raw_opens ~mode:Expression ~full ~prefix + ~completion_context:None + in + items_for_raw_jsx_prop_value @ regular_completions) + else regular_completions + | Some (typ, _env, completion_context, type_arg_context) -> ( + if Debug.verbose () then + print_endline + "[process_completable]--> found type in nested expression \ + completion"; + (* Wrap the insert text in braces when we're completing the root of a + JSX prop value. *) + let wrap_insert_text_in_braces = + if List.length nested > 0 then false + else + match context_path with + | CJsxPropValue _ -> true + | _ -> false + in + let items = + typ + |> complete_typed_value ?type_arg_context ~raw_opens ~mode:Expression + ~full ~prefix ~completion_context + |> List.map (fun (c : Completion.t) -> + if wrap_insert_text_in_braces then + { + c with + insert_text = + (match c.insert_text with + | None -> None + | Some text -> Some ("{" ^ text ^ "}")); + } + else c) + in + match (prefix, completion_context) with + | "", _ -> items + | _, None -> + let items = + if List.length regular_completions > 0 then + (* The client will occasionally sort the list of completions alphabetically, disregarding the order + in which we send it. This fixes that by providing a sort text making the typed completions + guaranteed to end up on top. *) + items + |> List.map (fun (c : Completion.t) -> + {c with sort_text = Some ("A" ^ " " ^ c.name)}) + else items + in + items @ regular_completions + | _ -> items))) + | CexhaustiveSwitch {context_path; expr_loc} -> + let range = Utils.range_of_loc expr_loc in + let print_failwith_str num = "${" ^ string_of_int num ^ ":%todo}" in + let with_exhaustive_item ~cases ?(start_index = 0) (c : Completion.t) = + (* We don't need to write out `switch` here since we know that's what the + user has already written. Just complete for the rest. *) + let new_text = + c.name ^ " {\n" + ^ (cases + |> List.mapi (fun index case_text -> + "| " ^ case_text ^ " => " + ^ print_failwith_str (start_index + index + 1)) + |> String.concat "\n") + ^ "\n}" + |> Utils.indent range.start.character + in + [ + c; + { + c with + name = c.name ^ " (exhaustive switch)"; + filter_text = Some c.name; + insert_text_format = Some Snippet; + insert_text = Some new_text; + kind = Snippet "insert exhaustive switch for value"; + }; + ] + in + let completions_for_context_path = + context_path + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:for_hover ~scope + in + completions_for_context_path + |> List.map (fun (c : Completion.t) -> + match c.kind with + | Value typ_expr -> ( + match typ_expr |> Type_utils.extract_type ~env:c.env ~package with + | Some (Tvariant v, _) -> + with_exhaustive_item c + ~cases: + (v.constructors + |> List.map (fun (constructor : Constructor.t) -> + constructor.cname.txt + ^ + match constructor.args with + | Args [] -> "" + | _ -> "(_)")) + | Some (Tpolyvariant v, _) -> + with_exhaustive_item c + ~cases: + (v.constructors + |> List.map (fun (constructor : poly_variant_constructor) -> + "#" ^ constructor.display_name + ^ + match constructor.args with + | [] -> "" + | _ -> "(_)")) + | Some (Toption (_env, _typ), _) -> + with_exhaustive_item c ~cases:["Some($1)"; "None"] ~start_index:1 + | Some (Tresult _, _) -> + with_exhaustive_item c ~cases:["Ok($1)"; "Error($1)"] + ~start_index:1 + | Some (Tbool _, _) -> + with_exhaustive_item c ~cases:["true"; "false"] + | _ -> [c]) + | _ -> [c]) + |> List.flatten + | ChtmlElement {prefix} -> + Completion_jsx.html_elements + |> List.filter_map (fun (element_name, description, deprecated) -> + if Utils.starts_with element_name prefix then + let name = "<" ^ element_name ^ ">" in + Some + (Completion.create name ~synthetic:true ~kind:(Label name) + ~detail:description ~env ~docstring:[description] + ~insert_text:element_name + ?deprecated: + (match deprecated with + | true -> Some "true" + | false -> None)) + else None) + | CextensionNode prefix -> + if Utils.starts_with "todo" prefix then + let detail = + "`%todo` is used to tell the compiler that some code still needs to be \ + implemented." + in + [ + Completion.create "todo" ~synthetic:true ~kind:(Label "todo") ~detail + ~env ~insert_text:"todo"; + Completion.create "todo (with payload)" ~synthetic:true + ~includes_snippets:true ~kind:(Label "todo") + ~detail:(detail ^ " With a payload.") + ~env ~insert_text:"todo(\"${0:TODO}\")"; + ] + else [] diff --git a/analysis/src/CompletionDecorators.ml b/analysis/src/completion_decorators.ml similarity index 100% rename from analysis/src/CompletionDecorators.ml rename to analysis/src/completion_decorators.ml diff --git a/analysis/src/completion_expressions.ml b/analysis/src/completion_expressions.ml new file mode 100644 index 00000000000..79c86e54da0 --- /dev/null +++ b/analysis/src/completion_expressions.ml @@ -0,0 +1,318 @@ +open Shared_types + +let is_expr_hole exp = + match exp.Parsetree.pexp_desc with + | Pexp_extension ({txt = "rescript.exprhole"}, _) -> true + | _ -> false + +let is_expr_tuple expr = + match expr.Parsetree.pexp_desc with + | Pexp_tuple _ -> true + | _ -> false + +let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos + ~first_char_before_cursor_no_white = + let loc_has_cursor loc = loc |> Cursor_position.loc_has_cursor ~pos in + let some_if_has_cursor v = + if loc_has_cursor exp.pexp_loc then Some v else None + in + match exp.pexp_desc with + | Pexp_ident {txt = Lident txt} when Utils.has_braces exp.pexp_attributes -> + (* An ident with braces attribute corresponds to for example `{n}`. + Looks like a record but is parsed as an ident with braces. *) + some_if_has_cursor + (txt, [Completable.NRecordBody {seen_fields = []}] @ expr_path) + | Pexp_ident {txt = Lident txt} -> some_if_has_cursor (txt, expr_path) + | Pexp_construct ({txt = Lident "()"}, _) -> some_if_has_cursor ("", expr_path) + | Pexp_construct ({txt = Lident txt}, None) -> + some_if_has_cursor (txt, expr_path) + | Pexp_variant (label, None) -> some_if_has_cursor ("#" ^ label, expr_path) + | Pexp_array array_patterns -> ( + let next_expr_path = [Completable.NArray] @ expr_path in + (* No fields but still has cursor = empty completion *) + if List.length array_patterns = 0 && loc_has_cursor exp.pexp_loc then + Some ("", next_expr_path) + else + let array_item_with_cursor = + array_patterns + |> List.find_map (fun e -> + e + |> traverse_expr ~expr_path:next_expr_path + ~first_char_before_cursor_no_white ~pos) + in + + match (array_item_with_cursor, loc_has_cursor exp.pexp_loc) with + | Some array_item_with_cursor, _ -> Some array_item_with_cursor + | None, true when first_char_before_cursor_no_white = Some ',' -> + (* No item had the cursor, but the entire expr still has the cursor (so + the cursor is in the array somewhere), and the first char before the + cursor is a comma = interpret as compleing for a new value (example: + `[None, , None]`) *) + Some ("", next_expr_path) + | _ -> None) + | Pexp_tuple tuple_items when loc_has_cursor exp.pexp_loc -> + tuple_items + |> traverse_expr_tuple_items ~first_char_before_cursor_no_white ~pos + ~next_expr_path:(fun item_num -> + [Completable.NTupleItem {item_num}] @ expr_path) + ~result_from_found_item_num:(fun item_num -> + [Completable.NTupleItem {item_num = item_num + 1}] @ expr_path) + | Pexp_record ([], _) -> + (* Empty fields means we're in a record body `{}`. Complete for the fields. *) + some_if_has_cursor + ("", [Completable.NRecordBody {seen_fields = []}] @ expr_path) + | Pexp_record (fields, _) -> ( + let field_with_cursor = ref None in + let field_with_expr_hole = ref None in + Ext_list.iter fields (fun {lid = fname; x = exp} -> + match + ( fname.Location.txt, + exp.Parsetree.pexp_loc |> Cursor_position.classify_loc ~pos ) + with + | Longident.Lident fname, HasCursor -> + field_with_cursor := Some (fname, exp) + | Lident fname, _ when is_expr_hole exp -> + field_with_expr_hole := Some (fname, exp) + | _ -> ()); + let seen_fields = + Ext_list.filter_map fields (fun {lid = field_name} -> + match field_name with + | {Location.txt = Longident.Lident field_name} -> Some field_name + | _ -> None) + in + match (!field_with_cursor, !field_with_expr_hole) with + | Some (fname, f), _ | None, Some (fname, f) -> ( + match f.pexp_desc with + | Pexp_extension ({txt = "rescript.exprhole"}, _) -> + (* An expression hole means for example `{someField: }`. We want to complete for the type of `someField`. *) + some_if_has_cursor + ("", [Completable.NFollowRecordField {field_name = fname}] @ expr_path) + | Pexp_ident {txt = Lident txt} when fname = txt -> + (* This is a heuristic for catching writing field names. ReScript has punning for record fields, but the AST doesn't, + so punning is represented as the record field name and identifier being the same: {someField}. *) + some_if_has_cursor + (txt, [Completable.NRecordBody {seen_fields}] @ expr_path) + | Pexp_ident {txt = Lident txt} -> + (* A var means `{someField: s}` or similar. Complete for identifiers or values. *) + some_if_has_cursor (txt, expr_path) + | _ -> + f + |> traverse_expr ~first_char_before_cursor_no_white ~pos + ~expr_path: + ([Completable.NFollowRecordField {field_name = fname}] + @ expr_path)) + | None, None -> ( + if Debug.verbose () then ( + Printf.printf "[traverse_expr] No field with cursor and no expr hole.\n"; + + match first_char_before_cursor_no_white with + | None -> () + | Some c -> + Printf.printf "[traverse_expr] firstCharBeforeCursorNoWhite: %c.\n" c); + + (* Figure out if we're completing for a new field. + If the cursor is inside of the record body, but no field has the cursor, + and there's no pattern hole. Check the first char to the left of the cursor, + ignoring white space. If that's a comma or {, we assume you're completing for a new field, + since you're either between 2 fields (comma to the left) or at the start of the record ({). *) + match first_char_before_cursor_no_white with + | Some (',' | '{') -> + some_if_has_cursor + ("", [Completable.NRecordBody {seen_fields}] @ expr_path) + | _ -> None)) + | Pexp_construct + ( {txt}, + Some {pexp_loc; pexp_desc = Pexp_construct ({txt = Lident "()"}, _)} ) + when loc_has_cursor pexp_loc -> + (* Empty payload with cursor, like: Test() *) + Some + ( "", + [ + Completable.NVariantPayload + {constructor_name = Utils.get_unqualified_name txt; item_num = 0}; + ] + @ expr_path ) + | Pexp_construct ({txt}, Some e) + when pos >= (e.pexp_loc |> Loc.end_) + && first_char_before_cursor_no_white = Some ',' + && is_expr_tuple e = false -> + (* Empty payload with trailing ',', like: Test(true, ) *) + Some + ( "", + [ + Completable.NVariantPayload + {constructor_name = Utils.get_unqualified_name txt; item_num = 1}; + ] + @ expr_path ) + | Pexp_construct ({txt}, Some {pexp_loc; pexp_desc = Pexp_tuple tuple_items}) + when loc_has_cursor pexp_loc -> + tuple_items + |> traverse_expr_tuple_items ~first_char_before_cursor_no_white ~pos + ~next_expr_path:(fun item_num -> + [ + Completable.NVariantPayload + {constructor_name = Utils.get_unqualified_name txt; item_num}; + ] + @ expr_path) + ~result_from_found_item_num:(fun item_num -> + [ + Completable.NVariantPayload + { + constructor_name = Utils.get_unqualified_name txt; + item_num = item_num + 1; + }; + ] + @ expr_path) + | Pexp_construct ({txt}, Some p) when loc_has_cursor exp.pexp_loc -> + p + |> traverse_expr ~first_char_before_cursor_no_white ~pos + ~expr_path: + ([ + Completable.NVariantPayload + { + constructor_name = Utils.get_unqualified_name txt; + item_num = 0; + }; + ] + @ expr_path) + | Pexp_variant + (txt, Some {pexp_loc; pexp_desc = Pexp_construct ({txt = Lident "()"}, _)}) + when loc_has_cursor pexp_loc -> + (* Empty payload with cursor, like: #test() *) + Some + ( "", + [Completable.NPolyvariantPayload {constructor_name = txt; item_num = 0}] + @ expr_path ) + | Pexp_variant (txt, Some e) + when pos >= (e.pexp_loc |> Loc.end_) + && first_char_before_cursor_no_white = Some ',' + && is_expr_tuple e = false -> + (* Empty payload with trailing ',', like: #test(true, ) *) + Some + ( "", + [Completable.NPolyvariantPayload {constructor_name = txt; item_num = 1}] + @ expr_path ) + | Pexp_variant (txt, Some {pexp_loc; pexp_desc = Pexp_tuple tuple_items}) + when loc_has_cursor pexp_loc -> + tuple_items + |> traverse_expr_tuple_items ~first_char_before_cursor_no_white ~pos + ~next_expr_path:(fun item_num -> + [Completable.NPolyvariantPayload {constructor_name = txt; item_num}] + @ expr_path) + ~result_from_found_item_num:(fun item_num -> + [ + Completable.NPolyvariantPayload + {constructor_name = txt; item_num = item_num + 1}; + ] + @ expr_path) + | Pexp_variant (txt, Some p) when loc_has_cursor exp.pexp_loc -> + p + |> traverse_expr ~first_char_before_cursor_no_white ~pos + ~expr_path: + ([ + Completable.NPolyvariantPayload + {constructor_name = txt; item_num = 0}; + ] + @ expr_path) + | _ -> None + +and traverse_expr_tuple_items tuple_items ~next_expr_path + ~result_from_found_item_num ~pos ~first_char_before_cursor_no_white = + let item_num = ref (-1) in + let item_with_cursor = + tuple_items + |> List.find_map (fun e -> + item_num := !item_num + 1; + e + |> traverse_expr ~expr_path:(next_expr_path !item_num) + ~first_char_before_cursor_no_white ~pos) + in + match (item_with_cursor, first_char_before_cursor_no_white) with + | None, Some ',' -> + (* No tuple item has the cursor, but there's a comma before the cursor. + Figure out what arg we're trying to complete. Example: (true, , None) *) + let pos_num = ref (-1) in + tuple_items + |> List.iteri (fun index e -> + if pos >= Loc.start e.Parsetree.pexp_loc then pos_num := index); + if !pos_num > -1 then Some ("", result_from_found_item_num !pos_num) + else None + | v, _ -> v + +let pretty_print_fn_template_arg_name ?current_index ~env ~full + (arg_typ : Types.type_expr) = + let index_text = + match current_index with + | None -> "" + | Some i -> string_of_int i + in + let default_var_name = "v" ^ index_text in + let arg_typ, suffix, _env = + Type_utils.dig_to_relevant_template_name_type ~env ~package:full.package + arg_typ + in + match arg_typ |> Type_utils.path_from_type_expr with + | None -> default_var_name + | Some p -> ( + let trailing_elements_of_path = + p |> Utils.expand_path |> List.rev |> Utils.last_elements + in + match trailing_elements_of_path with + | [] | ["t"] -> default_var_name + | ["unit"] -> "()" + (* Special treatment for JsxEvent, since that's a common enough thing + used in event handlers. *) + | ["JsxEvent"; "synthetic"] -> "event" + | ["synthetic"] -> "event" + (* Ignore `t` types, and go for its module name instead. *) + | [some_name; "t"] | [_; some_name] | [some_name] -> ( + match some_name with + | "string" | "int" | "float" | "array" | "option" | "bool" -> + default_var_name + | some_name when String.length some_name < 30 -> + if some_name = "synthetic" then + Printf.printf "synthetic! %s\n" + (trailing_elements_of_path |> Shared_types.ident); + (* We cap how long the name can be, so we don't end up with super + long type names. *) + (some_name |> Utils.lowercase_first_char) ^ suffix + | _ -> default_var_name) + | _ -> default_var_name) + +let complete_constructor_payload ~pos_before_cursor + ~first_char_before_cursor_no_white + (constructor_lid : Longident.t Location.loc) expr = + match + traverse_expr expr ~expr_path:[] ~pos:pos_before_cursor + ~first_char_before_cursor_no_white + with + | None -> None + | Some (prefix, nested) -> + (* The nested path must start with the constructor name found, plus + the target argument number for the constructor. We translate to + that here, because we need to account for multi arg constructors + being represented as tuples. *) + let nested = + match List.rev nested with + | Completable.NTupleItem {item_num} :: rest -> + [ + Completable.NVariantPayload + {constructor_name = Longident.last constructor_lid.txt; item_num}; + ] + @ rest + | nested -> + [ + Completable.NVariantPayload + { + constructor_name = Longident.last constructor_lid.txt; + item_num = 0; + }; + ] + @ nested + in + let variant_ctx_path = + Completable.CTypeAtPos + {constructor_lid.loc with loc_start = constructor_lid.loc.loc_end} + in + Some + (Completable.Cexpression {context_path = variant_ctx_path; prefix; nested}) diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/completion_front_end.ml similarity index 51% rename from analysis/src/CompletionFrontEnd.ml rename to analysis/src/completion_front_end.ml index cdb879290dc..481c7a0d3f5 100644 --- a/analysis/src/CompletionFrontEnd.ml +++ b/analysis/src/completion_front_end.ml @@ -1,39 +1,39 @@ -open SharedTypes +open Shared_types -let findArgCompletables ~(args : arg list) ~endPos ~posBeforeCursor - ~(contextPath : Completable.contextPath) ~posAfterFunExpr - ~firstCharBeforeCursorNoWhite ~charBeforeCursor ~isPipedExpr = - let fnHasCursor = - posAfterFunExpr <= posBeforeCursor && posBeforeCursor < endPos +let find_arg_completables ~(args : arg list) ~end_pos ~pos_before_cursor + ~(context_path : Completable.context_path) ~pos_after_fun_expr + ~first_char_before_cursor_no_white ~char_before_cursor ~is_piped_expr = + let fn_has_cursor = + pos_after_fun_expr <= pos_before_cursor && pos_before_cursor < end_pos in - let allNames = + let all_names = List.fold_right - (fun arg allLabels -> + (fun arg all_labels -> match arg with - | {label = Some labelled} -> labelled.name :: allLabels - | {label = None} -> allLabels) + | {label = Some labelled} -> labelled.name :: all_labels + | {label = None} -> all_labels) args [] in - let unlabelledCount = ref (if isPipedExpr then 1 else 0) in - let someArgHadEmptyExprLoc = ref false in + let unlabelled_count = ref (if is_piped_expr then 1 else 0) in + let some_arg_had_empty_expr_loc = ref false in let rec loop args = match args with | {label = Some labelled; exp} :: rest -> if - labelled.posStart <= posBeforeCursor - && posBeforeCursor < labelled.posEnd + labelled.pos_start <= pos_before_cursor + && pos_before_cursor < labelled.pos_end then ( if Debug.verbose () then print_endline "[findArgCompletables] Completing named arg #2"; - Some (Completable.CnamedArg (contextPath, labelled.name, allNames))) - else if exp.pexp_loc |> Loc.hasPos ~pos:posBeforeCursor then ( + Some (Completable.CnamedArg (context_path, labelled.name, all_names))) + else if exp.pexp_loc |> Loc.has_pos ~pos:pos_before_cursor then ( if Debug.verbose () then print_endline "[findArgCompletables] Completing in the assignment of labelled \ argument"; match - CompletionExpressions.traverseExpr exp ~exprPath:[] - ~pos:posBeforeCursor ~firstCharBeforeCursorNoWhite + Completion_expressions.traverse_expr exp ~expr_path:[] + ~pos:pos_before_cursor ~first_char_before_cursor_no_white with | None -> None | Some (prefix, nested) -> @@ -43,26 +43,26 @@ let findArgCompletables ~(args : arg list) ~endPos ~posBeforeCursor Some (Cexpression { - contextPath = + context_path = CArgument { - functionContextPath = contextPath; - argumentLabel = Labelled labelled.name; + function_context_path = context_path; + argument_label = Labelled labelled.name; }; prefix; nested = List.rev nested; })) - else if CompletionExpressions.isExprHole exp then ( + else if Completion_expressions.is_expr_hole exp then ( if Debug.verbose () then print_endline "[findArgCompletables] found exprhole"; Some (Cexpression { - contextPath = + context_path = CArgument { - functionContextPath = contextPath; - argumentLabel = Labelled labelled.name; + function_context_path = context_path; + argument_label = Labelled labelled.name; }; prefix = ""; nested = []; @@ -71,20 +71,20 @@ let findArgCompletables ~(args : arg list) ~endPos ~posBeforeCursor | {label = None; exp} :: rest -> if Debug.verbose () then Printf.printf "[findArgCompletable] unlabelled arg expr is: %s \n" - (DumpAst.printExprItem ~pos:posBeforeCursor ~indentation:0 exp); + (Dump_ast.print_expr_item ~pos:pos_before_cursor ~indentation:0 exp); (* Track whether there was an arg with an empty loc (indicates parser error)*) - if CursorPosition.locIsEmpty exp.pexp_loc ~pos:posBeforeCursor then - someArgHadEmptyExprLoc := true; + if Cursor_position.loc_is_empty exp.pexp_loc ~pos:pos_before_cursor then + some_arg_had_empty_expr_loc := true; if Res_parsetree_viewer.is_template_literal exp then None - else if exp.pexp_loc |> Loc.hasPos ~pos:posBeforeCursor then ( + else if exp.pexp_loc |> Loc.has_pos ~pos:pos_before_cursor then ( if Debug.verbose () then print_endline "[findArgCompletables] Completing in an unlabelled argument"; match - CompletionExpressions.traverseExpr exp ~pos:posBeforeCursor - ~firstCharBeforeCursorNoWhite ~exprPath:[] + Completion_expressions.traverse_expr exp ~pos:pos_before_cursor + ~first_char_before_cursor_no_white ~expr_path:[] with | None -> if Debug.verbose () then @@ -98,46 +98,46 @@ let findArgCompletables ~(args : arg list) ~endPos ~posBeforeCursor Some (Cexpression { - contextPath = + context_path = CArgument { - functionContextPath = contextPath; - argumentLabel = - Unlabelled {argumentPosition = !unlabelledCount}; + function_context_path = context_path; + argument_label = + Unlabelled {argument_position = !unlabelled_count}; }; prefix; nested = List.rev nested; })) - else if CompletionExpressions.isExprHole exp then ( + else if Completion_expressions.is_expr_hole exp then ( if Debug.verbose () then print_endline "[findArgCompletables] found an exprhole #2"; Some (Cexpression { - contextPath = + context_path = CArgument { - functionContextPath = contextPath; - argumentLabel = - Unlabelled {argumentPosition = !unlabelledCount}; + function_context_path = context_path; + argument_label = + Unlabelled {argument_position = !unlabelled_count}; }; prefix = ""; nested = []; })) else ( - unlabelledCount := !unlabelledCount + 1; + unlabelled_count := !unlabelled_count + 1; loop rest) | [] -> - let hadEmptyExpLoc = !someArgHadEmptyExprLoc in - if fnHasCursor then ( + let had_empty_exp_loc = !some_arg_had_empty_expr_loc in + if fn_has_cursor then ( if Debug.verbose () then print_endline "[findArgCompletables] Function has cursor"; - match charBeforeCursor with + match char_before_cursor with | Some '~' -> if Debug.verbose () then print_endline "[findArgCompletables] '~' is before cursor"; - Some (Completable.CnamedArg (contextPath, "", allNames)) - | _ when hadEmptyExpLoc -> + Some (Completable.CnamedArg (context_path, "", all_names)) + | _ when had_empty_exp_loc -> (* Special case: `Console.log(arr->)`, completing on the pipe. This match branch happens when the fn call has the cursor and: - there's no argument label or expr that has the cursor @@ -156,8 +156,8 @@ let findArgCompletables ~(args : arg list) ~endPos ~posBeforeCursor arg had empty loc"; None | _ - when firstCharBeforeCursorNoWhite = Some '(' - || firstCharBeforeCursorNoWhite = Some ',' -> + when first_char_before_cursor_no_white = Some '(' + || first_char_before_cursor_no_white = Some ',' -> (* Checks to ensure that completing for empty unlabelled arg makes sense by checking what's left of the cursor. *) if Debug.verbose () then @@ -165,16 +165,16 @@ let findArgCompletables ~(args : arg list) ~endPos ~posBeforeCursor "[findArgCompletables] Completing for unlabelled argument value \ because nothing matched and is not labelled argument name \ completion. isPipedExpr: %b\n" - isPipedExpr; + is_piped_expr; Some (Cexpression { - contextPath = + context_path = CArgument { - functionContextPath = contextPath; - argumentLabel = - Unlabelled {argumentPosition = !unlabelledCount}; + function_context_path = context_path; + argument_label = + Unlabelled {argument_position = !unlabelled_count}; }; prefix = ""; nested = []; @@ -187,27 +187,27 @@ let findArgCompletables ~(args : arg list) ~endPos ~posBeforeCursor | [ {label = None; exp = {pexp_desc = Pexp_construct ({txt = Lident "()"}, _)}}; ] - when fnHasCursor -> + when fn_has_cursor -> if Debug.verbose () then print_endline "[findArgCompletables] Completing for unit argument"; Some (Completable.Cexpression { - contextPath = + context_path = CArgument { - functionContextPath = contextPath; - argumentLabel = + function_context_path = context_path; + argument_label = Unlabelled - {argumentPosition = (if isPipedExpr then 1 else 0)}; + {argument_position = (if is_piped_expr then 1 else 0)}; }; prefix = ""; nested = []; }) | _ -> loop args -let rec exprToContextPathInner ~(inJsxContext : bool) (e : Parsetree.expression) - = +let rec expr_to_context_path_inner ~(in_jsx_context : bool) + (e : Parsetree.expression) = match e.pexp_desc with | Pexp_constant (Pconst_string _) -> Some Completable.CPString | Pexp_constant (Pconst_integer _) -> Some CPInt @@ -218,22 +218,23 @@ let rec exprToContextPathInner ~(inJsxContext : bool) (e : Parsetree.expression) (CPArray (match exprs with | [] -> None - | exp :: _ -> exprToContextPath ~inJsxContext exp)) + | exp :: _ -> expr_to_context_path ~in_jsx_context exp)) | Pexp_ident {txt = Lident "->"} -> None | Pexp_ident {txt; loc} -> Some - (CPId {path = Utils.flattenLongIdent txt; completionContext = Value; loc}) + (CPId + {path = Utils.flatten_long_ident txt; completion_context = Value; loc}) | Pexp_field (e1, {txt = Lident name}) -> ( - match exprToContextPath ~inJsxContext e1 with - | Some contextPath -> + match expr_to_context_path ~in_jsx_context e1 with + | Some context_path -> Some (CPField { - contextPath; - fieldName = name; - posOfDot = None; - exprLoc = e1.pexp_loc; - inJsx = inJsxContext; + context_path; + field_name = name; + pos_of_dot = None; + expr_loc = e1.pexp_loc; + in_jsx = in_jsx_context; }) | _ -> None) | Pexp_field (e1, {loc; txt = Ldot (lid, name)}) -> @@ -241,22 +242,22 @@ let rec exprToContextPathInner ~(inJsxContext : bool) (e : Parsetree.expression) Some (CPField { - contextPath = + context_path = CPId { - path = Utils.flattenLongIdent lid; - completionContext = Module; + path = Utils.flatten_long_ident lid; + completion_context = Module; loc; }; - fieldName = name; - posOfDot = None; - exprLoc = e1.pexp_loc; - inJsx = inJsxContext; + field_name = name; + pos_of_dot = None; + expr_loc = e1.pexp_loc; + in_jsx = in_jsx_context; }) | Pexp_send (e1, {txt}) -> ( - match exprToContextPath ~inJsxContext e1 with + match expr_to_context_path ~in_jsx_context e1 with | None -> None - | Some contexPath -> Some (CPObj (contexPath, txt))) + | Some contex_path -> Some (CPObj (contex_path, txt))) | Pexp_apply { funct = @@ -270,7 +271,7 @@ let rec exprToContextPathInner ~(inJsxContext : bool) (e : Parsetree.expression) transformed_jsx; } -> (* Transform away pipe with apply call *) - exprToContextPath ~inJsxContext + expr_to_context_path ~in_jsx_context { pexp_desc = Pexp_apply @@ -288,7 +289,7 @@ let rec exprToContextPathInner ~(inJsxContext : bool) (e : Parsetree.expression) ]; } as app) -> (* Transform away pipe with identifier *) - exprToContextPath ~inJsxContext + expr_to_context_path ~in_jsx_context { pexp_desc = Pexp_apply @@ -301,29 +302,29 @@ let rec exprToContextPathInner ~(inJsxContext : bool) (e : Parsetree.expression) pexp_attributes; } | Pexp_apply {funct = e1; args} -> ( - match exprToContextPath ~inJsxContext e1 with + match expr_to_context_path ~in_jsx_context e1 with | None -> None - | Some contexPath -> Some (CPApply (contexPath, args |> List.map fst))) + | Some contex_path -> Some (CPApply (contex_path, args |> List.map fst))) | Pexp_tuple exprs -> - let exprsAsContextPaths = - exprs |> List.filter_map (exprToContextPath ~inJsxContext) + let exprs_as_context_paths = + exprs |> List.filter_map (expr_to_context_path ~in_jsx_context) in - if List.length exprs = List.length exprsAsContextPaths then - Some (CTuple exprsAsContextPaths) + if List.length exprs = List.length exprs_as_context_paths then + Some (CTuple exprs_as_context_paths) else None - | Pexp_await e -> exprToContextPathInner ~inJsxContext e + | Pexp_await e -> expr_to_context_path_inner ~in_jsx_context e | _ -> None -and exprToContextPath ~(inJsxContext : bool) (e : Parsetree.expression) = +and expr_to_context_path ~(in_jsx_context : bool) (e : Parsetree.expression) = match ( Res_parsetree_viewer.expr_is_await e, - exprToContextPathInner ~inJsxContext e ) + expr_to_context_path_inner ~in_jsx_context e ) with - | true, Some ctxPath -> Some (CPAwait ctxPath) - | false, Some ctxPath -> Some ctxPath + | true, Some ctx_path -> Some (CPAwait ctx_path) + | false, Some ctx_path -> Some ctx_path | _, None -> None -let completePipeChain ~(inJsxContext : bool) (exp : Parsetree.expression) = +let complete_pipe_chain ~(in_jsx_context : bool) (exp : Parsetree.expression) = (* Complete the end of pipe chains by reconstructing the pipe chain as a single pipe, so it can be completed. Example: @@ -339,8 +340,8 @@ let completePipeChain ~(inJsxContext : bool) (exp : Parsetree.expression) = funct = {pexp_desc = Pexp_ident {txt = Lident "->"}}; args = [_; (_, {pexp_desc = Pexp_apply {funct = d}})]; } -> - exprToContextPath ~inJsxContext exp - |> Option.map (fun ctxPath -> (ctxPath, d.pexp_loc)) + expr_to_context_path ~in_jsx_context exp + |> Option.map (fun ctx_path -> (ctx_path, d.pexp_loc)) (* When the left side of the pipe we're completing is an identifier application. Example: someArray->filterAllTheGoodStuff-> *) | Pexp_apply @@ -348,81 +349,81 @@ let completePipeChain ~(inJsxContext : bool) (exp : Parsetree.expression) = funct = {pexp_desc = Pexp_ident {txt = Lident "->"}}; args = [_; (_, {pexp_desc = Pexp_ident _; pexp_loc})]; } -> - exprToContextPath ~inJsxContext exp - |> Option.map (fun ctxPath -> (ctxPath, pexp_loc)) + expr_to_context_path ~in_jsx_context exp + |> Option.map (fun ctx_path -> (ctx_path, pexp_loc)) | _ -> None -let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc - text = - let offsetNoWhite = Utils.skipWhite text (offset - 1) in - let posNoWhite = - let line, col = posCursor in - (line, max 0 col - offset + offsetNoWhite) +let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file + ?find_this_expr_loc text = + let offset_no_white = Utils.skip_white text (offset - 1) in + let pos_no_white = + let line, col = pos_cursor in + (line, max 0 col - offset + offset_no_white) in (* Identifies the first character before the cursor that's not white space. Should be used very sparingly, but can be used to drive completion triggering in scenarios where the parser eats things we'd need to complete. Example: let {whatever, }, char is ','. *) - let firstCharBeforeCursorNoWhite = - if offsetNoWhite < String.length text && offsetNoWhite >= 0 then - Some text.[offsetNoWhite] + let first_char_before_cursor_no_white = + if offset_no_white < String.length text && offset_no_white >= 0 then + Some text.[offset_no_white] else None in - let posOfDot = Pos.posOfDot text ~pos:posCursor ~offset in - let charAtCursor = + let pos_of_dot = Pos.pos_of_dot text ~pos:pos_cursor ~offset in + let char_at_cursor = if offset >= 0 && offset < String.length text then text.[offset] else '\n' in - let posBeforeCursor = Pos.posBeforeCursor posCursor in - let charBeforeCursor, blankAfterCursor = - match Pos.positionToOffset text posCursor with + let pos_before_cursor = Pos.pos_before_cursor pos_cursor in + let char_before_cursor, blank_after_cursor = + match Pos.position_to_offset text pos_cursor with | Some offset when offset > 0 -> ( - let charBeforeCursor = text.[offset - 1] in - match charAtCursor with + let char_before_cursor = text.[offset - 1] in + match char_at_cursor with | ' ' | '\t' | '\r' | '\n' -> - (Some charBeforeCursor, Some charBeforeCursor) - | _ -> (Some charBeforeCursor, None)) + (Some char_before_cursor, Some char_before_cursor) + | _ -> (Some char_before_cursor, None)) | _ -> (None, None) in - let flattenLidCheckDot ?(jsx = true) (lid : Longident.t Location.loc) = + let flatten_lid_check_dot ?(jsx = true) (lid : Longident.t Location.loc) = (* Flatten an identifier keeping track of whether the current cursor is after a "." in the id followed by a blank character. In that case, cut the path after ".". *) - let cutAtOffset = - let idStart = Loc.start lid.loc in - match blankAfterCursor with + let cut_at_offset = + let id_start = Loc.start lid.loc in + match blank_after_cursor with | Some '.' -> - if fst posBeforeCursor = fst idStart then - Some (snd posBeforeCursor - snd idStart) + if fst pos_before_cursor = fst id_start then + Some (snd pos_before_cursor - snd id_start) else None | _ -> None in - Utils.flattenLongIdent ~cutAtOffset ~jsx lid.txt + Utils.flatten_long_ident ~cut_at_offset ~jsx lid.txt in - let currentCtxPath = ref None in - let processingFun = ref None in - let setCurrentCtxPath ctxPath = - if !Cfg.debugFollowCtxPath then + let current_ctx_path = ref None in + let processing_fun = ref None in + let set_current_ctx_path ctx_path = + if !Cfg.debug_follow_ctx_path then Printf.printf "setting current ctxPath: %s\n" - (Completable.contextPathToString ctxPath); - currentCtxPath := Some ctxPath + (Completable.context_path_to_string ctx_path); + current_ctx_path := Some ctx_path in - let resetCurrentCtxPath ctxPath = - (match (!currentCtxPath, ctxPath) with + let reset_current_ctx_path ctx_path = + (match (!current_ctx_path, ctx_path) with | None, None -> () | _ -> - if !Cfg.debugFollowCtxPath then + if !Cfg.debug_follow_ctx_path then Printf.printf "resetting current ctxPath to: %s\n" - (match ctxPath with + (match ctx_path with | None -> "None" - | Some ctxPath -> Completable.contextPathToString ctxPath)); - currentCtxPath := ctxPath + | Some ctx_path -> Completable.context_path_to_string ctx_path)); + current_ctx_path := ctx_path in let found = ref false in let result = ref None in let scope = ref (Scope.create ()) in - let setResultOpt x = + let set_result_opt x = if !result = None then match x with | None -> @@ -433,207 +434,211 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc | Some x -> if Debug.verbose () then Printf.printf "[set_result] set new result to %s\n" - (Completable.toString x); + (Completable.to_string x); result := Some (x, !scope) in - let inJsxContext = ref false in - let setResult x = setResultOpt (Some x) in - let scopeValueDescription (vd : Parsetree.value_description) = + let in_jsx_context = ref false in + let set_result x = set_result_opt (Some x) in + let scope_value_description (vd : Parsetree.value_description) = scope := - !scope |> Scope.addValue ~name:vd.pval_name.txt ~loc:vd.pval_name.loc + !scope |> Scope.add_value ~name:vd.pval_name.txt ~loc:vd.pval_name.loc in - let rec scopePattern ?contextPath - ?(patternPath : Completable.nestedPath list = []) + let rec scope_pattern ?context_path + ?(pattern_path : Completable.nested_path list = []) (pat : Parsetree.pattern) = - let contextPathToSave = - match (contextPath, patternPath) with - | maybeContextPath, [] -> maybeContextPath - | Some contextPath, patternPath -> + let context_path_to_save = + match (context_path, pattern_path) with + | maybe_context_path, [] -> maybe_context_path + | Some context_path, pattern_path -> Some (Completable.CPatternPath - {rootCtxPath = contextPath; nested = List.rev patternPath}) + {root_ctx_path = context_path; nested = List.rev pattern_path}) | _ -> None in match pat.ppat_desc with | Ppat_any -> () | Ppat_var {txt; loc} -> scope := - !scope |> Scope.addValue ~name:txt ~loc ?contextPath:contextPathToSave - | Ppat_alias (p, asA) -> - scopePattern p ~patternPath ?contextPath; - let ctxPath = - if contextPathToSave = None then + !scope + |> Scope.add_value ~name:txt ~loc ?context_path:context_path_to_save + | Ppat_alias (p, as_a) -> + scope_pattern p ~pattern_path ?context_path; + let ctx_path = + if context_path_to_save = None then match p with | {ppat_desc = Ppat_var {txt; loc}} -> Some - (Completable.CPId {path = [txt]; completionContext = Value; loc}) + (Completable.CPId {path = [txt]; completion_context = Value; loc}) | _ -> None else None in scope := - !scope |> Scope.addValue ~name:asA.txt ~loc:asA.loc ?contextPath:ctxPath + !scope + |> Scope.add_value ~name:as_a.txt ~loc:as_a.loc ?context_path:ctx_path | Ppat_constant _ | Ppat_interval _ -> () | Ppat_tuple pl -> pl |> List.iteri (fun index p -> - scopePattern p - ~patternPath:(NTupleItem {itemNum = index} :: patternPath) - ?contextPath) + scope_pattern p + ~pattern_path:(NTupleItem {item_num = index} :: pattern_path) + ?context_path) | Ppat_construct (_, None) -> () | Ppat_construct ({txt}, Some {ppat_desc = Ppat_tuple pl}) -> pl |> List.iteri (fun index p -> - scopePattern p - ~patternPath: + scope_pattern p + ~pattern_path: (NVariantPayload { - itemNum = index; - constructorName = Utils.getUnqualifiedName txt; + item_num = index; + constructor_name = Utils.get_unqualified_name txt; } - :: patternPath) - ?contextPath) + :: pattern_path) + ?context_path) | Ppat_construct ({txt}, Some p) -> - scopePattern - ~patternPath: + scope_pattern + ~pattern_path: (NVariantPayload - {itemNum = 0; constructorName = Utils.getUnqualifiedName txt} - :: patternPath) - ?contextPath p + {item_num = 0; constructor_name = Utils.get_unqualified_name txt} + :: pattern_path) + ?context_path p | Ppat_variant (_, None) -> () | Ppat_variant (txt, Some {ppat_desc = Ppat_tuple pl}) -> pl |> List.iteri (fun index p -> - scopePattern p - ~patternPath: - (NPolyvariantPayload {itemNum = index; constructorName = txt} - :: patternPath) - ?contextPath) + scope_pattern p + ~pattern_path: + (NPolyvariantPayload {item_num = index; constructor_name = txt} + :: pattern_path) + ?context_path) | Ppat_variant (txt, Some p) -> - scopePattern - ~patternPath: - (NPolyvariantPayload {itemNum = 0; constructorName = txt} - :: patternPath) - ?contextPath p + scope_pattern + ~pattern_path: + (NPolyvariantPayload {item_num = 0; constructor_name = txt} + :: pattern_path) + ?context_path p | Ppat_record (fields, _) -> Ext_list.iter fields (fun {lid = fname; x = p} -> match fname with | {Location.txt = Longident.Lident fname} -> - scopePattern - ~patternPath: - (Completable.NFollowRecordField {fieldName = fname} - :: patternPath) - ?contextPath p + scope_pattern + ~pattern_path: + (Completable.NFollowRecordField {field_name = fname} + :: pattern_path) + ?context_path p | _ -> ()) | Ppat_array pl -> pl |> List.iter - (scopePattern ~patternPath:(NArray :: patternPath) ?contextPath) - | Ppat_or (p1, _) -> scopePattern ~patternPath ?contextPath p1 - | Ppat_constraint (p, coreType) -> - scopePattern ~patternPath - ?contextPath:(TypeUtils.contextPathFromCoreType coreType) + (scope_pattern ~pattern_path:(NArray :: pattern_path) ?context_path) + | Ppat_or (p1, _) -> scope_pattern ~pattern_path ?context_path p1 + | Ppat_constraint (p, core_type) -> + scope_pattern ~pattern_path + ?context_path:(Type_utils.context_path_from_core_type core_type) p | Ppat_type _ -> () | Ppat_unpack {txt; loc} -> - scope := !scope |> Scope.addModule ~name:txt ~loc - | Ppat_exception p -> scopePattern ~patternPath ?contextPath p + scope := !scope |> Scope.add_module ~name:txt ~loc + | Ppat_exception p -> scope_pattern ~pattern_path ?context_path p | Ppat_extension _ -> () - | Ppat_open (_, p) -> scopePattern ~patternPath ?contextPath p + | Ppat_open (_, p) -> scope_pattern ~pattern_path ?context_path p in - let locHasCursor = CursorPosition.locHasCursor ~pos:posBeforeCursor in - let locIsEmpty = CursorPosition.locIsEmpty ~pos:posBeforeCursor in - let completePattern ?contextPath (pat : Parsetree.pattern) = + let loc_has_cursor = Cursor_position.loc_has_cursor ~pos:pos_before_cursor in + let loc_is_empty = Cursor_position.loc_is_empty ~pos:pos_before_cursor in + let complete_pattern ?context_path (pat : Parsetree.pattern) = match ( pat - |> CompletionPatterns.traversePattern ~patternPath:[] ~locHasCursor - ~firstCharBeforeCursorNoWhite ~posBeforeCursor, - contextPath ) + |> Completion_patterns.traverse_pattern ~pattern_path:[] ~loc_has_cursor + ~first_char_before_cursor_no_white ~pos_before_cursor, + context_path ) with - | Some (prefix, nestedPattern), Some ctxPath -> + | Some (prefix, nested_pattern), Some ctx_path -> if Debug.verbose () then Printf.printf "[completePattern] found pattern that can be completed\n"; - setResult + set_result (Completable.Cpattern { - contextPath = ctxPath; + context_path = ctx_path; prefix; - nested = List.rev nestedPattern; + nested = List.rev nested_pattern; fallback = None; - patternMode = Default; + pattern_mode = Default; }) | _ -> () in - let scopeValueBinding (vb : Parsetree.value_binding) = - let contextPath = + let scope_value_binding (vb : Parsetree.value_binding) = + let context_path = (* Pipe chains get special treatment here, because when assigning values we want the return of the entire pipe chain as a function call, rather than as a pipe completion call. *) - match completePipeChain ~inJsxContext:!inJsxContext vb.pvb_expr with - | Some (ctxPath, _) -> Some ctxPath - | None -> exprToContextPath ~inJsxContext:!inJsxContext vb.pvb_expr + match complete_pipe_chain ~in_jsx_context:!in_jsx_context vb.pvb_expr with + | Some (ctx_path, _) -> Some ctx_path + | None -> expr_to_context_path ~in_jsx_context:!in_jsx_context vb.pvb_expr in - scopePattern ?contextPath vb.pvb_pat + scope_pattern ?context_path vb.pvb_pat in - let scopeTypeKind (tk : Parsetree.type_kind) = + let scope_type_kind (tk : Parsetree.type_kind) = match tk with - | Ptype_variant constrDecls -> - constrDecls + | Ptype_variant constr_decls -> + constr_decls |> List.iter (fun (cd : Parsetree.constructor_declaration) -> scope := !scope - |> Scope.addConstructor ~name:cd.pcd_name.txt ~loc:cd.pcd_loc) - | Ptype_record labelDecls -> - labelDecls + |> Scope.add_constructor ~name:cd.pcd_name.txt ~loc:cd.pcd_loc) + | Ptype_record label_decls -> + label_decls |> List.iter (fun (ld : Parsetree.label_declaration) -> scope := - !scope |> Scope.addField ~name:ld.pld_name.txt ~loc:ld.pld_loc) + !scope |> Scope.add_field ~name:ld.pld_name.txt ~loc:ld.pld_loc) | _ -> () in - let scopeTypeDeclaration (td : Parsetree.type_declaration) = + let scope_type_declaration (td : Parsetree.type_declaration) = scope := - !scope |> Scope.addType ~name:td.ptype_name.txt ~loc:td.ptype_name.loc; - scopeTypeKind td.ptype_kind + !scope |> Scope.add_type ~name:td.ptype_name.txt ~loc:td.ptype_name.loc; + scope_type_kind td.ptype_kind in - let scopeModuleBinding (mb : Parsetree.module_binding) = + let scope_module_binding (mb : Parsetree.module_binding) = scope := - !scope |> Scope.addModule ~name:mb.pmb_name.txt ~loc:mb.pmb_name.loc + !scope |> Scope.add_module ~name:mb.pmb_name.txt ~loc:mb.pmb_name.loc in - let scopeModuleDeclaration (md : Parsetree.module_declaration) = + let scope_module_declaration (md : Parsetree.module_declaration) = scope := - !scope |> Scope.addModule ~name:md.pmd_name.txt ~loc:md.pmd_name.loc + !scope |> Scope.add_module ~name:md.pmd_name.txt ~loc:md.pmd_name.loc in (* Identifies expressions where we can do typed pattern or expr completion. *) - let typedCompletionExpr (exp : Parsetree.expression) = - let debugTypedCompletionExpr = false in - if exp.pexp_loc |> CursorPosition.locHasCursor ~pos:posBeforeCursor then ( - if Debug.verbose () && debugTypedCompletionExpr then + let typed_completion_expr (exp : Parsetree.expression) = + let debug_typed_completion_expr = false in + if exp.pexp_loc |> Cursor_position.loc_has_cursor ~pos:pos_before_cursor + then ( + if Debug.verbose () && debug_typed_completion_expr then print_endline "[typedCompletionExpr] Has cursor"; match exp.pexp_desc with (* No cases means there's no `|` yet in the switch *) | Pexp_match (({pexp_desc = Pexp_ident _} as expr), []) -> - if Debug.verbose () && debugTypedCompletionExpr then + if Debug.verbose () && debug_typed_completion_expr then print_endline "[typedCompletionExpr] No cases, with ident"; - if locHasCursor expr.pexp_loc then ( - if Debug.verbose () && debugTypedCompletionExpr then + if loc_has_cursor expr.pexp_loc then ( + if Debug.verbose () && debug_typed_completion_expr then print_endline "[typedCompletionExpr] No cases - has cursor"; (* We can do exhaustive switch completion if this is an ident we can complete from. *) - match exprToContextPath ~inJsxContext:!inJsxContext expr with + match expr_to_context_path ~in_jsx_context:!in_jsx_context expr with | None -> () - | Some contextPath -> - setResult (CexhaustiveSwitch {contextPath; exprLoc = exp.pexp_loc})) + | Some context_path -> + set_result + (CexhaustiveSwitch {context_path; expr_loc = exp.pexp_loc})) | Pexp_match (_expr, []) -> (* switch x { } *) - if Debug.verbose () && debugTypedCompletionExpr then + if Debug.verbose () && debug_typed_completion_expr then print_endline "[typedCompletionExpr] No cases, rest"; () | Pexp_match (expr, [{pc_lhs; pc_rhs}]) - when locHasCursor expr.pexp_loc - && CompletionExpressions.isExprHole pc_rhs - && CompletionPatterns.isPatternHole pc_lhs -> + when loc_has_cursor expr.pexp_loc + && Completion_expressions.is_expr_hole pc_rhs + && Completion_patterns.is_pattern_hole pc_lhs -> (* switch x { | } when we're in the switch expr itself. *) - if Debug.verbose () && debugTypedCompletionExpr then + if Debug.verbose () && debug_typed_completion_expr then print_endline "[typedCompletionExpr] No cases (expr and pat holes), rest"; () @@ -649,94 +654,94 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc }; ] ) -> ( (* A single case that's a pattern hole typically means `switch x { | }`. Complete as the pattern itself with nothing nested. *) - match exprToContextPath ~inJsxContext:!inJsxContext exp with + match expr_to_context_path ~in_jsx_context:!in_jsx_context exp with | None -> () - | Some ctxPath -> - setResult + | Some ctx_path -> + set_result (Completable.Cpattern { - contextPath = ctxPath; + context_path = ctx_path; nested = []; prefix = ""; fallback = None; - patternMode = Default; + pattern_mode = Default; })) | Pexp_match (exp, cases) -> ( - if Debug.verbose () && debugTypedCompletionExpr then + if Debug.verbose () && debug_typed_completion_expr then print_endline "[typedCompletionExpr] Has cases"; (* If there's more than one case, or the case isn't a pattern hole, figure out if we're completing another broken parser case (`switch x { | true => () | }` for example). *) - match exp |> exprToContextPath ~inJsxContext:!inJsxContext with + match exp |> expr_to_context_path ~in_jsx_context:!in_jsx_context with | None -> - if Debug.verbose () && debugTypedCompletionExpr then + if Debug.verbose () && debug_typed_completion_expr then print_endline "[typedCompletionExpr] Has cases - no ctx path" - | Some ctxPath -> ( - if Debug.verbose () && debugTypedCompletionExpr then + | Some ctx_path -> ( + if Debug.verbose () && debug_typed_completion_expr then print_endline "[typedCompletionExpr] Has cases - has ctx path"; - let hasCaseWithCursor = + let has_case_with_cursor = cases |> List.find_opt (fun case -> - locHasCursor case.Parsetree.pc_lhs.ppat_loc) + loc_has_cursor case.Parsetree.pc_lhs.ppat_loc) |> Option.is_some in - let hasCaseWithEmptyLoc = + let has_case_with_empty_loc = cases |> List.find_opt (fun case -> - locIsEmpty case.Parsetree.pc_lhs.ppat_loc) + loc_is_empty case.Parsetree.pc_lhs.ppat_loc) |> Option.is_some in - if Debug.verbose () && debugTypedCompletionExpr then + if Debug.verbose () && debug_typed_completion_expr then Printf.printf "[typedCompletionExpr] Has cases - has ctx path - \ hasCaseWithEmptyLoc: %b, hasCaseWithCursor: %b\n" - hasCaseWithEmptyLoc hasCaseWithCursor; - match (hasCaseWithEmptyLoc, hasCaseWithCursor) with + has_case_with_empty_loc has_case_with_cursor; + match (has_case_with_empty_loc, has_case_with_cursor) with | _, true -> (* Always continue if there's a case with the cursor *) () | true, false -> (* If there's no case with the cursor, but a broken parser case, complete for the top level. *) - setResult + set_result (Completable.Cpattern { - contextPath = ctxPath; + context_path = ctx_path; nested = []; prefix = ""; fallback = None; - patternMode = Default; + pattern_mode = Default; }) | false, false -> ())) | _ -> ()) in let structure (iterator : Ast_iterator.iterator) (structure : Parsetree.structure) = - let oldScope = !scope in + let old_scope = !scope in Ast_iterator.default_iterator.structure iterator structure; - scope := oldScope + scope := old_scope in let structure_item (iterator : Ast_iterator.iterator) (item : Parsetree.structure_item) = let processed = ref false in (match item.pstr_desc with | Pstr_open {popen_lid} -> - scope := !scope |> Scope.addOpen ~lid:popen_lid.txt - | Pstr_primitive vd -> scopeValueDescription vd - | Pstr_value (recFlag, bindings) -> - if recFlag = Recursive then bindings |> List.iter scopeValueBinding; + scope := !scope |> Scope.add_open ~lid:popen_lid.txt + | Pstr_primitive vd -> scope_value_description vd + | Pstr_value (rec_flag, bindings) -> + if rec_flag = Recursive then bindings |> List.iter scope_value_binding; bindings |> List.iter (fun vb -> iterator.value_binding iterator vb); - if recFlag = Nonrecursive then bindings |> List.iter scopeValueBinding; + if rec_flag = Nonrecursive then bindings |> List.iter scope_value_binding; processed := true - | Pstr_type (recFlag, decls) -> - if recFlag = Recursive then decls |> List.iter scopeTypeDeclaration; + | Pstr_type (rec_flag, decls) -> + if rec_flag = Recursive then decls |> List.iter scope_type_declaration; decls |> List.iter (fun td -> iterator.type_declaration iterator td); - if recFlag = Nonrecursive then decls |> List.iter scopeTypeDeclaration; + if rec_flag = Nonrecursive then decls |> List.iter scope_type_declaration; processed := true | Pstr_module mb -> iterator.module_binding iterator mb; - scopeModuleBinding mb; + scope_module_binding mb; processed := true | Pstr_recmodule mbs -> - mbs |> List.iter scopeModuleBinding; + mbs |> List.iter scope_module_binding; mbs |> List.iter (fun b -> iterator.module_binding iterator b); processed := true | Pstr_include {pincl_mod = {pmod_desc = med}} -> ( @@ -744,7 +749,7 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc | Pmod_ident {txt = lid; loc} | Pmod_apply ({pmod_desc = Pmod_ident {txt = lid; loc}}, _) -> let module_name = Longident.flatten lid |> String.concat "." in - scope := !scope |> Scope.addInclude ~name:module_name ~loc + scope := !scope |> Scope.add_include ~name:module_name ~loc | _ -> ()) | _ -> ()); if not !processed then @@ -752,26 +757,26 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc in let value_binding (iterator : Ast_iterator.iterator) (value_binding : Parsetree.value_binding) = - let oldInJsxContext = !inJsxContext in - if Utils.isJsxComponent value_binding then inJsxContext := true; + let old_in_jsx_context = !in_jsx_context in + if Utils.is_jsx_component value_binding then in_jsx_context := true; (match value_binding with - | {pvb_pat = {ppat_desc = Ppat_constraint (_pat, coreType)}; pvb_expr} - when locHasCursor pvb_expr.pexp_loc -> ( + | {pvb_pat = {ppat_desc = Ppat_constraint (_pat, core_type)}; pvb_expr} + when loc_has_cursor pvb_expr.pexp_loc -> ( (* Expression with derivable type annotation. E.g: let x: someRecord = {} *) match - ( TypeUtils.contextPathFromCoreType coreType, + ( Type_utils.context_path_from_core_type core_type, pvb_expr - |> CompletionExpressions.traverseExpr ~exprPath:[] - ~pos:posBeforeCursor ~firstCharBeforeCursorNoWhite ) + |> Completion_expressions.traverse_expr ~expr_path:[] + ~pos:pos_before_cursor ~first_char_before_cursor_no_white ) with - | Some ctxPath, Some (prefix, nested) -> - setResult + | Some ctx_path, Some (prefix, nested) -> + set_result (Completable.Cexpression - {contextPath = ctxPath; prefix; nested = List.rev nested}) + {context_path = ctx_path; prefix; nested = List.rev nested}) | _ -> ()) | {pvb_pat = {ppat_desc = Ppat_var {loc}}; pvb_expr} - when locHasCursor pvb_expr.pexp_loc -> ( + when loc_has_cursor pvb_expr.pexp_loc -> ( (* Expression without a type annotation. We can complete this if this has compiled previously and there's a type available for the identifier itself. This is nice because the type is assigned even if the assignment isn't complete. @@ -779,82 +784,83 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc E.g: let x = {name: "name", }, when `x` has compiled. *) match pvb_expr - |> CompletionExpressions.traverseExpr ~exprPath:[] ~pos:posBeforeCursor - ~firstCharBeforeCursorNoWhite + |> Completion_expressions.traverse_expr ~expr_path:[] + ~pos:pos_before_cursor ~first_char_before_cursor_no_white with | Some (prefix, nested) -> (* This completion should be low prio, so let any deeper completion hit first, and only set this TypeAtPos completion if nothing else here hit. *) Ast_iterator.default_iterator.value_binding iterator value_binding; - setResult + set_result (Completable.Cexpression - {contextPath = CTypeAtPos loc; prefix; nested = List.rev nested}) + {context_path = CTypeAtPos loc; prefix; nested = List.rev nested}) | _ -> ()) | { - pvb_pat = {ppat_desc = Ppat_constraint (_pat, coreType); ppat_loc}; + pvb_pat = {ppat_desc = Ppat_constraint (_pat, core_type); ppat_loc}; pvb_expr; } - when locHasCursor value_binding.pvb_loc - && locHasCursor ppat_loc = false - && locHasCursor pvb_expr.pexp_loc = false - && CompletionExpressions.isExprHole pvb_expr -> ( + when loc_has_cursor value_binding.pvb_loc + && loc_has_cursor ppat_loc = false + && loc_has_cursor pvb_expr.pexp_loc = false + && Completion_expressions.is_expr_hole pvb_expr -> ( (* Expression with derivable type annotation, when the expression is empty (expr hole). E.g: let x: someRecord = *) - match TypeUtils.contextPathFromCoreType coreType with - | Some ctxPath -> - setResult + match Type_utils.context_path_from_core_type core_type with + | Some ctx_path -> + set_result (Completable.Cexpression - {contextPath = ctxPath; prefix = ""; nested = []}) + {context_path = ctx_path; prefix = ""; nested = []}) | _ -> ()) - | {pvb_pat; pvb_expr} when locHasCursor pvb_pat.ppat_loc -> ( + | {pvb_pat; pvb_expr} when loc_has_cursor pvb_pat.ppat_loc -> ( (* Completing a destructuring. E.g: let {} = someVar *) match ( pvb_pat - |> CompletionPatterns.traversePattern ~patternPath:[] ~locHasCursor - ~firstCharBeforeCursorNoWhite ~posBeforeCursor, - exprToContextPath ~inJsxContext:!inJsxContext pvb_expr ) + |> Completion_patterns.traverse_pattern ~pattern_path:[] + ~loc_has_cursor ~first_char_before_cursor_no_white + ~pos_before_cursor, + expr_to_context_path ~in_jsx_context:!in_jsx_context pvb_expr ) with - | Some (prefix, nested), Some ctxPath -> - setResult + | Some (prefix, nested), Some ctx_path -> + set_result (Completable.Cpattern { - contextPath = ctxPath; + context_path = ctx_path; prefix; nested = List.rev nested; fallback = None; - patternMode = Destructuring; + pattern_mode = Destructuring; }) | _ -> ()) | _ -> ()); Ast_iterator.default_iterator.value_binding iterator value_binding; - inJsxContext := oldInJsxContext + in_jsx_context := old_in_jsx_context in let signature (iterator : Ast_iterator.iterator) (signature : Parsetree.signature) = - let oldScope = !scope in + let old_scope = !scope in Ast_iterator.default_iterator.signature iterator signature; - scope := oldScope + scope := old_scope in let signature_item (iterator : Ast_iterator.iterator) (item : Parsetree.signature_item) = let processed = ref false in (match item.psig_desc with | Psig_open {popen_lid} -> - scope := !scope |> Scope.addOpen ~lid:popen_lid.txt - | Psig_value vd -> scopeValueDescription vd - | Psig_type (recFlag, decls) -> - if recFlag = Recursive then decls |> List.iter scopeTypeDeclaration; + scope := !scope |> Scope.add_open ~lid:popen_lid.txt + | Psig_value vd -> scope_value_description vd + | Psig_type (rec_flag, decls) -> + if rec_flag = Recursive then decls |> List.iter scope_type_declaration; decls |> List.iter (fun td -> iterator.type_declaration iterator td); - if recFlag = Nonrecursive then decls |> List.iter scopeTypeDeclaration; + if rec_flag = Nonrecursive then decls |> List.iter scope_type_declaration; processed := true | Psig_module md -> iterator.module_declaration iterator md; - scopeModuleDeclaration md; + scope_module_declaration md; processed := true | Psig_recmodule mds -> - mds |> List.iter scopeModuleDeclaration; + mds |> List.iter scope_module_declaration; mds |> List.iter (fun d -> iterator.module_declaration iterator d); processed := true | _ -> ()); @@ -866,18 +872,19 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc (if String.length id.txt >= 4 && String.sub id.txt 0 4 = "res." then (* skip: internal parser attribute *) () else if id.loc.loc_ghost then () - else if id.loc |> Loc.hasPos ~pos:posBeforeCursor then - let posStart, posEnd = Loc.range id.loc in + else if id.loc |> Loc.has_pos ~pos:pos_before_cursor then + let pos_start, pos_end = Loc.range id.loc in match - (Pos.positionToOffset text posStart, Pos.positionToOffset text posEnd) + ( Pos.position_to_offset text pos_start, + Pos.position_to_offset text pos_end ) with - | Some offsetStart, Some offsetEnd - when offsetStart >= 0 && offsetEnd >= offsetStart -> + | Some offset_start, Some offset_end + when offset_start >= 0 && offset_end >= offset_start -> (* Can't trust the parser's location E.g. @foo. let x... gives as label @foo.let *) let label = - let rawLabel = - String.sub text offsetStart (offsetEnd - offsetStart) + let raw_label = + String.sub text offset_start (offset_end - offset_start) in let ( ++ ) x y = match (x, y) with @@ -887,13 +894,13 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc in let label = match - String.index_opt rawLabel ' ' - ++ String.index_opt rawLabel '\t' - ++ String.index_opt rawLabel '\r' - ++ String.index_opt rawLabel '\n' + String.index_opt raw_label ' ' + ++ String.index_opt raw_label '\t' + ++ String.index_opt raw_label '\r' + ++ String.index_opt raw_label '\n' with - | None -> rawLabel - | Some i -> String.sub rawLabel 0 i + | None -> raw_label + | Some i -> String.sub raw_label 0 i in if label <> "" && label.[0] = '@' then String.sub label 1 (String.length label - 1) @@ -902,8 +909,8 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc found := true; if debug then Printf.printf "Attribute id:%s:%s label:%s\n" id.txt - (Loc.toString id.loc) label; - setResult (Completable.Cdecorator label) + (Loc.to_string id.loc) label; + set_result (Completable.Cdecorator label) | _ -> () else if id.txt = "module" then match payload with @@ -916,10 +923,10 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc _ ); }; ] - when locHasCursor pexp_loc -> + when loc_has_cursor pexp_loc -> if Debug.verbose () then print_endline "[decoratorCompletion] Found @module"; - setResult (Completable.CdecoratorPayload (Module s)) + set_result (Completable.CdecoratorPayload (Module s)) | PStr [ { @@ -928,48 +935,48 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc ( { pexp_desc = Pexp_record - ({lid = {txt = Lident "from"}; x = fromExpr} :: _, _); + ({lid = {txt = Lident "from"}; x = from_expr} :: _, _); }, _ ); }; ] - when locHasCursor fromExpr.pexp_loc - || locIsEmpty fromExpr.pexp_loc - && CompletionExpressions.isExprHole fromExpr -> ( + when loc_has_cursor from_expr.pexp_loc + || loc_is_empty from_expr.pexp_loc + && Completion_expressions.is_expr_hole from_expr -> ( if Debug.verbose () then print_endline "[decoratorCompletion] Found @module with import attributes and \ cursor on \"from\""; match - ( locHasCursor fromExpr.pexp_loc, - locIsEmpty fromExpr.pexp_loc, - CompletionExpressions.isExprHole fromExpr, - fromExpr ) + ( loc_has_cursor from_expr.pexp_loc, + loc_is_empty from_expr.pexp_loc, + Completion_expressions.is_expr_hole from_expr, + from_expr ) with | true, _, _, {pexp_desc = Pexp_constant (Pconst_string (s, _))} -> if Debug.verbose () then print_endline "[decoratorCompletion] @module `from` payload was string"; - setResult (Completable.CdecoratorPayload (Module s)) + set_result (Completable.CdecoratorPayload (Module s)) | false, true, true, _ -> if Debug.verbose () then print_endline "[decoratorCompletion] @module `from` payload was expr hole"; - setResult (Completable.CdecoratorPayload (Module "")) + set_result (Completable.CdecoratorPayload (Module "")) | _ -> ()) | PStr [{pstr_desc = Pstr_eval (expr, _)}] -> ( if Debug.verbose () then print_endline "[decoratorCompletion] Found @module with non-string payload"; match - CompletionExpressions.traverseExpr expr ~exprPath:[] - ~pos:posBeforeCursor ~firstCharBeforeCursorNoWhite + Completion_expressions.traverse_expr expr ~expr_path:[] + ~pos:pos_before_cursor ~first_char_before_cursor_no_white with | None -> () | Some (prefix, nested) -> if Debug.verbose () then print_endline "[decoratorCompletion] Found @module record path"; - setResult + set_result (Completable.CdecoratorPayload (ModuleWithImportAttributes {nested = List.rev nested; prefix})) ) @@ -980,14 +987,14 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc if Debug.verbose () then print_endline "[decoratorCompletion] Found @jsxConfig"; match - CompletionExpressions.traverseExpr expr ~exprPath:[] - ~pos:posBeforeCursor ~firstCharBeforeCursorNoWhite + Completion_expressions.traverse_expr expr ~expr_path:[] + ~pos:pos_before_cursor ~first_char_before_cursor_no_white with | None -> () | Some (prefix, nested) -> if Debug.verbose () then print_endline "[decoratorCompletion] Found @jsxConfig path!"; - setResult + set_result (Completable.CdecoratorPayload (JsxConfig {nested = List.rev nested; prefix}))) | _ -> () @@ -1005,141 +1012,144 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc _ ); }; ] - when locHasCursor pexp_loc -> + when loc_has_cursor pexp_loc -> if Debug.verbose () then print_endline "[decoratorCompletion] Found @editor.completeFrom"; - setResult + set_result (Completable.Cpath (CPId { - path = Utils.flattenLongIdent path; - completionContext = Module; + path = Utils.flatten_long_ident path; + completion_context = Module; loc; })) | _ -> ()); Ast_iterator.default_iterator.attribute iterator (id, payload) in - let rec iterateFnArguments ~args ~iterator ~isPipe - (argCompletable : Completable.t option) = - match argCompletable with + let rec iterate_fn_arguments ~args ~iterator ~is_pipe + (arg_completable : Completable.t option) = + match arg_completable with | None -> ( - match !currentCtxPath with + match !current_ctx_path with | None -> () - | Some functionContextPath -> - let currentUnlabelledCount = ref (if isPipe then 1 else 0) in + | Some function_context_path -> + let current_unlabelled_count = ref (if is_pipe then 1 else 0) in args |> List.iter (fun (arg : arg) -> - let previousCtxPath = !currentCtxPath in - setCurrentCtxPath + let previous_ctx_path = !current_ctx_path in + set_current_ctx_path (CArgument { - functionContextPath; - argumentLabel = + function_context_path; + argument_label = (match arg with | {label = None} -> - let current = !currentUnlabelledCount in - currentUnlabelledCount := current + 1; - Unlabelled {argumentPosition = current} + let current = !current_unlabelled_count in + current_unlabelled_count := current + 1; + Unlabelled {argument_position = current} | {label = Some {name; opt = true}} -> Optional name | {label = Some {name; opt = false}} -> Labelled name); }); expr iterator arg.exp; - resetCurrentCtxPath previousCtxPath)) - | Some argCompletable -> setResult argCompletable - and iterateJsxProps ~iterator (props : CompletionJsx.jsxProps) = + reset_current_ctx_path previous_ctx_path)) + | Some arg_completable -> set_result arg_completable + and iterate_jsx_props ~iterator (props : Completion_jsx.jsx_props) = props.props - |> List.iter (fun (prop : CompletionJsx.prop) -> - let previousCtxPath = !currentCtxPath in - setCurrentCtxPath + |> List.iter (fun (prop : Completion_jsx.prop) -> + let previous_ctx_path = !current_ctx_path in + set_current_ctx_path (CJsxPropValue { - pathToComponent = - Utils.flattenLongIdent ~jsx:true props.compName.txt; - propName = prop.name; - emptyJsxPropNameHint = None; + path_to_component = + Utils.flatten_long_ident ~jsx:true props.comp_name.txt; + prop_name = prop.name; + empty_jsx_prop_name_hint = None; }); expr iterator prop.exp; - resetCurrentCtxPath previousCtxPath) + reset_current_ctx_path previous_ctx_path) and expr (iterator : Ast_iterator.iterator) (expr : Parsetree.expression) = - let oldInJsxContext = !inJsxContext in + let old_in_jsx_context = !in_jsx_context in let processed = ref false in - let setFound () = + let set_found () = found := true; if debug then Printf.printf "posCursor:[%s] posNoWhite:[%s] Found expr:%s\n" - (Pos.toString posCursor) (Pos.toString posNoWhite) - (Loc.toString expr.pexp_loc) + (Pos.to_string pos_cursor) + (Pos.to_string pos_no_white) + (Loc.to_string expr.pexp_loc) in - (match findThisExprLoc with + (match find_this_expr_loc with | Some loc when expr.pexp_loc = loc -> ( - match exprToContextPath ~inJsxContext:!inJsxContext expr with + match expr_to_context_path ~in_jsx_context:!in_jsx_context expr with | None -> () - | Some ctxPath -> setResult (Cpath ctxPath)) + | Some ctx_path -> set_result (Cpath ctx_path)) | _ -> ()); - let setPipeResult ~(lhs : Parsetree.expression) ~id = - match completePipeChain ~inJsxContext:!inJsxContext lhs with + let set_pipe_result ~(lhs : Parsetree.expression) ~id = + match complete_pipe_chain ~in_jsx_context:!in_jsx_context lhs with | None -> ( - match exprToContextPath ~inJsxContext:!inJsxContext lhs with + match expr_to_context_path ~in_jsx_context:!in_jsx_context lhs with | Some pipe -> - setResult + set_result (Cpath (CPPipe { synthetic = false; - contextPath = pipe; + context_path = pipe; id; - lhsLoc = lhs.pexp_loc; - inJsx = !inJsxContext; + lhs_loc = lhs.pexp_loc; + in_jsx = !in_jsx_context; })); true | None -> false) - | Some (pipe, lhsLoc) -> - setResult + | Some (pipe, lhs_loc) -> + set_result (Cpath (CPPipe { synthetic = false; - contextPath = pipe; + context_path = pipe; id; - lhsLoc; - inJsx = !inJsxContext; + lhs_loc; + in_jsx = !in_jsx_context; })); true in - typedCompletionExpr expr; + typed_completion_expr expr; match expr.pexp_desc with | Pexp_match (expr, cases) when cases <> [] - && locHasCursor expr.pexp_loc = false - && Option.is_none findThisExprLoc -> + && loc_has_cursor expr.pexp_loc = false + && Option.is_none find_this_expr_loc -> if Debug.verbose () then print_endline "[completionFrontend] Checking each case"; - let ctxPath = exprToContextPath ~inJsxContext:!inJsxContext expr in - let oldCtxPath = !currentCtxPath in + let ctx_path = + expr_to_context_path ~in_jsx_context:!in_jsx_context expr + in + let old_ctx_path = !current_ctx_path in cases |> List.iter (fun (case : Parsetree.case) -> - let oldScope = !scope in + let old_scope = !scope in if - locHasCursor case.pc_rhs.pexp_loc = false - && locHasCursor case.pc_lhs.ppat_loc - then completePattern ?contextPath:ctxPath case.pc_lhs; - scopePattern ?contextPath:ctxPath case.pc_lhs; + loc_has_cursor case.pc_rhs.pexp_loc = false + && loc_has_cursor case.pc_lhs.ppat_loc + then complete_pattern ?context_path:ctx_path case.pc_lhs; + scope_pattern ?context_path:ctx_path case.pc_lhs; Ast_iterator.default_iterator.case iterator case; - scope := oldScope); - resetCurrentCtxPath oldCtxPath + scope := old_scope); + reset_current_ctx_path old_ctx_path | Pexp_apply { - funct = {pexp_desc = Pexp_ident {txt = Lident "->"; loc = opLoc}}; + funct = {pexp_desc = Pexp_ident {txt = Lident "->"; loc = op_loc}}; args = [ (_, lhs); (_, {pexp_desc = Pexp_extension _; pexp_loc = {loc_ghost = true}}); ]; } - when opLoc |> Loc.hasPos ~pos:posBeforeCursor -> + when op_loc |> Loc.has_pos ~pos:pos_before_cursor -> (* Case foo-> when the parser adds a ghost expression to the rhs so the apply expression does not include the cursor *) - if setPipeResult ~lhs ~id:"" then setFound () + if set_pipe_result ~lhs ~id:"" then set_found () (* A dot completion for a tagged templated application with an expr hole. Example: @@ -1151,25 +1161,25 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc args = [ (* sh`echo "meh"` *) - (_, ({pexp_desc = Pexp_apply _} as innerExpr)); + (_, ({pexp_desc = Pexp_apply _} as inner_expr)); (* recovery inserted node *) (_, {pexp_desc = Pexp_extension ({txt = "rescript.exprhole"}, _)}); ]; } - when Res_parsetree_viewer.is_tagged_template_literal innerExpr -> - exprToContextPath ~inJsxContext:!inJsxContext innerExpr + when Res_parsetree_viewer.is_tagged_template_literal inner_expr -> + expr_to_context_path ~in_jsx_context:!in_jsx_context inner_expr |> Option.iter (fun cpath -> - setResult + set_result (Cpath (CPField { - contextPath = cpath; - fieldName = ""; - posOfDot; - exprLoc = expr.pexp_loc; - inJsx = !inJsxContext; + context_path = cpath; + field_name = ""; + pos_of_dot; + expr_loc = expr.pexp_loc; + in_jsx = !in_jsx_context; })); - setFound ()) + set_found ()) (* A dot completion for a tagged templated application with an ident. Example: @@ -1181,166 +1191,166 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc args = [ (* sh`echo "meh"` *) - (_, ({pexp_desc = Pexp_apply _} as innerExpr)); + (_, ({pexp_desc = Pexp_apply _} as inner_expr)); (* foo *) - (_, {pexp_desc = Pexp_ident {txt = Lident fieldName}}); + (_, {pexp_desc = Pexp_ident {txt = Lident field_name}}); ]; } - when Res_parsetree_viewer.is_tagged_template_literal innerExpr - && expr.pexp_loc |> Loc.hasPos ~pos:posBeforeCursor -> - exprToContextPath ~inJsxContext:!inJsxContext innerExpr + when Res_parsetree_viewer.is_tagged_template_literal inner_expr + && expr.pexp_loc |> Loc.has_pos ~pos:pos_before_cursor -> + expr_to_context_path ~in_jsx_context:!in_jsx_context inner_expr |> Option.iter (fun cpath -> - setResult + set_result (Cpath (CPField { - contextPath = cpath; - fieldName; - posOfDot; - exprLoc = expr.pexp_loc; - inJsx = !inJsxContext; + context_path = cpath; + field_name; + pos_of_dot; + expr_loc = expr.pexp_loc; + in_jsx = !in_jsx_context; })); - setFound ()) + set_found ()) | _ -> ( - if expr.pexp_loc |> Loc.hasPos ~pos:posNoWhite && !result = None then ( - setFound (); + if expr.pexp_loc |> Loc.has_pos ~pos:pos_no_white && !result = None then ( + set_found (); match expr.pexp_desc with | Pexp_extension ({txt = "obj"}, PStr [str_item]) -> Ast_iterator.default_iterator.structure_item iterator str_item - | Pexp_extension ({txt}, _) -> setResult (CextensionNode txt) - | Pexp_constant _ -> setResult Cnone + | Pexp_extension ({txt}, _) -> set_result (CextensionNode txt) + | Pexp_constant _ -> set_result Cnone | Pexp_ident lid -> - let lidPath = flattenLidCheckDot lid in + let lid_path = flatten_lid_check_dot lid in if debug then Printf.printf "Pexp_ident %s:%s\n" - (lidPath |> String.concat ".") - (Loc.toString lid.loc); - if lid.loc |> Loc.hasPos ~pos:posBeforeCursor then - let isLikelyModulePath = - match lidPath with + (lid_path |> String.concat ".") + (Loc.to_string lid.loc); + if lid.loc |> Loc.has_pos ~pos:pos_before_cursor then + let is_likely_module_path = + match lid_path with | head :: _ when String.length head > 0 && head.[0] == Char.uppercase_ascii head.[0] -> true | _ -> false in - setResult + set_result (Cpath (CPId { loc = lid.loc; - path = lidPath; - completionContext = + path = lid_path; + completion_context = (if - isLikelyModulePath + is_likely_module_path && expr |> Res_parsetree_viewer.is_braced_expr then ValueOrField else Value); })) - | Pexp_construct (lid, eOpt) -> ( - let lidPath = flattenLidCheckDot lid in + | Pexp_construct (lid, e_opt) -> ( + let lid_path = flatten_lid_check_dot lid in if debug then Printf.printf "Pexp_construct %s:%s %s\n" - (lidPath |> String.concat "\n") - (Loc.toString lid.loc) - (match eOpt with + (lid_path |> String.concat "\n") + (Loc.to_string lid.loc) + (match e_opt with | None -> "None" - | Some e -> Loc.toString e.pexp_loc); + | Some e -> Loc.to_string e.pexp_loc); if - eOpt = None && (not lid.loc.loc_ghost) - && lid.loc |> Loc.hasPos ~pos:posBeforeCursor + e_opt = None && (not lid.loc.loc_ghost) + && lid.loc |> Loc.has_pos ~pos:pos_before_cursor then - setResult + set_result (Cpath (CPId - {loc = lid.loc; path = lidPath; completionContext = Value})) + {loc = lid.loc; path = lid_path; completion_context = Value})) else - match eOpt with - | Some e when locHasCursor e.pexp_loc -> ( + match e_opt with + | Some e when loc_has_cursor e.pexp_loc -> ( match - CompletionExpressions.completeConstructorPayload - ~posBeforeCursor ~firstCharBeforeCursorNoWhite lid e + Completion_expressions.complete_constructor_payload + ~pos_before_cursor ~first_char_before_cursor_no_white lid e with | Some result -> (* Check if anything else more important completes before setting this completion. *) Ast_iterator.default_iterator.expr iterator e; - setResult result + set_result result | None -> ()) | _ -> ()) - | Pexp_field (e, fieldName) -> ( + | Pexp_field (e, field_name) -> ( if debug then - Printf.printf "Pexp_field %s %s:%s\n" (Loc.toString e.pexp_loc) - (Utils.flattenLongIdent fieldName.txt |> String.concat ".") - (Loc.toString fieldName.loc); - if fieldName.loc |> Loc.hasPos ~pos:posBeforeCursor then - match fieldName.txt with + Printf.printf "Pexp_field %s %s:%s\n" (Loc.to_string e.pexp_loc) + (Utils.flatten_long_ident field_name.txt |> String.concat ".") + (Loc.to_string field_name.loc); + if field_name.loc |> Loc.has_pos ~pos:pos_before_cursor then + match field_name.txt with | Lident name -> ( - match exprToContextPath ~inJsxContext:!inJsxContext e with - | Some contextPath -> - let contextPath = + match expr_to_context_path ~in_jsx_context:!in_jsx_context e with + | Some context_path -> + let context_path = Completable.CPField { - contextPath; - fieldName = name; - posOfDot; - exprLoc = e.pexp_loc; - inJsx = !inJsxContext; + context_path; + field_name = name; + pos_of_dot; + expr_loc = e.pexp_loc; + in_jsx = !in_jsx_context; } in - setResult (Cpath contextPath) + set_result (Cpath context_path) | None -> ()) | Ldot (id, name) -> (* Case x.M.field ignore the x part *) - let contextPath = + let context_path = Completable.CPField { - contextPath = + context_path = CPId { - loc = fieldName.loc; - path = Utils.flattenLongIdent id; - completionContext = Module; + loc = field_name.loc; + path = Utils.flatten_long_ident id; + completion_context = Module; }; - fieldName = - (if blankAfterCursor = Some '.' then + field_name = + (if blank_after_cursor = Some '.' then (* x.M. field ---> M. *) "" else if name = "_" then "" else name); - posOfDot; - exprLoc = e.pexp_loc; - inJsx = !inJsxContext; + pos_of_dot; + expr_loc = e.pexp_loc; + in_jsx = !in_jsx_context; } in - setResult (Cpath contextPath) + set_result (Cpath context_path) | Lapply _ -> () - else if Loc.end_ e.pexp_loc = posBeforeCursor then - match exprToContextPath ~inJsxContext:!inJsxContext e with - | Some contextPath -> - setResult + else if Loc.end_ e.pexp_loc = pos_before_cursor then + match expr_to_context_path ~in_jsx_context:!in_jsx_context e with + | Some context_path -> + set_result (Cpath (CPField { - contextPath; - fieldName = ""; - posOfDot; - exprLoc = e.pexp_loc; - inJsx = !inJsxContext; + context_path; + field_name = ""; + pos_of_dot; + expr_loc = e.pexp_loc; + in_jsx = !in_jsx_context; })) | None -> ()) | Pexp_jsx_element ( Jsx_unary_element { - jsx_unary_element_tag_name = compName; + jsx_unary_element_tag_name = comp_name; jsx_unary_element_props = props; } | Jsx_container_element { - jsx_container_element_tag_name_start = compName; + jsx_container_element_tag_name_start = comp_name; jsx_container_element_props = props; } ) -> ( - inJsxContext := true; + in_jsx_context := true; let is_valid_tag_for_props = - match compName.txt with + match comp_name.txt with | Parsetree.JsxTagInvalid _ -> false | _ -> true in @@ -1352,58 +1362,59 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc children | _ -> [] in - let compName_loc = compName.loc in + let compName_loc = comp_name.loc in let compName_lid = - Ast_helper.Jsx.longident_of_jsx_tag_name compName.txt + Ast_helper.Jsx.longident_of_jsx_tag_name comp_name.txt in - let jsxPropsOpt = + let jsx_props_opt = if is_valid_tag_for_props then Some - (CompletionJsx.extractJsxProps - ~compName:(Location.mkloc compName_lid compName_loc) + (Completion_jsx.extract_jsx_props + ~comp_name:(Location.mkloc compName_lid compName_loc) ~props ~children) else None in - let compNamePath = - flattenLidCheckDot ~jsx:true + let comp_name_path = + flatten_lid_check_dot ~jsx:true {txt = compName_lid; loc = compName_loc} in (if debug then - match jsxPropsOpt with - | Some jsxProps -> + match jsx_props_opt with + | Some jsx_props -> Printf.printf "JSX <%s:%s %s> _children:%s\n" - (compNamePath |> String.concat ".") - (Loc.toString compName_loc) - (jsxProps.props + (comp_name_path |> String.concat ".") + (Loc.to_string compName_loc) + (jsx_props.props |> List.map (fun - ({name; posStart; posEnd; exp} : CompletionJsx.prop) -> + ({name; pos_start; pos_end; exp} : Completion_jsx.prop) + -> Printf.sprintf "%s[%s->%s]=...%s" name - (Pos.toString posStart) (Pos.toString posEnd) - (Loc.toString exp.pexp_loc)) + (Pos.to_string pos_start) (Pos.to_string pos_end) + (Loc.to_string exp.pexp_loc)) |> String.concat " ") - (match jsxProps.childrenStart with + (match jsx_props.children_start with | None -> "None" - | Some childrenPosStart -> Pos.toString childrenPosStart) + | Some children_pos_start -> Pos.to_string children_pos_start) | None -> Printf.printf "JSX <%s:%s > _children:None\n" - (compNamePath |> String.concat ".") - (Loc.toString compName_loc)); + (comp_name_path |> String.concat ".") + (Loc.to_string compName_loc)); (* If the tag name is an uppercase path and the cursor is right after a dot (e.g., - setResult + (match comp_name.txt with + | Parsetree.JsxUpperTag _ when blank_after_cursor = Some '.' -> + set_result (Cpath (CPId { loc = compName_loc; - path = compNamePath; - completionContext = Module; + path = comp_name_path; + completion_context = Module; })) | _ -> ()); - let jsxCompletable = - match (jsxPropsOpt, expr.pexp_desc) with + let jsx_completable = + match (jsx_props_opt, expr.pexp_desc) with | ( Some _, Pexp_jsx_element (Jsx_container_element @@ -1412,22 +1423,22 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc jsx_container_element_children = _ :: _; }) ) -> None - | Some jsxProps, _ -> - CompletionJsx.findJsxPropsCompletable ~jsxProps - ~endPos:(Loc.end_ expr.pexp_loc) ~posBeforeCursor - ~posAfterCompName:(Loc.end_ compName_loc) - ~firstCharBeforeCursorNoWhite ~charAtCursor + | Some jsx_props, _ -> + Completion_jsx.find_jsx_props_completable ~jsx_props + ~end_pos:(Loc.end_ expr.pexp_loc) ~pos_before_cursor + ~pos_after_comp_name:(Loc.end_ compName_loc) + ~first_char_before_cursor_no_white ~char_at_cursor | None, _ -> None in - (match jsxCompletable with - | Some _ as res -> setResultOpt res + (match jsx_completable with + | Some _ as res -> set_result_opt res | None -> ()); if - jsxCompletable = None - && compName_loc |> Loc.hasPos ~pos:posBeforeCursor + jsx_completable = None + && compName_loc |> Loc.has_pos ~pos:pos_before_cursor then - setResult - (match compNamePath with + set_result + (match comp_name_path with | [prefix] when Char.lowercase_ascii prefix.[0] = prefix.[0] -> ChtmlElement {prefix} | _ -> @@ -1435,12 +1446,12 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc (CPId { loc = compName_loc; - path = compNamePath; - completionContext = Module; + path = comp_name_path; + completion_context = Module; })) else - match jsxPropsOpt with - | Some jsxProps -> iterateJsxProps ~iterator jsxProps + match jsx_props_opt with + | Some jsx_props -> iterate_jsx_props ~iterator jsx_props | None -> ()) | Pexp_apply { @@ -1451,55 +1462,56 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc (_, {pexp_desc = Pexp_ident {txt = Longident.Lident id; loc}}); ]; } - when loc |> Loc.hasPos ~pos:posBeforeCursor -> + when loc |> Loc.has_pos ~pos:pos_before_cursor -> if Debug.verbose () then print_endline "[expr_iter] Case foo->id"; - setPipeResult ~lhs ~id |> ignore + set_pipe_result ~lhs ~id |> ignore | Pexp_apply { - funct = {pexp_desc = Pexp_ident {txt = Lident "->"; loc = opLoc}}; + funct = {pexp_desc = Pexp_ident {txt = Lident "->"; loc = op_loc}}; args = [(_, lhs); _]; } - when Loc.end_ opLoc = posCursor -> + when Loc.end_ op_loc = pos_cursor -> if Debug.verbose () then print_endline "[expr_iter] Case foo->"; - setPipeResult ~lhs ~id:"" |> ignore + set_pipe_result ~lhs ~id:"" |> ignore | Pexp_apply { funct = {pexp_desc = Pexp_ident {txt = Lident "->"}}; - args = [_; (_, {pexp_desc = Pexp_apply {funct = funExpr; args}})]; + args = [_; (_, {pexp_desc = Pexp_apply {funct = fun_expr; args}})]; } when (* Normally named arg completion fires when the cursor is right after the expression. E.g in foo(~<---there But it should not fire in foo(~a)<---there *) not - (Loc.end_ expr.pexp_loc = posCursor - && charBeforeCursor = Some ')') -> ( + (Loc.end_ expr.pexp_loc = pos_cursor + && char_before_cursor = Some ')') -> ( (* Complete fn argument values and named args when the fn call is piped. E.g. someVar->someFn(). *) if Debug.verbose () then print_endline "[expr_iter] Complete fn arguments (piped)"; - let args = extractExpApplyArgs ~args in - let funCtxPath = - exprToContextPath ~inJsxContext:!inJsxContext funExpr + let args = extract_exp_apply_args ~args in + let fun_ctx_path = + expr_to_context_path ~in_jsx_context:!in_jsx_context fun_expr in - let argCompletable = - match funCtxPath with - | Some contextPath -> - findArgCompletables ~contextPath ~args - ~endPos:(Loc.end_ expr.pexp_loc) ~posBeforeCursor - ~posAfterFunExpr:(Loc.end_ funExpr.pexp_loc) - ~charBeforeCursor ~isPipedExpr:true - ~firstCharBeforeCursorNoWhite + let arg_completable = + match fun_ctx_path with + | Some context_path -> + find_arg_completables ~context_path ~args + ~end_pos:(Loc.end_ expr.pexp_loc) ~pos_before_cursor + ~pos_after_fun_expr:(Loc.end_ fun_expr.pexp_loc) + ~char_before_cursor ~is_piped_expr:true + ~first_char_before_cursor_no_white | None -> None in - match argCompletable with + match arg_completable with | None -> ( - match funCtxPath with + match fun_ctx_path with | None -> () - | Some funCtxPath -> - let oldCtxPath = !currentCtxPath in - setCurrentCtxPath funCtxPath; - argCompletable |> iterateFnArguments ~isPipe:true ~args ~iterator; - resetCurrentCtxPath oldCtxPath) - | Some argCompletable -> setResult argCompletable) + | Some fun_ctx_path -> + let old_ctx_path = !current_ctx_path in + set_current_ctx_path fun_ctx_path; + arg_completable + |> iterate_fn_arguments ~is_pipe:true ~args ~iterator; + reset_current_ctx_path old_ctx_path) + | Some arg_completable -> set_result arg_completable) | Pexp_apply { funct = {pexp_desc = Pexp_ident {txt = Lident "->"}}; @@ -1507,189 +1519,195 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc } -> (* Ignore any other pipe. *) () - | Pexp_apply {funct = funExpr; args} + | Pexp_apply {funct = fun_expr; args} when not - (Loc.end_ expr.pexp_loc = posCursor - && charBeforeCursor = Some ')') -> ( + (Loc.end_ expr.pexp_loc = pos_cursor + && char_before_cursor = Some ')') -> ( (* Complete fn argument values and named args when the fn call is _not_ piped. E.g. someFn(). *) if Debug.verbose () then print_endline "[expr_iter] Complete fn arguments (not piped)"; - let args = extractExpApplyArgs ~args in + let args = extract_exp_apply_args ~args in if debug then Printf.printf "Pexp_apply ...%s (%s)\n" - (Loc.toString funExpr.pexp_loc) + (Loc.to_string fun_expr.pexp_loc) (args |> List.map (fun {label; exp} -> Printf.sprintf "%s...%s" (match label with | None -> "" - | Some {name; opt; posStart; posEnd} -> - "~" ^ name ^ Pos.toString posStart ^ "->" - ^ Pos.toString posEnd ^ "=" + | Some {name; opt; pos_start; pos_end} -> + "~" ^ name ^ Pos.to_string pos_start ^ "->" + ^ Pos.to_string pos_end ^ "=" ^ if opt then "?" else "") - (Loc.toString exp.pexp_loc)) + (Loc.to_string exp.pexp_loc)) |> String.concat ", "); - let funCtxPath = - exprToContextPath ~inJsxContext:!inJsxContext funExpr + let fun_ctx_path = + expr_to_context_path ~in_jsx_context:!in_jsx_context fun_expr in - let argCompletable = - match funCtxPath with - | Some contextPath -> - findArgCompletables ~contextPath ~args - ~endPos:(Loc.end_ expr.pexp_loc) ~posBeforeCursor - ~posAfterFunExpr:(Loc.end_ funExpr.pexp_loc) - ~charBeforeCursor ~isPipedExpr:false - ~firstCharBeforeCursorNoWhite + let arg_completable = + match fun_ctx_path with + | Some context_path -> + find_arg_completables ~context_path ~args + ~end_pos:(Loc.end_ expr.pexp_loc) ~pos_before_cursor + ~pos_after_fun_expr:(Loc.end_ fun_expr.pexp_loc) + ~char_before_cursor ~is_piped_expr:false + ~first_char_before_cursor_no_white | None -> None in - match argCompletable with + match arg_completable with | None -> ( - match funCtxPath with + match fun_ctx_path with | None -> () - | Some funCtxPath -> - let oldCtxPath = !currentCtxPath in - setCurrentCtxPath funCtxPath; - argCompletable |> iterateFnArguments ~isPipe:false ~args ~iterator; - resetCurrentCtxPath oldCtxPath) - | Some argCompletable -> setResult argCompletable) + | Some fun_ctx_path -> + let old_ctx_path = !current_ctx_path in + set_current_ctx_path fun_ctx_path; + arg_completable + |> iterate_fn_arguments ~is_pipe:false ~args ~iterator; + reset_current_ctx_path old_ctx_path) + | Some arg_completable -> set_result arg_completable) | Pexp_send (lhs, {txt; loc}) -> ( (* e["txt"] If the string for txt is not closed, it could go over several lines. Only take the first like to represent the label *) - let txtLines = txt |> String.split_on_char '\n' in - let label = List.hd txtLines in + let txt_lines = txt |> String.split_on_char '\n' in + let label = List.hd txt_lines in let label = if label <> "" && label.[String.length label - 1] = '\r' then String.sub label 0 (String.length label - 1) else label in - let labelRange = + let label_range = let l, c = Loc.start loc in ((l, c + 1), (l, c + 1 + String.length label)) in if debug then Printf.printf "Pexp_send %s%s e:%s\n" label - (Range.toString labelRange) - (Loc.toString lhs.pexp_loc); + (Range.to_string label_range) + (Loc.to_string lhs.pexp_loc); if - labelRange |> Range.hasPos ~pos:posBeforeCursor - || (label = "" && posCursor = fst labelRange) + label_range |> Range.has_pos ~pos:pos_before_cursor + || (label = "" && pos_cursor = fst label_range) then - match exprToContextPath ~inJsxContext:!inJsxContext lhs with - | Some contextPath -> setResult (Cpath (CPObj (contextPath, label))) + match expr_to_context_path ~in_jsx_context:!in_jsx_context lhs with + | Some context_path -> + set_result (Cpath (CPObj (context_path, label))) | None -> ()) | Pexp_fun - {arg_label = lbl; default = defaultExpOpt; lhs = pat; rhs = e} -> - let oldScope = !scope in - (match (!processingFun, !currentCtxPath) with - | None, Some ctxPath -> processingFun := Some (ctxPath, 0) + {arg_label = lbl; default = default_exp_opt; lhs = pat; rhs = e} -> + let old_scope = !scope in + (match (!processing_fun, !current_ctx_path) with + | None, Some ctx_path -> processing_fun := Some (ctx_path, 0) | _ -> ()); - let argContextPath = - match !processingFun with + let arg_context_path = + match !processing_fun with | None -> None - | Some (ctxPath, currentUnlabelledCount) -> - (processingFun := + | Some (ctx_path, current_unlabelled_count) -> + (processing_fun := match lbl with - | Nolabel -> Some (ctxPath, currentUnlabelledCount + 1) - | _ -> Some (ctxPath, currentUnlabelledCount)); + | Nolabel -> Some (ctx_path, current_unlabelled_count + 1) + | _ -> Some (ctx_path, current_unlabelled_count)); if Debug.verbose () then print_endline "[expr_iter] Completing for argument value"; Some (Completable.CArgument { - functionContextPath = ctxPath; - argumentLabel = + function_context_path = ctx_path; + argument_label = (match lbl with | Nolabel -> - Unlabelled {argumentPosition = currentUnlabelledCount} + Unlabelled + {argument_position = current_unlabelled_count} | Optional {txt = name} -> Optional name | Labelled {txt = name} -> Labelled name); }) in - (match defaultExpOpt with + (match default_exp_opt with | None -> () - | Some defaultExp -> iterator.expr iterator defaultExp); - if locHasCursor e.pexp_loc = false then - completePattern ?contextPath:argContextPath pat; - scopePattern ?contextPath:argContextPath pat; + | Some default_exp -> iterator.expr iterator default_exp); + if loc_has_cursor e.pexp_loc = false then + complete_pattern ?context_path:arg_context_path pat; + scope_pattern ?context_path:arg_context_path pat; iterator.pat iterator pat; iterator.expr iterator e; - scope := oldScope; + scope := old_scope; processed := true - | Pexp_let (recFlag, bindings, e) -> - let oldScope = !scope in - if recFlag = Recursive then bindings |> List.iter scopeValueBinding; + | Pexp_let (rec_flag, bindings, e) -> + let old_scope = !scope in + if rec_flag = Recursive then bindings |> List.iter scope_value_binding; bindings |> List.iter (fun vb -> iterator.value_binding iterator vb); - if recFlag = Nonrecursive then bindings |> List.iter scopeValueBinding; + if rec_flag = Nonrecursive then + bindings |> List.iter scope_value_binding; iterator.expr iterator e; - scope := oldScope; + scope := old_scope; processed := true - | Pexp_letmodule (name, modExpr, modBody) -> - let oldScope = !scope in + | Pexp_letmodule (name, mod_expr, mod_body) -> + let old_scope = !scope in iterator.location iterator name.loc; - iterator.module_expr iterator modExpr; - scope := !scope |> Scope.addModule ~name:name.txt ~loc:name.loc; - iterator.expr iterator modBody; - scope := oldScope; + iterator.module_expr iterator mod_expr; + scope := !scope |> Scope.add_module ~name:name.txt ~loc:name.loc; + iterator.expr iterator mod_body; + scope := old_scope; processed := true | Pexp_open (_, lid, e) -> - let oldScope = !scope in + let old_scope = !scope in iterator.location iterator lid.loc; - scope := !scope |> Scope.addOpen ~lid:lid.txt; + scope := !scope |> Scope.add_open ~lid:lid.txt; iterator.expr iterator e; - scope := oldScope; + scope := old_scope; processed := true | _ -> ()); if not !processed then Ast_iterator.default_iterator.expr iterator expr; - inJsxContext := oldInJsxContext; + in_jsx_context := old_in_jsx_context; match expr.pexp_desc with | Pexp_fun _ -> () - | _ -> processingFun := None) + | _ -> processing_fun := None) in let typ (iterator : Ast_iterator.iterator) (core_type : Parsetree.core_type) = - if core_type.ptyp_loc |> Loc.hasPos ~pos:posNoWhite then ( + if core_type.ptyp_loc |> Loc.has_pos ~pos:pos_no_white then ( found := true; if debug then Printf.printf "posCursor:[%s] posNoWhite:[%s] Found type:%s\n" - (Pos.toString posCursor) (Pos.toString posNoWhite) - (Loc.toString core_type.ptyp_loc); + (Pos.to_string pos_cursor) + (Pos.to_string pos_no_white) + (Loc.to_string core_type.ptyp_loc); match core_type.ptyp_desc with | Ptyp_constr (lid, _args) -> - let lidPath = flattenLidCheckDot lid in + let lid_path = flatten_lid_check_dot lid in if debug then Printf.printf "Ptyp_constr %s:%s\n" - (lidPath |> String.concat ".") - (Loc.toString lid.loc); - if lid.loc |> Loc.hasPos ~pos:posBeforeCursor then - setResult + (lid_path |> String.concat ".") + (Loc.to_string lid.loc); + if lid.loc |> Loc.has_pos ~pos:pos_before_cursor then + set_result (Cpath - (CPId {loc = lid.loc; path = lidPath; completionContext = Type})) + (CPId {loc = lid.loc; path = lid_path; completion_context = Type})) | _ -> ()); Ast_iterator.default_iterator.typ iterator core_type in let pat (iterator : Ast_iterator.iterator) (pat : Parsetree.pattern) = - if pat.ppat_loc |> Loc.hasPos ~pos:posNoWhite then ( + if pat.ppat_loc |> Loc.has_pos ~pos:pos_no_white then ( found := true; if debug then Printf.printf "posCursor:[%s] posNoWhite:[%s] Found pattern:%s\n" - (Pos.toString posCursor) (Pos.toString posNoWhite) - (Loc.toString pat.ppat_loc); + (Pos.to_string pos_cursor) + (Pos.to_string pos_no_white) + (Loc.to_string pat.ppat_loc); (match pat.ppat_desc with | Ppat_construct (lid, _) -> ( - let lidPath = flattenLidCheckDot lid in + let lid_path = flatten_lid_check_dot lid in if debug then Printf.printf "Ppat_construct %s:%s\n" - (lidPath |> String.concat ".") - (Loc.toString lid.loc); + (lid_path |> String.concat ".") + (Loc.to_string lid.loc); let completion = Completable.Cpath - (CPId {loc = lid.loc; path = lidPath; completionContext = Value}) + (CPId {loc = lid.loc; path = lid_path; completion_context = Value}) in match !result with | Some (Completable.Cpattern p, scope) -> result := Some (Cpattern {p with fallback = Some completion}, scope) - | _ -> setResult completion) + | _ -> set_result completion) | _ -> ()); Ast_iterator.default_iterator.pat iterator pat) in @@ -1697,24 +1715,24 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc (me : Parsetree.module_expr) = let processed = ref false in (match me.pmod_desc with - | Pmod_ident lid when lid.loc |> Loc.hasPos ~pos:posBeforeCursor -> - let lidPath = flattenLidCheckDot lid in + | Pmod_ident lid when lid.loc |> Loc.has_pos ~pos:pos_before_cursor -> + let lid_path = flatten_lid_check_dot lid in if debug then Printf.printf "Pmod_ident %s:%s\n" - (lidPath |> String.concat ".") - (Loc.toString lid.loc); + (lid_path |> String.concat ".") + (Loc.to_string lid.loc); found := true; - setResult + set_result (Cpath - (CPId {loc = lid.loc; path = lidPath; completionContext = Module})) - | Pmod_functor (name, maybeType, body) -> - let oldScope = !scope in - scope := !scope |> Scope.addModule ~name:name.txt ~loc:name.loc; - (match maybeType with + (CPId {loc = lid.loc; path = lid_path; completion_context = Module})) + | Pmod_functor (name, maybe_type, body) -> + let old_scope = !scope in + scope := !scope |> Scope.add_module ~name:name.txt ~loc:name.loc; + (match maybe_type with | None -> () | Some mt -> iterator.module_type iterator mt); iterator.module_expr iterator body; - scope := oldScope; + scope := old_scope; processed := true | _ -> ()); if not !processed then Ast_iterator.default_iterator.module_expr iterator me @@ -1722,16 +1740,16 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc let module_type (iterator : Ast_iterator.iterator) (mt : Parsetree.module_type) = (match mt.pmty_desc with - | Pmty_ident lid when lid.loc |> Loc.hasPos ~pos:posBeforeCursor -> - let lidPath = flattenLidCheckDot lid in + | Pmty_ident lid when lid.loc |> Loc.has_pos ~pos:pos_before_cursor -> + let lid_path = flatten_lid_check_dot lid in if debug then Printf.printf "Pmty_ident %s:%s\n" - (lidPath |> String.concat ".") - (Loc.toString lid.loc); + (lid_path |> String.concat ".") + (Loc.to_string lid.loc); found := true; - setResult + set_result (Cpath - (CPId {loc = lid.loc; path = lidPath; completionContext = Module})) + (CPId {loc = lid.loc; path = lid_path; completion_context = Module})) | _ -> ()); Ast_iterator.default_iterator.module_type iterator mt in @@ -1739,29 +1757,29 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc (type_kind : Parsetree.type_kind) = (match type_kind with | Ptype_variant [decl] - when decl.pcd_name.loc |> Loc.hasPos ~pos:posNoWhite + when decl.pcd_name.loc |> Loc.has_pos ~pos:pos_no_white && decl.pcd_args = Pcstr_tuple [] -> (* "type t = Pre" could signal the intent to complete variant "Prelude", or the beginning of "Prefix.t" *) if debug then Printf.printf "Ptype_variant unary %s:%s\n" decl.pcd_name.txt - (Loc.toString decl.pcd_name.loc); + (Loc.to_string decl.pcd_name.loc); found := true; - setResult + set_result (Cpath (CPId { loc = decl.pcd_name.loc; path = [decl.pcd_name.txt]; - completionContext = Value; + completion_context = Value; })) | _ -> ()); Ast_iterator.default_iterator.type_kind iterator type_kind in - let lastScopeBeforeCursor = ref (Scope.create ()) in + let last_scope_before_cursor = ref (Scope.create ()) in let location (_iterator : Ast_iterator.iterator) (loc : Location.t) = - if Loc.end_ loc <= posCursor then lastScopeBeforeCursor := !scope + if Loc.end_ loc <= pos_cursor then last_scope_before_cursor := !scope in let iterator = @@ -1783,47 +1801,47 @@ let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc } in - if kindFile = Files.Res then ( + if kind_file = Files.Res then ( let parser = Res_driver.parsing_engine.parse_implementation_from_source ~for_printer:false in let {Res_driver.parsetree = str} = parser ~source:text in iterator.structure iterator str |> ignore; - if blankAfterCursor = Some ' ' || blankAfterCursor = Some '\n' then ( - scope := !lastScopeBeforeCursor; - setResult + if blank_after_cursor = Some ' ' || blank_after_cursor = Some '\n' then ( + scope := !last_scope_before_cursor; + set_result (Cpath - (CPId {loc = Location.none; path = [""]; completionContext = Value}))); + (CPId {loc = Location.none; path = [""]; completion_context = Value}))); if !found = false then if debug then Printf.printf "XXX Not found!\n"; !result) - else if kindFile = Resi then ( + else if kind_file = Resi then ( let parser = Res_driver.parsing_engine.parse_interface_from_source ~for_printer:false in let {Res_driver.parsetree = signature} = parser ~source:text in iterator.signature iterator signature |> ignore; - if blankAfterCursor = Some ' ' || blankAfterCursor = Some '\n' then ( - scope := !lastScopeBeforeCursor; - setResult + if blank_after_cursor = Some ' ' || blank_after_cursor = Some '\n' then ( + scope := !last_scope_before_cursor; + set_result (Cpath - (CPId {loc = Location.none; path = [""]; completionContext = Type}))); + (CPId {loc = Location.none; path = [""]; completion_context = Type}))); if !found = false then if debug then Printf.printf "XXX Not found!\n"; !result) else None -let completionWithParser ~debug ~source ~kindFile ~posCursor = - match Pos.positionToOffset source posCursor with +let completion_with_parser ~debug ~source ~kind_file ~pos_cursor = + match Pos.position_to_offset source pos_cursor with | Some offset -> - completionWithParser1 ~debug ~offset ~posCursor ~kindFile source + completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file source | None -> None -let findTypeOfExpressionAtLoc ~debug ~posCursor ~source ~kindFile loc = +let find_type_of_expression_at_loc ~debug ~pos_cursor ~source ~kind_file loc = match source with | "" -> None | source -> ( - match Pos.positionToOffset source posCursor with + match Pos.position_to_offset source pos_cursor with | Some offset -> - completionWithParser1 ~findThisExprLoc:loc ~debug ~offset ~posCursor - ~kindFile source + completion_with_parser1 ~find_this_expr_loc:loc ~debug ~offset ~pos_cursor + ~kind_file source | None -> None) diff --git a/analysis/src/CompletionJsx.ml b/analysis/src/completion_jsx.ml similarity index 75% rename from analysis/src/CompletionJsx.ml rename to analysis/src/completion_jsx.ml index 4ddba8c642d..e60fcda21f3 100644 --- a/analysis/src/CompletionJsx.ml +++ b/analysis/src/completion_jsx.ml @@ -1,8 +1,8 @@ -open SharedTypes +open Shared_types (* List and explanations taken from https://www.tutorialrepublic.com/html-reference/html5-tags.php. *) -let htmlElements = +let html_elements = [ ("a", "Defines a hyperlink.", false); ("abbr", "Defines an abbreviated form of a longer word or phrase.", false); @@ -207,84 +207,82 @@ let htmlElements = ("wbr", "Represents a line break opportunity.", false); ] -let getJsxLabels ~componentPath ~findTypeOfValue ~package = - match componentPath @ ["make"] |> findTypeOfValue with +let get_jsx_labels ~component_path ~find_type_of_value ~package = + match component_path @ ["make"] |> find_type_of_value with | Some (typ, make_env) -> - let getFields ~path ~typeArgs = - match References.digConstructor ~env:make_env ~package path with + let get_fields ~path ~type_args = + match References.dig_constructor ~env:make_env ~package path with | Some ( env, { item = { decl = - { - type_kind = Type_record (labelDecls, _repr); - type_params = typeParams; - }; + {type_kind = Type_record (label_decls, _repr); type_params}; }; } ) -> - labelDecls + label_decls |> List.map (fun (ld : Types.label_declaration) -> let name = Ident.name ld.ld_id in let t = - ld.ld_type |> TypeUtils.instantiateType ~typeParams ~typeArgs + ld.ld_type + |> Type_utils.instantiate_type ~type_params ~type_args in (name, t, env)) | _ -> [] in - let rec getLabels (t : Types.type_expr) = + let rec get_labels (t : Types.type_expr) = match t.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> getLabels t1 - | Tconstr (p, [propsType], _) when Path.name p = "React.component" -> ( - let rec getPropsType (t : Types.type_expr) = + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> get_labels t1 + | Tconstr (p, [props_type], _) when Path.name p = "React.component" -> ( + let rec get_props_type (t : Types.type_expr) = match t.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> getPropsType t1 - | Tconstr (path, typeArgs, _) when Path.last path = "props" -> - Some (path, typeArgs) + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> get_props_type t1 + | Tconstr (path, type_args, _) when Path.last path = "props" -> + Some (path, type_args) | _ -> None in - match propsType |> getPropsType with - | Some (path, typeArgs) -> getFields ~path ~typeArgs + match props_type |> get_props_type with + | Some (path, type_args) -> get_fields ~path ~type_args | None -> []) | Tarrow - ({lbl = Nolabel; typ = {desc = Tconstr (path, typeArgs, _)}}, _, _, _) + ({lbl = Nolabel; typ = {desc = Tconstr (path, type_args, _)}}, _, _, _) when Path.last path = "props" -> - getFields ~path ~typeArgs - | Tconstr (clPath, [{desc = Tconstr (path, typeArgs, _)}; _], _) - when Path.name clPath = "React.componentLike" + get_fields ~path ~type_args + | Tconstr (cl_path, [{desc = Tconstr (path, type_args, _)}; _], _) + when Path.name cl_path = "React.componentLike" && Path.last path = "props" -> (* JSX V4 external or interface *) - getFields ~path ~typeArgs + get_fields ~path ~type_args | Tarrow ({lbl = Nolabel; typ}, _, _, _) -> ( (* Component without the JSX PPX, like a make fn taking a hand-written type props. *) - let rec digToConstr typ = + let rec dig_to_constr typ = match typ.Types.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> digToConstr t1 - | Tconstr (path, typeArgs, _) when Path.last path = "props" -> - Some (path, typeArgs) + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> dig_to_constr t1 + | Tconstr (path, type_args, _) when Path.last path = "props" -> + Some (path, type_args) | _ -> None in - match digToConstr typ with + match dig_to_constr typ with | None -> [] - | Some (path, typeArgs) -> getFields ~path ~typeArgs) + | Some (path, type_args) -> get_fields ~path ~type_args) | _ -> [] in - typ |> getLabels + typ |> get_labels | None -> [] type prop = { name: string; - posStart: int * int; - posEnd: int * int; + pos_start: int * int; + pos_end: int * int; exp: Parsetree.expression; } -type jsxProps = { - compName: Longident.t Location.loc; +type jsx_props = { + comp_name: Longident.t Location.loc; props: prop list; - childrenStart: (int * int) option; + children_start: (int * int) option; } (** @@ -297,7 +295,7 @@ for the JSX prop value. This code is safe because we also check that the location of the expression is broken, which only happens when the expression is a parse error/not complete. *) -let isRegexpJsxHeuristicExpr expr = +let is_regexp_jsx_heuristic_expr expr = match expr.Parsetree.pexp_desc with | Pexp_extension ( {txt = "re"}, @@ -313,39 +311,40 @@ let isRegexpJsxHeuristicExpr expr = true | _ -> false -let findJsxPropsCompletable ~jsxProps ~endPos ~posBeforeCursor - ~firstCharBeforeCursorNoWhite ~charAtCursor ~posAfterCompName = - let allLabels = +let find_jsx_props_completable ~jsx_props ~end_pos ~pos_before_cursor + ~first_char_before_cursor_no_white ~char_at_cursor ~pos_after_comp_name = + let all_labels = List.fold_right - (fun prop allLabels -> prop.name :: allLabels) - jsxProps.props [] + (fun prop all_labels -> prop.name :: all_labels) + jsx_props.props [] in - let beforeChildrenStart = - match jsxProps.childrenStart with - | Some childrenPos -> posBeforeCursor < childrenPos - | None -> posBeforeCursor <= endPos + let before_children_start = + match jsx_props.children_start with + | Some children_pos -> pos_before_cursor < children_pos + | None -> pos_before_cursor <= end_pos in let rec loop props = match props with | prop :: rest -> - if prop.posStart <= posBeforeCursor && posBeforeCursor < prop.posEnd then ( + if prop.pos_start <= pos_before_cursor && pos_before_cursor < prop.pos_end + then ( if Debug.verbose () then print_endline "[jsx_props_completable]--> Cursor on the prop name"; Some (Completable.Cjsx - ( Utils.flattenLongIdent ~jsx:true jsxProps.compName.txt, + ( Utils.flatten_long_ident ~jsx:true jsx_props.comp_name.txt, prop.name, - allLabels ))) + all_labels ))) else if - prop.posEnd <= posBeforeCursor - && posBeforeCursor < Loc.start prop.exp.pexp_loc + prop.pos_end <= pos_before_cursor + && pos_before_cursor < Loc.start prop.exp.pexp_loc then ( if Debug.verbose () then print_endline "[jsx_props_completable]--> Cursor between the prop name and expr \ assigned"; - match (firstCharBeforeCursorNoWhite, prop.exp) with + match (first_char_before_cursor_no_white, prop.exp) with | Some '=', {pexp_desc = Pexp_ident {txt = Lident txt}} -> if Debug.verbose () then Printf.printf @@ -354,36 +353,38 @@ let findJsxPropsCompletable ~jsxProps ~endPos ~posBeforeCursor Some (Cexpression { - contextPath = + context_path = CJsxPropValue { - pathToComponent = - Utils.flattenLongIdent ~jsx:true jsxProps.compName.txt; - propName = prop.name; - emptyJsxPropNameHint = Some txt; + path_to_component = + Utils.flatten_long_ident ~jsx:true + jsx_props.comp_name.txt; + prop_name = prop.name; + empty_jsx_prop_name_hint = Some txt; }; nested = []; prefix = ""; }) | _ -> None) - else if prop.exp.pexp_loc |> Loc.hasPos ~pos:posBeforeCursor then ( + else if prop.exp.pexp_loc |> Loc.has_pos ~pos:pos_before_cursor then ( if Debug.verbose () then print_endline "[jsx_props_completable]--> Cursor on expr assigned"; match - CompletionExpressions.traverseExpr prop.exp ~exprPath:[] - ~pos:posBeforeCursor ~firstCharBeforeCursorNoWhite + Completion_expressions.traverse_expr prop.exp ~expr_path:[] + ~pos:pos_before_cursor ~first_char_before_cursor_no_white with | Some (prefix, nested) -> Some (Cexpression { - contextPath = + context_path = CJsxPropValue { - pathToComponent = - Utils.flattenLongIdent ~jsx:true jsxProps.compName.txt; - propName = prop.name; - emptyJsxPropNameHint = None; + path_to_component = + Utils.flatten_long_ident ~jsx:true + jsx_props.comp_name.txt; + prop_name = prop.name; + empty_jsx_prop_name_hint = None; }; nested = List.rev nested; prefix; @@ -393,8 +394,8 @@ let findJsxPropsCompletable ~jsxProps ~endPos ~posBeforeCursor if Debug.verbose () then print_endline "[jsx_props_completable]--> Loc is broken"; if - CompletionExpressions.isExprHole prop.exp - || isRegexpJsxHeuristicExpr prop.exp + Completion_expressions.is_expr_hole prop.exp + || is_regexp_jsx_heuristic_expr prop.exp then ( if Debug.verbose () then print_endline @@ -403,21 +404,22 @@ let findJsxPropsCompletable ~jsxProps ~endPos ~posBeforeCursor Some (Cexpression { - contextPath = + context_path = CJsxPropValue { - pathToComponent = - Utils.flattenLongIdent ~jsx:true jsxProps.compName.txt; - propName = prop.name; - emptyJsxPropNameHint = None; + path_to_component = + Utils.flatten_long_ident ~jsx:true + jsx_props.comp_name.txt; + prop_name = prop.name; + empty_jsx_prop_name_hint = None; }; prefix = ""; nested = []; })) else None) else if - rest = [] && beforeChildrenStart && charAtCursor = '>' - && firstCharBeforeCursorNoWhite = Some '=' + rest = [] && before_children_start && char_at_cursor = '>' + && first_char_before_cursor_no_white = Some '=' then ( (* This is a special case for: (completing directly after the '='). The completion comes at the end of the component, after the equals sign, but before any @@ -430,35 +432,36 @@ let findJsxPropsCompletable ~jsxProps ~endPos ~posBeforeCursor Some (Cexpression { - contextPath = + context_path = CJsxPropValue { - pathToComponent = - Utils.flattenLongIdent ~jsx:true jsxProps.compName.txt; - propName = prop.name; - emptyJsxPropNameHint = None; + path_to_component = + Utils.flatten_long_ident ~jsx:true + jsx_props.comp_name.txt; + prop_name = prop.name; + empty_jsx_prop_name_hint = None; }; prefix = ""; nested = []; })) else loop rest | [] -> - let afterCompName = posBeforeCursor >= posAfterCompName in - if afterCompName && beforeChildrenStart then ( + let after_comp_name = pos_before_cursor >= pos_after_comp_name in + if after_comp_name && before_children_start then ( if Debug.verbose () then print_endline "[jsx_props_completable]--> Complete for JSX prop name"; Some (Cjsx - ( Utils.flattenLongIdent ~jsx:true jsxProps.compName.txt, + ( Utils.flatten_long_ident ~jsx:true jsx_props.comp_name.txt, "", - allLabels ))) + all_labels ))) else None in - loop jsxProps.props + loop jsx_props.props -let extractJsxProps ~(compName : Longident.t Location.loc) ~props ~children = +let extract_jsx_props ~(comp_name : Longident.t Location.loc) ~props ~children = let open Parsetree in - let childrenStart = + let children_start = match children with | [] -> None | child :: _ -> @@ -470,8 +473,8 @@ let extractJsxProps ~(compName : Longident.t Location.loc) ~props ~children = | JSXPropPunning (_, name) -> { name = name.txt; - posStart = Loc.start name.loc; - posEnd = Loc.end_ name.loc; + pos_start = Loc.start name.loc; + pos_end = Loc.end_ name.loc; exp = Ast_helper.Exp.ident ~loc:name.loc {txt = Longident.Lident name.txt; loc = name.loc}; @@ -479,16 +482,16 @@ let extractJsxProps ~(compName : Longident.t Location.loc) ~props ~children = | JSXPropValue (name, _, value) -> { name = name.txt; - posStart = Loc.start name.loc; - posEnd = Loc.end_ name.loc; + pos_start = Loc.start name.loc; + pos_end = Loc.end_ name.loc; exp = value; } | JSXPropSpreading (loc, expr) -> { name = "_spreadProps"; - posStart = Loc.start loc; - posEnd = Loc.end_ loc; + pos_start = Loc.start loc; + pos_end = Loc.end_ loc; exp = expr; }) in - {compName; props; childrenStart} + {comp_name; props; children_start} diff --git a/analysis/src/completion_patterns.ml b/analysis/src/completion_patterns.ml new file mode 100644 index 00000000000..cc1a270cab7 --- /dev/null +++ b/analysis/src/completion_patterns.ml @@ -0,0 +1,266 @@ +open Shared_types + +let is_pattern_hole pat = + match pat.Parsetree.ppat_desc with + | Ppat_extension ({txt = "rescript.patternhole"}, _) -> true + | _ -> false + +let is_pattern_tuple pat = + match pat.Parsetree.ppat_desc with + | Ppat_tuple _ -> true + | _ -> false + +let rec traverse_tuple_items tuple_items ~next_pattern_path + ~result_from_found_item_num ~loc_has_cursor + ~first_char_before_cursor_no_white ~pos_before_cursor = + let item_num = ref (-1) in + let item_with_cursor = + tuple_items + |> List.find_map (fun pat -> + item_num := !item_num + 1; + pat + |> traverse_pattern + ~pattern_path:(next_pattern_path !item_num) + ~loc_has_cursor ~first_char_before_cursor_no_white + ~pos_before_cursor) + in + match (item_with_cursor, first_char_before_cursor_no_white) with + | None, Some ',' -> + (* No tuple item has the cursor, but there's a comma before the cursor. + Figure out what arg we're trying to complete. Example: (true, , None) *) + let pos_num = ref (-1) in + tuple_items + |> List.iteri (fun index pat -> + if pos_before_cursor >= Loc.start pat.Parsetree.ppat_loc then + pos_num := index); + if !pos_num > -1 then Some ("", result_from_found_item_num !pos_num) + else None + | v, _ -> v + +and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor + ~first_char_before_cursor_no_white ~pos_before_cursor = + let some_if_has_cursor v debug_id = + if loc_has_cursor pat.Parsetree.ppat_loc then ( + if Debug.verbose () then + Printf.printf + "[traversePattern:someIfHasCursor] '%s' has cursor, returning \n" + debug_id; + Some v) + else None + in + match pat.ppat_desc with + | Ppat_constant _ | Ppat_interval _ -> None + | Ppat_constraint (p, _) + | Ppat_alias (p, _) + | Ppat_exception p + | Ppat_open (_, p) -> + p + |> traverse_pattern ~pattern_path ~loc_has_cursor + ~first_char_before_cursor_no_white ~pos_before_cursor + | Ppat_or (p1, p2) -> ( + let or_pat_with_item = + [p1; p2] + |> List.find_map (fun p -> + p + |> traverse_pattern ~pattern_path ~loc_has_cursor + ~first_char_before_cursor_no_white ~pos_before_cursor) + in + match or_pat_with_item with + | None when is_pattern_hole p1 || is_pattern_hole p2 -> + if Debug.verbose () then + Printf.printf + "[traversePattern] found or-pattern that was pattern hole\n"; + Some ("", pattern_path) + | v -> v) + | Ppat_any -> + (* We treat any `_` as an empty completion. This is mainly because we're + inserting `_` in snippets and automatically put the cursor there. So + letting it trigger an empty completion improves the ergonomics by a + lot. *) + some_if_has_cursor ("", pattern_path) "Ppat_any" + | Ppat_var {txt} -> some_if_has_cursor (txt, pattern_path) "Ppat_var" + | Ppat_construct ({txt = Lident "()"}, None) -> + (* switch s { | () }*) + some_if_has_cursor + ("", pattern_path @ [Completable.NTupleItem {item_num = 0}]) + "Ppat_construct()" + | Ppat_construct ({txt = Lident prefix}, None) -> + some_if_has_cursor (prefix, pattern_path) "Ppat_construct(Lident)" + | Ppat_variant (prefix, None) -> + some_if_has_cursor ("#" ^ prefix, pattern_path) "Ppat_variant" + | Ppat_array array_patterns -> + let next_pattern_path = [Completable.NArray] @ pattern_path in + if List.length array_patterns = 0 && loc_has_cursor pat.ppat_loc then + Some ("", next_pattern_path) + else + array_patterns + |> List.find_map (fun pat -> + pat + |> traverse_pattern ~pattern_path:next_pattern_path ~loc_has_cursor + ~first_char_before_cursor_no_white ~pos_before_cursor) + | Ppat_tuple tuple_items when loc_has_cursor pat.ppat_loc -> + tuple_items + |> traverse_tuple_items ~first_char_before_cursor_no_white + ~pos_before_cursor ~loc_has_cursor + ~next_pattern_path:(fun item_num -> + [Completable.NTupleItem {item_num}] @ pattern_path) + ~result_from_found_item_num:(fun item_num -> + [Completable.NTupleItem {item_num = item_num + 1}] @ pattern_path) + | Ppat_record ([], _) -> + (* Empty fields means we're in a record body `{}`. Complete for the fields. *) + some_if_has_cursor + ("", [Completable.NRecordBody {seen_fields = []}] @ pattern_path) + "Ppat_record(empty)" + | Ppat_record (fields, _) -> ( + let field_with_cursor = ref None in + let field_with_pat_hole = ref None in + Ext_list.iter fields (fun {lid = fname; x = f} -> + match + ( fname.Location.txt, + f.Parsetree.ppat_loc + |> Cursor_position.classify_loc ~pos:pos_before_cursor ) + with + | Longident.Lident fname, HasCursor -> + field_with_cursor := Some (fname, f) + | Lident fname, _ when is_pattern_hole f -> + field_with_pat_hole := Some (fname, f) + | _ -> ()); + let seen_fields = + Ext_list.filter_map fields (fun {lid = field_name} -> + match field_name with + | {Location.txt = Longident.Lident field_name} -> Some field_name + | _ -> None) + in + match (!field_with_cursor, !field_with_pat_hole) with + | Some (fname, f), _ | None, Some (fname, f) -> ( + match f.ppat_desc with + | Ppat_extension ({txt = "rescript.patternhole"}, _) -> + (* A pattern hole means for example `{someField: }`. We want to complete for the type of `someField`. *) + some_if_has_cursor + ( "", + [Completable.NFollowRecordField {field_name = fname}] @ pattern_path + ) + "patternhole" + | Ppat_var {txt} -> + (* A var means `{s}` or similar. Complete for fields. *) + some_if_has_cursor + (txt, [Completable.NRecordBody {seen_fields}] @ pattern_path) + "Ppat_var #2" + | _ -> + f + |> traverse_pattern + ~pattern_path: + ([Completable.NFollowRecordField {field_name = fname}] + @ pattern_path) + ~loc_has_cursor ~first_char_before_cursor_no_white + ~pos_before_cursor) + | None, None -> ( + (* Figure out if we're completing for a new field. + If the cursor is inside of the record body, but no field has the cursor, + and there's no pattern hole. Check the first char to the left of the cursor, + ignoring white space. If that's a comma, we assume you're completing for a new field. *) + match first_char_before_cursor_no_white with + | Some ',' -> + some_if_has_cursor + ("", [Completable.NRecordBody {seen_fields}] @ pattern_path) + "firstCharBeforeCursorNoWhite:," + | _ -> None)) + | Ppat_construct + ( {txt}, + Some {ppat_loc; ppat_desc = Ppat_construct ({txt = Lident "()"}, _)} ) + when loc_has_cursor ppat_loc -> + (* Empty payload with cursor, like: Test() *) + Some + ( "", + [ + Completable.NVariantPayload + {constructor_name = Utils.get_unqualified_name txt; item_num = 0}; + ] + @ pattern_path ) + | Ppat_construct ({txt}, Some pat) + when pos_before_cursor >= (pat.ppat_loc |> Loc.end_) + && first_char_before_cursor_no_white = Some ',' + && is_pattern_tuple pat = false -> + (* Empty payload with trailing ',', like: Test(true, ) *) + Some + ( "", + [ + Completable.NVariantPayload + {constructor_name = Utils.get_unqualified_name txt; item_num = 1}; + ] + @ pattern_path ) + | Ppat_construct ({txt}, Some {ppat_loc; ppat_desc = Ppat_tuple tuple_items}) + when loc_has_cursor ppat_loc -> + tuple_items + |> traverse_tuple_items ~loc_has_cursor ~first_char_before_cursor_no_white + ~pos_before_cursor + ~next_pattern_path:(fun item_num -> + [ + Completable.NVariantPayload + {constructor_name = Utils.get_unqualified_name txt; item_num}; + ] + @ pattern_path) + ~result_from_found_item_num:(fun item_num -> + [ + Completable.NVariantPayload + { + constructor_name = Utils.get_unqualified_name txt; + item_num = item_num + 1; + }; + ] + @ pattern_path) + | Ppat_construct ({txt}, Some p) when loc_has_cursor pat.ppat_loc -> + p + |> traverse_pattern ~loc_has_cursor ~first_char_before_cursor_no_white + ~pos_before_cursor + ~pattern_path: + ([ + Completable.NVariantPayload + { + constructor_name = Utils.get_unqualified_name txt; + item_num = 0; + }; + ] + @ pattern_path) + | Ppat_variant + (txt, Some {ppat_loc; ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}) + when loc_has_cursor ppat_loc -> + (* Empty payload with cursor, like: #test() *) + Some + ( "", + [Completable.NPolyvariantPayload {constructor_name = txt; item_num = 0}] + @ pattern_path ) + | Ppat_variant (txt, Some pat) + when pos_before_cursor >= (pat.ppat_loc |> Loc.end_) + && first_char_before_cursor_no_white = Some ',' + && is_pattern_tuple pat = false -> + (* Empty payload with trailing ',', like: #test(true, ) *) + Some + ( "", + [Completable.NPolyvariantPayload {constructor_name = txt; item_num = 1}] + @ pattern_path ) + | Ppat_variant (txt, Some {ppat_loc; ppat_desc = Ppat_tuple tuple_items}) + when loc_has_cursor ppat_loc -> + tuple_items + |> traverse_tuple_items ~loc_has_cursor ~first_char_before_cursor_no_white + ~pos_before_cursor + ~next_pattern_path:(fun item_num -> + [Completable.NPolyvariantPayload {constructor_name = txt; item_num}] + @ pattern_path) + ~result_from_found_item_num:(fun item_num -> + [ + Completable.NPolyvariantPayload + {constructor_name = txt; item_num = item_num + 1}; + ] + @ pattern_path) + | Ppat_variant (txt, Some p) when loc_has_cursor pat.ppat_loc -> + p + |> traverse_pattern ~loc_has_cursor ~first_char_before_cursor_no_white + ~pos_before_cursor + ~pattern_path: + ([ + Completable.NPolyvariantPayload + {constructor_name = txt; item_num = 0}; + ] + @ pattern_path) + | _ -> None diff --git a/analysis/src/Completions.ml b/analysis/src/completions.ml similarity index 55% rename from analysis/src/Completions.ml rename to analysis/src/completions.ml index ae35a5a0d34..37c8be8eeff 100644 --- a/analysis/src/Completions.ml +++ b/analysis/src/completions.ml @@ -1,11 +1,11 @@ -let getCompletions ~debug ~source ~kindFile ~pos ~forHover - ~(full : SharedTypes.full option) = +let get_completions ~debug ~source ~kind_file ~pos ~for_hover + ~(full : Shared_types.full option) = match source with | "" -> None | source -> ( match - CompletionFrontEnd.completionWithParser ~debug ~source ~kindFile - ~posCursor:pos + Completion_front_end.completion_with_parser ~debug ~source ~kind_file + ~pos_cursor:pos with | None -> None | Some (completable, scope) -> ( @@ -14,17 +14,17 @@ let getCompletions ~debug ~source ~kindFile ~pos ~forHover Printf.printf "\nScope from frontend:\n"; List.iter (fun item -> - Printf.printf "%s\n" (SharedTypes.ScopeTypes.item_to_string item)) + Printf.printf "%s\n" (Shared_types.Scope_types.item_to_string item)) scope; print_newline ()); (* Only perform expensive ast operations if there are completables *) match full with | None -> None | Some full -> - let env = SharedTypes.QueryEnv.fromFile full.file in + let env = Shared_types.Query_env.from_file full.file in let completables = completable - |> CompletionBackEnd.processCompletable ~debug ~full ~pos ~scope ~env - ~forHover + |> Completion_back_end.process_completable ~debug ~full ~pos ~scope + ~env ~for_hover in Some (completables, full, scope))) diff --git a/analysis/src/create_interface.ml b/analysis/src/create_interface.ml new file mode 100644 index 00000000000..f74f2e151ea --- /dev/null +++ b/analysis/src/create_interface.ml @@ -0,0 +1,329 @@ +module Source_file_extractor = struct + let create ~path = + match Files.read_file path with + | None -> [||] + | Some text -> text |> String.split_on_char '\n' |> Array.of_list + + let extract lines ~pos_start ~pos_end = + let line_start, col_start = pos_start in + let line_end, col_end = pos_end in + let res = ref [] in + if line_start < 0 || line_start > line_end || line_end >= Array.length lines + then [] + else ( + for n = line_end downto line_start do + let line = lines.(n) in + let len = String.length line in + if n = line_start && n = line_end then ( + if col_start >= 0 && col_start < col_end && col_end <= len then + let indent = String.make col_start ' ' in + res := + (indent ^ String.sub line col_start (col_end - col_start)) :: !res) + else if n = line_start then ( + if col_start >= 0 && col_start < len then + let indent = String.make col_start ' ' in + res := + (indent ^ String.sub line col_start (len - col_start)) :: !res) + else if n = line_end then ( + if col_end > 0 && col_end <= len then + res := String.sub line 0 col_end :: !res) + else res := line :: !res + done; + !res) +end + +module Attributes_utils : sig + type t + + val make : string list -> t + + val contains : string -> t -> bool + + val to_string : t -> string +end = struct + type attribute = {line: int; offset: int; name: string} + type t = attribute list + type parse_state = Search | Collect of int + + let make lines = + let make_attr line_idx attr_offset_start attr_offset_end line = + { + line = line_idx; + offset = attr_offset_start; + name = + String.sub line attr_offset_start (attr_offset_end - attr_offset_start); + } + in + let res = ref [] in + lines + |> List.iteri (fun line_idx line -> + let state = ref Search in + for i = 0 to String.length line - 1 do + let ch = line.[i] in + match (!state, ch) with + | Search, '@' -> state := Collect i + | Collect attr_offset, ' ' -> + res := make_attr line_idx attr_offset i line :: !res; + state := Search + | Search, _ | Collect _, _ -> () + done; + + match !state with + | Collect attr_offset -> + res := + make_attr line_idx attr_offset (String.length line) line :: !res + | _ -> ()); + !res |> List.rev + + let contains attribute_for_search t = + t |> List.exists (fun {name} -> name = attribute_for_search) + + let to_string t = + match t with + | [] -> "" + | {line} :: _ -> + let prev_line = ref line in + let buffer = ref "" in + let res = ref [] in + t + |> List.iter (fun attr -> + let {line; offset; name} = attr in + + if line <> !prev_line then ( + res := !buffer :: !res; + buffer := ""; + prev_line := line); + + let indent = String.make (offset - String.length !buffer) ' ' in + buffer := !buffer ^ indent ^ name); + res := !buffer :: !res; + !res |> List.rev |> String.concat "\n" +end + +let print_signature ~extractor ~signature = + Printtyp.reset_names (); + let sig_item_to_string (item : Outcometree.out_sig_item) = + item |> Res_outcome_printer.print_out_sig_item_doc + |> Res_doc.to_string ~width:Res_printer.default_print_width + in + + let gen_sig_str_for_inline_attr lines attributes id vd = + let divider = if List.length lines > 1 then "\n" else " " in + + let sig_str = + sig_item_to_string + (Printtyp.tree_of_value_description id {vd with val_kind = Val_reg}) + in + + (attributes |> Attributes_utils.to_string) ^ divider ^ sig_str ^ "\n" + in + + let buf = Buffer.create 10 in + + let get_component_type (typ : Types.type_expr) = + let react_element = + Ctype.newconstr (Pdot (Pident (Ident.create "React"), "element", 0)) [] + in + match typ.desc with + | Tarrow + ( {typ = {desc = Tconstr (Path.Pident props_id, type_args, _)}}, + ret_type, + _, + _ ) + when Ident.name props_id = "props" -> + Some (type_args, ret_type) + | Tconstr + ( Pdot (Pident {name = "React"}, "component", _), + [{desc = Tconstr (Path.Pident props_id, type_args, _)}], + _ ) + when Ident.name props_id = "props" -> + Some (type_args, react_element) + | Tconstr + ( Pdot (Pident {name = "React"}, "componentLike", _), + [{desc = Tconstr (Path.Pident props_id, type_args, _)}; ret_type], + _ ) + when Ident.name props_id = "props" -> + Some (type_args, ret_type) + | _ -> None + in + + let rec process_signature ~indent (signature : Types.signature) : unit = + match signature with + | Sig_type + (props_id, {type_params; type_kind = Type_record (label_decls, _)}, _) + :: Sig_value (make_id (* make *), make_value_desc) + :: rest + when Ident.name props_id = "props" + && get_component_type make_value_desc.val_type <> None -> + (* PPX V4 component declaration: + type props = {...} + let v = ... + *) + let new_item_str = + let type_args, ret_type = + match get_component_type make_value_desc.val_type with + | Some x -> x + | None -> assert false + in + let rec mk_fun_type (label_decls : Types.label_declaration list) = + match label_decls with + | [] -> ret_type + | label_decl :: rest -> + let prop_type = + Type_utils.instantiate_type ~type_params ~type_args + label_decl.ld_type + in + let lbl_name = label_decl.ld_id |> Ident.name in + let lbl = + if label_decl.ld_optional then + Asttypes.Optional {txt = lbl_name; loc = Location.none} + else Asttypes.Labelled {txt = lbl_name; loc = Location.none} + in + { + ret_type with + desc = Tarrow ({lbl; typ = prop_type}, mk_fun_type rest, Cok, None); + } + in + let fun_type = + if List.length label_decls = 0 (* No props *) then + let t_unit = + Ctype.newconstr (Path.Pident (Ident.create "unit")) [] + in + { + ret_type with + desc = Tarrow ({lbl = Nolabel; typ = t_unit}, ret_type, Cok, None); + } + else mk_fun_type label_decls + in + sig_item_to_string + (Printtyp.tree_of_value_description make_id + {make_value_desc with val_type = fun_type}) + in + Buffer.add_string buf (indent ^ "@react.component\n"); + Buffer.add_string buf (indent ^ new_item_str ^ "\n"); + process_signature ~indent rest + | Sig_module (id, mod_decl, rec_status) :: rest -> + let colon_or_equals = + match mod_decl.md_type with + | Mty_alias _ -> " = " + | _ -> ": " + in + Buffer.add_string buf + (indent + ^ (match rec_status with + | Trec_not -> "module " + | Trec_first -> "module rec " + | Trec_next -> "and ") + ^ Ident.name id ^ colon_or_equals); + process_module_type ~indent mod_decl.md_type; + Buffer.add_string buf "\n"; + process_signature ~indent rest + | Sig_modtype (id, mtd) :: rest -> + let () = + match mtd.mtd_type with + | None -> + Buffer.add_string buf (indent ^ "module type " ^ Ident.name id ^ "\n") + | Some mt -> + Buffer.add_string buf (indent ^ "module type " ^ Ident.name id ^ " = "); + process_module_type ~indent mt; + Buffer.add_string buf "\n" + in + process_signature ~indent rest + | Sig_value (id, ({val_kind = Val_prim prim; val_loc} as vd)) :: items + when prim.prim_native_name <> "" && prim.prim_native_name.[0] = '\132' -> + (* Rescript primitive name, e.g. @val external ... *) + let lines = + let pos_start, pos_end = Loc.range val_loc in + extractor |> Source_file_extractor.extract ~pos_start ~pos_end + in + let attributes = Attributes_utils.make lines in + + if Attributes_utils.contains "@inline" attributes then + (* Generate type signature for @inline declaration *) + Buffer.add_string buf + (gen_sig_str_for_inline_attr lines attributes id vd) + else + (* Copy the external declaration verbatim from the implementation file *) + Buffer.add_string buf ((lines |> String.concat "\n") ^ "\n"); + + process_signature ~indent items + | Sig_value (id, vd) :: items -> + let new_item_str = + sig_item_to_string (Printtyp.tree_of_value_description id vd) + in + Buffer.add_string buf (indent ^ new_item_str ^ "\n"); + process_signature ~indent items + | Sig_type (_id, type_decl, _recStatus) :: items -> + let lines = + let pos_start, pos_end = Loc.range type_decl.type_loc in + extractor |> Source_file_extractor.extract ~pos_start ~pos_end + in + (* Copy the type declaration verbatim to preserve attributes *) + Buffer.add_string buf ((lines |> String.concat "\n") ^ "\n"); + process_signature ~indent items + | Sig_typext (id, ext_constr, ext_status) :: items -> + let new_item_str = + sig_item_to_string + (Printtyp.tree_of_extension_constructor id ext_constr ext_status) + in + Buffer.add_string buf (indent ^ new_item_str ^ "\n"); + process_signature ~indent items + | Sig_class _ :: items -> + (* not needed *) + process_signature ~indent items + | Sig_class_type _ :: items -> + (* not needed *) + process_signature ~indent items + | [] -> () + and process_module_type ~indent (mt : Types.module_type) = + match mt with + | Mty_signature signature -> + Buffer.add_string buf "{\n"; + process_signature ~indent:(indent ^ " ") signature; + Buffer.add_string buf (indent ^ "}") + | Mty_functor _ -> + let rec collect_functor_args ~args (mt : Types.module_type) = + match mt with + | Mty_functor (id, None, mt) when Ident.name id = "*" -> + (* AST encoding of functor with no arguments *) + collect_functor_args ~args mt + | Mty_functor (id, mto, mt) -> + collect_functor_args ~args:((id, mto) :: args) mt + | mt -> (List.rev args, mt) + in + let args, ret_mt = collect_functor_args ~args:[] mt in + Buffer.add_string buf "("; + args + |> List.iter (fun (id, mto) -> + Buffer.add_string buf ("\n" ^ indent ^ " "); + (match mto with + | None -> Buffer.add_string buf (Ident.name id) + | Some mt -> + Buffer.add_string buf (Ident.name id ^ ": "); + process_module_type ~indent:(indent ^ " ") mt); + Buffer.add_string buf ","); + if args <> [] then Buffer.add_string buf ("\n" ^ indent); + Buffer.add_string buf (") =>\n" ^ indent); + process_module_type ~indent ret_mt + | Mty_ident path | Mty_alias (_, path) -> + let rec out_ident_to_string (ident : Outcometree.out_ident) = + match ident with + | Oide_ident s -> s + | Oide_dot (ident, s) -> out_ident_to_string ident ^ "." ^ s + | Oide_apply (call, arg) -> + out_ident_to_string call ^ "(" ^ out_ident_to_string arg ^ ")" + in + Buffer.add_string buf (out_ident_to_string (Printtyp.tree_of_path path)) + in + + process_signature ~indent:"" signature; + Buffer.contents buf + +let command ~path ~cmi_file = + match Shared.try_read_cmi cmi_file with + | Some cmi_info -> + (* For reading the config *) + let _ = Cmt.load_full_cmt_from_path ~path in + let extractor = Source_file_extractor.create ~path in + print_signature ~extractor ~signature:cmi_info.cmi_sign + | None -> "" diff --git a/analysis/src/DceCommand.ml b/analysis/src/dce_command.ml similarity index 56% rename from analysis/src/DceCommand.ml rename to analysis/src/dce_command.ml index 8bce148efe9..820482b920d 100644 --- a/analysis/src/DceCommand.ml +++ b/analysis/src/dce_command.ml @@ -1,7 +1,7 @@ let command () = - Reanalyze.RunConfig.dce (); - let dce_config = Reanalyze.DceConfig.current () in - Reanalyze.runAnalysis ~dce_config ~cmtRoot:None ~reactive_collection:None + Reanalyze.Run_config.dce (); + let dce_config = Reanalyze.Dce_config.current () in + Reanalyze.run_analysis ~dce_config ~cmt_root:None ~reactive_collection:None ~reactive_merge:None ~reactive_liveness:None ~reactive_solver:None ~skip_file:None (); let issues = !Reanalyze.Log_.Stats.issues in diff --git a/analysis/src/debug.ml b/analysis/src/debug.ml new file mode 100644 index 00000000000..a7002fa56cd --- /dev/null +++ b/analysis/src/debug.ml @@ -0,0 +1,13 @@ +type debug_level = Off | Regular | Verbose + +let debug_level = ref Off + +let log s = + match !debug_level with + | Regular | Verbose -> print_endline s + | Off -> () + +let debug_print_env (env : Shared_types.Query_env.t) = + env.path_rev @ [env.file.module_name] |> List.rev |> String.concat "." + +let verbose () = !debug_level = Verbose diff --git a/analysis/src/Diagnostics.ml b/analysis/src/diagnostics.ml similarity index 79% rename from analysis/src/Diagnostics.ml rename to analysis/src/diagnostics.ml index 1dad9a9b6fa..bcc537b9667 100644 --- a/analysis/src/Diagnostics.ml +++ b/analysis/src/diagnostics.ml @@ -1,4 +1,4 @@ -let document_syntax ~source ~kindFile = +let document_syntax ~source ~kind_file = let get_diagnostics diagnostics = diagnostics |> List.map (fun diagnostic -> @@ -21,16 +21,16 @@ let document_syntax ~source ~kindFile = ~message:(`String (Res_diagnostics.explain diagnostic)) ~severity:Lsp.Types.DiagnosticSeverity.Error ()) in - if kindFile = Files.Res then - let parseImplementation = + if kind_file = Files.Res then + let parse_implementation = Res_driver.parsing_engine.parse_implementation_from_source ~for_printer:false ~source in - get_diagnostics parseImplementation.diagnostics - else if kindFile = Files.Resi then - let parseInterface = + get_diagnostics parse_implementation.diagnostics + else if kind_file = Files.Resi then + let parse_interface = Res_driver.parsing_engine.parse_interface_from_source ~for_printer:false ~source in - get_diagnostics parseInterface.diagnostics + get_diagnostics parse_interface.diagnostics else [] diff --git a/analysis/src/DocumentSymbol.ml b/analysis/src/document_symbol.ml similarity index 58% rename from analysis/src/DocumentSymbol.ml rename to analysis/src/document_symbol.ml index 856b0299063..49ae7b32d73 100644 --- a/analysis/src/DocumentSymbol.ml +++ b/analysis/src/document_symbol.ml @@ -2,70 +2,72 @@ let command ~path = let symbols = ref [] in - let addSymbol name loc kind = + let add_symbol name loc kind = if (not loc.Location.loc_ghost) && loc.loc_start.pos_cnum >= 0 && loc.loc_end.pos_cnum >= 0 then - let range = Utils.cmtLocToRange loc in + let range = Utils.cmt_loc_to_range loc in let symbol = Lsp.Types.DocumentSymbol.create ~name ~range ~selectionRange:range ~children:[] ~kind () in symbols := symbol :: !symbols in - let rec exprKind (exp : Parsetree.expression) = + let rec expr_kind (exp : Parsetree.expression) = match exp.pexp_desc with | Pexp_fun _ -> Lsp.Types.SymbolKind.Function - | Pexp_constraint (e, _) -> exprKind e + | Pexp_constraint (e, _) -> expr_kind e | Pexp_constant (Pconst_string _) -> Lsp.Types.SymbolKind.String | Pexp_constant (Pconst_float _ | Pconst_integer _) -> Lsp.Types.SymbolKind.Number | Pexp_constant _ -> Lsp.Types.SymbolKind.Constant | _ -> Lsp.Types.SymbolKind.Variable in - let processTypeKind (tk : Parsetree.type_kind) = + let process_type_kind (tk : Parsetree.type_kind) = match tk with - | Ptype_variant constrDecls -> - constrDecls + | Ptype_variant constr_decls -> + constr_decls |> List.iter (fun (cd : Parsetree.constructor_declaration) -> - addSymbol cd.pcd_name.txt cd.pcd_loc EnumMember) - | Ptype_record labelDecls -> - labelDecls + add_symbol cd.pcd_name.txt cd.pcd_loc EnumMember) + | Ptype_record label_decls -> + label_decls |> List.iter (fun (ld : Parsetree.label_declaration) -> - addSymbol ld.pld_name.txt ld.pld_loc Property) + add_symbol ld.pld_name.txt ld.pld_loc Property) | _ -> () in - let processTypeDeclaration (td : Parsetree.type_declaration) = - addSymbol td.ptype_name.txt td.ptype_loc TypeParameter; - processTypeKind td.ptype_kind + let process_type_declaration (td : Parsetree.type_declaration) = + add_symbol td.ptype_name.txt td.ptype_loc TypeParameter; + process_type_kind td.ptype_kind in - let processValueDescription (vd : Parsetree.value_description) = - addSymbol vd.pval_name.txt vd.pval_loc Variable + let process_value_description (vd : Parsetree.value_description) = + add_symbol vd.pval_name.txt vd.pval_loc Variable in - let processModuleBinding (mb : Parsetree.module_binding) = - addSymbol mb.pmb_name.txt mb.pmb_loc Module + let process_module_binding (mb : Parsetree.module_binding) = + add_symbol mb.pmb_name.txt mb.pmb_loc Module in - let processModuleDeclaration (md : Parsetree.module_declaration) = - addSymbol md.pmd_name.txt md.pmd_loc Module + let process_module_declaration (md : Parsetree.module_declaration) = + add_symbol md.pmd_name.txt md.pmd_loc Module in - let processExtensionConstructor (et : Parsetree.extension_constructor) = - addSymbol et.pext_name.txt et.pext_loc Constructor + let process_extension_constructor (et : Parsetree.extension_constructor) = + add_symbol et.pext_name.txt et.pext_loc Constructor in let value_binding (iterator : Ast_iterator.iterator) (vb : Parsetree.value_binding) = (match vb.pvb_pat.ppat_desc with | Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _) -> - addSymbol txt vb.pvb_loc (exprKind vb.pvb_expr) + add_symbol txt vb.pvb_loc (expr_kind vb.pvb_expr) | _ -> ()); Ast_iterator.default_iterator.value_binding iterator vb in let expr (iterator : Ast_iterator.iterator) (e : Parsetree.expression) = (match e.pexp_desc with - | Pexp_letmodule ({txt}, modExpr, _) -> - addSymbol txt {e.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} Module - | Pexp_letexception (ec, _) -> processExtensionConstructor ec + | Pexp_letmodule ({txt}, mod_expr, _) -> + add_symbol txt + {e.pexp_loc with loc_end = mod_expr.pmod_loc.loc_end} + Module + | Pexp_letexception (ec, _) -> process_extension_constructor ec | _ -> ()); Ast_iterator.default_iterator.expr iterator e in @@ -73,31 +75,33 @@ let command ~path = (item : Parsetree.structure_item) = (match item.pstr_desc with | Pstr_value _ -> () - | Pstr_primitive vd -> processValueDescription vd - | Pstr_type (_, typDecls) -> typDecls |> List.iter processTypeDeclaration - | Pstr_module mb -> processModuleBinding mb - | Pstr_recmodule mbs -> mbs |> List.iter processModuleBinding - | Pstr_exception ec -> processExtensionConstructor ec + | Pstr_primitive vd -> process_value_description vd + | Pstr_type (_, typ_decls) -> + typ_decls |> List.iter process_type_declaration + | Pstr_module mb -> process_module_binding mb + | Pstr_recmodule mbs -> mbs |> List.iter process_module_binding + | Pstr_exception ec -> process_extension_constructor ec | _ -> ()); Ast_iterator.default_iterator.structure_item iterator item in let signature_item (iterator : Ast_iterator.iterator) (item : Parsetree.signature_item) = (match item.psig_desc with - | Psig_value vd -> processValueDescription vd - | Psig_type (_, typDecls) -> typDecls |> List.iter processTypeDeclaration - | Psig_module md -> processModuleDeclaration md - | Psig_recmodule mds -> mds |> List.iter processModuleDeclaration - | Psig_exception ec -> processExtensionConstructor ec + | Psig_value vd -> process_value_description vd + | Psig_type (_, typ_decls) -> + typ_decls |> List.iter process_type_declaration + | Psig_module md -> process_module_declaration md + | Psig_recmodule mds -> mds |> List.iter process_module_declaration + | Psig_exception ec -> process_extension_constructor ec | _ -> ()); Ast_iterator.default_iterator.signature_item iterator item in let module_expr (iterator : Ast_iterator.iterator) (me : Parsetree.module_expr) = match me.pmod_desc with - | Pmod_constraint (modExpr, _modTyp) -> + | Pmod_constraint (mod_expr, _modTyp) -> (* Don't double-list items in implementation and interface *) - Ast_iterator.default_iterator.module_expr iterator modExpr + Ast_iterator.default_iterator.module_expr iterator mod_expr | _ -> Ast_iterator.default_iterator.module_expr iterator me in let iterator = @@ -123,7 +127,7 @@ let command ~path = in let {Res_driver.parsetree = signature} = parser ~filename:path in iterator.signature iterator signature |> ignore); - let isInside + let is_inside ({ range = { @@ -143,7 +147,7 @@ let command ~path = (sl1 > sl2 || (sl1 = sl2 && sc1 >= sc2)) && (el1 < el2 || (el1 = el2 && ec1 <= ec2)) in - let compareSymbol (s1 : Lsp.Types.DocumentSymbol.t) + let compare_symbol (s1 : Lsp.Types.DocumentSymbol.t) (s2 : Lsp.Types.DocumentSymbol.t) = let n = compare s1.range.start.line s2.range.start.line in if n <> 0 then n @@ -155,30 +159,32 @@ let command ~path = if n <> 0 then n else compare s1.range.end_.character s2.range.end_.character in - let rec addSymbolToChildren ~symbol children = + let rec add_symbol_to_children ~symbol children = match children with | [] -> [symbol] | last :: rest -> - if isInside symbol last then + if is_inside symbol last then match last.children with | Some c -> - let newLast = - {last with children = Some (c |> addSymbolToChildren ~symbol)} + let new_last = + {last with children = Some (c |> add_symbol_to_children ~symbol)} in - newLast :: rest + new_last :: rest | _ -> rest else symbol :: children in - let rec addSortedSymbolsToChildren ~sortedSymbols children = - match sortedSymbols with + let rec add_sorted_symbols_to_children ~sorted_symbols children = + match sorted_symbols with | [] -> children - | firstSymbol :: rest -> + | first_symbol :: rest -> children - |> addSymbolToChildren ~symbol:firstSymbol - |> addSortedSymbolsToChildren ~sortedSymbols:rest + |> add_symbol_to_children ~symbol:first_symbol + |> add_sorted_symbols_to_children ~sorted_symbols:rest in - let sortedSymbols = !symbols |> List.sort compareSymbol in - let symbolsWithChildren = [] |> addSortedSymbolsToChildren ~sortedSymbols in - `List (symbolsWithChildren |> List.map Lsp.Types.DocumentSymbol.yojson_of_t) + let sorted_symbols = !symbols |> List.sort compare_symbol in + let symbols_with_children = + [] |> add_sorted_symbols_to_children ~sorted_symbols + in + `List (symbols_with_children |> List.map Lsp.Types.DocumentSymbol.yojson_of_t) |> Yojson.Safe.pretty_to_string ~std:true |> print_endline diff --git a/analysis/src/dot_completion_utils.ml b/analysis/src/dot_completion_utils.ml new file mode 100644 index 00000000000..5bc0407df17 --- /dev/null +++ b/analysis/src/dot_completion_utils.ml @@ -0,0 +1,42 @@ +let filter_record_fields ~env ~record_as_string ~prefix ~exact fields = + fields + |> Utils.filter_map (fun (field : Shared_types.field) -> + if Utils.check_name field.fname.txt ~prefix ~exact then + Some + (Shared_types.Completion.create field.fname.txt ~env + ?deprecated:field.deprecated ~docstring:field.docstring + ~kind:(Shared_types.Completion.Field (field, record_as_string))) + else None) + +let field_completions_for_dot_completion ?pos_of_dot typ ~env ~package ~prefix + ~exact = + let as_object = typ |> Type_utils.extract_object_type ~env ~package in + match as_object with + | Some (obj_env, obj) -> + (* Handle obj completion via dot *) + if Debug.verbose () then + Printf.printf "[dot_completion]--> Obj type found:\n"; + obj |> Type_utils.get_obj_fields + |> Utils.filter_map (fun (field, _typ) -> + if Utils.check_name field ~prefix ~exact then + let full_obj_field_name = Printf.sprintf "[\"%s\"]" field in + Some + (Shared_types.Completion.create full_obj_field_name + ~synthetic:true ~insert_text:full_obj_field_name ~env:obj_env + ~kind:(Shared_types.Completion.ObjLabel typ) + ?additional_text_edits: + (match pos_of_dot with + | None -> None + | Some pos_of_dot -> + Some + (Type_utils.make_additional_text_edits_for_removing_dot + pos_of_dot))) + else None) + | None -> ( + match typ |> Type_utils.extract_record_type ~env ~package with + | Some (env, fields, typ_decl) -> + fields + |> filter_record_fields ~env ~prefix ~exact + ~record_as_string: + (typ_decl.item.decl |> Shared.decl_to_string typ_decl.name.txt) + | None -> []) diff --git a/analysis/src/dump_ast.ml b/analysis/src/dump_ast.ml new file mode 100644 index 00000000000..0ebb44c0d5a --- /dev/null +++ b/analysis/src/dump_ast.ml @@ -0,0 +1,345 @@ +open Shared_types +(* This is intended to be a debug tool. It's by no means complete. Rather, you're encouraged to extend this with printing whatever types you need printing. *) + +let empty_loc_denom = "" +let has_cursor_denom = "<*>" +let no_cursor_denom = "" + +let print_loc_denominator loc ~pos = + match loc |> Cursor_position.classify_loc ~pos with + | EmptyLoc -> empty_loc_denom + | HasCursor -> has_cursor_denom + | NoCursor -> no_cursor_denom + +let print_loc_denominator_loc loc ~pos = + match loc |> Cursor_position.classify_location_loc ~pos with + | Cursor_position.EmptyLoc -> empty_loc_denom + | HasCursor -> has_cursor_denom + | NoCursor -> no_cursor_denom + +let print_loc_denominator_pos pos ~pos_start ~pos_end = + match Cursor_position.classify_positions pos ~pos_start ~pos_end with + | Cursor_position.EmptyLoc -> empty_loc_denom + | HasCursor -> has_cursor_denom + | NoCursor -> no_cursor_denom + +let add_indentation indentation = + let rec indent str indentation = + if indentation < 1 then str else indent (str ^ " ") (indentation - 1) + in + indent "" indentation + +let print_attributes attributes = + match List.length attributes with + | 0 -> "" + | _ -> + "[" + ^ (attributes + |> List.map (fun ({Location.txt}, _payload) -> "@" ^ txt) + |> String.concat ",") + ^ "]" + +let print_constant const = + match const with + | Parsetree.Pconst_integer (s, _) -> "Pconst_integer(" ^ s ^ ")" + | Pconst_char c -> "Pconst_char(" ^ String.make 1 (Char.chr c) ^ ")" + | Pconst_string (s, delim) -> + let delim = + match delim with + | None -> "" + | Some delim -> delim ^ " " + in + "Pconst_string(" ^ delim ^ s ^ delim ^ ")" + | Pconst_float (s, _) -> "Pconst_float(" ^ s ^ ")" + +let print_core_type typ ~pos = + print_attributes typ.Parsetree.ptyp_attributes + ^ (typ.ptyp_loc |> print_loc_denominator ~pos) + ^ + match typ.ptyp_desc with + | Ptyp_any -> "Ptyp_any" + | Ptyp_var name -> "Ptyp_var(" ^ str name ^ ")" + | Ptyp_constr (lid, _types) -> + "Ptyp_constr(" + ^ (lid |> print_loc_denominator_loc ~pos) + ^ (Utils.flatten_long_ident lid.txt |> ident |> str) + ^ ")" + | Ptyp_variant _ -> "Ptyp_variant()" + | _ -> "" + +let rec print_pattern pattern ~pos ~indentation = + print_attributes pattern.Parsetree.ppat_attributes + ^ (pattern.ppat_loc |> print_loc_denominator ~pos) + ^ + match pattern.Parsetree.ppat_desc with + | Ppat_or (pat1, pat2) -> + "Ppat_or(\n" + ^ add_indentation (indentation + 1) + ^ print_pattern pat1 ~pos ~indentation:(indentation + 2) + ^ ",\n" + ^ add_indentation (indentation + 1) + ^ print_pattern pat2 ~pos ~indentation:(indentation + 2) + ^ "\n" + ^ add_indentation indentation + ^ ")" + | Ppat_extension (({txt} as loc), _) -> + "Ppat_extension(%" ^ (loc |> print_loc_denominator_loc ~pos) ^ txt ^ ")" + | Ppat_var ({txt} as loc) -> + "Ppat_var(" ^ (loc |> print_loc_denominator_loc ~pos) ^ txt ^ ")" + | Ppat_constant const -> "Ppat_constant(" ^ print_constant const ^ ")" + | Ppat_construct (({txt} as loc), maybe_pat) -> + "Ppat_construct(" + ^ (loc |> print_loc_denominator_loc ~pos) + ^ (Utils.flatten_long_ident txt |> ident |> str) + ^ (match maybe_pat with + | None -> "" + | Some pat -> "," ^ print_pattern pat ~pos ~indentation) + ^ ")" + | Ppat_variant (label, maybe_pat) -> + "Ppat_variant(" ^ str label + ^ (match maybe_pat with + | None -> "" + | Some pat -> "," ^ print_pattern pat ~pos ~indentation) + ^ ")" + | Ppat_record (fields, _) -> + "Ppat_record(\n" + ^ add_indentation (indentation + 1) + ^ "fields:\n" + ^ (Ext_list.map fields (fun {lid; x = pat} -> + add_indentation (indentation + 2) + ^ (lid |> print_loc_denominator_loc ~pos) + ^ (Utils.flatten_long_ident lid.txt |> ident |> str) + ^ ": " + ^ print_pattern pat ~pos ~indentation:(indentation + 2)) + |> String.concat "\n") + ^ "\n" + ^ add_indentation indentation + ^ ")" + | Ppat_tuple patterns -> + "Ppat_tuple(\n" + ^ (patterns + |> List.map (fun pattern -> + add_indentation (indentation + 2) + ^ (pattern |> print_pattern ~pos ~indentation:(indentation + 2))) + |> String.concat ",\n") + ^ "\n" + ^ add_indentation indentation + ^ ")" + | Ppat_any -> "Ppat_any" + | Ppat_constraint (pattern, typ) -> + "Ppat_constraint(\n" + ^ add_indentation (indentation + 1) + ^ print_core_type typ ~pos ^ ",\n" + ^ add_indentation (indentation + 1) + ^ (pattern |> print_pattern ~pos ~indentation:(indentation + 1)) + ^ "\n" + ^ add_indentation indentation + ^ ")" + | v -> Printf.sprintf "" (Utils.identify_ppat v) + +and print_case case ~pos ~indentation ~case_num = + add_indentation indentation + ^ Printf.sprintf "case %i:\n" case_num + ^ add_indentation (indentation + 1) + ^ "pattern" + ^ (case.Parsetree.pc_lhs.ppat_loc |> print_loc_denominator ~pos) + ^ ":\n" + ^ add_indentation (indentation + 2) + ^ print_pattern case.Parsetree.pc_lhs ~pos ~indentation + ^ "\n" + ^ add_indentation (indentation + 1) + ^ "expr" + ^ (case.Parsetree.pc_rhs.pexp_loc |> print_loc_denominator ~pos) + ^ ":\n" + ^ add_indentation (indentation + 2) + ^ print_expr_item case.pc_rhs ~pos ~indentation:(indentation + 2) + +and print_expr_item expr ~pos ~indentation = + print_attributes expr.Parsetree.pexp_attributes + ^ (expr.pexp_loc |> print_loc_denominator ~pos) + ^ + match expr.Parsetree.pexp_desc with + | Pexp_array exprs -> + "Pexp_array(\n" + ^ add_indentation (indentation + 1) + ^ (exprs + |> List.map (fun expr -> + expr |> print_expr_item ~pos ~indentation:(indentation + 1)) + |> String.concat ("\n" ^ add_indentation (indentation + 1))) + ^ "\n" + ^ add_indentation indentation + ^ ")" + | Pexp_match (match_expr, cases) -> + "Pexp_match(" + ^ print_expr_item match_expr ~pos ~indentation:0 + ^ ")\n" + ^ (cases + |> List.mapi (fun case_num case -> + print_case case ~pos ~case_num:(case_num + 1) + ~indentation:(indentation + 1)) + |> String.concat "\n") + | Pexp_ident {txt} -> + "Pexp_ident:" ^ (Utils.flatten_long_ident txt |> Shared_types.ident) + | Pexp_break -> "Pexp_break" + | Pexp_continue -> "Pexp_continue" + | Pexp_apply {funct = expr; args} -> + let print_label labelled ~pos = + match labelled with + | None -> "" + | Some labelled -> + print_loc_denominator_pos pos ~pos_start:labelled.pos_start + ~pos_end:labelled.pos_end + ^ "~" + ^ if labelled.opt then "?" else "" ^ labelled.name + in + let args = extract_exp_apply_args ~args in + "Pexp_apply(\n" + ^ add_indentation (indentation + 1) + ^ "expr:\n" + ^ add_indentation (indentation + 2) + ^ print_expr_item expr ~pos ~indentation:(indentation + 2) + ^ "\n" + ^ add_indentation (indentation + 1) + ^ "args:\n" + ^ (args + |> List.map (fun arg -> + add_indentation (indentation + 2) + ^ print_label arg.label ~pos ^ "=\n" + ^ add_indentation (indentation + 3) + ^ print_expr_item arg.exp ~pos ~indentation:(indentation + 3)) + |> String.concat ",\n") + ^ "\n" + ^ add_indentation indentation + ^ ")" + | Pexp_constant constant -> "Pexp_constant(" ^ print_constant constant ^ ")" + | Pexp_construct (({txt} as loc), maybe_expr) -> + "Pexp_construct(" + ^ (loc |> print_loc_denominator_loc ~pos) + ^ (Utils.flatten_long_ident txt |> ident |> str) + ^ (match maybe_expr with + | None -> "" + | Some expr -> ", " ^ print_expr_item expr ~pos ~indentation) + ^ ")" + | Pexp_variant (label, maybe_expr) -> + "Pexp_variant(" ^ str label + ^ (match maybe_expr with + | None -> "" + | Some expr -> "," ^ print_expr_item expr ~pos ~indentation) + ^ ")" + | Pexp_fun {arg_label = arg; lhs = pattern; rhs = next_expr} -> + "Pexp_fun(\n" + ^ add_indentation (indentation + 1) + ^ "arg: " + ^ (match arg with + | Nolabel -> "Nolabel" + | Labelled {txt = name} -> "Labelled(" ^ name ^ ")" + | Optional {txt = name} -> "Optional(" ^ name ^ ")") + ^ ",\n" + ^ add_indentation (indentation + 2) + ^ "pattern: " + ^ print_pattern pattern ~pos ~indentation:(indentation + 2) + ^ ",\n" + ^ add_indentation (indentation + 1) + ^ "next expr:\n" + ^ add_indentation (indentation + 2) + ^ print_expr_item next_expr ~pos ~indentation:(indentation + 2) + ^ "\n" + ^ add_indentation indentation + ^ ")" + | Pexp_extension (({txt} as loc), _) -> + "Pexp_extension(%" ^ (loc |> print_loc_denominator_loc ~pos) ^ txt ^ ")" + | Pexp_assert expr -> + "Pexp_assert(" ^ print_expr_item expr ~pos ~indentation ^ ")" + | Pexp_field (exp, loc) -> + "Pexp_field(" + ^ (loc |> print_loc_denominator_loc ~pos) + ^ print_expr_item exp ~pos ~indentation + ^ ")" + | Pexp_record (fields, _) -> + "Pexp_record(\n" + ^ add_indentation (indentation + 1) + ^ "fields:\n" + ^ (Ext_list.map fields (fun {lid; x = expr} -> + add_indentation (indentation + 2) + ^ (lid |> print_loc_denominator_loc ~pos) + ^ (Utils.flatten_long_ident lid.txt |> ident |> str) + ^ ": " + ^ print_expr_item expr ~pos ~indentation:(indentation + 2)) + |> String.concat "\n") + ^ "\n" + ^ add_indentation indentation + ^ ")" + | Pexp_tuple exprs -> + "Pexp_tuple(\n" + ^ (exprs + |> List.map (fun expr -> + add_indentation (indentation + 2) + ^ (expr |> print_expr_item ~pos ~indentation:(indentation + 2))) + |> String.concat ",\n") + ^ "\n" + ^ add_indentation indentation + ^ ")" + | v -> Printf.sprintf "" (Utils.identify_pexp v) + +let print_value_binding value ~pos ~indentation = + print_attributes value.Parsetree.pvb_attributes + ^ "value" ^ ":\n" + ^ add_indentation (indentation + 1) + ^ (value.pvb_pat |> print_pattern ~pos ~indentation:(indentation + 1)) + ^ "\n" + ^ add_indentation indentation + ^ "expr:\n" + ^ add_indentation (indentation + 1) + ^ print_expr_item value.pvb_expr ~pos ~indentation:(indentation + 1) + +let print_struct_item struct_item ~pos ~source = + match struct_item.Parsetree.pstr_loc |> Cursor_position.classify_loc ~pos with + | HasCursor -> ( + let start_offset = + match + Pos.position_to_offset source (struct_item.pstr_loc |> Loc.start) + with + | None -> 0 + | Some offset -> offset + in + let end_offset = + (* Include the next line of the source since that will hold the ast comment pointing to the position. + Caveat: this only works for single line sources with a comment on the next line. Will need to be + adapted if that's not the only use case.*) + let line, _col = struct_item.pstr_loc |> Loc.end_ in + match Pos.position_to_offset source (line + 2, 0) with + | None -> 0 + | Some offset -> offset + in + + ("\nSource:\n// " + ^ String.sub source start_offset (end_offset - start_offset) + ^ "\n") + ^ print_loc_denominator struct_item.pstr_loc ~pos + ^ + match struct_item.pstr_desc with + | Pstr_eval (expr, _attributes) -> + "Pstr_eval(\n" ^ print_expr_item expr ~pos ~indentation:1 ^ "\n)" + | Pstr_value (rec_flag, values) -> + "Pstr_value(\n" + ^ (match rec_flag with + | Recursive -> " rec,\n" + | Nonrecursive -> "") + ^ (values + |> List.map (fun value -> + add_indentation 1 ^ print_value_binding value ~pos ~indentation:1) + |> String.concat ",\n") + ^ "\n)" + | _ -> "") + | _ -> "" + +let dump ~current_file ~pos = + let {Res_driver.parsetree = structure; source} = + Res_driver.parsing_engine.parse_implementation ~for_printer:true + ~filename:current_file + in + + print_endline + (structure + |> List.map (fun struct_item -> print_struct_item struct_item ~pos ~source) + |> String.concat "") diff --git a/analysis/src/Files.ml b/analysis/src/files.ml similarity index 66% rename from analysis/src/Files.ml rename to analysis/src/files.ml index aafe2012534..2c71d6a736a 100644 --- a/analysis/src/Files.ml +++ b/analysis/src/files.ml @@ -1,33 +1,33 @@ let split str string = Str.split (Str.regexp_string str) string -let removeExtraDots path = +let remove_extra_dots path = Str.global_replace (Str.regexp_string "/./") "/" path |> Str.global_replace (Str.regexp {|^\./\.\./|}) "../" (* Win32 & MacOS are case-insensitive *) -let pathEq = +let path_eq = if Sys.os_type = "Linux" then fun a b -> a = b else fun a b -> String.lowercase_ascii a = String.lowercase_ascii b -let pathStartsWith text prefix = +let path_starts_with text prefix = String.length prefix <= String.length text - && pathEq (String.sub text 0 (String.length prefix)) prefix + && path_eq (String.sub text 0 (String.length prefix)) prefix -let sliceToEnd str pos = String.sub str pos (String.length str - pos) +let slice_to_end str pos = String.sub str pos (String.length str - pos) let relpath base path = - if pathStartsWith path base then + if path_starts_with path base then let baselen = String.length base in let rest = String.sub path baselen (String.length path - baselen) in - (if rest <> "" && rest.[0] = Filename.dir_sep.[0] then sliceToEnd rest 1 + (if rest <> "" && rest.[0] = Filename.dir_sep.[0] then slice_to_end rest 1 else rest) - |> removeExtraDots + |> remove_extra_dots else let rec loop bp pp = match (bp, pp) with | "." :: ra, _ -> loop ra pp | _, "." :: rb -> loop bp rb - | a :: ra, b :: rb when pathEq a b -> loop ra rb + | a :: ra, b :: rb when path_eq a b -> loop ra rb | _ -> (bp, pp) in let base, path = @@ -38,12 +38,12 @@ let relpath base path = | [] -> ["."] | _ -> List.map (fun _ -> "..") base) @ path) - |> removeExtraDots + |> remove_extra_dots -let maybeStat path = +let maybe_stat path = try Some (Unix.stat path) with Unix.Unix_error (Unix.ENOENT, _, _) -> None -let readFile filename = +let read_file filename = try (* windows can't use open_in *) let chan = open_in_bin filename in @@ -53,12 +53,12 @@ let readFile filename = with _ -> None let exists path = - match maybeStat path with + match maybe_stat path with | None -> false | Some _ -> true -let ifExists path = if exists path then Some path else None +let if_exists path = if exists path then Some path else None -let readDirectory dir = +let read_directory dir = match Unix.opendir dir with | exception Unix.Unix_error (Unix.ENOENT, "opendir", _dir) -> [] | handle -> @@ -74,45 +74,45 @@ let readDirectory dir = in loop handle -let rec collectDirs path = - match maybeStat path with +let rec collect_dirs path = + match maybe_stat path with | None -> [] | Some {Unix.st_kind = Unix.S_DIR} -> path - :: (readDirectory path - |> List.map (fun name -> collectDirs (Filename.concat path name)) + :: (read_directory path + |> List.map (fun name -> collect_dirs (Filename.concat path name)) |> List.concat) | _ -> [] -let rec collect ?(checkDir = fun _ -> true) ?maxDepth path test = - match (maxDepth, maybeStat path) with +let rec collect ?(check_dir = fun _ -> true) ?max_depth path test = + match (max_depth, maybe_stat path) with | None, None -> [] | Some 0, _ -> [] | None, Some {Unix.st_kind = Unix.S_DIR} -> - if checkDir path then - readDirectory path + if check_dir path then + read_directory path |> List.map (fun name -> - collect ~checkDir (Filename.concat path name) test) + collect ~check_dir (Filename.concat path name) test) |> List.concat else [] | Some n, Some {Unix.st_kind = Unix.S_DIR} -> - if checkDir path then - readDirectory path + if check_dir path then + read_directory path |> List.map (fun name -> - collect ~checkDir ~maxDepth:(n - 1) + collect ~check_dir ~max_depth:(n - 1) (Filename.concat path name) test) |> List.concat else [] | _ -> if test path then [path] else [] -type classifiedFile = Res | Resi | Other +type classified_file = Res | Resi | Other -let classifySourceFile path = +let classify_source_file path = if Filename.check_suffix path ".res" && exists path then Res else if Filename.check_suffix path ".resi" && exists path then Resi else Other -let canonicalizeUri uri = - let path = Uri.toPath uri in - path |> Unix.realpath |> Uri.fromPath |> Uri.toString +let canonicalize_uri uri = + let path = Uri.to_path uri in + path |> Unix.realpath |> Uri.from_path |> Uri.to_string diff --git a/analysis/src/find_files.ml b/analysis/src/find_files.ml new file mode 100644 index 00000000000..9bc07111265 --- /dev/null +++ b/analysis/src/find_files.ml @@ -0,0 +1,353 @@ +let if_debug debug name fn v = if debug then Log.log (name ^ ": " ^ fn v) +let ( /+ ) = Filename.concat +let bind f x = Option.bind x f + +(* Returns a list of paths, relative to the provided `base` *) +let get_source_directories ~include_dev ~base_dir config = + let rec handle_item current item = + match item with + | `List contents -> List.map (handle_item current) contents |> List.concat + | `String text -> [current /+ text] + | `Assoc _ -> ( + let dir = + item |> Yojson_helpers.get "dir" + |> bind Yojson_helpers.string_opt + |> Option.value ~default:"Must specify directory" + in + let typ = + if include_dev then "lib" + else + item |> Yojson_helpers.get "type" + |> bind Yojson_helpers.string_opt + |> Option.value ~default:"lib" + in + + if typ = "dev" then [] + else + match item |> Yojson_helpers.get "subdirs" with + | None | Some (`Bool false) -> [current /+ dir] + | Some (`Bool true) -> + Files.collect_dirs (base_dir /+ current /+ dir) + |> List.filter (fun name -> name <> Filename.current_dir_name) + |> List.map (Files.relpath base_dir) + | Some item -> (current /+ dir) :: handle_item (current /+ dir) item) + | _ -> failwith "Invalid subdirs entry" + in + match config |> Yojson_helpers.get "sources" with + | None -> [] + | Some item -> handle_item "" item + +let is_compiled_file name = + Filename.check_suffix name ".cmt" || Filename.check_suffix name ".cmti" + +let is_implementation name = + Filename.check_suffix name ".re" + || Filename.check_suffix name ".res" + || Filename.check_suffix name ".ml" + +let is_interface name = + Filename.check_suffix name ".rei" + || Filename.check_suffix name ".resi" + || Filename.check_suffix name ".mli" + +let is_source_file name = is_implementation name || is_interface name + +let compiled_name_space name = + String.split_on_char '-' name + |> List.map String.capitalize_ascii + |> String.concat "" + (* Remove underscores??? Whyyy bucklescript, whyyyy *) + |> String.split_on_char '_' + |> String.concat "" + +let compiled_base_name ~namespace name = + Filename.chop_extension name + ^ + match namespace with + | None -> "" + | Some n -> "-" ^ compiled_name_space n + +let get_name x = + Filename.basename x |> Filename.chop_extension |> String.capitalize_ascii + +let filter_duplicates cmts = + (* Remove .cmt's that have .cmti's *) + let intfs = Hashtbl.create 100 in + cmts + |> List.iter (fun path -> + if + Filename.check_suffix path ".rei" + || Filename.check_suffix path ".mli" + || Filename.check_suffix path ".cmti" + then Hashtbl.add intfs (get_name path) true); + cmts + |> List.filter (fun path -> + not + ((Filename.check_suffix path ".re" + || Filename.check_suffix path ".ml" + || Filename.check_suffix path ".cmt") + && Hashtbl.mem intfs (get_name path))) + +let name_space_to_name n = + n + |> Str.split (Str.regexp "[-/@]") + |> List.map String.capitalize_ascii + |> String.concat "" + +type namespace_config = + | NamespaceDisabled + | NamespaceFromPackageName + | NamespaceExplicit of string + +let getNamespaceConfig config = + match config |> Yojson_helpers.get "namespace" with + | None | Some (`Bool false) -> NamespaceDisabled + | Some (`Bool true) -> NamespaceFromPackageName + | Some (`String namespace) -> NamespaceExplicit namespace + | Some _ -> NamespaceDisabled + +let get_namespace config = + match getNamespaceConfig config with + | NamespaceDisabled -> None + | NamespaceExplicit namespace -> Some (name_space_to_name namespace) + | NamespaceFromPackageName -> + let fromName = + config |> Yojson_helpers.get "name" |> bind Yojson_helpers.string_opt + in + fromName |> Option.map name_space_to_name + +module String_set = Set.Make (String) + +let get_public config = + let public = config |> Yojson_helpers.get "public" in + match public with + | None -> None + | Some public -> ( + match public |> Yojson_helpers.to_list_opt with + | None -> None + | Some public -> + Some + (public + |> List.filter_map Yojson_helpers.string_opt + |> String_set.of_list)) + +let collect_files directory = + let all_files = Files.read_directory directory in + let compileds = + all_files |> List.filter is_compiled_file |> filter_duplicates + in + let sources = all_files |> List.filter is_source_file |> filter_duplicates in + compileds + |> Utils.filter_map (fun path -> + let mod_name = get_name path in + let cmt = directory /+ path in + let res_opt = + Utils.find + (fun name -> + if get_name name = mod_name then Some (directory /+ name) + else None) + sources + in + match res_opt with + | None -> None + | Some res -> Some (mod_name, Shared_types.Impl {cmt; res})) + +(* Dependency resolution uses the package graph recorded by the build system in + .sourcedirs.json when available. If a package is not listed there, analysis + falls back to walking up node_modules from the project root. *) +let read_sourcedirs_package_roots base = + let source_dirs_file = base /+ "lib" /+ "bs" /+ ".sourcedirs.json" in + let read_package_entry = function + | `List [`String name; `String path] -> + let path = if Filename.is_relative path then base /+ path else path in + Some (name, path) + | _ -> None + in + match Files.read_file source_dirs_file with + | None -> [] + | Some text -> ( + match Yojson_helpers.from_string_opt text with + | None -> [] + | Some json -> ( + match + json |> Yojson_helpers.get "pkgs" |> bind Yojson_helpers.to_list_opt + with + | None -> [] + | Some packages -> packages |> List.filter_map read_package_entry)) + +let find_package_root ~base ~sourcedirs_package_roots name = + match List.assoc_opt name sourcedirs_package_roots with + | Some path when Files.exists path -> Some path + | _ -> Module_resolution.resolve_node_module_path ~start_path:base name + +(* returns a list of (absolute path to cmt(i), relative path from base to source file) *) +let find_project_files ~public ~namespace ~path ~source_directories ~lib_bs = + let dirs = + source_directories |> List.map (Filename.concat path) |> String_set.of_list + in + let files = + (* Use maxDepth to prevent infinite recursion where `rescript` depends on `@rescript/runtime`, + but `@rescript/runtime` also has `rescript` as a dev dependency *) + dirs |> String_set.elements + |> List.map (fun name -> Files.collect ~max_depth:2 name is_source_file) + |> List.concat |> String_set.of_list + in + dirs + |> if_debug true "Source directories" (fun s -> + s |> String_set.elements |> List.map Utils.dump_path + |> String.concat " "); + files + |> if_debug true "Source files" (fun s -> + s |> String_set.elements |> List.map Utils.dump_path + |> String.concat " "); + + let interfaces = Hashtbl.create 100 in + files + |> String_set.iter (fun path -> + if is_interface path then + Hashtbl.replace interfaces (get_name path) path); + + let normals = + files |> String_set.elements + |> Utils.filter_map (fun file -> + if is_implementation file then ( + let module_name = get_name file in + let resi = Hashtbl.find_opt interfaces module_name in + Hashtbl.remove interfaces module_name; + let base = + compiled_base_name ~namespace (Files.relpath path file) + in + match resi with + | Some resi -> + let cmti = (lib_bs /+ base) ^ ".cmti" in + let cmt = (lib_bs /+ base) ^ ".cmt" in + if Files.exists cmti then + if Files.exists cmt then + (* Log.log("Intf and impl " ++ cmti ++ " " ++ cmt) *) + Some + ( module_name, + Shared_types.IntfAndImpl {cmti; resi; cmt; res = file} ) + else None + else ( + (* Log.log("Just intf " ++ cmti) *) + Log.log + ("Bad source file (no cmt/cmti/cmi) " ^ (lib_bs /+ base)); + None) + | None -> + let cmt = (lib_bs /+ base) ^ ".cmt" in + if Files.exists cmt then + Some (module_name, Impl {cmt; res = file}) + else ( + Log.log ("Bad source file (no cmt/cmi) " ^ (lib_bs /+ base)); + None)) + else None) + in + let result = + normals + |> List.filter_map (fun (name, paths) -> + let original_name = name in + let name = + match namespace with + | None -> name + | Some namespace -> name ^ "-" ^ namespace + in + match public with + | Some public -> + if public |> String_set.mem original_name then Some (name, paths) + else None + | None -> Some (name, paths)) + in + match namespace with + | None -> result + | Some namespace -> + let module_name = name_space_to_name namespace in + let cmt = (lib_bs /+ namespace) ^ ".cmt" in + Log.log ("adding namespace " ^ namespace ^ " : " ^ module_name ^ " : " ^ cmt); + (module_name, Namespace {cmt}) :: result + +let find_dependency_files base config = + let deps = + match + ( config + |> Yojson_helpers.get "dependencies" + |> bind Yojson_helpers.to_list_opt, + config + |> Yojson_helpers.get "bs-dependencies" + |> bind Yojson_helpers.to_list_opt ) + with + | None, None -> [] + | Some deps, None | _, Some deps -> + deps |> List.filter_map Yojson_helpers.string_opt + in + let dev_deps = + match + ( config + |> Yojson_helpers.get "dev-dependencies" + |> bind Yojson_helpers.to_list_opt, + config + |> Yojson_helpers.get "bs-dev-dependencies" + |> bind Yojson_helpers.to_list_opt ) + with + | None, None -> [] + | Some dev_deps, None | _, Some dev_deps -> + dev_deps |> List.filter_map Yojson_helpers.string_opt + in + let deps = deps @ dev_deps in + Log.log ("Dependencies: " ^ String.concat " " deps); + let sourcedirs_package_roots = read_sourcedirs_package_roots base in + let dep_files = + deps + |> List.map (fun name -> + let result = + bind + (fun path -> + let rescript_json_path = path /+ "rescript.json" in + + let parse_text text = + match Yojson_helpers.from_string_opt text with + | Some inner -> ( + let namespace = get_namespace inner in + let source_directories = + get_source_directories ~include_dev:false ~base_dir:path + inner + in + match Build_system.get_lib_bs path with + | None -> None + | Some lib_bs -> + let compiled_directories = + source_directories |> List.map (Filename.concat lib_bs) + in + let compiled_directories = + match namespace with + | None -> compiled_directories + | Some _ -> lib_bs :: compiled_directories + in + let project_files = + find_project_files ~public:(get_public inner) + ~namespace ~path ~source_directories ~lib_bs + in + Some (compiled_directories, project_files)) + | None -> None + in + + match Files.read_file rescript_json_path with + | Some text -> parse_text text + | None -> None) + (find_package_root ~base ~sourcedirs_package_roots name) + in + + match result with + | Some (files, directories) -> (files, directories) + | None -> + Log.log ("Skipping nonexistent dependency: " ^ name); + ([], [])) + in + match Build_system.get_stdlib base with + | None -> None + | Some stdlib_directory -> + let compiled_directories, project_files = + let files, directories = List.split dep_files in + (List.concat files, List.concat directories) + in + let all_files = project_files @ collect_files stdlib_directory in + Some (compiled_directories, all_files) diff --git a/analysis/src/Hint.ml b/analysis/src/hint.ml similarity index 74% rename from analysis/src/Hint.ml rename to analysis/src/hint.ml index d5f10838077..cad294f840d 100644 --- a/analysis/src/Hint.ml +++ b/analysis/src/hint.ml @@ -1,11 +1,11 @@ -open SharedTypes +open Shared_types -type inlayHintKind = Type -let inlayKindToLspInlayHint = function +type inlay_hint_kind = Type +let inlay_kind_to_lsp_inlay_hint = function | Type -> Lsp.Types.InlayHintKind.Type -let locItemToTypeHint ~full:{file; package} locItem = - match locItem.locType with +let loc_item_to_type_hint ~full:{file; package} loc_item = + match loc_item.loc_type with | Constant t -> Some (match t with @@ -16,36 +16,36 @@ let locItemToTypeHint ~full:{file; package} locItem = | Const_int32 _ -> "int32" | Const_int64 _ -> "int64" | Const_bigint _ -> "bigint") - | Typed (_, t, locKind) -> - let fromType typ = - typ |> Shared.typeToString + | Typed (_, t, loc_kind) -> + let from_type typ = + typ |> Shared.type_to_string |> Str.global_replace (Str.regexp "[\r\n\t]") "" in Some - (match References.definedForLoc ~file ~package locKind with - | None -> fromType t + (match References.defined_for_loc ~file ~package loc_kind with + | None -> from_type t | Some (_, res) -> ( match res with - | `Declared -> fromType t - | `Constructor _ -> fromType t - | `Field -> fromType t)) + | `Declared -> from_type t + | `Constructor _ -> from_type t + | `Field -> from_type t)) | _ -> None -let inlay ~source ~kindFile ~pos ~maxLength ~full ~debug = - let maxlen = try Some (int_of_string maxLength) with Failure _ -> None in +let inlay ~source ~kind_file ~pos ~max_length ~full ~debug = + let maxlen = try Some (int_of_string max_length) with Failure _ -> None in let hints = ref [] in let start_line, end_line = pos in let push loc kind = - let range = Utils.cmtLocToRange loc in + let range = Utils.cmt_loc_to_range loc in if start_line <= range.end_.line && end_line >= range.start.line then hints := (range, kind) :: !hints in - let rec processPattern (pat : Parsetree.pattern) = + let rec process_pattern (pat : Parsetree.pattern) = match pat.ppat_desc with - | Ppat_tuple pl -> pl |> List.iter processPattern + | Ppat_tuple pl -> pl |> List.iter process_pattern | Ppat_record (fields, _) -> - Ext_list.iter fields (fun {x = p} -> processPattern p) - | Ppat_array fields -> fields |> List.iter processPattern + Ext_list.iter fields (fun {x = p} -> process_pattern p) + | Ppat_array fields -> fields |> List.iter process_pattern | Ppat_var {loc} -> push loc Type | _ -> () in @@ -65,13 +65,13 @@ let inlay ~source ~kindFile ~pos ~maxLength ~full ~debug = }; } -> push vb.pvb_pat.ppat_loc Type - | {pvb_pat = {ppat_desc = Ppat_tuple _}} -> processPattern vb.pvb_pat - | {pvb_pat = {ppat_desc = Ppat_record _}} -> processPattern vb.pvb_pat + | {pvb_pat = {ppat_desc = Ppat_tuple _}} -> process_pattern vb.pvb_pat + | {pvb_pat = {ppat_desc = Ppat_record _}} -> process_pattern vb.pvb_pat | _ -> ()); Ast_iterator.default_iterator.value_binding iterator vb in let iterator = {Ast_iterator.default_iterator with value_binding} in - (if kindFile = Files.Res then + (if kind_file = Files.Res then let parser = Res_driver.parsing_engine.parse_implementation_from_source ~for_printer:false @@ -83,21 +83,21 @@ let inlay ~source ~kindFile ~pos ~maxLength ~full ~debug = | Some full -> let result = !hints - |> List.filter_map (fun ((range : Lsp.Types.Range.t), hintKind) -> + |> List.filter_map (fun ((range : Lsp.Types.Range.t), hint_kind) -> match - References.getLocItem ~full + References.get_loc_item ~full ~pos:(range.start.line, range.start.character + 1) ~debug with | None -> None - | Some locItem -> ( + | Some loc_item -> ( let position = Lsp.Types.Position.create ~line:range.start.line ~character:range.end_.character in - match locItemToTypeHint locItem ~full with + match loc_item_to_type_hint loc_item ~full with | Some label -> ( - let kind = inlayKindToLspInlayHint hintKind in + let kind = inlay_kind_to_lsp_inlay_hint hint_kind in let label = ": " ^ label in let result = Lsp.Types.InlayHint.create ~position ~kind ~paddingLeft:true @@ -111,10 +111,10 @@ let inlay ~source ~kindFile ~pos ~maxLength ~full ~debug = in Some result -let codeLens ~source ~kindFile ~full ~debug = +let code_lens ~source ~kind_file ~full ~debug = let lenses = ref [] in let push loc = - let range = Utils.cmtLocToRange loc in + let range = Utils.cmt_loc_to_range loc in lenses := range :: !lenses in (* Code lenses are only emitted for functions right now. So look for value bindings that are functions, @@ -133,7 +133,7 @@ let codeLens ~source ~kindFile ~full ~debug = let iterator = {Ast_iterator.default_iterator with value_binding} in (* We only print code lenses in implementation files. This is because they'd be redundant in interface files, where the definition itself will be the same thing as what would've been printed in the code lens. *) - (if kindFile = Files.Res then + (if kind_file = Files.Res then let parser = Res_driver.parsing_engine.parse_implementation_from_source ~for_printer:false @@ -147,11 +147,11 @@ let codeLens ~source ~kindFile ~full ~debug = !lenses |> List.filter_map (fun (range : Lsp.Types.Range.t) -> match - References.getLocItem ~full + References.get_loc_item ~full ~pos:(range.start.line, range.start.character + 1) ~debug with - | Some {locType = Typed (_, typeExpr, _)} -> + | Some {loc_type = Typed (_, type_expr, _)} -> (* Code lenses can run commands. An empty command string means we just want the editor to print the text, not link to running a command. *) let command = @@ -159,7 +159,7 @@ let codeLens ~source ~kindFile ~full ~debug = ~command:"" (* Print the type with a huge line width, because the code lens always prints on a single line in the editor. *) - ~title:(typeExpr |> Shared.typeToString ~lineWidth:400) + ~title:(type_expr |> Shared.type_to_string ~line_width:400) () in Some (Lsp.Types.CodeLens.create ~range ~command ()) diff --git a/analysis/src/hover.ml b/analysis/src/hover.ml new file mode 100644 index 00000000000..f87029695a3 --- /dev/null +++ b/analysis/src/hover.ml @@ -0,0 +1,328 @@ +open Shared_types + +module String_set = Set.Make (String) + +let show_module_top_level ~docstring ~is_type ~name + (top_level : Module.item list) = + let contents = + top_level + |> List.map (fun item -> + match item.Module.kind with + (* TODO pretty print module contents *) + | Type ({decl}, rec_status) -> + " " ^ (decl |> Shared.decl_to_string ~rec_status item.name) + | Module _ -> " module " ^ item.name + | Value typ -> + " let " ^ item.name ^ ": " ^ (typ |> Shared.type_to_string)) + (* TODO indent *) + |> String.concat "\n" + in + let name = Utils.cut_after_dash name in + let full = + Markdown.code_block + ("module " + ^ (if is_type then "type " ^ name ^ " = " else name ^ ": ") + ^ "{" ^ "\n" ^ contents ^ "\n}") + in + let doc = + match docstring with + | [] -> "" + | _ :: _ -> + "\n" + ^ (docstring |> String.concat "\n") + ^ Markdown.divider ^ Markdown.spacing + in + Some (doc ^ full) + +let rec show_module ~docstring ~(file : File.t) ~package ~name + (declared : Module.t Declared.t option) = + match declared with + | None -> + show_module_top_level ~docstring ~is_type:false ~name file.structure.items + | Some {item = Structure {items}; module_path} -> + let is_type = + match module_path with + | ExportedModule {is_type} -> is_type + | _ -> false + in + show_module_top_level ~docstring ~is_type ~name items + | Some ({item = Constraint (_moduleItem, module_type_item)} as declared) -> + (* show the interface *) + show_module ~docstring ~file ~name ~package + (Some {declared with item = module_type_item}) + | Some ({item = Ident path} as declared) -> ( + match References.resolve_module_reference ~file ~package declared with + | None -> Some ("Unable to resolve module reference " ^ Path.name path) + | Some (_, declared) -> show_module ~docstring ~file ~name ~package declared + ) + +type extracted_type = { + name: string; + path: Path.t; + decl: Types.type_declaration; + env: Shared_types.Query_env.t; + loc: Warnings.loc; +} + +let find_relevant_types_from_type ~file ~package typ = + (* Expand definitions of types mentioned in typ. + If typ itself is a record or variant, search its body *) + let env = Query_env.from_file file in + let env_to_search, types_to_search = + match typ |> Shared.dig_constructor with + | Some path -> ( + let label_declarations_types lds = + lds |> List.map (fun (ld : Types.label_declaration) -> ld.ld_type) + in + match References.dig_constructor ~env ~package path with + | None -> (env, [typ]) + | Some (env1, {item = {decl}}) -> ( + match decl.type_kind with + | Type_record (lds, _) -> + (env1, typ :: (lds |> label_declarations_types)) + | Type_variant cds -> + ( env1, + cds + |> List.map (fun (cd : Types.constructor_declaration) -> + let from_args = + match cd.cd_args with + | Cstr_tuple ts -> ts + | Cstr_record lds -> lds |> label_declarations_types + in + typ + :: + (match cd.cd_res with + | None -> from_args + | Some t -> t :: from_args)) + |> List.flatten ) + | _ -> (env, [typ]))) + | None -> (env, [typ]) + in + let from_constructor_path ~env path = + match References.dig_constructor ~env ~package path with + | None -> None + | Some (env, {name = {txt}; extent_loc; item = {decl}}) -> + if Utils.is_uncurried_internal path then None + else Some {name = txt; env; loc = extent_loc; decl; path} + in + let constructors = Shared.find_type_constructors types_to_search in + constructors |> List.filter_map (from_constructor_path ~env:env_to_search) + +let expand_types ~file ~package ~supports_markdown_links typ = + match find_relevant_types_from_type typ ~file ~package with + | {decl; path} :: _ + when Res_parsetree_viewer.has_inline_record_definition_attribute + decl.type_attributes -> + (* We print inline record types just with their definition, not the constr pointing + to them, since that doesn't make sense to show the user. *) + ( [ + Markdown.code_block + (decl + |> Shared.decl_to_string ~print_name_as_is:true + (Shared_types.path_ident_to_string path)); + ], + `InlineType ) + | all -> + let types_seen = ref String_set.empty in + let type_id ~(env : Query_env.t) ~name = + env.file.module_name :: List.rev (name :: env.path_rev) + |> String.concat "." + in + ( all + (* Don't produce duplicate type definitions for recursive types *) + |> List.filter (fun {env; name} -> + let type_id = type_id ~env ~name in + if String_set.mem type_id !types_seen then false + else ( + types_seen := String_set.add type_id !types_seen; + true)) + |> List.map (fun {decl; env; loc; path} -> + let link_to_type_definition_str = + if + supports_markdown_links + && not + (Res_parsetree_viewer + .has_inline_record_definition_attribute + decl.type_attributes) + then + Markdown.go_to_definition_text ~env ~pos:loc.Warnings.loc_start + else "" + in + Markdown.divider + ^ (if supports_markdown_links then Markdown.spacing else "") + ^ Markdown.code_block + (decl + |> Shared.decl_to_string ~print_name_as_is:true + (Shared_types.path_ident_to_string path)) + ^ link_to_type_definition_str ^ "\n"), + `Default ) + +(* Produces a hover with relevant types expanded in the main type being hovered. *) +let hover_with_expanded_types ~file ~package ~supports_markdown_links ?docstring + ?constructor typ = + let expanded_types, expansion_type = + expand_types ~file ~package ~supports_markdown_links typ + in + match expansion_type with + | `Default -> + let type_string = Shared.type_to_string typ in + let type_string = + match constructor with + | Some constructor -> + type_string ^ "\n" ^ Completion_back_end.show_constructor constructor + | None -> type_string + in + let type_string = + match docstring with + | Some [] | None -> Markdown.code_block type_string + | Some docstring -> + Markdown.code_block type_string + ^ Markdown.divider + ^ (docstring |> String.concat "\n") + in + type_string :: expanded_types |> String.concat "\n" + | `InlineType -> expanded_types |> String.concat "\n" + +(* Leverages autocomplete functionality to produce a hover for a position. This + makes it (most often) work with unsaved content. *) +let get_hover_via_completions ~debug ~source ~kind_file ~pos ~for_hover + ~supports_markdown_links ~full = + match + Completions.get_completions ~debug ~source ~kind_file ~pos ~for_hover ~full + with + | None -> None + | Some (completions, ({file; package} as full), scope) -> ( + let raw_opens = Scope.get_raw_opens scope in + match completions with + | {kind = Label typ_string; docstring} :: _ -> + let parts = + docstring + @ if typ_string = "" then [] else [Markdown.code_block typ_string] + in + + Some (String.concat "\n\n" parts) + | {kind = Field _; env; docstring} :: _ -> ( + let opens = + Completion_back_end.get_opens ~debug ~raw_opens ~package ~env + in + match + Completion_back_end.completions_get_type_env2 ~debug ~full ~raw_opens + ~opens ~pos completions + with + | Some (typ, _env) -> + let type_string = + hover_with_expanded_types ~file ~package ~docstring + ~supports_markdown_links typ + in + Some type_string + | None -> None) + | {env} :: _ -> ( + let opens = + Completion_back_end.get_opens ~debug ~raw_opens ~package ~env + in + match + Completion_back_end.completions_get_type_env2 ~debug ~full ~raw_opens + ~opens ~pos completions + with + | Some (typ, _env) -> + let type_string = + hover_with_expanded_types ~file ~package ~supports_markdown_links typ + in + Some type_string + | None -> None) + | _ -> None) + +let new_hover ~full:{file; package} ~supports_markdown_links loc_item = + match loc_item.loc_type with + | TypeDefinition (name, decl, _stamp) -> ( + let type_def = Markdown.code_block (Shared.decl_to_string name decl) in + match decl.type_manifest with + | None -> Some type_def + | Some typ -> ( + let expanded_types, expansion_type = + expand_types ~file ~package ~supports_markdown_links typ + in + match expansion_type with + | `Default -> Some (type_def :: expanded_types |> String.concat "\n") + | `InlineType -> Some (expanded_types |> String.concat "\n"))) + | LModule (Definition (stamp, _tip)) | LModule (LocalReference (stamp, _tip)) + -> ( + match Stamps.find_module file.stamps stamp with + | None -> None + | Some md -> ( + match References.resolve_module_reference ~file ~package md with + | None -> None + | Some (file, declared) -> + let name, docstring = + match declared with + | Some d -> (d.name.txt, d.docstring) + | None -> (file.module_name, file.structure.docstring) + in + show_module ~docstring ~name ~file declared ~package)) + | LModule (GlobalReference (module_name, path, tip)) -> ( + match Process_cmt.file_for_module ~package module_name with + | None -> None + | Some file -> ( + let env = Query_env.from_file file in + match References.exported_for_tip ~env ~path ~package ~tip with + | None -> None + | Some (_env, _name, stamp) -> ( + match Stamps.find_module file.stamps stamp with + | None -> None + | Some md -> ( + match References.resolve_module_reference ~file ~package md with + | None -> None + | Some (file, declared) -> + let name, docstring = + match declared with + | Some d -> (d.name.txt, d.docstring) + | None -> (file.module_name, file.structure.docstring) + in + show_module ~docstring ~name ~file ~package declared)))) + | LModule NotFound -> None + | TopLevelModule name -> ( + match Process_cmt.file_for_module ~package name with + | None -> None + | Some file -> + show_module ~docstring:file.structure.docstring ~name:file.module_name + ~file ~package None) + | Typed (_, _, Definition (_, (Field _ | Constructor _))) -> None + | Constant t -> + Some + (Markdown.code_block + (match t with + | Const_int _ -> "int" + | Const_char _ -> "char" + | Const_string _ -> "string" + | Const_float _ -> "float" + | Const_int32 _ -> "int32" + | Const_int64 _ -> "int64" + | Const_bigint _ -> "bigint")) + | Typed (_, t, loc_kind) -> ( + let from_type ?docstring ?constructor typ = + hover_with_expanded_types ~file ~package ~supports_markdown_links + ?docstring ?constructor typ + in + (* Expand first-class modules to the underlying module type signature. *) + let t = Shared.dig t in + match t.desc with + | Tpackage (path, _lids, _tys) -> ( + let env = Query_env.from_file file in + match + Resolve_path.resolve_module_from_compiler_path ~env ~package path + with + | None -> Some (from_type t) + | Some (env_for_module, Some declared) -> + let name = Path.name path in + show_module ~docstring:declared.docstring ~name + ~file:env_for_module.file ~package (Some declared) + | Some (_, None) -> Some (from_type t)) + | _ -> + Some + (match References.defined_for_loc ~file ~package loc_kind with + | None -> t |> from_type + | Some (docstring, res) -> ( + match res with + | `Declared | `Field -> t |> from_type ~docstring + | `Constructor constructor -> + t |> from_type ~docstring:constructor.docstring ~constructor))) diff --git a/analysis/src/jsx_hacks.ml b/analysis/src/jsx_hacks.ml new file mode 100644 index 00000000000..70db806dbfe --- /dev/null +++ b/analysis/src/jsx_hacks.ml @@ -0,0 +1,5 @@ +let path_is_fragment path = Path.name path = "ReasonReact.fragment" + +let primitive_is_fragment (vd : Typedtree.value_description) = + vd.val_name.txt = "fragment" + && vd.val_loc.loc_start.pos_fname |> Filename.basename = "ReasonReact.res" diff --git a/analysis/src/Loc.ml b/analysis/src/loc.ml similarity index 57% rename from analysis/src/Loc.ml rename to analysis/src/loc.ml index 6febb9a6267..abb5669ed1a 100644 --- a/analysis/src/Loc.ml +++ b/analysis/src/loc.ml @@ -1,28 +1,28 @@ type t = Location.t -let start (loc : t) = Pos.ofLexing loc.loc_start -let end_ (loc : t) = Pos.ofLexing loc.loc_end +let start (loc : t) = Pos.of_lexing loc.loc_start +let end_ (loc : t) = Pos.of_lexing loc.loc_end let range loc : Range.t = (start loc, end_ loc) -let toString (loc : t) = - (if loc.loc_ghost then "__ghost__" else "") ^ (loc |> range |> Range.toString) +let to_string (loc : t) = + (if loc.loc_ghost then "__ghost__" else "") ^ (loc |> range |> Range.to_string) -let hasPos ~pos loc = start loc <= pos && pos < end_ loc +let has_pos ~pos loc = start loc <= pos && pos < end_ loc (** Allows the character after the end to be included. Ie when the cursor is at the end of the word, like `someIdentifier`. Useful in some scenarios. *) -let hasPosInclusiveEnd ~pos loc = start loc <= pos && pos <= end_ loc +let has_pos_inclusive_end ~pos loc = start loc <= pos && pos <= end_ loc -let mkPosition (pos : Pos.t) = +let mk_position (pos : Pos.t) = let line, character = pos in Lsp.Types.Position.create ~line ~character -let rangeOfLoc (loc : t) = - let start = loc |> start |> mkPosition in - let end_ = loc |> end_ |> mkPosition in +let range_of_loc (loc : t) = + let start = loc |> start |> mk_position in + let end_ = loc |> end_ |> mk_position in Lsp.Types.Range.create ~start ~end_ -let isInside (x : t) (y : t) = +let is_inside (x : t) (y : t) = x.loc_start.pos_cnum >= y.loc_start.pos_cnum && x.loc_end.pos_cnum <= y.loc_end.pos_cnum && x.loc_start.pos_lnum >= y.loc_start.pos_lnum diff --git a/analysis/src/local_tables.ml b/analysis/src/local_tables.ml new file mode 100644 index 00000000000..a4676d80eb0 --- /dev/null +++ b/analysis/src/local_tables.ml @@ -0,0 +1,65 @@ +open Shared_types + +type 'a table = (string * (int * int), 'a Declared.t) Hashtbl.t +type names_used = (string, unit) Hashtbl.t + +type t = { + names_used: names_used; + mutable result_rev: Completion.t list; + constructor_table: Constructor.t table; + modules_table: Module.t table; + types_table: Type.t table; + value_table: Types.type_expr table; + included_value_table: (string * Types.type_expr) table; +} + +let create () = + { + names_used = Hashtbl.create 1; + result_rev = []; + constructor_table = Hashtbl.create 1; + modules_table = Hashtbl.create 1; + types_table = Hashtbl.create 1; + value_table = Hashtbl.create 1; + included_value_table = Hashtbl.create 1; + } + +let populate_values ~env local_tables = + env.Query_env.file.stamps + |> Stamps.iter_values (fun _ declared -> + Hashtbl.replace local_tables.value_table + (declared.name.txt, declared.name.loc |> Loc.start) + declared) + +let populate_included_values ~env local_tables = + env.Query_env.file.stamps + |> Stamps.iter_values (fun _ declared -> + match declared.module_path with + | Module_path.IncludedModule (source, _) -> + let path = Path.name source in + let declared = {declared with item = (path, declared.item)} in + Hashtbl.replace local_tables.included_value_table + (declared.name.txt, declared.name.loc |> Loc.start) + declared + | _ -> ()) + +let populate_constructors ~env local_tables = + env.Query_env.file.stamps + |> Stamps.iter_constructors (fun _ declared -> + Hashtbl.replace local_tables.constructor_table + (declared.name.txt, declared.extent_loc |> Loc.start) + declared) + +let populate_types ~env local_tables = + env.Query_env.file.stamps + |> Stamps.iter_types (fun _ declared -> + Hashtbl.replace local_tables.types_table + (declared.name.txt, declared.name.loc |> Loc.start) + declared) + +let populate_modules ~env local_tables = + env.Query_env.file.stamps + |> Stamps.iter_modules (fun _ declared -> + Hashtbl.replace local_tables.modules_table + (declared.name.txt, declared.extent_loc |> Loc.start) + declared) diff --git a/analysis/src/Log.ml b/analysis/src/log.ml similarity index 100% rename from analysis/src/Log.ml rename to analysis/src/log.ml diff --git a/analysis/src/markdown.ml b/analysis/src/markdown.ml new file mode 100644 index 00000000000..ea92d1c5b25 --- /dev/null +++ b/analysis/src/markdown.ml @@ -0,0 +1,23 @@ +let spacing = "\n```\n \n```\n" +let code_block code = Printf.sprintf "```rescript\n%s\n```" code +let divider = "\n---\n" + +type link = {start_pos: Lsp.Types.Position.t; file: string; label: string} + +let link_to_command_args link = + Printf.sprintf "[\"%s\",%i,%i]" link.file link.start_pos.line + link.start_pos.character + +let make_goto_command link = + Printf.sprintf "[%s](command:rescript-vscode.go_to_location?%s)" link.label + (Uri.encode_u_r_i_component (link_to_command_args link)) + +let go_to_definition_text ~env ~pos = + let start_line, start_col = Pos.of_lexing pos in + "\nGo to: " + ^ make_goto_command + { + label = "Type definition"; + file = Uri.to_string env.Shared_types.Query_env.file.uri; + start_pos = {line = start_line; character = start_col}; + } diff --git a/analysis/src/ModuleResolution.ml b/analysis/src/module_resolution.ml similarity index 61% rename from analysis/src/ModuleResolution.ml rename to analysis/src/module_resolution.ml index 343e5381d10..622fc83227f 100644 --- a/analysis/src/ModuleResolution.ml +++ b/analysis/src/module_resolution.ml @@ -1,6 +1,6 @@ let ( /+ ) = Filename.concat -let rec resolveNodeModulePath ~startPath name = +let rec resolve_node_module_path ~start_path name = if name = "@rescript/runtime" then (* Hack: we need a reliable way to resolve modules in monorepos. *) Some !Runtime_package.path @@ -12,7 +12,7 @@ let rec resolveNodeModulePath ~startPath name = | '@' -> scope /+ name | _ -> name in - let path = startPath /+ "node_modules" /+ name in + let path = start_path /+ "node_modules" /+ name in if Files.exists path then Some path - else if Filename.dirname startPath = startPath then None - else resolveNodeModulePath ~startPath:(Filename.dirname startPath) name + else if Filename.dirname start_path = start_path then None + else resolve_node_module_path ~start_path:(Filename.dirname start_path) name diff --git a/analysis/src/packages.ml b/analysis/src/packages.ml new file mode 100644 index 00000000000..3a5068f1776 --- /dev/null +++ b/analysis/src/packages.ml @@ -0,0 +1,231 @@ +open Shared_types + +(* Creates the `pathsForModule` hashtbl, which maps a `moduleName` to it's `paths` (the ml/re, mli/rei, cmt, and cmti files) *) +let make_paths_for_module ~project_files_and_paths ~dependencies_files_and_paths + = + let paths_for_module = Hashtbl.create 30 in + dependencies_files_and_paths + |> List.iter (fun (mod_name, paths) -> + Hashtbl.replace paths_for_module mod_name paths); + project_files_and_paths + |> List.iter (fun (mod_name, paths) -> + Hashtbl.replace paths_for_module mod_name paths); + paths_for_module + +let override_rescript_version = ref None + +let get_re_script_version () = + match !override_rescript_version with + | Some override_rescript_version -> override_rescript_version + | None -> ( + (* TODO: Include patch stuff when needed *) + let default_version = (11, 0) in + try + let value = Sys.getenv "RESCRIPT_VERSION" in + let version = + match value |> String.split_on_char '.' with + | major :: minor :: _rest -> ( + match (int_of_string_opt major, int_of_string_opt minor) with + | Some major, Some minor -> (major, minor) + | _ -> default_version) + | _ -> default_version + in + version + with Not_found -> default_version) + +let new_bs_package ~root_path = + let rescript_json = Filename.concat root_path "rescript.json" in + + let parse_raw raw = + let lib_bs = + match !Cfg.is_doc_gen_from_compiler with + | true -> Build_system.get_stdlib root_path + | false -> Build_system.get_lib_bs root_path + in + match Yojson_helpers.from_string_opt raw with + | Some config -> ( + let namespace = Find_files.get_namespace config in + let rescript_version = get_re_script_version () in + let suffix = + match config |> Yojson_helpers.get "suffix" with + | Some (`String suffix) -> suffix + | _ -> ".js" + in + let generic_jsx_module = + let jsx_config = config |> Yojson_helpers.get "jsx" in + match jsx_config with + | Some jsx_config -> ( + match jsx_config |> Yojson_helpers.get "module" with + | Some (`String m) when String.lowercase_ascii m <> "react" -> Some m + | _ -> None) + | None -> None + in + let autocomplete = + match config |> Yojson_helpers.get "editor" with + | Some editor_config -> ( + match editor_config |> Yojson_helpers.get "autocomplete" with + | Some (`Assoc map) -> + map + |> List.fold_left + (fun acc (key, value) -> + match value with + | `List items -> + let values = + items + |> List.filter_map (function + | `String s -> Some s + | _ -> None) + in + Misc.String_map.add key values acc + | _ -> acc) + Misc.String_map.empty + | _ -> Misc.String_map.empty) + | None -> Misc.String_map.empty + in + match lib_bs with + | None -> None + | Some lib_bs -> + let cached = Cache.read_cache (Cache.target_file_from_lib_bs lib_bs) in + let project_files, dependencies_files, paths_for_module = + match cached with + | Some cached -> + ( cached.project_files, + cached.dependencies_files, + cached.paths_for_module ) + | None -> + let dependencies_files_and_paths = + match Find_files.find_dependency_files root_path config with + | None -> [] + | Some (_dependencyDirectories, dependencies_files_and_paths) -> + dependencies_files_and_paths + in + let source_directories = + Find_files.get_source_directories ~include_dev:true + ~base_dir:root_path config + in + let project_files_and_paths = + Find_files.find_project_files + ~public:(Find_files.get_public config) + ~namespace ~path:root_path ~source_directories ~lib_bs + in + let paths_for_module = + make_paths_for_module ~project_files_and_paths + ~dependencies_files_and_paths + in + let project_files = + project_files_and_paths |> List.map fst |> File_set.of_list + in + let dependencies_files = + dependencies_files_and_paths |> List.map fst |> File_set.of_list + in + (project_files, dependencies_files, paths_for_module) + in + Some + (let opens_from_namespace = + match namespace with + | None -> [] + | Some namespace -> + let cmt = Filename.concat lib_bs namespace ^ ".cmt" in + Hashtbl.replace paths_for_module namespace (Namespace {cmt}); + let path = [Find_files.name_space_to_name namespace] in + [path] + in + let bind f x = Option.bind x f in + let compiler_flags = + match + ( Yojson_helpers.get "compiler-flags" config + |> bind Yojson_helpers.to_list_opt, + Yojson_helpers.get "bsc-flags" config + |> bind Yojson_helpers.to_list_opt ) + with + | Some compiler_flags, None | _, Some compiler_flags -> + compiler_flags + | None, None -> [] + in + let no_pervasives = + compiler_flags + |> List.exists (fun s -> + match s with + | `String s -> s = "-nopervasives" + | _ -> false) + in + let opens_from_compiler_flags = + List.fold_left + (fun opens item -> + match item |> Yojson_helpers.string_opt with + | None -> opens + | Some s -> ( + let parts = String.split_on_char ' ' s in + match parts with + | "-open" :: name :: _ -> + let path = name |> String.split_on_char '.' in + path :: opens + | _ -> opens)) + [] compiler_flags + in + let opens_from_pervasives = + if no_pervasives then [] + else [["Stdlib"]; ["Pervasives"; "JsxModules"]] + in + let opens = + opens_from_pervasives @ opens_from_namespace + |> List.rev_append opens_from_compiler_flags + |> List.map (fun path -> path @ ["place holder"]) + in + { + generic_jsx_module; + suffix; + rescript_version; + root_path; + project_files; + dependencies_files; + paths_for_module; + opens; + namespace; + autocomplete; + })) + | None -> None + in + + match Files.read_file rescript_json with + | Some raw -> parse_raw raw + | None -> + Log.log ("Unable to read " ^ rescript_json); + None + +let find_root ~uri packages_by_root = + let path = Uri.to_path uri in + let rec loop path = + if path = "/" then None + else if Hashtbl.mem packages_by_root path then Some (`Root path) + else if Files.exists (Filename.concat path "rescript.json") then + Some (`Bs path) + else + let parent = Filename.dirname path in + if parent = path then (* reached root *) None else loop parent + in + loop (if Sys.is_directory path then path else Filename.dirname path) + +let get_package ~uri = + let open Shared_types in + if Hashtbl.mem state.root_for_uri uri then + Some + (Hashtbl.find state.packages_by_root + (Hashtbl.find state.root_for_uri uri)) + else + match find_root ~uri state.packages_by_root with + | None -> + Log.log "No root directory found"; + None + | Some (`Root root_path) -> + Hashtbl.replace state.root_for_uri uri root_path; + Some + (Hashtbl.find state.packages_by_root + (Hashtbl.find state.root_for_uri uri)) + | Some (`Bs root_path) -> ( + match new_bs_package ~root_path with + | None -> None + | Some package -> + Hashtbl.replace state.root_for_uri uri package.root_path; + Hashtbl.replace state.packages_by_root package.root_path package; + Some package) diff --git a/analysis/src/pipe_completion_utils.ml b/analysis/src/pipe_completion_utils.ml new file mode 100644 index 00000000000..385da524da4 --- /dev/null +++ b/analysis/src/pipe_completion_utils.ml @@ -0,0 +1,26 @@ +let add_jsx_completion_items ~main_type_id ~env ~prefix + ~(full : Shared_types.full) ~raw_opens typ = + match main_type_id with + | ("array" | "float" | "string" | "int") as builtin_name_to_complete -> + if Utils.check_name builtin_name_to_complete ~prefix ~exact:false then + let name = + match full.package.generic_jsx_module with + | None -> "React." ^ builtin_name_to_complete + | Some g -> + g ^ "." ^ builtin_name_to_complete + |> String.split_on_char '.' + |> Type_utils.remove_opens_from_completion_path ~raw_opens + ~package:full.package + |> String.concat "." + in + [ + Shared_types.Completion.create name ~synthetic:true + ~includes_snippets:true ~kind:(Value typ) ~env ~sort_text:"A" + ~docstring: + [ + "Turns `" ^ builtin_name_to_complete + ^ "` into a JSX element so it can be used inside of JSX."; + ]; + ] + else [] + | _ -> [] diff --git a/analysis/src/Pos.ml b/analysis/src/pos.ml similarity index 61% rename from analysis/src/Pos.ml rename to analysis/src/pos.ml index d739c9dae12..0418aeabf74 100644 --- a/analysis/src/Pos.ml +++ b/analysis/src/pos.ml @@ -1,11 +1,11 @@ type t = int * int -let ofLexing {Lexing.pos_lnum; pos_cnum; pos_bol} = +let of_lexing {Lexing.pos_lnum; pos_cnum; pos_bol} = (pos_lnum - 1, pos_cnum - pos_bol) -let toString (loc, col) = Printf.sprintf "%d:%d" loc col +let to_string (loc, col) = Printf.sprintf "%d:%d" loc col -let offsetOfLine text line = +let offset_of_line text line = let ln = String.length text in let rec loop i lno = if i >= ln then None @@ -18,16 +18,16 @@ let offsetOfLine text line = | 0 -> Some 0 | _ -> loop 0 0 -let positionToOffset text (line, character) = - match offsetOfLine text line with +let position_to_offset text (line, character) = + match offset_of_line text line with | None -> None | Some bol -> let offset = bol + character in if offset >= 0 && offset <= String.length text then Some offset else None -let posBeforeCursor pos = (fst pos, max 0 (snd pos - 1)) +let pos_before_cursor pos = (fst pos, max 0 (snd pos - 1)) -let posOfDot text ~(pos : int * int) ~offset = +let pos_of_dot text ~(pos : int * int) ~offset = let rec loop i = if i < 0 then None else @@ -38,7 +38,7 @@ let posOfDot text ~(pos : int * int) ~offset = in match loop (offset - 1) with | None -> None - | Some offsetBeforeDot -> + | Some offset_before_dot -> let line, col = pos in - let newCol = max 0 (col - (offset - offsetBeforeDot)) in - Some (line, newCol) + let new_col = max 0 (col - (offset - offset_before_dot)) in + Some (line, new_col) diff --git a/analysis/src/PrintType.ml b/analysis/src/print_type.ml similarity index 67% rename from analysis/src/PrintType.ml rename to analysis/src/print_type.ml index 3234d11b45b..5d3ddf9503c 100644 --- a/analysis/src/PrintType.ml +++ b/analysis/src/print_type.ml @@ -1,11 +1,11 @@ -let printExpr ?(lineWidth = 60) typ = +let print_expr ?(line_width = 60) typ = Printtyp.reset_names (); Printtyp.reset_and_mark_loops typ; - Res_doc.to_string ~width:lineWidth + Res_doc.to_string ~width:line_width (Res_outcome_printer.print_out_type_doc (Printtyp.tree_of_typexp false typ)) -let printDecl ?printNameAsIs ~recStatus name decl = +let print_decl ?print_name_as_is ~rec_status name decl = Printtyp.reset_names (); Res_doc.to_string ~width:60 - (Res_outcome_printer.print_out_sig_item_doc ?print_name_as_is:printNameAsIs - (Printtyp.tree_of_type_declaration (Ident.create name) decl recStatus)) + (Res_outcome_printer.print_out_sig_item_doc ?print_name_as_is + (Printtyp.tree_of_type_declaration (Ident.create name) decl rec_status)) diff --git a/analysis/src/ProcessAttributes.ml b/analysis/src/process_attributes.ml similarity index 64% rename from analysis/src/ProcessAttributes.ml rename to analysis/src/process_attributes.ml index 31d994d5e03..62df3ca3ea6 100644 --- a/analysis/src/ProcessAttributes.ml +++ b/analysis/src/process_attributes.ml @@ -1,7 +1,7 @@ -open SharedTypes +open Shared_types (* TODO should I hang on to location? *) -let rec findDocAttribute attributes = +let rec find_doc_attribute attributes = let open Parsetree in match attributes with | [] -> None @@ -15,9 +15,9 @@ let rec findDocAttribute attributes = ] ) :: _ -> Some doc - | _ :: rest -> findDocAttribute rest + | _ :: rest -> find_doc_attribute rest -let rec findDeprecatedAttribute attributes = +let rec find_deprecated_attribute attributes = let open Parsetree in match attributes with | [] -> None @@ -42,44 +42,45 @@ let rec findDeprecatedAttribute attributes = Some !reason | _ -> None) | ({Asttypes.txt = "deprecated"}, _) :: _ -> Some "" - | _ :: rest -> findDeprecatedAttribute rest + | _ :: rest -> find_deprecated_attribute rest -let newDeclared ~item ~extent ~name ~stamp ~modulePath isExported attributes = +let new_declared ~item ~extent ~name ~stamp ~module_path is_exported attributes + = { Declared.name; stamp; - extentLoc = extent; - isExported; - modulePath; - deprecated = findDeprecatedAttribute (List.rev attributes); + extent_loc = extent; + is_exported; + module_path; + deprecated = find_deprecated_attribute (List.rev attributes); docstring = - (match findDocAttribute attributes with + (match find_doc_attribute attributes with | None -> [] | Some d -> [d]); item; } -let rec findEditorCompleteFromAttribute ?(modulePaths = []) attributes = +let rec find_editor_complete_from_attribute ?(module_paths = []) attributes = let open Parsetree in match attributes with - | [] -> modulePaths + | [] -> module_paths | ( {Asttypes.txt = "editor.completeFrom"}, - PStr [{pstr_desc = Pstr_eval (payloadExpr, _)}] ) + PStr [{pstr_desc = Pstr_eval (payload_expr, _)}] ) :: rest -> let items = - match payloadExpr with + match payload_expr with | {pexp_desc = Pexp_array items} -> items | p -> [p] in - let modulePathsFromArray = + let module_paths_from_array = items |> List.filter_map (fun item -> match item.Parsetree.pexp_desc with | Pexp_construct ({txt = path}, None) -> - Some (Utils.flattenLongIdent path) + Some (Utils.flatten_long_ident path) | _ -> None) in - findEditorCompleteFromAttribute - ~modulePaths:(modulePathsFromArray @ modulePaths) + find_editor_complete_from_attribute + ~module_paths:(module_paths_from_array @ module_paths) rest - | _ :: rest -> findEditorCompleteFromAttribute ~modulePaths rest + | _ :: rest -> find_editor_complete_from_attribute ~module_paths rest diff --git a/analysis/src/ProcessCmt.ml b/analysis/src/process_cmt.ml similarity index 60% rename from analysis/src/ProcessCmt.ml rename to analysis/src/process_cmt.ml index 96601f6e3be..24066d80cec 100644 --- a/analysis/src/ProcessCmt.ml +++ b/analysis/src/process_cmt.ml @@ -1,26 +1,26 @@ -open SharedTypes +open Shared_types -let isModuleType (declared : Module.t Declared.t) = - match declared.modulePath with - | ExportedModule {isType} -> isType +let is_module_type (declared : Module.t Declared.t) = + match declared.module_path with + | ExportedModule {is_type} -> is_type | _ -> false -let addDeclared ~(name : string Location.loc) ~extent ~stamp ~(env : Env.t) - ~item attributes addExported addStamp = - let isExported = addExported name.txt stamp in +let add_declared ~(name : string Location.loc) ~extent ~stamp ~(env : Env.t) + ~item attributes add_exported add_stamp = + let is_exported = add_exported name.txt stamp in let declared = - ProcessAttributes.newDeclared ~item ~extent ~name ~stamp - ~modulePath:env.modulePath isExported attributes + Process_attributes.new_declared ~item ~extent ~name ~stamp + ~module_path:env.module_path is_exported attributes in - addStamp env.stamps stamp declared; + add_stamp env.stamps stamp declared; declared -let attrsToDocstring attrs = - match ProcessAttributes.findDocAttribute attrs with +let attrs_to_docstring attrs = + match Process_attributes.find_doc_attribute attrs with | None -> [] | Some docstring -> [docstring] -let mapRecordField {Types.ld_id; ld_type; ld_attributes; ld_optional} = +let map_record_field {Types.ld_id; ld_type; ld_attributes; ld_optional} = let astamp = Ident.binding_time ld_id in let name = Ident.name ld_id in { @@ -29,34 +29,34 @@ let mapRecordField {Types.ld_id; ld_type; ld_attributes; ld_optional} = typ = ld_type; optional = ld_optional; docstring = - (match ProcessAttributes.findDocAttribute ld_attributes with + (match Process_attributes.find_doc_attribute ld_attributes with | None -> [] | Some docstring -> [docstring]); - deprecated = ProcessAttributes.findDeprecatedAttribute ld_attributes; + deprecated = Process_attributes.find_deprecated_attribute ld_attributes; } -let rec forTypeSignatureItem ~(env : SharedTypes.Env.t) ~(exported : Exported.t) - (item : Types.signature_item) = +let rec for_type_signature_item ~(env : Shared_types.Env.t) + ~(exported : Exported.t) (item : Types.signature_item) = match item with | Sig_value (ident, {val_type; val_attributes; val_loc = loc}) -> let item = val_type in let stamp = Ident.binding_time ident in - let oldDeclared = Stamps.findValue env.stamps stamp in + let old_declared = Stamps.find_value env.stamps stamp in let declared = - addDeclared + add_declared ~name:(Location.mkloc (Ident.name ident) loc) ~extent:loc ~stamp ~env ~item val_attributes (Exported.add exported Exported.Value) - Stamps.addValue + Stamps.add_value in let declared = (* When an id is shadowed, a module constraint without the doc comment is created. Here the existing doc comment is restored. See https://github.com/rescript-lang/rescript-vscode/issues/621 *) - match oldDeclared with - | Some oldDeclared when declared.docstring = [] -> - let newDeclared = {declared with docstring = oldDeclared.docstring} in - Stamps.addValue env.stamps stamp newDeclared; - newDeclared + match old_declared with + | Some old_declared when declared.docstring = [] -> + let new_declared = {declared with docstring = old_declared.docstring} in + Stamps.add_value env.stamps stamp new_declared; + new_declared | _ -> declared in [ @@ -65,16 +65,16 @@ let rec forTypeSignatureItem ~(env : SharedTypes.Env.t) ~(exported : Exported.t) name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; - loc = declared.extentLoc; + loc = declared.extent_loc; }; ] | Sig_type ( ident, ({type_loc; type_kind; type_manifest; type_attributes} as decl), - recStatus ) -> + rec_status ) -> let declared = let name = Location.mknoloc (Ident.name ident) in - addDeclared ~extent:type_loc + add_declared ~extent:type_loc ~item: { Type.decl; @@ -110,84 +110,87 @@ let rec forTypeSignatureItem ~(env : SharedTypes.Env.t) ~(exported : Exported.t) (args |> List.map (fun t -> (t, Location.none))) | Cstr_record fields -> - InlineRecord (fields |> List.map mapRecordField)); + InlineRecord + (fields |> List.map map_record_field)); res = cd_res; - typeDecl = (name, decl); - docstring = attrsToDocstring cd_attributes; + type_decl = (name, decl); + docstring = attrs_to_docstring cd_attributes; deprecated = - ProcessAttributes.findDeprecatedAttribute + Process_attributes.find_deprecated_attribute cd_attributes; } in let declared = - ProcessAttributes.newDeclared ~item ~extent:cd_loc + Process_attributes.new_declared ~item ~extent:cd_loc ~name:(Location.mknoloc name) ~stamp (* TODO maybe this needs another child *) - ~modulePath:env.modulePath true cd_attributes + ~module_path:env.module_path true cd_attributes in - Stamps.addConstructor env.stamps stamp declared; + Stamps.add_constructor env.stamps stamp declared; item)) | Type_record (fields, _) -> - Record (fields |> List.map mapRecordField)); + Record (fields |> List.map map_record_field)); } ~name ~stamp:(Ident.binding_time ident) ~env type_attributes (Exported.add exported Exported.Type) - Stamps.addType + Stamps.add_type in [ { - Module.kind = Type (declared.item, recStatus); + Module.kind = Type (declared.item, rec_status); name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; - loc = declared.extentLoc; + loc = declared.extent_loc; }; ] | Sig_module (ident, {md_type; md_attributes; md_loc}, _) -> let name = Ident.name ident in let declared = - addDeclared ~extent:md_loc - ~item:(forTypeModule ~name ~env md_type) + add_declared ~extent:md_loc + ~item:(for_type_module ~name ~env md_type) ~name:(Location.mkloc name md_loc) ~stamp:(Ident.binding_time ident) ~env md_attributes (Exported.add exported Exported.Module) - Stamps.addModule + Stamps.add_module in [ { Module.kind = - Module {type_ = declared.item; isModuleType = isModuleType declared}; + Module + {type_ = declared.item; is_module_type = is_module_type declared}; name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; - loc = declared.extentLoc; + loc = declared.extent_loc; }; ] | _ -> [] -and forTypeSignature ~name ~env signature = +and for_type_signature ~name ~env signature = let exported = Exported.init () in let items = List.fold_right - (fun item items -> forTypeSignatureItem ~env ~exported item @ items) + (fun item items -> for_type_signature_item ~env ~exported item @ items) signature [] in {Module.name; docstring = []; exported; items; deprecated = None} -and forTypeModule ~name ~env moduleType = - match moduleType with +and for_type_module ~name ~env module_type = + match module_type with | Types.Mty_ident path -> Ident path | Mty_alias (_ (* 402 *), path) -> Ident path - | Mty_signature signature -> Structure (forTypeSignature ~name ~env signature) - | Mty_functor (_argIdent, _argType, resultType) -> - forTypeModule ~name ~env resultType + | Mty_signature signature -> + Structure (for_type_signature ~name ~env signature) + | Mty_functor (_argIdent, _argType, result_type) -> + for_type_module ~name ~env result_type -let getModuleTypePath mod_desc = +let get_module_type_path mod_desc = match mod_desc with | Typedtree.Tmty_ident (path, _) | Tmty_alias (path, _) -> Some path | Tmty_signature _ | Tmty_functor _ | Tmty_with _ | Tmty_typeof _ -> None -let forTypeDeclaration ~env ~(exported : Exported.t) +let for_type_declaration ~env ~(exported : Exported.t) { Typedtree.typ_id; typ_loc; @@ -196,10 +199,10 @@ let forTypeDeclaration ~env ~(exported : Exported.t) typ_type; typ_kind; typ_manifest; - } ~recStatus = + } ~rec_status = let stamp = Ident.binding_time typ_id in let declared = - addDeclared ~extent:typ_loc + add_declared ~extent:typ_loc ~item: { Type.decl = typ_type; @@ -237,7 +240,7 @@ let forTypeDeclaration ~env ~(exported : Exported.t) Constructor.stamp; cname; deprecated = - ProcessAttributes.findDeprecatedAttribute + Process_attributes.find_deprecated_attribute cd_attributes; args = (match cd_args with @@ -262,30 +265,31 @@ let forTypeDeclaration ~env ~(exported : Exported.t) optional = f.ld_optional; docstring = (match - ProcessAttributes - .findDocAttribute f.ld_attributes + Process_attributes + .find_doc_attribute + f.ld_attributes with | None -> [] | Some docstring -> [docstring]); deprecated = - ProcessAttributes - .findDeprecatedAttribute + Process_attributes + .find_deprecated_attribute f.ld_attributes; }))); res = (match cd_res with | None -> None | Some t -> Some t.ctyp_type); - typeDecl = (name.txt, typ_type); - docstring = attrsToDocstring cd_attributes; + type_decl = (name.txt, typ_type); + docstring = attrs_to_docstring cd_attributes; } in let declared = - ProcessAttributes.newDeclared ~item ~extent:cd_loc - ~name:cname ~stamp ~modulePath:env.modulePath true + Process_attributes.new_declared ~item ~extent:cd_loc + ~name:cname ~stamp ~module_path:env.module_path true cd_attributes in - Stamps.addConstructor env.stamps stamp declared; + Stamps.add_constructor env.stamps stamp declared; item)) | Ttype_record fields -> Record @@ -306,34 +310,34 @@ let forTypeDeclaration ~env ~(exported : Exported.t) fname; typ = ctyp_type; optional = ld_optional; - docstring = attrsToDocstring ld_attributes; + docstring = attrs_to_docstring ld_attributes; deprecated = - ProcessAttributes.findDeprecatedAttribute + Process_attributes.find_deprecated_attribute ld_attributes; }))); } ~name ~stamp ~env typ_attributes (Exported.add exported Exported.Type) - Stamps.addType + Stamps.add_type in { - Module.kind = Module.Type (declared.item, recStatus); + Module.kind = Module.Type (declared.item, rec_status); name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; - loc = declared.extentLoc; + loc = declared.extent_loc; } -let rec forSignatureItem ~env ~(exported : Exported.t) +let rec for_signature_item ~env ~(exported : Exported.t) (item : Typedtree.signature_item) = match item.sig_desc with | Tsig_value {val_id; val_loc; val_name = name; val_desc; val_attributes} -> let declared = - addDeclared ~name + add_declared ~name ~stamp:(Ident.binding_time val_id) ~extent:val_loc ~item:val_desc.ctyp_type ~env val_attributes (Exported.add exported Exported.Value) - Stamps.addValue + Stamps.add_value in [ { @@ -341,102 +345,103 @@ let rec forSignatureItem ~env ~(exported : Exported.t) name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; - loc = declared.extentLoc; + loc = declared.extent_loc; }; ] - | Tsig_type (recFlag, decls) -> + | Tsig_type (rec_flag, decls) -> decls |> List.mapi (fun i decl -> - let recStatus = - match recFlag with + let rec_status = + match rec_flag with | Recursive when i = 0 -> Types.Trec_first | Nonrecursive when i = 0 -> Types.Trec_not | _ -> Types.Trec_next in - decl |> forTypeDeclaration ~env ~exported ~recStatus) + decl |> for_type_declaration ~env ~exported ~rec_status) | Tsig_module {md_id; md_attributes; md_loc; md_name = name; md_type = {mty_type}} -> let item = - forTypeModule ~name:name.txt - ~env:(env |> Env.addModule ~name:name.txt) + for_type_module ~name:name.txt + ~env:(env |> Env.add_module ~name:name.txt) mty_type in let declared = - addDeclared ~item ~name ~extent:md_loc ~stamp:(Ident.binding_time md_id) + add_declared ~item ~name ~extent:md_loc ~stamp:(Ident.binding_time md_id) ~env md_attributes (Exported.add exported Exported.Module) - Stamps.addModule + Stamps.add_module in [ { Module.kind = - Module {type_ = declared.item; isModuleType = isModuleType declared}; + Module + {type_ = declared.item; is_module_type = is_module_type declared}; name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; - loc = declared.extentLoc; + loc = declared.extent_loc; }; ] - | Tsig_recmodule modDecls -> - modDecls - |> List.map (fun modDecl -> - forSignatureItem ~env ~exported - {item with sig_desc = Tsig_module modDecl}) + | Tsig_recmodule mod_decls -> + mod_decls + |> List.map (fun mod_decl -> + for_signature_item ~env ~exported + {item with sig_desc = Tsig_module mod_decl}) |> List.flatten | Tsig_include {incl_mod; incl_type} -> let env = - match getModuleTypePath incl_mod.mty_desc with + match get_module_type_path incl_mod.mty_desc with | None -> env | Some path -> - {env with modulePath = IncludedModule (path, env.modulePath)} + {env with module_path = IncludedModule (path, env.module_path)} in - let topLevel = + let top_level = List.fold_right - (fun item items -> forTypeSignatureItem ~env ~exported item @ items) + (fun item items -> for_type_signature_item ~env ~exported item @ items) incl_type [] in - topLevel + top_level (* TODO: process other things here *) | _ -> [] -let forSignature ~name ~env sigItems = +let for_signature ~name ~env sig_items = let exported = Exported.init () in let items = - sigItems |> List.map (forSignatureItem ~env ~exported) |> List.flatten + sig_items |> List.map (for_signature_item ~env ~exported) |> List.flatten in let attributes = - match sigItems with + match sig_items with | {sig_desc = Tsig_attribute attribute} :: _ -> [attribute] | _ -> [] in - let docstring = attrsToDocstring attributes in - let deprecated = ProcessAttributes.findDeprecatedAttribute attributes in + let docstring = attrs_to_docstring attributes in + let deprecated = Process_attributes.find_deprecated_attribute attributes in {Module.name; docstring; exported; items; deprecated} -let forTreeModuleType ~name ~env {Typedtree.mty_desc} = +let for_tree_module_type ~name ~env {Typedtree.mty_desc} = match mty_desc with | Tmty_ident _ -> None | Tmty_signature {sig_items} -> - let contents = forSignature ~name ~env sig_items in + let contents = for_signature ~name ~env sig_items in Some (Module.Structure contents) | _ -> None -let rec getModulePath mod_desc = +let rec get_module_path mod_desc = match mod_desc with | Typedtree.Tmod_ident (path, _lident) -> Some path | Tmod_structure _ -> None | Tmod_functor (_ident, _argName, _maybeType, _resultExpr) -> None - | Tmod_apply (functor_, _arg, _coercion) -> getModulePath functor_.mod_desc + | Tmod_apply (functor_, _arg, _coercion) -> get_module_path functor_.mod_desc | Tmod_unpack (_expr, _moduleType) -> None | Tmod_constraint (expr, _typ, _constraint, _coercion) -> - getModulePath expr.mod_desc + get_module_path expr.mod_desc -let rec forStructureItem ~(env : SharedTypes.Env.t) ~(exported : Exported.t) +let rec for_structure_item ~(env : Shared_types.Env.t) ~(exported : Exported.t) item = match item.Typedtree.str_desc with | Tstr_value (_isRec, bindings) -> let items = ref [] in - let rec handlePattern attributes pat = + let rec handle_pattern attributes pat = match pat.Typedtree.pat_desc with | Tpat_var (ident, name) | Tpat_alias (_, ident, name) (* let x : t = ... *) -> @@ -444,7 +449,7 @@ let rec forStructureItem ~(env : SharedTypes.Env.t) ~(exported : Exported.t) let unpack_loc_opt = match pat.pat_extra - |> Utils.filterMap (function + |> Utils.filter_map (function | Typedtree.Tpat_unpack, loc, _ -> Some loc | _ -> None) with @@ -455,33 +460,33 @@ let rec forStructureItem ~(env : SharedTypes.Env.t) ~(exported : Exported.t) match (Shared.dig pat.pat_type).desc with | Tpackage (path, _, _) -> let declared = - ProcessAttributes.newDeclared ~item:(Module.Ident path) + Process_attributes.new_declared ~item:(Module.Ident path) ~extent:(Option.get unpack_loc_opt) - ~name ~stamp:(Ident.binding_time ident) ~modulePath:NotVisible + ~name ~stamp:(Ident.binding_time ident) ~module_path:NotVisible false attributes in - Stamps.addModule env.stamps (Ident.binding_time ident) declared; + Stamps.add_module env.stamps (Ident.binding_time ident) declared; items := { Module.kind = Module { type_ = declared.item; - isModuleType = isModuleType declared; + is_module_type = is_module_type declared; }; name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; - loc = declared.extentLoc; + loc = declared.extent_loc; } :: !items | _ -> let item = pat.pat_type in let declared = - addDeclared ~name ~stamp:(Ident.binding_time ident) ~env + add_declared ~name ~stamp:(Ident.binding_time ident) ~env ~extent:pat.pat_loc ~item attributes (Exported.add exported Exported.Value) - Stamps.addValue + Stamps.add_value in items := { @@ -489,16 +494,16 @@ let rec forStructureItem ~(env : SharedTypes.Env.t) ~(exported : Exported.t) name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; - loc = declared.extentLoc; + loc = declared.extent_loc; } :: !items else let item = pat.pat_type in let declared = - addDeclared ~name ~stamp:(Ident.binding_time ident) ~env + add_declared ~name ~stamp:(Ident.binding_time ident) ~env ~extent:pat.pat_loc ~item attributes (Exported.add exported Exported.Value) - Stamps.addValue + Stamps.add_value in items := { @@ -506,23 +511,23 @@ let rec forStructureItem ~(env : SharedTypes.Env.t) ~(exported : Exported.t) name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; - loc = declared.extentLoc; + loc = declared.extent_loc; } :: !items | Tpat_tuple pats | Tpat_array pats | Tpat_construct (_, _, pats) -> - pats |> List.iter (fun p -> handlePattern [] p) - | Tpat_or (p, _, _) -> handlePattern [] p + pats |> List.iter (fun p -> handle_pattern [] p) + | Tpat_or (p, _, _) -> handle_pattern [] p | Tpat_record (items, _) -> - items |> List.iter (fun (_, _, p, _) -> handlePattern [] p) - | Tpat_variant (_, Some p, _) -> handlePattern [] p + items |> List.iter (fun (_, _, p, _) -> handle_pattern [] p) + | Tpat_variant (_, Some p, _) -> handle_pattern [] p | Tpat_variant (_, None, _) | Tpat_any | Tpat_constant _ -> () in List.iter (fun {Typedtree.vb_pat; vb_attributes} -> - handlePattern vb_attributes vb_pat) + handle_pattern vb_attributes vb_pat) bindings; bindings - |> List.iter (fun {Typedtree.vb_expr} -> scanLetModules ~env vb_expr); + |> List.iter (fun {Typedtree.vb_expr} -> scan_let_modules ~env vb_expr); !items | Tstr_module {mb_id; mb_attributes; mb_loc; mb_name = name; mb_expr = {mod_desc}} @@ -530,76 +535,79 @@ let rec forStructureItem ~(env : SharedTypes.Env.t) ~(exported : Exported.t) (String.length name.txt >= 6 && (String.sub name.txt 0 6 = "local_") [@doesNotRaise]) (* %%private generates a dummy module called local_... *) -> - let item = forModule ~env mod_desc name.txt in + let item = for_module ~env mod_desc name.txt in let declared = - addDeclared ~item ~name ~extent:mb_loc ~stamp:(Ident.binding_time mb_id) + add_declared ~item ~name ~extent:mb_loc ~stamp:(Ident.binding_time mb_id) ~env mb_attributes (Exported.add exported Exported.Module) - Stamps.addModule + Stamps.add_module in [ { Module.kind = - Module {type_ = declared.item; isModuleType = isModuleType declared}; + Module + {type_ = declared.item; is_module_type = is_module_type declared}; name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; - loc = declared.extentLoc; + loc = declared.extent_loc; }; ] - | Tstr_recmodule modDecls -> - modDecls - |> List.map (fun modDecl -> - forStructureItem ~env ~exported - {item with str_desc = Tstr_module modDecl}) + | Tstr_recmodule mod_decls -> + mod_decls + |> List.map (fun mod_decl -> + for_structure_item ~env ~exported + {item with str_desc = Tstr_module mod_decl}) |> List.flatten | Tstr_modtype { mtd_name = name; mtd_id; mtd_attributes; - mtd_type = Some {mty_type = modType}; + mtd_type = Some {mty_type = mod_type}; mtd_loc; } -> - let env = env |> Env.addModuleType ~name:name.txt in - let modTypeItem = forTypeModule ~name:name.txt ~env modType in + let env = env |> Env.add_module_type ~name:name.txt in + let mod_type_item = for_type_module ~name:name.txt ~env mod_type in let declared = - addDeclared ~item:modTypeItem ~name ~extent:mtd_loc + add_declared ~item:mod_type_item ~name ~extent:mtd_loc ~stamp:(Ident.binding_time mtd_id) ~env mtd_attributes (Exported.add exported Exported.Module) - Stamps.addModule + Stamps.add_module in [ { Module.kind = - Module {type_ = declared.item; isModuleType = isModuleType declared}; + Module + {type_ = declared.item; is_module_type = is_module_type declared}; name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; - loc = declared.extentLoc; + loc = declared.extent_loc; }; ] | Tstr_include {incl_mod; incl_type} -> let env = - match getModulePath incl_mod.mod_desc with + match get_module_path incl_mod.mod_desc with | None -> env | Some path -> - {env with modulePath = IncludedModule (path, env.modulePath)} + {env with module_path = IncludedModule (path, env.module_path)} in - let topLevel = + let top_level = List.fold_right - (fun item items -> forTypeSignatureItem ~env ~exported item @ items) + (fun item items -> for_type_signature_item ~env ~exported item @ items) incl_type [] in - topLevel - | Tstr_primitive vd when JsxHacks.primitiveIsFragment vd = false -> + top_level + | Tstr_primitive vd when Jsx_hacks.primitive_is_fragment vd = false -> let declared = - addDeclared ~extent:vd.val_loc ~item:vd.val_val.val_type ~name:vd.val_name + add_declared ~extent:vd.val_loc ~item:vd.val_val.val_type + ~name:vd.val_name ~stamp:(Ident.binding_time vd.val_id) ~env vd.val_attributes (Exported.add exported Exported.Value) - Stamps.addValue + Stamps.add_value in [ { @@ -607,51 +615,51 @@ let rec forStructureItem ~(env : SharedTypes.Env.t) ~(exported : Exported.t) name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; - loc = declared.extentLoc; + loc = declared.extent_loc; }; ] - | Tstr_type (recFlag, decls) -> + | Tstr_type (rec_flag, decls) -> decls |> List.mapi (fun i decl -> - let recStatus = - match recFlag with + let rec_status = + match rec_flag with | Recursive when i = 0 -> Types.Trec_first | Nonrecursive when i = 0 -> Types.Trec_not | _ -> Types.Trec_next in - decl |> forTypeDeclaration ~env ~exported ~recStatus) + decl |> for_type_declaration ~env ~exported ~rec_status) | _ -> [] -and forModule ~env mod_desc moduleName = +and for_module ~env mod_desc module_name = match mod_desc with | Tmod_ident (path, _lident) -> Ident path | Tmod_structure structure -> - let env = env |> Env.addModule ~name:moduleName in - let contents = forStructure ~name:moduleName ~env structure.str_items in + let env = env |> Env.add_module ~name:module_name in + let contents = for_structure ~name:module_name ~env structure.str_items in Structure contents - | Tmod_functor (ident, argName, maybeType, resultExpr) -> - (match maybeType with + | Tmod_functor (ident, arg_name, maybe_type, result_expr) -> + (match maybe_type with | None -> () | Some t -> - let kind = forTypeModule ~name:argName.txt ~env t.mty_type in + let kind = for_type_module ~name:arg_name.txt ~env t.mty_type in let stamp = Ident.binding_time ident in let declared = - ProcessAttributes.newDeclared ~item:kind ~name:argName - ~extent:argName.loc ~stamp ~modulePath:NotVisible false [] + Process_attributes.new_declared ~item:kind ~name:arg_name + ~extent:arg_name.loc ~stamp ~module_path:NotVisible false [] in - Stamps.addModule env.stamps stamp declared); - forModule ~env resultExpr.mod_desc moduleName + Stamps.add_module env.stamps stamp declared); + for_module ~env result_expr.mod_desc module_name | Tmod_apply (functor_, _arg, _coercion) -> - forModule ~env functor_.mod_desc moduleName - | Tmod_unpack (_expr, moduleType) -> - let env = env |> Env.addModule ~name:moduleName in - forTypeModule ~name:moduleName ~env moduleType + for_module ~env functor_.mod_desc module_name + | Tmod_unpack (_expr, module_type) -> + let env = env |> Env.add_module ~name:module_name in + for_type_module ~name:module_name ~env module_type | Tmod_constraint (expr, typ, _constraint, _coercion) -> (* TODO do this better I think *) - let modKind = forModule ~env expr.mod_desc moduleName in - let env = env |> Env.addModule ~name:moduleName in - let modTypeKind = forTypeModule ~name:moduleName ~env typ in - Constraint (modKind, modTypeKind) + let mod_kind = for_module ~env expr.mod_desc module_name in + let env = env |> Env.add_module ~name:module_name in + let mod_type_kind = for_type_module ~name:module_name ~env typ in + Constraint (mod_kind, mod_type_kind) (* Walk a typed expression and register any `let module M = ...` bindings as local @@ -660,136 +668,138 @@ and forModule ~env mod_desc moduleName = NotVisible (non-exported) and the extent is the alias identifier location so scope lookups match precisely. *) -and scanLetModules ~env (e : Typedtree.expression) = +and scan_let_modules ~env (e : Typedtree.expression) = match e.exp_desc with | Texp_letmodule (id, name, mexpr, body) -> let stamp = Ident.binding_time id in - let item = forModule ~env mexpr.mod_desc name.txt in + let item = for_module ~env mexpr.mod_desc name.txt in let declared = - ProcessAttributes.newDeclared ~item ~extent:name.loc ~name ~stamp - ~modulePath:NotVisible false [] + Process_attributes.new_declared ~item ~extent:name.loc ~name ~stamp + ~module_path:NotVisible false [] in - Stamps.addModule env.stamps stamp declared; - scanLetModules ~env body + Stamps.add_module env.stamps stamp declared; + scan_let_modules ~env body | Texp_let (_rf, bindings, body) -> - List.iter (fun {Typedtree.vb_expr} -> scanLetModules ~env vb_expr) bindings; - scanLetModules ~env body + List.iter + (fun {Typedtree.vb_expr} -> scan_let_modules ~env vb_expr) + bindings; + scan_let_modules ~env body | Texp_apply {funct; args; _} -> - scanLetModules ~env funct; + scan_let_modules ~env funct; args |> List.iter (function - | _, Some e -> scanLetModules ~env e + | _, Some e -> scan_let_modules ~env e | _, None -> ()) - | Texp_tuple exprs -> List.iter (scanLetModules ~env) exprs + | Texp_tuple exprs -> List.iter (scan_let_modules ~env) exprs | Texp_sequence (e1, e2) -> - scanLetModules ~env e1; - scanLetModules ~env e2 + scan_let_modules ~env e1; + scan_let_modules ~env e2 | Texp_match (e, cases, exn_cases, _) -> - scanLetModules ~env e; + scan_let_modules ~env e; let scan_case {Typedtree.c_lhs = _; c_guard; c_rhs} = (match c_guard with - | Some g -> scanLetModules ~env g + | Some g -> scan_let_modules ~env g | None -> ()); - scanLetModules ~env c_rhs + scan_let_modules ~env c_rhs in List.iter scan_case cases; List.iter scan_case exn_cases | Texp_function {case; _} -> let {Typedtree.c_lhs = _; c_guard; c_rhs} = case in (match c_guard with - | Some g -> scanLetModules ~env g + | Some g -> scan_let_modules ~env g | None -> ()); - scanLetModules ~env c_rhs + scan_let_modules ~env c_rhs | Texp_try (e, cases) -> - scanLetModules ~env e; + scan_let_modules ~env e; cases |> List.iter (fun {Typedtree.c_lhs = _; c_guard; c_rhs} -> (match c_guard with - | Some g -> scanLetModules ~env g + | Some g -> scan_let_modules ~env g | None -> ()); - scanLetModules ~env c_rhs) - | Texp_ifthenelse (e1, e2, e3Opt) -> ( - scanLetModules ~env e1; - scanLetModules ~env e2; - match e3Opt with - | Some e3 -> scanLetModules ~env e3 + scan_let_modules ~env c_rhs) + | Texp_ifthenelse (e1, e2, e3_opt) -> ( + scan_let_modules ~env e1; + scan_let_modules ~env e2; + match e3_opt with + | Some e3 -> scan_let_modules ~env e3 | None -> ()) | _ -> () -and forStructure ~name ~env strItems = +and for_structure ~name ~env str_items = let exported = Exported.init () in let items = List.fold_right - (fun item results -> forStructureItem ~env ~exported item @ results) - strItems [] + (fun item results -> for_structure_item ~env ~exported item @ results) + str_items [] in let attributes = - strItems + str_items |> List.filter_map (fun (struc : Typedtree.structure_item) -> match struc with | {str_desc = Tstr_attribute attr} -> Some attr | _ -> None) in - let docstring = attrsToDocstring attributes in - let deprecated = ProcessAttributes.findDeprecatedAttribute attributes in + let docstring = attrs_to_docstring attributes in + let deprecated = Process_attributes.find_deprecated_attribute attributes in {Module.name; docstring; exported; items; deprecated} -let fileForCmtInfos ~moduleName ~uri +let file_for_cmt_infos ~module_name ~uri ({cmt_modname; cmt_annots} : Cmt_format.cmt_infos) = let env = - {Env.stamps = Stamps.init (); modulePath = File (uri, moduleName)} + {Env.stamps = Stamps.init (); module_path = File (uri, module_name)} in match cmt_annots with | Partial_implementation parts -> let items = parts |> Array.to_list - |> Utils.filterMap (fun p -> + |> Utils.filter_map (fun p -> match (p : Cmt_format.binary_part) with | Partial_structure str -> Some str.str_items | Partial_structure_item str -> Some [str] | _ -> None) |> List.concat in - let structure = forStructure ~name:moduleName ~env items in - {File.uri; moduleName = cmt_modname; stamps = env.stamps; structure} + let structure = for_structure ~name:module_name ~env items in + {File.uri; module_name = cmt_modname; stamps = env.stamps; structure} | Partial_interface parts -> let items = parts |> Array.to_list - |> Utils.filterMap (fun (p : Cmt_format.binary_part) -> + |> Utils.filter_map (fun (p : Cmt_format.binary_part) -> match p with | Partial_signature str -> Some str.sig_items | Partial_signature_item str -> Some [str] | _ -> None) |> List.concat in - let structure = forSignature ~name:moduleName ~env items in - {uri; moduleName = cmt_modname; stamps = env.stamps; structure} + let structure = for_signature ~name:module_name ~env items in + {uri; module_name = cmt_modname; stamps = env.stamps; structure} | Implementation structure -> - let structure = forStructure ~name:moduleName ~env structure.str_items in - {uri; moduleName = cmt_modname; stamps = env.stamps; structure} + let structure = for_structure ~name:module_name ~env structure.str_items in + {uri; module_name = cmt_modname; stamps = env.stamps; structure} | Interface signature -> - let structure = forSignature ~name:moduleName ~env signature.sig_items in - {uri; moduleName = cmt_modname; stamps = env.stamps; structure} - | _ -> File.create moduleName uri + let structure = for_signature ~name:module_name ~env signature.sig_items in + {uri; module_name = cmt_modname; stamps = env.stamps; structure} + | _ -> File.create module_name uri -let fileForCmt ~moduleName ~cmt ~uri = - match Hashtbl.find_opt state.cmtCache cmt with +let file_for_cmt ~module_name ~cmt ~uri = + match Hashtbl.find_opt state.cmt_cache cmt with | Some file -> Some file | None -> ( - match Shared.tryReadCmt cmt with + match Shared.try_read_cmt cmt with | None -> None | Some infos -> - let file = fileForCmtInfos ~moduleName ~uri infos in - Hashtbl.replace state.cmtCache cmt file; + let file = file_for_cmt_infos ~module_name ~uri infos in + Hashtbl.replace state.cmt_cache cmt file; Some file) -let fileForModule moduleName ~package = - match Hashtbl.find_opt package.pathsForModule moduleName with +let file_for_module module_name ~package = + match Hashtbl.find_opt package.paths_for_module module_name with | Some paths -> - let uri = getUri paths in - let cmt = getCmtPath ~uri paths in - Log.log ("fileForModule " ^ showPaths paths); - fileForCmt ~cmt ~moduleName ~uri + let uri = get_uri paths in + let cmt = get_cmt_path ~uri paths in + Log.log ("fileForModule " ^ show_paths paths); + file_for_cmt ~cmt ~module_name ~uri | None -> - Log.log ("No path for module " ^ moduleName); + Log.log ("No path for module " ^ module_name); None diff --git a/analysis/src/ProcessExtra.ml b/analysis/src/process_extra.ml similarity index 51% rename from analysis/src/ProcessExtra.ml rename to analysis/src/process_extra.ml index 75390cefbad..0c44d934f34 100644 --- a/analysis/src/ProcessExtra.ml +++ b/analysis/src/process_extra.ml @@ -1,45 +1,45 @@ -open SharedTypes +open Shared_types -let addLocItem extra loc locType = +let add_loc_item extra loc loc_type = if not loc.Warnings.loc_ghost then - extra.locItems <- {loc; locType} :: extra.locItems + extra.loc_items <- {loc; loc_type} :: extra.loc_items -let addReference ~extra stamp loc = - Hashtbl.replace extra.internalReferences stamp +let add_reference ~extra stamp loc = + Hashtbl.replace extra.internal_references stamp (loc :: - (if Hashtbl.mem extra.internalReferences stamp then - Hashtbl.find extra.internalReferences stamp + (if Hashtbl.mem extra.internal_references stamp then + Hashtbl.find extra.internal_references stamp else [])) -let extraForFile ~(file : File.t) = - let extra = initExtra () in +let extra_for_file ~(file : File.t) = + let extra = init_extra () in file.stamps - |> Stamps.iterModules (fun stamp (d : Module.t Declared.t) -> - addLocItem extra d.name.loc (LModule (Definition (stamp, Module))); - addReference ~extra stamp d.name.loc); + |> Stamps.iter_modules (fun stamp (d : Module.t Declared.t) -> + add_loc_item extra d.name.loc (LModule (Definition (stamp, Module))); + add_reference ~extra stamp d.name.loc); file.stamps - |> Stamps.iterValues (fun stamp (d : Types.type_expr Declared.t) -> - addLocItem extra d.name.loc + |> Stamps.iter_values (fun stamp (d : Types.type_expr Declared.t) -> + add_loc_item extra d.name.loc (Typed (d.name.txt, d.item, Definition (stamp, Value))); - addReference ~extra stamp d.name.loc); + add_reference ~extra stamp d.name.loc); file.stamps - |> Stamps.iterTypes (fun stamp (d : Type.t Declared.t) -> - addLocItem extra d.name.loc + |> Stamps.iter_types (fun stamp (d : Type.t Declared.t) -> + add_loc_item extra d.name.loc (TypeDefinition (d.name.txt, d.item.Type.decl, stamp)); - addReference ~extra stamp d.name.loc; + add_reference ~extra stamp d.name.loc; match d.item.Type.kind with | Record labels -> labels |> List.iter (fun {stamp; fname; typ} -> - addReference ~extra stamp fname.loc; - addLocItem extra fname.loc + add_reference ~extra stamp fname.loc; + add_loc_item extra fname.loc (Typed (d.name.txt, typ, Definition (d.stamp, Field fname.txt)))) | Variant constructors -> constructors |> List.iter (fun {Constructor.stamp; cname} -> - addReference ~extra stamp cname.loc; + add_reference ~extra stamp cname.loc; let t = { Types.id = 0; @@ -52,7 +52,7 @@ let extraForFile ~(file : File.t) = ref Types.Mnil ); } in - addLocItem extra cname.loc + add_loc_item extra cname.loc (Typed ( d.name.txt, t, @@ -60,46 +60,46 @@ let extraForFile ~(file : File.t) = | _ -> ()); extra -let addExternalReference ~extra moduleName path tip loc = +let add_external_reference ~extra module_name path tip loc = (* TODO need to follow the path, and be able to load the files to follow module references... *) - Hashtbl.replace extra.externalReferences moduleName + Hashtbl.replace extra.external_references module_name ((path, tip, loc) :: - (if Hashtbl.mem extra.externalReferences moduleName then - Hashtbl.find extra.externalReferences moduleName + (if Hashtbl.mem extra.external_references module_name then + Hashtbl.find extra.external_references module_name else [])) -let addFileReference ~extra moduleName loc = - let newLocs = - match Hashtbl.find_opt extra.fileReferences moduleName with - | Some oldLocs -> LocationSet.add loc oldLocs - | None -> LocationSet.singleton loc +let add_file_reference ~extra module_name loc = + let new_locs = + match Hashtbl.find_opt extra.file_references module_name with + | Some old_locs -> Location_set.add loc old_locs + | None -> Location_set.singleton loc in - Hashtbl.replace extra.fileReferences moduleName newLocs + Hashtbl.replace extra.file_references module_name new_locs -let handleConstructor txt = +let handle_constructor txt = match txt with | Longident.Lident name -> name | Ldot (_left, name) -> name | Lapply (_, _) -> assert false -let rec lidIsComplex (lid : Longident.t) = +let rec lid_is_complex (lid : Longident.t) = match lid with | Lapply _ -> true - | Ldot (lid, _) -> lidIsComplex lid + | Ldot (lid, _) -> lid_is_complex lid | _ -> false -let extraForStructureItems ~(iterator : Tast_iterator.iterator) +let extra_for_structure_items ~(iterator : Tast_iterator.iterator) (items : Typedtree.structure_item list) = items |> List.iter (iterator.structure_item iterator) -let extraForSignatureItems ~(iterator : Tast_iterator.iterator) +let extra_for_signature_items ~(iterator : Tast_iterator.iterator) (items : Typedtree.signature_item list) = items |> List.iter (iterator.signature_item iterator) -let extraForCmt ~(iterator : Tast_iterator.iterator) +let extra_for_cmt ~(iterator : Tast_iterator.iterator) ({cmt_annots} : Cmt_format.cmt_infos) = - let extraForParts parts = + let extra_for_parts parts = parts |> Array.iter (fun part -> match part with @@ -114,11 +114,11 @@ let extraForCmt ~(iterator : Tast_iterator.iterator) in match cmt_annots with | Implementation structure -> - extraForStructureItems ~iterator structure.str_items + extra_for_structure_items ~iterator structure.str_items | Partial_implementation parts -> let items = parts |> Array.to_list - |> Utils.filterMap (fun (p : Cmt_format.binary_part) -> + |> Utils.filter_map (fun (p : Cmt_format.binary_part) -> match p with | Partial_structure str -> Some str.str_items | Partial_structure_item str -> Some [str] @@ -126,35 +126,36 @@ let extraForCmt ~(iterator : Tast_iterator.iterator) | _ -> None) |> List.concat in - extraForStructureItems ~iterator items; - extraForParts parts - | Interface signature -> extraForSignatureItems ~iterator signature.sig_items + extra_for_structure_items ~iterator items; + extra_for_parts parts + | Interface signature -> + extra_for_signature_items ~iterator signature.sig_items | Partial_interface parts -> let items = parts |> Array.to_list - |> Utils.filterMap (fun (p : Cmt_format.binary_part) -> + |> Utils.filter_map (fun (p : Cmt_format.binary_part) -> match p with | Partial_signature s -> Some s.sig_items | Partial_signature_item str -> Some [str] | _ -> None) |> List.concat in - extraForSignatureItems ~iterator items; - extraForParts parts - | _ -> extraForStructureItems ~iterator [] + extra_for_signature_items ~iterator items; + extra_for_parts parts + | _ -> extra_for_structure_items ~iterator [] -let addForPath ~env ~extra path lident loc typ tip = - let identName = Longident.last lident in - let identLoc = Utils.endOfLocation loc (String.length identName) in - let locType = - match ResolvePath.fromCompilerPath ~env path with +let add_for_path ~env ~extra path lident loc typ tip = + let ident_name = Longident.last lident in + let ident_loc = Utils.end_of_location loc (String.length ident_name) in + let loc_type = + match Resolve_path.from_compiler_path ~env path with | Stamp stamp -> - addReference ~extra stamp identLoc; + add_reference ~extra stamp ident_loc; LocalReference (stamp, tip) | NotFound -> NotFound - | Global (moduleName, path) -> - addExternalReference ~extra moduleName path tip identLoc; - GlobalReference (moduleName, path, tip) + | Global (module_name, path) -> + add_external_reference ~extra module_name path tip ident_loc; + GlobalReference (module_name, path, tip) | Exported (env, name) -> ( match match tip with @@ -162,109 +163,110 @@ let addForPath ~env ~extra path lident loc typ tip = | _ -> Exported.find env.exported Exported.Value name with | Some stamp -> - addReference ~extra stamp identLoc; + add_reference ~extra stamp ident_loc; LocalReference (stamp, tip) | None -> NotFound) | GlobalMod _ -> NotFound in - addLocItem extra loc (Typed (identName, typ, locType)) + add_loc_item extra loc (Typed (ident_name, typ, loc_type)) -let addForPathParent ~env ~extra path loc = - let locType = - match ResolvePath.fromCompilerPath ~env path with - | GlobalMod moduleName -> - addFileReference ~extra moduleName loc; - TopLevelModule moduleName +let add_for_path_parent ~env ~extra path loc = + let loc_type = + match Resolve_path.from_compiler_path ~env path with + | GlobalMod module_name -> + add_file_reference ~extra module_name loc; + TopLevelModule module_name | Stamp stamp -> - addReference ~extra stamp loc; + add_reference ~extra stamp loc; LModule (LocalReference (stamp, Module)) | NotFound -> LModule NotFound - | Global (moduleName, path) -> - addExternalReference ~extra moduleName path Module loc; - LModule (GlobalReference (moduleName, path, Module)) + | Global (module_name, path) -> + add_external_reference ~extra module_name path Module loc; + LModule (GlobalReference (module_name, path, Module)) | Exported (env, name) -> ( match Exported.find env.exported Exported.Module name with | Some stamp -> - addReference ~extra stamp loc; + add_reference ~extra stamp loc; LModule (LocalReference (stamp, Module)) | None -> LModule NotFound) in - addLocItem extra loc locType + add_loc_item extra loc loc_type -let getTypeAtPath ~env path = - match ResolvePath.fromCompilerPath ~env path with +let get_type_at_path ~env path = + match Resolve_path.from_compiler_path ~env path with | GlobalMod _ -> `Not_found - | Global (moduleName, path) -> `Global (moduleName, path) + | Global (module_name, path) -> `Global (module_name, path) | NotFound -> `Not_found | Exported (env, name) -> ( match Exported.find env.exported Exported.Type name with | None -> `Not_found | Some stamp -> ( - let declaredType = Stamps.findType env.file.stamps stamp in - match declaredType with - | Some declaredType -> `Local declaredType + let declared_type = Stamps.find_type env.file.stamps stamp in + match declared_type with + | Some declared_type -> `Local declared_type | None -> `Not_found)) | Stamp stamp -> ( - let declaredType = Stamps.findType env.file.stamps stamp in - match declaredType with - | Some declaredType -> `Local declaredType + let declared_type = Stamps.find_type env.file.stamps stamp in + match declared_type with + | Some declared_type -> `Local declared_type | None -> `Not_found) -let addForField ~env ~extra ~recordType ~fieldType {Asttypes.txt; loc} = - match (Shared.dig recordType).desc with +let add_for_field ~env ~extra ~record_type ~field_type {Asttypes.txt; loc} = + match (Shared.dig record_type).desc with | Tconstr (path, _args, _memo) -> - let t = getTypeAtPath ~env path in - let name = handleConstructor txt in - let nameLoc = Utils.endOfLocation loc (String.length name) in - let locType = + let t = get_type_at_path ~env path in + let name = handle_constructor txt in + let name_loc = Utils.end_of_location loc (String.length name) in + let loc_type = match t with | `Local {stamp; item = {kind = Record fields}} -> ( match fields |> List.find_opt (fun f -> f.fname.txt = name) with | Some {stamp = astamp} -> - addReference ~extra astamp nameLoc; + add_reference ~extra astamp name_loc; LocalReference (stamp, Field name) | None -> NotFound) - | `Global (moduleName, path) -> - addExternalReference ~extra moduleName path (Field name) nameLoc; - GlobalReference (moduleName, path, Field name) + | `Global (module_name, path) -> + add_external_reference ~extra module_name path (Field name) name_loc; + GlobalReference (module_name, path, Field name) | _ -> NotFound in - addLocItem extra nameLoc (Typed (name, fieldType, locType)) + add_loc_item extra name_loc (Typed (name, field_type, loc_type)) | _ -> () -let addForRecord ~env ~extra ~recordType items = - match (Shared.dig recordType).desc with +let add_for_record ~env ~extra ~record_type items = + match (Shared.dig record_type).desc with | Tconstr (path, _args, _memo) -> - let t = getTypeAtPath ~env path in + let t = get_type_at_path ~env path in items |> List.iter (fun ({Asttypes.txt; loc}, _, _, _) -> (* let name = Longident.last(txt); *) - let name = handleConstructor txt in - let nameLoc = Utils.endOfLocation loc (String.length name) in - let locType = + let name = handle_constructor txt in + let name_loc = Utils.end_of_location loc (String.length name) in + let loc_type = match t with | `Local {stamp; item = {kind = Record fields}} -> ( match fields |> List.find_opt (fun f -> f.fname.txt = name) with | Some {stamp = astamp} -> - addReference ~extra astamp nameLoc; + add_reference ~extra astamp name_loc; LocalReference (stamp, Field name) | None -> NotFound) - | `Global (moduleName, path) -> - addExternalReference ~extra moduleName path (Field name) nameLoc; - GlobalReference (moduleName, path, Field name) + | `Global (module_name, path) -> + add_external_reference ~extra module_name path (Field name) + name_loc; + GlobalReference (module_name, path, Field name) | _ -> NotFound in - addLocItem extra nameLoc (Typed (name, recordType, locType))) + add_loc_item extra name_loc (Typed (name, record_type, loc_type))) | _ -> () -let addForConstructor ~env ~extra constructorType {Asttypes.txt; loc} +let add_for_constructor ~env ~extra constructor_type {Asttypes.txt; loc} {Types.cstr_name} = - match (Shared.dig constructorType).desc with + match (Shared.dig constructor_type).desc with | Tconstr (path, _args, _memo) -> - let name = handleConstructor txt in - let nameLoc = Utils.endOfLocation loc (String.length name) in - let t = getTypeAtPath ~env path in - let locType = + let name = handle_constructor txt in + let name_loc = Utils.end_of_location loc (String.length name) in + let t = get_type_at_path ~env path in + let loc_type = match t with | `Local {stamp; item = {kind = Variant constructors}} -> ( match @@ -272,36 +274,37 @@ let addForConstructor ~env ~extra constructorType {Asttypes.txt; loc} |> List.find_opt (fun c -> c.Constructor.cname.txt = cstr_name) with | Some {stamp = cstamp} -> - addReference ~extra cstamp nameLoc; + add_reference ~extra cstamp name_loc; LocalReference (stamp, Constructor name) | None -> NotFound) - | `Global (moduleName, path) -> - addExternalReference ~extra moduleName path (Constructor name) nameLoc; - GlobalReference (moduleName, path, Constructor name) + | `Global (module_name, path) -> + add_external_reference ~extra module_name path (Constructor name) + name_loc; + GlobalReference (module_name, path, Constructor name) | _ -> NotFound in - addLocItem extra nameLoc (Typed (name, constructorType, locType)) + add_loc_item extra name_loc (Typed (name, constructor_type, loc_type)) | _ -> () -let rec addForLongident ~env ~extra top (path : Path.t) (txt : Longident.t) loc - = - if (not loc.Location.loc_ghost) && not (lidIsComplex txt) then ( - let idLength = String.length (String.concat "." (Longident.flatten txt)) in - let reportedLength = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum in - let isPpx = idLength <> reportedLength in - if isPpx then +let rec add_for_longident ~env ~extra top (path : Path.t) (txt : Longident.t) + loc = + if (not loc.Location.loc_ghost) && not (lid_is_complex txt) then ( + let id_length = String.length (String.concat "." (Longident.flatten txt)) in + let reported_length = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum in + let is_ppx = id_length <> reported_length in + if is_ppx then match top with - | Some (t, tip) -> addForPath ~env ~extra path txt loc t tip - | None -> addForPathParent ~env ~extra path loc + | Some (t, tip) -> add_for_path ~env ~extra path txt loc t tip + | None -> add_for_path_parent ~env ~extra path loc else - let l = Utils.endOfLocation loc (String.length (Longident.last txt)) in + let l = Utils.end_of_location loc (String.length (Longident.last txt)) in (match top with - | Some (t, tip) -> addForPath ~env ~extra path txt l t tip - | None -> addForPathParent ~env ~extra path l); + | Some (t, tip) -> add_for_path ~env ~extra path txt l t tip + | None -> add_for_path_parent ~env ~extra path l); match (path, txt) with | Pdot (pinner, _pname, _), Ldot (inner, name) -> - addForLongident ~env ~extra None pinner inner - (Utils.chopLocationEnd loc (String.length name + 1)) + add_for_longident ~env ~extra None pinner inner + (Utils.chop_location_end loc (String.length name + 1)) | Pident _, Lident _ -> () | _ -> ()) @@ -310,11 +313,11 @@ let rec handle_module_expr ~env ~extra expr = | Typedtree.Tmod_constraint (expr, _, _, _) -> handle_module_expr ~env ~extra expr.mod_desc | Tmod_ident (path, {txt; loc}) -> - if not (lidIsComplex txt) then + if not (lid_is_complex txt) then Log.log ("Ident!! " ^ String.concat "." (Longident.flatten txt)); - addForLongident ~env ~extra None path txt loc - | Tmod_functor (_ident, _argName, _maybeType, resultExpr) -> - handle_module_expr ~env ~extra resultExpr.mod_desc + add_for_longident ~env ~extra None path txt loc + | Tmod_functor (_ident, _argName, _maybeType, result_expr) -> + handle_module_expr ~env ~extra result_expr.mod_desc | Tmod_apply (obj, arg, _) -> handle_module_expr ~env ~extra obj.mod_desc; handle_module_expr ~env ~extra arg.mod_desc @@ -327,7 +330,7 @@ let structure_item ~env ~extra (iter : Tast_iterator.iterator) item = | Tstr_module {mb_expr} -> handle_module_expr ~env ~extra mb_expr.mod_desc | Tstr_open {open_path; open_txt = {txt; loc}} -> (* Log.log("Have an open here"); *) - addForLongident ~env ~extra None open_path txt loc + add_for_longident ~env ~extra None open_path txt loc | _ -> ()); Tast_iterator.default_iterator.structure_item iter item @@ -336,14 +339,14 @@ let signature_item ~(file : File.t) ~extra (iter : Tast_iterator.iterator) item (match item.Typedtree.sig_desc with | Tsig_value {val_id; val_loc; val_name = name; val_desc; val_attributes} -> let stamp = Ident.binding_time val_id in - if Stamps.findValue file.stamps stamp = None then ( + if Stamps.find_value file.stamps stamp = None then ( let declared = - ProcessAttributes.newDeclared ~name ~stamp ~extent:val_loc - ~modulePath:NotVisible ~item:val_desc.ctyp_type false val_attributes + Process_attributes.new_declared ~name ~stamp ~extent:val_loc + ~module_path:NotVisible ~item:val_desc.ctyp_type false val_attributes in - Stamps.addValue file.stamps stamp declared; - addReference ~extra stamp name.loc; - addLocItem extra name.loc + Stamps.add_value file.stamps stamp declared; + add_reference ~extra stamp name.loc; + add_loc_item extra name.loc (Typed (name.txt, val_desc.ctyp_type, Definition (stamp, Value)))) | _ -> ()); Tast_iterator.default_iterator.signature_item iter item @@ -352,7 +355,7 @@ let typ ~env ~extra (iter : Tast_iterator.iterator) (item : Typedtree.core_type) = (match item.ctyp_desc with | Ttyp_constr (path, {txt; loc}, _args) -> - addForLongident ~env ~extra (Some (item.ctyp_type, Type)) path txt loc + add_for_longident ~env ~extra (Some (item.ctyp_type, Type)) path txt loc | _ -> ()); Tast_iterator.default_iterator.typ iter item @@ -377,77 +380,82 @@ let pat ~(file : File.t) ~env ~extra (iter : Tast_iterator.iterator) | Tpackage (path, _, _) -> Some path | _ -> None in - let addForPattern stamp name = - if Stamps.findValue file.stamps stamp = None then ( + let add_for_pattern stamp name = + if Stamps.find_value file.stamps stamp = None then ( let declared = - ProcessAttributes.newDeclared ~name ~stamp ~modulePath:NotVisible + Process_attributes.new_declared ~name ~stamp ~module_path:NotVisible ~extent:pattern.pat_loc ~item:pattern.pat_type false pattern.pat_attributes in - Stamps.addValue file.stamps stamp declared; - addReference ~extra stamp name.loc; - addLocItem extra name.loc + Stamps.add_value file.stamps stamp declared; + add_reference ~extra stamp name.loc; + add_loc_item extra name.loc (Typed (name.txt, pattern.pat_type, Definition (stamp, Value)))) in (* Log.log("Entering pattern " ++ Utils.showLocation(pat_loc)); *) (match pattern.pat_desc with | Tpat_record (items, _) -> - addForRecord ~env ~extra ~recordType:pattern.pat_type items + add_for_record ~env ~extra ~record_type:pattern.pat_type items | Tpat_construct (lident, constructor, _) -> - addForConstructor ~env ~extra pattern.pat_type lident constructor + add_for_constructor ~env ~extra pattern.pat_type lident constructor | Tpat_alias (_inner, ident, name) -> ( let stamp = Ident.binding_time ident in match unpacked_module_path_opt () with | Some path -> let declared = - ProcessAttributes.newDeclared ~item:(Module.Ident path) ~extent:name.loc - ~name ~stamp ~modulePath:NotVisible false pattern.pat_attributes + Process_attributes.new_declared ~item:(Module.Ident path) + ~extent:name.loc ~name ~stamp ~module_path:NotVisible false + pattern.pat_attributes in - Stamps.addModule file.stamps stamp declared - | None -> addForPattern stamp name) + Stamps.add_module file.stamps stamp declared + | None -> add_for_pattern stamp name) | Tpat_var (ident, name) -> ( (* Log.log("Pattern " ++ name.txt); *) let stamp = Ident.binding_time ident in match unpacked_module_path_opt () with | Some path -> let declared = - ProcessAttributes.newDeclared ~item:(Module.Ident path) ~extent:name.loc - ~name ~stamp ~modulePath:NotVisible false pattern.pat_attributes + Process_attributes.new_declared ~item:(Module.Ident path) + ~extent:name.loc ~name ~stamp ~module_path:NotVisible false + pattern.pat_attributes in - Stamps.addModule file.stamps stamp declared - | None -> addForPattern stamp name) + Stamps.add_module file.stamps stamp declared + | None -> add_for_pattern stamp name) | _ -> ()); Tast_iterator.default_iterator.pat iter pattern let expr ~env ~(extra : extra) (iter : Tast_iterator.iterator) (expression : Typedtree.expression) = (match expression.exp_desc with - | Texp_ident (path, {txt; loc}, _) when not (JsxHacks.pathIsFragment path) -> - addForLongident ~env ~extra (Some (expression.exp_type, Value)) path txt loc + | Texp_ident (path, {txt; loc}, _) when not (Jsx_hacks.path_is_fragment path) + -> + add_for_longident ~env ~extra + (Some (expression.exp_type, Value)) + path txt loc | Texp_record {fields} -> - addForRecord ~env ~extra ~recordType:expression.exp_type + add_for_record ~env ~extra ~record_type:expression.exp_type (fields |> Array.to_list - |> Utils.filterMap (fun (desc, item, opt) -> + |> Utils.filter_map (fun (desc, item, opt) -> match item with | Typedtree.Overridden (loc, _) -> Some (loc, desc, (), opt) | _ -> None)) | Texp_constant constant -> - addLocItem extra expression.exp_loc (Constant constant) + add_loc_item extra expression.exp_loc (Constant constant) (* Skip unit and list literals *) | Texp_construct ({txt = Lident ("()" | "::"); loc}, _, _args) when loc.loc_end.pos_cnum - loc.loc_start.pos_cnum <> 2 -> () | Texp_construct (lident, constructor, _args) -> - addForConstructor ~env ~extra expression.exp_type lident constructor + add_for_constructor ~env ~extra expression.exp_type lident constructor | Texp_field (inner, lident, _label_description) -> - addForField ~env ~extra ~recordType:inner.exp_type - ~fieldType:expression.exp_type lident + add_for_field ~env ~extra ~record_type:inner.exp_type + ~field_type:expression.exp_type lident | _ -> ()); Tast_iterator.default_iterator.expr iter expression -let getExtra ~file ~infos = - let extra = extraForFile ~file in - let env = QueryEnv.fromFile file in +let get_extra ~file ~infos = + let extra = extra_for_file ~file in + let env = Query_env.from_file file in let iterator = { Tast_iterator.default_iterator with @@ -458,5 +466,5 @@ let getExtra ~file ~infos = typ = typ ~env ~extra; } in - extraForCmt ~iterator infos; + extra_for_cmt ~iterator infos; extra diff --git a/analysis/src/range.ml b/analysis/src/range.ml new file mode 100644 index 00000000000..6ff4e3dcc0a --- /dev/null +++ b/analysis/src/range.ml @@ -0,0 +1,6 @@ +type t = Pos.t * Pos.t + +let to_string ((pos_start, pos_end) : t) = + Printf.sprintf "[%s->%s]" (Pos.to_string pos_start) (Pos.to_string pos_end) + +let has_pos ~pos ((pos_start, pos_end) : t) = pos_start <= pos && pos < pos_end diff --git a/analysis/src/references.ml b/analysis/src/references.ml new file mode 100644 index 00000000000..2eb20746266 --- /dev/null +++ b/analysis/src/references.ml @@ -0,0 +1,577 @@ +open Shared_types + +let debug_references = ref true +let maybe_log m = if !debug_references then Log.log ("[ref] " ^ m) + +let check_pos (line, char) + {Location.loc_start = {pos_lnum; pos_bol; pos_cnum}; loc_end} = + if line < pos_lnum || (line = pos_lnum && char < pos_cnum - pos_bol) then + false + else if + line > loc_end.pos_lnum + || (line = loc_end.pos_lnum && char > loc_end.pos_cnum - loc_end.pos_bol) + then false + else true + +let loc_items_for_pos ~extra pos = + extra.loc_items |> List.filter (fun {loc; loc_type = _} -> check_pos pos loc) + +let line_col_to_cmt_loc ~pos:(line, col) = (line + 1, col) + +let get_loc_item ~full ~pos ~debug = + let log n msg = if debug then Printf.printf "getLocItem #%d: %s\n" n msg in + let pos = line_col_to_cmt_loc ~pos in + let loc_items = loc_items_for_pos ~extra:full.extra pos in + if !Log.verbose then + print_endline + ("locItems:\n " + ^ (loc_items |> List.map loc_item_to_string |> String.concat "\n ")); + let name_of li = + match li.loc_type with + | Typed (n, _, _) -> n + | _ -> "NotFound" + in + match loc_items with + | li1 :: li2 :: li3 :: ({loc_type = Typed ("makeProps", _, _)} as li4) :: _ + when full.file.uri |> Uri.is_interface -> + log 1 "heuristic for makeProps in interface files"; + if debug then + Printf.printf "n1:%s n2:%s n3:%s\n" (name_of li1) (name_of li2) + (name_of li3); + Some li4 + | [ + {loc_type = Constant _}; + ({loc_type = Typed ("createDOMElementVariadic", _, _)} as li2); + ] -> + log 3 "heuristic for
"; + Some li2 + | {loc_type = Typed ("makeProps", _, _)} + :: ({loc_type = Typed ("make", _, _)} as li2) + :: _ -> + log 4 + "heuristic for within fragments: take make as makeProps does not \ + work\n\ + the type is not great but jump to definition works"; + Some li2 + | [ + ({loc_type = Typed (_, _, LocalReference _)} as li1); + ({loc_type = Typed (_, _, _)} as li2); + ] + when li1.loc = li2.loc -> + log 5 + "heuristic for JSX and compiler combined:\n\ + ~x becomes Props#x\n\ + heuristic for: [Props, x], give loc of `x`"; + if debug then Printf.printf "n1:%s n2:%s\n" (name_of li1) (name_of li2); + Some li2 + | [ + ({loc_type = Typed (_, _, LocalReference _)} as li1); + ({ + loc_type = Typed (_, _, GlobalReference ("Js_OO", ["unsafe_downgrade"], _)); + } as li2); + li3; + ] + (* For older compiler 9.0 or earlier *) + when li1.loc = li2.loc && li2.loc = li3.loc -> + (* Not currently testable on 9.1.4 *) + log 6 + "heuristic for JSX and compiler combined:\n\ + ~x becomes Js_OO.unsafe_downgrade(Props)#x\n\ + heuristic for: [Props, unsafe_downgrade, x], give loc of `x`"; + Some li3 + | [ + ({loc_type = Typed (_, _, LocalReference (_, Value))} as li1); + ({loc_type = Typed (_, _, Definition (_, Value))} as li2); + ] -> + log 7 + "heuristic for JSX on type-annotated labeled (~arg:t):\n\ + (~arg:t) becomes Props#arg\n\ + Props has the location range of arg:t\n\ + arg has the location range of arg\n\ + heuristic for: [Props, arg], give loc of `arg`"; + if debug then Printf.printf "n1:%s n2:%s\n" (name_of li1) (name_of li2); + Some li2 + | [li1; li2; li3] when li1.loc = li2.loc && li2.loc = li3.loc -> + (* Not currently testable on 9.1.4 *) + log 8 + "heuristic for JSX with at most one child\n\ + heuristic for: [makeProps, make, createElement], give the loc of `make` "; + Some li2 + | [li1; li2; li3; li4] + when li1.loc = li2.loc && li2.loc = li3.loc && li3.loc = li4.loc -> + log 9 + "heuristic for JSX variadic, e.g. {x} {y} \n\ + heuristic for: [React.null, makeProps, make, createElementVariadic], \ + give the loc of `make`"; + if debug then + Printf.printf "n1:%s n2:%s n3:%s n4:%s\n" (name_of li1) (name_of li2) + (name_of li3) (name_of li4); + Some li3 + | {loc_type = Typed (_, {desc = Tconstr (path, _, _)}, _)} :: li :: _ + when Utils.is_uncurried_internal path -> + Some li + | li :: _ -> Some li + | _ -> None + +let declared_for_tip ~(stamps : Stamps.t) stamp (tip : Tip.t) = + match tip with + | Value -> + Stamps.find_value stamps stamp + |> Option.map (fun x -> {x with Declared.item = ()}) + | Field _ | Constructor _ | Type -> + Stamps.find_type stamps stamp + |> Option.map (fun x -> {x with Declared.item = ()}) + | Module -> + Stamps.find_module stamps stamp + |> Option.map (fun x -> {x with Declared.item = ()}) + +let get_field (file : File.t) stamp name = + match Stamps.find_type file.stamps stamp with + | None -> None + | Some {item = {kind}} -> ( + match kind with + | Record fields -> fields |> List.find_opt (fun f -> f.fname.txt = name) + | _ -> None) + +let get_constructor (file : File.t) stamp name = + match Stamps.find_type file.stamps stamp with + | None -> None + | Some {item = {kind}} -> ( + match kind with + | Variant constructors -> ( + match + constructors + |> List.find_opt (fun const -> const.Constructor.cname.txt = name) + with + | None -> None + | Some const -> Some const) + | _ -> None) + +let exported_for_tip ~env ~path ~package ~(tip : Tip.t) = + match Resolve_path.resolve_path ~env ~path ~package with + | None -> + Log.log ("Cannot resolve path " ^ path_to_string path); + None + | Some (env, name) -> ( + let kind = + match tip with + | Value -> Exported.Value + | Field _ | Constructor _ | Type -> Exported.Type + | Module -> Exported.Module + in + match Exported.find env.exported kind name with + | None -> + Log.log ("Exported not found for tip " ^ name ^ " > " ^ Tip.to_string tip); + None + | Some stamp -> Some (env, name, stamp)) + +let defined_for_loc ~file ~package loc_kind = + let inner ~file stamp (tip : Tip.t) = + match tip with + | Constructor name -> ( + match get_constructor file stamp name with + | None -> None + | Some constructor -> + Some (constructor.docstring, `Constructor constructor)) + | Field name -> + Some + ( (match get_field file stamp name with + | None -> [] + | Some field -> field.docstring), + `Field ) + | _ -> ( + maybe_log + ("Trying for declared " ^ Tip.to_string tip ^ " " ^ string_of_int stamp + ^ " in file " ^ Uri.to_string file.uri); + match declared_for_tip ~stamps:file.stamps stamp tip with + | None -> None + | Some declared -> Some (declared.docstring, `Declared)) + in + match loc_kind with + | NotFound -> None + | LocalReference (stamp, tip) | Definition (stamp, tip) -> + inner ~file stamp tip + | GlobalReference (module_name, path, tip) -> ( + maybe_log ("Getting global " ^ module_name); + match Process_cmt.file_for_module ~package module_name with + | None -> + Log.log ("Cannot get module " ^ module_name); + None + | Some file -> ( + let env = Query_env.from_file file in + match exported_for_tip ~env ~path ~package ~tip with + | None -> None + | Some (env, name, stamp) -> ( + maybe_log ("Getting for " ^ string_of_int stamp ^ " in " ^ name); + match inner ~file:env.file stamp tip with + | None -> + Log.log "could not get defined"; + None + | Some res -> + maybe_log "Yes!! got it"; + Some res))) + +(** Find alternative declaration: from res in case of interface, or from resi in case of implementation *) +let alternate_declared ~(file : File.t) ~package (declared : _ Declared.t) tip = + match Hashtbl.find_opt package.paths_for_module file.module_name with + | None -> None + | Some paths -> ( + match paths with + | IntfAndImpl {resi; res} -> ( + maybe_log + ("alternateDeclared for " ^ file.module_name ^ " has both resi and res"); + let alternate_uri = if Uri.is_interface file.uri then res else resi in + match Cmt.full_from_uri ~uri:(Uri.from_path alternate_uri) with + | None -> None + | Some {file; extra} -> ( + let env = Query_env.from_file file in + let path = Module_path.to_path declared.module_path declared.name.txt in + maybe_log ("find declared for path " ^ path_to_string path); + let declared_opt = + match exported_for_tip ~env ~path ~package ~tip with + | None -> None + | Some (_env, _name, stamp) -> + declared_for_tip ~stamps:file.stamps stamp tip + in + match declared_opt with + | None -> None + | Some declared -> Some (file, extra, declared))) + | _ -> + maybe_log ("alternateDeclared for " ^ file.module_name ^ " not found"); + + None) + +let rec resolve_module_reference ?(paths_seen = []) ~file ~package + (declared : Module.t Declared.t) = + match declared.item with + | Structure _ -> Some (file, Some declared) + | Constraint (_moduleItem, module_type_item) -> + resolve_module_reference ~paths_seen ~file ~package + {declared with item = module_type_item} + | Ident path -> ( + let env = Query_env.from_file file in + match Resolve_path.from_compiler_path ~env path with + | NotFound -> None + | Exported (env, name) -> ( + match Exported.find env.exported Exported.Module name with + | None -> None + | Some stamp -> ( + match Stamps.find_module env.file.stamps stamp with + | None -> None + | Some md -> Some (env.file, Some md))) + | Global (module_name, path) -> ( + match Process_cmt.file_for_module ~package module_name with + | None -> None + | Some file -> ( + let env = Query_env.from_file file in + match Resolve_path.resolve_path ~env ~package ~path with + | None -> None + | Some (env, name) -> ( + match Exported.find env.exported Exported.Module name with + | None -> None + | Some stamp -> ( + match Stamps.find_module env.file.stamps stamp with + | None -> None + | Some md -> Some (env.file, Some md))))) + | Stamp stamp -> ( + match Stamps.find_module file.stamps stamp with + | None -> None + | Some ({item = Ident path} as md) when not (List.mem path paths_seen) -> + (* avoid possible infinite loops *) + resolve_module_reference ~file ~package ~paths_seen:(path :: paths_seen) + md + | Some md -> Some (file, Some md)) + | GlobalMod name -> ( + match Process_cmt.file_for_module ~package name with + | None -> None + | Some file -> Some (file, None))) + +let validate_loc (loc : Location.t) (backup : Location.t) = + if loc.loc_start.pos_cnum = -1 then + if backup.loc_start.pos_cnum = -1 then + { + Location.loc_ghost = true; + loc_start = {pos_cnum = 0; pos_lnum = 1; pos_bol = 0; pos_fname = ""}; + loc_end = {pos_cnum = 0; pos_lnum = 1; pos_bol = 0; pos_fname = ""}; + } + else backup + else loc + +let resolve_module_definition ~(file : File.t) ~package stamp = + match Stamps.find_module file.stamps stamp with + | None -> None + | Some md -> ( + match resolve_module_reference ~file ~package md with + | None -> None + | Some (file, declared) -> + let loc = + match declared with + | None -> Uri.to_top_level_loc file.uri + | Some declared -> validate_loc declared.name.loc declared.extent_loc + in + Some (file.uri, loc)) + +let definition ~file ~package stamp (tip : Tip.t) = + match tip with + | Constructor name -> ( + match get_constructor file stamp name with + | None -> None + | Some constructor -> Some (file.uri, constructor.cname.loc)) + | Field name -> ( + match get_field file stamp name with + | None -> None + | Some field -> Some (file.uri, field.fname.loc)) + | Module -> resolve_module_definition ~file ~package stamp + | _ -> ( + match declared_for_tip ~stamps:file.stamps stamp tip with + | None -> None + | Some declared -> + let file_impl, declared_impl = + match alternate_declared ~package ~file declared tip with + | Some (file_impl, _extra, declared_impl) when Uri.is_interface file.uri + -> + (file_impl, declared_impl) + | _ -> (file, declared) + in + let loc = validate_loc declared_impl.name.loc declared_impl.extent_loc in + let env = Query_env.from_file file_impl in + let uri = + Resolve_path.get_source_uri ~env ~package declared_impl.module_path + in + maybe_log ("Inner uri " ^ Uri.to_string uri); + Some (uri, loc)) + +let definition_for_loc_item ~full:{file; package} loc_item = + match loc_item.loc_type with + | Typed (_, _, Definition (stamp, tip)) -> ( + maybe_log + ("Typed Definition stamp:" ^ string_of_int stamp ^ " tip:" + ^ Tip.to_string tip); + match declared_for_tip ~stamps:file.stamps stamp tip with + | None -> None + | Some declared -> + maybe_log ("Declared " ^ declared.name.txt); + if declared.is_exported then ( + maybe_log ("exported, looking for alternate " ^ file.module_name); + match alternate_declared ~package ~file declared tip with + | None -> None + | Some (file, _extra, declared) -> + let loc = validate_loc declared.name.loc declared.extent_loc in + Some (file.uri, loc)) + else None) + | Typed (_, _, NotFound) + | LModule (NotFound | Definition (_, _)) + | TypeDefinition (_, _, _) + | Constant _ -> + None + | TopLevelModule name -> ( + maybe_log ("Toplevel " ^ name); + match Hashtbl.find_opt package.paths_for_module name with + | None -> None + | Some paths -> + let uri = get_uri paths in + Some (uri, Uri.to_top_level_loc uri)) + | LModule (LocalReference (stamp, tip)) + | Typed (_, _, LocalReference (stamp, tip)) -> + maybe_log ("Local defn " ^ Tip.to_string tip); + definition ~file ~package stamp tip + | LModule (GlobalReference (module_name, path, tip)) + | Typed (_, _, GlobalReference (module_name, path, tip)) -> ( + maybe_log + ("Typed GlobalReference moduleName:" ^ module_name ^ " path:" + ^ path_to_string path ^ " tip:" ^ Tip.to_string tip); + match Process_cmt.file_for_module ~package module_name with + | None -> None + | Some file -> ( + let env = Query_env.from_file file in + match exported_for_tip ~env ~path ~package ~tip with + | None -> None + | Some (env, _name, stamp) -> + (* oooh wht do I do if the stamp is inside a pseudo-file? *) + maybe_log ("Got stamp " ^ string_of_int stamp); + definition ~file:env.file ~package stamp tip)) + +let dig_constructor ~env ~package path = + match Resolve_path.resolve_from_compiler_path ~env ~package path with + | NotFound -> None + | Stamp stamp -> ( + match Stamps.find_type env.file.stamps stamp with + | None -> None + | Some t -> Some (env, t)) + | Exported (env, name) -> ( + match Exported.find env.exported Exported.Type name with + | None -> None + | Some stamp -> ( + match Stamps.find_type env.file.stamps stamp with + | None -> None + | Some t -> Some (env, t))) + | _ -> None + +let type_definition_for_loc_item ~full:{file; package} loc_item = + match loc_item.loc_type with + | Constant _ | TopLevelModule _ | LModule _ -> None + | TypeDefinition _ -> Some (file.uri, loc_item.loc) + | Typed (_, typ, _) -> ( + let env = Query_env.from_file file in + match Shared.dig_constructor typ with + | None -> None + | Some path -> ( + match dig_constructor ~env ~package path with + | Some (env, declared) -> Some (env.file.uri, declared.item.decl.type_loc) + | None -> None)) + +let is_visible (declared : _ Declared.t) = + declared.is_exported + && + let rec loop (v : Module_path.t) = + match v with + | File _ -> true + | NotVisible -> false + | IncludedModule (_, inner) -> loop inner + | ExportedModule {module_path = inner} -> loop inner + in + loop declared.module_path + +type references = { + uri: Uri.t; + loc_opt: Location.t option; (* None: reference to a toplevel module *) +} + +let for_local_stamp ~full:{file; extra; package} stamp (tip : Tip.t) = + let env = Query_env.from_file file in + match + match tip with + | Constructor name -> + get_constructor file stamp name + |> Option.map (fun x -> x.Constructor.stamp) + | Field name -> get_field file stamp name |> Option.map (fun x -> x.stamp) + | _ -> Some stamp + with + | None -> [] + | Some local_stamp -> ( + match Hashtbl.find_opt extra.internal_references local_stamp with + | None -> [] + | Some locs -> + maybe_log ("Checking externals: " ^ string_of_int stamp); + let externals = + match declared_for_tip ~stamps:env.file.stamps stamp tip with + | None -> [] + | Some declared -> + if is_visible declared then ( + let alternative_references = + match alternate_declared ~package ~file declared tip with + | None -> [] + | Some (file, extra, {stamp}) -> ( + match + match tip with + | Constructor name -> + get_constructor file stamp name + |> Option.map (fun x -> x.Constructor.stamp) + | Field name -> + get_field file stamp name |> Option.map (fun x -> x.stamp) + | _ -> Some stamp + with + | None -> [] + | Some local_stamp -> ( + match + Hashtbl.find_opt extra.internal_references local_stamp + with + | None -> [] + | Some locs -> + locs + |> List.map (fun loc -> + {uri = file.uri; loc_opt = Some loc}))) + (* if this file has a corresponding interface or implementation file + also find the references in that file *) + in + let path = + Module_path.to_path declared.module_path declared.name.txt + in + maybe_log ("Now checking path " ^ path_to_string path); + let this_module_name = file.module_name in + let externals = + package.project_files |> File_set.elements + |> List.filter (fun name -> name <> file.module_name) + |> List.map (fun module_name -> + Cmt.fulls_from_module ~package ~module_name + |> List.map (fun {file; extra} -> + match + Hashtbl.find_opt extra.external_references + this_module_name + with + | None -> [] + | Some refs -> + let locs = + refs + |> Utils.filter_map (fun (p, t, locs) -> + if p = path && t = tip then Some locs + else None) + in + locs + |> List.map (fun loc -> + {uri = file.uri; loc_opt = Some loc}))) + |> List.concat |> List.concat + in + alternative_references @ externals) + else ( + maybe_log "Not visible"; + []) + in + List.append + (locs |> List.map (fun loc -> {uri = file.uri; loc_opt = Some loc})) + externals) + +let all_references_for_loc_item ~full:({file; package} as full) loc_item = + match loc_item.loc_type with + | TopLevelModule module_name -> + let other_modules_references = + package.project_files |> File_set.elements + |> Utils.filter_map (fun name -> + match Process_cmt.file_for_module ~package name with + | None -> None + | Some file -> Cmt.full_from_uri ~uri:file.uri) + |> List.map (fun full -> + match Hashtbl.find_opt full.extra.file_references module_name with + | None -> [] + | Some locs -> + locs |> Location_set.elements + |> List.map (fun loc -> + { + uri = Uri.from_path loc.Location.loc_start.pos_fname; + loc_opt = Some loc; + })) + |> List.flatten + in + let target_module_references = + match Hashtbl.find_opt package.paths_for_module module_name with + | None -> [] + | Some paths -> + let module_src_to_ref src = {uri = Uri.from_path src; loc_opt = None} in + get_src paths |> List.map module_src_to_ref + in + List.append target_module_references other_modules_references + | Typed (_, _, NotFound) | LModule NotFound | Constant _ -> [] + | TypeDefinition (_, _, stamp) -> for_local_stamp ~full stamp Type + | Typed (_, _, (LocalReference (stamp, tip) | Definition (stamp, tip))) + | LModule (LocalReference (stamp, tip) | Definition (stamp, tip)) -> + maybe_log + ("Finding references for " ^ Uri.to_string file.uri ^ " and stamp " + ^ string_of_int stamp ^ " and tip " ^ Tip.to_string tip); + for_local_stamp ~full stamp tip + | LModule (GlobalReference (module_name, path, tip)) + | Typed (_, _, GlobalReference (module_name, path, tip)) -> ( + match Process_cmt.file_for_module ~package module_name with + | None -> [] + | Some file -> ( + let env = Query_env.from_file file in + match exported_for_tip ~env ~path ~package ~tip with + | None -> [] + | Some (env, _name, stamp) -> ( + match Cmt.full_from_uri ~uri:env.file.uri with + | None -> [] + | Some full -> + maybe_log + ("Finding references for (global) " ^ Uri.to_string env.file.uri + ^ " and stamp " ^ string_of_int stamp ^ " and tip " + ^ Tip.to_string tip); + for_local_stamp ~full stamp tip))) diff --git a/analysis/src/resolve_path.ml b/analysis/src/resolve_path.ml new file mode 100644 index 00000000000..9393269359a --- /dev/null +++ b/analysis/src/resolve_path.ml @@ -0,0 +1,149 @@ +open Shared_types + +type resolution = + | Exported of Query_env.t * file_path + | Global of file_path * file_path list + | GlobalMod of file_path + | NotFound + | Stamp of int + +let rec join_paths module_path path = + match module_path with + | Path.Pident ident -> (ident.stamp, ident.name, path) + | Papply (fn_path, _argPath) -> join_paths fn_path path + | Pdot (inner, name, _) -> join_paths inner (name :: path) + +let rec make_path ~(env : Query_env.t) module_path = + match module_path with + | Path.Pident ident when ident.stamp == 0 -> GlobalMod ident.name + | Pident ident -> Stamp ident.stamp + | Papply (fn_path, _argPath) -> make_path ~env fn_path + | Pdot (inner, name, _) -> ( + match join_paths inner [name] with + | 0, module_name, path -> Global (module_name, path) + | stamp, _moduleName, path -> ( + let res = + match Stamps.find_module env.file.stamps stamp with + | None -> None + | Some {item = kind} -> find_in_module ~env kind path + in + match res with + | None -> NotFound + | Some (`Local (env, name)) -> Exported (env, name) + | Some (`Global (module_name, full_path)) -> + Global (module_name, full_path))) + +and resolve_path_inner ~(env : Query_env.t) ~path = + match path with + | [] -> None + | [name] -> Some (`Local (env, name)) + | sub_name :: sub_path -> ( + match Exported.find env.exported Exported.Module sub_name with + | None -> None + | Some stamp -> ( + match Stamps.find_module env.file.stamps stamp with + | None -> None + | Some {item} -> find_in_module ~env item sub_path)) + +and find_in_module ~(env : Query_env.t) module_ path = + match module_ with + | Structure structure -> + resolve_path_inner ~env:(Query_env.enter_structure env structure) ~path + | Constraint (_, module1) -> find_in_module ~env module1 path + | Ident module_path -> ( + let stamp, module_name, full_path = join_paths module_path path in + if stamp = 0 then Some (`Global (module_name, full_path)) + else + match Stamps.find_module env.file.stamps stamp with + | None -> None + | Some {item} -> find_in_module ~env item full_path) + +let rec resolve_path ~env ~path ~package = + Log.log ("resolvePath path:" ^ path_to_string path); + match resolve_path_inner ~env ~path with + | None -> None + | Some result -> ( + match result with + | `Local (env, name) -> Some (env, name) + | `Global (module_name, full_path) -> ( + Log.log + ("resolvePath Global path:" ^ path_to_string full_path ^ " module:" + ^ module_name); + match Process_cmt.file_for_module ~package module_name with + | None -> None + | Some file -> + resolve_path ~env:(Query_env.from_file file) ~path:full_path ~package)) + +let from_compiler_path ~(env : Query_env.t) path : resolution = + match make_path ~env path with + | Stamp stamp -> Stamp stamp + | GlobalMod name -> GlobalMod name + | NotFound -> NotFound + | Exported (env, name) -> Exported (env, name) + | Global (module_name, full_path) -> Global (module_name, full_path) + +let resolve_module_from_compiler_path ~env ~package path = + match from_compiler_path ~env path with + | Global (module_name, path) -> ( + match Process_cmt.file_for_module ~package module_name with + | None -> None + | Some file -> ( + let env = Query_env.from_file file in + match resolve_path ~env ~package ~path with + | None -> None + | Some (env, name) -> ( + match Exported.find env.exported Exported.Module name with + | None -> None + | Some stamp -> ( + match Stamps.find_module env.file.stamps stamp with + | None -> None + | Some declared -> Some (env, Some declared))))) + | Stamp stamp -> ( + match Stamps.find_module env.file.stamps stamp with + | None -> None + | Some declared -> Some (env, Some declared)) + | GlobalMod module_name -> ( + match Process_cmt.file_for_module ~package module_name with + | None -> None + | Some file -> + let env = Query_env.from_file file in + Some (env, None)) + | NotFound -> None + | Exported (env, name) -> ( + match Exported.find env.exported Exported.Module name with + | None -> None + | Some stamp -> ( + match Stamps.find_module env.file.stamps stamp with + | None -> None + | Some declared -> Some (env, Some declared))) + +let resolve_from_compiler_path ~env ~package path = + match from_compiler_path ~env path with + | Global (module_name, path) -> ( + let res = + match Process_cmt.file_for_module ~package module_name with + | None -> None + | Some file -> + let env = Query_env.from_file file in + resolve_path ~env ~package ~path + in + match res with + | None -> NotFound + | Some (env, name) -> Exported (env, name)) + | Stamp stamp -> Stamp stamp + | GlobalMod _ -> NotFound + | NotFound -> NotFound + | Exported (env, name) -> Exported (env, name) + +let rec get_source_uri ~(env : Query_env.t) ~package (path : Module_path.t) = + match path with + | File (uri, _moduleName) -> uri + | NotVisible -> env.file.uri + | IncludedModule (path, inner) -> ( + Log.log "INCLUDED MODULE"; + match resolve_module_from_compiler_path ~env ~package path with + | None -> + Log.log "NOT FOUND"; + get_source_uri ~env ~package inner + | Some (env, _declared) -> env.file.uri) + | ExportedModule {module_path = inner} -> get_source_uri ~env ~package inner diff --git a/analysis/src/scope.ml b/analysis/src/scope.ml new file mode 100644 index 00000000000..115cdcca8ab --- /dev/null +++ b/analysis/src/scope.ml @@ -0,0 +1,150 @@ +type item = Shared_types.Scope_types.item + +type t = item list + +open Shared_types.Scope_types + +let item_to_string item = + let str s = if s = "" then "\"\"" else s in + let list l = "[" ^ (l |> List.map str |> String.concat ", ") ^ "]" in + match item with + | Constructor (s, loc) -> "Constructor " ^ s ^ " " ^ Loc.to_string loc + | Field (s, loc) -> "Field " ^ s ^ " " ^ Loc.to_string loc + | Open sl -> "Open " ^ list sl + | Module (s, loc) -> "Module " ^ s ^ " " ^ Loc.to_string loc + | Value (s, loc, _, _) -> "Value " ^ s ^ " " ^ Loc.to_string loc + | Type (s, loc) -> "Type " ^ s ^ " " ^ Loc.to_string loc + | Include (s, loc) -> "Include " ^ s ^ " " ^ Loc.to_string loc +[@@live] + +let create () : t = [] +let add_constructor ~name ~loc x = Constructor (name, loc) :: x +let add_field ~name ~loc x = Field (name, loc) :: x +let add_module ~name ~loc x = Module (name, loc) :: x +let add_open ~lid x = + Open (Utils.flatten_long_ident lid @ ["place holder"]) :: x +let add_value ~name ~loc ?context_path x = + let show_debug = !Cfg.debug_follow_ctx_path in + (if show_debug then + match context_path with + | None -> Printf.printf "adding value '%s', no ctxPath\n" name + | Some context_path -> + if show_debug then + Printf.printf "adding value '%s' with ctxPath: %s\n" name + (Shared_types.Completable.context_path_to_string context_path)); + Value (name, loc, context_path, x) :: x +let add_type ~name ~loc x = Type (name, loc) :: x +let add_include ~name ~loc x = Include (name, loc) :: x + +let iter_values_before_first_open f x = + let rec loop items = + match items with + | Value (s, loc, context_path, scope) :: rest -> + f s loc context_path scope; + loop rest + | Open _ :: _ -> () + | _ :: rest -> loop rest + | [] -> () + in + loop x + +let iter_values_after_first_open f x = + let rec loop found_open items = + match items with + | Value (s, loc, context_path, scope) :: rest -> + if found_open then f s loc context_path scope; + loop found_open rest + | Open _ :: rest -> loop true rest + | _ :: rest -> loop found_open rest + | [] -> () + in + loop false x + +let iter_constructors_before_first_open f x = + let rec loop items = + match items with + | Constructor (s, loc) :: rest -> + f s loc; + loop rest + | Open _ :: _ -> () + | _ :: rest -> loop rest + | [] -> () + in + loop x + +let iter_constructors_after_first_open f x = + let rec loop found_open items = + match items with + | Constructor (s, loc) :: rest -> + if found_open then f s loc; + loop found_open rest + | Open _ :: rest -> loop true rest + | _ :: rest -> loop found_open rest + | [] -> () + in + loop false x + +let iter_types_before_first_open f x = + let rec loop items = + match items with + | Type (s, loc) :: rest -> + f s loc; + loop rest + | Open _ :: _ -> () + | _ :: rest -> loop rest + | [] -> () + in + loop x + +let iter_types_after_first_open f x = + let rec loop found_open items = + match items with + | Type (s, loc) :: rest -> + if found_open then f s loc; + loop found_open rest + | Open _ :: rest -> loop true rest + | _ :: rest -> loop found_open rest + | [] -> () + in + loop false x + +let iter_modules_before_first_open f x = + let rec loop items = + match items with + | Module (s, loc) :: rest -> + f s loc; + loop rest + | Open _ :: _ -> () + | _ :: rest -> loop rest + | [] -> () + in + loop x + +let iter_modules_after_first_open f x = + let rec loop found_open items = + match items with + | Module (s, loc) :: rest -> + if found_open then f s loc; + loop found_open rest + | Open _ :: rest -> loop true rest + | _ :: rest -> loop found_open rest + | [] -> () + in + loop false x + +let iter_includes f x = + let rec loop items = + match items with + | [] -> () + | Include (s, loc) :: rest -> + f s loc; + loop rest + | _ :: rest -> loop rest + in + loop x + +let get_raw_opens x = + x + |> Utils.filter_map (function + | Open path -> Some path + | _ -> None) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/semantic_tokens.ml similarity index 66% rename from analysis/src/SemanticTokens.ml rename to analysis/src/semantic_tokens.ml index 1862ba612f4..10532f81ee6 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/semantic_tokens.ml @@ -19,7 +19,7 @@ module Token = struct (* This needs to stay synced with the same legend in `server.ts` *) (* See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens *) - type tokenType = + type token_type = | Operator (** < and > *) | Variable (** let x = *) | Type (** type t = *) @@ -29,7 +29,7 @@ module Token = struct | Property (** {x:...} *) | JsxLowercase (** div in
*) - let tokenTypeToInt = function + let token_type_to_int = function | Operator -> 0 | Variable -> 1 | Type -> 2 @@ -39,7 +39,7 @@ module Token = struct | Property -> 6 | JsxLowercase -> 7 - let tokenTypeDebug = function + let token_type_debug = function | Operator -> "Operator" | Variable -> "Variable" | Type -> "Type" @@ -49,71 +49,79 @@ module Token = struct | Property -> "Property" | JsxLowercase -> "JsxLowercase" - let tokenModifiers = 0 (* None at the moment *) + let token_modifiers = 0 (* None at the moment *) - type token = int * int * int * tokenType + type token = int * int * int * token_type type emitter = { mutable tokens: token list; - mutable lastLine: int; - mutable lastChar: int; + mutable last_line: int; + mutable last_char: int; } - let createEmitter () = {tokens = []; lastLine = 0; lastChar = 0} + let create_emitter () = {tokens = []; last_line = 0; last_char = 0} let add ~line ~char ~length ~type_ e = e.tokens <- (line, char, length, type_) :: e.tokens - let emitToken (line, char, length, type_) e = - let deltaLine = line - e.lastLine in - let deltaChar = if deltaLine = 0 then char - e.lastChar else char in - e.lastLine <- line; - e.lastChar <- char; - if deltaLine >= 0 && deltaChar >= 0 && length >= 0 then + let emit_token (line, char, length, type_) e = + let delta_line = line - e.last_line in + let delta_char = if delta_line = 0 then char - e.last_char else char in + e.last_line <- line; + e.last_char <- char; + if delta_line >= 0 && delta_char >= 0 && length >= 0 then Some - [|deltaLine; deltaChar; length; tokenTypeToInt type_; tokenModifiers|] + [| + delta_line; + delta_char; + length; + token_type_to_int type_; + token_modifiers; + |] else None let emit e = - let sortedTokens = + let sorted_tokens = e.tokens |> List.sort (fun (l1, c1, _, _) (l2, c2, _, _) -> if l1 = l2 then compare c1 c2 else compare l1 l2) in - let arrays = sortedTokens |> List.filter_map (fun t -> e |> emitToken t) in + let arrays = + sorted_tokens |> List.filter_map (fun t -> e |> emit_token t) + in Array.concat arrays - let arrayToJsonString arr = + let array_to_json_string arr = let items = Array.map string_of_int arr |> Array.to_list in "[" ^ String.concat "," items ^ "]" end -let isLowercaseId id = +let is_lowercase_id id = id <> "" && let c = id.[0] in c == '_' || (c >= 'a' && c <= 'z') -let isUppercaseId id = +let is_uppercase_id id = id <> "" && let c = id.[0] in c >= 'A' && c <= 'Z' -let emitFromRange (posStart, posEnd) ~type_ emitter = +let emit_from_range (pos_start, pos_end) ~type_ emitter = let length = - if fst posStart = fst posEnd then snd posEnd - snd posStart else 0 + if fst pos_start = fst pos_end then snd pos_end - snd pos_start else 0 in if length > 0 then emitter - |> Token.add ~line:(fst posStart) ~char:(snd posStart) ~length ~type_ + |> Token.add ~line:(fst pos_start) ~char:(snd pos_start) ~length ~type_ -let emitFromLoc ~loc ~type_ emitter = - emitter |> emitFromRange (Loc.range loc) ~type_ +let emit_from_loc ~loc ~type_ emitter = + emitter |> emit_from_range (Loc.range loc) ~type_ -let emitLongident ?(backwards = false) ?(jsx = false) - ?(lowerCaseToken = if jsx then Token.JsxLowercase else Token.Variable) - ?(upperCaseToken = Token.Namespace) ?(lastToken = None) ?(posEnd = None) +let emit_longident ?(backwards = false) ?(jsx = false) + ?(lower_case_token = if jsx then Token.JsxLowercase else Token.Variable) + ?(upper_case_token = Token.Namespace) ?(last_token = None) ?(pos_end = None) ~pos ~lid ~debug emitter = let rec flatten acc lid = match lid with @@ -123,112 +131,118 @@ let emitLongident ?(backwards = false) ?(jsx = false) in let rec loop pos segments = match segments with - | [id] when isUppercaseId id || isLowercaseId id -> + | [id] when is_uppercase_id id || is_lowercase_id id -> let type_ = - match lastToken with + match last_token with | Some type_ -> type_ - | None -> if isUppercaseId id then upperCaseToken else lowerCaseToken + | None -> + if is_uppercase_id id then upper_case_token else lower_case_token in - let posAfter = (fst pos, snd pos + String.length id) in - let posEnd, lenMismatch = + let pos_after = (fst pos, snd pos + String.length id) in + let pos_end, len_mismatch = (* There could be a length mismatch when ids are quoted e.g. variable /"true" or object field {"x":...} *) - match posEnd with - | Some posEnd -> (posEnd, posEnd <> posAfter) - | None -> (posAfter, false) + match pos_end with + | Some pos_end -> (pos_end, pos_end <> pos_after) + | None -> (pos_after, false) in if debug then - Printf.printf "Lident: %s %s%s %s\n" id (Pos.toString pos) - (if lenMismatch then "->" ^ Pos.toString posEnd else "") - (Token.tokenTypeDebug type_); - emitter |> emitFromRange (pos, posEnd) ~type_ - | id :: segments when isUppercaseId id || isLowercaseId id -> - let type_ = if isUppercaseId id then upperCaseToken else lowerCaseToken in + Printf.printf "Lident: %s %s%s %s\n" id (Pos.to_string pos) + (if len_mismatch then "->" ^ Pos.to_string pos_end else "") + (Token.token_type_debug type_); + emitter |> emit_from_range (pos, pos_end) ~type_ + | id :: segments when is_uppercase_id id || is_lowercase_id id -> + let type_ = + if is_uppercase_id id then upper_case_token else lower_case_token + in if debug then - Printf.printf "Ldot: %s %s %s\n" id (Pos.toString pos) - (Token.tokenTypeDebug type_); + Printf.printf "Ldot: %s %s %s\n" id (Pos.to_string pos) + (Token.token_type_debug type_); let length = String.length id in - emitter |> emitFromRange (pos, (fst pos, snd pos + length)) ~type_; + emitter |> emit_from_range (pos, (fst pos, snd pos + length)) ~type_; loop (fst pos, snd pos + length + 1) segments | _ -> () in let segments = flatten [] lid in if backwards then ( - let totalLength = segments |> String.concat "." |> String.length in - if snd pos >= totalLength then - loop (fst pos, snd pos - totalLength) segments) + let total_length = segments |> String.concat "." |> String.length in + if snd pos >= total_length then + loop (fst pos, snd pos - total_length) segments) else loop pos segments -let emitVariable ~id ~debug ~loc emitter = - if debug then Printf.printf "Variable: %s %s\n" id (Loc.toString loc); - emitter |> emitFromLoc ~loc ~type_:Variable +let emit_variable ~id ~debug ~loc emitter = + if debug then Printf.printf "Variable: %s %s\n" id (Loc.to_string loc); + emitter |> emit_from_loc ~loc ~type_:Variable -let emitJsxOpen ~lid ~debug ~(loc : Location.t) emitter = +let emit_jsx_open ~lid ~debug ~(loc : Location.t) emitter = if not loc.loc_ghost then - emitter |> emitLongident ~pos:(Loc.start loc) ~lid ~jsx:true ~debug + emitter |> emit_longident ~pos:(Loc.start loc) ~lid ~jsx:true ~debug -let emitJsxClose ~lid ~debug ~pos emitter = - emitter |> emitLongident ~backwards:true ~pos ~lid ~jsx:true ~debug +let emit_jsx_close ~lid ~debug ~pos emitter = + emitter |> emit_longident ~backwards:true ~pos ~lid ~jsx:true ~debug -let emitJsxTag ~debug ~name ~pos emitter = - if debug then Printf.printf "JsxTag %s: %s\n" name (Pos.toString pos); - emitter |> emitFromRange (pos, (fst pos, snd pos + 1)) ~type_:Token.JsxTag +let emit_jsx_tag ~debug ~name ~pos emitter = + if debug then Printf.printf "JsxTag %s: %s\n" name (Pos.to_string pos); + emitter |> emit_from_range (pos, (fst pos, snd pos + 1)) ~type_:Token.JsxTag -let emitType ~lid ~debug ~(loc : Location.t) emitter = +let emit_type ~lid ~debug ~(loc : Location.t) emitter = if not loc.loc_ghost then emitter - |> emitLongident ~lowerCaseToken:Token.Type ~pos:(Loc.start loc) ~lid ~debug + |> emit_longident ~lower_case_token:Token.Type ~pos:(Loc.start loc) ~lid + ~debug -let emitRecordLabel ~(label : Longident.t Location.loc) ~debug emitter = +let emit_record_label ~(label : Longident.t Location.loc) ~debug emitter = if not label.loc.loc_ghost then emitter - |> emitLongident ~lowerCaseToken:Token.Property ~pos:(Loc.start label.loc) - ~posEnd:(Some (Loc.end_ label.loc)) + |> emit_longident ~lower_case_token:Token.Property + ~pos:(Loc.start label.loc) + ~pos_end:(Some (Loc.end_ label.loc)) ~lid:label.txt ~debug -let emitVariant ~(name : Longident.t Location.loc) ~debug emitter = +let emit_variant ~(name : Longident.t Location.loc) ~debug emitter = if not name.loc.loc_ghost then emitter - |> emitLongident ~lastToken:(Some Token.EnumMember) + |> emit_longident ~last_token:(Some Token.EnumMember) ~pos:(Loc.start name.loc) ~lid:name.txt ~debug -let command ~debug ~emitter ~source ~kindFile = - let processTypeArg (coreType : Parsetree.core_type) = - if debug then Printf.printf "TypeArg: %s\n" (Loc.toString coreType.ptyp_loc) +let command ~debug ~emitter ~source ~kind_file = + let process_type_arg (core_type : Parsetree.core_type) = + if debug then + Printf.printf "TypeArg: %s\n" (Loc.to_string core_type.ptyp_loc) in - let typ (iterator : Ast_iterator.iterator) (coreType : Parsetree.core_type) = - match coreType.ptyp_desc with + let typ (iterator : Ast_iterator.iterator) (core_type : Parsetree.core_type) = + match core_type.ptyp_desc with | Ptyp_constr ({txt = lid; loc}, args) -> - emitter |> emitType ~lid ~debug ~loc; - args |> List.iter processTypeArg; - Ast_iterator.default_iterator.typ iterator coreType - | _ -> Ast_iterator.default_iterator.typ iterator coreType + emitter |> emit_type ~lid ~debug ~loc; + args |> List.iter process_type_arg; + Ast_iterator.default_iterator.typ iterator core_type + | _ -> Ast_iterator.default_iterator.typ iterator core_type in let type_declaration (iterator : Ast_iterator.iterator) (tydecl : Parsetree.type_declaration) = emitter - |> emitType ~lid:(Lident tydecl.ptype_name.txt) ~debug + |> emit_type ~lid:(Lident tydecl.ptype_name.txt) ~debug ~loc:tydecl.ptype_name.loc; Ast_iterator.default_iterator.type_declaration iterator tydecl in let pat (iterator : Ast_iterator.iterator) (p : Parsetree.pattern) = match p.ppat_desc with | Ppat_var {txt = id} -> - if isLowercaseId id then - emitter |> emitVariable ~id ~debug ~loc:p.ppat_loc; + if is_lowercase_id id then + emitter |> emit_variable ~id ~debug ~loc:p.ppat_loc; Ast_iterator.default_iterator.pat iterator p | Ppat_construct ({txt = Lident ("true" | "false")}, _) -> (* Don't emit true or false *) Ast_iterator.default_iterator.pat iterator p | Ppat_record (cases, _) -> Ext_list.iter cases (fun {lid = label} -> - emitter |> emitRecordLabel ~label ~debug); + emitter |> emit_record_label ~label ~debug); Ast_iterator.default_iterator.pat iterator p | Ppat_construct (name, _) -> - emitter |> emitVariant ~name ~debug; + emitter |> emit_variant ~name ~debug; Ast_iterator.default_iterator.pat iterator p | Ppat_type {txt = lid; loc} -> - emitter |> emitType ~lid ~debug ~loc; + emitter |> emit_type ~lid ~debug ~loc; Ast_iterator.default_iterator.pat iterator p | _ -> Ast_iterator.default_iterator.pat iterator p in @@ -258,8 +272,8 @@ let command ~debug ~emitter ~source ~kindFile = in if should_emit then emitter - |> emitLongident ~pos:(Loc.start loc) - ~posEnd:(Some (Loc.end_ loc)) + |> emit_longident ~pos:(Loc.start loc) + ~pos_end:(Some (Loc.end_ loc)) ~lid ~debug; Ast_iterator.default_iterator.expr iterator e) | Pexp_jsx_element (Jsx_unary_element {jsx_unary_element_tag_name = lident}) @@ -273,31 +287,32 @@ let command ~debug ~emitter ~source ~kindFile = - handled like other Longitent.t, except lowercase id is marked Token.JsxLowercase *) emitter (* --> emitJsxTag ~debug ~name:"<" ~pos:(Loc.start e.pexp_loc); + |> emit_jsx_tag ~debug ~name:"<" ~pos:(Loc.start e.pexp_loc); let lid = Ast_helper.Jsx.longident_of_jsx_tag_name lident.txt in let loc = lident.loc in - emitter |> emitJsxOpen ~lid ~debug ~loc; + emitter |> emit_jsx_open ~lid ~debug ~loc; let closing_line, closing_column = Loc.end_ e.pexp_loc in emitter (* <-- *) - |> emitJsxTag ~debug ~name:"/>" ~pos:(closing_line, closing_column - 2) + |> emit_jsx_tag ~debug ~name:"/>" ~pos:(closing_line, closing_column - 2) (* minus two for /> *) | Pexp_jsx_element (Jsx_container_element { jsx_container_element_tag_name_start = lident; - jsx_container_element_opening_tag_end = posOfGreatherthanAfterProps; + jsx_container_element_opening_tag_end = + pos_of_greatherthan_after_props; jsx_container_element_children = children; jsx_container_element_closing_tag = closing_tag_opt; }) -> (* opening tag *) emitter (* --> emitJsxTag ~debug ~name:"<" ~pos:(Loc.start e.pexp_loc); + |> emit_jsx_tag ~debug ~name:"<" ~pos:(Loc.start e.pexp_loc); let lid = Ast_helper.Jsx.longident_of_jsx_tag_name lident.txt in let loc = lident.loc in - emitter |> emitJsxOpen ~lid ~debug ~loc; + emitter |> emit_jsx_open ~lid ~debug ~loc; emitter (* <-- *) - |> emitJsxTag ~debug ~name:">" - ~pos:(Pos.ofLexing posOfGreatherthanAfterProps); + |> emit_jsx_tag ~debug ~name:">" + ~pos:(Pos.of_lexing pos_of_greatherthan_after_props); (* children *) List.iter (iterator.expr iterator) children; @@ -316,16 +331,16 @@ let command ~debug ~emitter ~source ~kindFile = } -> emitter - |> emitJsxTag ~debug ~name:" emit_jsx_tag ~debug ~name:" emitJsxClose ~debug ~lid ~pos:(Loc.end_ loc); + emitter |> emit_jsx_close ~debug ~lid ~pos:(Loc.end_ loc); emitter (* ... <-- *) - |> emitJsxTag ~debug ~name:">" - ~pos:(Pos.ofLexing final_greather_than)) + |> emit_jsx_tag ~debug ~name:">" + ~pos:(Pos.of_lexing final_greather_than)) | Pexp_apply { funct = @@ -336,25 +351,25 @@ let command ~debug ~emitter ~source ~kindFile = args = [_; _]; } -> if debug then - Printf.printf "Binary operator %s %s\n" op (Loc.toString loc); - emitter |> emitFromLoc ~loc ~type_:Operator; + Printf.printf "Binary operator %s %s\n" op (Loc.to_string loc); + emitter |> emit_from_loc ~loc ~type_:Operator; Ast_iterator.default_iterator.expr iterator e | Pexp_record (cases, _) -> Ext_list.filter_map cases (fun {lid} -> match lid.txt with - | Longident.Lident s when not (Utils.isFirstCharUppercase s) -> + | Longident.Lident s when not (Utils.is_first_char_uppercase s) -> Some lid | _ -> None) - |> List.iter (fun label -> emitter |> emitRecordLabel ~label ~debug); + |> List.iter (fun label -> emitter |> emit_record_label ~label ~debug); Ast_iterator.default_iterator.expr iterator e | Pexp_field (_, label) | Pexp_setfield (_, label, _) -> - emitter |> emitRecordLabel ~label ~debug; + emitter |> emit_record_label ~label ~debug; Ast_iterator.default_iterator.expr iterator e | Pexp_construct ({txt = Lident ("true" | "false")}, _) -> (* Don't emit true or false *) Ast_iterator.default_iterator.expr iterator e | Pexp_construct (name, _) -> - emitter |> emitVariant ~name ~debug; + emitter |> emit_variant ~name ~debug; Ast_iterator.default_iterator.expr iterator e | _ -> Ast_iterator.default_iterator.expr iterator e in @@ -363,7 +378,7 @@ let command ~debug ~emitter ~source ~kindFile = match me.pmod_desc with | Pmod_ident {txt = lid; loc} -> if not loc.loc_ghost then - emitter |> emitLongident ~pos:(Loc.start loc) ~lid ~debug; + emitter |> emit_longident ~pos:(Loc.start loc) ~lid ~debug; Ast_iterator.default_iterator.module_expr iterator me | _ -> Ast_iterator.default_iterator.module_expr iterator me in @@ -371,7 +386,7 @@ let command ~debug ~emitter ~source ~kindFile = (mb : Parsetree.module_binding) = if not mb.pmb_name.loc.loc_ghost then emitter - |> emitLongident + |> emit_longident ~pos:(Loc.start mb.pmb_name.loc) ~lid:(Longident.Lident mb.pmb_name.txt) ~debug; Ast_iterator.default_iterator.module_binding iterator mb @@ -380,7 +395,7 @@ let command ~debug ~emitter ~source ~kindFile = (md : Parsetree.module_declaration) = if not md.pmd_name.loc.loc_ghost then emitter - |> emitLongident + |> emit_longident ~pos:(Loc.start md.pmd_name.loc) ~lid:(Longident.Lident md.pmd_name.txt) ~debug; Ast_iterator.default_iterator.module_declaration iterator md @@ -391,7 +406,7 @@ let command ~debug ~emitter ~source ~kindFile = | Pmty_ident {txt = lid; loc} -> if not loc.loc_ghost then emitter - |> emitLongident ~upperCaseToken:Token.Type ~pos:(Loc.start loc) ~lid + |> emit_longident ~upper_case_token:Token.Type ~pos:(Loc.start loc) ~lid ~debug; Ast_iterator.default_iterator.module_type iterator mt | _ -> Ast_iterator.default_iterator.module_type iterator mt @@ -400,7 +415,7 @@ let command ~debug ~emitter ~source ~kindFile = (mtd : Parsetree.module_type_declaration) = if not mtd.pmtd_name.loc.loc_ghost then emitter - |> emitLongident ~upperCaseToken:Token.Type + |> emit_longident ~upper_case_token:Token.Type ~pos:(Loc.start mtd.pmtd_name.loc) ~lid:(Longident.Lident mtd.pmtd_name.txt) ~debug; Ast_iterator.default_iterator.module_type_declaration iterator mtd @@ -409,7 +424,7 @@ let command ~debug ~emitter ~source ~kindFile = (od : Parsetree.open_description) = if not od.popen_lid.loc.loc_ghost then emitter - |> emitLongident + |> emit_longident ~pos:(Loc.start od.popen_lid.loc) ~lid:od.popen_lid.txt ~debug; Ast_iterator.default_iterator.open_description iterator od @@ -417,7 +432,7 @@ let command ~debug ~emitter ~source ~kindFile = let label_declaration (iterator : Ast_iterator.iterator) (ld : Parsetree.label_declaration) = emitter - |> emitRecordLabel + |> emit_record_label ~label:{loc = ld.pld_name.loc; txt = Longident.Lident ld.pld_name.txt} ~debug; Ast_iterator.default_iterator.label_declaration iterator ld @@ -425,7 +440,7 @@ let command ~debug ~emitter ~source ~kindFile = let constructor_declaration (iterator : Ast_iterator.iterator) (cd : Parsetree.constructor_declaration) = emitter - |> emitVariant + |> emit_variant ~name:{loc = cd.pcd_name.loc; txt = Longident.Lident cd.pcd_name.txt} ~debug; Ast_iterator.default_iterator.constructor_declaration iterator cd @@ -435,7 +450,7 @@ let command ~debug ~emitter ~source ~kindFile = (item : Parsetree.structure_item) = (match item.pstr_desc with | Pstr_primitive {pval_name = {txt = id; loc}} -> - emitter |> emitVariable ~id ~debug ~loc + emitter |> emit_variable ~id ~debug ~loc | _ -> ()); Ast_iterator.default_iterator.structure_item iterator item in @@ -444,7 +459,7 @@ let command ~debug ~emitter ~source ~kindFile = (item : Parsetree.signature_item) = (match item.psig_desc with | Psig_value {pval_name = {txt = id; loc}} -> - emitter |> emitVariable ~id ~debug ~loc + emitter |> emit_variable ~id ~debug ~loc | _ -> ()); Ast_iterator.default_iterator.signature_item iterator item in @@ -469,7 +484,7 @@ let command ~debug ~emitter ~source ~kindFile = } in - if kindFile = Files.Res then ( + if kind_file = Files.Res then ( let parser = Res_driver.parsing_engine.parse_implementation_from_source ~for_printer:false @@ -489,7 +504,7 @@ let command ~debug ~emitter ~source ~kindFile = (List.length signature) (List.length diagnostics); iterator.signature iterator signature |> ignore -let semanticTokens ~source ~kindFile = - let emitter = Token.createEmitter () in - command ~emitter ~debug:false ~source ~kindFile; +let semantic_tokens ~source ~kind_file = + let emitter = Token.create_emitter () in + command ~emitter ~debug:false ~source ~kind_file; Lsp.Types.SemanticTokens.create ~data:(Token.emit emitter) () diff --git a/analysis/src/Shared.ml b/analysis/src/shared.ml similarity index 71% rename from analysis/src/Shared.ml rename to analysis/src/shared.ml index b2d7edf76ea..d5467fc2288 100644 --- a/analysis/src/Shared.ml +++ b/analysis/src/shared.ml @@ -1,4 +1,4 @@ -let tryReadCmt cmt = +let try_read_cmt cmt = if not (Files.exists cmt) then ( Log.log ("Cmt file does not exist " ^ cmt); None) @@ -16,7 +16,7 @@ let tryReadCmt cmt = None | x -> Some x -let tryReadCmi cmi = +let try_read_cmi cmi = if not (Files.exists cmi) then None else match Cmt_format.read_cmi cmi with @@ -32,21 +32,21 @@ let rec dig (te : Types.type_expr) = | Tpoly (inner, _) -> dig inner | _ -> te -let digConstructor te = +let dig_constructor te = match (dig te).desc with | Tconstr (path, _args, _memo) -> Some path | _ -> None -let findTypeConstructors (tel : Types.type_expr list) = +let find_type_constructors (tel : Types.type_expr list) = let paths = ref [] in - let addPath path = + let add_path path = if not (List.exists (Path.same path) !paths) then paths := path :: !paths in let rec loop (te : Types.type_expr) = match te.desc with | Tlink te1 | Tsubst te1 | Tpoly (te1, _) -> loop te1 | Tconstr (path, args, _) -> - addPath path; + add_path path; args |> List.iter loop | Tarrow (arg, ret, _, _) -> loop arg.typ; @@ -59,18 +59,18 @@ let findTypeConstructors (tel : Types.type_expr list) = tel |> List.iter loop; !paths |> List.rev -let declToString ?printNameAsIs ?(recStatus = Types.Trec_not) name t = - PrintType.printDecl ?printNameAsIs ~recStatus name t +let decl_to_string ?print_name_as_is ?(rec_status = Types.Trec_not) name t = + Print_type.print_decl ?print_name_as_is ~rec_status name t -let cacheTypeToString = ref false -let typeTbl = Hashtbl.create 1 +let cache_type_to_string = ref false +let type_tbl = Hashtbl.create 1 -let typeToString ?lineWidth (t : Types.type_expr) = +let type_to_string ?line_width (t : Types.type_expr) = match - if !cacheTypeToString then Hashtbl.find_opt typeTbl (t.id, t) else None + if !cache_type_to_string then Hashtbl.find_opt type_tbl (t.id, t) else None with | None -> - let s = PrintType.printExpr ?lineWidth t in - Hashtbl.replace typeTbl (t.id, t) s; + let s = Print_type.print_expr ?line_width t in + Hashtbl.replace type_tbl (t.id, t) s; s | Some s -> s diff --git a/analysis/src/shared_types.ml b/analysis/src/shared_types.ml new file mode 100644 index 00000000000..7685e8cd5b8 --- /dev/null +++ b/analysis/src/shared_types.ml @@ -0,0 +1,968 @@ +let str s = if s = "" then "\"\"" else s +let list l = "[" ^ (l |> List.map str |> String.concat ", ") ^ "]" +let ident l = l |> List.map str |> String.concat "." + +type path = string list + +type typed_fn_arg = Asttypes.arg_label * Types.type_expr + +let path_to_string (path : path) = path |> String.concat "." + +module Module_path = struct + type t = + | File of Uri.t * string + | NotVisible + | IncludedModule of Path.t * t + | ExportedModule of {name: string; module_path: t; is_type: bool} + + let to_path module_path tip_name : path = + let rec loop module_path current = + match module_path with + | File _ -> current + | IncludedModule (_, inner) -> loop inner current + | ExportedModule {name; module_path = inner} -> + loop inner (name :: current) + | NotVisible -> current + in + loop module_path [tip_name] + + let to_path_with_prefix module_path prefix : path = + let rec loop module_path current = + match module_path with + | File _ -> current + | IncludedModule (_, inner) -> loop inner current + | ExportedModule {name; module_path = inner} -> + loop inner (name :: current) + | NotVisible -> current + in + prefix :: loop module_path [] +end + +type field = { + stamp: int; + fname: string Location.loc; + typ: Types.type_expr; + optional: bool; + docstring: string list; + deprecated: string option; +} + +type constructor_args = + | InlineRecord of field list + | Args of (Types.type_expr * Location.t) list + +module Constructor = struct + type t = { + stamp: int; + cname: string Location.loc; + args: constructor_args; + res: Types.type_expr option; + type_decl: string * Types.type_declaration; + docstring: string list; + deprecated: string option; + } +end + +module Type = struct + type kind = + | Abstract of (Path.t * Types.type_expr list) option + | Open + | Tuple of Types.type_expr list + | Record of field list + | Variant of Constructor.t list + + type t = { + kind: kind; + decl: Types.type_declaration; + name: string; + attributes: Parsetree.attributes; + } +end + +module Exported = struct + type named_stamp_map = (string, int) Hashtbl.t + + type t = { + types_: named_stamp_map; + values_: named_stamp_map; + modules_: named_stamp_map; + } + + type kind = Type | Value | Module + + let init () = + { + types_ = Hashtbl.create 10; + values_ = Hashtbl.create 10; + modules_ = Hashtbl.create 10; + } + + let add t kind name x = + let tbl = + match kind with + | Type -> t.types_ + | Value -> t.values_ + | Module -> t.modules_ + in + if Hashtbl.mem tbl name then false + else + let () = Hashtbl.add tbl name x in + true + + let find t kind name = + let tbl = + match kind with + | Type -> t.types_ + | Value -> t.values_ + | Module -> t.modules_ + in + Hashtbl.find_opt tbl name + + let iter t kind f = + let tbl = + match kind with + | Type -> t.types_ + | Value -> t.values_ + | Module -> t.modules_ + in + Hashtbl.iter f tbl +end + +module Module = struct + type kind = + | Value of Types.type_expr + | Type of Type.t * Types.rec_status + | Module of {type_: t; is_module_type: bool} + + and item = { + kind: kind; + name: string; + loc: Location.t; + docstring: string list; + deprecated: string option; + } + + and structure = { + name: string; + docstring: string list; + exported: Exported.t; + items: item list; + deprecated: string option; + } + + and t = Ident of Path.t | Structure of structure | Constraint of t * t +end + +module Declared = struct + type 'item t = { + name: string Location.loc; + extent_loc: Location.t; + stamp: int; + module_path: Module_path.t; + is_exported: bool; + deprecated: string option; + docstring: string list; + item: 'item; + } +end + +module Stamps : sig + type kind = + | KType of Type.t Declared.t + | KValue of Types.type_expr Declared.t + | KModule of Module.t Declared.t + | KConstructor of Constructor.t Declared.t + + val loc_of_kind : kind -> Warnings.loc + + type t + + val add_constructor : t -> int -> Constructor.t Declared.t -> unit + val add_module : t -> int -> Module.t Declared.t -> unit + val add_type : t -> int -> Type.t Declared.t -> unit + val add_value : t -> int -> Types.type_expr Declared.t -> unit + val find_module : t -> int -> Module.t Declared.t option + val find_type : t -> int -> Type.t Declared.t option + val find_value : t -> int -> Types.type_expr Declared.t option + val init : unit -> t + val iter_constructors : (int -> Constructor.t Declared.t -> unit) -> t -> unit + val iter_modules : (int -> Module.t Declared.t -> unit) -> t -> unit + val iter_types : (int -> Type.t Declared.t -> unit) -> t -> unit + val iter_values : (int -> Types.type_expr Declared.t -> unit) -> t -> unit + val get_entries : t -> (int * kind) list +end = struct + type 't stamp_map = (int, 't Declared.t) Hashtbl.t + + type kind = + | KType of Type.t Declared.t + | KValue of Types.type_expr Declared.t + | KModule of Module.t Declared.t + | KConstructor of Constructor.t Declared.t + + let loc_of_kind = function + | KType declared -> declared.extent_loc + | KValue declared -> declared.extent_loc + | KModule declared -> declared.extent_loc + | KConstructor declared -> declared.extent_loc + + type t = (int, kind) Hashtbl.t + + let init () = Hashtbl.create 10 + + let add_constructor (stamps : t) stamp declared = + Hashtbl.add stamps stamp (KConstructor declared) + + let add_module stamps stamp declared = + Hashtbl.add stamps stamp (KModule declared) + + let add_type stamps stamp declared = Hashtbl.add stamps stamp (KType declared) + + let add_value stamps stamp declared = + Hashtbl.add stamps stamp (KValue declared) + + let find_module stamps stamp = + match Hashtbl.find_opt stamps stamp with + | Some (KModule declared) -> Some declared + | _ -> None + + let find_type stamps stamp = + match Hashtbl.find_opt stamps stamp with + | Some (KType declared) -> Some declared + | _ -> None + + let find_value stamps stamp = + match Hashtbl.find_opt stamps stamp with + | Some (KValue declared) -> Some declared + | _ -> None + + let iter_modules f stamps = + Hashtbl.iter + (fun stamp d -> + match d with + | KModule d -> f stamp d + | _ -> ()) + stamps + + let iter_types f stamps = + Hashtbl.iter + (fun stamp d -> + match d with + | KType d -> f stamp d + | _ -> ()) + stamps + + let iter_values f stamps = + Hashtbl.iter + (fun stamp d -> + match d with + | KValue d -> f stamp d + | _ -> ()) + stamps + + let iter_constructors f stamps = + Hashtbl.iter + (fun stamp d -> + match d with + | KConstructor d -> f stamp d + | _ -> ()) + stamps + + let get_entries t = t |> Hashtbl.to_seq |> List.of_seq +end + +module File = struct + type t = { + uri: Uri.t; + stamps: Stamps.t; + module_name: string; + structure: Module.structure; + } + + let create module_name uri = + { + uri; + stamps = Stamps.init (); + module_name; + structure = + { + name = module_name; + docstring = []; + exported = Exported.init (); + items = []; + deprecated = None; + }; + } +end + +module Query_env : sig + type t = private { + file: File.t; + exported: Exported.t; + path_rev: path; + parent: t option; + } + val from_file : File.t -> t + val enter_structure : t -> Module.structure -> t + + (* Express a path starting from the module represented by the env. + E.g. the env is at A.B.C and the path is D. + The result is A.B.C.D if D is inside C. + Or A.B.D or A.D or D if it's in one of its parents. *) + val path_from_env : t -> path -> bool * path + + val to_string : t -> string +end = struct + type t = { + file: File.t; + exported: Exported.t; + path_rev: path; + parent: t option; + } + + let to_string {file; path_rev} = + file.module_name :: List.rev path_rev |> String.concat "." + + let from_file (file : File.t) = + {file; exported = file.structure.exported; path_rev = []; parent = None} + + (* Prune a path and find a parent environment that contains the module name *) + let rec prune_path path_rev env name = + if Exported.find env.exported Module name <> None then (true, path_rev) + else + match (path_rev, env.parent) with + | _ :: rest, Some env -> prune_path rest env name + | _ -> (false, []) + + let path_from_env env path = + match path with + | [] -> (true, env.path_rev |> List.rev) + | name :: _ -> + let found, pruned_path_rev = prune_path env.path_rev env name in + (found, List.rev_append pruned_path_rev path) + + let enter_structure env (structure : Module.structure) = + let name = structure.name in + let path_rev = name :: snd (prune_path env.path_rev env name) in + {env with exported = structure.exported; path_rev; parent = Some env} +end + +type type_arg_context = { + env: Query_env.t; + type_args: Types.type_expr list; + type_params: Types.type_expr list; +} + +type poly_variant_constructor = { + name: string; + display_name: string; + args: Types.type_expr list; +} + +(* TODO(env-stuff) All envs for bool string etc can be removed. *) +type inner_type = + | TypeExpr of Types.type_expr + | ExtractedType of completion_type +and completion_type = + | Tuple of Query_env.t * Types.type_expr list * Types.type_expr + | Texn of Query_env.t + | Tpromise of Query_env.t * Types.type_expr + | Toption of Query_env.t * inner_type + | Tresult of { + env: Query_env.t; + ok_type: Types.type_expr; + error_type: Types.type_expr; + } + | Tbool of Query_env.t + | Tarray of Query_env.t * inner_type + | Tstring of Query_env.t + | TtypeT of {env: Query_env.t; path: Path.t} + | Tvariant of { + env: Query_env.t; + constructors: Constructor.t list; + variant_decl: Types.type_declaration; + variant_name: string; + } + | Tpolyvariant of { + env: Query_env.t; + constructors: poly_variant_constructor list; + type_expr: Types.type_expr; + } + | Trecord of { + env: Query_env.t; + fields: field list; + definition: + [ `NameOnly of string + (** When we only have the name, like when pulling the record from a declared type. *) + | `TypeExpr of Types.type_expr + (** When we have the full type expr from the compiler. *) ]; + } + | TinlineRecord of {env: Query_env.t; fields: field list} + | Tfunction of { + env: Query_env.t; + args: typed_fn_arg list; + typ: Types.type_expr; + return_type: Types.type_expr; + } + +module Env = struct + type t = {stamps: Stamps.t; module_path: Module_path.t} + let add_exported_module ~name ~is_type env = + { + env with + module_path = + ExportedModule {name; module_path = env.module_path; is_type}; + } + let add_module ~name env = env |> add_exported_module ~name ~is_type:false + let add_module_type ~name env = env |> add_exported_module ~name ~is_type:true +end + +type file_path = string + +type paths = + | Impl of {cmt: file_path; res: file_path} + | Namespace of {cmt: file_path} + | IntfAndImpl of { + cmti: file_path; + resi: file_path; + cmt: file_path; + res: file_path; + } + +let show_paths paths = + match paths with + | Impl {cmt; res} -> + Printf.sprintf "Impl cmt:%s res:%s" (Utils.dump_path cmt) + (Utils.dump_path res) + | Namespace {cmt} -> Printf.sprintf "Namespace cmt:%s" (Utils.dump_path cmt) + | IntfAndImpl {cmti; resi; cmt; res} -> + Printf.sprintf "IntfAndImpl cmti:%s resi:%s cmt:%s res:%s" + (Utils.dump_path cmti) (Utils.dump_path resi) (Utils.dump_path cmt) + (Utils.dump_path res) + +let get_src p = + match p with + | Impl {res} -> [res] + | Namespace _ -> [] + | IntfAndImpl {resi; res} -> [resi; res] + +let get_uri p = + match p with + | Impl {res} -> Uri.from_path res + | Namespace {cmt} -> Uri.from_path cmt + | IntfAndImpl {resi} -> Uri.from_path resi + +let get_uris p = + match p with + | Impl {res} -> [Uri.from_path res] + | Namespace {cmt} -> [Uri.from_path cmt] + | IntfAndImpl {res; resi} -> [Uri.from_path res; Uri.from_path resi] + +let get_cmt_path ~uri p = + match p with + | Impl {cmt} -> cmt + | Namespace {cmt} -> cmt + | IntfAndImpl {cmti; cmt} -> + let interface = Utils.ends_with (Uri.to_path uri) "i" in + if interface then cmti else cmt + +module Tip = struct + type t = Value | Type | Field of string | Constructor of string | Module + + let to_string tip = + match tip with + | Value -> "Value" + | Type -> "Type" + | Field f -> "Field(" ^ f ^ ")" + | Constructor a -> "Constructor(" ^ a ^ ")" + | Module -> "Module" +end + +let rec path_ident_to_string (p : Path.t) = + match p with + | Pident {name} -> name + | Pdot (next_path, id, _) -> + Printf.sprintf "%s.%s" (path_ident_to_string next_path) id + | Papply _ -> "" + +type loc_kind = + | LocalReference of int * Tip.t + | GlobalReference of string * string list * Tip.t + | NotFound + | Definition of int * Tip.t + +type loc_type = + | Typed of string * Types.type_expr * loc_kind + | Constant of Asttypes.constant + | LModule of loc_kind + | TopLevelModule of string + | TypeDefinition of string * Types.type_declaration * int + +type loc_item = {loc: Location.t; loc_type: loc_type} + +module Location_set = Set.Make (struct + include Location + + let compare loc1 loc2 = compare loc2 loc1 + + (* polymorphic compare should be OK *) +end) + +type extra = { + internal_references: (int, Location.t list) Hashtbl.t; + external_references: + (string, (string list * Tip.t * Location.t) list) Hashtbl.t; + file_references: (string, Location_set.t) Hashtbl.t; + mutable loc_items: loc_item list; +} + +type file = string + +module File_set = Set.Make (String) + +type package = { + generic_jsx_module: string option; + suffix: string; + root_path: file_path; + project_files: File_set.t; + dependencies_files: File_set.t; + paths_for_module: (file, paths) Hashtbl.t; + namespace: string option; + opens: path list; + rescript_version: int * int; + autocomplete: file list Misc.String_map.t; +} + +let all_files_in_package package = + File_set.union package.project_files package.dependencies_files + +type full = {extra: extra; file: File.t; package: package} + +let init_extra () = + { + internal_references = Hashtbl.create 10; + external_references = Hashtbl.create 10; + file_references = Hashtbl.create 10; + loc_items = []; + } + +type state = { + packages_by_root: (string, package) Hashtbl.t; + root_for_uri: (Uri.t, string) Hashtbl.t; + cmt_cache: (file_path, File.t) Hashtbl.t; +} + +(* There's only one state, so it can as well be global *) +let state = + { + packages_by_root = Hashtbl.create 1; + root_for_uri = Hashtbl.create 30; + cmt_cache = Hashtbl.create 30; + } + +let loc_kind_to_string = function + | LocalReference (_, tip) -> "(LocalReference " ^ Tip.to_string tip ^ ")" + | GlobalReference _ -> "GlobalReference" + | NotFound -> "NotFound" + | Definition (_, tip) -> "(Definition " ^ Tip.to_string tip ^ ")" + +let loc_type_to_string = function + | Typed (name, e, loc_kind) -> + "Typed " ^ name ^ " " ^ Shared.type_to_string e ^ " " + ^ loc_kind_to_string loc_kind + | Constant _ -> "Constant" + | LModule loc_kind -> "LModule " ^ loc_kind_to_string loc_kind + | TopLevelModule _ -> "TopLevelModule" + | TypeDefinition _ -> "TypeDefinition" + +let loc_item_to_string {loc = {Location.loc_start; loc_end}; loc_type} = + let pos1 = Utils.cmt_pos_to_position loc_start in + let pos2 = Utils.cmt_pos_to_position loc_end in + Printf.sprintf "%d:%d-%d:%d %s" pos1.line pos1.character pos2.line + pos2.character + (loc_type_to_string loc_type) + +(* needed for debugging *) +let _ = loc_item_to_string + +module Completable = struct + (* Completion context *) + type completion_context = Type | Value | Module | Field | ValueOrField + + type argument_label = + | Unlabelled of {argument_position: int} + | Labelled of string + | Optional of string + + (** Additional context for nested completion where needed. *) + type nested_context = + | RecordField of {seen_fields: string list} + (** Completing for a record field, and we already saw the following fields... *) + | CameFromRecordField of string + (** We just came from this field (we leverage use this for better + completion names etc) *) + + type nested_path = + | NTupleItem of {item_num: int} + | NFollowRecordField of {field_name: string} + | NRecordBody of {seen_fields: string list} + | NVariantPayload of {constructor_name: string; item_num: int} + | NPolyvariantPayload of {constructor_name: string; item_num: int} + | NArray + + let nested_path_to_string p = + match p with + | NTupleItem {item_num} -> "tuple($" ^ string_of_int item_num ^ ")" + | NFollowRecordField {field_name} -> "recordField(" ^ field_name ^ ")" + | NRecordBody _ -> "recordBody" + | NVariantPayload {constructor_name; item_num} -> + "variantPayload::" ^ constructor_name ^ "($" ^ string_of_int item_num + ^ ")" + | NPolyvariantPayload {constructor_name; item_num} -> + "polyvariantPayload::" ^ constructor_name ^ "($" ^ string_of_int item_num + ^ ")" + | NArray -> "array" + + type context_path = + | CPString + | CPArray of context_path option + | CPInt + | CPFloat + | CPBool + | CPOption of context_path + | CPApply of context_path * Asttypes.arg_label list + | CPId of { + path: string list; + completion_context: completion_context; + loc: Location.t; + } + | CPField of { + context_path: context_path; + field_name: string; + pos_of_dot: (int * int) option; + expr_loc: Location.t; + in_jsx: bool; + (** Whether this field access was found in a JSX context. *) + } + | CPObj of context_path * string + | CPAwait of context_path + | CPPipe of { + synthetic: bool; (** Whether this pipe completion is synthetic. *) + context_path: context_path; + id: string; + in_jsx: bool; (** Whether this pipe was found in a JSX context. *) + lhs_loc: Location.t; + (** The loc item for the left hand side of the pipe. *) + } + | CTuple of context_path list + | CArgument of { + function_context_path: context_path; + argument_label: argument_label; + } + | CJsxPropValue of { + path_to_component: string list; + prop_name: string; + empty_jsx_prop_name_hint: string option; + (* This helps handle a special case in JSX prop completion. More info where this is used. *) + } + | CPatternPath of {root_ctx_path: context_path; nested: nested_path list} + | CTypeAtPos of Location.t + (** A position holding something that might have a *compiled* type. *) + + type pattern_mode = Default | Destructuring + + type decorator_payload = + | Module of string + | ModuleWithImportAttributes of {nested: nested_path list; prefix: string} + | JsxConfig of {nested: nested_path list; prefix: string} + + type t = + | Cdecorator of string (** e.g. @module *) + | CdecoratorPayload of decorator_payload + | CextensionNode of string (** e.g. %todo *) + | CnamedArg of context_path * string * string list + (** e.g. (..., "label", ["l1", "l2"]) for ...(...~l1...~l2...~label...) *) + | Cnone (** e.g. don't complete inside strings *) + | Cpath of context_path + | Cjsx of string list * string * string list + (** E.g. (["M", "Comp"], "id", ["id1", "id2"]) for "Value" + | Type -> "Type" + | Module -> "Module" + | Field -> "Field" + | ValueOrField -> "ValueOrField" + + let rec context_path_to_string = function + | CPString -> "string" + | CPInt -> "int" + | CPFloat -> "float" + | CPBool -> "bool" + | CPAwait ctx_path -> "await " ^ context_path_to_string ctx_path + | CPOption ctx_path -> "option<" ^ context_path_to_string ctx_path ^ ">" + | CPApply (cp, labels) -> + context_path_to_string cp ^ "(" + ^ (labels + |> List.map (function + | Asttypes.Nolabel -> "Nolabel" + | Labelled {txt} -> "~" ^ txt + | Optional {txt} -> "?" ^ txt) + |> String.concat ", ") + ^ ")" + | CPArray (Some ctx_path) -> + "array<" ^ context_path_to_string ctx_path ^ ">" + | CPArray None -> "array" + | CPId {path; completion_context} -> + completion_context_to_string completion_context ^ list path + | CPField {context_path = cp; field_name = s} -> + context_path_to_string cp ^ "." ^ str s + | CPObj (cp, s) -> context_path_to_string cp ^ "[\"" ^ s ^ "\"]" + | CPPipe {context_path; id; in_jsx} -> + context_path_to_string context_path + ^ "->" ^ id + ^ if in_jsx then " <>" else "" + | CTuple ctx_paths -> + "CTuple(" + ^ (ctx_paths |> List.map context_path_to_string |> String.concat ", ") + ^ ")" + | CArgument {function_context_path; argument_label} -> + "CArgument " + ^ context_path_to_string function_context_path + ^ "(" + ^ (match argument_label with + | Unlabelled {argument_position} -> + "$" ^ string_of_int argument_position + | Labelled name -> "~" ^ name + | Optional name -> "~" ^ name ^ "=?") + ^ ")" + | CJsxPropValue {path_to_component; prop_name} -> + "CJsxPropValue " ^ (path_to_component |> list) ^ " " ^ prop_name + | CPatternPath {root_ctx_path; nested} -> + "CPatternPath(" + ^ context_path_to_string root_ctx_path + ^ ")" ^ "->" + ^ (nested + |> List.map (fun nested_path -> nested_path_to_string nested_path) + |> String.concat "->") + | CTypeAtPos _loc -> "CTypeAtPos()" + + let to_string = function + | Cpath cp -> "Cpath " ^ context_path_to_string cp + | Cdecorator s -> "Cdecorator(" ^ str s ^ ")" + | CextensionNode s -> "CextensionNode(" ^ str s ^ ")" + | CdecoratorPayload (Module s) -> "CdecoratorPayload(module=" ^ s ^ ")" + | CdecoratorPayload (ModuleWithImportAttributes _) -> + "CdecoratorPayload(moduleWithImportAttributes)" + | CdecoratorPayload (JsxConfig _) -> "JsxConfig" + | CnamedArg (cp, s, sl2) -> + "CnamedArg(" + ^ (cp |> context_path_to_string) + ^ ", " ^ str s ^ ", " ^ (sl2 |> list) ^ ")" + | Cnone -> "Cnone" + | Cjsx (sl1, s, sl2) -> + "Cjsx(" ^ (sl1 |> list) ^ ", " ^ str s ^ ", " ^ (sl2 |> list) ^ ")" + | Cpattern {context_path; nested; prefix} -> ( + "Cpattern " + ^ context_path_to_string context_path + ^ (if prefix = "" then "" else "=" ^ prefix) + ^ + match nested with + | [] -> "" + | nested_paths -> + "->" + ^ (nested_paths + |> List.map (fun nested_path -> nested_path_to_string nested_path) + |> String.concat ", ")) + | Cexpression {context_path; nested; prefix} -> ( + "Cexpression " + ^ context_path_to_string context_path + ^ (if prefix = "" then "" else "=" ^ prefix) + ^ + match nested with + | [] -> "" + | nested_paths -> + "->" + ^ (nested_paths + |> List.map (fun nested_path -> nested_path_to_string nested_path) + |> String.concat ", ")) + | CexhaustiveSwitch {context_path} -> + "CexhaustiveSwitch " ^ context_path_to_string context_path + | ChtmlElement {prefix} -> "ChtmlElement <" ^ prefix +end + +module Scope_types = struct + type item = + | Constructor of string * Location.t + | Field of string * Location.t + | Module of string * Location.t + | Open of string list + | Type of string * Location.t + | Value of string * Location.t * Completable.context_path option * item list + | Include of string * Location.t + + let item_to_string = function + | Constructor (name, loc) -> + "Constructor " ^ name ^ " " ^ Warnings.loc_to_string loc + | Field (name, loc) -> "Field " ^ name ^ " " ^ Warnings.loc_to_string loc + | Module (name, loc) -> "Module " ^ name ^ " " ^ Warnings.loc_to_string loc + | Open path -> "Open " ^ (path |> String.concat ".") + | Type (name, loc) -> "Type " ^ name ^ " " ^ Warnings.loc_to_string loc + | Value (name, loc, _, _) -> + "Value " ^ name ^ " " ^ Warnings.loc_to_string loc + | Include (name, loc) -> + "Include " ^ name ^ " " ^ Warnings.loc_to_string loc +end + +module Completion = struct + type kind = + | Module of {docstring: string list; module_: Module.t} + | Value of Types.type_expr + | ObjLabel of Types.type_expr + | Label of string + | Type of Type.t + | Constructor of Constructor.t * string + | PolyvariantConstructor of poly_variant_constructor * string + | Field of field * string + | FileModule of string + | Snippet of string + | ExtractedType of completion_type * [`Value | `Type] + | FollowContextPath of Completable.context_path * Scope_types.item list + + type t = { + name: string; + sort_text: string option; + insert_text: string option; + filter_text: string option; + insert_text_format: Lsp.Types.InsertTextFormat.t option; + env: Query_env.t; + deprecated: string option; + docstring: string list; + kind: kind; + detail: string option; + type_arg_context: type_arg_context option; + data: (string * string) list option; + additional_text_edits: Lsp.Types.TextEdit.t list option; + synthetic: bool; + (** Whether this item is an made up, synthetic item or not. *) + } + + let create ?(synthetic = false) ?additional_text_edits ?data ?type_arg_context + ?(includes_snippets = false) ?insert_text ~kind ~env ?sort_text + ?deprecated ?filter_text ?detail ?(docstring = []) name = + { + name; + env; + deprecated; + docstring; + kind; + sort_text; + insert_text; + insert_text_format = + (if includes_snippets then Some Lsp.Types.InsertTextFormat.Snippet + else None); + filter_text; + detail; + type_arg_context; + data; + additional_text_edits; + synthetic; + } + + (* https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_completion *) + (* https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#completionItemKind *) + let kind_to_lsp_completion_item kind = + match kind with + | Module _ -> Lsp.Types.CompletionItemKind.Module + | FileModule _ -> Lsp.Types.CompletionItemKind.Module + | Constructor (_, _) | PolyvariantConstructor (_, _) -> + Lsp.Types.CompletionItemKind.Constructor + | ObjLabel _ -> Lsp.Types.CompletionItemKind.Constructor + | Label _ -> Lsp.Types.CompletionItemKind.Constructor + | Field (_, _) -> Lsp.Types.CompletionItemKind.Field + | Type _ | ExtractedType (_, `Type) -> Lsp.Types.CompletionItemKind.Struct + | Value _ | ExtractedType (_, `Value) -> Lsp.Types.CompletionItemKind.Value + | Snippet _ | FollowContextPath _ -> Lsp.Types.CompletionItemKind.Snippet +end + +let kind_from_inner_type (t : inner_type) = + match t with + | ExtractedType extracted_type -> + Completion.ExtractedType (extracted_type, `Value) + | TypeExpr typ -> Value typ + +module Cursor_position = struct + type t = NoCursor | HasCursor | EmptyLoc + + let classify_loc loc ~pos = + if loc |> Loc.has_pos ~pos then HasCursor + else if loc |> Loc.end_ = (Location.none |> Loc.end_) then EmptyLoc + else NoCursor + + let classify_location_loc (loc : 'a Location.loc) ~pos = + if Loc.start loc.Location.loc <= pos && pos <= Loc.end_ loc.loc then + HasCursor + else if loc.loc |> Loc.end_ = (Location.none |> Loc.end_) then EmptyLoc + else NoCursor + + let classify_positions pos ~pos_start ~pos_end = + if pos_start <= pos && pos <= pos_end then HasCursor + else if pos_end = (Location.none |> Loc.end_) then EmptyLoc + else NoCursor + + let loc_has_cursor loc ~pos = loc |> classify_loc ~pos = HasCursor + + let loc_is_empty loc ~pos = loc |> classify_loc ~pos = EmptyLoc +end + +type labelled = { + name: string; + opt: bool; + pos_start: int * int; + pos_end: int * int; +} + +type label = labelled option +type arg = {label: label; exp: Parsetree.expression} + +let extract_exp_apply_args ~args = + let rec process_args ~acc args = + match args with + | ( ((Asttypes.Labelled {txt = s; loc} | Optional {txt = s; loc}) as label), + (e : Parsetree.expression) ) + :: rest -> ( + let named_arg_loc = if loc = Location.none then None else Some loc in + match named_arg_loc with + | Some loc -> + let labelled = + { + name = s; + opt = + (match label with + | Optional _ -> true + | _ -> false); + pos_start = Loc.start loc; + pos_end = Loc.end_ loc; + } + in + process_args ~acc:({label = Some labelled; exp = e} :: acc) rest + | None -> process_args ~acc rest) + | (Nolabel, (e : Parsetree.expression)) :: rest -> + if e.pexp_loc.loc_ghost then process_args ~acc rest + else process_args ~acc:({label = None; exp = e} :: acc) rest + | [] -> List.rev acc + in + args |> process_args ~acc:[] diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/signature_help.ml similarity index 59% rename from analysis/src/SignatureHelp.ml rename to analysis/src/signature_help.ml index 27a53a0ccbb..75ca8897df9 100644 --- a/analysis/src/SignatureHelp.ml +++ b/analysis/src/signature_help.ml @@ -1,61 +1,61 @@ -open SharedTypes -type cursorAtArg = Unlabelled of int | Labelled of string +open Shared_types +type cursor_at_arg = Unlabelled of int | Labelled of string (* Produces the doc string shown below the signature help for each parameter. *) -let docsForLabel typeExpr ~file ~package ~supportsMarkdownLinks = - let types = Hover.findRelevantTypesFromType ~file ~package typeExpr in - let typeNames = types |> List.map (fun {Hover.name} -> name) in - let typeDefinitions = +let docs_for_label type_expr ~file ~package ~supports_markdown_links = + let types = Hover.find_relevant_types_from_type ~file ~package type_expr in + let type_names = types |> List.map (fun {Hover.name} -> name) in + let type_definitions = types |> List.map (fun {Hover.decl; name; env; loc; path} -> - let linkToTypeDefinitionStr = - if supportsMarkdownLinks then - Markdown.goToDefinitionText ~env ~pos:loc.Warnings.loc_start + let link_to_type_definition_str = + if supports_markdown_links then + Markdown.go_to_definition_text ~env ~pos:loc.Warnings.loc_start else "" in (* Since printing the whole name via its path can get quite long, and we're short on space for the signature help, we'll only print the fully "qualified" type name if we must (ie if several types we're displaying have the same name). *) - let multipleTypesHaveThisName = - typeNames - |> List.filter (fun typeName -> typeName = name) + let multiple_types_have_this_name = + type_names + |> List.filter (fun type_name -> type_name = name) |> List.length > 1 in - let typeName = - if multipleTypesHaveThisName then - path |> SharedTypes.pathIdentToString + let type_name = + if multiple_types_have_this_name then + path |> Shared_types.path_ident_to_string else name in - Markdown.codeBlock - (Shared.declToString ~printNameAsIs:true typeName decl) - ^ linkToTypeDefinitionStr) + Markdown.code_block + (Shared.decl_to_string ~print_name_as_is:true type_name decl) + ^ link_to_type_definition_str) in - typeDefinitions |> String.concat "\n" + type_definitions |> String.concat "\n" -let findFunctionType ~debug ~source ~kindFile ~pos ~full = +let find_function_type ~debug ~source ~kind_file ~pos ~full = (* Start by looking at the typed info at the loc of the fn *) match full with | None -> None | Some full -> ( let {file; package} = full in - let env = QueryEnv.fromFile file in - let fnFromLocItem = - match References.getLocItem ~full ~pos ~debug:false with - | Some {locType = Typed (_, typeExpr, locKind)} -> ( + let env = Query_env.from_file file in + let fn_from_loc_item = + match References.get_loc_item ~full ~pos ~debug:false with + | Some {loc_type = Typed (_, type_expr, loc_kind)} -> ( let docstring = - match References.definedForLoc ~file ~package locKind with + match References.defined_for_loc ~file ~package loc_kind with | None -> [] | Some (docstring, _) -> docstring in if Debug.verbose () then Printf.printf "[sig_help_fn] Found loc item: %s.\n" - (Shared.typeToString typeExpr); + (Shared.type_to_string type_expr); match - TypeUtils.extractFunctionType2 ~env ~package:full.package typeExpr + Type_utils.extract_function_type2 ~env ~package:full.package type_expr with | args, _tRet, _ when args <> [] -> - Some (args, docstring, typeExpr, package, env, file) + Some (args, docstring, type_expr, package, env, file) | _ -> None) | None -> if Debug.verbose () then @@ -67,8 +67,8 @@ let findFunctionType ~debug ~source ~kindFile ~pos ~full = "[sig_help_fn] Found loc item, but not what was expected.\n"; None in - match fnFromLocItem with - | Some fnFromLocItem -> Some fnFromLocItem + match fn_from_loc_item with + | Some fn_from_loc_item -> Some fn_from_loc_item | None -> ( (* If nothing was found there, try using the unsaved completion engine *) let completables = @@ -79,15 +79,15 @@ let findFunctionType ~debug ~source ~kindFile ~pos ~full = This lets us leverage all of the smart work done in completions to find the correct type in many cases even for files not saved yet. *) match - CompletionFrontEnd.completionWithParser ~debug ~source ~kindFile - ~posCursor:pos + Completion_front_end.completion_with_parser ~debug ~source + ~kind_file ~pos_cursor:pos with | None -> None | Some (completable, scope) -> Some ( completable - |> CompletionBackEnd.processCompletable ~debug ~full ~pos ~scope - ~env ~forHover:true, + |> Completion_back_end.process_completable ~debug ~full ~pos + ~scope ~env ~for_hover:true, env, package, file )) @@ -95,70 +95,70 @@ let findFunctionType ~debug ~source ~kindFile ~pos ~full = match completables with | Some ({kind = Value type_expr; docstring} :: _, env, package, file) -> let args, _, _ = - TypeUtils.extractFunctionType2 type_expr ~env ~package + Type_utils.extract_function_type2 type_expr ~env ~package in Some (args, docstring, type_expr, package, env, file) | _ -> None)) (* Extracts all parameters from a parsed function signature *) -let extractParameters ~signature ~typeStrForParser ~labelPrefixLen = +let extract_parameters ~signature ~type_str_for_parser ~label_prefix_len = match signature with | [{Parsetree.psig_desc = Psig_value {pval_type = expr}}] when match expr.ptyp_desc with | Ptyp_arrow _ -> true | _ -> false -> - let rec extractParams expr params = + let rec extract_params expr params = match expr with | { (* Gotcha: functions with multiple arugments are modelled as a series of single argument functions. *) - Parsetree.ptyp_desc = Ptyp_arrow {arg; ret = nextFunctionExpr}; + Parsetree.ptyp_desc = Ptyp_arrow {arg; ret = next_function_expr}; ptyp_loc; } -> - let startOffset = + let start_offset = ptyp_loc |> Loc.start - |> Pos.positionToOffset typeStrForParser + |> Pos.position_to_offset type_str_for_parser |> Option.get in - let endOffset = + let end_offset = arg.typ.ptyp_loc |> Loc.end_ - |> Pos.positionToOffset typeStrForParser + |> Pos.position_to_offset type_str_for_parser |> Option.get in (* The AST locations does not account for "=?" of optional arguments, so add that to the offset here if needed. *) - let endOffset = + let end_offset = match arg.lbl with - | Asttypes.Optional _ -> endOffset + 2 - | _ -> endOffset + | Asttypes.Optional _ -> end_offset + 2 + | _ -> end_offset in - extractParams nextFunctionExpr + extract_params next_function_expr (params @ [ ( arg.lbl, (* Remove the label prefix offset here, since we're not showing that to the end user. *) - startOffset - labelPrefixLen, - endOffset - labelPrefixLen ); + start_offset - label_prefix_len, + end_offset - label_prefix_len ); ]) | _ -> params in - extractParams expr [] + extract_params expr [] | _ -> [] (* Finds what parameter is active, if any *) -let findActiveParameter ~argAtCursor ~args = - match argAtCursor with +let find_active_parameter ~arg_at_cursor ~args = + match arg_at_cursor with | None -> ( (* If a function only has one, unlabelled argument, we can safely assume that's active whenever we're in the signature help for that function, even if we technically didn't find anything at the cursor (which we don't for empty expressions). *) match args with | [(Asttypes.Nolabel, _)] -> Some 0 | _ -> None) - | Some (Unlabelled unlabelledArgumentIndex) -> + | Some (Unlabelled unlabelled_argument_index) -> let index = ref 0 in args |> List.find_map (fun (label, _) -> match label with - | Asttypes.Nolabel when !index = unlabelledArgumentIndex -> + | Asttypes.Nolabel when !index = unlabelled_argument_index -> Some !index | _ -> index := !index + 1; @@ -168,53 +168,53 @@ let findActiveParameter ~argAtCursor ~args = args |> List.find_map (fun (label, _) -> match label with - | (Asttypes.Labelled {txt = labelName} | Optional {txt = labelName}) - when labelName = name -> + | (Asttypes.Labelled {txt = label_name} | Optional {txt = label_name}) + when label_name = name -> Some !index | _ -> index := !index + 1; None) -type constructorInfo = { +type constructor_info = { docstring: string list; name: string; - args: constructorArgs; + args: constructor_args; } -let findConstructorArgs ~full ~env ~constructorName loc = +let find_constructor_args ~full ~env ~constructor_name loc = match - References.getLocItem ~debug:false ~full - ~pos:(Pos.ofLexing loc.Location.loc_end) + References.get_loc_item ~debug:false ~full + ~pos:(Pos.of_lexing loc.Location.loc_end) with | None -> None - | Some {locType = Typed (_, typExpr, _)} -> ( - match TypeUtils.extractType ~env ~package:full.package typExpr with - | Some ((Toption (_, TypeExpr t) as extractedType), _) -> ( - match constructorName with + | Some {loc_type = Typed (_, typ_expr, _)} -> ( + match Type_utils.extract_type ~env ~package:full.package typ_expr with + | Some ((Toption (_, TypeExpr t) as extracted_type), _) -> ( + match constructor_name with | "Some" -> Some { name = "Some"; docstring = [ - Markdown.codeBlock - (TypeUtils.extractedTypeToString extractedType); + Markdown.code_block + (Type_utils.extracted_type_to_string extracted_type); ]; args = Args [(t, Location.none)]; } | _ -> None) - | Some ((Tresult {okType; errorType} as extractedType), _) -> ( - match constructorName with + | Some ((Tresult {ok_type; error_type} as extracted_type), _) -> ( + match constructor_name with | "Ok" -> Some { name = "Ok"; docstring = [ - Markdown.codeBlock - (TypeUtils.extractedTypeToString extractedType); + Markdown.code_block + (Type_utils.extracted_type_to_string extracted_type); ]; - args = Args [(okType, Location.none)]; + args = Args [(ok_type, Location.none)]; } | "Error" -> Some @@ -222,49 +222,49 @@ let findConstructorArgs ~full ~env ~constructorName loc = name = "Error"; docstring = [ - Markdown.codeBlock - (TypeUtils.extractedTypeToString extractedType); + Markdown.code_block + (Type_utils.extracted_type_to_string extracted_type); ]; - args = Args [(errorType, Location.none)]; + args = Args [(error_type, Location.none)]; } | _ -> None) | Some (Tvariant {constructors}, _) -> constructors |> List.find_opt (fun (c : Constructor.t) -> - c.cname.txt = constructorName) + c.cname.txt = constructor_name) |> Option.map (fun (c : Constructor.t) -> {docstring = c.docstring; name = c.cname.txt; args = c.args}) | _ -> None) | _ -> None -let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads - ~full = +let signature_help ~debug ~source ~kind_file ~pos + ~allow_for_constructor_payloads ~full = match source with | "" -> None | text -> ( - match Pos.positionToOffset text pos with + match Pos.position_to_offset text pos with | None -> None | Some offset -> ( - let posBeforeCursor = Pos.posBeforeCursor pos in - let offsetNoWhite = Utils.skipWhite text (offset - 1) in - let firstCharBeforeCursorNoWhite = - if offsetNoWhite < String.length text && offsetNoWhite >= 0 then - Some text.[offsetNoWhite] + let pos_before_cursor = Pos.pos_before_cursor pos in + let offset_no_white = Utils.skip_white text (offset - 1) in + let first_char_before_cursor_no_white = + if offset_no_white < String.length text && offset_no_white >= 0 then + Some text.[offset_no_white] else None in - let locHasCursor loc = - loc |> CursorPosition.locHasCursor ~pos:posBeforeCursor + let loc_has_cursor loc = + loc |> Cursor_position.loc_has_cursor ~pos:pos_before_cursor in - let supportsMarkdownLinks = true in + let supports_markdown_links = true in let result = ref None in - let printThing thg = + let print_thing thg = match thg with | `ConstructorExpr _ -> "Constructor(expr)" | `ConstructorPat _ -> "Constructor(pat)" | `FunctionCall _ -> "FunctionCall" in - let setResult (loc, thing) = - match (thing, allowForConstructorPayloads) with + let set_result (loc, thing) = + match (thing, allow_for_constructor_payloads) with | (`ConstructorExpr _ | `ConstructorPat _), false -> () | _ -> ( match !result with @@ -272,52 +272,55 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads if Debug.verbose () then Printf.printf "[sig_help_result] Setting because had none\n"; result := Some (loc, thing) - | Some (currentLoc, currentThing) - when Pos.ofLexing loc.Location.loc_start - > Pos.ofLexing currentLoc.Location.loc_start -> + | Some (current_loc, current_thing) + when Pos.of_lexing loc.Location.loc_start + > Pos.of_lexing current_loc.Location.loc_start -> result := Some (loc, thing); if Debug.verbose () then Printf.printf "[sig_help_result] Setting because loc of %s > then existing \ of %s\n" - (printThing thing) (printThing currentThing) - | Some (_, currentThing) -> + (print_thing thing) + (print_thing current_thing) + | Some (_, current_thing) -> if Debug.verbose () then Printf.printf "[sig_help_result] Doing nothing because loc of %s < then \ existing of %s\n" - (printThing thing) (printThing currentThing)) + (print_thing thing) + (print_thing current_thing)) in - let searchForArgWithCursor ~isPipeExpr ~args = - let extractedArgs = extractExpApplyArgs ~args in - let argAtCursor = - let firstArgIndex = if isPipeExpr then 1 else 0 in - let unlabelledArgCount = ref firstArgIndex in - let lastUnlabelledArgBeforeCursor = ref firstArgIndex in + let search_for_arg_with_cursor ~is_pipe_expr ~args = + let extracted_args = extract_exp_apply_args ~args in + let arg_at_cursor = + let first_arg_index = if is_pipe_expr then 1 else 0 in + let unlabelled_arg_count = ref first_arg_index in + let last_unlabelled_arg_before_cursor = ref first_arg_index in let argAtCursor_ = - extractedArgs + extracted_args |> List.find_map (fun arg -> match arg.label with | None -> - let currentUnlabelledArgCount = !unlabelledArgCount in - unlabelledArgCount := currentUnlabelledArgCount + 1; + let current_unlabelled_arg_count = !unlabelled_arg_count in + unlabelled_arg_count := current_unlabelled_arg_count + 1; (* An argument without a label is just the expression, so we can use that. *) - if locHasCursor arg.exp.pexp_loc then - Some (Unlabelled currentUnlabelledArgCount) + if loc_has_cursor arg.exp.pexp_loc then + Some (Unlabelled current_unlabelled_arg_count) else ( (* If this unlabelled arg doesn't have the cursor, record it as the last seen unlabelled arg before the cursor.*) - if posBeforeCursor >= (arg.exp.pexp_loc |> Loc.start) + if pos_before_cursor >= (arg.exp.pexp_loc |> Loc.start) then - lastUnlabelledArgBeforeCursor := - currentUnlabelledArgCount; + last_unlabelled_arg_before_cursor := + current_unlabelled_arg_count; None) - | Some {name; posStart; posEnd} -> ( + | Some {name; pos_start; pos_end} -> ( (* Check for the label identifier itself having the cursor *) match - pos |> CursorPosition.classifyPositions ~posStart ~posEnd + pos + |> Cursor_position.classify_positions ~pos_start ~pos_end with | HasCursor -> Some (Labelled name) | NoCursor | EmptyLoc -> ( @@ -328,7 +331,8 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads match ( arg.exp.pexp_desc, arg.exp.pexp_loc - |> CursorPosition.classifyLoc ~pos:posBeforeCursor ) + |> Cursor_position.classify_loc + ~pos:pos_before_cursor ) with | Pexp_extension ({txt = "rescript.exprhole"}, _), _ | _, HasCursor -> @@ -340,9 +344,9 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads | None -> Some (Unlabelled - (!lastUnlabelledArgBeforeCursor + (!last_unlabelled_arg_before_cursor + - if firstCharBeforeCursorNoWhite = Some ',' then 1 + if first_char_before_cursor_no_white = Some ',' then 1 (* If we found no argument with the cursor, we might still be able to complete for an unlabelled argument, if the char before the cursor is ',', like: `someFn(123, )` @@ -353,7 +357,7 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads else 0)) | v -> v in - (argAtCursor, extractedArgs) + (arg_at_cursor, extracted_args) in let expr (iterator : Ast_iterator.iterator) (expr : Parsetree.expression) = @@ -377,39 +381,39 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads ]; }; } - when locHasCursor pexp_loc -> - let argAtCursor, extractedArgs = - searchForArgWithCursor ~isPipeExpr:true ~args + when loc_has_cursor pexp_loc -> + let arg_at_cursor, extracted_args = + search_for_arg_with_cursor ~is_pipe_expr:true ~args in - setResult - (exp.pexp_loc, `FunctionCall (argAtCursor, exp, extractedArgs)) + set_result + (exp.pexp_loc, `FunctionCall (arg_at_cursor, exp, extracted_args)) (* Look for applying idents, like someIdent(...) *) | { pexp_desc = Pexp_apply {funct = {pexp_desc = Pexp_ident _} as exp; args}; pexp_loc; } - when locHasCursor pexp_loc -> - let argAtCursor, extractedArgs = - searchForArgWithCursor ~isPipeExpr:false ~args + when loc_has_cursor pexp_loc -> + let arg_at_cursor, extracted_args = + search_for_arg_with_cursor ~is_pipe_expr:false ~args in - setResult - (exp.pexp_loc, `FunctionCall (argAtCursor, exp, extractedArgs)) - | {pexp_desc = Pexp_construct (lid, Some payloadExp); pexp_loc} - when locHasCursor payloadExp.pexp_loc - || CompletionExpressions.isExprHole payloadExp - && locHasCursor pexp_loc -> + set_result + (exp.pexp_loc, `FunctionCall (arg_at_cursor, exp, extracted_args)) + | {pexp_desc = Pexp_construct (lid, Some payload_exp); pexp_loc} + when loc_has_cursor payload_exp.pexp_loc + || Completion_expressions.is_expr_hole payload_exp + && loc_has_cursor pexp_loc -> (* Constructor payloads *) - setResult (lid.loc, `ConstructorExpr (lid, payloadExp)) + set_result (lid.loc, `ConstructorExpr (lid, payload_exp)) | _ -> ()); Ast_iterator.default_iterator.expr iterator expr in let pat (iterator : Ast_iterator.iterator) (pat : Parsetree.pattern) = (match pat with - | {ppat_desc = Ppat_construct (lid, Some payloadPat)} - when locHasCursor payloadPat.ppat_loc -> + | {ppat_desc = Ppat_construct (lid, Some payload_pat)} + when loc_has_cursor payload_pat.ppat_loc -> (* Constructor payloads *) - setResult (lid.loc, `ConstructorPat (lid, payloadPat)) + set_result (lid.loc, `ConstructorPat (lid, payload_pat)) | _ -> ()); Ast_iterator.default_iterator.pat iterator pat in @@ -422,14 +426,14 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads iterator.structure iterator structure |> ignore; (* Handle function application, if found *) match !result with - | Some (_, `FunctionCall (argAtCursor, exp, _extractedArgs)) -> ( + | Some (_, `FunctionCall (arg_at_cursor, exp, _extractedArgs)) -> ( (* Not looking for the cursor position after this, but rather the target function expression's loc. *) let pos = exp.pexp_loc |> Loc.end_ in - match findFunctionType ~source ~kindFile ~debug ~pos ~full with + match find_function_type ~source ~kind_file ~debug ~pos ~full with | Some (args, docstring, type_expr, package, _env, file) -> if debug then Printf.printf "argAtCursor: %s\n" - (match argAtCursor with + (match arg_at_cursor with | None -> "none" | Some (Labelled name) -> "~" ^ name | Some (Unlabelled index) -> @@ -440,42 +444,42 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads offsets from the parser. *) (* A full let binding with the type text is needed for the parser to be able to parse it. *) - let labelPrefix = "let fn: " in - let labelPrefixLen = String.length labelPrefix in - let fnTypeStr = Shared.typeToString type_expr in - let typeStrForParser = labelPrefix ^ fnTypeStr in + let label_prefix = "let fn: " in + let label_prefix_len = String.length label_prefix in + let fn_type_str = Shared.type_to_string type_expr in + let type_str_for_parser = label_prefix ^ fn_type_str in let {Res_driver.parsetree = signature} = Res_driver.parse_interface_from_source ~for_printer:false - ~display_filename:"" ~source:typeStrForParser + ~display_filename:"" ~source:type_str_for_parser in let parameters = - extractParameters ~signature ~typeStrForParser ~labelPrefixLen + extract_parameters ~signature ~type_str_for_parser ~label_prefix_len in if debug then Printf.printf "extracted params: \n%s\n" (parameters |> List.map (fun (_, start, end_) -> - String.sub fnTypeStr start (end_ - start)) + String.sub fn_type_str start (end_ - start)) |> list); (* Figure out the active parameter *) - let activeParameter = findActiveParameter ~argAtCursor ~args in + let active_parameter = find_active_parameter ~arg_at_cursor ~args in - let paramUnlabelledArgCount = ref 0 in - let parametersInformation = + let param_unlabelled_arg_count = ref 0 in + let parameters_information = parameters - |> List.map (fun (argLabel, start, end_) -> - let paramArgCount = !paramUnlabelledArgCount in - paramUnlabelledArgCount := paramArgCount + 1; - let unlabelledArgCount = ref 0 in + |> List.map (fun (arg_label, start, end_) -> + let param_arg_count = !param_unlabelled_arg_count in + param_unlabelled_arg_count := param_arg_count + 1; + let unlabelled_arg_count = ref 0 in let documentation = match args |> List.find_opt (fun (lbl, _) -> - let argCount = !unlabelledArgCount in - unlabelledArgCount := argCount + 1; - match (lbl, argLabel) with + let arg_count = !unlabelled_arg_count in + unlabelled_arg_count := arg_count + 1; + match (lbl, arg_label) with | ( Asttypes.Optional {txt = l1}, Asttypes.Optional {txt = l2} ) when l1 = l2 -> @@ -483,28 +487,28 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads | Labelled {txt = l1}, Labelled {txt = l2} when l1 = l2 -> true - | Nolabel, Nolabel when paramArgCount = argCount - -> + | Nolabel, Nolabel + when param_arg_count = arg_count -> true | _ -> false) with | None -> Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown ~value:"" - | Some (_, labelTypExpr) -> + | Some (_, label_typ_expr) -> Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown ~value: - (docsForLabel ~supportsMarkdownLinks ~file ~package - labelTypExpr) + (docs_for_label ~supports_markdown_links ~file + ~package label_typ_expr) in Lsp.Types.ParameterInformation.create ~label:(`Offset (start, end_)) ~documentation:(`MarkupContent documentation) ()) in let signatures = - Lsp.Types.SignatureInformation.create ~label:fnTypeStr - ~parameters:parametersInformation + Lsp.Types.SignatureInformation.create ~label:fn_type_str + ~parameters:parameters_information ?documentation: (match List.nth_opt docstring 0 with | None -> None @@ -514,17 +518,17 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads (Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown ~value:docs))) ~activeParameter: - (match activeParameter with + (match active_parameter with | None -> Some (-1) - | activeParameter -> activeParameter) + | active_parameter -> active_parameter) () in let signature = Lsp.Types.SignatureHelp.create ~signatures:[signatures] ~activeParameter: - (match activeParameter with + (match active_parameter with | None -> Some (-1) - | activeParameter -> activeParameter) + | active_parameter -> active_parameter) ~activeSignature:0 () in Some signature @@ -540,19 +544,19 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads None | Some full -> ( let {file} = full in - let env = QueryEnv.fromFile file in - let constructorName = Longident.last lid.txt in + let env = Query_env.from_file file in + let constructor_name = Longident.last lid.txt in match - findConstructorArgs ~full ~env ~constructorName + find_constructor_args ~full ~env ~constructor_name {lid.loc with loc_start = lid.loc.loc_end} with | None -> if Debug.verbose () then Printf.printf "[signature_help] Did not find constructor '%s'\n" - constructorName; + constructor_name; None | Some constructor -> - let argParts = + let arg_parts = match constructor.args with | Args [] -> None | InlineRecord fields -> @@ -561,77 +565,78 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads (`InlineRecord (fields |> List.map (fun (field : field) -> - let startOffset = !offset in - let argText = + let start_offset = !offset in + let arg_text = Printf.sprintf "%s%s: %s" field.fname.txt (if field.optional then "?" else "") - (Shared.typeToString + (Shared.type_to_string (if field.optional then - Utils.unwrapIfOption field.typ + Utils.unwrap_if_option field.typ else field.typ)) in - let endOffset = - startOffset + String.length argText + let end_offset = + start_offset + String.length arg_text in - offset := endOffset + String.length ", "; - (argText, field, (startOffset, endOffset))))) + offset := end_offset + String.length ", "; + (arg_text, field, (start_offset, end_offset))))) | Args [(typ, _)] -> Some (`SingleArg - ( typ |> Shared.typeToString, - docsForLabel ~file:full.file ~package:full.package - ~supportsMarkdownLinks typ )) + ( typ |> Shared.type_to_string, + docs_for_label ~file:full.file ~package:full.package + ~supports_markdown_links typ )) | Args args -> let offset = ref 0 in Some (`TupleArg (args |> List.map (fun (typ, _) -> - let startOffset = !offset in - let argText = typ |> Shared.typeToString in - let endOffset = - startOffset + String.length argText + let start_offset = !offset in + let arg_text = typ |> Shared.type_to_string in + let end_offset = + start_offset + String.length arg_text in - offset := endOffset + String.length ", "; - ( argText, - docsForLabel ~file:full.file ~package:full.package - ~supportsMarkdownLinks typ, - (startOffset, endOffset) )))) + offset := end_offset + String.length ", "; + ( arg_text, + docs_for_label ~file:full.file + ~package:full.package ~supports_markdown_links + typ, + (start_offset, end_offset) )))) in let label = constructor.name ^ "(" - ^ (match argParts with + ^ (match arg_parts with | None -> "" | Some (`InlineRecord fields) -> "{" ^ (fields - |> List.map (fun (argText, _, _) -> argText) + |> List.map (fun (arg_text, _, _) -> arg_text) |> String.concat ", ") ^ "}" | Some (`SingleArg (arg, _)) -> arg | Some (`TupleArg items) -> items - |> List.map (fun (argText, _, _) -> argText) + |> List.map (fun (arg_text, _, _) -> arg_text) |> String.concat ", ") ^ ")" in - let activeParameter = + let active_parameter = match cs with | `ConstructorExpr (_, {pexp_desc = Pexp_tuple items}) -> ( let idx = ref 0 in - let tupleItemWithCursor = + let tuple_item_with_cursor = items |> List.find_map (fun (item : Parsetree.expression) -> - let currentIndex = !idx in - idx := currentIndex + 1; - if locHasCursor item.pexp_loc then Some currentIndex + let current_index = !idx in + idx := current_index + 1; + if loc_has_cursor item.pexp_loc then Some current_index else None) in - match tupleItemWithCursor with + match tuple_item_with_cursor with | None -> -1 | Some i -> i) | `ConstructorExpr (_, {pexp_desc = Pexp_record (fields, _)}) -> ( - let fieldNameWithCursor = + let field_name_with_cursor = fields |> List.find_map (fun @@ -639,41 +644,42 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads Parsetree.expression Parsetree.record_element) -> if - posBeforeCursor >= Pos.ofLexing loc.loc_start - && posBeforeCursor - <= Pos.ofLexing expr.pexp_loc.loc_end + pos_before_cursor >= Pos.of_lexing loc.loc_start + && pos_before_cursor + <= Pos.of_lexing expr.pexp_loc.loc_end then Some (Longident.last txt) else None) in - match (fieldNameWithCursor, argParts) with - | Some fieldName, Some (`InlineRecord fields) -> + match (field_name_with_cursor, arg_parts) with + | Some field_name, Some (`InlineRecord fields) -> let idx = ref 0 in - let fieldIndex = ref (-1) in + let field_index = ref (-1) in fields |> List.iter (fun (_, field, _) -> idx := !idx + 1; - let currentIndex = !idx in - if fieldName = field.fname.txt then - fieldIndex := currentIndex + let current_index = !idx in + if field_name = field.fname.txt then + field_index := current_index else ()); - !fieldIndex + !field_index | _ -> -1) - | `ConstructorExpr (_, expr) when locHasCursor expr.pexp_loc -> 0 + | `ConstructorExpr (_, expr) when loc_has_cursor expr.pexp_loc -> + 0 | `ConstructorPat (_, {ppat_desc = Ppat_tuple items}) -> ( let idx = ref 0 in - let tupleItemWithCursor = + let tuple_item_with_cursor = items |> List.find_map (fun (item : Parsetree.pattern) -> - let currentIndex = !idx in - idx := currentIndex + 1; - if locHasCursor item.ppat_loc then Some currentIndex + let current_index = !idx in + idx := current_index + 1; + if loc_has_cursor item.ppat_loc then Some current_index else None) in - match tupleItemWithCursor with + match tuple_item_with_cursor with | None -> -1 | Some i -> i) | `ConstructorPat (_, {ppat_desc = Ppat_record (fields, _)}) -> ( - let fieldNameWithCursor = + let field_name_with_cursor = fields |> List.find_map (fun @@ -681,39 +687,39 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads Parsetree.pattern Parsetree.record_element) -> if - posBeforeCursor >= Pos.ofLexing loc.loc_start - && posBeforeCursor - <= Pos.ofLexing pat.ppat_loc.loc_end + pos_before_cursor >= Pos.of_lexing loc.loc_start + && pos_before_cursor + <= Pos.of_lexing pat.ppat_loc.loc_end then Some (Longident.last txt) else None) in - match (fieldNameWithCursor, argParts) with - | Some fieldName, Some (`InlineRecord fields) -> + match (field_name_with_cursor, arg_parts) with + | Some field_name, Some (`InlineRecord fields) -> let idx = ref 0 in - let fieldIndex = ref (-1) in + let field_index = ref (-1) in fields |> List.iter (fun (_, field, _) -> idx := !idx + 1; - let currentIndex = !idx in - if fieldName = field.fname.txt then - fieldIndex := currentIndex + let current_index = !idx in + if field_name = field.fname.txt then + field_index := current_index else ()); - !fieldIndex + !field_index | _ -> -1) - | `ConstructorPat (_, pat) when locHasCursor pat.ppat_loc -> 0 + | `ConstructorPat (_, pat) when loc_has_cursor pat.ppat_loc -> 0 | _ -> -1 in - let constructorNameLength = String.length constructor.name in + let constructor_name_length = String.length constructor.name in let params = - match argParts with + match arg_parts with | None -> [] | Some (`SingleArg (_, docstring)) -> [ Lsp.Types.ParameterInformation.create ~label: (`Offset - (constructorNameLength + 1, String.length label - 1)) + (constructor_name_length + 1, String.length label - 1)) ~documentation: (`MarkupContent (Lsp.Types.MarkupContent.create @@ -721,7 +727,7 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads (); ] | Some (`InlineRecord fields) -> - let baseOffset = constructorNameLength + 2 in + let base_offset = constructor_name_length + 2 in (* Account for leading '({' *) Lsp.Types.ParameterInformation.create ~label:(`Offset (0, 0)) @@ -734,7 +740,7 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads |> List.map (fun (_, (field : field), (start, end_)) -> Lsp.Types.ParameterInformation.create ~label: - (`Offset (baseOffset + start, baseOffset + end_)) + (`Offset (base_offset + start, base_offset + end_)) ~documentation: (`MarkupContent (Lsp.Types.MarkupContent.create @@ -744,12 +750,12 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads ())) | Some (`TupleArg items) -> (* Account for leading '(' *) - let baseOffset = constructorNameLength + 1 in + let base_offset = constructor_name_length + 1 in items |> List.map (fun (_, docstring, (start, end_)) -> Lsp.Types.ParameterInformation.create ~label: - (`Offset (baseOffset + start, baseOffset + end_)) + (`Offset (base_offset + start, base_offset + end_)) ~documentation: (`MarkupContent (Lsp.Types.MarkupContent.create @@ -767,11 +773,11 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads (`MarkupContent (Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown ~value:docs))) - ~activeParameter:(Some activeParameter) () + ~activeParameter:(Some active_parameter) () in let signature = Lsp.Types.SignatureHelp.create ~signatures:[signatures] - ~activeParameter:(Some activeParameter) ~activeSignature:0 () + ~activeParameter:(Some active_parameter) ~activeSignature:0 () in Some signature)) | _ -> None)) diff --git a/analysis/src/StructureUtils.ml b/analysis/src/structure_utils.ml similarity index 51% rename from analysis/src/StructureUtils.ml rename to analysis/src/structure_utils.ml index 2421f92a4b6..895dab2d507 100644 --- a/analysis/src/StructureUtils.ml +++ b/analysis/src/structure_utils.ml @@ -1,10 +1,10 @@ -open SharedTypes +open Shared_types let unique_items (structure : Module.structure) : Module.item list = - let namesUsed = Hashtbl.create 10 in + let names_used = Hashtbl.create 10 in structure.items |> List.filter (fun (it : Module.item) -> - if Hashtbl.mem namesUsed it.name then false + if Hashtbl.mem names_used it.name then false else ( - Hashtbl.add namesUsed it.name (); + Hashtbl.add names_used it.name (); true)) diff --git a/analysis/src/type_utils.ml b/analysis/src/type_utils.ml new file mode 100644 index 00000000000..826276bad0f --- /dev/null +++ b/analysis/src/type_utils.ml @@ -0,0 +1,1324 @@ +open Shared_types + +let module_path_from_env env = + let module_name = env.Query_env.file.module_name in + let transformed_module_name = + (* Transform namespaced module names from internal format (Context-Kaplay) + to user-facing format (Kaplay.Context) *) + match String.rindex_opt module_name '-' with + | None -> module_name + | Some i -> + let namespace = + String.sub module_name (i + 1) (String.length module_name - i - 1) + in + let module_ = String.sub module_name 0 i in + namespace ^ "." ^ module_ + in + transformed_module_name :: List.rev env.path_rev + +let full_type_id_from_decl ~env ~name ~module_path = + env.Query_env.file.module_name :: Module_path.to_path module_path name + |> String.concat "." + +let debug_log_type_arg_context {env; type_args; type_params} = + Printf.sprintf "Type arg context. env: %s, typeArgs: %s, typeParams: %s\n" + (Debug.debug_print_env env) + (type_args |> List.map Shared.type_to_string |> String.concat ", ") + (type_params |> List.map Shared.type_to_string |> String.concat ", ") + +(** Checks whether this type has any uninstantiated type parameters. *) +let rec has_tvar (ty : Types.type_expr) : bool = + match ty.desc with + | Tvar _ -> true + | Tarrow (arg, ret, _, _) -> has_tvar arg.typ || has_tvar ret + | Ttuple tyl -> List.exists has_tvar tyl + | Tconstr (_, tyl, _) -> List.exists has_tvar tyl + | Tobject (ty, _) -> has_tvar ty + | Tfield (_, _, ty1, ty2) -> has_tvar ty1 || has_tvar ty2 + | Tnil -> false + | Tlink ty -> has_tvar ty + | Tsubst ty -> has_tvar ty + | Tvariant {row_fields; _} -> + List.exists + (function + | _, Types.Rpresent (Some ty) -> has_tvar ty + | _, Reither (_, tyl, _, _) -> List.exists has_tvar tyl + | _ -> false) + row_fields + | Tunivar _ -> true + | Tpoly (ty, tyl) -> has_tvar ty || List.exists has_tvar tyl + | Tpackage (_, _, tyl) -> List.exists has_tvar tyl + +let find_type_via_loc ~full ~debug (loc : Location.t) = + match + References.get_loc_item ~full ~pos:(Pos.of_lexing loc.loc_end) ~debug + with + | Some {loc_type = Typed (_, typ_expr, _)} -> Some typ_expr + | _ -> None + +let path_from_type_expr (t : Types.type_expr) = + match t.desc with + | Tconstr (path, _typeArgs, _) + | Tlink {desc = Tconstr (path, _typeArgs, _)} + | Tsubst {desc = Tconstr (path, _typeArgs, _)} + | Tpoly ({desc = Tconstr (path, _typeArgs, _)}, []) -> + Some path + | _ -> None + +let print_record_from_fields ?name (fields : field list) = + (match name with + | None -> "" + | Some name -> "type " ^ name ^ " = ") + ^ "{" + ^ (fields + |> List.map (fun f -> f.fname.txt ^ ": " ^ Shared.type_to_string f.typ) + |> String.concat ", ") + ^ "}" + +let rec extracted_type_to_string ?(name_only = false) ?(inner = false) = + function + | Tuple (_, _, typ) | Tpolyvariant {type_expr = typ} | Tfunction {typ} -> + if inner then + try + typ |> path_from_type_expr |> Option.get + |> Shared_types.path_ident_to_string + with _ -> "" + else Shared.type_to_string typ + | Trecord {definition; fields} -> + let name = + match definition with + | `TypeExpr typ -> ( + try + typ |> path_from_type_expr |> Option.get + |> Shared_types.path_ident_to_string + with _ -> "") + | `NameOnly name -> name + in + if inner || name_only then name else print_record_from_fields ~name fields + | Tbool _ -> "bool" + | Tstring _ -> "string" + | TtypeT _ -> "type t" + | Tarray (_, TypeExpr inner_typ) -> + "array<" ^ Shared.type_to_string inner_typ ^ ">" + | Tarray (_, ExtractedType inner_typ) -> + "array<" ^ extracted_type_to_string ~inner:true inner_typ ^ ">" + | Toption (_, TypeExpr inner_typ) -> + "option<" ^ Shared.type_to_string inner_typ ^ ">" + | Tresult {ok_type; error_type} -> + "result<" + ^ Shared.type_to_string ok_type + ^ ", " + ^ Shared.type_to_string error_type + ^ ">" + | Toption (_, ExtractedType inner_typ) -> + "option<" ^ extracted_type_to_string ~inner:true inner_typ ^ ">" + | Tpromise (_, inner_typ) -> + "promise<" ^ Shared.type_to_string inner_typ ^ ">" + | Tvariant {variant_decl; variant_name} -> + if inner || name_only then variant_name + else Shared.decl_to_string variant_name variant_decl + | TinlineRecord {fields} -> print_record_from_fields fields + | Texn _ -> "exn" + +let get_extracted_type maybe_res = + match maybe_res with + | None -> None + | Some (extracted_type, _) -> Some extracted_type + +let instantiate_type ~type_params ~type_args (t : Types.type_expr) = + if type_params = [] || type_args = [] then t + else + let rec apply_sub tp ta t = + match (tp, ta) with + | t1 :: t_rest1, t2 :: t_rest2 -> + if t1 = t then t2 else apply_sub t_rest1 t_rest2 t + | [], _ | _, [] -> t + in + let rec loop (t : Types.type_expr) = + match t.desc with + | Tlink t -> loop t + | Tvar _ -> apply_sub type_params type_args t + | Tunivar _ -> t + | Tconstr (path, args, memo) -> + {t with desc = Tconstr (path, args |> List.map loop, memo)} + | Tsubst t -> loop t + | Tvariant rd -> {t with desc = Tvariant (row_desc rd)} + | Tnil -> t + | Tarrow (arg, ret, c, arity) -> + { + t with + desc = Tarrow ({arg with typ = loop arg.typ}, loop ret, c, arity); + } + | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} + | Tobject (t, r) -> {t with desc = Tobject (loop t, r)} + | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} + | Tpoly (t, []) -> loop t + | Tpoly (t, tl) -> {t with desc = Tpoly (loop t, tl |> List.map loop)} + | Tpackage (p, l, tl) -> + {t with desc = Tpackage (p, l, tl |> List.map loop)} + and row_desc (rd : Types.row_desc) = + let row_fields = + rd.row_fields |> List.map (fun (l, rf) -> (l, row_field rf)) + in + let row_more = loop rd.row_more in + let row_name = + match rd.row_name with + | None -> None + | Some (p, tl) -> Some (p, tl |> List.map loop) + in + {rd with row_fields; row_more; row_name} + and row_field (rf : Types.row_field) = + match rf with + | Rpresent None -> rf + | Rpresent (Some t) -> Rpresent (Some (loop t)) + | Reither (b1, tl, b2, r) -> Reither (b1, tl |> List.map loop, b2, r) + | Rabsent -> Rabsent + in + loop t + +let instantiate_type2 ?(type_arg_context : type_arg_context option) + (t : Types.type_expr) = + match type_arg_context with + | None | Some {type_args = []} | Some {type_params = []} -> t + | Some {type_args; type_params} -> + let rec apply_sub tp ta name = + match (tp, ta) with + | {Types.desc = Tvar (Some var_name)} :: t_rest1, t2 :: t_rest2 -> + if var_name = name then t2 else apply_sub t_rest1 t_rest2 name + | _ :: t_rest1, _ :: t_rest2 -> apply_sub t_rest1 t_rest2 name + | [], _ | _, [] -> t + in + + let rec loop (t : Types.type_expr) = + match t.desc with + | Tlink t -> loop t + | Tvar (Some name) -> apply_sub type_params type_args name + | Tvar _ -> t + | Tunivar _ -> t + | Tconstr (path, args, memo) -> + {t with desc = Tconstr (path, args |> List.map loop, memo)} + | Tsubst t -> loop t + | Tvariant rd -> {t with desc = Tvariant (row_desc rd)} + | Tnil -> t + | Tarrow (arg, ret, c, arity) -> + { + t with + desc = Tarrow ({arg with typ = loop arg.typ}, loop ret, c, arity); + } + | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} + | Tobject (t, r) -> {t with desc = Tobject (loop t, r)} + | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} + | Tpoly (t, []) -> loop t + | Tpoly (t, tl) -> {t with desc = Tpoly (loop t, tl |> List.map loop)} + | Tpackage (p, l, tl) -> + {t with desc = Tpackage (p, l, tl |> List.map loop)} + and row_desc (rd : Types.row_desc) = + let row_fields = + rd.row_fields |> List.map (fun (l, rf) -> (l, row_field rf)) + in + let row_more = loop rd.row_more in + let row_name = + match rd.row_name with + | None -> None + | Some (p, tl) -> Some (p, tl |> List.map loop) + in + {rd with row_fields; row_more; row_name} + and row_field (rf : Types.row_field) = + match rf with + | Rpresent None -> rf + | Rpresent (Some t) -> Rpresent (Some (loop t)) + | Reither (b1, tl, b2, r) -> Reither (b1, tl |> List.map loop, b2, r) + | Rabsent -> Rabsent + in + loop t + +let rec extract_record_type ~env ~package (t : Types.type_expr) = + match t.desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> + extract_record_type ~env ~package t1 + | Tconstr (path, type_args, _) -> ( + match References.dig_constructor ~env ~package path with + | Some (env, ({item = {kind = Record fields}} as typ)) -> + let type_params = typ.item.decl.type_params in + let fields = + fields + |> List.map (fun field -> + let field_typ = + field.typ |> instantiate_type ~type_params ~type_args + in + {field with typ = field_typ}) + in + Some (env, fields, typ) + | Some (env, {item = {decl = {type_manifest = Some t1; type_params}}}) -> + let t1 = t1 |> instantiate_type ~type_params ~type_args in + extract_record_type ~env ~package t1 + | _ -> None) + | _ -> None + +let rec extract_object_type ~env ~package (t : Types.type_expr) = + match t.desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> + extract_object_type ~env ~package t1 + | Tobject (t_obj, _) -> Some (env, t_obj) + | Tconstr (path, type_args, _) -> ( + match References.dig_constructor ~env ~package path with + | Some (env, {item = {decl = {type_manifest = Some t1; type_params}}}) -> + let t1 = t1 |> instantiate_type ~type_params ~type_args in + extract_object_type ~env ~package t1 + | _ -> None) + | _ -> None + +let extract_function_type ~env ~package ?(dig_into = true) typ = + let rec loop ~env acc (t : Types.type_expr) = + match t.desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ~env acc t1 + | Tarrow (arg, t_ret, _, _) -> loop ~env ((arg.lbl, arg.typ) :: acc) t_ret + | Tconstr (path, type_args, _) when dig_into -> ( + match References.dig_constructor ~env ~package path with + | Some (env, {item = {decl = {type_manifest = Some t1; type_params}}}) -> + let t1 = t1 |> instantiate_type ~type_params ~type_args in + loop ~env acc t1 + | _ -> (List.rev acc, t)) + | _ -> (List.rev acc, t) + in + loop ~env [] typ + +let extract_function_type_with_env ~env ~package typ = + let rec loop ~env acc (t : Types.type_expr) = + match t.desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ~env acc t1 + | Tarrow (arg, t_ret, _, _) -> loop ~env ((arg.lbl, arg.typ) :: acc) t_ret + | Tconstr (path, type_args, _) -> ( + match References.dig_constructor ~env ~package path with + | Some (_env, {item = {decl = {type_manifest = Some t1; type_params}}}) -> + let t1 = t1 |> instantiate_type ~type_params ~type_args in + loop ~env acc t1 + | Some _ -> (List.rev acc, t, env) + | _ -> (List.rev acc, t, env)) + | _ -> (List.rev acc, t, env) + in + loop ~env [] typ + +let maybe_set_type_arg_ctx ?type_arg_context_from_type_manifest ~type_params + ~type_args env = + match type_arg_context_from_type_manifest with + | Some type_arg_context_from_type_manifest -> + Some type_arg_context_from_type_manifest + | None -> + let type_arg_context = + if List.length type_params > 0 then Some {env; type_params; type_args} + else None + in + (match type_arg_context with + | None -> () + | Some type_arg_context -> + if Debug.verbose () then + Printf.printf "[#type_arg_ctx]--> setting new type arg ctx: %s" + (debug_log_type_arg_context type_arg_context)); + type_arg_context + +(* TODO(env-stuff) Maybe this could be removed entirely if we can guarantee that we don't have to look up functions from in here. *) +let extract_function_type2 ?type_arg_context ~env ~package typ = + let rec loop ?type_arg_context ~env acc (t : Types.type_expr) = + match t.desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> + loop ?type_arg_context ~env acc t1 + | Tarrow (arg, t_ret, _, _) -> + loop ?type_arg_context ~env ((arg.lbl, arg.typ) :: acc) t_ret + | Tconstr (path, type_args, _) -> ( + match References.dig_constructor ~env ~package path with + | Some (env, {item = {decl = {type_manifest = Some t1; type_params}}}) -> + let type_arg_context = + maybe_set_type_arg_ctx ~type_params ~type_args env + in + loop ?type_arg_context ~env acc t1 + | _ -> (List.rev acc, t, type_arg_context)) + | _ -> (List.rev acc, t, type_arg_context) + in + loop ?type_arg_context ~env [] typ + +let rec extract_type ?(print_opening_debug = true) + ?(type_arg_context : type_arg_context option) + ?(type_arg_context_from_type_manifest : type_arg_context option) ~env + ~package (t : Types.type_expr) = + let maybe_set_type_arg_ctx = + maybe_set_type_arg_ctx ?type_arg_context_from_type_manifest + in + if Debug.verbose () && print_opening_debug then + Printf.printf + "[extract_type]--> starting extraction of type: %s, in env: %s. Has type \ + arg ctx: %b\n" + (Shared.type_to_string t) + (Debug.debug_print_env env) + (Option.is_some type_arg_context); + (match type_arg_context with + | None -> () + | Some type_arg_context -> + if Debug.verbose () && print_opening_debug then + Printf.printf "[extract_type]--> %s" + (debug_log_type_arg_context type_arg_context)); + let instantiate_type = instantiate_type2 in + match t.desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> + extract_type ?type_arg_context ~print_opening_debug:false ~env ~package t1 + | Tconstr (Path.Pident {name = "option"}, [payload_type_expr], _) -> + Some (Toption (env, TypeExpr payload_type_expr), type_arg_context) + | Tconstr (Path.Pident {name = "promise"}, [payload_type_expr], _) -> + Some (Tpromise (env, payload_type_expr), type_arg_context) + | Tconstr (Path.Pident {name = "array"}, [payload_type_expr], _) -> + Some (Tarray (env, TypeExpr payload_type_expr), type_arg_context) + | Tconstr (Path.Pident {name = "result"}, [ok_type; error_type], _) -> + Some (Tresult {env; ok_type; error_type}, type_arg_context) + | Tconstr (Path.Pident {name = "bool"}, [], _) -> + Some (Tbool env, type_arg_context) + | Tconstr (Path.Pident {name = "string"}, [], _) -> + Some (Tstring env, type_arg_context) + | Tconstr (Path.Pident {name = "exn"}, [], _) -> + Some (Texn env, type_arg_context) + | Tarrow _ -> ( + match extract_function_type2 ?type_arg_context t ~env ~package with + | args, t_ret, type_arg_context when args <> [] -> + Some + (Tfunction {env; args; typ = t; return_type = t_ret}, type_arg_context) + | _args, _tRet, _typeArgContext -> None) + | Tconstr (path, type_args, _) -> ( + if Debug.verbose () then + Printf.printf "[extract_type]--> digging for type %s in %s\n" + (Path.name path) + (Debug.debug_print_env env); + match References.dig_constructor ~env ~package path with + | Some + ( env_from_declaration, + {item = {decl = {type_manifest = Some t1; type_params}}} ) -> + if Debug.verbose () then + print_endline "[extract_type]--> found type manifest"; + + (* Type manifests inherit the last type args ctx that wasn't for a type manifest. + This is because the manifest itself doesn't have type args and an env that can + be used to instantiate. *) + let type_arg_context = + maybe_set_type_arg_ctx ~type_params ~type_args env + in + t1 + |> extract_type ?type_arg_context_from_type_manifest:type_arg_context + ~env:env_from_declaration ~package + | Some + (env_from_item, {name; item = {decl; kind = Type.Variant constructors}}) + -> + if Debug.verbose () then print_endline "[extract_type]--> found variant"; + let type_arg_context = + maybe_set_type_arg_ctx ~type_params:decl.type_params ~type_args env + in + Some + ( Tvariant + { + env = env_from_item; + constructors; + variant_name = name.txt; + variant_decl = decl; + }, + type_arg_context ) + | Some (env_from_declaration, {item = {kind = Record fields; decl}}) -> + if Debug.verbose () then print_endline "[extract_type]--> found record"; + (* Need to create a new type arg context here because we're sending along a type expr that might have type vars. *) + let type_arg_context = + maybe_set_type_arg_ctx ~type_params:decl.type_params ~type_args env + in + Some + ( Trecord {env = env_from_declaration; fields; definition = `TypeExpr t}, + type_arg_context ) + | Some (env_from_declaration, {item = {name = "t"; decl = {type_params}}}) + -> + let type_arg_context = + maybe_set_type_arg_ctx ~type_params ~type_args env + in + Some (TtypeT {env = env_from_declaration; path}, type_arg_context) + | None -> + if Debug.verbose () then + print_endline "[extract_type]--> found nothing when digging"; + None + | _ -> + if Debug.verbose () then + print_endline "[extract_type]--> found something else when digging"; + None) + | Ttuple expressions -> Some (Tuple (env, expressions, t), type_arg_context) + | Tvariant {row_fields} -> + let constructors = + row_fields + |> List.map (fun (label, field) -> + { + name = label; + display_name = + Utils.print_maybe_exotic_ident ~allow_uident:true label; + args = + (* Multiple arguments are represented as a Ttuple, while a single argument is just the type expression itself. *) + (match field with + | Types.Rpresent (Some type_expr) -> ( + match type_expr.desc with + | Ttuple args -> args + | _ -> [type_expr]) + | _ -> []); + }) + in + Some (Tpolyvariant {env; constructors; type_expr = t}, type_arg_context) + | Tvar (Some var_name) -> ( + if Debug.verbose () then + Printf.printf + "[extract_type]--> found type variable: '%s. Trying to instantiate %s" + var_name + (match type_arg_context with + | None -> "with no type args ctx\n" + | Some type_arg_context -> + Printf.sprintf "with %s" (debug_log_type_arg_context type_arg_context)); + + let instantiated = t |> instantiate_type ?type_arg_context in + let rec extract_instantiated t = + match t.Types.desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> extract_instantiated t1 + | _ -> t + in + match extract_instantiated instantiated with + | {desc = Tvar _} -> + if Debug.verbose () then + Printf.printf "[extract_type]--> could not instantiate '%s. Skipping.\n" + var_name; + None + | _ -> + if Debug.verbose () then + Printf.printf + "[extract_type]--> SUCCEEDED instantiation, new type is: %s\n" + (Shared.type_to_string instantiated); + + (* Use the env from instantiation if we managed to instantiate the type param *) + let next_env = + match type_arg_context with + | Some {env} -> env + | None -> env + in + instantiated |> extract_type ?type_arg_context ~env:next_env ~package) + | _ -> + if Debug.verbose () then print_endline "[extract_type]--> miss"; + None + +let is_function_type ~env ~package t = + match extract_type ~env ~package t with + | Some (Tfunction _, _) -> true + | _ -> false + +let find_return_type_of_function_at_loc loc ~(env : Query_env.t) ~full ~debug = + match References.get_loc_item ~full ~pos:(loc |> Loc.end_) ~debug with + | Some {loc_type = Typed (_, typ_expr, _)} -> ( + match extract_function_type ~env ~package:full.package typ_expr with + | args, t_ret when args <> [] -> Some t_ret + | _ -> None) + | _ -> None + +let rec dig_to_relevant_template_name_type ~env ~package ?(suffix = "") + (t : Types.type_expr) = + match t.desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> + dig_to_relevant_template_name_type ~suffix ~env ~package t1 + | Tconstr (Path.Pident {name = "option"}, [t1], _) -> + dig_to_relevant_template_name_type ~suffix ~env ~package t1 + | Tconstr (Path.Pident {name = "array"}, [t1], _) -> + dig_to_relevant_template_name_type ~suffix:"s" ~env ~package t1 + | Tconstr (path, _, _) -> ( + match References.dig_constructor ~env ~package path with + | Some (env, {item = {decl = {type_manifest = Some typ}}}) -> + dig_to_relevant_template_name_type ~suffix ~env ~package typ + | _ -> (t, suffix, env)) + | _ -> (t, suffix, env) + +let rec resolve_type_for_pipe_completion ~env ~package ~lhs_loc ~full + (t : Types.type_expr) = + (* If the type we're completing on is a type parameter, we won't be able to + do completion unless we know what that type parameter is compiled as. + This attempts to look up the compiled type for that type parameter by + looking for compiled information at the loc of that expression. *) + let typ_from_loc = + match t with + | {Types.desc = Tvar _} -> + find_return_type_of_function_at_loc lhs_loc ~env ~full ~debug:false + | _ -> None + in + match typ_from_loc with + | Some ({desc = Tvar _} as t) -> (env, t) + | Some typ_from_loc -> + typ_from_loc + |> resolve_type_for_pipe_completion ~lhs_loc ~env ~package ~full + | None -> + let rec dig_to_relevant_type ~env ~package (t : Types.type_expr) = + match t.desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> + dig_to_relevant_type ~env ~package t1 + (* Don't descend into types named "t". Type t is a convention in the ReScript ecosystem. *) + | Tconstr (path, _, _) when path |> Path.last = "t" -> (env, t) + | Tconstr (path, _, _) -> ( + match References.dig_constructor ~env ~package path with + | Some (env, {item = {decl = {type_manifest = Some typ}}}) -> + dig_to_relevant_type ~env ~package typ + | _ -> (env, t)) + | _ -> (env, t) + in + dig_to_relevant_type ~env ~package t + +let extract_type_from_resolved_type (typ : Type.t) ~env ~full = + match typ.kind with + | Tuple items -> Some (Tuple (env, items, Ctype.newty (Ttuple items))) + | Record fields -> + Some (Trecord {env; fields; definition = `NameOnly typ.name}) + | Variant constructors -> + Some + (Tvariant + {env; constructors; variant_name = typ.name; variant_decl = typ.decl}) + | Abstract _ | Open -> ( + match typ.decl.type_manifest with + | None -> None + | Some t -> + t |> extract_type ~env ~package:full.package |> get_extracted_type) + +(** The context we just came from as we resolve the nested structure. *) +type ctx = Rfield of string (** A record field of name *) + +let rec resolve_nested ?type_arg_context ~env ~full ~nested ?ctx + (typ : completion_type) = + let extract_type = extract_type ?type_arg_context in + if Debug.verbose () then + Printf.printf + "[nested]--> running nested in env: %s. Has type arg ctx: %b\n" + (Debug.debug_print_env env) + (Option.is_some type_arg_context); + (match type_arg_context with + | None -> () + | Some type_arg_context -> + if Debug.verbose () then + Printf.printf "[nested]--> %s" + (debug_log_type_arg_context type_arg_context)); + match nested with + | [] -> + if Debug.verbose () then + print_endline "[nested]--> reached end of pattern, returning type"; + Some + ( typ, + env, + (match ctx with + | None -> None + | Some (Rfield field_name) -> + Some (Completable.CameFromRecordField field_name)), + type_arg_context ) + | pattern_path :: nested -> ( + match (pattern_path, typ) with + | Completable.NTupleItem {item_num}, Tuple (env, tuple_items, _) -> ( + if Debug.verbose () then + print_endline "[nested]--> trying to move into tuple"; + match List.nth_opt tuple_items item_num with + | None -> + if Debug.verbose () then + print_endline "[nested]--> tuple element not found"; + None + | Some typ -> + typ + |> extract_type ~env ~package:full.package + |> Utils.Option.flat_map (fun (typ, type_arg_context) -> + typ |> resolve_nested ?type_arg_context ~env ~full ~nested)) + | ( NFollowRecordField {field_name}, + (TinlineRecord {env; fields} | Trecord {env; fields}) ) -> ( + if Debug.verbose () then + print_endline "[nested]--> trying to move into record field"; + match + fields + |> List.find_opt (fun (field : field) -> field.fname.txt = field_name) + with + | None -> + if Debug.verbose () then + print_endline "[nested]--> did not find record field"; + None + | Some {typ; optional} -> + if Debug.verbose () then + print_endline "[nested]--> found record field type"; + let typ = if optional then Utils.unwrap_if_option typ else typ in + + if Debug.verbose () then + Printf.printf "[nested]--> extracting from type %s in env %s\n" + (Shared.type_to_string typ) + (Debug.debug_print_env env); + typ + |> extract_type ~env ~package:full.package + |> Utils.Option.flat_map (fun (typ, type_arg_context) -> + typ + |> resolve_nested ?type_arg_context ~ctx:(Rfield field_name) ~env + ~full ~nested)) + | NRecordBody {seen_fields}, Trecord {env; definition = `TypeExpr type_expr} + -> + type_expr + |> extract_type ~env ~package:full.package + |> Option.map (fun (typ, type_arg_context) -> + ( typ, + env, + Some (Completable.RecordField {seen_fields}), + type_arg_context )) + | ( NRecordBody {seen_fields}, + (Trecord {env; definition = `NameOnly _} as extracted_type) ) -> + Some + ( extracted_type, + env, + Some (Completable.RecordField {seen_fields}), + type_arg_context ) + | NRecordBody {seen_fields}, TinlineRecord {env; fields} -> + Some + ( TinlineRecord {fields; env}, + env, + Some (Completable.RecordField {seen_fields}), + type_arg_context ) + | ( NVariantPayload {constructor_name = "Some"; item_num = 0}, + Toption (env, ExtractedType typ) ) -> + if Debug.verbose () then + print_endline "[nested]--> moving into option Some"; + typ |> resolve_nested ?type_arg_context ~env ~full ~nested + | ( NVariantPayload {constructor_name = "Some"; item_num = 0}, + Toption (env, TypeExpr typ) ) -> + if Debug.verbose () then + print_endline "[nested]--> moving into option Some"; + typ + |> extract_type ~env ~package:full.package + |> Utils.Option.flat_map (fun (t, type_arg_context) -> + t |> resolve_nested ?type_arg_context ~env ~full ~nested) + | NVariantPayload {constructor_name = "Ok"; item_num = 0}, Tresult {ok_type} + -> + if Debug.verbose () then print_endline "[nested]--> moving into result Ok"; + ok_type + |> extract_type ~env ~package:full.package + |> Utils.Option.flat_map (fun (t, type_arg_context) -> + t |> resolve_nested ?type_arg_context ~env ~full ~nested) + | ( NVariantPayload {constructor_name = "Error"; item_num = 0}, + Tresult {error_type} ) -> + if Debug.verbose () then + print_endline "[nested]--> moving into result Error"; + error_type + |> extract_type ~env ~package:full.package + |> Utils.Option.flat_map (fun (t, type_arg_context) -> + t |> resolve_nested ?type_arg_context ~env ~full ~nested) + | NVariantPayload {constructor_name; item_num}, Tvariant {env; constructors} + -> ( + if Debug.verbose () then + Printf.printf + "[nested]--> trying to move into variant payload $%i of constructor \ + '%s'\n" + item_num constructor_name; + match + constructors + |> List.find_opt (fun (c : Constructor.t) -> + c.cname.txt = constructor_name) + with + | Some {args = Args args} -> ( + if Debug.verbose () then + print_endline "[nested]--> found constructor (Args type)"; + match List.nth_opt args item_num with + | None -> + if Debug.verbose () then + print_endline "[nested]--> did not find relevant args num"; + None + | Some (typ, _) -> + if Debug.verbose () then + Printf.printf "[nested]--> found arg of type: %s\n" + (Shared.type_to_string typ); + + typ + |> extract_type ~env ~package:full.package + |> Utils.Option.flat_map (fun (typ, type_arg_context) -> + if Debug.verbose () then + Printf.printf + "[nested]--> extracted %s, continuing descent of %i items\n" + (extracted_type_to_string typ) + (List.length nested); + typ |> resolve_nested ?type_arg_context ~env ~full ~nested)) + | Some {args = InlineRecord fields} when item_num = 0 -> + if Debug.verbose () then + print_endline "[nested]--> found constructor (inline record)"; + TinlineRecord {env; fields} + |> resolve_nested ?type_arg_context ~env ~full ~nested + | _ -> None) + | ( NPolyvariantPayload {constructor_name; item_num}, + Tpolyvariant {env; constructors} ) -> ( + match + constructors + |> List.find_opt (fun (c : poly_variant_constructor) -> + c.name = constructor_name) + with + | None -> None + | Some constructor -> ( + match List.nth_opt constructor.args item_num with + | None -> None + | Some typ -> + typ + |> extract_type ~env ~package:full.package + |> Utils.Option.flat_map (fun (typ, type_arg_context) -> + typ |> resolve_nested ?type_arg_context ~env ~full ~nested))) + | NArray, Tarray (env, ExtractedType typ) -> + typ |> resolve_nested ?type_arg_context ~env ~full ~nested + | NArray, Tarray (env, TypeExpr typ) -> + typ + |> extract_type ~env ~package:full.package + |> Utils.Option.flat_map (fun (typ, type_arg_context) -> + typ |> resolve_nested ?type_arg_context ~env ~full ~nested) + | _ -> None) + +let find_type_of_record_field fields ~field_name = + match + fields + |> List.find_opt (fun (field : field) -> field.fname.txt = field_name) + with + | None -> None + | Some {typ; optional} -> + let typ = if optional then Utils.unwrap_if_option typ else typ in + Some typ + +let find_type_of_constructor_arg constructors ~constructor_name ~payload_num + ~env = + match + constructors + |> List.find_opt (fun (c : Constructor.t) -> c.cname.txt = constructor_name) + with + | Some {args = Args args} -> ( + match List.nth_opt args payload_num with + | None -> None + | Some (typ, _) -> Some (TypeExpr typ)) + | Some {args = InlineRecord fields} when payload_num = 0 -> + Some (ExtractedType (TinlineRecord {env; fields})) + | _ -> None + +let find_type_of_polyvariant_arg constructors ~constructor_name ~payload_num = + match + constructors + |> List.find_opt (fun (c : poly_variant_constructor) -> + c.name = constructor_name) + with + | Some {args} -> ( + match List.nth_opt args payload_num with + | None -> None + | Some typ -> Some typ) + | None -> None + +let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~nested = + if Debug.verbose () then print_endline "[nested_pattern_path]"; + let t = + match typ with + | TypeExpr t -> + t |> extract_type ~env ~package:full.package |> get_extracted_type + | ExtractedType t -> Some t + in + match nested with + | [] -> None + | [final_pattern_path] -> ( + match t with + | None -> None + | Some completion_type -> ( + match (final_pattern_path, completion_type) with + | ( Completable.NFollowRecordField {field_name}, + (TinlineRecord {fields} | Trecord {fields}) ) -> ( + match fields |> find_type_of_record_field ~field_name with + | None -> None + | Some typ -> Some (TypeExpr typ, env)) + | NTupleItem {item_num}, Tuple (env, tuple_items, _) -> ( + match List.nth_opt tuple_items item_num with + | None -> None + | Some typ -> Some (TypeExpr typ, env)) + | ( NVariantPayload {constructor_name; item_num}, + Tvariant {env; constructors} ) -> ( + match + constructors + |> find_type_of_constructor_arg ~constructor_name + ~payload_num:item_num ~env + with + | Some typ -> Some (typ, env) + | None -> None) + | ( NPolyvariantPayload {constructor_name; item_num}, + Tpolyvariant {env; constructors} ) -> ( + match + constructors + |> find_type_of_polyvariant_arg ~constructor_name + ~payload_num:item_num + with + | Some typ -> Some (TypeExpr typ, env) + | None -> None) + | ( NVariantPayload {constructor_name = "Some"; item_num = 0}, + Toption (env, typ) ) -> + Some (typ, env) + | ( NVariantPayload {constructor_name = "Ok"; item_num = 0}, + Tresult {env; ok_type} ) -> + Some (TypeExpr ok_type, env) + | ( NVariantPayload {constructor_name = "Error"; item_num = 0}, + Tresult {env; error_type} ) -> + Some (TypeExpr error_type, env) + | NArray, Tarray (env, typ) -> Some (typ, env) + | _ -> None)) + | pattern_path :: nested -> ( + match t with + | None -> None + | Some completion_type -> ( + match (pattern_path, completion_type) with + | ( Completable.NFollowRecordField {field_name}, + (TinlineRecord {env; fields} | Trecord {env; fields}) ) -> ( + match fields |> find_type_of_record_field ~field_name with + | None -> None + | Some typ -> + typ + |> extract_type ~env ~package:full.package + |> get_extracted_type + |> Utils.Option.flat_map (fun typ -> + ExtractedType typ + |> resolve_nested_pattern_path ~env ~full ~nested)) + | NTupleItem {item_num}, Tuple (env, tuple_items, _) -> ( + match List.nth_opt tuple_items item_num with + | None -> None + | Some typ -> + typ + |> extract_type ~env ~package:full.package + |> get_extracted_type + |> Utils.Option.flat_map (fun typ -> + ExtractedType typ + |> resolve_nested_pattern_path ~env ~full ~nested)) + | ( NVariantPayload {constructor_name; item_num}, + Tvariant {env; constructors} ) -> ( + match + constructors + |> find_type_of_constructor_arg ~constructor_name + ~payload_num:item_num ~env + with + | Some typ -> typ |> resolve_nested_pattern_path ~env ~full ~nested + | None -> None) + | ( NPolyvariantPayload {constructor_name; item_num}, + Tpolyvariant {env; constructors} ) -> ( + match + constructors + |> find_type_of_polyvariant_arg ~constructor_name + ~payload_num:item_num + with + | Some typ -> + TypeExpr typ |> resolve_nested_pattern_path ~env ~full ~nested + | None -> None) + | ( NVariantPayload {constructor_name = "Some"; item_num = 0}, + Toption (env, typ) ) -> + typ |> resolve_nested_pattern_path ~env ~full ~nested + | ( NVariantPayload {constructor_name = "Ok"; item_num = 0}, + Tresult {env; ok_type} ) -> + TypeExpr ok_type |> resolve_nested_pattern_path ~env ~full ~nested + | ( NVariantPayload {constructor_name = "Error"; item_num = 0}, + Tresult {env; error_type} ) -> + TypeExpr error_type |> resolve_nested_pattern_path ~env ~full ~nested + | NArray, Tarray (env, typ) -> + typ |> resolve_nested_pattern_path ~env ~full ~nested + | _ -> None)) + +let get_args ~env (t : Types.type_expr) ~full = + let rec get_args_loop ~env (t : Types.type_expr) ~full + ~current_argument_position = + match t.desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> + get_args_loop ~full ~env ~current_argument_position t1 + | Tarrow ({lbl = Labelled {txt = l}; typ = t_arg}, t_ret, _, _) -> + (Shared_types.Completable.Labelled l, t_arg) + :: get_args_loop ~full ~env ~current_argument_position t_ret + | Tarrow ({lbl = Optional {txt = l}; typ = t_arg}, t_ret, _, _) -> + (Optional l, t_arg) + :: get_args_loop ~full ~env ~current_argument_position t_ret + | Tarrow ({lbl = Nolabel; typ = t_arg}, t_ret, _, _) -> + (Unlabelled {argument_position = current_argument_position}, t_arg) + :: get_args_loop ~full ~env + ~current_argument_position:(current_argument_position + 1) + t_ret + | Tconstr (path, type_args, _) -> ( + match References.dig_constructor ~env ~package:full.package path with + | Some (env, {item = {decl = {type_manifest = Some t1; type_params}}}) -> + let t1 = t1 |> instantiate_type ~type_params ~type_args in + get_args_loop ~full ~env ~current_argument_position t1 + | _ -> []) + | _ -> [] + in + t |> get_args_loop ~env ~full ~current_argument_position:0 + +let type_is_unit (typ : Types.type_expr) = + match typ.desc with + | Tconstr (Pident id, _typeArgs, _) + | Tlink {desc = Tconstr (Pident id, _typeArgs, _)} + | Tsubst {desc = Tconstr (Pident id, _typeArgs, _)} + | Tpoly ({desc = Tconstr (Pident id, _typeArgs, _)}, []) + when Ident.name id = "unit" -> + true + | _ -> false + +let rec context_path_from_core_type (core_type : Parsetree.core_type) = + match core_type.ptyp_desc with + | Ptyp_constr ({txt = Lident "option"}, [inner_typ]) -> + inner_typ |> context_path_from_core_type + |> Option.map (fun inner_typ -> Completable.CPOption inner_typ) + | Ptyp_constr ({txt = Lident "array"}, [inner_typ]) -> + Some (Completable.CPArray (inner_typ |> context_path_from_core_type)) + | Ptyp_constr (lid, _) -> + Some + (CPId + { + path = lid.txt |> Utils.flatten_long_ident; + completion_context = Type; + loc = lid.loc; + }) + | _ -> None + +let unwrap_completion_type_if_option (t : Shared_types.completion_type) = + match t with + | Toption (_, ExtractedType unwrapped) -> unwrapped + | _ -> t + +module Codegen = struct + let mk_fail_with_exp () = + Ast_helper.Exp.apply + (Ast_helper.Exp.ident {txt = Lident "failwith"; loc = Location.none}) + [(Nolabel, Ast_helper.Exp.constant (Pconst_string ("TODO", None)))] + + let mk_construct_pat ?payload name = + Ast_helper.Pat.construct + {Asttypes.txt = Longident.Lident name; loc = Location.none} + payload + + let mk_tag_pat ?payload name = Ast_helper.Pat.variant name payload + + let any () = Ast_helper.Pat.any () + + let rec extracted_type_to_exhaustive_patterns ~env ~full extracted_type = + match extracted_type with + | Tvariant v -> + Some + (v.constructors + |> List.map (fun (c : Shared_types.Constructor.t) -> + mk_construct_pat + ?payload: + (match c.args with + | Args [] -> None + | _ -> Some (any ())) + c.cname.txt)) + | Tpolyvariant v -> + Some + (v.constructors + |> List.map (fun (c : Shared_types.poly_variant_constructor) -> + mk_tag_pat + ?payload: + (match c.args with + | [] -> None + | _ -> Some (any ())) + c.display_name)) + | Toption (_, inner_type) -> + let extracted_type = + match inner_type with + | ExtractedType t -> Some t + | TypeExpr t -> + extract_type t ~env ~package:full.package |> get_extracted_type + in + let expanded_branches = + match extracted_type with + | None -> [] + | Some extracted_type -> ( + match + extracted_type_to_exhaustive_patterns ~env ~full extracted_type + with + | None -> [] + | Some patterns -> patterns) + in + Some + ([ + mk_construct_pat "None"; + mk_construct_pat ~payload:(Ast_helper.Pat.any ()) "Some"; + ] + @ (expanded_branches + |> List.map (fun (pat : Parsetree.pattern) -> + mk_construct_pat ~payload:pat "Some"))) + | Tresult {ok_type; error_type} -> + let extracted_ok_type = + ok_type |> extract_type ~env ~package:full.package |> get_extracted_type + in + let extracted_error_type = + error_type + |> extract_type ~env ~package:full.package + |> get_extracted_type + in + let expanded_ok_branches = + match extracted_ok_type with + | None -> [] + | Some extracted_type -> ( + match + extracted_type_to_exhaustive_patterns ~env ~full extracted_type + with + | None -> [] + | Some patterns -> patterns) + in + let expanded_error_branches = + match extracted_error_type with + | None -> [] + | Some extracted_type -> ( + match + extracted_type_to_exhaustive_patterns ~env ~full extracted_type + with + | None -> [] + | Some patterns -> patterns) + in + Some + ((expanded_ok_branches + |> List.map (fun (pat : Parsetree.pattern) -> + mk_construct_pat ~payload:pat "Ok")) + @ (expanded_error_branches + |> List.map (fun (pat : Parsetree.pattern) -> + mk_construct_pat ~payload:pat "Error"))) + | Tbool _ -> Some [mk_construct_pat "true"; mk_construct_pat "false"] + | _ -> None + + let extracted_type_to_exhaustive_cases ~env ~full extracted_type = + let patterns = + extracted_type_to_exhaustive_patterns ~env ~full extracted_type + in + + match patterns with + | None -> None + | Some patterns -> + Some + (patterns + |> List.map (fun (pat : Parsetree.pattern) -> + Ast_helper.Exp.case pat (mk_fail_with_exp ()))) +end + +let get_module_path_relative_to_env ~debug ~(env : Query_env.t) ~env_from_item + path = + match path with + | _ :: path_rev -> + (* type path is relative to the completion environment + express it from the root of the file *) + let found, path_from_env = + Query_env.path_from_env env_from_item (List.rev path_rev) + in + if debug then + Printf.printf "CPPipe pathFromEnv:%s found:%b\n" + (path_from_env |> String.concat ".") + found; + if path_from_env = [] then None + else if + env.file.module_name <> env_from_item.file.module_name && found + (* If the module names are different, then one needs to qualify the path. + But only if the path belongs to the env from completion *) + then Some (env_from_item.file.module_name :: path_from_env) + else Some path_from_env + | _ -> None + +let remove_opens_from_completion_path ~raw_opens ~package completion_path = + let rec remove_raw_open raw_open module_path = + match (raw_open, module_path) with + | [_], _ -> Some module_path + | s :: inner, first :: rest_path when s = first -> + remove_raw_open inner rest_path + | _ -> None + in + let rec remove_raw_opens raw_opens module_path = + match raw_opens with + | raw_open :: rest_opens -> ( + let new_module_path = remove_raw_opens rest_opens module_path in + match remove_raw_open raw_open new_module_path with + | None -> new_module_path + | Some mp -> mp) + | [] -> module_path + in + let completion_path_minus_opens = + completion_path |> Utils.flatten_any_namespace_in_path + |> remove_raw_opens package.opens + |> remove_raw_opens raw_opens + in + completion_path_minus_opens + +let path_to_element_props package = + match package.generic_jsx_module with + | None -> ["ReactDOM"; "domProps"] + | Some g -> (g |> String.split_on_char '.') @ ["Elements"; "props"] + +module String_set = Set.Make (String) + +let get_extra_modules_to_complete_from_for_type ~env ~full (t : Types.type_expr) + = + let found_module_paths = ref String_set.empty in + let add_to_module_paths attributes = + Process_attributes.find_editor_complete_from_attribute attributes + |> List.iter (fun e -> + found_module_paths := + String_set.add (e |> String.concat ".") !found_module_paths) + in + let rec inner ~env ~full (t : Types.type_expr) = + match t |> Shared.dig_constructor with + | Some path -> ( + match References.dig_constructor ~env ~package:full.package path with + | None -> () + | Some (env, {item = {decl = {type_manifest = Some t}; attributes}}) -> + add_to_module_paths attributes; + inner ~env ~full t + | Some (_, {item = {attributes}}) -> add_to_module_paths attributes) + | None -> () + in + inner ~env ~full t; + !found_module_paths |> String_set.elements + |> List.map (fun l -> String.split_on_char '.' l) + +let get_first_fn_unlabelled_arg_type ~env ~full t = + let labels, _, env = + extract_function_type_with_env ~env ~package:full.package t + in + let rec find_first_unlabelled_arg_type labels = + match labels with + | (Asttypes.Nolabel, t) :: _ -> Some t + | _ :: rest -> find_first_unlabelled_arg_type rest + | [] -> None + in + match find_first_unlabelled_arg_type labels with + | Some t -> Some (t, env) + | _ -> None + +let make_additional_text_edits_for_removing_dot pos_of_dot = + let start = + Lsp.Types.Position.create ~line:(fst pos_of_dot) + ~character:(snd pos_of_dot - 1) + in + let end_ = + Lsp.Types.Position.create ~line:(fst pos_of_dot) ~character:(snd pos_of_dot) + in + [ + Lsp.Types.TextEdit.create ~newText:"" + ~range:(Lsp.Types.Range.create ~start ~end_); + ] + +(** Turns a completion into a pipe completion. *) +let transform_completion_to_pipe_completion ?(synthetic = false) ~env + ?pos_of_dot (completion : Completion.t) = + let name = completion.name in + let name_with_pipe = "->" ^ name in + Some + { + completion with + name = name_with_pipe; + sort_text = + (match completion.sort_text with + | Some _ -> completion.sort_text + | None -> Some (name |> String.split_on_char '.' |> List.rev |> List.hd)); + insert_text = Some name_with_pipe; + env; + synthetic; + additional_text_edits = + (match pos_of_dot with + | None -> None + | Some pos_of_dot -> + Some (make_additional_text_edits_for_removing_dot pos_of_dot)); + } + +(** This takes a type expr and the env that type expr was found in, and produces a globally unique + id for that specific type. The globally unique id is the full path to the type as seen from the root + of the project. Example: type x in module SomeModule in file SomeFile would get the globally + unique id `SomeFile.SomeModule.x`.*) +let rec find_root_type_id ~full ~env (t : Types.type_expr) = + let debug = false in + match t.desc with + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> find_root_type_id ~full ~env t1 + | Tconstr (path, _, _) -> ( + (* We have a path. Try to dig to its declaration *) + if debug then + Printf.printf "[findRootTypeId] path %s, dig\n" (Path.name path); + match References.dig_constructor ~env ~package:full.package path with + | Some (env, {item = {decl = {type_manifest = Some t1}}}) -> + if debug then + Printf.printf "[findRootTypeId] dug up type alias at module path %s \n" + (module_path_from_env env |> String.concat "."); + find_root_type_id ~full ~env t1 + | Some (env, {item = {name}; module_path}) -> + (* if it's a named type, then we know its name will be its module path from the env + its name.*) + if debug then + Printf.printf + "[findRootTypeId] dug up named type at module path %s, from item: %s \n" + (module_path_from_env env |> String.concat ".") + (Module_path.to_path module_path name |> String.concat "."); + Some (full_type_id_from_decl ~env ~name ~module_path) + | None -> + (* If we didn't find anything, then it might be a builtin type. Check it.*) + if debug then Printf.printf "[findRootTypeId] dug up non-type alias\n"; + if + Predef.builtin_idents + |> List.find_opt (fun (_, i) -> Ident.same i (Path.head path)) + |> Option.is_some + then + Some + (if debug then Printf.printf "[findRootTypeId] returning builtin\n"; + Path.name path) + else None) + | _ -> None + +(** Filters out completions that are not pipeable from a list of completions. *) +let filter_pipeable_functions ~env ~full ?synthetic ?target_type_id ?pos_of_dot + completions = + match target_type_id with + | None -> completions + | Some target_type_id -> + completions + |> List.filter_map (fun (completion : Completion.t) -> + let this_completion_item_type_id = + match completion.kind with + | Value t -> ( + match + get_first_fn_unlabelled_arg_type ~full ~env:completion.env t + with + | None -> None + | Some (t, env_from_labelled_arg) -> + find_root_type_id ~full ~env:env_from_labelled_arg t) + | _ -> None + in + match this_completion_item_type_id with + | Some main_type_id when main_type_id = target_type_id -> ( + match pos_of_dot with + | None -> Some completion + | Some pos_of_dot -> + transform_completion_to_pipe_completion ?synthetic ~env + ~pos_of_dot completion) + | _ -> None) + +let remove_current_module_if_needed ~env_completion_is_made_from completion_path + = + if + List.length completion_path > 0 + && List.hd completion_path + = env_completion_is_made_from.Query_env.file.module_name + then List.tl completion_path + else completion_path + +let rec get_obj_fields (texp : Types.type_expr) = + match texp.desc with + | Tfield (name, _, t1, t2) -> + let fields = t2 |> get_obj_fields in + (name, t1) :: fields + | Tlink te | Tsubst te | Tpoly (te, []) -> te |> get_obj_fields + | Tvar None -> [] + | _ -> [] + +let path_to_builtin path = + Predef.builtin_idents + |> List.find_opt (fun (_, i) -> Ident.same i (Path.head path)) + +let completion_path_from_maybe_builtin path = + match path_to_builtin path with + | Some ("array", _) -> Some ["Stdlib"; "Array"] + | Some ("option", _) -> Some ["Stdlib"; "Option"] + | Some ("string", _) -> Some ["Stdlib"; "String"] + | Some ("int", _) -> Some ["Stdlib"; "Int"] + | Some ("float", _) -> Some ["Stdlib"; "Float"] + | Some ("promise", _) -> Some ["Stdlib"; "Promise"] + | Some ("list", _) -> Some ["Stdlib"; "List"] + | Some ("result", _) -> Some ["Stdlib"; "Result"] + | Some ("dict", _) -> Some ["Stdlib"; "Dict"] + | Some ("char", _) -> Some ["Stdlib"; "Char"] + | _ -> ( + match path |> Utils.expand_path |> List.rev with + | [main_module; "t"] when String.starts_with ~prefix:"Stdlib_" main_module + -> + (* Route Stdlib_X to Stdlib.X for proper completions without the Stdlib_ prefix *) + Some (String.split_on_char '_' main_module) + | ["Primitive_js_extern"; "null"] -> Some ["Stdlib"; "Null"] + | ["Primitive_js_extern"; "nullable"] -> Some ["Stdlib"; "Nullable"] + | _ -> None) diff --git a/analysis/src/Uri.ml b/analysis/src/uri.ml similarity index 74% rename from analysis/src/Uri.ml rename to analysis/src/uri.ml index 912acbecbf2..6b4ae5c96ef 100644 --- a/analysis/src/Uri.ml +++ b/analysis/src/uri.ml @@ -1,17 +1,17 @@ type t = Lsp.Uri.t -let stripPath = ref false (* for use in tests *) +let strip_path = ref false (* for use in tests *) -let fromPath path = Lsp.Uri.of_path path -let fromString str = Lsp.Uri.of_string str -let isInterface uri = uri |> Lsp.Uri.to_string |> Filename.check_suffix "i" -let toPath uri = +let from_path path = Lsp.Uri.of_path path +let from_string str = Lsp.Uri.of_string str +let is_interface uri = uri |> Lsp.Uri.to_string |> Filename.check_suffix "i" +let to_path uri = (* Lsp.Uri.to_path remove the schema file:// but keep the `/` on start of path. *) let p = Lsp.Uri.to_path uri in - if !stripPath then String.sub p 1 (String.length p - 1) else p + if !strip_path then String.sub p 1 (String.length p - 1) else p -let toTopLevelLoc (uri : Lsp.Uri.t) = - let topPos = +let to_top_level_loc (uri : Lsp.Uri.t) = + let top_pos = { Lexing.pos_fname = uri |> Lsp.Uri.to_path; pos_lnum = 1; @@ -19,10 +19,10 @@ let toTopLevelLoc (uri : Lsp.Uri.t) = pos_cnum = 0; } in - {Location.loc_start = topPos; Location.loc_end = topPos; loc_ghost = false} + {Location.loc_start = top_pos; Location.loc_end = top_pos; loc_ghost = false} -let toString t = - if !stripPath then Filename.basename (Lsp.Uri.to_path t) +let to_string t = + if !strip_path then Filename.basename (Lsp.Uri.to_path t) else Lsp.Uri.to_string t (* Light weight, hopefully-enough-for-the-purpose fn to encode URI components. @@ -30,7 +30,7 @@ let toString t = https://en.wikipedia.org/wiki/Percent-encoding. Note that this function is not general purpose, rather it's currently only for URL encoding the argument list passed to command links in markdown. *) -let encodeURIComponent text = +let encode_u_r_i_component text = let ln = String.length text in let buf = Buffer.create ln in let rec loop i = diff --git a/analysis/src/uri.mli b/analysis/src/uri.mli new file mode 100644 index 00000000000..ecf4cff770b --- /dev/null +++ b/analysis/src/uri.mli @@ -0,0 +1,10 @@ +type t = Lsp.Uri.t + +val from_path : string -> t +val from_string : string -> t +val is_interface : t -> bool +val strip_path : bool ref +val to_path : t -> string +val to_string : t -> string +val to_top_level_loc : t -> Location.t +val encode_u_r_i_component : string -> string diff --git a/analysis/src/Utils.ml b/analysis/src/utils.ml similarity index 73% rename from analysis/src/Utils.ml rename to analysis/src/utils.ml index a4bfc33bec2..18a26e3241b 100644 --- a/analysis/src/Utils.ml +++ b/analysis/src/utils.ml @@ -2,38 +2,38 @@ * `startsWith(string, prefix)` * true if the string starts with the prefix *) -let startsWith s prefix = +let starts_with s prefix = if prefix = "" then true else let p = String.length prefix in p <= String.length s && String.sub s 0 p = prefix -let endsWith s suffix = +let ends_with s suffix = if suffix = "" then true else let p = String.length suffix in let l = String.length s in p <= String.length s && String.sub s (l - p) p = suffix -let isFirstCharUppercase s = +let is_first_char_uppercase s = String.length s > 0 && Char.equal s.[0] (Char.uppercase_ascii s.[0]) -let cmtPosToPosition {Lexing.pos_lnum; pos_cnum; pos_bol} = +let cmt_pos_to_position {Lexing.pos_lnum; pos_cnum; pos_bol} = Lsp.Types.Position.create ~line:(pos_lnum - 1) ~character:(pos_cnum - pos_bol) -let cmtLocToRange {Location.loc_start; loc_end} = - let start = cmtPosToPosition loc_start in - let end_ = cmtPosToPosition loc_end in +let cmt_loc_to_range {Location.loc_start; loc_end} = + let start = cmt_pos_to_position loc_start in + let end_ = cmt_pos_to_position loc_end in Lsp.Types.Range.create ~start ~end_ -let endOfLocation loc length = +let end_of_location loc length = let open Location in { loc with loc_start = {loc.loc_end with pos_cnum = loc.loc_end.pos_cnum - length}; } -let chopLocationEnd loc length = +let chop_location_end loc length = let open Location in { loc with @@ -49,7 +49,7 @@ let rec find fn items = | None -> find fn rest | Some x -> Some x) -let filterMap f = +let filter_map f = let rec aux accu = function | [] -> List.rev accu | x :: l -> ( @@ -59,11 +59,11 @@ let filterMap f = in aux [] -let dumpPath path = Str.global_replace (Str.regexp_string "\\") "/" path -let isUncurriedInternal path = startsWith (Path.name path) "Js.Fn.arity" +let dump_path path = Str.global_replace (Str.regexp_string "\\") "/" path +let is_uncurried_internal path = starts_with (Path.name path) "Js.Fn.arity" -let flattenLongIdent ?(jsx = false) ?(cutAtOffset = None) lid = - let extendPath s path = +let flatten_long_ident ?(jsx = false) ?(cut_at_offset = None) lid = + let extend_path s path = match path with | "" :: _ -> path | _ -> s :: path @@ -73,16 +73,16 @@ let flattenLongIdent ?(jsx = false) ?(cutAtOffset = None) lid = | Longident.Lident txt -> ([txt], String.length txt) | Ldot (lid, txt) -> let path, offset = loop lid in - if Some offset = cutAtOffset then (extendPath "" path, offset + 1) + if Some offset = cut_at_offset then (extend_path "" path, offset + 1) else if jsx && txt = "createElement" then (path, offset) - else if txt = "_" then (extendPath "" path, offset + 1) - else (extendPath txt path, offset + 1 + String.length txt) + else if txt = "_" then (extend_path "" path, offset + 1) + else (extend_path txt path, offset + 1 + String.length txt) | Lapply _ -> ([], 0) in let path, _ = loop lid in List.rev path -let identifyPexp pexp = +let identify_pexp pexp = match pexp with | Parsetree.Pexp_ident _ -> "Pexp_ident" | Pexp_constant _ -> "Pexp_constant" @@ -119,7 +119,7 @@ let identifyPexp pexp = | Pexp_await _ -> "Pexp_await" | Pexp_jsx_element _ -> "Pexp_jsx_element" -let identifyPpat pat = +let identify_ppat pat = match pat with | Parsetree.Ppat_any -> "Ppat_any" | Ppat_var _ -> "Ppat_var" @@ -139,35 +139,36 @@ let identifyPpat pat = | Ppat_extension _ -> "Ppat_extension" | Ppat_open _ -> "Ppat_open" -let rec skipWhite text i = +let rec skip_white text i = if i < 0 then 0 else match text.[i] with - | ' ' | '\n' | '\r' | '\t' -> skipWhite text (i - 1) + | ' ' | '\n' | '\r' | '\t' -> skip_white text (i - 1) | _ -> i -let hasBraces attributes = +let has_braces attributes = attributes |> List.exists (fun (loc, _) -> loc.Location.txt = "res.braces") -let rec unwrapIfOption (t : Types.type_expr) = +let rec unwrap_if_option (t : Types.type_expr) = match t.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> unwrapIfOption t1 - | Tconstr (Path.Pident {name = "option"}, [unwrappedType], _) -> unwrappedType + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> unwrap_if_option t1 + | Tconstr (Path.Pident {name = "option"}, [unwrapped_type], _) -> + unwrapped_type | _ -> t -let isJsxComponent (vb : Parsetree.value_binding) = +let is_jsx_component (vb : Parsetree.value_binding) = vb.pvb_attributes |> List.exists (function | {Location.txt = "react.component" | "jsx.component"}, _payload -> true | _ -> false) -let checkName name ~prefix ~exact = - if exact then name = prefix else startsWith name prefix +let check_name name ~prefix ~exact = + if exact then name = prefix else starts_with name prefix -let rec getUnqualifiedName txt = +let rec get_unqualified_name txt = match txt with - | Longident.Lident fieldName -> fieldName - | Ldot (t, _) -> getUnqualifiedName t + | Longident.Lident field_name -> field_name + | Ldot (t, _) -> get_unqualified_name t | _ -> "" let indent n text = @@ -185,43 +186,43 @@ let indent n text = line ^ "\n" ^ (lines |> List.map (fun line -> spaces ^ line) |> String.concat "\n") -let mkPosition (pos : Pos.t) = +let mk_position (pos : Pos.t) = let line, character = pos in Lsp.Types.Position.create ~line ~character -let rangeOfLoc (loc : Location.t) = - let start = loc |> Loc.start |> mkPosition in - let end_ = loc |> Loc.end_ |> mkPosition in +let range_of_loc (loc : Location.t) = + let start = loc |> Loc.start |> mk_position in + let end_ = loc |> Loc.end_ |> mk_position in Lsp.Types.Range.create ~start ~end_ -let rec expandPath (path : Path.t) = +let rec expand_path (path : Path.t) = match path with | Pident id -> [Ident.name id] - | Pdot (p, s, _) -> s :: expandPath p + | Pdot (p, s, _) -> s :: expand_path p | Papply _ -> [] module Option = struct - let flatMap f o = + let flat_map f o = match o with | None -> None | Some v -> f v end -let rec lastElements list = +let rec last_elements list = match list with | ([_; _] | [_] | []) as res -> res - | _ :: tl -> lastElements tl + | _ :: tl -> last_elements tl -let lowercaseFirstChar s = +let lowercase_first_char s = if String.length s = 0 then s else String.mapi (fun i c -> if i = 0 then Char.lowercase_ascii c else c) s -let cutAfterDash s = +let cut_after_dash s = match String.index s '-' with | n -> ( try String.sub s 0 n with Invalid_argument _ -> s) | exception Not_found -> s -let fileNameHasUnallowedChars s = +let file_name_has_unallowed_chars s = let regexp = Str.regexp "[^A-Za-z0-9_]" in try ignore (Str.search_forward regexp s 0); @@ -233,24 +234,24 @@ let fileNameHasUnallowedChars s = Globals-RescriptBun.URL.t (which is an illegal path because of the namespace) becomes: RescriptBun.Globals.URL.t *) -let rec flattenAnyNamespaceInPath path = +let rec flatten_any_namespace_in_path path = match path with | [] -> [] | head :: tail -> if String.contains head '-' then let parts = String.split_on_char '-' head in (* Namespaces are in reverse order, so "URL-RescriptBun" where RescriptBun is the namespace. *) - (parts |> List.rev) @ flattenAnyNamespaceInPath tail - else head :: flattenAnyNamespaceInPath tail + (parts |> List.rev) @ flatten_any_namespace_in_path tail + else head :: flatten_any_namespace_in_path tail -let printMaybeExoticIdent ?(allowUident = false) txt = +let print_maybe_exotic_ident ?(allow_uident = false) txt = let len = String.length txt in let rec loop i = if i == len then txt else if i == 0 then match String.unsafe_get txt i with - | 'A' .. 'Z' when allowUident -> loop (i + 1) + | 'A' .. 'Z' when allow_uident -> loop (i + 1) | 'a' .. 'z' | '_' -> loop (i + 1) | _ -> "\"" ^ txt ^ "\"" else @@ -260,8 +261,8 @@ let printMaybeExoticIdent ?(allowUident = false) txt = in if Res_token.is_keyword_txt txt then "\"" ^ txt ^ "\"" else loop 0 -let findPackageJson root = - let path = Uri.toPath root in +let find_package_json root = + let path = Uri.to_path root in let rec loop path = if path = "/" then None diff --git a/analysis/src/xform.ml b/analysis/src/xform.ml new file mode 100644 index 00000000000..8b78dee94b9 --- /dev/null +++ b/analysis/src/xform.ml @@ -0,0 +1,954 @@ +(** Code transformations using the parser/printer and ast operations *) + +let is_braced_expr = Res_parsetree_viewer.is_braced_expr + +let extract_type_from_expr expr ~debug ~source ~kind_file ~full ~pos = + match + expr.Parsetree.pexp_loc + |> Completion_front_end.find_type_of_expression_at_loc ~debug ~source + ~kind_file + ~pos_cursor:(Pos.of_lexing expr.Parsetree.pexp_loc.loc_start) + with + | Some (completable, scope) -> ( + let env = Shared_types.Query_env.from_file full.Shared_types.file in + let completions = + completable + |> Completion_back_end.process_completable ~debug ~full ~pos ~scope ~env + ~for_hover:true + in + let raw_opens = Scope.get_raw_opens scope in + match completions with + | {env} :: _ -> ( + let opens = + Completion_back_end.get_opens ~debug ~raw_opens ~package:full.package + ~env + in + match + Completion_back_end.completions_get_completion_type2 ~debug ~full + ~raw_opens ~opens ~pos completions + with + | Some (typ, _env) -> + let extracted_type = + match typ with + | ExtractedType t -> Some t + | TypeExpr t -> + Type_utils.extract_type t ~env ~package:full.package + |> Type_utils.get_extracted_type + in + extracted_type + | None -> None) + | _ -> None) + | _ -> None + +module If_then_else = struct + (* Convert if-then-else to switch *) + + let rec list_to_pat ~item_to_pat = function + | [] -> Some [] + | x :: x_list -> ( + match (item_to_pat x, list_to_pat ~item_to_pat x_list) with + | Some p, Some p_list -> Some (p :: p_list) + | _ -> None) + + let rec exp_to_pat (exp : Parsetree.expression) = + let mk_pat ppat_desc = + Ast_helper.Pat.mk ~loc:exp.pexp_loc ~attrs:exp.pexp_attributes ppat_desc + in + match exp.pexp_desc with + | Pexp_construct (lid, None) -> Some (mk_pat (Ppat_construct (lid, None))) + | Pexp_construct (lid, Some e1) -> ( + match exp_to_pat e1 with + | None -> None + | Some p1 -> Some (mk_pat (Ppat_construct (lid, Some p1)))) + | Pexp_variant (label, None) -> Some (mk_pat (Ppat_variant (label, None))) + | Pexp_variant (label, Some e1) -> ( + match exp_to_pat e1 with + | None -> None + | Some p1 -> Some (mk_pat (Ppat_variant (label, Some p1)))) + | Pexp_constant c -> Some (mk_pat (Ppat_constant c)) + | Pexp_tuple e_list -> ( + match list_to_pat ~item_to_pat:exp_to_pat e_list with + | None -> None + | Some pat_list -> Some (mk_pat (Ppat_tuple pat_list))) + | Pexp_record (items, None) -> ( + let item_to_pat {Parsetree.lid; x = e; opt} = + match exp_to_pat e with + | None -> None + | Some p -> Some {Parsetree.lid; x = p; opt} + in + match list_to_pat ~item_to_pat items with + | None -> None + | Some pat_items -> Some (mk_pat (Ppat_record (pat_items, Closed)))) + | Pexp_record (_, Some _) -> None + | _ -> None + + let mk_iterator ~pos ~changed = + let expr (iterator : Ast_iterator.iterator) (e : Parsetree.expression) = + let new_exp = + match e.pexp_desc with + | Pexp_ifthenelse + ( { + pexp_desc = + Pexp_apply + { + funct = + { + pexp_desc = + Pexp_ident + {txt = Longident.Lident (("==" | "!=") as op)}; + }; + args = [(Nolabel, arg1); (Nolabel, arg2)]; + }; + }, + e1, + Some e2 ) + when Loc.has_pos ~pos e.pexp_loc -> ( + let e1, e2 = if op = "==" then (e1, e2) else (e2, e1) in + let mk_match ~arg ~pat = + let cases = + [ + Ast_helper.Exp.case pat e1; + Ast_helper.Exp.case (Ast_helper.Pat.any ()) e2; + ] + in + Ast_helper.Exp.match_ ~loc:e.pexp_loc ~attrs:e.pexp_attributes arg + cases + in + + match exp_to_pat arg2 with + | None -> ( + match exp_to_pat arg1 with + | None -> None + | Some pat1 -> + let new_exp = mk_match ~arg:arg2 ~pat:pat1 in + Some new_exp) + | Some pat2 -> + let new_exp = mk_match ~arg:arg1 ~pat:pat2 in + Some new_exp) + | _ -> None + in + match new_exp with + | Some new_exp -> changed := Some new_exp + | None -> Ast_iterator.default_iterator.expr iterator e + in + + {Ast_iterator.default_iterator with expr} + + let xform ~pos ~code_actions ~print_expr ~path structure = + let changed = ref None in + let iterator = mk_iterator ~pos ~changed in + iterator.structure iterator structure; + match !changed with + | None -> () + | Some new_expr -> + let range = Loc.range_of_loc new_expr.pexp_loc in + let new_text = print_expr ~range new_expr in + let code_action = + Code_actions.make ~title:"Replace with switch" ~kind:RefactorRewrite + ~uri:path ~new_text ~range + in + code_actions := code_action :: !code_actions +end + +module Module_to_file = struct + let mk_iterator ~pos ~changed ~path ~print_standalone_structure = + let structure_item (iterator : Ast_iterator.iterator) + (structure_item : Parsetree.structure_item) = + (match structure_item.pstr_desc with + | Pstr_module + {pmb_loc; pmb_name; pmb_expr = {pmod_desc = Pmod_structure structure}} + when structure_item.pstr_loc |> Loc.has_pos ~pos -> + let range = Loc.range_of_loc structure_item.pstr_loc in + let new_text_in_current_file = "" in + let text_for_extracted_file = + print_standalone_structure ~loc:pmb_loc structure + in + let module_name = pmb_name.txt in + let new_file_path = + Filename.concat (Filename.dirname path) module_name ^ ".res" + in + let uri = Uri.from_string new_file_path in + let document_changes = + [ + `CreateFile + (Lsp.Types.CreateFile.create ~uri + ~options: + (Lsp.Types.CreateFileOptions.create ~overwrite:false + ~ignoreIfExists:true ()) + ()); + `TextDocumentEdit + (Lsp.Types.TextDocumentEdit.create + ~edits: + [ + `TextEdit + (Lsp.Types.TextEdit.create ~range + ~newText:text_for_extracted_file); + ] + ~textDocument: + (Lsp.Types.OptionalVersionedTextDocumentIdentifier.create + ~uri ())); + `TextDocumentEdit + (Lsp.Types.TextDocumentEdit.create + ~edits: + [ + `TextEdit + (Lsp.Types.TextEdit.create ~range + ~newText:new_text_in_current_file); + ] + ~textDocument: + (Lsp.Types.OptionalVersionedTextDocumentIdentifier.create + ~uri:(Uri.from_string path) ())); + ] + in + changed := + Some + (Code_actions.make_with_document_changes + ~title: + (Printf.sprintf "Extract local module \"%s\" to file \"%s\"" + module_name (module_name ^ ".res")) + ~kind:RefactorRewrite ~document_changes); + () + | _ -> ()); + Ast_iterator.default_iterator.structure_item iterator structure_item + in + + {Ast_iterator.default_iterator with structure_item} + + let xform ~pos ~code_actions ~path ~print_standalone_structure structure = + let changed = ref None in + let iterator = + mk_iterator ~pos ~path ~changed ~print_standalone_structure + in + iterator.structure iterator structure; + match !changed with + | None -> () + | Some code_action -> code_actions := code_action :: !code_actions +end + +module Add_braces_to_fn = struct + (* Add braces to fn without braces *) + + let mk_iterator ~pos ~changed = + (* While iterating the AST, keep info on which structure item we are in. + Printing from the structure item, rather than the body of the function, + gives better local pretty printing *) + let current_structure_item = ref None in + + let structure_item (iterator : Ast_iterator.iterator) + (item : Parsetree.structure_item) = + let saved = !current_structure_item in + current_structure_item := Some item; + Ast_iterator.default_iterator.structure_item iterator item; + current_structure_item := saved + in + let expr (iterator : Ast_iterator.iterator) (e : Parsetree.expression) = + let braces_attribute = + let loc = + { + Location.none with + loc_start = Lexing.dummy_pos; + loc_end = + { + Lexing.dummy_pos with + pos_lnum = Lexing.dummy_pos.pos_lnum + 1 (* force line break *); + }; + } + in + (Location.mkloc "res.braces" loc, Parsetree.PStr []) + in + let is_function = function + | {Parsetree.pexp_desc = Pexp_fun _} -> true + | _ -> false + in + (match e.pexp_desc with + | Pexp_fun {rhs = body_expr} + when Loc.has_pos ~pos body_expr.pexp_loc + && is_braced_expr body_expr = false + && is_function body_expr = false -> + body_expr.pexp_attributes <- + braces_attribute :: body_expr.pexp_attributes; + changed := !current_structure_item + | _ -> ()); + Ast_iterator.default_iterator.expr iterator e + in + + {Ast_iterator.default_iterator with expr; structure_item} + + let xform ~pos ~code_actions ~path ~print_structure_item structure = + let changed = ref None in + let iterator = mk_iterator ~pos ~changed in + iterator.structure iterator structure; + match !changed with + | None -> () + | Some new_structure_item -> + let range = Loc.range_of_loc new_structure_item.pstr_loc in + let new_text = print_structure_item ~range new_structure_item in + let code_action = + Code_actions.make ~title:"Add braces to function" ~kind:RefactorRewrite + ~uri:path ~new_text ~range + in + code_actions := code_action :: !code_actions +end + +module Add_type_annotation = struct + (* Add type annotation to value declaration *) + + type annotation = Plain | WithParens + + let mk_iterator ~pos ~result = + let process_pattern ?(is_unlabeled_only_arg = false) + (pat : Parsetree.pattern) = + match pat.ppat_desc with + | Ppat_var {loc} when Loc.has_pos ~pos loc -> + result := Some (if is_unlabeled_only_arg then WithParens else Plain) + | _ -> () + in + let rec process_function ~arg_num (e : Parsetree.expression) = + match e.pexp_desc with + | Pexp_fun {arg_label; lhs = pat; rhs = e} -> + let is_unlabeled_only_arg = + arg_num = 1 && arg_label = Nolabel + && + match e.pexp_desc with + | Pexp_fun _ -> false + | _ -> true + in + process_pattern ~is_unlabeled_only_arg pat; + process_function ~arg_num:(arg_num + 1) e + | _ -> () + in + let structure_item (iterator : Ast_iterator.iterator) + (si : Parsetree.structure_item) = + match si.pstr_desc with + | Pstr_value (_recFlag, bindings) -> + let process_binding (vb : Parsetree.value_binding) = + (* Can't add a type annotation to a jsx component, or the compiler crashes *) + let is_jsx_component = Utils.is_jsx_component vb in + if not is_jsx_component then process_pattern vb.pvb_pat; + process_function vb.pvb_expr + in + bindings |> List.iter (process_binding ~arg_num:1); + Ast_iterator.default_iterator.structure_item iterator si + | _ -> Ast_iterator.default_iterator.structure_item iterator si + in + {Ast_iterator.default_iterator with structure_item} + + let xform ~path ~pos ~full ~structure ~code_actions ~debug = + let result = ref None in + let iterator = mk_iterator ~pos ~result in + iterator.structure iterator structure; + match !result with + | None -> () + | Some annotation -> ( + match References.get_loc_item ~full ~pos ~debug with + | None -> () + | Some loc_item -> ( + match loc_item.loc_type with + | Typed (name, typ, _) -> + let range, new_text = + match annotation with + | Plain -> + ( Loc.range_of_loc + {loc_item.loc with loc_start = loc_item.loc.loc_end}, + ": " ^ (typ |> Shared.type_to_string) ) + | WithParens -> + ( Loc.range_of_loc loc_item.loc, + "(" ^ name ^ ": " ^ (typ |> Shared.type_to_string) ^ ")" ) + in + let code_action = + Code_actions.make ~title:"Add type annotation" ~kind:RefactorRewrite + ~uri:path ~new_text ~range + in + code_actions := code_action :: !code_actions + | _ -> ())) +end + +module Expand_catch_all_for_variants = struct + let mk_iterator ~pos ~result = + let expr (iterator : Ast_iterator.iterator) (e : Parsetree.expression) = + (if e.pexp_loc |> Loc.has_pos ~pos then + match e.pexp_desc with + | Pexp_match (switch_expr, cases) -> ( + let catch_all_case = + cases + |> List.find_opt (fun (c : Parsetree.case) -> + match c with + | {pc_lhs = {ppat_desc = Ppat_any}} -> true + | _ -> false) + in + match catch_all_case with + | None -> () + | Some catch_all_case -> + result := Some (switch_expr, catch_all_case, cases)) + | _ -> ()); + Ast_iterator.default_iterator.expr iterator e + in + {Ast_iterator.default_iterator with expr} + + let xform ~source ~kind_file ~path ~pos ~full ~structure ~code_actions ~debug + = + let result = ref None in + let iterator = mk_iterator ~pos ~result in + iterator.structure iterator structure; + match !result with + | None -> () + | Some (switch_expr, catch_all_case, cases) -> ( + if Debug.verbose () then + print_endline + "[codeAction - ExpandCatchAllForVariants] Found target switch"; + let rec find_all_constructor_names + ?(mode : [`option | `default] = `default) ?(constructor_names = []) + (p : Parsetree.pattern) = + match p.ppat_desc with + | Ppat_construct ({txt = Lident "Some"}, Some payload) + when mode = `option -> + find_all_constructor_names ~mode ~constructor_names payload + | Ppat_construct ({txt}, _) -> Longident.last txt :: constructor_names + | Ppat_variant (name, _) -> name :: constructor_names + | Ppat_or (a, b) -> + find_all_constructor_names ~mode ~constructor_names a + @ find_all_constructor_names ~mode ~constructor_names b + @ constructor_names + | _ -> constructor_names + in + let get_current_constructor_names ?mode cases = + cases + |> List.map (fun (c : Parsetree.case) -> + if Option.is_some c.pc_guard then [] + else find_all_constructor_names ?mode c.pc_lhs) + |> List.flatten + in + let current_constructor_names = get_current_constructor_names cases in + match + switch_expr + |> extract_type_from_expr ~debug ~source ~kind_file ~full + ~pos:(Pos.of_lexing switch_expr.pexp_loc.loc_end) + with + | Some (Tvariant {constructors}) -> + let missing_constructors = + constructors + |> List.filter (fun (c : Shared_types.Constructor.t) -> + current_constructor_names |> List.mem c.cname.txt = false) + in + if List.length missing_constructors > 0 then + let new_text = + missing_constructors + |> List.map (fun (c : Shared_types.Constructor.t) -> + c.cname.txt + ^ + match c.args with + | Args [] -> "" + | Args _ | InlineRecord _ -> "(_)") + |> String.concat " | " + in + let range = Loc.range_of_loc catch_all_case.pc_lhs.ppat_loc in + let code_action = + Code_actions.make ~title:"Expand catch-all" ~kind:RefactorRewrite + ~uri:path ~new_text ~range + in + code_actions := code_action :: !code_actions + else () + | Some (Tpolyvariant {constructors}) -> + let missing_constructors = + constructors + |> List.filter (fun (c : Shared_types.poly_variant_constructor) -> + current_constructor_names |> List.mem c.name = false) + in + if List.length missing_constructors > 0 then + let new_text = + missing_constructors + |> List.map (fun (c : Shared_types.poly_variant_constructor) -> + Res_printer.polyvar_ident_to_string c.name + ^ + match c.args with + | [] -> "" + | _ -> "(_)") + |> String.concat " | " + in + let range = Loc.range_of_loc catch_all_case.pc_lhs.ppat_loc in + let code_action = + Code_actions.make ~title:"Expand catch-all" ~kind:RefactorRewrite + ~uri:path ~new_text ~range + in + code_actions := code_action :: !code_actions + else () + | Some (Toption (env, inner_type)) -> ( + if Debug.verbose () then + print_endline + "[codeAction - ExpandCatchAllForVariants] Found option type"; + let inner_type = + match inner_type with + | ExtractedType t -> Some t + | TypeExpr t -> ( + match Type_utils.extract_type ~env ~package:full.package t with + | None -> None + | Some (t, _) -> Some t) + in + match inner_type with + | Some ((Tvariant _ | Tpolyvariant _) as variant) -> + let current_constructor_names = + get_current_constructor_names ~mode:`option cases + in + let has_none_case = + cases + |> List.exists (fun (c : Parsetree.case) -> + match c.pc_lhs.ppat_desc with + | Ppat_construct ({txt = Lident "None"}, _) -> true + | _ -> false) + in + let missing_constructors = + match variant with + | Tvariant {constructors} -> + constructors + |> List.filter_map (fun (c : Shared_types.Constructor.t) -> + if + current_constructor_names |> List.mem c.cname.txt = false + then + Some + ( c.cname.txt, + match c.args with + | Args [] -> false + | _ -> true ) + else None) + | Tpolyvariant {constructors} -> + constructors + |> List.filter_map + (fun (c : Shared_types.poly_variant_constructor) -> + if current_constructor_names |> List.mem c.name = false + then + Some + ( Res_printer.polyvar_ident_to_string c.name, + match c.args with + | [] -> false + | _ -> true ) + else None) + | _ -> [] + in + if List.length missing_constructors > 0 || not has_none_case then + let new_text = + "Some(" + ^ (missing_constructors + |> List.map (fun (name, has_args) -> + name ^ if has_args then "(_)" else "") + |> String.concat " | ") + ^ ")" + in + let new_text = + if has_none_case then new_text else new_text ^ " | None" + in + let range = Loc.range_of_loc catch_all_case.pc_lhs.ppat_loc in + let code_action = + Code_actions.make ~title:"Expand catch-all" ~kind:RefactorRewrite + ~uri:path ~new_text ~range + in + code_actions := code_action :: !code_actions + else () + | _ -> ()) + | _ -> ()) +end + +module Exhaustive_switch = struct + (* Expand expression to be an exhaustive switch of the underlying value *) + type pos_type = Single of Pos.t | Range of Pos.t * Pos.t + + type completion_type = + | Switch of { + pos: Pos.t; + switch_expr: Parsetree.expression; + completion_expr: Parsetree.expression; + } + | Selection of {expr: Parsetree.expression} + + let mk_iterator_single ~pos ~result = + let expr (iterator : Ast_iterator.iterator) (exp : Parsetree.expression) = + (match exp.pexp_desc with + | Pexp_ident _ when Loc.has_pos_inclusive_end ~pos exp.pexp_loc -> + (* Exhaustive switch for having the cursor on an identifier. *) + result := Some (Selection {expr = exp}) + | Pexp_match (completion_expr, []) + when Loc.has_pos_inclusive_end ~pos exp.pexp_loc -> + (* No cases means there's no `|` yet in the switch, so `switch someExpr` *) + result := Some (Switch {pos; switch_expr = exp; completion_expr}) + | _ -> ()); + Ast_iterator.default_iterator.expr iterator exp + in + {Ast_iterator.default_iterator with expr} + + let mk_iterator_range ~start_pos ~end_pos ~found_selection = + let expr (iterator : Ast_iterator.iterator) (exp : Parsetree.expression) = + let exp_start_pos = Pos.of_lexing exp.pexp_loc.loc_start in + let exp_end_pos = Pos.of_lexing exp.pexp_loc.loc_end in + + (if exp_start_pos = start_pos then + match !found_selection with + | None, end_expr -> found_selection := (Some exp, end_expr) + | _ -> ()); + + (if exp_end_pos = end_pos then + match !found_selection with + | start_exp, _ -> found_selection := (start_exp, Some exp)); + + Ast_iterator.default_iterator.expr iterator exp + in + {Ast_iterator.default_iterator with expr} + + let xform ~print_expr ~path ~source ~kind_file ~pos ~full ~structure + ~code_actions ~debug = + (* TODO: Adapt to '(' as leading/trailing character (skip one col, it's not included in the AST) *) + let result = ref None in + let found_selection = ref (None, None) in + let iterator = + match pos with + | Single pos -> mk_iterator_single ~pos ~result + | Range (start_pos, end_pos) -> + mk_iterator_range ~start_pos ~end_pos ~found_selection + in + iterator.structure iterator structure; + (match !found_selection with + | Some start_exp, Some end_exp -> + if debug then + Printf.printf "found selection: %s -> %s\n" + (Loc.to_string start_exp.pexp_loc) + (Loc.to_string end_exp.pexp_loc); + result := Some (Selection {expr = start_exp}) + | _ -> ()); + match !result with + | None -> () + | Some (Selection {expr}) -> ( + match + expr + |> extract_type_from_expr ~debug ~source ~kind_file ~full + ~pos:(Pos.of_lexing expr.pexp_loc.loc_start) + with + | None -> () + | Some extracted_type -> ( + let open Type_utils.Codegen in + let exhaustive_switch = + extracted_type_to_exhaustive_cases + ~env:(Shared_types.Query_env.from_file full.file) + ~full extracted_type + in + match exhaustive_switch with + | None -> () + | Some cases -> + let range = Loc.range_of_loc expr.pexp_loc in + let new_text = + print_expr ~range {expr with pexp_desc = Pexp_match (expr, cases)} + in + let code_action = + Code_actions.make ~title:"Exhaustive switch" ~kind:RefactorRewrite + ~uri:path ~new_text ~range + in + code_actions := code_action :: !code_actions)) + | Some (Switch {switch_expr; completion_expr; pos}) -> ( + match + completion_expr + |> extract_type_from_expr ~debug ~source ~kind_file ~full ~pos + with + | None -> () + | Some extracted_type -> ( + let open Type_utils.Codegen in + let exhaustive_switch = + extracted_type_to_exhaustive_cases + ~env:(Shared_types.Query_env.from_file full.file) + ~full extracted_type + in + match exhaustive_switch with + | None -> () + | Some cases -> + let range = Loc.range_of_loc switch_expr.pexp_loc in + let new_text = + print_expr ~range + {switch_expr with pexp_desc = Pexp_match (completion_expr, cases)} + in + let code_action = + Code_actions.make ~title:"Exhaustive switch" ~kind:RefactorRewrite + ~uri:path ~new_text ~range + in + code_actions := code_action :: !code_actions)) +end + +module Add_doc_template = struct + let create_template () = + let doc_content = ["\n"; "\n"] in + let expression = + Ast_helper.Exp.constant + (Parsetree.Pconst_string (String.concat "" doc_content, None)) + in + let structure_item_desc = Parsetree.Pstr_eval (expression, []) in + let structure_item = Ast_helper.Str.mk structure_item_desc in + let attr_loc = + { + Location.none with + loc_start = Lexing.dummy_pos; + loc_end = + { + Lexing.dummy_pos with + pos_lnum = Lexing.dummy_pos.pos_lnum (* force line break *); + }; + } + in + (Location.mkloc "res.doc" attr_loc, Parsetree.PStr [structure_item]) + + module Interface = struct + let mk_iterator ~pos ~result = + let signature_item (iterator : Ast_iterator.iterator) + (item : Parsetree.signature_item) = + match item.psig_desc with + | Psig_value value_description as r + when Loc.has_pos ~pos value_description.pval_loc + && Process_attributes.find_doc_attribute + value_description.pval_attributes + = None -> + result := Some (r, item.psig_loc) + | Psig_type (_, hd :: _) as r + when Loc.has_pos ~pos hd.ptype_loc + && Process_attributes.find_doc_attribute hd.ptype_attributes + = None -> + result := Some (r, item.psig_loc) + | Psig_module {pmd_name = {loc}} as r -> + if Loc.start loc = pos then result := Some (r, item.psig_loc) + else Ast_iterator.default_iterator.signature_item iterator item + | _ -> Ast_iterator.default_iterator.signature_item iterator item + in + {Ast_iterator.default_iterator with signature_item} + + let process_sig_value (value_desc : Parsetree.value_description) loc = + let attr = create_template () in + let new_value_binding = + {value_desc with pval_attributes = attr :: value_desc.pval_attributes} + in + let signature_item_desc = Parsetree.Psig_value new_value_binding in + Ast_helper.Sig.mk ~loc signature_item_desc + + let process_type_decl (typ : Parsetree.type_declaration) = + let attr = create_template () in + let new_type_declaration = + {typ with ptype_attributes = attr :: typ.ptype_attributes} + in + new_type_declaration + + let process_mod_decl (mod_decl : Parsetree.module_declaration) loc = + let attr = create_template () in + let new_mod_decl = + {mod_decl with pmd_attributes = attr :: mod_decl.pmd_attributes} + in + Ast_helper.Sig.mk ~loc (Parsetree.Psig_module new_mod_decl) + + let xform ~path ~pos ~code_actions ~signature ~print_signature_item = + let result = ref None in + let iterator = mk_iterator ~pos ~result in + iterator.signature iterator signature; + match !result with + | Some (signature_item, loc) -> ( + let new_signature_item = + match signature_item with + | Psig_value value_desc -> + Some (process_sig_value value_desc value_desc.pval_loc) + (* Some loc *) + | Psig_type (flag, hd :: tl) -> + let new_first_type_decl = process_type_decl hd in + Some + (Ast_helper.Sig.mk ~loc + (Parsetree.Psig_type (flag, new_first_type_decl :: tl))) + | Psig_module mod_decl -> Some (process_mod_decl mod_decl loc) + | _ -> None + in + + match new_signature_item with + | Some signature_item -> + let range = Loc.range_of_loc signature_item.psig_loc in + let new_text = print_signature_item ~range signature_item in + let code_action = + Code_actions.make ~title:"Add Documentation template" + ~kind:RefactorRewrite ~uri:path ~new_text ~range + in + code_actions := code_action :: !code_actions + | None -> ()) + | None -> () + end + + module Implementation = struct + let mk_iterator ~pos ~result = + let structure_item (iterator : Ast_iterator.iterator) + (si : Parsetree.structure_item) = + match si.pstr_desc with + | Pstr_value (_, {pvb_pat = {ppat_loc}; pvb_attributes} :: _) as r + when Loc.has_pos ~pos ppat_loc + && Process_attributes.find_doc_attribute pvb_attributes = None -> + result := Some (r, si.pstr_loc) + | Pstr_primitive value_description as r + when Loc.has_pos ~pos value_description.pval_loc + && Process_attributes.find_doc_attribute + value_description.pval_attributes + = None -> + result := Some (r, si.pstr_loc) + | Pstr_module {pmb_name = {loc}} as r -> + if Loc.start loc = pos then result := Some (r, si.pstr_loc) + else Ast_iterator.default_iterator.structure_item iterator si + | Pstr_type (_, hd :: _) as r + when Loc.has_pos ~pos hd.ptype_loc + && Process_attributes.find_doc_attribute hd.ptype_attributes + = None -> + result := Some (r, si.pstr_loc) + | _ -> Ast_iterator.default_iterator.structure_item iterator si + in + {Ast_iterator.default_iterator with structure_item} + + let process_value_binding (value_binding : Parsetree.value_binding) = + let attr = create_template () in + let new_value_binding = + { + value_binding with + pvb_attributes = attr :: value_binding.pvb_attributes; + } + in + new_value_binding + + let process_primitive (value_desc : Parsetree.value_description) loc = + let attr = create_template () in + let new_value_desc = + {value_desc with pval_attributes = attr :: value_desc.pval_attributes} + in + Ast_helper.Str.primitive ~loc new_value_desc + + let process_module_binding (mod_bind : Parsetree.module_binding) loc = + let attr = create_template () in + let new_mod_binding = + {mod_bind with pmb_attributes = attr :: mod_bind.pmb_attributes} + in + Ast_helper.Str.module_ ~loc new_mod_binding + + let xform ~pos ~code_actions ~path ~print_structure_item ~structure = + let result = ref None in + let iterator = mk_iterator ~pos ~result in + iterator.structure iterator structure; + match !result with + | None -> () + | Some (structure_item, loc) -> ( + let new_structure_item = + match structure_item with + | Pstr_value (flag, hd :: tl) -> + let new_value_binding = process_value_binding hd in + Some + (Ast_helper.Str.mk ~loc + (Parsetree.Pstr_value (flag, new_value_binding :: tl))) + | Pstr_primitive value_desc -> Some (process_primitive value_desc loc) + | Pstr_module mod_bind -> Some (process_module_binding mod_bind loc) + | Pstr_type (flag, hd :: tl) -> + let new_first_type_decl = Interface.process_type_decl hd in + Some + (Ast_helper.Str.mk ~loc + (Parsetree.Pstr_type (flag, new_first_type_decl :: tl))) + | _ -> None + in + + match new_structure_item with + | Some structure_item -> + let range = Loc.range_of_loc structure_item.pstr_loc in + let new_text = print_structure_item ~range structure_item in + let code_action = + Code_actions.make ~title:"Add Documentation template" + ~kind:RefactorRewrite ~uri:path ~new_text ~range + in + code_actions := code_action :: !code_actions + | None -> ()) + end +end + +let parse_implementation ~source = + let {Res_driver.parsetree = structure; comments} = + Res_driver.parsing_engine.parse_implementation_from_source + ~for_printer:false ~source + in + let filter_comments ~loc comments = + (* Relevant comments in the range of the expression *) + let filter comment = + Loc.has_pos ~pos:(Loc.start (Res_comment.loc comment)) loc + in + comments |> List.filter filter + in + let print_expr ~(range : Lsp.Types.Range.t) (expr : Parsetree.expression) = + let structure = [Ast_helper.Str.eval ~loc:expr.pexp_loc expr] in + structure + |> Res_printer.print_implementation + ~comments:(comments |> filter_comments ~loc:expr.pexp_loc) + |> Utils.indent range.start.character + in + let print_structure_item ~(range : Lsp.Types.Range.t) + (item : Parsetree.structure_item) = + let structure = [item] in + structure + |> Res_printer.print_implementation + ~comments:(comments |> filter_comments ~loc:item.pstr_loc) + |> Utils.indent range.start.character + in + let print_standalone_structure ~(loc : Location.t) structure = + structure + |> Res_printer.print_implementation + ~comments:(comments |> filter_comments ~loc) + in + (structure, print_expr, print_structure_item, print_standalone_structure) + +let parse_interface ~source = + let {Res_driver.parsetree = structure; comments} = + Res_driver.parsing_engine.parse_interface_from_source ~for_printer:false + ~source + in + let filter_comments ~loc comments = + (* Relevant comments in the range of the expression *) + let filter comment = + Loc.has_pos ~pos:(Loc.start (Res_comment.loc comment)) loc + in + comments |> List.filter filter + in + let print_signature_item ~(range : Lsp.Types.Range.t) + (item : Parsetree.signature_item) = + let signature_item = [item] in + signature_item + |> Res_printer.print_interface + ~comments:(comments |> filter_comments ~loc:item.psig_loc) + |> Utils.indent range.start.character + in + (structure, print_signature_item) + +let extract_code_actions ~path ~start_pos ~end_pos ~source ~kind_file ~debug = + let pos = start_pos in + let code_actions = ref [] in + match kind_file with + | Files.Res -> + let structure, print_expr, print_structure_item, print_standalone_structure + = + parse_implementation ~source + in + If_then_else.xform ~pos ~code_actions ~print_expr ~path structure; + Module_to_file.xform ~pos ~code_actions ~path ~print_standalone_structure + structure; + Add_braces_to_fn.xform ~pos ~code_actions ~path ~print_structure_item + structure; + Add_doc_template.Implementation.xform ~pos ~code_actions ~path + ~print_structure_item ~structure; + + (* This Code Action needs type info *) + let () = + match Cmt.load_full_cmt_from_path ~path with + | Some full -> + Add_type_annotation.xform ~path ~pos ~full ~structure ~code_actions + ~debug; + Expand_catch_all_for_variants.xform ~path ~source ~kind_file ~pos ~full + ~structure ~code_actions ~debug; + Exhaustive_switch.xform ~print_expr ~path ~source ~kind_file + ~pos: + (if start_pos = end_pos then Single start_pos + else Range (start_pos, end_pos)) + ~full ~structure ~code_actions ~debug + | None -> () + in + + !code_actions + | Resi -> + let signature, print_signature_item = parse_interface ~source in + Add_doc_template.Interface.xform ~pos ~code_actions ~path ~signature + ~print_signature_item; + !code_actions + | Other -> [] diff --git a/analysis/src/yojson_helpers.ml b/analysis/src/yojson_helpers.ml new file mode 100644 index 00000000000..b45b7331e6e --- /dev/null +++ b/analysis/src/yojson_helpers.ml @@ -0,0 +1 @@ +include Reanalyze.Yojson_helpers diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index 67fbc0043de..419bdd4c5ff 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -266,7 +266,7 @@ let command_line_flags : (string * Bsc_args.spec * string) array = ( "-bs-project-root", string_call (fun s -> Ext_path.project_root := Some s; - GenTypeConfig.project_root := s), + Gen_type_config.project_root := s), "*internal* Set the project root directory" ); ( "-bs-ast", unit_call (fun _ -> @@ -300,26 +300,26 @@ let command_line_flags : (string * Bsc_args.spec * string) array = ("-bs-gentype", set Clflags.bs_gentype, "*internal* Pass gentype command"); ( "-bs-gentype-module", string_call (fun s -> - GenTypeConfig.module_flag := GenTypeConfig.module_of_string s), + Gen_type_config.module_flag := Gen_type_config.module_of_string s), "*internal* Set gentype module system: commonjs|esmodule" ); ( "-bs-gentype-module-resolution", string_call (fun s -> - GenTypeConfig.module_resolution_flag := - GenTypeConfig.module_resolution_of_string s), + Gen_type_config.module_resolution_flag := + Gen_type_config.module_resolution_of_string s), "*internal* Set gentype module resolution strategy: node|node16|bundler" ); ( "-bs-gentype-export-interfaces", - set GenTypeConfig.export_interfaces_flag, + set Gen_type_config.export_interfaces_flag, "*internal* Emit gentype interface files" ); ( "-bs-gentype-generated-extension", string_call (fun s -> - GenTypeConfig.generated_file_extension_flag := Some s), + Gen_type_config.generated_file_extension_flag := Some s), "*internal* Set gentype generated-file extension (e.g. .gen.tsx)" ); ( "-bs-gentype-suffix", - string_call (fun s -> GenTypeConfig.suffix_flag := Some s), + string_call (fun s -> Gen_type_config.suffix_flag := Some s), "*internal* Set gentype import-path suffix (e.g. .bs.js, .mjs)" ); ( "-bs-gentype-shim", - string_call GenTypeConfig.add_shim, + string_call Gen_type_config.add_shim, "*internal* Register a gentype shim mapping: From=To (repeatable)" ); ( "-bs-gentype-debug", string_call Debug.set_item, @@ -327,18 +327,18 @@ let command_line_flags : (string * Bsc_args.spec * string) array = all|basic|codeItems|config|converter|dependencies|moduleResolution|notImplemented|translation|typeEnv|typeResolution" ); ( "-bs-gentype-dep", - string_call GenTypeConfig.add_bs_dependency, + string_call Gen_type_config.add_bs_dependency, "*internal* Register a gentype bsb dependency (repeatable)" ); ( "-bs-gentype-source-dir", - string_call GenTypeConfig.add_source_dir, + string_call Gen_type_config.add_source_dir, "*internal* Register a gentype source directory relative to the project \ root (repeatable)" ); ( "-bs-gentype-dep-path", - string_call GenTypeConfig.add_dep_path, + string_call Gen_type_config.add_dep_path, "*internal* Register a gentype dependency install path: \ = (repeatable)" ); ( "-bs-gentype-bsb-project-root", - string_call (fun s -> GenTypeConfig.bsb_project_root := s), + string_call (fun s -> Gen_type_config.bsb_project_root := s), "*internal* Set gentype bsb project root (workspace root containing \ .sourcedirs.json)" ); (******************************************************************************) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 4310b1f80d1..6f6da8b605c 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -524,10 +524,10 @@ and expression_desc cxt ~(level : int) f x : cxt = ( ({ expression_desc = J.Var - ( Id {name = fnName} + ( Id {name = fn_name} | J.Qualified ( _, - Some fnName + Some fn_name (* We care about the function name when it is jsxs, If this is the case, we need to unpack an array later on *) ) ); @@ -552,7 +552,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | Undefined _ when opt -> None | _ -> Some (f, x)) in - print_jsx cxt ~level f fnName tag fields + print_jsx cxt ~level f fn_name tag fields | [ tag; { @@ -568,7 +568,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | Undefined _ when opt -> None | _ -> Some (f, x)) in - print_jsx cxt ~level ~key f fnName tag fields + print_jsx cxt ~level ~key f fn_name tag fields | [tag; ({expression_desc = J.Seq _} as props)] -> (* In the case of prop spreading, the expression will look like: (props.a = "Hello, world!", props) @@ -594,7 +594,7 @@ and expression_desc cxt ~(level : int) f x : cxt = in visit [] props in - print_jsx cxt ~level ~spread_props f fnName tag fields + print_jsx cxt ~level ~spread_props f fn_name tag fields | [tag; ({expression_desc = J.Seq _} as props); key] -> (* In the case of props + prop spreading and key argument *) let fields, spread_props = @@ -614,10 +614,10 @@ and expression_desc cxt ~(level : int) f x : cxt = in visit [] props in - print_jsx cxt ~level ~spread_props ~key f fnName tag fields + print_jsx cxt ~level ~spread_props ~key f fn_name tag fields | [tag; ({expression_desc = J.Var _} as spread_props)] -> (* All the props are spread *) - print_jsx cxt ~level ~spread_props f fnName tag [] + print_jsx cxt ~level ~spread_props f fn_name tag [] | _ -> (* This should not happen, we fallback to the general case *) expression_desc cxt ~level f @@ -1094,7 +1094,7 @@ and print_indented_list (f : P.t) (parent_expr_level : int) (cxt : cxt) process_items cxt items) and print_jsx cxt ?(spread_props : J.expression option) - ?(key : J.expression option) ~(level : int) f (fnName : string) + ?(key : J.expression option) ~(level : int) f (fn_name : string) (tag : J.expression) (fields : (string * J.expression) list) : cxt = (* TODO: make fragment detection respect custom JSX runtime modules instead of assuming "JsxRuntime". *) @@ -1119,7 +1119,7 @@ and print_jsx cxt ?(spread_props : J.expression option) List.find_map (fun (n, e) -> if n = "children" then - if fnName = "jsxs" then + if fn_name = "jsxs" then match e.J.expression_desc with | J.Array (xs, _) | J.Optional_block ({expression_desc = J.Array (xs, _)}, _) -> diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index 210c0a58dd9..530765477ed 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -1275,7 +1275,7 @@ let tag_type = function (* TODO: this should not happen *) assert false -let rec emit_check (check : t Ast_untagged_variants.DynamicChecks.t) = +let rec emit_check (check : t Ast_untagged_variants.Dynamic_checks.t) = match check with | TagType t -> tag_type t | BinOp (op, x, y) -> @@ -1297,14 +1297,14 @@ let rec emit_check (check : t Ast_untagged_variants.DynamicChecks.t) = let is_a_literal_case ~literal_cases ~block_cases (e : t) = let check = - Ast_untagged_variants.DynamicChecks.is_a_literal_case ~literal_cases + Ast_untagged_variants.Dynamic_checks.is_a_literal_case ~literal_cases ~block_cases (Expr e) in emit_check check let is_int_tag ?has_null_undefined_other e = let check = - Ast_untagged_variants.DynamicChecks.is_int_tag ?has_null_undefined_other + Ast_untagged_variants.Dynamic_checks.is_int_tag ?has_null_undefined_other (Expr e) in emit_check check diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index ec208532a59..d37d55ea9a8 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -202,7 +202,7 @@ val assign : ?comment:string -> t -> t -> t val tag_type : Ast_untagged_variants.tag_type -> t -val emit_check : t Ast_untagged_variants.DynamicChecks.t -> t +val emit_check : t Ast_untagged_variants.Dynamic_checks.t -> t val triple_equal : ?comment:string -> t -> t -> t (* TODO: reduce [triple_equal] use *) diff --git a/compiler/core/js_implementation.ml b/compiler/core/js_implementation.ml index 5f4e4e6c765..ec7ef0c2e62 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -31,7 +31,7 @@ let print_if_pipe ppf flag printer arg = let print_if ppf flag printer arg = if !flag then fprintf ppf "%a@." printer arg let process_with_gentype cmt_file = - if !Clflags.bs_gentype then GenTypeMain.process_cmt_file cmt_file + if !Clflags.bs_gentype then Gen_type_main.process_cmt_file cmt_file let after_parsing_sig ppf outputprefix ast = if !Clflags.only_parse = false then ( diff --git a/compiler/core/js_pass_external_shadow.ml b/compiler/core/js_pass_external_shadow.ml index 1415a14c52a..1fe994506cb 100644 --- a/compiler/core/js_pass_external_shadow.ml +++ b/compiler/core/js_pass_external_shadow.ml @@ -24,7 +24,7 @@ module E = Js_exp_make -module StringSet = Set.Make (String) +module String_set = Set.Make (String) let global_this = E.js_global "globalThis" @@ -58,12 +58,12 @@ let rewrite_shadowed_global_in_expr ~(name : string) (expr : J.expression) : let program (js : J.program) : J.program = let shadowed_globals = - Ext_list.fold_left js.block StringSet.empty (fun acc (st : J.statement) -> + Ext_list.fold_left js.block String_set.empty (fun acc (st : J.statement) -> match st.statement_desc with | Variable {ident; property} when is_lexical_binding_kind property && should_rewrite_binding ident -> - StringSet.add ident.name acc + String_set.add ident.name acc | _ -> acc) in let super = Js_record_map.super in @@ -79,7 +79,7 @@ let program (js : J.program) : J.program = match obj.expression_desc with | Var (Id id) when Ext_ident.is_js id - && StringSet.mem id.name shadowed_globals -> + && String_set.mem id.name shadowed_globals -> E.dot global_this id.name | _ -> obj in diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 9897f0c01e4..97f6bec84e5 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -803,12 +803,12 @@ let compile output_prefix = let check = match (i, j) with | Some tag_type, _ -> - Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type + Ast_untagged_variants.Dynamic_checks.add_runtime_type_check ~tag_type ~has_null_case ~block_cases (Expr x) (Expr y) | _, Some tag_type -> - Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type + Ast_untagged_variants.Dynamic_checks.add_runtime_type_check ~tag_type ~has_null_case ~block_cases (Expr y) (Expr x) - | _ -> Ast_untagged_variants.DynamicChecks.( == ) (Expr x) (Expr y) + | _ -> Ast_untagged_variants.Dynamic_checks.( == ) (Expr x) (Expr y) in E.emit_check check in diff --git a/compiler/core/lam_compile_context.ml b/compiler/core/lam_compile_context.ml index c6341e743db..636f0a254bf 100644 --- a/compiler/core/lam_compile_context.ml +++ b/compiler/core/lam_compile_context.ml @@ -24,7 +24,7 @@ type jbl_label = int -module HandlerMap = Map_int +module Handler_map = Map_int type value = {exit_id: Ident.t; bindings: Ident.t list; order_id: int} @@ -64,7 +64,7 @@ type continuation = | Assign of J.ident (* when use [Assign], var is not needed, since it's already declared *) -type jmp_table = value HandlerMap.t +type jmp_table = value Handler_map.t let continuation_is_return (x : continuation) = match x with @@ -81,7 +81,7 @@ type t = { loop_label_counter: int ref; } -let empty_handler_map = HandlerMap.empty +let empty_handler_map = Handler_map.empty let enter_switch cxt = {cxt with switch_depth = cxt.switch_depth + 1} @@ -115,9 +115,9 @@ let add_jmps (m : jmp_table) (exit_id : Ident.t) (code_table : handler list) : jmp_table * (int * Lam.t) list = let map, handlers = Ext_list.fold_left_with_offset code_table (m, []) - (HandlerMap.cardinal m + 1) + (Handler_map.cardinal m + 1) (fun {label; handler; bindings} (acc, handlers) order_id -> - ( HandlerMap.add acc label {exit_id; bindings; order_id}, + ( Handler_map.add acc label {exit_id; bindings; order_id}, (order_id, handler) :: handlers )) in (map, List.rev handlers) @@ -125,7 +125,7 @@ let add_jmps (m : jmp_table) (exit_id : Ident.t) (code_table : handler list) : let add_pseudo_jmp (m : jmp_table) (exit_id : Ident.t) (* TODO not needed, remove it later *) (code_table : handler) : jmp_table * Lam.t = - ( HandlerMap.add m code_table.label + ( Handler_map.add m code_table.label {exit_id; bindings = code_table.bindings; order_id = -1}, code_table.handler ) diff --git a/compiler/depends/ast_extract.ml b/compiler/depends/ast_extract.ml index 0516fb1beb3..036ff98e386 100644 --- a/compiler/depends/ast_extract.ml +++ b/compiler/depends/ast_extract.ml @@ -24,12 +24,12 @@ (* type module_name = private string *) -module Set_string = Depend.StringSet +module Set_string = Depend.String_set (* FIXME: [Clflags.open_modules] seems not to be properly used *) -module SMap = Depend.StringMap +module S_map = Depend.String_map -let bound_vars = SMap.empty +let bound_vars = S_map.empty type 'a kind = 'a Ml_binary.kind diff --git a/compiler/depends/ast_extract.mli b/compiler/depends/ast_extract.mli index 9e53b4cbd4b..a3342d52f21 100644 --- a/compiler/depends/ast_extract.mli +++ b/compiler/depends/ast_extract.mli @@ -22,6 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -module Set_string = Depend.StringSet +module Set_string = Depend.String_set val read_parse_and_extract : 'a Ml_binary.kind -> 'a -> Set_string.t diff --git a/compiler/ext/misc.ml b/compiler/ext/misc.ml index d63856aa076..46f99d25d3c 100644 --- a/compiler/ext/misc.ml +++ b/compiler/ext/misc.ml @@ -401,11 +401,11 @@ let cut_at s c = let pos = String.index s c in (String.sub s 0 pos, String.sub s (pos + 1) (String.length s - pos - 1)) -module StringSet = Set.Make (struct +module String_set = Set.Make (struct type t = string let compare = compare end) -module StringMap = Map.Make (struct +module String_map = Map.Make (struct type t = string let compare = compare end) diff --git a/compiler/ext/misc.mli b/compiler/ext/misc.mli index 8e4a1cb283e..6dc9294833a 100644 --- a/compiler/ext/misc.mli +++ b/compiler/ext/misc.mli @@ -206,8 +206,8 @@ val cut_at : string -> char -> string * string @since 4.01 *) -module StringSet : Set.S with type elt = string -module StringMap : Map.S with type key = string +module String_set : Set.S with type elt = string +module String_map : Map.S with type key = string (* TODO: replace all custom instantiations of StringSet/StringMap in various compiler modules with this one. *) diff --git a/compiler/gentype/Annotation.ml b/compiler/gentype/annotation.ml similarity index 97% rename from compiler/gentype/Annotation.ml rename to compiler/gentype/annotation.ml index 9c66678b389..06aa96fcd4e 100644 --- a/compiler/gentype/Annotation.ml +++ b/compiler/gentype/annotation.ml @@ -1,4 +1,4 @@ -type import = {import_path: ImportPath.t} +type import = {import_path: Import_path.t} type attribute_payload = | BoolPayload of bool @@ -163,7 +163,7 @@ let doc_string_from_attrs attributes = attributes |> get_doc_payload let has_attribute check_text (attributes : Typedtree.attributes) = get_attribute_payload check_text attributes <> None -let from_attributes ~(config : GenTypeConfig.t) ~loc +let from_attributes ~(config : Gen_type_config.t) ~loc (attributes : Typedtree.attributes) = let default = if config.everything then GenType else NoGenType in if has_attribute tag_is_gentype_opaque attributes then GenTypeOpaque @@ -286,10 +286,10 @@ and structure_check_annotation ~check_annotation |> List.exists (structure_item_check_annotation ~check_annotation) let import_from_string import_string : import = - let import_path = ImportPath.from_string_unsafe import_string in + let import_path = Import_path.from_string_unsafe import_string in {import_path} -let update_config_for_module ~(config : GenTypeConfig.t) attributes = +let update_config_for_module ~(config : Gen_type_config.t) attributes = if attributes |> has_attribute tag_is_gentype then {config with everything = true} else config diff --git a/compiler/gentype/CodeItem.ml b/compiler/gentype/code_item.ml similarity index 80% rename from compiler/gentype/CodeItem.ml rename to compiler/gentype/code_item.ml index 7913263c679..187b608fbdd 100644 --- a/compiler/gentype/CodeItem.ml +++ b/compiler/gentype/code_item.ml @@ -1,4 +1,4 @@ -open GenTypeCommon +open Gen_type_common type export_type = { loc: Location.t; @@ -6,8 +6,8 @@ type export_type = { opaque: bool option; type_: type_; type_vars: string list; - resolved_type_name: ResolvedName.t; - doc_string: DocString.t; + resolved_type_name: Resolved_name.t; + doc_string: Doc_string.t; } type import_value = { @@ -18,10 +18,10 @@ type import_value = { } type export_value = { - doc_string: DocString.t; + doc_string: Doc_string.t; module_access_path: Runtime.module_access_path; original_name: string; - resolved_name: ResolvedName.t; + resolved_name: Resolved_name.t; type_: type_; } @@ -33,7 +33,7 @@ type export_from_type_declaration = { type import_type = { type_name: string; as_type_name: string option; - import_path: ImportPath.t; + import_path: Import_path.t; } type export_type_item = { @@ -42,7 +42,7 @@ type export_type_item = { annotation: Annotation.t; } -type export_type_map = export_type_item StringMap.t +type export_type_map = export_type_item String_map.t type type_declaration = { export_from_type_declaration: export_from_type_declaration; diff --git a/compiler/gentype/Converter.ml b/compiler/gentype/converter.ml similarity index 86% rename from compiler/gentype/Converter.ml rename to compiler/gentype/converter.ml index 11a70fa3ae7..3679ebac1fa 100644 --- a/compiler/gentype/Converter.ml +++ b/compiler/gentype/converter.ml @@ -1,8 +1,8 @@ -open GenTypeCommon +open Gen_type_common let type_get_inlined ~config ~lookup_id ~type_name_is_interface type0 = let circular = ref "" in - let rec visit ~(visited : StringSet.t) type_ = + let rec visit ~(visited : String_set.t) type_ = let normalized_ = type_ in match type_ with | Array (t, mutable_) -> @@ -18,13 +18,13 @@ let type_get_inlined ~config ~lookup_id ~type_name_is_interface type0 = {function_ with arg_types = arg_converted; ret_type = ret_normalized} | Ident {builtin = true} -> normalized_ | Ident {builtin = false; name; type_args} -> ( - if visited |> StringSet.mem name then ( + if visited |> String_set.mem name then ( circular := name; normalized_) else - let visited = visited |> StringSet.add name in + let visited = visited |> String_set.add name in match name |> lookup_id with - | {CodeItem.annotation = GenTypeOpaque} -> normalized_ + | {Code_item.annotation = GenTypeOpaque} -> normalized_ | {annotation = NoGenType} -> normalized_ | {type_vars; type_} -> let pairs = @@ -37,7 +37,7 @@ let type_get_inlined ~config ~lookup_id ~type_name_is_interface type0 = | _, type_argument -> Some type_argument | exception Not_found -> None in - let inlined = type_ |> TypeVars.substitute ~f |> visit ~visited in + let inlined = type_ |> Type_vars.substitute ~f |> visit ~visited in inlined | exception Not_found -> let type_args = @@ -82,8 +82,8 @@ let type_get_inlined ~config ~lookup_id ~type_name_is_interface type0 = let t_normalized = a_type |> visit ~visited in {a_name; a_type = t_normalized} in - let normalized = type0 |> visit ~visited:StringSet.empty in + let normalized = type0 |> visit ~visited:String_set.empty in if !Debug.converter then Log_.item "type0:%s \n" - (type0 |> EmitType.type_to_string ~config ~type_name_is_interface); + (type0 |> Emit_type.type_to_string ~config ~type_name_is_interface); normalized diff --git a/compiler/gentype/Debug.ml b/compiler/gentype/debug.ml similarity index 100% rename from compiler/gentype/Debug.ml rename to compiler/gentype/debug.ml diff --git a/compiler/gentype/Dependencies.ml b/compiler/gentype/dependencies.ml similarity index 70% rename from compiler/gentype/Dependencies.ml rename to compiler/gentype/dependencies.ml index e4049c6c00a..17f5e7b9fd9 100644 --- a/compiler/gentype/Dependencies.ml +++ b/compiler/gentype/dependencies.ml @@ -1,4 +1,4 @@ -open GenTypeCommon +open Gen_type_common let rec handle_namespace ~name dep = match dep with @@ -10,35 +10,37 @@ let rec from_path1 ~config ~type_env (path : Path.t) = match path with | Pident id -> ( let name = id |> Ident.name in - match type_env |> TypeEnv.lookup ~name with + match type_env |> Type_env.lookup ~name with | None -> (type_env, External name) | Some type_env1 -> ( let type_env2 = - match type_env |> TypeEnv.get_module ~name with + match type_env |> Type_env.get_module ~name with | Some type_env2 -> type_env2 | None -> type_env1 in - match type_env1 |> TypeEnv.expand_alias_to_external_module ~name with + match type_env1 |> Type_env.expand_alias_to_external_module ~name with | Some dep -> (type_env2, dep) | None -> let resolved_name = - name |> TypeEnv.add_module_path ~type_env:type_env1 + name |> Type_env.add_module_path ~type_env:type_env1 in (type_env2, Internal resolved_name))) | Pdot (Pident id, s, _pos) - when id |> ScopedPackage.is_generated_module ~config -> + when id |> Scoped_package.is_generated_module ~config -> ( type_env, - External (s |> ScopedPackage.add_generated_module ~generated_module:id) ) + External (s |> Scoped_package.add_generated_module ~generated_module:id) + ) | Pdot (p, s, _pos) -> ( let type_env_from_p, dep = p |> from_path1 ~config ~type_env in match - type_env_from_p |> TypeEnv.expand_alias_to_external_module ~name:s + type_env_from_p |> Type_env.expand_alias_to_external_module ~name:s with | Some dep -> (type_env_from_p, dep) | None -> (type_env_from_p, Dot (dep, s))) | Papply _ -> ( type_env, - Internal ("__Papply_unsupported_genType__" |> ResolvedName.from_string) ) + Internal ("__Papply_unsupported_genType__" |> Resolved_name.from_string) + ) let rec is_internal dep = match dep with @@ -50,7 +52,7 @@ let from_path ~config ~type_env path = let _, dep = path |> from_path1 ~config ~type_env in if !Debug.type_resolution then Log_.item "fromPath path:%s typeEnv:%s %s resolved:%s\n" (path |> Path.name) - (type_env |> TypeEnv.to_string) + (type_env |> Type_env.to_string) (match dep |> is_internal with | true -> "Internal" | false -> "External") @@ -61,9 +63,9 @@ let from_path ~config ~type_env path = let rec get_outer_module_name dep = match dep with - | External name -> name |> ModuleName.from_string_unsafe + | External name -> name |> Module_name.from_string_unsafe | Internal resolved_name -> - resolved_name |> ResolvedName.to_string |> ModuleName.from_string_unsafe + resolved_name |> Resolved_name.to_string |> Module_name.from_string_unsafe | Dot (dep1, _) -> dep1 |> get_outer_module_name let rec remove_external_outer_module dep = diff --git a/compiler/gentype/EmitJs.ml b/compiler/gentype/emit_js.ml similarity index 74% rename from compiler/gentype/EmitJs.ml rename to compiler/gentype/emit_js.ml index 7a72efa2e17..1d5f232e3f5 100644 --- a/compiler/gentype/EmitJs.ml +++ b/compiler/gentype/emit_js.ml @@ -1,12 +1,12 @@ -open GenTypeCommon +open Gen_type_common type env = { - requires_early: ImportPath.t Config.ModuleNameMap.t; - requires: ImportPath.t Config.ModuleNameMap.t; + requires_early: Import_path.t Config.Module_name_map.t; + requires: Import_path.t Config.Module_name_map.t; (** For each .cmt we import types from, keep the map of exported types *) - cmt_to_export_type_map: CodeItem.export_type_map StringMap.t; + cmt_to_export_type_map: Code_item.export_type_map String_map.t; (** Map of types imported from other files *) - export_type_map_from_other_files: CodeItem.export_type_map; + export_type_map_from_other_files: Code_item.export_type_map; imported_value_or_component: bool; } @@ -17,21 +17,21 @@ let require_module ~import ~env ~import_path module_name = | false -> env.requires in let requires_new = - requires |> Config.ModuleNameMap.add module_name import_path + requires |> Config.Module_name_map.add module_name import_path in match import with | true -> {env with requires_early = requires_new} | false -> {env with requires = requires_new} let create_export_type_map ~config ~file ~from_cmt_read_recursively - (type_declarations : CodeItem.type_declaration list) : - CodeItem.export_type_map = + (type_declarations : Code_item.type_declaration list) : + Code_item.export_type_map = if !Debug.code_items then Log_.item "Create Type Map for %s\n" file; - let update_export_type_map (export_type_map : CodeItem.export_type_map) - (type_declaration : CodeItem.type_declaration) : CodeItem.export_type_map - = + let update_export_type_map (export_type_map : Code_item.export_type_map) + (type_declaration : Code_item.type_declaration) : + Code_item.export_type_map = let add_export_type ~annotation - ({resolved_type_name; type_; type_vars} : CodeItem.export_type) = + ({resolved_type_name; type_; type_vars} : Code_item.export_type) = let annotation = match annotation with | Annotation.NoGenType when from_cmt_read_recursively -> @@ -40,40 +40,40 @@ let create_export_type_map ~config ~file ~from_cmt_read_recursively in if !Debug.code_items then Log_.item "Type Map: %s%s%s\n" - (resolved_type_name |> ResolvedName.to_string) + (resolved_type_name |> Resolved_name.to_string) (match type_vars = [] with | true -> "" | false -> "(" ^ (type_vars |> String.concat ",") ^ ")") (" " - ^ (annotation |> Annotation.to_string |> EmitText.comment) + ^ (annotation |> Annotation.to_string |> Emit_text.comment) ^ " = " ^ (type_ - |> EmitType.type_to_string ~config ~type_name_is_interface:(fun _ -> - false))); + |> Emit_type.type_to_string ~config + ~type_name_is_interface:(fun _ -> false))); export_type_map - |> StringMap.add - (resolved_type_name |> ResolvedName.to_string) - {CodeItem.type_vars; type_; annotation} + |> String_map.add + (resolved_type_name |> Resolved_name.to_string) + {Code_item.type_vars; type_; annotation} in match type_declaration.export_from_type_declaration with | {export_type; annotation} -> export_type |> add_export_type ~annotation in - type_declarations |> List.fold_left update_export_type_map StringMap.empty + type_declarations |> List.fold_left update_export_type_map String_map.empty -let code_item_to_string ~config ~type_name_is_interface (code_item : CodeItem.t) - = +let code_item_to_string ~config ~type_name_is_interface + (code_item : Code_item.t) = match code_item with | ExportValue {resolved_name; type_} -> "ExportValue" ^ " resolvedName:" - ^ ResolvedName.to_string resolved_name + ^ Resolved_name.to_string resolved_name ^ " type:" - ^ EmitType.type_to_string ~config ~type_name_is_interface type_ + ^ Emit_type.type_to_string ~config ~type_name_is_interface type_ | ImportValue {import_annotation} -> - "ImportValue " ^ (import_annotation.import_path |> ImportPath.dump) + "ImportValue " ^ (import_annotation.import_path |> Import_path.dump) let emit_export_type ~emitters ~config ~type_name_is_interface { - CodeItem.loc; + Code_item.loc; name_as; opaque; type_; @@ -81,7 +81,7 @@ let emit_export_type ~emitters ~config ~type_name_is_interface resolved_type_name; doc_string; } = - let free_type_vars = TypeVars.free type_ in + let free_type_vars = Type_vars.free type_ in let is_gadt = free_type_vars |> List.exists (fun s -> not (List.mem s type_vars)) in @@ -93,7 +93,7 @@ let emit_export_type ~emitters ~config ~type_name_is_interface Log_.info ~loc ~name:"Warning genType" (fun ppf () -> Format.fprintf ppf "GADT types are not supported: exporting %s as opaque type" - (resolved_type_name |> ResolvedName.to_string)); + (resolved_type_name |> Resolved_name.to_string)); Some true | _ -> opaque in @@ -102,27 +102,27 @@ let emit_export_type ~emitters ~config ~type_name_is_interface | Some opaque -> opaque | None -> false in - resolved_type_name |> ResolvedName.to_string - |> EmitType.emit_export_type ~config ~emitters ~name_as ~opaque ~type_ + resolved_type_name |> Resolved_name.to_string + |> Emit_type.emit_export_type ~config ~emitters ~name_as ~opaque ~type_ ~type_name_is_interface ~type_vars ~doc_string -let type_name_is_interface ~(export_type_map : CodeItem.export_type_map) - ~(export_type_map_from_other_files : CodeItem.export_type_map) type_name = +let type_name_is_interface ~(export_type_map : Code_item.export_type_map) + ~(export_type_map_from_other_files : Code_item.export_type_map) type_name = let type_is_interface type_ = match type_ with | Object _ -> true | _ -> false in - match export_type_map |> StringMap.find type_name with + match export_type_map |> String_map.find type_name with | {type_} -> type_ |> type_is_interface | exception Not_found -> ( - match export_type_map_from_other_files |> StringMap.find type_name with + match export_type_map_from_other_files |> String_map.find type_name with | {type_} -> type_ |> type_is_interface | exception Not_found -> false) let emit_export_from_type_declaration ~config ~emitters ~env ~type_name_is_interface - (export_from_type_declaration : CodeItem.export_from_type_declaration) = + (export_from_type_declaration : Code_item.export_from_type_declaration) = ( env, export_from_type_declaration.export_type |> emit_export_type ~emitters ~config ~type_name_is_interface ) @@ -158,7 +158,7 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name let value_name_not_checked = value_name ^ "NotChecked" in let emitters = import_path - |> EmitType.emit_import_value_as_early ~emitters + |> Emit_type.emit_import_value_as_early ~emitters ~name:first_name_in_path ~name_as:(Some value_name_not_checked) in (emitters, value_name_not_checked, env) @@ -170,16 +170,16 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name arg_types = [{a_type = Object (closed_flag, fields); a_name}]; ret_type; } as function_) - when ret_type |> EmitType.is_type_function_component ~fields -> + when ret_type |> Emit_type.is_type_function_component ~fields -> (* JSX V3 *) let fields = fields |> List.map (fun (field : field) -> match field.name_js = "children" - && field.type_ |> EmitType.is_type_react_element + && field.type_ |> Emit_type.is_type_react_element with - | true -> {field with type_ = EmitType.type_react_child} + | true -> {field with type_ = Emit_type.type_react_child} | false -> field) in let function_ = @@ -195,16 +195,16 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name ret_type; } as function_) when Filename.check_suffix name "props" - && ret_type |> EmitType.is_type_function_component ~fields:[] -> ( + && ret_type |> Emit_type.is_type_function_component ~fields:[] -> ( match inline_one_level props_type with | Object (closed_flags, fields) -> (* JSX V3 *) let fields = Ext_list.filter_map fields (fun (field : field) -> match field.name_js with - | "children" when field.type_ |> EmitType.is_type_react_element + | "children" when field.type_ |> Emit_type.is_type_react_element -> - Some {field with type_ = EmitType.type_react_child} + Some {field with type_ = Emit_type.type_react_child} | "key" -> (* Filter out key, which is added to the props type definition in V4 *) None @@ -223,13 +223,13 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name let value_name_type_checked = value_name ^ "TypeChecked" in let emitters = imported_as_name ^ rest_of_path - |> EmitType.emit_export_const ~config + |> Emit_type.emit_export_const ~config ~comment: ("In case of type error, check the type of '" ^ value_name ^ "' in '" - ^ (file_name |> ModuleName.to_string) + ^ (file_name |> Module_name.to_string) ^ ".res'" ^ " and '" - ^ (import_path |> ImportPath.emit) + ^ (import_path |> Import_path.emit) ^ "'.") ~early:true ~emitters ~name:value_name_type_checked ~type_ ~type_name_is_interface @@ -241,8 +241,8 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name in let emitters = value_name_type_checked - |> EmitType.emit_type_cast ~config ~type_ ~type_name_is_interface - |> EmitType.emit_export_const + |> Emit_type.emit_type_cast ~config ~type_ ~type_name_is_interface + |> Emit_type.emit_export_const ~comment: ("Export '" ^ value_name_not_default ^ "' early to allow circular import from the '.bs.js' file.") @@ -251,19 +251,19 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name in let emitters = match value_name = "default" with - | true -> EmitType.emit_export_default ~emitters value_name_not_default + | true -> Emit_type.emit_export_default ~emitters value_name_not_default | false -> emitters in ({env with imported_value_or_component = true}, emitters) | ExportValue {doc_string; module_access_path; original_name; resolved_name; type_} -> - let resolved_name_str = ResolvedName.to_string resolved_name in + let resolved_name_str = Resolved_name.to_string resolved_name in let import_path = file_name - |> ModuleResolver.resolve_module ~config ~import_extension:config.suffix + |> Module_resolver.resolve_module ~config ~import_extension:config.suffix ~output_file_relative ~resolver ~use_bs_dependencies:false in - let file_name_js = file_name |> ModuleName.for_js_file in + let file_name_js = file_name |> Module_name.for_js_file in let env_with_requires = file_name_js |> require_module ~import:false ~env ~import_path in @@ -274,10 +274,10 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name | true -> Runtime.default | false -> resolved_name_str in - let module HookType = struct + let module Hook_type = struct type t = { props_type: type_; - resolved_type_name: ResolvedName.t; + resolved_type_name: Resolved_name.t; type_vars: string list; } end in @@ -289,7 +289,7 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name ret_type; type_vars; } as function_) - when ret_type |> EmitType.is_type_function_component ~fields -> + when ret_type |> Emit_type.is_type_function_component ~fields -> (* JSX V3 *) let props_type = let fields = @@ -297,9 +297,9 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name |> List.map (fun (field : field) -> match field.name_js = "children" - && field.type_ |> EmitType.is_type_react_element + && field.type_ |> Emit_type.is_type_react_element with - | true -> {field with type_ = EmitType.type_react_child} + | true -> {field with type_ = Emit_type.type_react_child} | false -> field) in Object (closed_flags, fields) @@ -313,16 +313,16 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name && (original_name = default || original_name = make) then ( config.emit_type_prop_done <- true; - ResolvedName.from_string "Props") - else ResolvedName.from_string name |> ResolvedName.dot "Props" + Resolved_name.from_string "Props") + else Resolved_name.from_string name |> Resolved_name.dot "Props" in ( Function function_, - Some {HookType.props_type; resolved_type_name; type_vars} ) + Some {Hook_type.props_type; resolved_type_name; type_vars} ) | Function ({arg_types = [{a_type = Ident {name} as props_type}]; ret_type} as function_) when Filename.check_suffix name "props" - && ret_type |> EmitType.is_type_function_component ~fields:[] -> + && ret_type |> Emit_type.is_type_function_component ~fields:[] -> let comp_type = match inline_one_level props_type with | Object (closed_flags, fields) -> @@ -332,8 +332,8 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name Ext_list.filter_map fields (fun (field : field) -> match field.name_js with | "children" - when field.type_ |> EmitType.is_type_react_element -> - Some {field with type_ = EmitType.type_react_child} + when field.type_ |> Emit_type.is_type_react_element -> + Some {field with type_ = Emit_type.type_react_child} | "key" -> (* Filter out key, which is added to the props type definition in V4 *) None @@ -352,7 +352,7 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name in resolved_name - |> ExportModule.extend_export_modules ~doc_string ~module_items_emitter + |> Export_module.extend_export_modules ~doc_string ~module_items_emitter ~type_; let emitters = match hook_type with @@ -367,7 +367,7 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name resolved_type_name; doc_string; } - : CodeItem.export_type) + : Code_item.export_type) in (* For doc gen (https://github.com/cristianoc/genType/issues/342) *) config.emit_import_react <- true; @@ -375,15 +375,15 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name | _ -> emitters in let emitters = - (file_name_js |> ModuleName.to_string) + (file_name_js |> Module_name.to_string) ^ "." ^ (module_access_path |> Runtime.emit_module_access_path ~config) - |> EmitType.emit_export_const ~config ~doc_string ~early:false ~emitters + |> Emit_type.emit_export_const ~config ~doc_string ~early:false ~emitters ~name ~type_ ~type_name_is_interface in let emitters = match original_name = default with - | true -> EmitType.emit_export_default ~emitters Runtime.default + | true -> Emit_type.emit_export_default ~emitters Runtime.default | false -> emitters in (env_with_requires, emitters) @@ -401,27 +401,27 @@ let emit_code_items ~config ~output_file_relative ~emitters let emit_requires ~imported_value_or_component ~early ~config ~requires emitters = - Config.ModuleNameMap.fold + Config.Module_name_map.fold (fun module_name import_path emitters -> import_path - |> EmitType.emit_require ~imported_value_or_component ~early ~emitters + |> Emit_type.emit_require ~imported_value_or_component ~early ~emitters ~config ~module_name) requires emitters let type_get_inlined ~config ~export_type_map type_ = type_ |> Converter.type_get_inlined ~config - ~lookup_id:(fun s -> export_type_map |> StringMap.find s) + ~lookup_id:(fun s -> export_type_map |> String_map.find s) ~type_name_is_interface:(fun _ -> false) (** Read the cmt file referenced in an import type, and recursively for the import types obtained from reading the cmt file. *) let rec read_cmt_files_recursively ~config ~env ~input_cmt_translate_type_declarations ~output_file_relative ~resolver - {CodeItem.type_name; as_type_name; import_path} = + {Code_item.type_name; as_type_name; import_path} = let update_type_map_from_other_files ~as_type ~export_type_map_from_cmt env = - match export_type_map_from_cmt |> StringMap.find type_name with - | (export_type_item : CodeItem.export_type_item) -> + match export_type_map_from_cmt |> String_map.find type_name with + | (export_type_item : Code_item.export_type_item) -> let type_ = export_type_item.type_ |> type_get_inlined ~config ~export_type_map:export_type_map_from_cmt @@ -430,18 +430,18 @@ let rec read_cmt_files_recursively ~config ~env env with export_type_map_from_other_files = env.export_type_map_from_other_files - |> StringMap.add as_type {export_type_item with type_}; + |> String_map.add as_type {export_type_item with type_}; } | exception Not_found -> env in let cmt_file = import_path - |> ImportPath.to_cmt ~config ~output_file_relative + |> Import_path.to_cmt ~config ~output_file_relative |> Paths.get_cmt_file in match as_type_name with | Some as_type when cmt_file <> "" -> ( - match env.cmt_to_export_type_map |> StringMap.find cmt_file with + match env.cmt_to_export_type_map |> String_map.find cmt_file with | export_type_map_from_cmt -> env |> update_type_map_from_other_files ~as_type ~export_type_map_from_cmt | exception Not_found -> @@ -450,7 +450,7 @@ let rec read_cmt_files_recursively ~config ~env Cmt_format.read_cmt cmt_file |> input_cmt_translate_type_declarations ~config ~output_file_relative ~resolver - |> fun (x : CodeItem.translation) -> x.type_declarations + |> fun (x : Code_item.translation) -> x.type_declarations in let export_type_map_from_cmt = type_declarations @@ -461,7 +461,7 @@ let rec read_cmt_files_recursively ~config ~env in let cmt_to_export_type_map = env.cmt_to_export_type_map - |> StringMap.add cmt_file export_type_map_from_cmt + |> String_map.add cmt_file export_type_map_from_cmt in let env = {env with cmt_to_export_type_map} @@ -469,7 +469,7 @@ let rec read_cmt_files_recursively ~config ~env in let new_import_types = type_declarations - |> List.map (fun (type_declaration : CodeItem.type_declaration) -> + |> List.map (fun (type_declaration : Code_item.type_declaration) -> type_declaration.import_types) |> List.concat in @@ -486,14 +486,14 @@ let rec read_cmt_files_recursively ~config ~env let emit_import_type ~config ~emitters ~env ~input_cmt_translate_type_declarations ~output_file_relative ~resolver ~type_name_is_interface - ({CodeItem.type_name; as_type_name; import_path} as import_type) = + ({Code_item.type_name; as_type_name; import_path} as import_type) = let env = import_type |> read_cmt_files_recursively ~config ~env ~input_cmt_translate_type_declarations ~output_file_relative ~resolver in let emitters = - EmitType.emit_import_type_as ~emitters ~config ~type_name ~as_type_name + Emit_type.emit_import_type_as ~emitters ~config ~type_name ~as_type_name ~type_name_is_interface:(type_name_is_interface ~env) ~import_path in @@ -515,10 +515,10 @@ let get_annotated_typed_declarations ~annotated_set type_declarations = |> List.map (fun type_declaration -> let name_in_annotated_set = annotated_set - |> StringSet.mem - (type_declaration.CodeItem.export_from_type_declaration + |> String_set.mem + (type_declaration.Code_item.export_from_type_declaration .export_type - .resolved_type_name |> ResolvedName.to_string) + .resolved_type_name |> Resolved_name.to_string) in if name_in_annotated_set then { @@ -533,19 +533,19 @@ let get_annotated_typed_declarations ~annotated_set type_declarations = |> List.filter (fun ({export_from_type_declaration = {annotation}} : - CodeItem.type_declaration) + Code_item.type_declaration) -> annotation <> NoGenType) let propagate_annotation_to_sub_types ~code_items - (type_map : CodeItem.export_type_map) = - let annotated_set = ref StringSet.empty in + (type_map : Code_item.export_type_map) = + let annotated_set = ref String_set.empty in let initial_annotated_types = - type_map |> StringMap.bindings - |> List.filter (fun (_, {CodeItem.annotation}) -> + type_map |> String_map.bindings + |> List.filter (fun (_, {Code_item.annotation}) -> annotation = Annotation.GenType) - |> List.map (fun (_, {CodeItem.type_}) -> type_) + |> List.map (fun (_, {Code_item.type_}) -> type_) in - let types_of_exported_value (code_item : CodeItem.t) = + let types_of_exported_value (code_item : Code_item.t) = match code_item with | ExportValue {type_} | ImportValue {type_} -> [type_] in @@ -553,23 +553,23 @@ let propagate_annotation_to_sub_types ~code_items code_items |> List.map types_of_exported_value |> List.concat in let visit_typ_and_update_marked type0 = - let visited = ref StringSet.empty in + let visited = ref String_set.empty in let rec visit type_ = match type_ with | Ident {name = type_name; type_args} -> - if !visited |> StringSet.mem type_name then () + if !visited |> String_set.mem type_name then () else ( - visited := !visited |> StringSet.add type_name; + visited := !visited |> String_set.add type_name; type_args |> List.iter visit; - match type_map |> StringMap.find type_name with + match type_map |> String_map.find type_name with | {annotation = GenType | GenTypeOpaque} -> () | {type_ = type1; annotation = NoGenType} -> if !Debug.translation then Log_.item "Marking Type As Annotated %s\n" type_name; - annotated_set := !annotated_set |> StringSet.add type_name; + annotated_set := !annotated_set |> String_set.add type_name; type1 |> visit | exception Not_found -> - annotated_set := !annotated_set |> StringSet.add type_name) + annotated_set := !annotated_set |> String_set.add type_name) | Array (t, _) | Dict t -> t |> visit | Function {arg_types; ret_type} -> arg_types |> List.iter (fun {a_type} -> visit a_type); @@ -589,12 +589,12 @@ let propagate_annotation_to_sub_types ~code_items |> List.iter visit_typ_and_update_marked; let new_type_map = type_map - |> StringMap.mapi - (fun type_name (export_type_item : CodeItem.export_type_item) -> + |> String_map.mapi + (fun type_name (export_type_item : Code_item.export_type_item) -> { export_type_item with annotation = - (match !annotated_set |> StringSet.mem type_name with + (match !annotated_set |> String_set.mem type_name with | true -> Annotation.GenType | false -> export_type_item.annotation); }) @@ -606,17 +606,17 @@ let emit_translation_as_string ~config ~file_name (translation : Translation.t) = let initial_env = { - requires = Config.ModuleNameMap.empty; - requires_early = Config.ModuleNameMap.empty; - cmt_to_export_type_map = StringMap.empty; - export_type_map_from_other_files = StringMap.empty; + requires = Config.Module_name_map.empty; + requires_early = Config.Module_name_map.empty; + cmt_to_export_type_map = String_map.empty; + export_type_map_from_other_files = String_map.empty; imported_value_or_component = false; } in let export_type_map, annotated_set = translation.type_declarations |> create_export_type_map ~config - ~file:(file_name |> ModuleName.to_string) + ~file:(file_name |> Module_name.to_string) ~from_cmt_read_recursively:false |> propagate_annotation_to_sub_types ~code_items:translation.code_items in @@ -626,13 +626,13 @@ let emit_translation_as_string ~config ~file_name in let import_types_from_type_declarations = annotated_type_declarations - |> List.map (fun (type_declaration : CodeItem.type_declaration) -> + |> List.map (fun (type_declaration : Code_item.type_declaration) -> type_declaration.import_types) |> List.concat in let export_from_type_declarations = annotated_type_declarations - |> List.map (fun (type_declaration : CodeItem.type_declaration) -> + |> List.map (fun (type_declaration : Code_item.type_declaration) -> type_declaration.export_from_type_declaration) in let type_name_is_interface ~env = @@ -640,11 +640,12 @@ let emit_translation_as_string ~config ~file_name ~export_type_map_from_other_files:env.export_type_map_from_other_files in let lookupId_ ~env s = - try export_type_map |> StringMap.find s - with Not_found -> env.export_type_map_from_other_files |> StringMap.find s + try export_type_map |> String_map.find s + with Not_found -> + env.export_type_map_from_other_files |> String_map.find s in let emitters = Emitters.initial - and module_items_emitter = ExportModule.create_module_items_emitter () + and module_items_emitter = Export_module.create_module_items_emitter () and env = initial_env in let env, emitters = (* imports from type declarations go first to build up type tables *) @@ -674,7 +675,7 @@ let emit_translation_as_string ~config ~file_name | _, type_argument -> Some type_argument | exception Not_found -> None in - type_ |> TypeVars.substitute ~f + type_ |> Type_vars.substitute ~f | exception Not_found -> type_) | _ -> type_ in @@ -686,21 +687,21 @@ let emit_translation_as_string ~config ~file_name in let emitters = match config.emit_import_react with - | true -> EmitType.emit_import_react ~emitters + | true -> Emit_type.emit_import_react ~emitters | false -> emitters in let env = match config.emit_import_curry with | true -> - ModuleName.curry + Module_name.curry |> require_module ~import:true ~env - ~import_path:(ImportPath.bs_curry_path ~config) + ~import_path:(Import_path.bs_curry_path ~config) | false -> env in let final_env = env in let emitters = module_items_emitter - |> ExportModule.emit_all_module_items ~config ~emitters ~file_name + |> Export_module.emit_all_module_items ~config ~emitters ~file_name in emitters |> emit_requires ~imported_value_or_component:false ~early:true ~config diff --git a/compiler/gentype/EmitText.ml b/compiler/gentype/emit_text.ml similarity index 100% rename from compiler/gentype/EmitText.ml rename to compiler/gentype/emit_text.ml diff --git a/compiler/gentype/EmitType.ml b/compiler/gentype/emit_type.ml similarity index 93% rename from compiler/gentype/EmitType.ml rename to compiler/gentype/emit_type.ml index 54e5777b8bb..d391dd276b3 100644 --- a/compiler/gentype/EmitType.ml +++ b/compiler/gentype/emit_type.ml @@ -1,4 +1,4 @@ -open GenTypeCommon +open Gen_type_common let file_header ~source_file = let make_header ~lines = @@ -47,7 +47,7 @@ let type_react_ref ~type_ = name_js = react_ref_current; optional = Mandatory; type_ = Null type_; - doc_string = DocString.empty; + doc_string = Doc_string.empty; }; ] ) @@ -99,7 +99,7 @@ let rec render_type ~(config : Config.t) ?(indent = None) field with type_ = field.type_ - |> TypeVars.substitute ~f:(fun s -> + |> Type_vars.substitute ~f:(fun s -> if type_vars |> List.mem s then Some type_any else None); }) in @@ -124,7 +124,7 @@ let rec render_type ~(config : Config.t) ?(indent = None) with | true -> name |> interface_name ~config | false -> name) - ^ EmitText.generics_string + ^ Emit_text.generics_string ~type_vars: (type_args |> List.map @@ -137,7 +137,7 @@ let rec render_type ~(config : Config.t) ?(indent = None) | Nullable type_ -> let use_parens x = match type_ with - | Function _ | Variant _ -> EmitText.parens [x] + | Function _ | Variant _ -> Emit_text.parens [x] | _ -> x in "(null | undefined | " @@ -148,7 +148,7 @@ let rec render_type ~(config : Config.t) ?(indent = None) | Option type_ -> let use_parens x = match type_ with - | Function _ | Variant _ -> EmitText.parens [x] + | Function _ | Variant _ -> Emit_text.parens [x] | _ -> x in "(undefined | " @@ -182,7 +182,7 @@ let rec render_type ~(config : Config.t) ?(indent = None) name_js = name; optional = Mandatory; type_ = TypeVar value; - doc_string = DocString.empty; + doc_string = Doc_string.empty; } in let fields fields = @@ -209,7 +209,7 @@ let rec render_type ~(config : Config.t) ?(indent = None) | _ -> false in let t = type_ |> render in - if need_parens then EmitText.parens [t] else t + if need_parens then Emit_text.parens [t] else t | false, type_ when polymorphic -> (* poly variant *) [ @@ -266,17 +266,17 @@ and render_field ~config ~indent ~type_name_is_interface ~in_fun_type let lbl = match is_js_safe_property_name lbl with | true -> lbl - | false -> EmitText.quotes lbl + | false -> Emit_text.quotes lbl in let def_str = mut_marker ^ lbl ^ opt_marker ^ ": " ^ (type_ |> render_type ~config ~indent ~type_name_is_interface ~in_fun_type) in - if DocString.has_content doc_string then + if Doc_string.has_content doc_string then (* Always print comments on newline before definition. *) let indent_str = indent |> Option.value ~default:"" in - "\n" ^ indent_str ^ DocString.render doc_string ^ indent_str ^ def_str + "\n" ^ indent_str ^ Doc_string.render doc_string ^ indent_str ^ def_str else Indent.break ~indent ^ def_str and render_fields ~config ~indent ~in_fun_type ~type_name_is_interface fields = @@ -301,7 +301,7 @@ and render_fun_type ~config ~indent ~in_fun_type ~type_name_is_interface (match in_fun_type with | true -> "(" | false -> "") - ^ EmitText.generics_string ~type_vars + ^ Emit_text.generics_string ~type_vars ^ "(" ^ String.concat ", " (List.mapi @@ -329,13 +329,13 @@ let type_to_string ~config ~type_name_is_interface type_ = type_ |> render_type ~config ~type_name_is_interface ~in_fun_type:false let emit_export_const ~early ?(comment = "") ~config - ?(doc_string = DocString.empty) ~emitters ~name ~type_ + ?(doc_string = Doc_string.empty) ~emitters ~name ~type_ ~type_name_is_interface line = let type_string = type_ |> type_to_string ~config ~type_name_is_interface in (match comment = "" with | true -> comment | false -> "// " ^ comment ^ "\n") - ^ DocString.render doc_string + ^ Doc_string.render doc_string ^ "export const " ^ name ^ ": " ^ type_string ^ " = " ^ line ^ " as any;" |> (match early with | true -> Emitters.export_early @@ -347,8 +347,8 @@ let emit_export_default ~emitters name = let emit_export_type ~(config : Config.t) ~emitters ~name_as ~opaque ~type_ ~type_name_is_interface ~type_vars ~doc_string resolved_type_name = - let doc_string = DocString.render doc_string in - let type_params_string = EmitText.generics_string ~type_vars in + let doc_string = Doc_string.render doc_string in + let type_params_string = Emit_text.generics_string ~type_vars in let is_interface = resolved_type_name |> type_name_is_interface in let resolved_type_name = match config.export_interfaces && is_interface with @@ -393,14 +393,14 @@ let emit_import_value_as_early ~emitters ~name ~name_as import_path = | Some name_as -> "{" ^ name ^ " as " ^ name_as ^ "}" | None -> name) ^ " from " ^ "'" - ^ (import_path |> ImportPath.emit) + ^ (import_path |> Import_path.emit) ^ "';" |> Emitters.require_early ~emitters let emit_require ~imported_value_or_component ~early ~emitters ~(config : Config.t) ~module_name import_path = - let module_name_string = ModuleName.to_string module_name in - let import_path_string = ImportPath.emit import_path in + let module_name_string = Module_name.to_string module_name in + let import_path_string = Import_path.emit import_path in let output = match config.module_ with | ESModule when not imported_value_or_component -> @@ -442,7 +442,7 @@ let emit_import_type_as ~emitters ~config ~type_name ~as_type_name | false -> (type_name, as_type_name)) | None -> (type_name, as_type_name) in - let import_path_string = import_path |> ImportPath.emit in + let import_path_string = import_path |> Import_path.emit in let import_prefix = "import type" in import_prefix ^ " " ^ "{" ^ type_name ^ (match as_type_name with diff --git a/compiler/gentype/Emitters.ml b/compiler/gentype/emitters.ml similarity index 100% rename from compiler/gentype/Emitters.ml rename to compiler/gentype/emitters.ml diff --git a/compiler/gentype/Emitters.mli b/compiler/gentype/emitters.mli similarity index 100% rename from compiler/gentype/Emitters.mli rename to compiler/gentype/emitters.mli diff --git a/compiler/gentype/ExportModule.ml b/compiler/gentype/export_module.ml similarity index 90% rename from compiler/gentype/ExportModule.ml rename to compiler/gentype/export_module.ml index eb3ce62954e..ec193bfb006 100644 --- a/compiler/gentype/ExportModule.ml +++ b/compiler/gentype/export_module.ml @@ -1,9 +1,9 @@ -open GenTypeCommon +open Gen_type_common type export_module_item = (string, export_module_value) Hashtbl.t and export_module_value = - | S of {name: string; type_: type_; doc_string: DocString.t} + | S of {name: string; type_: type_; doc_string: Doc_string.t} | M of {export_module_item: export_module_item} type export_module_items = (string, export_module_item) Hashtbl.t @@ -11,7 +11,7 @@ type export_module_items = (string, export_module_item) Hashtbl.t type types = { type_for_value: type_; type_for_type: type_; - doc_string: DocString.t; + doc_string: Doc_string.t; } type field_info = {field_for_value: field; field_for_type: field} @@ -33,7 +33,7 @@ let rec export_module_value_to_type ~config export_module_value = { type_for_value = Object (Open, fields_for_value); type_for_type = Object (Open, fields_for_type); - doc_string = DocString.empty; + doc_string = Doc_string.empty; } and export_module_item_to_fields = @@ -115,18 +115,19 @@ let emit_all_module_items ~config ~emitters ~file_name in if !Debug.code_items then Log_.item "EmitModule %s @." module_name; let emitted_module_item = - ModuleName.for_inner_module ~file_name ~inner_module_name:module_name - |> ModuleName.to_string + Module_name.for_inner_module ~file_name + ~inner_module_name:module_name + |> Module_name.to_string in emitted_module_item - |> EmitType.emit_export_const ~doc_string ~early:false ~config + |> Emit_type.emit_export_const ~doc_string ~early:false ~config ~emitters ~name:module_name ~type_:type_for_type ~type_name_is_interface:(fun _ -> false)) export_module_items let extend_export_modules ~(module_items_emitter : export_module_items) ~doc_string ~type_ resolved_name = - resolved_name |> ResolvedName.to_list + resolved_name |> Resolved_name.to_list |> extend_export_module_items ~export_module_items:module_items_emitter ~type_ ~doc_string - ~value_name:(resolved_name |> ResolvedName.to_string) + ~value_name:(resolved_name |> Resolved_name.to_string) diff --git a/compiler/gentype/FindSourceFile.ml b/compiler/gentype/find_source_file.ml similarity index 100% rename from compiler/gentype/FindSourceFile.ml rename to compiler/gentype/find_source_file.ml diff --git a/compiler/gentype/FindSourceFile.mli b/compiler/gentype/find_source_file.mli similarity index 100% rename from compiler/gentype/FindSourceFile.mli rename to compiler/gentype/find_source_file.mli diff --git a/compiler/gentype/GenIdent.ml b/compiler/gentype/gen_ident.ml similarity index 65% rename from compiler/gentype/GenIdent.ml rename to compiler/gentype/gen_ident.ml index 5cdf1fdb7a6..e2c09c0565b 100644 --- a/compiler/gentype/GenIdent.ml +++ b/compiler/gentype/gen_ident.ml @@ -1,4 +1,4 @@ -module IntMap = Map.Make (struct +module Int_map = Map.Make (struct type t = int let compare (x : int) (y : int) = compare x y @@ -6,18 +6,18 @@ end) type type_vars_gen = { (* Generate fresh identifiers *) - mutable type_name_map: string IntMap.t; + mutable type_name_map: string Int_map.t; mutable type_name_counter: int; } let create_type_vars_gen () = - {type_name_map = IntMap.empty; type_name_counter = 0} + {type_name_map = Int_map.empty; type_name_counter = 0} let js_type_name_for_anonymous_type_id ~type_vars_gen id = - try type_vars_gen.type_name_map |> IntMap.find id + try type_vars_gen.type_name_map |> Int_map.find id with Not_found -> type_vars_gen.type_name_counter <- type_vars_gen.type_name_counter + 1; let name = "T" ^ string_of_int type_vars_gen.type_name_counter in type_vars_gen.type_name_map <- - type_vars_gen.type_name_map |> IntMap.add id name; + type_vars_gen.type_name_map |> Int_map.add id name; name diff --git a/compiler/gentype/GenTypeCommon.ml b/compiler/gentype/gen_type_common.ml similarity index 91% rename from compiler/gentype/GenTypeCommon.ml rename to compiler/gentype/gen_type_common.ml index 9923927fda8..57138b2cde4 100644 --- a/compiler/gentype/GenTypeCommon.ml +++ b/compiler/gentype/gen_type_common.ml @@ -1,8 +1,8 @@ -module StringMap = Map.Make (String) -module StringSet = Set.Make (String) -module Config = GenTypeConfig +module String_map = Map.Make (String) +module String_set = Set.Make (String) +module Config = Gen_type_config -module DocString = struct +module Doc_string = struct type t = string option let render t = match t with @@ -60,7 +60,7 @@ let label_js_to_string case = | BoolLabel b -> b |> string_of_bool | FloatLabel s -> s | IntLabel i -> i - | StringLabel s -> s |> EmitText.quotes + | StringLabel s -> s |> Emit_text.quotes type closed_flag = Open | Closed | Inline @@ -86,7 +86,7 @@ and field = { name_js: string; optional: optional; type_: type_; - doc_string: DocString.t; + doc_string: Doc_string.t; } and function_ = { @@ -112,10 +112,10 @@ type label = Nolabel | Label of string | OptLabel of string type dep = | External of string - | Internal of ResolvedName.t + | Internal of Resolved_name.t | Dot of dep * string -module ScopedPackage = +module Scoped_package = (* Taken from ext_namespace.ml in bukclescript *) struct let namespace_of_package_name (s : string) : string = @@ -163,15 +163,15 @@ end let rec dep_to_string dep = match dep with - | External name -> name |> ScopedPackage.remove_generated_module - | Internal resolved_name -> resolved_name |> ResolvedName.to_string + | External name -> name |> Scoped_package.remove_generated_module + | Internal resolved_name -> resolved_name |> Resolved_name.to_string | Dot (d, s) -> dep_to_string d ^ "_" ^ s let rec dep_to_resolved_name (dep : dep) = match dep with - | External name -> name |> ResolvedName.from_string + | External name -> name |> Resolved_name.from_string | Internal resolved_name -> resolved_name - | Dot (p, s) -> ResolvedName.dot s (p |> dep_to_resolved_name) + | Dot (p, s) -> Resolved_name.dot s (p |> dep_to_resolved_name) let create_variant ~inherits ~no_payloads ~payloads ~polymorphic ~tag ~unboxed = Variant {inherits; no_payloads; payloads; polymorphic; tag; unboxed} @@ -197,7 +197,7 @@ let unit_t = ident "void" let weakmap_t (x, y) = ident ~type_args:[x; y] "WeakMap" let weakset_t x = ident ~type_args:[x] "WeakSet" -module NodeFilename = struct +module Node_filename = struct include Filename (* Force "/" separator. *) diff --git a/compiler/gentype/GenTypeConfig.ml b/compiler/gentype/gen_type_config.ml similarity index 91% rename from compiler/gentype/GenTypeConfig.ml rename to compiler/gentype/gen_type_config.ml index a4eafea44ea..dd0d8361afb 100644 --- a/compiler/gentype/GenTypeConfig.ml +++ b/compiler/gentype/gen_type_config.ml @@ -1,4 +1,4 @@ -module ModuleNameMap = Map.Make (ModuleName) +module Module_name_map = Map.Make (Module_name) type module_ = CommonJS | ESModule @@ -29,7 +29,7 @@ type t = { namespace: string option; platform_lib: string; project_root: string; - shims_map: ModuleName.t ModuleNameMap.t; + shims_map: Module_name.t Module_name_map.t; sources: string list; suffix: string; } @@ -50,7 +50,7 @@ let default = namespace = None; platform_lib = ""; project_root = ""; - shims_map = ModuleNameMap.empty; + shims_map = Module_name_map.empty; sources = []; suffix = ".bs.js"; } @@ -115,11 +115,11 @@ let build_config ~namespace = |> List.fold_left (fun map (from_module, to_module) -> let module_name = - (from_module |> ModuleName.from_string_unsafe : ModuleName.t) + (from_module |> Module_name.from_string_unsafe : Module_name.t) in - let shim_module_name = to_module |> ModuleName.from_string_unsafe in - ModuleNameMap.add module_name shim_module_name map) - ModuleNameMap.empty + let shim_module_name = to_module |> Module_name.from_string_unsafe in + Module_name_map.add module_name shim_module_name map) + Module_name_map.empty in let project_root = match !project_root with @@ -150,7 +150,8 @@ let build_config ~namespace = Log_.item "Project root: %s\n" project_root; if bsb_project_root <> project_root then Log_.item "bsb project root: %s\n" bsb_project_root; - Log_.item "Config shims:%d entries \n" (shims_map |> ModuleNameMap.cardinal)); + Log_.item "Config shims:%d entries \n" + (shims_map |> Module_name_map.cardinal)); let dep_paths = let tbl = Hashtbl.create (List.length !dep_paths_flag) in List.iter (fun (name, path) -> Hashtbl.add tbl name path) !dep_paths_flag; diff --git a/compiler/gentype/GenTypeMain.ml b/compiler/gentype/gen_type_main.ml similarity index 84% rename from compiler/gentype/GenTypeMain.ml rename to compiler/gentype/gen_type_main.ml index ed5d41654a2..4457545bca5 100644 --- a/compiler/gentype/GenTypeMain.ml +++ b/compiler/gentype/gen_type_main.ml @@ -1,4 +1,4 @@ -module StringSet = Set.Make (String) +module String_set = Set.Make (String) let cmt_check_annotations ~check_annotation input_cmt = match input_cmt.Cmt_format.cmt_annots with @@ -24,9 +24,9 @@ let signature_item_is_declaration signature_item = | _ -> false let input_cmt_translate_type_declarations ~config ~output_file_relative - ~resolver input_cmt : CodeItem.translation = + ~resolver input_cmt : Code_item.translation = let {Cmt_format.cmt_annots} = input_cmt in - let type_env = TypeEnv.root () in + let type_env = Type_env.root () in let translations = match cmt_annots with | Implementation structure -> @@ -35,7 +35,7 @@ let input_cmt_translate_type_declarations ~config ~output_file_relative str_items = structure.str_items |> List.filter structure_item_is_declaration; } - |> TranslateStructure.translate_structure ~config ~output_file_relative + |> Translate_structure.translate_structure ~config ~output_file_relative ~resolver ~type_env | Interface signature -> { @@ -43,7 +43,7 @@ let input_cmt_translate_type_declarations ~config ~output_file_relative sig_items = signature.sig_items |> List.filter signature_item_is_declaration; } - |> TranslateSignature.translate_signature ~config ~output_file_relative + |> Translate_signature.translate_signature ~config ~output_file_relative ~resolver ~type_env | Packed _ | Partial_implementation _ | Partial_interface _ -> [] in @@ -53,16 +53,16 @@ let input_cmt_translate_type_declarations ~config ~output_file_relative let translate_c_m_t ~config ~output_file_relative ~resolver input_cmt : Translation.t = let {Cmt_format.cmt_annots} = input_cmt in - let type_env = TypeEnv.root () in + let type_env = Type_env.root () in let translations = match cmt_annots with | Implementation structure -> structure - |> TranslateStructure.translate_structure ~config ~output_file_relative + |> Translate_structure.translate_structure ~config ~output_file_relative ~resolver ~type_env | Interface signature -> signature - |> TranslateSignature.translate_signature ~config ~output_file_relative + |> Translate_signature.translate_signature ~config ~output_file_relative ~resolver ~type_env | _ -> [] in @@ -73,14 +73,14 @@ let emit_translation ~config ~file_name ~output_file ~output_file_relative ~resolver ~source_file translation = let code_text = translation - |> EmitJs.emit_translation_as_string ~config ~file_name + |> Emit_js.emit_translation_as_string ~config ~file_name ~output_file_relative ~resolver ~input_cmt_translate_type_declarations in let file_contents = - EmitType.file_header ~source_file:(Filename.basename source_file) + Emit_type.file_header ~source_file:(Filename.basename source_file) ^ "\n" ^ code_text ^ "\n" in - GeneratedFiles.write_file_if_required ~output_file ~file_contents + Generated_files.write_file_if_required ~output_file ~file_contents let read_cmt cmt_file = try Cmt_format.read_cmt cmt_file @@ -144,10 +144,10 @@ let process_cmt_file cmt = read_input_cmt is_interface cmt_file in let source_file = - match input_cmt.cmt_annots |> FindSourceFile.cmt with + match input_cmt.cmt_annots |> Find_source_file.cmt with | Some source_file -> source_file | None -> ( - (file_name |> ModuleName.to_string) + (file_name |> Module_name.to_string) ^ match is_interface with | true -> ".resi" @@ -158,7 +158,7 @@ let process_cmt_file cmt = source_file |> Paths.get_output_file_relative ~config in let resolver = - ModuleResolver.create_lazy_resolver ~config + Module_resolver.create_lazy_resolver ~config ~extensions:[".res"; ".shim.ts"] ~exclude_file:(fun fname -> fname = "React.res" || fname = "ReasonReact.res") in @@ -168,8 +168,8 @@ let process_cmt_file cmt = |> emit_translation ~config ~file_name ~output_file ~output_file_relative ~resolver ~source_file else if input_cmt |> cmt_has_type_errors then - output_file |> GeneratedFiles.log_file_action TypeError + output_file |> Generated_files.log_file_action TypeError else ( - output_file |> GeneratedFiles.log_file_action NoMatch; + output_file |> Generated_files.log_file_action NoMatch; if Sys.file_exists output_file then Sys.remove output_file) [@@live] diff --git a/compiler/gentype/GeneratedFiles.ml b/compiler/gentype/generated_files.ml similarity index 100% rename from compiler/gentype/GeneratedFiles.ml rename to compiler/gentype/generated_files.ml diff --git a/compiler/gentype/ImportPath.ml b/compiler/gentype/import_path.ml similarity index 81% rename from compiler/gentype/ImportPath.ml rename to compiler/gentype/import_path.ml index dcc8d94983b..fb7d51858c3 100644 --- a/compiler/gentype/ImportPath.ml +++ b/compiler/gentype/import_path.ml @@ -1,4 +1,4 @@ -open GenTypeCommon +open Gen_type_common type t = string * string @@ -6,8 +6,8 @@ let bs_curry_path ~config = ("", Config.get_bs_curry_path ~config) let from_module ~dir ~import_extension module_name = let with_no_path = - (module_name |> ModuleName.to_string - |> ScopedPackage.remove_generated_module) + (module_name |> Module_name.to_string + |> Scoped_package.remove_generated_module) ^ import_extension in (dir, with_no_path) @@ -17,7 +17,7 @@ let from_string_unsafe s = ("", s) let chop_extension_safe (dir, s) = try (dir, s |> Filename.chop_extension) with Invalid_argument _ -> (dir, s) -let dump (dir, s) = NodeFilename.concat dir s +let dump (dir, s) = Node_filename.concat dir s let to_cmt ~(config : Config.t) ~output_file_relative (dir, s) = let open Filename in diff --git a/compiler/gentype/ImportPath.mli b/compiler/gentype/import_path.mli similarity index 89% rename from compiler/gentype/ImportPath.mli rename to compiler/gentype/import_path.mli index f44a63cc5bb..ae4c2a3e1d8 100644 --- a/compiler/gentype/ImportPath.mli +++ b/compiler/gentype/import_path.mli @@ -1,4 +1,4 @@ -open GenTypeCommon +open Gen_type_common type t @@ -6,6 +6,6 @@ val bs_curry_path : config:Config.t -> t val chop_extension_safe : t -> t [@@live] val dump : t -> string val emit : t -> string -val from_module : dir:string -> import_extension:string -> ModuleName.t -> t +val from_module : dir:string -> import_extension:string -> Module_name.t -> t val from_string_unsafe : string -> t val to_cmt : config:Config.t -> output_file_relative:string -> t -> string diff --git a/compiler/gentype/Indent.ml b/compiler/gentype/indent.ml similarity index 100% rename from compiler/gentype/Indent.ml rename to compiler/gentype/indent.ml diff --git a/compiler/gentype/Log_.ml b/compiler/gentype/log_.ml similarity index 100% rename from compiler/gentype/Log_.ml rename to compiler/gentype/log_.ml diff --git a/compiler/gentype/ModuleExtension.ml b/compiler/gentype/module_extension.ml similarity index 97% rename from compiler/gentype/ModuleExtension.ml rename to compiler/gentype/module_extension.ml index 0a1604f36f7..8181124e101 100644 --- a/compiler/gentype/ModuleExtension.ml +++ b/compiler/gentype/module_extension.ml @@ -1,4 +1,4 @@ -open GenTypeCommon +open Gen_type_common let shim_ts_output_file_extension ~(config : Config.t) = match config.module_resolution with diff --git a/compiler/gentype/ModuleName.ml b/compiler/gentype/module_name.ml similarity index 100% rename from compiler/gentype/ModuleName.ml rename to compiler/gentype/module_name.ml diff --git a/compiler/gentype/ModuleName.mli b/compiler/gentype/module_name.mli similarity index 100% rename from compiler/gentype/ModuleName.mli rename to compiler/gentype/module_name.mli diff --git a/compiler/gentype/ModuleResolver.ml b/compiler/gentype/module_resolver.ml similarity index 82% rename from compiler/gentype/ModuleResolver.ml rename to compiler/gentype/module_resolver.ml index c52efa3dd74..b85639b6f95 100644 --- a/compiler/gentype/ModuleResolver.ml +++ b/compiler/gentype/module_resolver.ml @@ -1,5 +1,5 @@ -open GenTypeCommon -module ModuleNameMap = Map.Make (ModuleName) +open Gen_type_common +module Module_name_map = Map.Make (Module_name) let ( +++ ) = Filename.concat @@ -28,8 +28,8 @@ let sourcedirs_to_map ~(config : Config.t) ~extensions ~exclude_file = | fname_chopped -> fname_chopped |> chop_extensions | exception _ -> fname in - let file_map = ref ModuleNameMap.empty in - let bs_dependencies_file_map = ref ModuleNameMap.empty in + let file_map = ref Module_name_map.empty in + let bs_dependencies_file_map = ref Module_name_map.empty in let filter_given_extension file_name = extensions |> List.exists (fun ext -> Filename.check_suffix file_name ext) && not (exclude_file file_name) @@ -40,8 +40,8 @@ let sourcedirs_to_map ~(config : Config.t) ~extensions ~exclude_file = if fname |> filter then map := !map - |> ModuleNameMap.add - (fname |> chop_extensions |> ModuleName.from_string_unsafe) + |> Module_name_map.add + (fname |> chop_extensions |> Module_name.from_string_unsafe) dir_emitted) in config.sources @@ -72,7 +72,7 @@ type case = Lowercase | Uppercase type resolver = { lazy_find: - (use_bs_dependencies:bool -> ModuleName.t -> (string * case * bool) option) + (use_bs_dependencies:bool -> Module_name.t -> (string * case * bool) option) Lazy.t; } @@ -84,12 +84,13 @@ let create_lazy_resolver ~config ~extensions ~exclude_file = sourcedirs_to_map ~config ~extensions ~exclude_file in let find ~bs_dependencies ~map module_name = - match map |> ModuleNameMap.find module_name with + match map |> Module_name_map.find module_name with | resolved_module_dir -> Some (resolved_module_dir, Uppercase, bs_dependencies) | exception Not_found -> ( match - map |> ModuleNameMap.find (module_name |> ModuleName.uncapitalize) + map + |> Module_name_map.find (module_name |> Module_name.uncapitalize) with | resolved_module_dir -> Some (resolved_module_dir, Lowercase, bs_dependencies) @@ -122,12 +123,12 @@ let resolve_module ~(config : Config.t) ~import_extension ~output_file_relative let module_name_res_file = (* Check if the module is in the same directory as the file being generated. So if e.g. project_root/src/ModuleName.res exists. *) - output_file_absolute_dir +++ (ModuleName.to_string module_name ^ ".res") + output_file_absolute_dir +++ (Module_name.to_string module_name ^ ".res") in let candidate = (* e.g. import "./Modulename.ext" *) module_name - |> ImportPath.from_module ~dir:Filename.current_dir_name ~import_extension + |> Import_path.from_module ~dir:Filename.current_dir_name ~import_extension in if Sys.file_exists module_name_res_file then candidate else @@ -159,42 +160,44 @@ let resolve_module ~(config : Config.t) ~import_extension ~output_file_relative (* e.g. import "../dst/ModuleName.ext" *) (match case = Uppercase with | true -> module_name - | false -> module_name |> ModuleName.uncapitalize) - |> ImportPath.from_module ~dir:from_output_dir_to_module_dir + | false -> module_name |> Module_name.uncapitalize) + |> Import_path.from_module ~dir:from_output_dir_to_module_dir ~import_extension let resolve_generated_module ~config ~output_file_relative ~resolver module_name = if !Debug.module_resolution then Log_.item "Resolve Generated Module: %s\n" - (module_name |> ModuleName.to_string); + (module_name |> Module_name.to_string); let import_path = resolve_module ~config - ~import_extension:(ModuleExtension.generated_module_extension ~config) + ~import_extension:(Module_extension.generated_module_extension ~config) ~output_file_relative ~resolver ~use_bs_dependencies:true module_name in if !Debug.module_resolution then - Log_.item "Import Path: %s\n" (import_path |> ImportPath.dump); + Log_.item "Import Path: %s\n" (import_path |> Import_path.dump); import_path (** Returns the path to import a given Reason module name. *) let import_path_for_reason_module_name ~(config : Config.t) ~output_file_relative ~resolver module_name = if !Debug.module_resolution then - Log_.item "Resolve Reason Module: %s\n" (module_name |> ModuleName.to_string); - match config.shims_map |> ModuleNameMap.find module_name with + Log_.item "Resolve Reason Module: %s\n" + (module_name |> Module_name.to_string); + match config.shims_map |> Module_name_map.find module_name with | shim_module_name -> if !Debug.module_resolution then - Log_.item "ShimModuleName: %s\n" (shim_module_name |> ModuleName.to_string); + Log_.item "ShimModuleName: %s\n" + (shim_module_name |> Module_name.to_string); let import_extension = - ModuleExtension.shim_ts_output_file_extension ~config + Module_extension.shim_ts_output_file_extension ~config in let import_path = resolve_module ~config ~import_extension ~output_file_relative ~resolver ~use_bs_dependencies:false shim_module_name in if !Debug.module_resolution then - Log_.item "Import Path: %s\n" (import_path |> ImportPath.dump); + Log_.item "Import Path: %s\n" (import_path |> Import_path.dump); import_path | exception Not_found -> module_name diff --git a/compiler/gentype/NamedArgs.ml b/compiler/gentype/named_args.ml similarity index 95% rename from compiler/gentype/NamedArgs.ml rename to compiler/gentype/named_args.ml index 4d34a0fa28a..59dc0ed448e 100644 --- a/compiler/gentype/NamedArgs.ml +++ b/compiler/gentype/named_args.ml @@ -1,4 +1,4 @@ -open GenTypeCommon +open Gen_type_common let group labeled_types = let types = diff --git a/compiler/gentype/Paths.ml b/compiler/gentype/paths.ml similarity index 92% rename from compiler/gentype/Paths.ml rename to compiler/gentype/paths.ml index c1407ae499b..20371e2b4e4 100644 --- a/compiler/gentype/Paths.ml +++ b/compiler/gentype/paths.ml @@ -1,4 +1,4 @@ -open GenTypeCommon +open Gen_type_common let concat = Filename.concat @@ -43,20 +43,20 @@ let remove_path_prefix ~prefix path = let append_suffix ~config source_path = (source_path |> handle_namespace) - ^ ModuleExtension.ts_input_file_suffix ~config + ^ Module_extension.ts_input_file_suffix ~config let get_output_file_relative ~(config : Config.t) source_path = - let relativePath = + let relative_path = remove_path_prefix ~prefix:config.project_root source_path in - append_suffix ~config relativePath + append_suffix ~config relative_path let get_output_file ~(config : Config.t) source_path = let relative_output_path = get_output_file_relative ~config source_path in Filename.concat config.project_root relative_output_path let get_module_name cmt = - cmt |> handle_namespace |> Filename.basename |> ModuleName.from_string_unsafe + cmt |> handle_namespace |> Filename.basename |> Module_name.from_string_unsafe let get_cmt_file cmt = let path_cmt = diff --git a/compiler/gentype/ResolvedName.ml b/compiler/gentype/resolved_name.ml similarity index 86% rename from compiler/gentype/ResolvedName.ml rename to compiler/gentype/resolved_name.ml index 79e737d35e8..0f58b115808 100644 --- a/compiler/gentype/ResolvedName.ml +++ b/compiler/gentype/resolved_name.ml @@ -7,7 +7,7 @@ let to_string x = x |> String.concat "_" type eq = t * t -module NameSet = Set.Make (struct +module Name_set = Set.Make (struct type nonrec t = t let rec compare (x : t) (y : t) = @@ -38,13 +38,13 @@ let rec apply_equations_to_elements ~(eqs : eq list) ~seen (elements : t list) : eqs |> List.map (apply_equation ~el) |> List.concat - |> List.filter (fun y -> not (NameSet.mem y seen)) + |> List.filter (fun y -> not (Name_set.mem y seen)) in fresh_elements |> List.map (fun el_fresh -> (el_fresh, el)) in let new_equations = elements |> List.map apply_eqs |> List.concat in let new_elements = new_equations |> List.map fst in - let new_seen = NameSet.union seen (new_elements |> NameSet.of_list) in + let new_seen = Name_set.union seen (new_elements |> Name_set.of_list) in match new_equations = [] with | true -> new_equations | false -> @@ -56,4 +56,4 @@ let rec apply_equations_to_elements ~(eqs : eq list) ~seen (elements : t list) : E.g. if the element is X.Y.t, return equation A.t = X.Y.t *) let apply_equations ~(eqs : eq list) (el : t) : eq list = - [el] |> apply_equations_to_elements ~eqs ~seen:NameSet.empty + [el] |> apply_equations_to_elements ~eqs ~seen:Name_set.empty diff --git a/compiler/gentype/ResolvedName.mli b/compiler/gentype/resolved_name.mli similarity index 100% rename from compiler/gentype/ResolvedName.mli rename to compiler/gentype/resolved_name.mli diff --git a/compiler/gentype/Runtime.ml b/compiler/gentype/runtime.ml similarity index 95% rename from compiler/gentype/Runtime.ml rename to compiler/gentype/runtime.ml index e8b14e21e9d..8fe4729a8ec 100644 --- a/compiler/gentype/Runtime.ml +++ b/compiler/gentype/runtime.ml @@ -11,7 +11,7 @@ let rec emit_module_access_path ~config module_access_path = | Dot (p, module_item) -> p |> emit_module_access_path ~config - |> EmitText.field_access ~label:module_item + |> Emit_text.field_access ~label:module_item let js_variant_tag ~polymorphic ~tag = match polymorphic with diff --git a/compiler/gentype/Runtime.mli b/compiler/gentype/runtime.mli similarity index 96% rename from compiler/gentype/Runtime.mli rename to compiler/gentype/runtime.mli index d220a0a7b51..36f73ddb297 100644 --- a/compiler/gentype/Runtime.mli +++ b/compiler/gentype/runtime.mli @@ -1,4 +1,4 @@ -open GenTypeCommon +open Gen_type_common type module_item type module_access_path = diff --git a/compiler/gentype/TranslateCoreType.ml b/compiler/gentype/translate_core_type.ml similarity index 96% rename from compiler/gentype/TranslateCoreType.ml rename to compiler/gentype/translate_core_type.ml index 882aa87ba6a..2c6d39b407e 100644 --- a/compiler/gentype/TranslateCoreType.ml +++ b/compiler/gentype/translate_core_type.ml @@ -1,5 +1,5 @@ -open GenTypeCommon -open! TranslateTypeExprFromTypes +open Gen_type_common +open! Translate_type_expr_from_types let remove_option ~(label : Asttypes.arg_label) (core_type : Typedtree.core_type) = @@ -115,7 +115,7 @@ let rec translate_arrow_type ~config ~type_vars_gen | false -> dependencies) in let labeled_convertable_types = rev_args |> List.rev in - let arg_types = labeled_convertable_types |> NamedArgs.group in + let arg_types = labeled_convertable_types |> Named_args.group in let function_type = Function {arg_types; ret_type; type_vars = []} in {dependencies = all_deps; type_ = function_type} @@ -148,7 +148,7 @@ and translateCoreType_ ~config ~type_vars_gen let params_translation = type_params |> translateCoreTypes_ ~config ~type_vars_gen ~type_env in - TranslateTypeExprFromTypes.translate_constr ~config ~params_translation + Translate_type_expr_from_types.translate_constr ~config ~params_translation ~path ~type_env | Ttyp_poly (_, t) -> t @@ -248,7 +248,7 @@ and translateCoreType_ ~config ~type_vars_gen in {dependencies; type_}) | Ttyp_package {pack_path; pack_fields} -> ( - match type_env |> TypeEnv.lookup_module_type_signature ~path:pack_path with + match type_env |> Type_env.lookup_module_type_signature ~path:pack_path with | Some (signature, type_env) -> let type_equations_translation = pack_fields @@ -265,7 +265,7 @@ and translateCoreType_ ~config ~type_vars_gen |> List.map (fun (_, translation) -> translation.dependencies) |> List.flatten in - let type_env1 = type_env |> TypeEnv.add_type_equations ~type_equations in + let type_env1 = type_env |> Type_env.add_type_equations ~type_equations in let dependencies_from_record_type, type_ = signature.sig_type |> signature_to_module_runtime_representation ~config ~type_vars_gen @@ -284,7 +284,7 @@ and translateCoreTypes_ ~config ~type_vars_gen ~type_env type_exprs : type_exprs |> List.map (translateCoreType_ ~config ~type_vars_gen ~type_env) let translate_core_type ~config ~type_env core_type = - let type_vars_gen = GenIdent.create_type_vars_gen () in + let type_vars_gen = Gen_ident.create_type_vars_gen () in let translation = core_type |> translateCoreType_ ~config ~type_vars_gen ~type_env in diff --git a/compiler/gentype/TranslateSignature.ml b/compiler/gentype/translate_signature.ml similarity index 93% rename from compiler/gentype/TranslateSignature.ml rename to compiler/gentype/translate_signature.ml index 9271f41a90d..d7a8ec4c9b4 100644 --- a/compiler/gentype/TranslateSignature.ml +++ b/compiler/gentype/translate_signature.ml @@ -1,4 +1,4 @@ -open GenTypeCommon +open Gen_type_common let translate_signature_value ~config ~output_file_relative ~resolver ~type_env (value_description : Typedtree.value_description) : Translation.t = @@ -24,14 +24,14 @@ let rec translate_module_declaration ~config ~output_file_relative ~resolver ~type_env ({md_id; md_type} : Typedtree.module_declaration) = let name = md_id |> Ident.name in if !Debug.translation then Log_.item "Translate Module Declaration %s\n" name; - let type_env = type_env |> TypeEnv.new_module ~name in + let type_env = type_env |> Type_env.new_module ~name in match md_type.mty_desc with | Tmty_signature signature -> signature |> translate_signature ~config ~output_file_relative ~resolver ~type_env |> Translation.combine | Tmty_ident (path, _) -> ( - match type_env |> TypeEnv.lookup_module_type_signature ~path with + match type_env |> Type_env.lookup_module_type_signature ~path with | None -> Translation.empty | Some (signature, _) -> signature @@ -74,7 +74,7 @@ and translate_module_type_declaration ~config ~output_file_relative ~resolver let translation = signature_without_values |> translate_signature ~config ~output_file_relative ~resolver - ~type_env:(type_env |> TypeEnv.new_module_type ~name ~signature) + ~type_env:(type_env |> Type_env.new_module_type ~name ~signature) |> Translation.combine in translation @@ -103,7 +103,7 @@ and translate_signature_item ~config ~output_file_relative ~resolver ~type_env code_items = []; type_declarations = type_declarations - |> TranslateTypeDeclarations.translate_type_declarations ~config + |> Translate_type_declarations.translate_type_declarations ~config ~output_file_relative ~recursive:(rec_flag = Recursive) ~resolver ~type_env; } @@ -120,7 +120,7 @@ and translate_signature_item ~config ~output_file_relative ~resolver ~type_env let module_item = Runtime.new_module_item ~name:(value_description.val_id |> Ident.name) in - type_env |> TypeEnv.update_module_item ~module_item; + type_env |> Type_env.update_module_item ~module_item; value_description |> translate_signature_value ~config ~output_file_relative ~resolver ~type_env @@ -137,7 +137,7 @@ and translate_signature_item ~config ~output_file_relative ~resolver ~type_env module_type_declaration.mtd_attributes |> Annotation.update_config_for_module ~config in - type_env |> TypeEnv.update_module_item ~module_item; + type_env |> Type_env.update_module_item ~module_item; module_type_declaration |> translate_module_type_declaration ~config ~output_file_relative ~resolver ~type_env diff --git a/compiler/gentype/TranslateSignatureFromTypes.ml b/compiler/gentype/translate_signature_from_types.ml similarity index 86% rename from compiler/gentype/TranslateSignatureFromTypes.ml rename to compiler/gentype/translate_signature_from_types.ml index 8672a95c39a..be847c6f52b 100644 --- a/compiler/gentype/TranslateSignatureFromTypes.ml +++ b/compiler/gentype/translate_signature_from_types.ml @@ -1,29 +1,29 @@ -open GenTypeCommon +open Gen_type_common (** Like translateTypeDeclaration but from Types not Typedtree *) let translate_type_declaration_from_types ~config ~output_file_relative ~resolver ~type_env ~id ({type_attributes; type_kind; type_loc; type_manifest; type_params} : - Types.type_declaration) : CodeItem.type_declaration list = - type_env |> TypeEnv.new_type ~name:(id |> Ident.name); + Types.type_declaration) : Code_item.type_declaration list = + type_env |> Type_env.new_type ~name:(id |> Ident.name); let type_name = Ident.name id in - let type_vars = type_params |> TypeVars.extract_from_type_expr in + let type_vars = type_params |> Type_vars.extract_from_type_expr in if !Debug.translation then Log_.item "Translate Types.type_declaration %s\n" type_name; let declaration_kind = match type_kind with | Type_record (label_declarations, _) -> - TranslateTypeDeclarations.RecordDeclarationFromTypes label_declarations + Translate_type_declarations.RecordDeclarationFromTypes label_declarations | Type_variant constructor_declarations when not - (TranslateTypeDeclarations.has_some_gadt_leaf + (Translate_type_declarations.has_some_gadt_leaf constructor_declarations) -> VariantDeclarationFromTypes constructor_declarations | Type_abstract -> GeneralDeclarationFromTypes type_manifest | _ -> NoDeclaration in declaration_kind - |> TranslateTypeDeclarations.traslate_declaration_kind ~config ~loc:type_loc + |> Translate_type_declarations.traslate_declaration_kind ~config ~loc:type_loc ~output_file_relative ~resolver ~type_attributes ~type_env ~type_name ~type_vars @@ -36,7 +36,7 @@ let rec translate_module_declaration_from_types ~config ~output_file_relative let name = id |> Ident.name in signature |> translate_signature_from_types ~config ~output_file_relative ~resolver - ~type_env:(type_env |> TypeEnv.new_module ~name) + ~type_env:(type_env |> Type_env.new_module ~name) |> Translation.combine | Mty_ident _ -> log_not_implemented ("Mty_ident " ^ __LOC__); @@ -67,7 +67,7 @@ and translate_signature_item_from_types ~config ~output_file_relative ~resolver module_declaration.md_attributes |> Annotation.update_config_for_module ~config in - type_env |> TypeEnv.update_module_item ~module_item; + type_env |> Type_env.update_module_item ~module_item; module_declaration |> translate_module_declaration_from_types ~config ~output_file_relative ~resolver ~type_env ~id @@ -75,7 +75,7 @@ and translate_signature_item_from_types ~config ~output_file_relative ~resolver let name = id |> Ident.name |> Ext_ident.unwrap_uppercase_exotic in if !Debug.translation then Log_.item "Translate Sig Value %s\n" name; let module_item = Runtime.new_module_item ~name in - type_env |> TypeEnv.update_module_item ~module_item; + type_env |> Type_env.update_module_item ~module_item; if val_attributes |> Annotation.from_attributes ~config ~loc:val_loc diff --git a/compiler/gentype/TranslateStructure.ml b/compiler/gentype/translate_structure.ml similarity index 88% rename from compiler/gentype/TranslateStructure.ml rename to compiler/gentype/translate_structure.ml index f0f89f943a3..1b3ad813f88 100644 --- a/compiler/gentype/TranslateStructure.ml +++ b/compiler/gentype/translate_structure.ml @@ -1,4 +1,4 @@ -open GenTypeCommon +open Gen_type_common let rec addAnnotationsToTypes_ ~config ~(expr : Typedtree.expression) (arg_types : arg_type list) = @@ -22,7 +22,7 @@ let rec addAnnotationsToTypes_ ~config ~(expr : Typedtree.expression) {funct = {exp_desc = Texp_ident (path, _, _)}; args = [(_, Some expr1)]}, _, _ ) -> ( - match path |> TranslateTypeExprFromTypes.path_to_list |> List.rev with + match path |> Translate_type_expr_from_types.path_to_list |> List.rev with | ["Js"; "Internal"; fn_mk] when (* Uncurried function definition uses Js.Internal.fn_mkX(...) *) String.length fn_mk >= 5 @@ -54,7 +54,7 @@ and add_annotations_to_fields ~config (expr : Typedtree.expression) add_annotations_to_fields ~config c_rhs next_fields arg_types in let name = - TranslateTypeDeclarations.rename_record_field + Translate_type_declarations.rename_record_field ~attributes:expr.exp_attributes ~name:field.name_js in ({field with name_js = name} :: next_fields1, types1) @@ -77,10 +77,10 @@ let remove_value_binding_duplicates structure_items = match bindings with | ({vb_pat = {pat_desc = Tpat_var (id, _)}} as binding) :: other_bindings -> let name = Ident.name id in - if !seen |> StringSet.mem name then + if !seen |> String_set.mem name then other_bindings |> process_bindings ~seen else ( - seen := !seen |> StringSet.add name; + seen := !seen |> String_set.add name; binding :: (other_bindings |> process_bindings ~seen)) | binding :: other_bindings -> binding :: (other_bindings |> process_bindings ~seen) @@ -98,7 +98,7 @@ let remove_value_binding_duplicates structure_items = | [] -> acc in structure_items |> List.rev - |> process_items ~acc:[] ~seen:(ref StringSet.empty) + |> process_items ~acc:[] ~seen:(ref String_set.empty) let translate_value_binding ~config ~output_file_relative ~resolver ~type_env {Typedtree.vb_attributes; vb_expr; vb_pat} : Translation.t = @@ -107,7 +107,7 @@ let translate_value_binding ~config ~output_file_relative ~resolver ~type_env let name = id |> Ident.name |> Ext_ident.unwrap_uppercase_exotic in if !Debug.translation then Log_.item "Translate Value Binding %s\n" name; let module_item = Runtime.new_module_item ~name in - type_env |> TypeEnv.update_module_item ~module_item; + type_env |> Type_env.update_module_item ~module_item; if vb_attributes |> Annotation.from_attributes ~config ~loc:vb_pat.pat_loc @@ -135,7 +135,7 @@ let rec remove_duplicate_value_bindings |> List.filter (fun value_binding -> match value_binding with | {Typedtree.vb_pat = {pat_desc = Tpat_var (id, _)}} -> - not (bound_in_rest |> StringSet.mem (id |> Ident.name)) + not (bound_in_rest |> String_set.mem (id |> Ident.name)) | _ -> true) in let bound = @@ -144,7 +144,7 @@ let rec remove_duplicate_value_bindings (fun bound (value_binding : Typedtree.value_binding) -> match value_binding with | {vb_pat = {pat_desc = Tpat_var (id, _)}} -> - bound |> StringSet.add (id |> Ident.name) + bound |> String_set.add (id |> Ident.name) | _ -> bound) bound_in_rest in @@ -156,9 +156,9 @@ let rec remove_duplicate_value_bindings rest |> remove_duplicate_value_bindings in (bound_in_rest, structure_item :: filtered_rest) - | [] -> (StringSet.empty, []) + | [] -> (String_set.empty, []) -let rec translate_module_binding ~(config : GenTypeConfig.t) +let rec translate_module_binding ~(config : Gen_type_config.t) ~output_file_relative ~resolver ~type_env ({mb_id; mb_expr; mb_attributes} : Typedtree.module_binding) : Translation.t = @@ -166,18 +166,18 @@ let rec translate_module_binding ~(config : GenTypeConfig.t) if !Debug.translation then Log_.item "Translate Module Binding %s\n" name; let module_item = Runtime.new_module_item ~name in let config = mb_attributes |> Annotation.update_config_for_module ~config in - type_env |> TypeEnv.update_module_item ~module_item; - let type_env = type_env |> TypeEnv.new_module ~name in + type_env |> Type_env.update_module_item ~module_item; + let type_env = type_env |> Type_env.new_module ~name in match mb_expr.mod_desc with | Tmod_ident (path, _) -> ( let dep = path |> Dependencies.from_path ~config ~type_env in let internal = dep |> Dependencies.is_internal in - type_env |> TypeEnv.add_module_equation ~dep ~internal; + type_env |> Type_env.add_module_equation ~dep ~internal; match Env.scrape_alias mb_expr.mod_env mb_expr.mod_type with | Mty_signature signature -> (* Treat module M = N as include N *) signature - |> TranslateSignatureFromTypes.translate_signature_from_types ~config + |> Translate_signature_from_types.translate_signature_from_types ~config ~output_file_relative ~resolver ~type_env |> Translation.combine | Mty_alias _ | Mty_ident _ | Mty_functor _ -> Translation.empty) @@ -195,7 +195,7 @@ let rec translate_module_binding ~(config : GenTypeConfig.t) match mb_expr.mod_type with | Mty_signature signature -> signature - |> TranslateSignatureFromTypes.translate_signature_from_types ~config + |> Translate_signature_from_types.translate_signature_from_types ~config ~output_file_relative ~resolver ~type_env |> Translation.combine | Mty_ident _ -> @@ -211,15 +211,15 @@ let rec translate_module_binding ~(config : GenTypeConfig.t) match module_type with | Mty_signature signature -> signature - |> TranslateSignatureFromTypes.translate_signature_from_types ~config + |> Translate_signature_from_types.translate_signature_from_types ~config ~output_file_relative ~resolver ~type_env |> Translation.combine | Mty_ident path -> ( - match type_env |> TypeEnv.lookup_module_type_signature ~path with + match type_env |> Type_env.lookup_module_type_signature ~path with | None -> Translation.empty | Some (signature, _) -> signature - |> TranslateSignature.translate_signature ~config ~output_file_relative + |> Translate_signature.translate_signature ~config ~output_file_relative ~resolver ~type_env |> Translation.combine) | Mty_functor _ -> @@ -232,17 +232,17 @@ let rec translate_module_binding ~(config : GenTypeConfig.t) log_not_implemented ("Tmod_functor " ^ __LOC__); Translation.empty | Tmod_constraint (_, Mty_ident path, Tmodtype_explicit _, Tcoerce_none) -> ( - match type_env |> TypeEnv.lookup_module_type_signature ~path with + match type_env |> Type_env.lookup_module_type_signature ~path with | None -> Translation.empty | Some (signature, _) -> signature - |> TranslateSignature.translate_signature ~config ~output_file_relative + |> Translate_signature.translate_signature ~config ~output_file_relative ~resolver ~type_env |> Translation.combine) | Tmod_constraint (_, Mty_signature signature, Tmodtype_explicit _, Tcoerce_none) -> signature - |> TranslateSignatureFromTypes.translate_signature_from_types ~config + |> Translate_signature_from_types.translate_signature_from_types ~config ~output_file_relative ~resolver ~type_env |> Translation.combine | Tmod_constraint @@ -262,7 +262,7 @@ let rec translate_module_binding ~(config : GenTypeConfig.t) Tmodtype_explicit {mty_desc = Tmty_signature {sig_type = signature}}, _ ) -> signature - |> TranslateSignatureFromTypes.translate_signature_from_types ~config + |> Translate_signature_from_types.translate_signature_from_types ~config ~output_file_relative ~resolver ~type_env |> Translation.combine | Tmod_constraint _ -> @@ -278,7 +278,7 @@ and translate_structure_item ~config ~output_file_relative ~resolver ~type_env code_items = []; type_declarations = type_declarations - |> TranslateTypeDeclarations.translate_type_declarations ~config + |> Translate_type_declarations.translate_type_declarations ~config ~output_file_relative ~recursive:(rec_flag = Recursive) ~resolver ~type_env; } @@ -299,7 +299,7 @@ and translate_structure_item ~config ~output_file_relative ~resolver ~type_env ~type_env | {str_desc = Tstr_modtype module_type_declaration} -> module_type_declaration - |> TranslateSignature.translate_module_type_declaration ~config + |> Translate_signature.translate_module_type_declaration ~config ~output_file_relative ~resolver ~type_env | {str_desc = Tstr_recmodule module_bindings} -> module_bindings @@ -337,7 +337,7 @@ and translate_structure_item ~config ~output_file_relative ~resolver ~type_env ~type_env | {str_desc = Tstr_include {incl_type = signature}} -> signature - |> TranslateSignatureFromTypes.translate_signature_from_types ~config + |> Translate_signature_from_types.translate_signature_from_types ~config ~output_file_relative ~resolver ~type_env |> Translation.combine | {str_desc = Tstr_eval _} -> diff --git a/compiler/gentype/TranslateTypeDeclarations.ml b/compiler/gentype/translate_type_declarations.ml similarity index 86% rename from compiler/gentype/TranslateTypeDeclarations.ml rename to compiler/gentype/translate_type_declarations.ml index 9d12689871d..01fe26c6583 100644 --- a/compiler/gentype/TranslateTypeDeclarations.ml +++ b/compiler/gentype/translate_type_declarations.ml @@ -1,4 +1,4 @@ -open GenTypeCommon +open Gen_type_common type declaration_kind = | RecordDeclarationFromTypes of Types.label_declaration list @@ -10,9 +10,9 @@ type declaration_kind = let create_export_type_from_type_declaration ~annotation ~loc ~name_as ~opaque ~type_ ~type_env ~doc_string type_name ~type_vars : - CodeItem.export_from_type_declaration = + Code_item.export_from_type_declaration = let resolved_type_name = - type_name |> sanitize_type_name |> TypeEnv.add_module_path ~type_env + type_name |> sanitize_type_name |> Type_env.add_module_path ~type_env in { export_type = @@ -53,7 +53,7 @@ let rename_record_field ~attributes ~name = let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver ~type_attributes ~type_env ~type_name ~type_vars declaration_kind : - CodeItem.type_declaration list = + Code_item.type_declaration list = let doc_string = type_attributes |> Annotation.doc_string_from_attrs in let annotation = type_attributes |> Annotation.from_attributes ~config ~loc in let opaque = @@ -69,13 +69,13 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver type_attributes |> Annotation.has_attribute Annotation.tag_is_unboxed in let tag_annotation = type_attributes |> Annotation.get_tag in - let return_type_declaration (type_declaration : CodeItem.type_declaration) = + let return_type_declaration (type_declaration : Code_item.type_declaration) = match opaque = Some true with | true -> [{type_declaration with import_types = []}] | false -> [type_declaration] in let handle_general_declaration - (translation : TranslateTypeExprFromTypes.translation) = + (translation : Translate_type_expr_from_types.translation) = let export_from_type_declaration = type_name |> create_export_type_from_type_declaration ~annotation ~loc ~name_as @@ -86,7 +86,7 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver |> Translation.translate_dependencies ~config ~output_file_relative ~resolver in - {CodeItem.import_types; export_from_type_declaration} + {Code_item.import_types; export_from_type_declaration} in let translate_label_declarations ?(inline = false) label_declarations = let field_translations = @@ -107,14 +107,14 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver mutability, ld_optional, ld_type - |> TranslateTypeExprFromTypes.translate_type_expr_from_types + |> Translate_type_expr_from_types.translate_type_expr_from_types ~config ~type_env, Annotation.doc_string_from_attrs ld_attributes )) in let dependencies = field_translations |> List.map - (fun (_, _, _, {TranslateTypeExprFromTypes.dependencies}, _) -> + (fun (_, _, _, {Translate_type_expr_from_types.dependencies}, _) -> dependencies) |> List.concat in @@ -125,7 +125,7 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver ( name, mutable_, optional_, - {TranslateTypeExprFromTypes.type_}, + {Translate_type_expr_from_types.type_}, doc_string ) -> let optional, type1 = @@ -140,14 +140,14 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver | [field] when unboxed_annotation -> field.type_ | _ -> Object ((if inline then Inline else Closed), fields) in - {TranslateTypeExprFromTypes.dependencies; type_} + {Translate_type_expr_from_types.dependencies; type_} in match (declaration_kind, import_string_opt) with | _, Some import_string -> (* import type *) let typeName_ = type_name in let name_with_module_path = - typeName_ |> TypeEnv.add_module_path ~type_env |> ResolvedName.to_string + typeName_ |> Type_env.add_module_path ~type_env |> Resolved_name.to_string in let type_name, as_type_name = match name_as with @@ -157,9 +157,9 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver let import_types = [ { - CodeItem.type_name; + Code_item.type_name; as_type_name = Some as_type_name; - import_path = import_string |> ImportPath.from_string_unsafe; + import_path = import_string |> Import_path.from_string_unsafe; }; ] in @@ -173,10 +173,10 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver |> ident ~type_args:(type_vars |> List.map (fun s -> TypeVar s))) ~type_env ~type_vars in - [{CodeItem.import_types; export_from_type_declaration}] + [{Code_item.import_types; export_from_type_declaration}] | (GeneralDeclarationFromTypes None | GeneralDeclaration None), None -> { - CodeItem.import_types = []; + Code_item.import_types = []; export_from_type_declaration = type_name |> create_export_type_from_type_declaration ~doc_string ~annotation ~loc @@ -186,19 +186,19 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver | GeneralDeclarationFromTypes (Some type_expr), None -> let translation = type_expr - |> TranslateTypeExprFromTypes.translate_type_expr_from_types ~config + |> Translate_type_expr_from_types.translate_type_expr_from_types ~config ~type_env in translation |> handle_general_declaration |> return_type_declaration | GeneralDeclaration (Some core_type), None -> let translation = - core_type |> TranslateCoreType.translate_core_type ~config ~type_env + core_type |> Translate_core_type.translate_core_type ~config ~type_env in let type_ = match (core_type, translation.type_) with | {ctyp_desc = Ttyp_variant (row_fields, _, _)}, Variant variant -> let row_fields_variants = - row_fields |> TranslateCoreType.process_variant + row_fields |> Translate_core_type.process_variant in let no_payloads = row_fields_variants.no_payloads |> List.map (create_case ~poly:true) @@ -222,7 +222,7 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver {translation with type_} |> handle_general_declaration |> return_type_declaration | RecordDeclarationFromTypes label_declarations, None -> - let {TranslateTypeExprFromTypes.dependencies; type_} = + let {Translate_type_expr_from_types.dependencies; type_} = label_declarations |> translate_label_declarations in let import_types = @@ -231,7 +231,7 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver ~resolver in { - CodeItem.import_types; + Code_item.import_types; export_from_type_declaration = type_name |> create_export_type_from_type_declaration ~doc_string ~annotation ~loc @@ -249,8 +249,8 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver match constructor_args with | Cstr_tuple type_exprs -> type_exprs - |> TranslateTypeExprFromTypes.translate_type_exprs_from_types - ~config ~type_env + |> Translate_type_expr_from_types + .translate_type_exprs_from_types ~config ~type_env | Cstr_record label_declarations -> [ label_declarations @@ -259,11 +259,11 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver in let arg_types = args_translation - |> List.map (fun {TranslateTypeExprFromTypes.type_} -> type_) + |> List.map (fun {Translate_type_expr_from_types.type_} -> type_) in let import_types = args_translation - |> List.map (fun {TranslateTypeExprFromTypes.dependencies} -> + |> List.map (fun {Translate_type_expr_from_types.dependencies} -> dependencies) |> List.concat |> Translation.translate_dependencies ~config @@ -294,11 +294,11 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver ~tag:tag_annotation ~unboxed:unboxed_annotation in let resolved_type_name = - type_name |> sanitize_type_name |> TypeEnv.add_module_path ~type_env + type_name |> sanitize_type_name |> Type_env.add_module_path ~type_env in let export_from_type_declaration = { - CodeItem.export_type = + Code_item.export_type = { loc; name_as; @@ -316,7 +316,7 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver |> List.map (fun (_, _, _, import_types) -> import_types) |> List.concat in - {CodeItem.export_from_type_declaration; import_types} + {Code_item.export_from_type_declaration; import_types} |> return_type_declaration | NoDeclaration, None -> [] @@ -327,7 +327,7 @@ let has_some_gadt_leaf constructor_declarations = let translate_type_declaration ~config ~output_file_relative ~resolver ~type_env ({typ_attributes; typ_id; typ_loc; typ_manifest; typ_params; typ_type} : - Typedtree.type_declaration) : CodeItem.type_declaration list = + Typedtree.type_declaration) : Code_item.type_declaration list = if !Debug.translation then Log_.item "Translate Type Declaration %s\n" (typ_id |> Ident.name); @@ -335,7 +335,7 @@ let translate_type_declaration ~config ~output_file_relative ~resolver ~type_env let type_vars = typ_params |> List.map (fun (core_type, _) -> core_type) - |> TypeVars.extract_from_core_type + |> Type_vars.extract_from_core_type in let declaration_kind = match typ_type.type_kind with @@ -352,11 +352,11 @@ let translate_type_declaration ~config ~output_file_relative ~resolver ~type_env let add_type_declaration_id_to_type_env ~type_env ({typ_id} : Typedtree.type_declaration) = - type_env |> TypeEnv.new_type ~name:(typ_id |> Ident.name) + type_env |> Type_env.new_type ~name:(typ_id |> Ident.name) let translate_type_declarations ~config ~output_file_relative ~recursive ~resolver ~type_env (type_declarations : Typedtree.type_declaration list) : - CodeItem.type_declaration list = + Code_item.type_declaration list = if recursive then type_declarations |> List.iter (add_type_declaration_id_to_type_env ~type_env); diff --git a/compiler/gentype/TranslateTypeExprFromTypes.ml b/compiler/gentype/translate_type_expr_from_types.ml similarity index 95% rename from compiler/gentype/TranslateTypeExprFromTypes.ml rename to compiler/gentype/translate_type_expr_from_types.ml index 3bf09ca0fae..b4a48253217 100644 --- a/compiler/gentype/TranslateTypeExprFromTypes.ml +++ b/compiler/gentype/translate_type_expr_from_types.ml @@ -1,4 +1,4 @@ -open GenTypeCommon +open Gen_type_common type translation = {dependencies: dep list; type_: type_} @@ -50,7 +50,7 @@ let translate_obj_type closed_flag fields_translations = name_js = name; optional; type_; - doc_string = DocString.empty; + doc_string = Doc_string.empty; }) in let type_ = Object (closed_flag, fields) in @@ -66,7 +66,7 @@ let translate_constr ~config ~params_translation ~(path : Path.t) ~type_env = |> List.map (fun {dependencies} -> dependencies) |> List.concat in - match type_env |> TypeEnv.apply_type_equations ~config ~path with + match type_env |> Type_env.apply_type_equations ~config ~path with | Some type_ -> {dependencies = type_param_deps; type_} | None -> let dep = path |> Dependencies.from_path ~config ~type_env in @@ -318,7 +318,7 @@ let translate_constr ~config ~params_translation ~(path : Path.t) ~type_env = name_js = "contents"; optional = Mandatory; type_ = param_translation.type_; - doc_string = DocString.empty; + doc_string = Doc_string.empty; }; ] ); } @@ -372,36 +372,36 @@ let translate_constr ~config ~params_translation ~(path : Path.t) ~type_env = Function { arg_types = [{a_name = ""; a_type = props_translation.type_}]; - ret_type = EmitType.type_react_element; + ret_type = Emit_type.type_react_element; type_vars = []; }; } | ["React"; "Context"; "t"], [param_translation] -> { dependencies = param_translation.dependencies; - type_ = EmitType.type_react_context ~type_:param_translation.type_; + type_ = Emit_type.type_react_context ~type_:param_translation.type_; } | (["React"; "Ref"; "t"] | ["React"; "ref"]), [param_translation] -> { dependencies = param_translation.dependencies; - type_ = EmitType.type_react_ref ~type_:param_translation.type_; + type_ = Emit_type.type_react_ref ~type_:param_translation.type_; } | (["ReactDOM"; "domRef"] | ["ReactDOM"; "Ref"; "t"]), [] -> - {dependencies = []; type_ = EmitType.type_react_d_o_m_re_dom_ref} + {dependencies = []; type_ = Emit_type.type_react_d_o_m_re_dom_ref} | ["ReactDOM"; "Ref"; "currentDomRef"], [] -> - {dependencies = []; type_ = EmitType.type_any} + {dependencies = []; type_ = Emit_type.type_any} | ["ReactDOMRe"; "domRef"], [] -> - {dependencies = []; type_ = EmitType.type_react_d_o_m_re_dom_ref} + {dependencies = []; type_ = Emit_type.type_react_d_o_m_re_dom_ref} | ["ReactDOMRe"; "Ref"; "currentDomRef"], [] -> - {dependencies = []; type_ = EmitType.type_any} + {dependencies = []; type_ = Emit_type.type_any} | ["ReactEvent"; "Mouse"; "t"], [] -> - {dependencies = []; type_ = EmitType.type_react_event_mouse_t} + {dependencies = []; type_ = Emit_type.type_react_event_mouse_t} | ( ( ["React"; "element"] | ["ReasonReact"; "reactElement"] | ["Pervasives"; "Jsx"; "element"] | ["Jsx"; "element"] ), [] ) -> - {dependencies = []; type_ = EmitType.type_react_element} + {dependencies = []; type_ = Emit_type.type_react_element} | ["option"], [param_translation] -> {param_translation with type_ = Option param_translation.type_} | ( ( ["Js"; "Undefined"; "t"] @@ -519,7 +519,7 @@ let rec translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps in let all_deps = List.rev_append rev_arg_deps dependencies in let labeled_convertable_types = rev_args |> List.rev in - let arg_types = labeled_convertable_types |> NamedArgs.group in + let arg_types = labeled_convertable_types |> Named_args.group in let function_type = Function {arg_types; ret_type; type_vars = []} in {dependencies = all_deps; type_ = function_type} @@ -528,7 +528,7 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env match type_expr.desc with | Tvar None -> let type_name = - GenIdent.js_type_name_for_anonymous_type_id ~type_vars_gen type_expr.id + Gen_ident.js_type_name_for_anonymous_type_id ~type_vars_gen type_expr.id in {dependencies = []; type_ = TypeVar type_name} | Tvar (Some s) -> {dependencies = []; type_ = TypeVar s} @@ -637,7 +637,7 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env {dependencies; type_} | {unknowns = _ :: _} -> {dependencies = []; type_ = unknown}) | Tpackage (path, ids, types) -> ( - match type_env |> TypeEnv.lookup_module_type_signature ~path with + match type_env |> Type_env.lookup_module_type_signature ~path with | Some (signature, type_env) -> let type_equations_translation = (List.combine ids types [@doesNotRaise]) @@ -656,7 +656,7 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env |> List.map (fun (_, translation) -> translation.dependencies) |> List.flatten in - let type_env1 = type_env |> TypeEnv.add_type_equations ~type_equations in + let type_env1 = type_env |> Type_env.add_type_equations ~type_equations in let dependencies_from_record_type, type_ = signature.sig_type |> signature_to_module_runtime_representation ~config ~type_vars_gen @@ -701,7 +701,7 @@ and signature_to_module_runtime_representation ~config ~type_vars_gen ~type_env | Types.Sig_module (id, module_declaration, _recStatus) -> let type_env1 = match - type_env |> TypeEnv.get_module ~name:(id |> Ident.name) + type_env |> Type_env.get_module ~name:(id |> Ident.name) with | Some type_env1 -> type_env1 | None -> type_env @@ -737,7 +737,7 @@ and signature_to_module_runtime_representation ~config ~type_vars_gen ~type_env (dependencies, Object (Closed, fields)) let translate_type_expr_from_types ~config ~type_env type_expr = - let type_vars_gen = GenIdent.create_type_vars_gen () in + let type_vars_gen = Gen_ident.create_type_vars_gen () in let translation = type_expr |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env in @@ -748,7 +748,7 @@ let translate_type_expr_from_types ~config ~type_env type_expr = translation let translate_type_exprs_from_types ~config ~type_env type_exprs = - let type_vars_gen = GenIdent.create_type_vars_gen () in + let type_vars_gen = Gen_ident.create_type_vars_gen () in let translations = type_exprs |> translateTypeExprsFromTypes_ ~config ~type_vars_gen ~type_env in diff --git a/compiler/gentype/Translation.ml b/compiler/gentype/translation.ml similarity index 79% rename from compiler/gentype/Translation.ml rename to compiler/gentype/translation.ml index c80b4133505..eb82b72ee70 100644 --- a/compiler/gentype/Translation.ml +++ b/compiler/gentype/translation.ml @@ -1,11 +1,11 @@ -open GenTypeCommon +open Gen_type_common -type t = CodeItem.translation +type t = Code_item.translation let empty = ({import_types = []; code_items = []; type_declarations = []} : t) let get_import_type_unique_name - ({type_name; as_type_name} : CodeItem.import_type) = + ({type_name; as_type_name} : Code_item.import_type) = type_name ^ match as_type_name with @@ -17,13 +17,13 @@ let import_type_compare i1 i2 = let combine (translations : t list) : t = ( translations - |> List.map (fun {CodeItem.import_types; code_items; type_declarations} -> + |> List.map (fun {Code_item.import_types; code_items; type_declarations} -> ((import_types, code_items), type_declarations)) |> List.split |> fun (x, y) -> (x |> List.split, y) ) |> fun ((import_types, code_items), type_declarations) -> { - CodeItem.import_types = import_types |> List.concat; + Code_item.import_types = import_types |> List.concat; code_items = code_items |> List.concat; type_declarations = type_declarations |> List.concat; } @@ -40,11 +40,11 @@ let dep_to_import_type ~config ~output_file_relative ~resolver (dep : dep) = | External name when name = "list" -> [ { - CodeItem.type_name = "list"; + Code_item.type_name = "list"; as_type_name = None; import_path = - ModuleName.rescript_pervasives - |> ModuleResolver.import_path_for_reason_module_name ~config + Module_name.rescript_pervasives + |> Module_resolver.import_path_for_reason_module_name ~config ~output_file_relative ~resolver; }; ] @@ -62,13 +62,13 @@ let dep_to_import_type ~config ~output_file_relative ~resolver (dep : dep) = in let import_path = module_name - |> ModuleResolver.import_path_for_reason_module_name ~config + |> Module_resolver.import_path_for_reason_module_name ~config ~output_file_relative ~resolver in [{type_name; as_type_name; import_path}] let translate_dependencies ~config ~output_file_relative ~resolver dependencies - : CodeItem.import_type list = + : Code_item.import_type list = dependencies |> List.map (dep_to_import_type ~config ~output_file_relative ~resolver) |> List.concat @@ -83,25 +83,25 @@ let translate_value ~attributes ~config ~doc_string ~output_file_relative in let type_expr_translation = type_expr - |> TranslateTypeExprFromTypes.translate_type_expr_from_types ~config + |> Translate_type_expr_from_types.translate_type_expr_from_types ~config ~type_env in - let type_vars = type_expr_translation.type_ |> TypeVars.free in + let type_vars = type_expr_translation.type_ |> Type_vars.free in let type_ = type_expr_translation.type_ |> abstract_the_type_parameters ~type_vars |> add_annotations_to_function in let resolved_name_original = - name |> TypeEnv.add_module_path ~type_env |> ResolvedName.to_string + name |> Type_env.add_module_path ~type_env |> Resolved_name.to_string in - let resolved_name = name_as |> TypeEnv.add_module_path ~type_env in + let resolved_name = name_as |> Type_env.add_module_path ~type_env in let module_access_path = - type_env |> TypeEnv.get_module_access_path ~name:resolved_name_original + type_env |> Type_env.get_module_access_path ~name:resolved_name_original in let code_items = [ - CodeItem.ExportValue + Code_item.ExportValue { doc_string; module_access_path; @@ -136,7 +136,7 @@ let translate_primitive ~config ~output_file_relative ~resolver ~type_env in let type_expr_translation = value_description.val_desc - |> TranslateCoreType.translate_core_type ~config ~type_env + |> Translate_core_type.translate_core_type ~config ~type_env in let attribute_import, attribute_renaming = value_description.val_attributes |> Annotation.get_attribute_import_renaming @@ -148,7 +148,7 @@ let translate_primitive ~config ~output_file_relative ~resolver ~type_env | Some as_path -> as_path | None -> value_name in - let type_vars = type_expr_translation.type_ |> TypeVars.free in + let type_vars = type_expr_translation.type_ |> Type_vars.free in let type_ = type_expr_translation.type_ |> abstract_the_type_parameters ~type_vars in @@ -171,15 +171,16 @@ let translate_primitive ~config ~output_file_relative ~resolver ~type_env | _ -> {import_types = []; code_items = []; type_declarations = []} let add_type_declarations_from_module_equations ~type_env (translation : t) = - let eqs = type_env |> TypeEnv.get_module_equations in + let eqs = type_env |> Type_env.get_module_equations in let new_type_declarations = translation.type_declarations - |> List.map (fun (type_declaration : CodeItem.type_declaration) -> + |> List.map (fun (type_declaration : Code_item.type_declaration) -> let export_type = type_declaration.export_from_type_declaration.export_type in let equations = - export_type.resolved_type_name |> ResolvedName.apply_equations ~eqs + export_type.resolved_type_name + |> Resolved_name.apply_equations ~eqs in equations |> List.map (fun (x, y) -> @@ -188,7 +189,7 @@ let add_type_declarations_from_module_equations ~type_env (translation : t) = export_type with name_as = None; type_ = - y |> ResolvedName.to_string + y |> Resolved_name.to_string |> ident ~builtin:false ~type_args: (export_type.type_vars @@ -197,9 +198,9 @@ let add_type_declarations_from_module_equations ~type_env (translation : t) = } in { - CodeItem.export_from_type_declaration = + Code_item.export_from_type_declaration = { - CodeItem.export_type = new_export_type; + Code_item.export_type = new_export_type; annotation = type_declaration.export_from_type_declaration .annotation; diff --git a/compiler/gentype/TypeEnv.ml b/compiler/gentype/type_env.ml similarity index 82% rename from compiler/gentype/TypeEnv.ml rename to compiler/gentype/type_env.ml index adbdaa6c48d..821d412a092 100644 --- a/compiler/gentype/TypeEnv.ml +++ b/compiler/gentype/type_env.ml @@ -1,15 +1,15 @@ -open GenTypeCommon +open Gen_type_common type module_equation = {internal: bool; dep: dep} type t = { - mutable map: entry StringMap.t; - mutable map_module_types: (Typedtree.signature * t) StringMap.t; + mutable map: entry String_map.t; + mutable map_module_types: (Typedtree.signature * t) String_map.t; mutable module_equation: module_equation option; mutable module_item: Runtime.module_item; name: string; parent: t option; - type_equations: type_ StringMap.t; + type_equations: type_ String_map.t; } and entry = Module of t | Type of string @@ -17,13 +17,13 @@ and entry = Module of t | Type of string let create_type_env ~name parent = let module_item = Runtime.new_module_item ~name in { - map = StringMap.empty; - map_module_types = StringMap.empty; + map = String_map.empty; + map_module_types = String_map.empty; module_equation = None; module_item; name; parent; - type_equations = StringMap.empty; + type_equations = String_map.empty; } let root () = None |> create_type_env ~name:"__root__" @@ -33,7 +33,7 @@ let new_module ~name type_env = if !Debug.type_env then Log_.item "TypeEnv.newModule %s %s\n" (type_env |> to_string) name; let new_type_env = Some type_env |> create_type_env ~name in - type_env.map <- type_env.map |> StringMap.add name (Module new_type_env); + type_env.map <- type_env.map |> String_map.add name (Module new_type_env); new_type_env let new_module_type ~name ~signature type_env = @@ -41,16 +41,16 @@ let new_module_type ~name ~signature type_env = Log_.item "TypeEnv.newModuleType %s %s\n" (type_env |> to_string) name; let new_type_env = Some type_env |> create_type_env ~name in type_env.map_module_types <- - type_env.map_module_types |> StringMap.add name (signature, new_type_env); + type_env.map_module_types |> String_map.add name (signature, new_type_env); new_type_env let new_type ~name type_env = if !Debug.type_env then Log_.item "TypeEnv.newType %s %s\n" (type_env |> to_string) name; - type_env.map <- type_env.map |> StringMap.add name (Type name) + type_env.map <- type_env.map |> String_map.add name (Type name) let get_module ~name type_env = - match type_env.map |> StringMap.find name with + match type_env.map |> String_map.find name with | Module type_env1 -> Some type_env1 | Type _ -> None | exception Not_found -> None @@ -78,7 +78,7 @@ let rec add_type_equation ~flattened ~type_ type_env = | [name] -> { type_env with - type_equations = type_env.type_equations |> StringMap.add name type_; + type_equations = type_env.type_equations |> String_map.add name type_; } | module_name :: rest -> ( match type_env |> get_module ~name:module_name with @@ -87,7 +87,7 @@ let rec add_type_equation ~flattened ~type_ type_env = type_env with map = type_env.map - |> StringMap.add module_name + |> String_map.add module_name (Module (type_env1 |> add_type_equation ~flattened:rest ~type_)); } | None -> type_env) @@ -106,20 +106,20 @@ let add_type_equations ~type_equations type_env = let apply_type_equations ~config ~path type_env = match path with | Path.Pident id -> ( - match type_env.type_equations |> StringMap.find (id |> Ident.name) with + match type_env.type_equations |> String_map.find (id |> Ident.name) with | type_ -> if !Debug.type_resolution then Log_.item "Typenv.applyTypeEquations %s name:%s type_:%s\n" (type_env |> to_string) (id |> Ident.name) (type_ - |> EmitType.type_to_string ~config ~type_name_is_interface:(fun _ -> + |> Emit_type.type_to_string ~config ~type_name_is_interface:(fun _ -> false)); Some type_ | exception Not_found -> None) | _ -> None let rec lookup ~name type_env = - match type_env.map |> StringMap.find name with + match type_env.map |> String_map.find name with | _ -> Some type_env | exception Not_found -> ( match type_env.parent with @@ -132,7 +132,7 @@ let rec lookup_module_type ~path type_env = if !Debug.type_env then Log_.item "Typenv.lookupModuleType %s moduleTypeName:%s\n" (type_env |> to_string) module_type_name; - match type_env.map_module_types |> StringMap.find module_type_name with + match type_env.map_module_types |> String_map.find module_type_name with | x -> Some x | exception Not_found -> ( match type_env.parent with @@ -142,7 +142,7 @@ let rec lookup_module_type ~path type_env = if !Debug.type_env then Log_.item "Typenv.lookupModuleType %s moduleName:%s\n" (type_env |> to_string) module_name; - match type_env.map |> StringMap.find module_name with + match type_env.map |> String_map.find module_name with | Module type_env1 -> type_env1 |> lookup_module_type ~path:path1 | Type _ -> None | exception Not_found -> ( @@ -168,13 +168,13 @@ let update_module_item ~module_item type_env = let rec add_module_path ~type_env name = match type_env.parent with - | None -> name |> ResolvedName.from_string + | None -> name |> Resolved_name.from_string | Some parent -> - type_env.name |> add_module_path ~type_env:parent |> ResolvedName.dot name + type_env.name |> add_module_path ~type_env:parent |> Resolved_name.dot name -let rec get_module_equations type_env : ResolvedName.eq list = +let rec get_module_equations type_env : Resolved_name.eq list = let sub_equations = - type_env.map |> StringMap.bindings + type_env.map |> String_map.bindings |> List.map (fun (_, entry) -> match entry with | Module te -> te |> get_module_equations diff --git a/compiler/gentype/TypeEnv.mli b/compiler/gentype/type_env.mli similarity index 85% rename from compiler/gentype/TypeEnv.mli rename to compiler/gentype/type_env.mli index 724bfbc5f94..c881e088b15 100644 --- a/compiler/gentype/TypeEnv.mli +++ b/compiler/gentype/type_env.mli @@ -1,13 +1,13 @@ -open GenTypeCommon +open Gen_type_common type t val add_module_equation : dep:dep -> internal:bool -> t -> unit -val add_module_path : type_env:t -> string -> ResolvedName.t +val add_module_path : type_env:t -> string -> Resolved_name.t val add_type_equations : type_equations:(Longident.t * type_) list -> t -> t val apply_type_equations : config:Config.t -> path:Path.t -> t -> type_ option val expand_alias_to_external_module : name:string -> t -> dep option -val get_module_equations : t -> ResolvedName.eq list +val get_module_equations : t -> Resolved_name.eq list val get_module_access_path : name:string -> t -> Runtime.module_access_path val get_module : name:string -> t -> t option val lookup : name:string -> t -> t option diff --git a/compiler/gentype/TypeVars.ml b/compiler/gentype/type_vars.ml similarity index 80% rename from compiler/gentype/TypeVars.ml rename to compiler/gentype/type_vars.ml index 98508da4f67..ef695a9f087 100644 --- a/compiler/gentype/TypeVars.ml +++ b/compiler/gentype/type_vars.ml @@ -1,4 +1,4 @@ -open GenTypeCommon +open Gen_type_common let extract_from_type_expr type_params = type_params @@ -68,41 +68,41 @@ let rec substitute ~f type0 = {payload with t = payload.t |> substitute ~f}); } -let rec free_ type0 : StringSet.t = +let rec free_ type0 : String_set.t = match type0 with | Array (t, _) -> t |> free_ | Function {arg_types; ret_type; type_vars} -> - StringSet.diff + String_set.diff ((arg_types |> freeOfList_) +++ (ret_type |> free_)) - (type_vars |> StringSet.of_list) + (type_vars |> String_set.of_list) | Object (_, fields) -> fields |> List.fold_left - (fun s {type_} -> StringSet.union s (type_ |> free_)) - StringSet.empty + (fun s {type_} -> String_set.union s (type_ |> free_)) + String_set.empty | Ident {type_args} -> type_args |> List.fold_left - (fun s type_arg -> StringSet.union s (type_arg |> free_)) - StringSet.empty + (fun s type_arg -> String_set.union s (type_arg |> free_)) + String_set.empty | Dict type_ | Null type_ | Nullable type_ -> type_ |> free_ | Option type_ | Promise type_ -> type_ |> free_ | Tuple inner_types -> inner_types |> List.fold_left - (fun s type_arg -> StringSet.union s (type_arg |> free_)) - StringSet.empty - | TypeVar s -> s |> StringSet.singleton + (fun s type_arg -> String_set.union s (type_arg |> free_)) + String_set.empty + | TypeVar s -> s |> String_set.singleton | Variant {payloads} -> payloads |> List.fold_left - (fun s {t} -> StringSet.union s (t |> free_)) - StringSet.empty + (fun s {t} -> String_set.union s (t |> free_)) + String_set.empty and freeOfList_ types = types - |> List.fold_left (fun s {a_type} -> s +++ (a_type |> free_)) StringSet.empty + |> List.fold_left (fun s {a_type} -> s +++ (a_type |> free_)) String_set.empty -and ( +++ ) = StringSet.union +and ( +++ ) = String_set.union -let free type_ = type_ |> free_ |> StringSet.elements +let free type_ = type_ |> free_ |> String_set.elements diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index 0a750bdda65..a78cf8c3eb3 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -70,7 +70,7 @@ module Lang = struct | Res -> "res" end -module BundleConfig = struct +module Bundle_config = struct type t = { mutable module_system: Ext_module_system.t; mutable filename: string option; @@ -104,7 +104,7 @@ type loc_err_info = { loc: Location.t; } -module LocWarnInfo = struct +module Loc_warn_info = struct type t = { full_msg: string; (* Full super_error related warn string *) short_msg: string; (* Plain warn message without any context *) @@ -116,7 +116,7 @@ end exception RescriptParsingErrors of loc_err_info list -module ErrorRet = struct +module Error_ret = struct let loc_error_attributes ~(type_ : string) ~(full_msg : string) ~(short_msg : string) (loc : Location.t) = let _file, line, startchar = Location.get_pos_info loc.Location.loc_start in @@ -132,7 +132,7 @@ module ErrorRet = struct ("type", inject @@ Js.string type_); |] - let make_warning (e : LocWarnInfo.t) = + let make_warning (e : Loc_warn_info.t) = let loc_attrs = loc_error_attributes ~type_:"warning" ~full_msg:e.full_msg ~short_msg:e.short_msg e.loc @@ -148,8 +148,8 @@ module ErrorRet = struct let attrs = Array.append loc_attrs warn_attrs in Js.Unsafe.obj attrs - let from_loc_errors ?(warnings : LocWarnInfo.t array option) ~(type_ : string) - (errors : loc_err_info array) = + let from_loc_errors ?(warnings : Loc_warn_info.t array option) + ~(type_ : string) (errors : loc_err_info array) = let js_errors = Array.map (fun (e : loc_err_info) -> @@ -189,7 +189,7 @@ module ErrorRet = struct ("type", inject @@ Js.string "warning_flag_error"); |]) - let make_warning_error (errors : LocWarnInfo.t array) = + let make_warning_error (errors : Loc_warn_info.t array) = let type_ = "warning_error" in let js_errors = Array.map make_warning errors in Js.Unsafe.( @@ -224,9 +224,9 @@ let error_of_exn e = let get_filename ~(lang : Lang.t) opt = match opt with | Some fname -> fname - | None -> BundleConfig.default_filename lang + | None -> Bundle_config.default_filename lang -module ResDriver = struct +module Res_driver = struct (* For now we are basically overriding functionality from Res_driver *) open Res_driver @@ -294,7 +294,7 @@ end let rescript_parse ~filename src = let structure, _ = - ResDriver.parse_implementation ~for_printer:false ~sourcefile:filename ~src + Res_driver.parse_implementation ~for_printer:false ~sourcefile:filename ~src in structure @@ -320,7 +320,7 @@ module Compile = struct * Location.error_of_exn properly, so we need to do some extra * overloading action *) - let warning_infos : LocWarnInfo.t array ref = ref [||] + let warning_infos : Loc_warn_info.t array ref = ref [||] let warning_buffer = Buffer.create 512 let warning_ppf = Format.formatter_of_buffer warning_buffer @@ -337,7 +337,7 @@ module Compile = struct | `Inactive -> () | `Active {Warnings.number; is_error} -> Location.default_warning_printer loc ppf w; - let open LocWarnInfo in + let open Loc_warn_info in let full_msg = flush_warning_buffer () in let short_msg = Warnings.message w in let info = {full_msg; short_msg; warn_number = number; is_error; loc} in @@ -366,16 +366,16 @@ module Compile = struct Format.flush_str_formatter () in let err = {full_msg; short_msg = error.msg; loc = error.loc} in - ErrorRet.from_loc_errors ~type_ [|err|] + Error_ret.from_loc_errors ~type_ [|err|] | None -> ( match e with | RescriptParsingErrors errors -> - ErrorRet.from_syntax_errors (Array.of_list errors) + Error_ret.from_syntax_errors (Array.of_list errors) | _ -> ( let msg = Printexc.to_string e in match e with - | Warnings.Errors -> ErrorRet.make_warning_error !warning_infos - | _ -> ErrorRet.make_unexpected_error msg)) + | Warnings.Errors -> Error_ret.make_warning_error !warning_infos + | _ -> Error_ret.make_unexpected_error msg)) (* Responsible for resetting all compiler state as if it were a new instance *) let reset_compiler () = @@ -427,8 +427,8 @@ module Compile = struct in let structure, _ = typed_tree in let acc = ref [] in - let module Iter = TypedtreeIter.MakeIterator (struct - include TypedtreeIter.DefaultIteratorArgument + let module Iter = Typedtree_iter.Make_iterator (struct + include Typedtree_iter.Default_iterator_argument let cur_rec_status = ref None @@ -475,10 +475,10 @@ module Compile = struct List.iter Iter.iter_structure_item structure.str_items; Js.array (!acc |> Array.of_list) - let implementation ?(include_debug_outputs = false) ~(config : BundleConfig.t) - ~lang str = + let implementation ?(include_debug_outputs = false) + ~(config : Bundle_config.t) ~lang str = let { - BundleConfig.module_system; + Bundle_config.module_system; warn_flags; open_modules; experimental_features; @@ -536,7 +536,7 @@ module Compile = struct ( "warnings", inject @@ (!warning_infos - |> Array.map ErrorRet.make_warning + |> Array.map Error_ret.make_warning |> Js.array |> inject) ); ("type_hints", inject @@ type_hints); ("type", inject @@ Js.string "success"); @@ -564,7 +564,7 @@ module Compile = struct else Js.Unsafe.obj attrs with e -> ( match e with - | Arg.Bad msg -> ErrorRet.make_warning_flag_error ~warn_flags msg + | Arg.Bad msg -> Error_ret.make_warning_flag_error ~warn_flags msg | _ -> handle_err e) let syntax_format ?(filename : string option) ~(from : Lang.t) ~(to_ : Lang.t) @@ -578,7 +578,7 @@ module Compile = struct * IMPORTANT: we need forPrinter:true when parsing code here, * otherwise we will loose some information for the ReScript printer *) let structure, comments = - ResDriver.parse_implementation ~for_printer:true + Res_driver.parse_implementation ~for_printer:true ~sourcefile:filename ~src in Res_printer.print_implementation ~width:80 structure ~comments @@ -630,7 +630,7 @@ module Export = struct (* Creates a "compiler instance" binding the configuration context to the specific compile / formatter functions *) let make () = let open Lang in - let config = BundleConfig.make () in + let config = Bundle_config.make () in let set_module_system value = match value with | "esmodule" -> @@ -677,7 +677,7 @@ module Export = struct | Some _, Some _ -> "Can't convert from " ^ from_lang ^ " to " ^ to_lang in - ErrorRet.make_unexpected_error msg + Error_ret.make_unexpected_error msg in Js.Unsafe.( obj @@ -728,7 +728,7 @@ module Export = struct ( "module_system", inject @@ (config.module_system - |> BundleConfig.string_of_module_system + |> Bundle_config.string_of_module_system |> Js.string) ); ("warn_flags", inject @@ Js.string config.warn_flags); ( "jsx_preserve_mode", diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 0970b4b3ee6..7953771b4c8 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -530,22 +530,23 @@ let attribute_of_warning loc s = ( {loc; txt = "ocaml.ppwarning"}, PStr [Str.eval ~loc (Exp.constant (Pconst_string (s, None)))] ) -module StringMap = Map.Make (struct +module String_map = Map.Make (struct type t = string let compare = compare end) -let cookies = ref StringMap.empty +let cookies = ref String_map.empty -let get_cookie k = try Some (StringMap.find k !cookies) with Not_found -> None +let get_cookie k = + try Some (String_map.find k !cookies) with Not_found -> None -let set_cookie k v = cookies := StringMap.add k v !cookies +let set_cookie k v = cookies := String_map.add k v !cookies let tool_name_ref = ref "_none_" let tool_name () = !tool_name_ref -module PpxContext = struct +module Ppx_context = struct open Longident open Asttypes open Ast_helper @@ -572,7 +573,7 @@ module PpxContext = struct x = make_list (make_pair make_string (fun x -> x)) - (StringMap.bindings !cookies); + (String_map.bindings !cookies); opt = false; } @@ -663,7 +664,9 @@ module PpxContext = struct | "cookies" -> let l = get_list (get_pair get_string (fun x -> x)) payload in cookies := - List.fold_left (fun s (k, v) -> StringMap.add k v s) StringMap.empty l + List.fold_left + (fun s (k, v) -> String_map.add k v s) + String_map.empty l | _ -> () in List.iter @@ -681,7 +684,7 @@ module PpxContext = struct fields @ [get_cookies ()] end -let ppx_context = PpxContext.make +let ppx_context = Ppx_context.make let extension_of_exn exn = match error_of_exn exn with @@ -695,10 +698,10 @@ let apply_lazy ~source ~target mapper = let fields, ast = match ast with | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: l -> - (PpxContext.get_fields x, l) + (Ppx_context.get_fields x, l) | _ -> ([], ast) in - PpxContext.restore fields; + Ppx_context.restore fields; let ast = try let mapper = mapper () in @@ -711,17 +714,17 @@ let apply_lazy ~source ~target mapper = }; ] in - let fields = PpxContext.update_cookies fields in - Str.attribute (PpxContext.mk fields) :: ast + let fields = Ppx_context.update_cookies fields in + Str.attribute (Ppx_context.mk fields) :: ast in let iface ast = let fields, ast = match ast with | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: l -> - (PpxContext.get_fields x, l) + (Ppx_context.get_fields x, l) | _ -> ([], ast) in - PpxContext.restore fields; + Ppx_context.restore fields; let ast = try let mapper = mapper () in @@ -734,8 +737,8 @@ let apply_lazy ~source ~target mapper = }; ] in - let fields = PpxContext.update_cookies fields in - Sig.attribute (PpxContext.mk fields) :: ast + let fields = Ppx_context.update_cookies fields in + Sig.attribute (Ppx_context.mk fields) :: ast in let ic = open_in_bin source in @@ -767,14 +770,14 @@ let apply_lazy ~source ~target mapper = let drop_ppx_context_str ~restore = function | {pstr_desc = Pstr_attribute ({Location.txt = "ocaml.ppx.context"}, a)} :: items -> - if restore then PpxContext.restore (PpxContext.get_fields a); + if restore then Ppx_context.restore (Ppx_context.get_fields a); items | items -> items let drop_ppx_context_sig ~restore = function | {psig_desc = Psig_attribute ({Location.txt = "ocaml.ppx.context"}, a)} :: items -> - if restore then PpxContext.restore (PpxContext.get_fields a); + if restore then Ppx_context.restore (Ppx_context.get_fields a); items | items -> items diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 06673db5ed0..d63fb296322 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -346,11 +346,11 @@ let is_nullary_variant (x : Types.constructor_arguments) = let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) ~(blocks : (Location.t * block) list) = - let module StringSet = Set.Make (String) in - let string_literals_consts = ref StringSet.empty in - let string_literals_blocks = ref StringSet.empty in - let nonstring_literals_consts = ref StringSet.empty in - let nonstring_literals_blocks = ref StringSet.empty in + let module String_set = Set.Make (String) in + let string_literals_consts = ref String_set.empty in + let string_literals_blocks = ref String_set.empty in + let nonstring_literals_consts = ref String_set.empty in + let nonstring_literals_blocks = ref String_set.empty in let instance_types = Hashtbl.create 1 in let function_types = ref 0 in let object_types = ref 0 in @@ -363,17 +363,17 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) let set = if is_const then string_literals_consts else string_literals_blocks in - if StringSet.mem s !set then + if String_set.mem s !set then raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); - set := StringSet.add s !set + set := String_set.add s !set in let add_nonstring_literal ~is_const ~loc s = let set = if is_const then nonstring_literals_consts else nonstring_literals_blocks in - if StringSet.mem s !set then + if String_set.mem s !set then raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); - set := StringSet.add s !set + set := String_set.add s !set in let invariant loc name = if !unknown_types <> 0 && List.length blocks <> 1 then @@ -399,8 +399,8 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); if !boolean_types > 0 - && (StringSet.mem "true" !nonstring_literals_consts - || StringSet.mem "false" !nonstring_literals_consts) + && (String_set.mem "true" !nonstring_literals_consts + || String_set.mem "false" !nonstring_literals_consts) then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); () in @@ -525,7 +525,7 @@ let has_undefined_literal attrs = process_tag_type attrs = Some Undefined let block_is_object ~env attrs = get_block_type ~env attrs = Some ObjectType -module DynamicChecks = struct +module Dynamic_checks = struct type op = EqEqEq | NotEqEq | Or | And type 'a t = | BinOp of op * 'a t * 'a t diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index 2af606a084f..dc72b0578f4 100644 --- a/compiler/ml/btype.ml +++ b/compiler/ml/btype.ml @@ -21,9 +21,9 @@ open Types (**** Sets, maps and hashtables of types ****) -module TypeSet = Set.Make (TypeOps) -module TypeMap = Map.Make (TypeOps) -module TypeHash = Hashtbl.Make (TypeOps) +module Type_set = Set.Make (Type_ops) +module Type_map = Map.Make (Type_ops) +module Type_hash = Hashtbl.Make (Type_ops) (**** Forward declarations ****) @@ -85,7 +85,7 @@ type change = | Ckind of field_kind option ref * field_kind option | Ccommu of commutable ref * commutable | Cuniv of type_expr option ref * type_expr option - | Ctypeset of TypeSet.t ref * TypeSet.t + | Ctypeset of Type_set.t ref * Type_set.t type changes = Change of change * changes ref | Unchanged | Invalid diff --git a/compiler/ml/btype.mli b/compiler/ml/btype.mli index ef099af22bb..02a04a7e062 100644 --- a/compiler/ml/btype.mli +++ b/compiler/ml/btype.mli @@ -20,9 +20,9 @@ open Types (**** Sets, maps and hashtables of types ****) -module TypeSet : Set.S with type elt = type_expr -module TypeMap : Map.S with type key = type_expr -module TypeHash : Hashtbl.S with type key = type_expr +module Type_set : Set.S with type elt = type_expr +module Type_map : Map.S with type key = type_expr +module Type_hash : Hashtbl.S with type key = type_expr (**** Levels ****) @@ -225,7 +225,7 @@ val set_row_field : row_field option ref -> row_field -> unit val set_univar : type_expr option ref -> type_expr -> unit val set_kind : field_kind option ref -> field_kind -> unit val set_commu : commutable ref -> commutable -> unit -val set_typeset : TypeSet.t ref -> TypeSet.t -> unit +val set_typeset : Type_set.t ref -> Type_set.t -> unit (* Set references, logging the old value *) val log_type : type_expr -> unit diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index e15adf31b43..b11b67c367d 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -71,7 +71,7 @@ let () = | _ -> None) type subtype_context = - | Generic of {errorCode: string} + | Generic of {error_code: string} | Coercion_target_variant_not_unboxed of { variant_name: Path.t; primitive: Path.t; @@ -227,7 +227,7 @@ let repr = repr (**** Type maps ****) -module TypePairs = Hashtbl.Make (struct +module Type_pairs = Hashtbl.Make (struct type t = type_expr * type_expr let equal (t1, t1') (t2, t2') = t1 == t2 && t1' == t2' let hash (t, t') = t.id + (93 * t'.id) @@ -801,33 +801,35 @@ type inv_type_expr = { let rec inv_type hash pty ty = let ty = repr ty in try - let inv = TypeHash.find hash ty in + let inv = Type_hash.find hash ty in inv.inv_parents <- pty @ inv.inv_parents with Not_found -> let inv = {inv_type = ty; inv_parents = pty} in - TypeHash.add hash ty inv; + Type_hash.add hash ty inv; iter_type_expr (inv_type hash [inv]) ty let compute_univars ty = - let inverted = TypeHash.create 17 in + let inverted = Type_hash.create 17 in inv_type inverted [] ty; - let node_univars = TypeHash.create 17 in + let node_univars = Type_hash.create 17 in let rec add_univar univ inv = match inv.inv_type.desc with | Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> () | _ -> ( try - let univs = TypeHash.find node_univars inv.inv_type in - if not (TypeSet.mem univ !univs) then ( - univs := TypeSet.add univ !univs; + let univs = Type_hash.find node_univars inv.inv_type in + if not (Type_set.mem univ !univs) then ( + univs := Type_set.add univ !univs; List.iter (add_univar univ) inv.inv_parents) with Not_found -> - TypeHash.add node_univars inv.inv_type (ref (TypeSet.singleton univ)); + Type_hash.add node_univars inv.inv_type (ref (Type_set.singleton univ)); List.iter (add_univar univ) inv.inv_parents) in - TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv) inverted; + Type_hash.iter + (fun ty inv -> if is_Tunivar ty then add_univar ty inv) + inverted; fun ty -> - try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty + try !(Type_hash.find node_univars ty) with Not_found -> Type_set.empty (*******************) (* Instantiation *) @@ -870,7 +872,7 @@ let rec copy ?env ?partial ?keep_names ty = match partial with | None -> assert false | Some (free_univars, keep) -> - if TypeSet.is_empty (free_univars ty) then + if Type_set.is_empty (free_univars ty) then if keep then ty.level else !current_level else generic_level in @@ -959,7 +961,7 @@ let rec copy ?env ?partial ?keep_names ty = in if row.row_closed && (not row.row_fixed) - && TypeSet.is_empty (free_univars ty) + && Type_set.is_empty (free_univars ty) && not (List.for_all not_reither row.row_fields) then ( more', @@ -1128,7 +1130,7 @@ let rec diff_list l1 l2 = let conflicts free bound = let bound = List.map repr bound in - TypeSet.exists (fun t -> List.memq (repr t) bound) free + Type_set.exists (fun t -> List.memq (repr t) bound) free let delayed_copy = ref [] (* copying to do later *) @@ -1138,7 +1140,7 @@ let delayed_copy = ref [] let rec copy_sep fixed free bound visited ty = let ty = repr ty in let univars = free ty in - if TypeSet.is_empty univars then ( + if Type_set.is_empty univars then ( if ty.level <> generic_level then ty else let t = newvar () in @@ -1498,8 +1500,8 @@ let rec occur_rec env allow_recursive visited ty0 = function if allow_recursive && is_contractive env p then () else try - if TypeSet.mem ty visited then raise Occur; - let visited = TypeSet.add ty visited in + if Type_set.mem ty visited then raise Occur; + let visited = Type_set.add ty visited in iter_type_expr (occur_rec env allow_recursive visited ty0) ty with Occur -> ( try @@ -1510,9 +1512,9 @@ let rec occur_rec env allow_recursive visited ty0 = function with Cannot_expand -> raise Occur)) | Tobject _ | Tvariant _ -> () | _ -> - if allow_recursive || TypeSet.mem ty visited then () + if allow_recursive || Type_set.mem ty visited then () else - let visited = TypeSet.add ty visited in + let visited = Type_set.add ty visited in iter_type_expr (occur_rec env allow_recursive visited ty0) ty) let type_changed = ref false (* trace possible changes to the studied type *) @@ -1525,7 +1527,7 @@ let occur env ty0 ty = try while type_changed := false; - occur_rec env allow_recursive TypeSet.empty ty0 ty; + occur_rec env allow_recursive Type_set.empty ty0 ty; !type_changed do () (* prerr_endline "changed" *) @@ -1611,31 +1613,31 @@ let rec unify_univar t1 t2 = function (* Test the occurrence of free univars in a type *) (* that's way too expensive. Must do some kind of caching *) let occur_univar env ty = - let visited = ref TypeMap.empty in + let visited = ref Type_map.empty in let rec occur_rec bound ty = let ty = repr ty in if ty.level >= lowest_level && - if TypeSet.is_empty bound then ( + if Type_set.is_empty bound then ( ty.level <- pivot_level - ty.level; true) else try - let bound' = TypeMap.find ty !visited in - if TypeSet.exists (fun x -> not (TypeSet.mem x bound)) bound' then ( - visited := TypeMap.add ty (TypeSet.inter bound bound') !visited; + let bound' = Type_map.find ty !visited in + if Type_set.exists (fun x -> not (Type_set.mem x bound)) bound' then ( + visited := Type_map.add ty (Type_set.inter bound bound') !visited; true) else false with Not_found -> - visited := TypeMap.add ty bound !visited; + visited := Type_map.add ty bound !visited; true then match ty.desc with | Tunivar _ -> - if not (TypeSet.mem ty bound) then raise (Unify [(ty, newgenvar ())]) + if not (Type_set.mem ty bound) then raise (Unify [(ty, newgenvar ())]) | Tpoly (ty, tyl) -> - let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in + let bound = List.fold_right Type_set.add (List.map repr tyl) bound in occur_rec bound ty | Tconstr (_, [], _) -> () | Tconstr (p, tl, _) -> ( @@ -1650,42 +1652,42 @@ let occur_univar env ty = | _ -> iter_type_expr (occur_rec bound) ty in try - occur_rec TypeSet.empty ty; + occur_rec Type_set.empty ty; unmark_type ty with exn -> unmark_type ty; raise exn (* Grouping univars by families according to their binders *) -let add_univars = List.fold_left (fun s (t, _) -> TypeSet.add (repr t) s) +let add_univars = List.fold_left (fun s (t, _) -> Type_set.add (repr t) s) let get_univar_family univar_pairs univars = - if univars = [] then TypeSet.empty + if univars = [] then Type_set.empty else let insert s = function | cl1, (_ :: _ as cl2) -> - if List.exists (fun (t1, _) -> TypeSet.mem (repr t1) s) cl1 then + if List.exists (fun (t1, _) -> Type_set.mem (repr t1) s) cl1 then add_univars s cl2 else s | _ -> s in - let s = List.fold_right TypeSet.add univars TypeSet.empty in + let s = List.fold_right Type_set.add univars Type_set.empty in List.fold_left insert s univar_pairs (* Whether a family of univars escapes from a type *) let univars_escape env univar_pairs vl ty = let family = get_univar_family univar_pairs vl in - let visited = ref TypeSet.empty in + let visited = ref Type_set.empty in let rec occur t = let t = repr t in - if TypeSet.mem t !visited then () + if Type_set.mem t !visited then () else ( - visited := TypeSet.add t !visited; + visited := Type_set.add t !visited; match t.desc with | Tpoly (t, tl) -> - if List.exists (fun t -> TypeSet.mem (repr t) family) tl then () + if List.exists (fun t -> Type_set.mem (repr t) family) tl then () else occur t - | Tunivar _ -> if TypeSet.mem t family then raise Occur + | Tunivar _ -> if Type_set.mem t family then raise Occur | Tconstr (_, [], _) -> () | Tconstr (p, tl, _) -> ( try @@ -1706,13 +1708,15 @@ let univars_escape env univar_pairs vl ty = let enter_poly env univar_pairs t1 tl1 t2 tl2 f = let old_univars = !univar_pairs in let known_univars = - List.fold_left (fun s (cl, _) -> add_univars s cl) TypeSet.empty old_univars + List.fold_left + (fun s (cl, _) -> add_univars s cl) + Type_set.empty old_univars in let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in if - List.exists (fun t -> TypeSet.mem t known_univars) tl1 + List.exists (fun t -> Type_set.mem t known_univars) tl1 && univars_escape env old_univars tl1 (newty (Tpoly (t2, tl2))) - || List.exists (fun t -> TypeSet.mem t known_univars) tl2 + || List.exists (fun t -> Type_set.mem t known_univars) tl2 && univars_escape env old_univars tl2 (newty (Tpoly (t1, tl1))) then raise (Unify []); let cl1 = List.map (fun t -> (t, ref None)) tl1 @@ -1827,12 +1831,12 @@ let reify env t = env := new_env; t in - let visited = ref TypeSet.empty in + let visited = ref Type_set.empty in let rec iterator ty = let ty = repr ty in - if TypeSet.mem ty !visited then () + if Type_set.mem ty !visited then () else ( - visited := TypeSet.add ty !visited; + visited := Type_set.add ty !visited; match ty.desc with | Tvar o -> let t = create_fresh_constr ty.level o in @@ -1921,9 +1925,9 @@ let rec mcomp type_pairs env t1 t2 = let t1' = repr t1' and t2' = repr t2' in if t1' == t2' then () else - try TypePairs.find type_pairs (t1', t2') + try Type_pairs.find type_pairs (t1', t2') with Not_found -> ( - TypePairs.add type_pairs (t1', t2') (); + Type_pairs.add type_pairs (t1', t2') (); match (t1'.desc, t2'.desc) with | Tvar _, Tvar _ -> assert false | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _) @@ -2086,7 +2090,7 @@ and mcomp_record_description type_pairs env = in iter -let mcomp env t1 t2 = mcomp (TypePairs.create 4) env t1 t2 +let mcomp env t1 t2 = mcomp (Type_pairs.create 4) env t1 t2 (* Real unification *) @@ -2108,12 +2112,12 @@ let add_gadt_equation env source destination = env := Env.add_local_constraint source decl newtype_level !env; cleanup_abbrev ()) -let unify_eq_set = TypePairs.create 11 +let unify_eq_set = Type_pairs.create 11 let order_type_pair t1 t2 = if t1.id <= t2.id then (t1, t2) else (t2, t1) let add_type_equality t1 t2 = - TypePairs.add unify_eq_set (order_type_pair t1 t2) () + Type_pairs.add unify_eq_set (order_type_pair t1 t2) () let eq_package_path env p1 p2 = Path.same p1 p2 @@ -2216,7 +2220,7 @@ let unify_eq t1 t2 = | Expression -> false | Pattern -> ( try - TypePairs.find unify_eq_set (order_type_pair t1 t2); + Type_pairs.find unify_eq_set (order_type_pair t1 t2); true with Not_found -> false) @@ -2742,10 +2746,10 @@ let unify_gadt ~newtype_level:lev (env : Env.t ref) ty1 ty2 = set_mode_pattern ~generate:true ~injective:true (fun () -> unify env ty1 ty2); newtype_level := None; - TypePairs.clear unify_eq_set + Type_pairs.clear unify_eq_set with e -> newtype_level := None; - TypePairs.clear unify_eq_set; + Type_pairs.clear unify_eq_set; raise e let unify_var env t1 t2 = @@ -2907,9 +2911,9 @@ let rec moregen inst_nongen type_pairs env t1 t2 = let t1' = repr t1' and t2' = repr t2' in if t1' == t2' then () else - try TypePairs.find type_pairs (t1', t2') + try Type_pairs.find type_pairs (t1', t2') with Not_found -> ( - TypePairs.add type_pairs (t1', t2') (); + Type_pairs.add type_pairs (t1', t2') (); match (t1'.desc, t2'.desc) with | Tvar _, _ when may_instantiate inst_nongen t1' -> moregen_occur env t1'.level t2; @@ -3067,7 +3071,7 @@ let moregeneral env inst_nongen pat_sch subj_sch = let patt = instance env pat_sch in let res = try - moregen inst_nongen (TypePairs.create 13) env patt subj; + moregen inst_nongen (Type_pairs.create 13) env patt subj; true with Unify _ -> false in @@ -3172,9 +3176,9 @@ let rec eqtype rename type_pairs subst env t1 t2 = let t1' = repr t1' and t2' = repr t2' in if t1' == t2' then () else - try TypePairs.find type_pairs (t1', t2') + try Type_pairs.find type_pairs (t1', t2') with Not_found -> ( - TypePairs.add type_pairs (t1', t2') (); + Type_pairs.add type_pairs (t1', t2') (); match (t1'.desc, t2'.desc) with | Tvar _, Tvar _ when rename -> ( try @@ -3226,7 +3230,7 @@ and eqtype_fields rename type_pairs subst env ty1 ty2 : unit = (* First check if same row => already equal *) let same_row = rest1 == rest2 - || TypePairs.mem type_pairs (rest1, rest2) + || Type_pairs.mem type_pairs (rest1, rest2) || (rename && List.mem (rest1, rest2) !subst) in if same_row then () @@ -3308,7 +3312,7 @@ let eqtype_list rename type_pairs subst env tl1 tl2 = (* Two modes: with or without renaming of variables *) let equal env rename tyl1 tyl2 = try - eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2; + eqtype_list rename (Type_pairs.create 11) (ref []) env tyl1 tyl2; true with Unify _ -> false @@ -3575,7 +3579,7 @@ let enlarge_type env ty = [generic_abbrev ...]). *) -let subtypes = TypePairs.create 17 +let subtypes = Type_pairs.create 17 let subtype_error ?ctx env trace = raise (Subtype (expand_trace env (List.rev trace), [], ctx)) @@ -3591,10 +3595,10 @@ let rec subtype_rec env trace t1 t2 cstrs = if t1 == t2 then cstrs else try - TypePairs.find subtypes (t1, t2); + Type_pairs.find subtypes (t1, t2); cstrs with Not_found -> ( - TypePairs.add subtypes (t1, t2) (); + Type_pairs.add subtypes (t1, t2) (); match (t1.desc, t2.desc) with | Tvar _, _ | _, Tvar _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _) @@ -3684,7 +3688,7 @@ let rec subtype_rec env trace t1 t2 cstrs = :: cstrs | None -> (* Unclear when this case actually happens. *) - (trace, t1, t2, !univar_pairs, Some (Generic {errorCode = "VCPMMVD"})) + (trace, t1, t2, !univar_pairs, Some (Generic {error_code = "VCPMMVD"})) :: cstrs) | Tconstr (_, [], _), Tconstr (path, [], _) when Variant_coercion.can_coerce_primitive path @@ -4030,11 +4034,11 @@ and subtype_row env trace row1 row2 cstrs = | _ -> raise Exit let subtype env ty1 ty2 = - TypePairs.clear subtypes; + Type_pairs.clear subtypes; univar_pairs := []; (* Build constraint set. *) let cstrs = subtype_rec env [(ty1, ty2)] ty1 ty2 [] in - TypePairs.clear subtypes; + Type_pairs.clear subtypes; (* Enforce constraints. *) function | () -> @@ -4102,13 +4106,13 @@ let cyclic_abbrev env id ty = (* Check for non-generalizable type variables *) exception Non_closed0 -let visited = ref TypeSet.empty +let visited = ref Type_set.empty let rec closed_schema_rec env ty = let ty = repr ty in - if TypeSet.mem ty !visited then () + if Type_set.mem ty !visited then () else ( - visited := TypeSet.add ty !visited; + visited := Type_set.add ty !visited; match ty.desc with | Tvar _ when ty.level <> generic_level -> raise Non_closed0 | Tconstr _ -> ( @@ -4130,21 +4134,21 @@ let rec closed_schema_rec env ty = (* Return whether all variables of type [ty] are generic. *) let closed_schema env ty = - visited := TypeSet.empty; + visited := Type_set.empty; try closed_schema_rec env ty; - visited := TypeSet.empty; + visited := Type_set.empty; true with Non_closed0 -> - visited := TypeSet.empty; + visited := Type_set.empty; false (* Normalize a type before printing, saving... *) (* Cannot use mark_type because deep_occur uses it too *) let rec normalize_type_rec env visited ty = let ty = repr ty in - if not (TypeSet.mem ty !visited) then ( - visited := TypeSet.add ty !visited; + if not (Type_set.mem ty !visited) then ( + visited := Type_set.add ty !visited; let tm = row_of_type ty in (if (not (is_Tconstr ty)) && is_constr_row ~allow_ident:false tm then match tm.desc with @@ -4216,7 +4220,7 @@ let rec normalize_type_rec env visited ty = | _ -> ()); iter_type_expr (normalize_type_rec env visited) ty) -let normalize_type env ty = normalize_type_rec env (ref TypeSet.empty) ty +let normalize_type env ty = normalize_type_rec env (ref Type_set.empty) ty (*************************) (* Remove dependencies *) @@ -4229,22 +4233,22 @@ let normalize_type env ty = normalize_type_rec env (ref TypeSet.empty) ty expand_abbrev. *) -let nondep_hash = TypeHash.create 47 -let nondep_variants = TypeHash.create 17 +let nondep_hash = Type_hash.create 47 +let nondep_variants = Type_hash.create 17 let clear_hash () = - TypeHash.clear nondep_hash; - TypeHash.clear nondep_variants + Type_hash.clear nondep_hash; + Type_hash.clear nondep_variants let rec nondep_type_rec env id ty = match ty.desc with | Tvar _ | Tunivar _ -> ty | Tlink ty -> nondep_type_rec env id ty | _ -> ( - try TypeHash.find nondep_hash ty + try Type_hash.find nondep_hash ty with Not_found -> let ty' = newgenvar () in (* Stub *) - TypeHash.add nondep_hash ty ty'; + Type_hash.add nondep_hash ty ty'; ty'.desc <- (match ty.desc with | Tconstr (p, tl, _abbrev) -> @@ -4279,13 +4283,13 @@ let rec nondep_type_rec env id ty = let more = repr row.row_more in (* We must keep sharing according to the row variable *) try - let ty2 = TypeHash.find nondep_variants more in + let ty2 = Type_hash.find nondep_variants more in (* This variant type has been already copied *) - TypeHash.add nondep_hash ty ty2; + Type_hash.add nondep_hash ty ty2; Tlink ty2 with Not_found -> ( (* Register new type first for recursion *) - TypeHash.add nondep_variants more ty'; + Type_hash.add nondep_variants more ty'; let static = static_row row in let more' = if static then newgenty Tnil else more in (* Return a new copy *) diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 6785374ac92..91c065442c7 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -19,7 +19,7 @@ open Asttypes open Types type subtype_context = - | Generic of {errorCode: string} + | Generic of {error_code: string} (** A generic subtype error, intended to be extended to be handled later. *) | Coercion_target_variant_not_unboxed of { variant_name: Path.t; diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml index df16f61971c..44e2ba9afa2 100644 --- a/compiler/ml/datarepr.ml +++ b/compiler/ml/datarepr.ml @@ -22,19 +22,19 @@ open Btype (* Simplified version of Ctype.free_vars *) let free_vars ?(param = false) ty = - let ret = ref TypeSet.empty in + let ret = ref Type_set.empty in let rec loop ty = let ty = repr ty in if ty.level >= lowest_level then ( ty.level <- pivot_level - ty.level; match ty.desc with - | Tvar _ -> ret := TypeSet.add ty !ret + | Tvar _ -> ret := Type_set.add ty !ret | Tvariant row -> ( let row = row_repr row in iter_row loop row; if not (static_row row) then match row.row_more.desc with - | Tvar _ when param -> ret := TypeSet.add ty !ret + | Tvar _ when param -> ret := Type_set.add ty !ret | _ -> loop row.row_more) (* XXX: What about Tobject ? *) | _ -> iter_type_expr loop ty) @@ -57,7 +57,7 @@ let constructor_existentials cd_args cd_res = | Some type_ret -> let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in let res_vars = free_vars type_ret in - TypeSet.elements (TypeSet.diff arg_vars_set res_vars) + Type_set.elements (Type_set.diff arg_vars_set res_vars) in (tyl, existentials) @@ -67,7 +67,7 @@ let constructor_args priv cd_args cd_res path rep = | Cstr_tuple l -> (existentials, l, None) | Cstr_record lbls -> let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in - let type_params = TypeSet.elements arg_vars_set in + let type_params = Type_set.elements arg_vars_set in let type_unboxed = match rep with | Record_unboxed _ -> unboxed_true_default_false diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 43a625160be..3b00ff9e5a3 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -20,26 +20,26 @@ open Parsetree let pp_deps = ref [] -module StringSet = Set.Make (struct +module String_set = Set.Make (struct type t = string let compare = compare end) -module StringMap = Map.Make (String) +module String_map = Map.Make (String) (* Module resolution map *) (* Node (set of imports for this path, map for submodules) *) -type map_tree = Node of StringSet.t * bound_map -and bound_map = map_tree StringMap.t -let bound = Node (StringSet.empty, StringMap.empty) +type map_tree = Node of String_set.t * bound_map +and bound_map = map_tree String_map.t +let bound = Node (String_set.empty, String_map.empty) (*let get_free (Node (s, _m)) = s*) let get_map (Node (_s, m)) = m -let make_leaf s = Node (StringSet.singleton s, StringMap.empty) -let make_node m = Node (StringSet.empty, m) +let make_leaf s = Node (String_set.singleton s, String_map.empty) +let make_node m = Node (String_set.empty, m) let rec weaken_map s (Node (s0, m0)) = - Node (StringSet.union s s0, StringMap.map (weaken_map s) m0) + Node (String_set.union s s0, String_map.map (weaken_map s) m0) let rec collect_free (Node (s, m)) = - StringMap.fold (fun _ n -> StringSet.union (collect_free n)) m s + String_map.fold (fun _ n -> String_set.union (collect_free n)) m s (* Returns the imports required to access the structure at path p *) (* Only raises Not_found if the head of p is not in the toplevel map *) @@ -47,27 +47,27 @@ let rec lookup_free p m = match p with | [] -> raise Not_found | s :: p -> ( - let (Node (f, m')) = StringMap.find s m in + let (Node (f, m')) = String_map.find s m in try lookup_free p m' with Not_found -> f) (* Returns the node corresponding to the structure at path p *) let rec lookup_map lid m = match lid with - | Lident s -> StringMap.find s m - | Ldot (l, s) -> StringMap.find s (get_map (lookup_map l m)) + | Lident s -> String_map.find s m + | Ldot (l, s) -> String_map.find s (get_map (lookup_map l m)) | Lapply _ -> raise Not_found (* Collect free module identifiers in the a.s.t. *) -let free_structure_names = ref StringSet.empty +let free_structure_names = ref String_set.empty let add_names s = - free_structure_names := StringSet.union s !free_structure_names + free_structure_names := String_set.union s !free_structure_names let rec add_path bv ?(p = []) = function | Lident s -> let free = - try lookup_free (s :: p) bv with Not_found -> StringSet.singleton s + try lookup_free (s :: p) bv with Not_found -> String_set.singleton s in (*StringSet.iter (fun s -> Printf.eprintf "%s " s) free; prerr_endline "";*) @@ -81,7 +81,7 @@ let open_module bv lid = match lookup_map lid bv with | Node (s, m) -> add_names s; - StringMap.fold StringMap.add m bv + String_map.fold String_map.add m bv | exception Not_found -> add_path bv lid; bv @@ -171,7 +171,7 @@ let add_type_extension bv te = add bv te.ptyext_path; List.iter (add_extension_constructor bv) te.ptyext_constructors -let pattern_bv = ref StringMap.empty +let pattern_bv = ref String_map.empty let rec add_pattern bv pat = match pat.ppat_desc with @@ -198,7 +198,7 @@ let rec add_pattern bv pat = add_type bv ty | Ppat_variant (_, op) -> add_opt add_pattern bv op | Ppat_type li -> add bv li - | Ppat_unpack id -> pattern_bv := StringMap.add id.txt bound !pattern_bv + | Ppat_unpack id -> pattern_bv := String_map.add id.txt bound !pattern_bv | Ppat_open (m, p) -> let bv = open_module bv m.txt in add_pattern bv p @@ -281,7 +281,7 @@ let rec add_expr bv exp = | Pexp_send (e, _m) -> add_expr bv e | Pexp_letmodule (id, m, e) -> let b = add_module_binding bv m in - add_expr (StringMap.add id.txt b bv) e + add_expr (String_map.add id.txt b bv) e | Pexp_letexception (_, e) -> add_expr bv e | Pexp_assert e -> add_expr bv e | Pexp_newtype (_, e) -> add_expr bv e @@ -350,7 +350,7 @@ and add_modtype bv mty = | Pmty_signature s -> add_signature bv s | Pmty_functor (id, mty1, mty2) -> Misc.may (add_modtype bv) mty1; - add_modtype (StringMap.add id.txt bound bv) mty2 + add_modtype (String_map.add id.txt bound bv) mty2 | Pmty_with (mty, cstrl) -> add_modtype bv mty; List.iter @@ -387,7 +387,7 @@ and add_modtype_binding bv mty = and add_signature bv sg = ignore (add_signature_binding bv sg) and add_signature_binding bv sg = - snd (List.fold_left add_sig_item (bv, StringMap.empty) sg) + snd (List.fold_left add_sig_item (bv, String_map.empty) sg) and add_sig_item (bv, m) item = match item.psig_desc with @@ -405,11 +405,11 @@ and add_sig_item (bv, m) item = (bv, m) | Psig_module pmd -> let m' = add_modtype_binding bv pmd.pmd_type in - let add = StringMap.add pmd.pmd_name.txt m' in + let add = String_map.add pmd.pmd_name.txt m' in (add bv, add m) | Psig_recmodule decls -> let add = - List.fold_right (fun pmd -> StringMap.add pmd.pmd_name.txt bound) decls + List.fold_right (fun pmd -> String_map.add pmd.pmd_name.txt bound) decls in let bv' = add bv and m' = add m in List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls; @@ -423,7 +423,7 @@ and add_sig_item (bv, m) item = | Psig_include incl -> let (Node (s, m')) = add_modtype_binding bv incl.pincl_mod in add_names s; - let add = StringMap.fold StringMap.add m' in + let add = String_map.fold String_map.add m' in (add bv, add m) | Psig_attribute _ -> (bv, m) | Psig_extension (e, _) -> @@ -454,7 +454,7 @@ and add_module bv modl = | Pmod_structure s -> ignore (add_structure bv s) | Pmod_functor (id, mty, modl) -> Misc.may (add_modtype bv) mty; - add_module (StringMap.add id.txt bound bv) modl + add_module (String_map.add id.txt bound bv) modl | Pmod_apply (mod1, mod2) -> add_module bv mod1; add_module bv mod2 @@ -470,9 +470,9 @@ and add_structure bv item_list = bv and add_structure_binding bv item_list = - List.fold_left add_struct_item (bv, StringMap.empty) item_list + List.fold_left add_struct_item (bv, String_map.empty) item_list -and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t = +and add_struct_item (bv, m) item : _ String_map.t * _ String_map.t = match item.pstr_desc with | Pstr_eval (e, _attrs) -> add_expr bv e; @@ -494,11 +494,11 @@ and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t = (bv, m) | Pstr_module x -> let b = add_module_binding bv x.pmb_expr in - let add = StringMap.add x.pmb_name.txt b in + let add = String_map.add x.pmb_name.txt b in (add bv, add m) | Pstr_recmodule bindings -> let add = - List.fold_right (fun x -> StringMap.add x.pmb_name.txt bound) bindings + List.fold_right (fun x -> String_map.add x.pmb_name.txt bound) bindings in let bv' = add bv and m = add m in List.iter (fun x -> add_module bv' x.pmb_expr) bindings; @@ -512,7 +512,7 @@ and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t = | Pstr_include incl -> let (Node (s, m')) = add_module_binding bv incl.pincl_mod in add_names s; - let add = StringMap.fold StringMap.add m' in + let add = String_map.fold String_map.add m' in (add bv, add m) | Pstr_attribute _ -> (bv, m) | Pstr_extension (e, _) -> diff --git a/compiler/ml/depend.mli b/compiler/ml/depend.mli index b4fb4c884ee..aa41f121e5e 100644 --- a/compiler/ml/depend.mli +++ b/compiler/ml/depend.mli @@ -15,16 +15,16 @@ (** Module dependencies. *) -module StringSet : Set.S with type elt = string -module StringMap : Map.S with type key = string +module String_set : Set.S with type elt = string +module String_map : Map.S with type key = string -type map_tree = Node of StringSet.t * bound_map -and bound_map = map_tree StringMap.t +type map_tree = Node of String_set.t * bound_map +and bound_map = map_tree String_map.t val make_leaf : string -> map_tree val make_node : bound_map -> map_tree -val weaken_map : StringSet.t -> map_tree -> map_tree +val weaken_map : String_set.t -> map_tree -> map_tree -val free_structure_names : StringSet.t ref +val free_structure_names : String_set.t ref (* dependencies found by preprocessing tools (plugins) *) val pp_deps : string list ref diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 970634be03d..0626ba55520 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -64,7 +64,7 @@ exception Error of error let error err = raise (Error err) -module EnvLazy : sig +module Env_lazy : sig type ('a, 'b) t type log @@ -137,7 +137,7 @@ end = struct loop !log end -module PathMap = Map.Make (Path) +module Path_map = Map.Make (Path) type summary = | Env_empty @@ -148,10 +148,10 @@ type summary = | Env_modtype of summary * Ident.t * modtype_declaration | Env_open of summary * Path.t | Env_functor_arg of summary * Ident.t - | Env_constraints of summary * type_declaration PathMap.t + | Env_constraints of summary * type_declaration Path_map.t | Env_copy_types of summary * string list -module TycompTbl = struct +module Tycomp_tbl = struct (** This module is used to store components of types (i.e. labels and constructors). We keep a representation of each nested "open" and the set of local bindings between each of them. *) @@ -244,7 +244,7 @@ module TycompTbl = struct with Not_found -> true) end -module IdTbl = struct +module Id_tbl = struct (** This module is used to store all kinds of components except (labels and constructors) in environments. We keep a representation of each nested "open" and the set of local @@ -389,17 +389,18 @@ let in_signature_flag = 0x01 let implicit_coercion_flag = 0x02 type t = { - values: value_description IdTbl.t; - constrs: constructor_description TycompTbl.t; - labels: label_description TycompTbl.t; - types: (type_declaration * type_descriptions) IdTbl.t; - modules: (Subst.t * module_declaration, module_declaration) EnvLazy.t IdTbl.t; - modtypes: modtype_declaration IdTbl.t; - components: module_components IdTbl.t; + values: value_description Id_tbl.t; + constrs: constructor_description Tycomp_tbl.t; + labels: label_description Tycomp_tbl.t; + types: (type_declaration * type_descriptions) Id_tbl.t; + modules: + (Subst.t * module_declaration, module_declaration) Env_lazy.t Id_tbl.t; + modtypes: modtype_declaration Id_tbl.t; + components: module_components Id_tbl.t; functor_args: unit Ident.tbl; summary: summary; - local_constraints: type_declaration PathMap.t; - gadt_instances: (int * TypeSet.t ref) list; + local_constraints: type_declaration Path_map.t; + gadt_instances: (int * Type_set.t ref) list; flags: int; } @@ -409,7 +410,7 @@ and module_components = { comps: ( t * Subst.t * Path.t * Types.module_type, module_components_repr option ) - EnvLazy.t; + Env_lazy.t; } and module_components_repr = @@ -424,7 +425,7 @@ and structure_components = { mutable comp_labels: (string, label_description list) Tbl.t; mutable comp_types: (type_declaration * type_descriptions) comp_tbl; mutable comp_modules: - (Subst.t * module_declaration, module_declaration) EnvLazy.t comp_tbl; + (Subst.t * module_declaration, module_declaration) Env_lazy.t comp_tbl; mutable comp_modtypes: modtype_declaration comp_tbl; mutable comp_components: module_components comp_tbl; (* warning -69*) } @@ -478,15 +479,15 @@ let subst_modtype_maker (subst, md) = let empty = { - values = IdTbl.empty; - constrs = TycompTbl.empty; - labels = TycompTbl.empty; - types = IdTbl.empty; - modules = IdTbl.empty; - modtypes = IdTbl.empty; - components = IdTbl.empty; + values = Id_tbl.empty; + constrs = Tycomp_tbl.empty; + labels = Tycomp_tbl.empty; + types = Id_tbl.empty; + modules = Id_tbl.empty; + modtypes = Id_tbl.empty; + components = Id_tbl.empty; summary = Env_empty; - local_constraints = PathMap.empty; + local_constraints = Path_map.empty; gadt_instances = []; flags = 0; functor_args = Ident.empty; @@ -514,21 +515,21 @@ let is_local_ext = function | _ -> false let diff env1 env2 = - IdTbl.diff_keys env1.values env2.values - @ TycompTbl.diff_keys is_local_ext env1.constrs env2.constrs - @ IdTbl.diff_keys env1.modules env2.modules + Id_tbl.diff_keys env1.values env2.values + @ Tycomp_tbl.diff_keys is_local_ext env1.constrs env2.constrs + @ Id_tbl.diff_keys env1.modules env2.modules -type can_load_cmis = Can_load_cmis | Cannot_load_cmis of EnvLazy.log +type can_load_cmis = Can_load_cmis | Cannot_load_cmis of Env_lazy.log let can_load_cmis = ref Can_load_cmis let without_cmis f x = - let log = EnvLazy.log () in + let log = Env_lazy.log () in let res = Misc.( protect_refs [R (can_load_cmis, Cannot_load_cmis log)] (fun () -> f x)) in - EnvLazy.backtrack log; + Env_lazy.backtrack log; res (* Forward declarations *) @@ -566,9 +567,9 @@ let md md_type = {md_type; md_attributes = []; md_loc = Location.none} let get_components_opt c = match !can_load_cmis with - | Can_load_cmis -> EnvLazy.force !components_of_module_maker' c.comps + | Can_load_cmis -> Env_lazy.force !components_of_module_maker' c.comps | Cannot_load_cmis log -> - EnvLazy.force_logged log !components_of_module_maker' c.comps + Env_lazy.force_logged log !components_of_module_maker' c.comps let empty_structure = Structure_comps @@ -611,18 +612,18 @@ let persistent_structures = let crc_units = Consistbl.create () -module StringSet = Set.Make (struct +module String_set = Set.Make (struct type t = string let compare = String.compare end) -let imported_units = ref StringSet.empty +let imported_units = ref String_set.empty -let add_import s = imported_units := StringSet.add s !imported_units +let add_import s = imported_units := String_set.add s !imported_units let clear_imports () = Consistbl.clear crc_units; - imported_units := StringSet.empty + imported_units := String_set.empty let check_consistency ps = try @@ -781,7 +782,7 @@ let get_unit_name () = !current_unit let rec find_module_descr path env = match path with | Pident id -> ( - try IdTbl.find_same id env.components + try Id_tbl.find_same id env.components with Not_found -> if Ident.persistent id && not (Ident.name id = !current_unit) then (find_pers_struct (Ident.name id)).ps_comps @@ -799,7 +800,7 @@ let rec find_module_descr path env = let find proj1 proj2 path env = match path with - | Pident id -> IdTbl.find_same id (proj1 env) + | Pident id -> Id_tbl.find_same id (proj1 env) | Pdot (p, s, _pos) -> ( match get_components (find_module_descr p env) with | Structure_comps c -> @@ -822,7 +823,7 @@ let type_of_cstr path = function let find_type_full path env = match Path.constructor_typath path with | Regular p -> ( - try (PathMap.find p env.local_constraints, ([], [])) + try (Path_map.find p env.local_constraints, ([], [])) with Not_found -> find_type_full p env) | Cstr (ty_path, s) -> let _, (cstrs, _) = @@ -835,7 +836,7 @@ let find_type_full path env = type_of_cstr path cstr | LocalExt id -> let cstr = - try TycompTbl.find_same id env.constrs with Not_found -> assert false + try Tycomp_tbl.find_same id env.constrs with Not_found -> assert false in type_of_cstr path cstr | Ext (mod_path, s) -> ( @@ -866,8 +867,8 @@ let find_module ~alias path env = match path with | Pident id -> ( try - let data = IdTbl.find_same id env.modules in - EnvLazy.force subst_modtype_maker data + let data = Id_tbl.find_same id env.modules in + Env_lazy.force subst_modtype_maker data with Not_found -> if Ident.persistent id && not (Ident.name id = !current_unit) then let ps = find_pers_struct (Ident.name id) in @@ -877,7 +878,7 @@ let find_module ~alias path env = match get_components (find_module_descr p env) with | Structure_comps c -> let data, _pos = Tbl.find_str s c.comp_modules in - EnvLazy.force subst_modtype_maker data + Env_lazy.force subst_modtype_maker data | Functor_comps _ -> raise Not_found) | Papply (p1, p2) -> ( let desc1 = find_module_descr p1 env in @@ -1000,7 +1001,7 @@ let mark_module_used env name loc = let rec lookup_module_descr_aux ?loc lid env = match lid with | Lident s -> ( - try IdTbl.find_name s env.components + try Id_tbl.find_name s env.components with Not_found -> if s = !current_unit then raise Not_found; let ps = find_pers_struct s in @@ -1037,9 +1038,9 @@ and lookup_module ~load ?loc lid env : Path.t = match lid with | Lident s -> ( try - let p, data = IdTbl.find_name s env.modules in + let p, data = Id_tbl.find_name s env.modules in let {md_loc; md_attributes; md_type} = - EnvLazy.force subst_modtype_maker data + Env_lazy.force subst_modtype_maker data in mark_module_used env s md_loc; (match md_type with @@ -1090,7 +1091,7 @@ and lookup_module ~load ?loc lid env : Path.t = let lookup proj1 proj2 ?loc lid env = match lid with - | Lident s -> IdTbl.find_name s (proj1 env) + | Lident s -> Id_tbl.find_name s (proj1 env) | Ldot (l, s) -> ( let p, desc = lookup_module_descr ?loc l env in match get_components desc with @@ -1103,7 +1104,7 @@ let lookup proj1 proj2 ?loc lid env = let lookup_all_simple proj1 proj2 shadow ?loc lid env = match lid with | Lident s -> - let xl = TycompTbl.find_all s (proj1 env) in + let xl = Tycomp_tbl.find_all s (proj1 env) in let rec do_shadow = function | [] -> [] | (x, f) :: xs -> @@ -1120,7 +1121,7 @@ let lookup_all_simple proj1 proj2 shadow ?loc lid env = | Functor_comps _ -> raise Not_found) | Lapply _ -> raise Not_found -let has_local_constraints env = not (PathMap.is_empty env.local_constraints) +let has_local_constraints env = not (Path_map.is_empty env.local_constraints) let cstr_shadow cstr1 cstr2 = match (cstr1.cstr_tag, cstr2.cstr_tag) with @@ -1149,7 +1150,7 @@ let copy_types l env = {desc with val_type = Subst.type_expr Subst.identity desc.val_type} in let values = - List.fold_left (fun env s -> IdTbl.update s f env) env.values l + List.fold_left (fun env s -> Id_tbl.update s f env) env.values l in {env with values; summary = Env_copy_types (env.summary, l)} @@ -1293,11 +1294,11 @@ let rec scrape_alias_for_visit env mty = | _ -> true let iter_env proj1 proj2 f env () = - IdTbl.iter (fun id x -> f (Pident id) x) (proj1 env); + Id_tbl.iter (fun id x -> f (Pident id) x) (proj1 env); let rec iter_components path path' mcomps = let cont () = let visit = - match EnvLazy.get_arg mcomps.comps with + match Env_lazy.get_arg mcomps.comps with | None -> true | Some (env, _sub, _path, mty) -> scrape_alias_for_visit env mty in @@ -1324,7 +1325,7 @@ let iter_env proj1 proj2 f env () = let id = Pident (Ident.create_persistent s) in iter_components id id ps.ps_comps) persistent_structures; - IdTbl.iter + Id_tbl.iter (fun id (path, comps) -> iter_components (Pident id) path comps) env.components @@ -1358,7 +1359,7 @@ let find_all_comps proj s (p, mcomps) = let rec find_shadowed_comps path env = match path with - | Pident id -> IdTbl.find_all (Ident.name id) env.components + | Pident id -> Id_tbl.find_all (Ident.name id) env.components | Pdot (p, s, _) -> let l = find_shadowed_comps p env in let l' = @@ -1369,7 +1370,7 @@ let rec find_shadowed_comps path env = let find_shadowed proj1 proj2 path env = match path with - | Pident id -> IdTbl.find_all (Ident.name id) (proj1 env) + | Pident id -> Id_tbl.find_all (Ident.name id) (proj1 env) | Pdot (p, s, _) -> let l = find_shadowed_comps p env in let l' = List.map (find_all_comps proj2 s) l in @@ -1386,7 +1387,7 @@ let find_shadowed_types path env = (* GADT instance tracking *) let add_gadt_instance_level lv env = - {env with gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances} + {env with gadt_instances = (lv, ref Type_set.empty) :: env.gadt_instances} let is_Tlink = function | {desc = Tlink _} -> true @@ -1396,10 +1397,10 @@ let gadt_instance_level env t = let rec find_instance = function | [] -> None | (lv, r) :: rem -> - if TypeSet.exists is_Tlink !r then + if Type_set.exists is_Tlink !r then (* Should we use set_typeset ? *) - r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty; - if TypeSet.mem t !r then Some lv else find_instance rem + r := Type_set.fold (fun ty -> Type_set.add (repr ty)) !r Type_set.empty; + if Type_set.mem t !r then Some lv else find_instance rem in find_instance env.gadt_instances @@ -1410,7 +1411,7 @@ let add_gadt_instances env lv tl = (* Format.eprintf "Added"; List.iter (fun ty -> Format.eprintf "@ %a" !Btype.print_raw ty) tl; Format.eprintf "@."; *) - set_typeset r (List.fold_right TypeSet.add tl !r) + set_typeset r (List.fold_right Type_set.add tl !r) (* Only use this after expand_head! *) let add_gadt_instance_chain env lv t = @@ -1419,9 +1420,9 @@ let add_gadt_instance_chain env lv t = in let rec add_instance t = let t = repr t in - if not (TypeSet.mem t !r) then ( + if not (Type_set.mem t !r) then ( (* Format.eprintf "@ %a" !Btype.print_raw t; *) - set_typeset r (TypeSet.add t !r); + set_typeset r (Type_set.add t !r); match t.desc with | Tconstr (p, _, memo) -> may add_instance (find_expans Private p !memo) | _ -> ()) @@ -1511,7 +1512,7 @@ let add_to_tbl id decl tbl = Tbl.add id (decl :: decls) tbl let rec components_of_module ~deprecated ~loc env sub path mty = - {deprecated; loc; comps = EnvLazy.create (env, sub, path, mty)} + {deprecated; loc; comps = Env_lazy.create (env, sub, path, mty)} and components_of_module_maker (env, sub, path, mty) = match scrape_alias env mty with @@ -1565,7 +1566,7 @@ and components_of_module_maker (env, sub, path, mty) = c.comp_constrs <- add_to_tbl (Ident.name id) descr c.comp_constrs; incr pos | Sig_module (id, md, _) -> - let md' = EnvLazy.create (sub, md) in + let md' = Env_lazy.create (sub, md) in c.comp_modules <- Tbl.add (Ident.name id) (md', !pos) c.comp_modules; let deprecated = Builtin_attributes.deprecated_of_attrs md.md_attributes @@ -1630,7 +1631,7 @@ and store_value ?check id decl env = may (fun f -> check_usage decl.val_loc id f value_declarations) check; { env with - values = IdTbl.add id decl env.values; + values = Id_tbl.add id decl env.values; summary = Env_value (env.summary, id, decl); } @@ -1668,13 +1669,13 @@ and store_type ~check id info env = env with constrs = List.fold_right - (fun (id, descr) constrs -> TycompTbl.add id descr constrs) + (fun (id, descr) constrs -> Tycomp_tbl.add id descr constrs) constructors env.constrs; labels = List.fold_right - (fun (id, descr) labels -> TycompTbl.add id descr labels) + (fun (id, descr) labels -> Tycomp_tbl.add id descr labels) labels env.labels; - types = IdTbl.add id (info, descrs) env.types; + types = Id_tbl.add id (info, descrs) env.types; summary = Env_type (env.summary, id, info); } @@ -1686,7 +1687,7 @@ and store_type_infos id info env = computation of label representations. *) { env with - types = IdTbl.add id (info, ([], [])) env.types; + types = Id_tbl.add id (info, ([], [])) env.types; summary = Env_type (env.summary, id, info); } @@ -1711,7 +1712,7 @@ and store_extension ~check id ext env = { env with constrs = - TycompTbl.add id (Datarepr.extension_descr (Pident id) ext) env.constrs; + Tycomp_tbl.add id (Datarepr.extension_descr (Pident id) ext) env.constrs; summary = Env_extension (env.summary, id, ext); } @@ -1723,9 +1724,9 @@ and store_module ~check id md env = let deprecated = Builtin_attributes.deprecated_of_attrs md.md_attributes in { env with - modules = IdTbl.add id (EnvLazy.create (Subst.identity, md)) env.modules; + modules = Id_tbl.add id (Env_lazy.create (Subst.identity, md)) env.modules; components = - IdTbl.add id + Id_tbl.add id (components_of_module ~deprecated ~loc:md.md_loc env Subst.identity (Pident id) md.md_type) env.components; @@ -1735,7 +1736,7 @@ and store_module ~check id md env = and store_modtype id info env = { env with - modtypes = IdTbl.add id info env.modtypes; + modtypes = Id_tbl.add id info env.modtypes; summary = Env_modtype (env.summary, id, info); } @@ -1786,7 +1787,7 @@ let add_module ?arg id mty env = add_module_declaration ~check:false ?arg id (md mty) env let add_local_type path info env = - {env with local_constraints = PathMap.add path info env.local_constraints} + {env with local_constraints = Path_map.add path info env.local_constraints} let add_local_constraint path info elv env = match info with @@ -1839,9 +1840,9 @@ let rec add_signature sg env = (* Open a signature path *) let add_components slot root env0 comps = - let add_l w comps env0 = TycompTbl.add_open slot w comps env0 in + let add_l w comps env0 = Tycomp_tbl.add_open slot w comps env0 in - let add w comps env0 = IdTbl.add_open slot w root comps env0 in + let add w comps env0 = Id_tbl.add_open slot w root comps env0 in let constrs = add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs @@ -1930,10 +1931,10 @@ let crc_of_unit name = let imports () = let dont_record_crc_unit = !Clflags.dont_record_crc_unit in match dont_record_crc_unit with - | None -> Consistbl.extract (StringSet.elements !imported_units) crc_units + | None -> Consistbl.extract (String_set.elements !imported_units) crc_units | Some x -> Consistbl.extract - (StringSet.fold + (String_set.fold (fun m acc -> if m = x then acc else m :: acc) !imported_units []) crc_units @@ -1989,7 +1990,7 @@ let save_signature ?check_exists ~deprecated sg modname filename = let find_all proj1 proj2 f lid env acc = match lid with | None -> - IdTbl.fold_name + Id_tbl.fold_name (fun name (p, data) acc -> f name p data acc) (proj1 env) acc | Some l -> ( @@ -2003,7 +2004,7 @@ let find_all proj1 proj2 f lid env acc = let find_all_simple_list proj1 proj2 f lid env acc = match lid with - | None -> TycompTbl.fold_name (fun data acc -> f data acc) (proj1 env) acc + | None -> Tycomp_tbl.fold_name (fun data acc -> f data acc) (proj1 env) acc | Some l -> ( let _p, desc = lookup_module_descr l env in match get_components desc with @@ -2020,9 +2021,9 @@ let fold_modules f lid env acc = match lid with | None -> let acc = - IdTbl.fold_name + Id_tbl.fold_name (fun name (p, data) acc -> - let data = EnvLazy.force subst_modtype_maker data in + let data = Env_lazy.force subst_modtype_maker data in f name p data acc) env.modules acc in @@ -2042,7 +2043,7 @@ let fold_modules f lid env acc = | Structure_comps c -> Tbl.fold (fun s (data, pos) acc -> - f s (Pdot (p, s, pos)) (EnvLazy.force subst_modtype_maker data) acc) + f s (Pdot (p, s, pos)) (Env_lazy.force subst_modtype_maker data) acc) c.comp_modules acc | Functor_comps _ -> acc) @@ -2069,7 +2070,7 @@ let initial_safe_string = (* Return the environment summary *) let summary env = - if PathMap.is_empty env.local_constraints then env.summary + if Path_map.is_empty env.local_constraints then env.summary else Env_constraints (env.summary, env.local_constraints) let last_env = ref empty diff --git a/compiler/ml/env.mli b/compiler/ml/env.mli index 48eaba1c10d..66b8e3192b4 100644 --- a/compiler/ml/env.mli +++ b/compiler/ml/env.mli @@ -17,7 +17,7 @@ open Types -module PathMap : +module Path_map : Map.S with type key = Path.t and type 'a t = 'a Map.Make(Path).t type summary = @@ -29,7 +29,7 @@ type summary = | Env_modtype of summary * Ident.t * modtype_declaration | Env_open of summary * Path.t | Env_functor_arg of summary * Ident.t - | Env_constraints of summary * type_declaration PathMap.t + | Env_constraints of summary * type_declaration Path_map.t | Env_copy_types of summary * string list type t diff --git a/compiler/ml/experimental_features.ml b/compiler/ml/experimental_features.ml index 662157b1efb..b30faa2e0b6 100644 --- a/compiler/ml/experimental_features.ml +++ b/compiler/ml/experimental_features.ml @@ -9,17 +9,17 @@ let from_string (s : string) : feature option = | "LetUnwrap" -> Some LetUnwrap | _ -> None -module FeatureSet = Set.Make (struct +module Feature_set = Set.Make (struct type t = feature let compare = compare end) -let enabled_features : FeatureSet.t ref = ref FeatureSet.empty +let enabled_features : Feature_set.t ref = ref Feature_set.empty let enable_from_string (s : string) = match from_string s with - | Some f -> enabled_features := FeatureSet.add f !enabled_features + | Some f -> enabled_features := Feature_set.add f !enabled_features | None -> () -let reset () = enabled_features := FeatureSet.empty +let reset () = enabled_features := Feature_set.empty -let is_enabled (f : feature) = FeatureSet.mem f !enabled_features +let is_enabled (f : feature) = Feature_set.mem f !enabled_features diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index a111bc388f8..33078a59fde 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -567,26 +567,26 @@ let iter f = function | Lassign (_, e) -> f e | Lsend (_k, obj, _) -> f obj -module IdentSet = Set.Make (Ident) +module Ident_set = Set.Make (Ident) let free_ids get l = - let fv = ref IdentSet.empty in + let fv = ref Ident_set.empty in let rec free l = iter free l; - fv := List.fold_right IdentSet.add (get l) !fv; + fv := List.fold_right Ident_set.add (get l) !fv; match l with | Lfunction {params} -> - List.iter (fun param -> fv := IdentSet.remove param !fv) params - | Llet (_str, _k, id, _arg, _body) -> fv := IdentSet.remove id !fv + List.iter (fun param -> fv := Ident_set.remove param !fv) params + | Llet (_str, _k, id, _arg, _body) -> fv := Ident_set.remove id !fv | Lletrec (decl, _body) -> - List.iter (fun (id, _exp) -> fv := IdentSet.remove id !fv) decl + List.iter (fun (id, _exp) -> fv := Ident_set.remove id !fv) decl | Lstaticcatch (_e1, (_, vars), _e2) -> - List.iter (fun id -> fv := IdentSet.remove id !fv) vars - | Ltrywith (_e1, exn, _e2) -> fv := IdentSet.remove exn !fv - | Lfor (v, _e1, _e2, _dir, _e3) -> fv := IdentSet.remove v !fv + List.iter (fun id -> fv := Ident_set.remove id !fv) vars + | Ltrywith (_e1, exn, _e2) -> fv := Ident_set.remove exn !fv + | Lfor (v, _e1, _e2, _dir, _e3) -> fv := Ident_set.remove v !fv | Lfor_of (v, _e1, _e2) | Lfor_await_of (v, _e1, _e2) -> - fv := IdentSet.remove v !fv - | Lassign (id, _e) -> fv := IdentSet.add id !fv + fv := Ident_set.remove v !fv + | Lassign (id, _e) -> fv := Ident_set.add id !fv | Lvar _ | Lconst _ | Lapply _ | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lbreak | Lcontinue | Lwhile _ | Lsend _ -> diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index b55caf8c364..0440d20c7f3 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -390,8 +390,8 @@ val lambda_module_alias : lambda val name_lambda : let_kind -> lambda -> (Ident.t -> lambda) -> lambda val iter : (lambda -> unit) -> lambda -> unit -module IdentSet : Set.S with type elt = Ident.t -val free_variables : lambda -> IdentSet.t +module Ident_set : Set.S with type elt = Ident.t +val free_variables : lambda -> Ident_set.t val transl_normal_path : Path.t -> lambda (* Path.t is already normal *) diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index b84339aed94..916646ea08a 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -439,7 +439,7 @@ let pretty_precompiled_res first nexts = in case action sharing is present. *) -module StoreExp = Switch.Store (struct +module Store_exp = Switch.Store (struct type t = lambda type key = lambda let compare_key = compare @@ -612,8 +612,8 @@ let default_compat p def = (* Or-pattern expansion, variables are a complication w.r.t. the article *) let rec extract_vars r p = match p.pat_desc with - | Tpat_var (id, _) -> IdentSet.add id r - | Tpat_alias (p, id, _) -> extract_vars (IdentSet.add id r) p + | Tpat_var (id, _) -> Ident_set.add id r + | Tpat_alias (p, id, _) -> extract_vars (Ident_set.add id r) p | Tpat_tuple pats -> List.fold_left extract_vars r pats | Tpat_record (lpats, _) -> List.fold_left (fun r (_, _, p, _) -> extract_vars r p) r lpats @@ -652,8 +652,8 @@ let rec explode_or_pat arg patl mk_action rem vars aliases = function let pm_free_variables {cases} = List.fold_right - (fun (_, act) r -> IdentSet.union (free_variables act) r) - cases IdentSet.empty + (fun (_, act) r -> Ident_set.union (free_variables act) r) + cases Ident_set.empty (* Basic grouping predicates *) let pat_as_constr = function @@ -735,8 +735,8 @@ let insert_or_append p ps act ors no = if is_or q then if may_compat p q then if - IdentSet.is_empty (extract_vars IdentSet.empty p) - && IdentSet.is_empty (extract_vars IdentSet.empty q) + Ident_set.is_empty (extract_vars Ident_set.empty p) + && Ident_set.is_empty (extract_vars Ident_set.empty q) && equiv_pat p q then (* attempt insert, for equivalent orpats with no variables *) @@ -1046,9 +1046,9 @@ and precompile_or argo cls ors args def k = } in let vars = - IdentSet.elements - (IdentSet.inter - (extract_vars IdentSet.empty orp) + Ident_set.elements + (Ident_set.inter + (extract_vars Ident_set.empty orp) (pm_free_variables orpm)) in let or_num = next_raise_count () in @@ -1620,7 +1620,7 @@ let handle_shared () = (hs, handle_shared) let share_actions_tree sw d = - let store = StoreExp.mk_store () in + let store = Store_exp.mk_store () in (* Default action is always shared *) let d = match d with @@ -1706,7 +1706,7 @@ let make_test_sequence loc fail tst lt_tst arg const_lambda_list = in hs (make_test_sequence const_lambda_list) -module SArg = struct +module S_arg = struct type primitive = Lambda.primitive let eqint = Pintcomp Ceq @@ -1760,7 +1760,7 @@ end (* Action sharing for Lswitch argument *) let share_actions_sw sw = (* Attempt sharing on all actions *) - let store = StoreExp.mk_store () in + let store = Store_exp.mk_store () in let fail = match sw.sw_failaction with | None -> None @@ -1832,7 +1832,7 @@ let reintroduce_fail sw = else sw | Some _ -> sw -module Switcher = Switch.Make (SArg) +module Switcher = Switch.Make (S_arg) open Switch let rec last def = function @@ -1846,7 +1846,7 @@ let get_edges low high l = | (x, _) :: _ -> (x, last high l) let as_interval_canfail fail low high l = - let store = StoreExp.mk_store () in + let store = Store_exp.mk_store () in let do_store _tag act = let i = store.act_store act in @@ -1896,7 +1896,7 @@ let as_interval_canfail fail low high l = (Array.of_list r, store) let as_interval_nofail l = - let store = StoreExp.mk_store () in + let store = Store_exp.mk_store () in let rec some_hole = function | [] | [_] -> false | (i, _) :: ((j, _) :: _ as rem) -> j > i + 1 || some_hole rem diff --git a/compiler/ml/mtype.ml b/compiler/ml/mtype.ml index 449d89ae5a3..4ed00e0054e 100644 --- a/compiler/ml/mtype.ml +++ b/compiler/ml/mtype.ml @@ -297,24 +297,24 @@ let contains_type env mty = (* Remove module aliases from a signature *) -module PathSet = Set.Make (Path) -module PathMap = Map.Make (Path) -module IdentSet = Set.Make (Ident) +module Path_set = Set.Make (Path) +module Path_map = Map.Make (Path) +module Ident_set = Set.Make (Ident) let rec get_prefixes = function - | Pident _ -> PathSet.empty - | Pdot (p, _, _) | Papply (p, _) -> PathSet.add p (get_prefixes p) + | Pident _ -> Path_set.empty + | Pdot (p, _, _) | Papply (p, _) -> Path_set.add p (get_prefixes p) let rec get_arg_paths = function - | Pident _ -> PathSet.empty + | Pident _ -> Path_set.empty | Pdot (p, _, _) -> get_arg_paths p | Papply (p1, p2) -> - PathSet.add p2 - (PathSet.union (get_prefixes p2) - (PathSet.union (get_arg_paths p1) (get_arg_paths p2))) + Path_set.add p2 + (Path_set.union (get_prefixes p2) + (Path_set.union (get_arg_paths p1) (get_arg_paths p2))) let rec rollback_path subst p = - try Pident (PathMap.find p subst) + try Pident (Path_map.find p subst) with Not_found -> ( match p with | Pident _ | Papply _ -> p @@ -327,19 +327,19 @@ let rec collect_ids subst bindings p = | Pident id -> let ids = try collect_ids subst bindings (Ident.find_same id bindings) - with Not_found -> IdentSet.empty + with Not_found -> Ident_set.empty in - IdentSet.add id ids - | _ -> IdentSet.empty + Ident_set.add id ids + | _ -> Ident_set.empty let collect_arg_paths mty = let open Btype in - let paths = ref PathSet.empty - and subst = ref PathMap.empty + let paths = ref Path_set.empty + and subst = ref Path_map.empty and bindings = ref Ident.empty in (* let rt = Ident.create "Root" in and prefix = ref (Path.Pident rt) in *) - let it_path p = paths := PathSet.union (get_arg_paths p) !paths + let it_path p = paths := Path_set.union (get_arg_paths p) !paths and it_signature_item it si = type_iterators.it_signature_item it si; match si with @@ -350,7 +350,7 @@ let collect_arg_paths mty = (function | Sig_module (id', _, _) -> subst := - PathMap.add (Pdot (Pident id, Ident.name id', -1)) id' !subst + Path_map.add (Pdot (Pident id, Ident.name id', -1)) id' !subst | _ -> ()) sg | _ -> () @@ -358,9 +358,9 @@ let collect_arg_paths mty = let it = {type_iterators with it_path; it_signature_item} in it.it_module_type it mty; it.it_module_type unmark_iterators mty; - PathSet.fold - (fun p -> IdentSet.union (collect_ids !subst !bindings p)) - !paths IdentSet.empty + Path_set.fold + (fun p -> Ident_set.union (collect_ids !subst !bindings p)) + !paths Ident_set.empty let rec remove_aliases env excl mty = match mty with @@ -378,7 +378,7 @@ and remove_aliases_sig env excl sg = | Sig_module (id, md, rs) :: rem -> let mty = match md.md_type with - | Mty_alias _ when IdentSet.mem id excl -> md.md_type + | Mty_alias _ when Ident_set.mem id excl -> md.md_type | mty -> remove_aliases env excl mty in Sig_module (id, {md with md_type = mty}, rs) diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index b86364445f0..4ae23724fb4 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -899,7 +899,7 @@ let should_extend ext env = false | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_or _ -> assert false)) -module ConstructorTagHashtbl = Hashtbl.Make (struct +module Constructor_tag_hashtbl = Hashtbl.Make (struct type t = Types.constructor_tag let hash = Hashtbl.hash let equal = Types.equal_tag @@ -915,12 +915,13 @@ let complete_tags nconsts nconstrs tags = | Cstr_block i -> seen_constr.(i) <- true | _ -> assert false) tags; - let r = ConstructorTagHashtbl.create (nconsts + nconstrs) in + let r = Constructor_tag_hashtbl.create (nconsts + nconstrs) in for i = 0 to nconsts - 1 do - if not seen_const.(i) then ConstructorTagHashtbl.add r (Cstr_constant i) () + if not seen_const.(i) then + Constructor_tag_hashtbl.add r (Cstr_constant i) () done; for i = 0 to nconstrs - 1 do - if not seen_constr.(i) then ConstructorTagHashtbl.add r (Cstr_block i) () + if not seen_constr.(i) then Constructor_tag_hashtbl.add r (Cstr_block i) () done; r @@ -996,7 +997,7 @@ let complete_constrs p all_tags = let constrs = get_variant_constructors p.pat_env c.cstr_res in let others = Ext_list.filter constrs (fun cnstr -> - ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag) + Constructor_tag_hashtbl.mem not_tags cnstr.cstr_tag) in let const, nonconst = List.partition (fun cnstr -> cnstr.cstr_arity = 0) others @@ -2364,22 +2365,23 @@ let check_partial_gadt ?partial_match_warning_hint pred loc casel = to a specific guard. *) -module IdSet = Set.Make (Ident) +module Id_set = Set.Make (Ident) -let pattern_vars p = IdSet.of_list (Typedtree.pat_bound_idents p) +let pattern_vars p = Id_set.of_list (Typedtree.pat_bound_idents p) (* Row for ambiguous variable search, unseen is the traditional pattern row, seen is a list of position bindings *) -type amb_row = {unseen: pattern list; seen: IdSet.t list} +type amb_row = {unseen: pattern list; seen: Id_set.t list} (* Push binding variables now *) let rec do_push r p ps seen k = match p.pat_desc with - | Tpat_alias (p, x, _) -> do_push (IdSet.add x r) p ps seen k - | Tpat_var (x, _) -> (omega, {unseen = ps; seen = IdSet.add x r :: seen}) :: k + | Tpat_alias (p, x, _) -> do_push (Id_set.add x r) p ps seen k + | Tpat_var (x, _) -> + (omega, {unseen = ps; seen = Id_set.add x r :: seen}) :: k | Tpat_or (p1, p2, _) -> do_push r p1 ps seen (do_push r p2 ps seen k) | _ -> (p, {unseen = ps; seen = r :: seen}) :: k @@ -2387,7 +2389,7 @@ let rec push_vars = function | [] -> [] | {unseen = []} :: _ -> assert false | {unseen = p :: ps; seen} :: rem -> - do_push IdSet.empty p ps seen (push_vars rem) + do_push Id_set.empty p ps seen (push_vars rem) let collect_stable = function | [] -> assert false @@ -2395,11 +2397,11 @@ let collect_stable = function let rec c_rec xss = function | [] -> xss | {seen = yss; _} :: rem -> - let xss = List.map2 IdSet.inter xss yss in + let xss = List.map2 Id_set.inter xss yss in c_rec xss rem in let inters = c_rec xss rem in - List.fold_left IdSet.union IdSet.empty inters + List.fold_left Id_set.union Id_set.empty inters (*********************************************) (* Filtering utilities for our specific rows *) @@ -2498,8 +2500,8 @@ let rec do_stable rs = (* If the first column is incoherent, then all the variables of this matrix are stable. *) List.fold_left - (fun acc (_, {seen; _}) -> List.fold_left IdSet.union acc seen) - IdSet.empty rs + (fun acc (_, {seen; _}) -> List.fold_left Id_set.union acc seen) + Id_set.empty rs else (* If the column is ill-typed but deemed coherent, we might spuriously warn about some variables being unstable. @@ -2509,7 +2511,7 @@ let rec do_stable rs = | [] -> do_stable (List.map snd rs) | (_, rs) :: env -> List.fold_left - (fun xs (_, rs) -> IdSet.inter xs (do_stable rs)) + (fun xs (_, rs) -> Id_set.inter xs (do_stable rs)) (do_stable rs) env) let stable p = do_stable [{unseen = [p]; seen = []}] @@ -2533,13 +2535,13 @@ let stable p = do_stable [{unseen = [p]; seen = []}] *) let all_rhs_idents exp = - let ids = ref IdSet.empty in - let module Iterator = TypedtreeIter.MakeIterator (struct - include TypedtreeIter.DefaultIteratorArgument + let ids = ref Id_set.empty in + let module Iterator = Typedtree_iter.Make_iterator (struct + include Typedtree_iter.Default_iterator_argument let enter_expression exp = match exp.exp_desc with | Texp_ident (path, _lid, _descr) -> - List.iter (fun id -> ids := IdSet.add id !ids) (Path.heads path) + List.iter (fun id -> ids := Id_set.add id !ids) (Path.heads path) | _ -> () (* Very hackish, detect unpack pattern compilation @@ -2559,8 +2561,8 @@ let all_rhs_idents exp = ({exp_desc = Texp_ident (Path.Pident id_exp, _, _)}, _); }, _ ) -> - assert (IdSet.mem id_exp !ids); - if not (IdSet.mem id_mod !ids) then ids := IdSet.remove id_exp !ids + assert (Id_set.mem id_exp !ids); + if not (Id_set.mem id_mod !ids) then ids := Id_set.remove id_exp !ids | _ -> assert false end) in Iterator.iter_expression exp; @@ -2576,12 +2578,12 @@ let check_ambiguous_bindings = match case with | {c_guard = None; _} -> () | {c_lhs = p; c_guard = Some g; _} -> - let all = IdSet.inter (pattern_vars p) (all_rhs_idents g) in - if not (IdSet.is_empty all) then + let all = Id_set.inter (pattern_vars p) (all_rhs_idents g) in + if not (Id_set.is_empty all) then let st = stable p in - let ambiguous = IdSet.diff all st in - if not (IdSet.is_empty ambiguous) then - let pps = IdSet.elements ambiguous |> List.map Ident.name in + let ambiguous = Id_set.diff all st in + if not (Id_set.is_empty ambiguous) then + let pps = Id_set.elements ambiguous |> List.map Ident.name in let warn = Ambiguous_pattern pps in Location.prerr_warning p.pat_loc warn) cases diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 9cf370da441..da6a3b25b16 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -259,8 +259,8 @@ let printing_depth = ref 0 let printing_cont = ref ([] : Env.iter_cont list) let printing_old = ref Env.empty let printing_pers = ref Concr.empty -module PathMap = Map.Make (Path) -let printing_map = ref PathMap.empty +module Path_map = Map.Make (Path) +let printing_map = ref Path_map.empty let same_type t t' = repr t == repr t' @@ -322,7 +322,7 @@ let set_printing_env env = (* printf "Reset printing_map@."; *) printing_old := env; printing_pers := Env.used_persistent (); - printing_map := PathMap.empty; + printing_map := Path_map.empty; printing_depth := 0; (* printf "Recompute printing_map.@."; *) let cont = @@ -332,13 +332,13 @@ let set_printing_env env = (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *) if s1 = Id then try - let r = PathMap.find p1 !printing_map in + let r = Path_map.find p1 !printing_map in match !r with | Paths l -> r := Paths (p :: l) | Best p' -> r := Paths [p; p'] (* assert false *) with Not_found -> - printing_map := PathMap.add p1 (ref (Paths [p])) !printing_map) + printing_map := Path_map.add p1 (ref (Paths [p])) !printing_map) env in printing_cont := [cont]) @@ -387,7 +387,7 @@ let best_type_path p = if !Clflags.real_paths || !printing_env == Env.empty then (p, Id) else let p', s = normalize_type_path !printing_env p in - let get_path () = get_best_path (PathMap.find p' !printing_map) in + let get_path () = get_best_path (Path_map.find p' !printing_map) in while !printing_cont <> [] && @@ -408,8 +408,8 @@ let name_counter = ref 0 let named_vars = ref ([] : string list) let weak_counter = ref 1 -let weak_var_map = ref TypeMap.empty -let named_weak_vars = ref StringSet.empty +let weak_var_map = ref Type_map.empty +let named_weak_vars = ref String_set.empty let reset_names () = names := []; @@ -424,7 +424,7 @@ let add_named_var ty = let name_is_already_used name = List.mem name !named_vars || List.exists (fun (_, name') -> name = name') !names - || StringSet.mem name !named_weak_vars + || String_set.mem name !named_weak_vars let rec new_name () = let name = @@ -441,8 +441,8 @@ let rec new_weak_name ty () = incr weak_counter; if name_is_already_used name then new_weak_name ty () else ( - named_weak_vars := StringSet.add name !named_weak_vars; - weak_var_map := TypeMap.add ty name !weak_var_map; + named_weak_vars := String_set.add name !named_weak_vars; + weak_var_map := Type_map.add ty name !weak_var_map; name) let name_of_type name_generator t = @@ -450,7 +450,7 @@ let name_of_type name_generator t = of the union-find class. *) try List.assq t !names with Not_found -> ( - try TypeMap.find t !weak_var_map + try Type_map.find t !weak_var_map with Not_found -> let name = match t.desc with @@ -1185,11 +1185,12 @@ let modtype_declaration id ppf decl = (* Refresh weak variable map in the toplevel *) let refresh_weak () = let refresh t name (m, s) = - if is_non_gen true (repr t) then (TypeMap.add t name m, StringSet.add name s) + if is_non_gen true (repr t) then + (Type_map.add t name m, String_set.add name s) else (m, s) in let m, s = - TypeMap.fold refresh !weak_var_map (TypeMap.empty, StringSet.empty) + Type_map.fold refresh !weak_var_map (Type_map.empty, String_set.empty) in named_weak_vars := s; weak_var_map := m @@ -1751,7 +1752,7 @@ let report_subtyping_error ppf env tr1 txt1 tr2 ctx = | Some ctx -> ( fprintf ppf "@,@,@["; match ctx with - | Generic {errorCode} -> fprintf ppf "Error: %s" errorCode + | Generic {error_code} -> fprintf ppf "Error: %s" error_code | Coercion_target_variant_not_unboxed {variant_name; primitive} -> fprintf ppf "@ The variant @{%s@} is not unboxed, so it cannot be \ diff --git a/compiler/ml/record_type_spread.ml b/compiler/ml/record_type_spread.ml index bf7b286dd2f..0156db4b99c 100644 --- a/compiler/ml/record_type_spread.ml +++ b/compiler/ml/record_type_spread.ml @@ -1,12 +1,12 @@ -module StringMap = Map.Make (String) +module String_map = Map.Make (String) let t_equals t1 t2 = t1.Types.level = t2.Types.level && t1.id = t2.id let substitute_types ~type_map (t : Types.type_expr) = - if StringMap.is_empty type_map then t + if String_map.is_empty type_map then t else let apply_substitution type_variable_name t = - match StringMap.find_opt type_variable_name type_map with + match String_map.find_opt type_variable_name type_map with | None -> t | Some substituted_type -> substituted_type in @@ -59,8 +59,9 @@ let substitute_type_vars (type_vars : (string * Types.type_expr) list) let type_map = type_vars |> List.fold_left - (fun acc (tvar_name, tvar_typ) -> StringMap.add tvar_name tvar_typ acc) - StringMap.empty + (fun acc (tvar_name, tvar_typ) -> + String_map.add tvar_name tvar_typ acc) + String_map.empty in substitute_types ~type_map typ diff --git a/compiler/ml/subst.ml b/compiler/ml/subst.ml index b30d32c6114..6956e90d496 100644 --- a/compiler/ml/subst.ml +++ b/compiler/ml/subst.ml @@ -24,30 +24,30 @@ type type_replacement = | Path of Path.t | Type_function of {params: type_expr list; body: type_expr} -module PathMap = Map.Make (Path) +module Path_map = Map.Make (Path) type t = { - types: type_replacement PathMap.t; - modules: Path.t PathMap.t; + types: type_replacement Path_map.t; + modules: Path.t Path_map.t; modtypes: (Ident.t, module_type) Tbl.t; for_saving: bool; } let identity = { - types = PathMap.empty; - modules = PathMap.empty; + types = Path_map.empty; + modules = Path_map.empty; modtypes = Tbl.empty; for_saving = false; } -let add_type_path id p s = {s with types = PathMap.add id (Path p) s.types} +let add_type_path id p s = {s with types = Path_map.add id (Path p) s.types} let add_type id p s = add_type_path (Pident id) p s let add_type_function id ~params ~body s = - {s with types = PathMap.add id (Type_function {params; body}) s.types} + {s with types = Path_map.add id (Type_function {params; body}) s.types} -let add_module_path id p s = {s with modules = PathMap.add id p s.modules} +let add_module_path id p s = {s with modules = Path_map.add id p s.modules} let add_module id p s = add_module_path (Pident id) p s let add_modtype id ty s = {s with modtypes = Tbl.add id ty s.modtypes} @@ -67,7 +67,7 @@ let attrs s x = else x let rec module_path s path = - try PathMap.find path s.modules + try Path_map.find path s.modules with Not_found -> ( match path with | Pident _ -> path @@ -85,7 +85,7 @@ let modtype_path s = function | Papply _ -> fatal_error "Subst.modtype_path" let type_path s path = - match PathMap.find path s.types with + match Path_map.find path s.types with | Path p -> p | Type_function _ -> assert false | exception Not_found -> ( @@ -102,7 +102,7 @@ let type_path s p = | Ext (p, cstr) -> Pdot (module_path s p, cstr, nopos) let to_subst_by_type_function s p = - match PathMap.find p s.types with + match Path_map.find p s.types with | Path _ -> false | Type_function _ -> true | exception Not_found -> false @@ -172,7 +172,7 @@ let rec typexp s ty = match desc with | Tconstr (p, args, _abbrev) -> ( let args = List.map (typexp s) args in - match PathMap.find p s.types with + match Path_map.find p s.types with | exception Not_found -> Tconstr (type_path s p, args, ref Mnil) | Path _ -> Tconstr (type_path s p, args, ref Mnil) | Type_function {params; body} -> diff --git a/compiler/ml/switch.ml b/compiler/ml/switch.ml index 9626f060c57..80bb69e7c52 100644 --- a/compiler/ml/switch.ml +++ b/compiler/ml/switch.ml @@ -31,19 +31,19 @@ module type Stored = sig end module Store (A : Stored) = struct - module AMap = Map.Make (struct + module A_map = Map.Make (struct type t = A.key let compare = A.compare_key end) type intern = { - mutable map: (bool * int) AMap.t; + mutable map: (bool * int) A_map.t; mutable next: int; mutable acts: (bool * A.t) list; } let mk_store () = - let st = {map = AMap.empty; next = 0; acts = []} in + let st = {map = A_map.empty; next = 0; acts = []} in let add mustshare act = let i = st.next in @@ -56,12 +56,12 @@ module Store (A : Stored) = struct match A.make_key act with | Some key -> ( try - let shared, i = AMap.find key st.map in - if not shared then st.map <- AMap.add key (true, i) st.map; + let shared, i = A_map.find key st.map in + if not shared then st.map <- A_map.add key (true, i) st.map; i with Not_found -> let i = add mustshare act in - st.map <- AMap.add key (mustshare, i) st.map; + st.map <- A_map.add key (mustshare, i) st.map; i) | None -> add mustshare act and get_shared () = @@ -71,7 +71,7 @@ module Store (A : Stored) = struct (fun (shared, act) -> if shared then Shared act else Single act) st.acts) in - AMap.iter + A_map.iter (fun _ (shared, i) -> if shared then match acts.(i) with diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index 6b89d29bb72..77617eda5d6 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -108,7 +108,7 @@ let reorder_rec_bindings bindings = if init.(i) = None then ( status.(i) <- Inprogress; for j = 0 to num_bindings - 1 do - if IdentSet.mem id.(j) fv.(i) then emit_binding j + if Ident_set.mem id.(j) fv.(i) then emit_binding j done); res := (id.(i), init.(i), rhs.(i)) :: !res; status.(i) <- Defined diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 87471ac26bf..eded92c102f 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -112,7 +112,7 @@ and wrap_id_pos_list loc id_pos_list get_field lam = let lam, s = List.fold_left (fun (lam, s) (id', pos, c) -> - if Lambda.IdentSet.mem id' fv then + if Lambda.Ident_set.mem id' fv then let id'' = Ident.create (Ident.name id') in ( Lambda.Llet ( Alias, @@ -318,7 +318,7 @@ and transl_structure loc fields cc rootpath final_env = function let v = Ext_array.reverse_of_list fields in let get_field pos = Lambda.Lvar v.(pos) and ids = - List.fold_right Lambda.IdentSet.add fields Lambda.IdentSet.empty + List.fold_right Lambda.Ident_set.add fields Lambda.Ident_set.empty in let get_field_name _name = get_field in let result = @@ -345,7 +345,7 @@ and transl_structure loc fields cc rootpath final_env = function loc ) and id_pos_list = Ext_list.filter id_pos_list (fun (id, _, _) -> - not (Lambda.IdentSet.mem id ids)) + not (Lambda.Ident_set.mem id ids)) in ( wrap_id_pos_list loc id_pos_list get_field_name lam, List.length pos_cc_list ) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 4f0b3be38e4..1073ffcf89b 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -832,7 +832,7 @@ let report_arity_mismatch ~arity_a ~arity_b ppf = (* Records *) let label_of_kind kind = if kind = "record" then "field" else "constructor" -module NameChoice (Name : sig +module Name_choice (Name : sig type t val type_kind : string val get_name : t -> string @@ -954,7 +954,7 @@ let wrap_disambiguate kind ty f x = with Error (loc, env, Wrong_name ("", _, tk, tp, name, valid_names)) -> raise (Error (loc, env, Wrong_name (kind, ty, tk, tp, name, valid_names))) -module Label = NameChoice (struct +module Label = Name_choice (struct type t = label_description let type_kind = "record" let get_name lbl = lbl.lbl_name @@ -1147,7 +1147,7 @@ let check_recordpat_labels ~get_jsx_component_error_info loc lbl_pat_list closed (* Constructors *) -module Constructor = NameChoice (struct +module Constructor = Name_choice (struct type t = constructor_description let type_kind = "variant" let get_name cstr = cstr.cstr_name diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 0f44d4595f4..4c73d9a3caf 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -195,7 +195,7 @@ let set_fixed_row env loc p decl = (* Translate one type declaration *) -module StringSet = Set.Make (struct +module String_set = Set.Make (struct type t = string let compare (x : t) y = compare x y end) @@ -463,12 +463,12 @@ let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id = pcd_args = rewrite_optional_inline_record_fields pcd_args; }) in - let all_constrs = ref StringSet.empty in + let all_constrs = ref String_set.empty in List.iter (fun {pcd_name = {txt = name}} -> - if StringSet.mem name !all_constrs then + if String_set.mem name !all_constrs then raise (Error (sdecl.ptype_loc, Duplicate_constructor name)); - all_constrs := StringSet.add name !all_constrs) + all_constrs := String_set.add name !all_constrs) scstrs; let copy_tag_attr_from_decl attr = let tag_attrs = @@ -639,14 +639,14 @@ let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id = | [] -> () | lbl :: rest -> let name = lbl.ld_id.name in - if StringSet.mem name seen then + if String_set.mem name seen then raise (Error (loc, Duplicate_label (name, Some sdecl.ptype_name.txt))); - check_duplicates loc rest (StringSet.add name seen) + check_duplicates loc rest (String_set.add name seen) in match lbls_opt with | Some (lbls, lbls') -> - check_duplicates sdecl.ptype_loc lbls StringSet.empty; + check_duplicates sdecl.ptype_loc lbls String_set.empty; let optional = Ext_list.exists lbls (fun lbl -> lbl.ld_optional) in ( Ttype_record lbls, Type_record @@ -761,14 +761,14 @@ let generalize_decl decl = (* Check that all constraints are enforced *) -module TypeSet = Btype.TypeSet -module TypeMap = Btype.TypeMap +module Type_set = Btype.Type_set +module Type_map = Btype.Type_map let rec check_constraints_rec env loc visited ty = let ty = Ctype.repr ty in - if TypeSet.mem ty !visited then () + if Type_set.mem ty !visited then () else ( - visited := TypeSet.add ty !visited; + visited := Type_set.add ty !visited; match ty.desc with | Tconstr (path, args, _) -> let args' = List.map (fun _ -> Ctype.newvar ()) args in @@ -784,7 +784,7 @@ let rec check_constraints_rec env loc visited ty = check_constraints_rec env loc visited ty | _ -> Btype.iter_type_expr (check_constraints_rec env loc visited) ty) -module SMap = Map.Make (String) +module S_map = Map.Make (String) let check_constraints_labels env visited l pl = let rec get_loc name = function @@ -798,7 +798,7 @@ let check_constraints_labels env visited l pl = l let check_constraints ~type_record_as_object env sdecl (_, decl) = - let visited = ref TypeSet.empty in + let visited = ref Type_set.empty in (match decl.type_kind with | Type_abstract -> () | Type_variant l -> @@ -808,13 +808,13 @@ let check_constraints ~type_record_as_object env sdecl (_, decl) = in let pl = find_pl sdecl.ptype_kind in let pl_index = - let foldf acc x = SMap.add x.pcd_name.txt x acc in - List.fold_left foldf SMap.empty pl + let foldf acc x = S_map.add x.pcd_name.txt x acc in + List.fold_left foldf S_map.empty pl in List.iter (fun {Types.cd_id = name; cd_args; cd_res} -> let {pcd_args; pcd_res; _} = - try SMap.find (Ident.name name) pl_index + try S_map.find (Ident.name name) pl_index with Not_found -> assert false in (match (cd_args, pcd_args) with @@ -892,10 +892,10 @@ let check_abbrev env sdecl (id, decl) = (* Check that recursion is well-founded *) let check_well_founded env loc path to_check ty = - let visited = ref TypeMap.empty in + let visited = ref Type_map.empty in let rec check ty0 parents ty = let ty = Btype.repr ty in - if TypeSet.mem ty parents then + if Type_set.mem ty parents then (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) if match ty0.desc with @@ -905,9 +905,9 @@ let check_well_founded env loc path to_check ty = else raise (Error (loc, Cycle_in_def (Path.name path, ty0))); let fini, parents = try - let prev = TypeMap.find ty !visited in - if TypeSet.subset parents prev then (true, parents) - else (false, TypeSet.union parents prev) + let prev = Type_map.find ty !visited in + if Type_set.subset parents prev then (true, parents) + else (false, Type_set.union parents prev) with Not_found -> (false, parents) in if fini then () @@ -919,12 +919,12 @@ let check_well_founded env loc path to_check ty = | Tobject _ | Tvariant _ -> true | _ -> false (* !Clflags.recursive_types*) in - let visited' = TypeMap.add ty parents !visited in + let visited' = Type_map.add ty parents !visited in let arg_exn = try visited := visited'; let parents = - if rec_ok then TypeSet.empty else TypeSet.add ty parents + if rec_ok then Type_set.empty else Type_set.add ty parents in Btype.iter_type_expr (check ty0 parents) ty; None @@ -935,16 +935,16 @@ let check_well_founded env loc path to_check ty = match ty.desc with | Tconstr (p, _, _) when arg_exn <> None || to_check p -> ( if to_check p then may raise arg_exn - else Btype.iter_type_expr (check ty0 TypeSet.empty) ty; + else Btype.iter_type_expr (check ty0 Type_set.empty) ty; try let ty' = Ctype.try_expand_once_opt env ty in - let ty0 = if TypeSet.is_empty parents then ty else ty0 in - check ty0 (TypeSet.add ty parents) ty' + let ty0 = if Type_set.is_empty parents then ty else ty0 in + check ty0 (Type_set.add ty parents) ty' with Ctype.Cannot_expand -> may raise arg_exn) | _ -> may raise arg_exn in let snap = Btype.snapshot () in - try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty + try Ctype.wrap_trace_gadt_instances env (check ty Type_set.empty) ty with Ctype.Unify _ -> (* Will be detected by check_recursion *) Btype.backtrack snap @@ -1035,7 +1035,7 @@ let check_abbrev_recursion env id_loc_list to_check tdecl = (* Compute variance *) let get_variance ty visited = - try TypeMap.find ty !visited with Not_found -> Variance.null + try Type_map.find ty !visited with Not_found -> Variance.null let compute_variance env visited vari ty = let rec compute_variance_rec vari ty = @@ -1045,7 +1045,7 @@ let compute_variance env visited vari ty = if Variance.subset vari vari' then () else let vari = Variance.union vari vari' in - visited := TypeMap.add ty vari !visited; + visited := Type_map.add ty vari !visited; let compute_same = compute_variance_rec vari in match ty.desc with | Tarrow (arg, ret, _, _) -> @@ -1134,7 +1134,7 @@ let compute_variance_type env check (required, loc) decl tyl = in (* Prepare *) let params = List.map Btype.repr decl.type_params in - let tvl = ref TypeMap.empty in + let tvl = ref Type_map.empty in (* Compute occurrences in the body *) let open Variance in List.iter @@ -1160,7 +1160,7 @@ let compute_variance_type env check (required, loc) decl tyl = (* If there are no extra variables there is nothing to do *) if fvl = [] then () else - let tvl2 = ref TypeMap.empty in + let tvl2 = ref Type_map.empty in List.iter2 (fun ty (p, n, _) -> if Btype.is_Tvar ty then () @@ -1170,17 +1170,17 @@ let compute_variance_type env check (required, loc) decl tyl = in compute_variance env tvl2 v ty) params required; - let visited = ref TypeSet.empty in + let visited = ref Type_set.empty in let rec check ty = let ty = Ctype.repr ty in - if TypeSet.mem ty !visited then () + if Type_set.mem ty !visited then () else - let visited' = TypeSet.add ty !visited in + let visited' = Type_set.add ty !visited in visited := visited'; let v1 = get_variance ty tvl in let snap = Btype.snapshot () in let v2 = - TypeMap.fold + Type_map.fold (fun t vt v -> if Ctype.equal env false [ty] [t] then union vt v else v) !tvl2 null diff --git a/compiler/ml/typedtreeIter.ml b/compiler/ml/typedtree_iter.ml similarity index 99% rename from compiler/ml/typedtreeIter.ml rename to compiler/ml/typedtree_iter.ml index 72c24352b98..6f48bcd620a 100644 --- a/compiler/ml/typedtreeIter.ml +++ b/compiler/ml/typedtree_iter.ml @@ -68,7 +68,7 @@ module type IteratorArgument = sig val leave_type_declarations : rec_flag -> unit end -module MakeIterator (Iter : IteratorArgument) : sig +module Make_iterator (Iter : IteratorArgument) : sig val iter_structure : structure -> unit val iter_signature : signature -> unit val iter_structure_item : structure_item -> unit @@ -404,7 +404,7 @@ end = struct | OTtag (_, _, ct) | OTinherit ct -> iter_core_type ct end -module DefaultIteratorArgument = struct +module Default_iterator_argument = struct let enter_structure _ = () let enter_value_description _ = () let enter_type_extension _ = () diff --git a/compiler/ml/typedtreeIter.mli b/compiler/ml/typedtree_iter.mli similarity index 96% rename from compiler/ml/typedtreeIter.mli rename to compiler/ml/typedtree_iter.mli index 17adaa67f5f..df070ca05bc 100644 --- a/compiler/ml/typedtreeIter.mli +++ b/compiler/ml/typedtree_iter.mli @@ -60,7 +60,7 @@ module type IteratorArgument = sig val leave_type_declarations : rec_flag -> unit end -module MakeIterator : functor (Iter : IteratorArgument) -> sig +module Make_iterator : functor (Iter : IteratorArgument) -> sig val iter_structure : structure -> unit val iter_signature : signature -> unit val iter_structure_item : structure_item -> unit @@ -71,4 +71,4 @@ module MakeIterator : functor (Iter : IteratorArgument) -> sig end [@@warning "-67"] -module DefaultIteratorArgument : IteratorArgument +module Default_iterator_argument : IteratorArgument diff --git a/compiler/ml/typemod.ml b/compiler/ml/typemod.ml index 0932c62f347..ac1ae9f30ca 100644 --- a/compiler/ml/typemod.ml +++ b/compiler/ml/typemod.ml @@ -603,7 +603,7 @@ let check_recmod_typedecls env sdecls decls = (* Auxiliaries for checking uniqueness of names in signatures and structures *) -module StringSet = Set.Make (struct +module String_set = Set.Make (struct type t = string let compare (x : t) y = String.compare x y end) @@ -649,12 +649,12 @@ let check_sig_item names loc = function let simplify_signature sg = let rec aux = function - | [] -> ([], StringSet.empty) + | [] -> ([], String_set.empty) | (Sig_value (id, _descr) as component) :: sg -> let ((sg, val_names) as k) = aux sg in let name = Ident.name id in - if StringSet.mem name val_names then k - else (component :: sg, StringSet.add name val_names) + if String_set.mem name val_names then k + else (component :: sg, String_set.add name val_names) | component :: sg -> let sg, val_names = aux sg in (component :: sg, val_names) diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index eeca29aa837..9f443f3c5ff 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -63,7 +63,7 @@ and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent and commutable = Cok | Cunknown | Clink of commutable ref -module TypeOps = struct +module Type_ops = struct type t = type_expr let compare t1 t2 = t1.id - t2.id let hash t = t.id @@ -72,11 +72,11 @@ end (* Maps of methods and instance variables *) -module OrderedString = struct +module Ordered_string = struct type t = string let compare (x : t) y = compare x y end -module Meths = Map.Make (OrderedString) +module Meths = Map.Make (Ordered_string) module Vars = Meths (* Value descriptions *) @@ -206,7 +206,7 @@ type extension_constructor = { (* Type expressions for the class language *) -module Concr = Set.Make (OrderedString) +module Concr = Set.Make (Ordered_string) (* Type expressions for the module language *) diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index cb9bf066641..598030ff12e 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -204,7 +204,7 @@ and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent *) and commutable = Cok | Cunknown | Clink of commutable ref -module TypeOps : sig +module Type_ops : sig type t = type_expr val compare : t -> t -> int val equal : t -> t -> bool diff --git a/compiler/syntax/cli/res_cli.ml b/compiler/syntax/cli/res_cli.ml index 201a3ac31e1..17234927076 100644 --- a/compiler/syntax/cli/res_cli.ml +++ b/compiler/syntax/cli/res_cli.ml @@ -155,7 +155,7 @@ module Color = struct end (* command line flags *) -module ResClflags : sig +module Res_clflags : sig val recover : bool ref val print : string ref val width : int ref @@ -221,7 +221,7 @@ end = struct let parse () = Arg.parse spec (fun f -> file := f) usage end -module CliArgProcessor = struct +module Cli_arg_processor = struct type backend = Parser : 'diagnostics Res_driver.parsing_engine -> backend [@@unboxed] @@ -317,11 +317,11 @@ end let () = if not !Sys.interactive then ( - ResClflags.parse (); - CliArgProcessor.process_file ~is_interface:!ResClflags.interface - ~width:!ResClflags.width ~recover:!ResClflags.recover - ~target:!ResClflags.print ~jsx_version:!ResClflags.jsx_version - ~jsx_module:!ResClflags.jsx_module ~typechecker:!ResClflags.typechecker - !ResClflags.file - ~test_ast_conversion:!ResClflags.test_ast_conversion) + Res_clflags.parse (); + Cli_arg_processor.process_file ~is_interface:!Res_clflags.interface + ~width:!Res_clflags.width ~recover:!Res_clflags.recover + ~target:!Res_clflags.print ~jsx_version:!Res_clflags.jsx_version + ~jsx_module:!Res_clflags.jsx_module ~typechecker:!Res_clflags.typechecker + !Res_clflags.file + ~test_ast_conversion:!Res_clflags.test_ast_conversion) [@@raises exit] diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index 5b8e83bedb8..5cf7eaf37ca 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -1072,7 +1072,7 @@ let transform_signature_item ~config item = | _ -> [item] (* There appear to be slightly different rules of transformation whether the component is upper-, lowercase or a fragment *) -type componentDescription = +type component_description = | LowercasedComponent | UppercasedComponent | FragmentComponent @@ -1163,7 +1163,7 @@ let try_find_key_prop (props : jsx_props) : (arg_label * expression) option = | _ -> None) let append_children_prop (config : Jsx_common.jsx_config) mapper - (component_description : componentDescription) (props : jsx_props) + (component_description : component_description) (props : jsx_props) (children : jsx_children) : jsx_props = match children with | [] -> props @@ -1197,8 +1197,8 @@ let append_children_prop (config : Jsx_common.jsx_config) mapper let loc = match List.rev xs with | [] -> head.pexp_loc - | lastChild :: _ -> - {head.pexp_loc with loc_end = lastChild.pexp_loc.loc_end} + | last_child :: _ -> + {head.pexp_loc with loc_end = last_child.pexp_loc.loc_end} in (* this is a hack to support react components that introspect into their children *) props @@ -1212,7 +1212,7 @@ let append_children_prop (config : Jsx_common.jsx_config) mapper ] let mk_react_jsx (config : Jsx_common.jsx_config) mapper loc attrs - (component_description : componentDescription) (elementTag : expression) + (component_description : component_description) (element_tag : expression) (props : jsx_props) (children : jsx_children) : expression = let more_than_one_children = List.length children > 1 in let props_with_children = @@ -1251,7 +1251,7 @@ let mk_react_jsx (config : Jsx_common.jsx_config) mapper loc attrs }, [key_prop; (nolabel, unit_expr ~loc:Location.none)] ) in - let args = [(nolabel, elementTag); (nolabel, props_record)] @ key_and_unit in + let args = [(nolabel, element_tag); (nolabel, props_record)] @ key_and_unit in Exp.apply ~loc ~attrs ~transformed_jsx:true jsx_expr args (* In most situations, the component name is the make function from a module. diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index 8f8ebdb0bb7..ff5b1a42c1c 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -1,5 +1,5 @@ module Doc = Res_doc -module CommentTable = Res_comments_table +module Comment_table = Res_comments_table let print_engine = Res_driver. @@ -52,7 +52,7 @@ end = struct Doc.to_string ~width:80 doc end -module SexpAst = struct +module Sexp_ast = struct open Parsetree let map_empty ~f items = @@ -980,28 +980,28 @@ module SexpAst = struct } end -let sexp_print_engine = SexpAst.print_engine +let sexp_print_engine = Sexp_ast.print_engine let comments_print_engine = { Res_driver.print_implementation = (fun ~width:_ ~filename:_ ~comments s -> - let cmt_tbl = CommentTable.make () in - CommentTable.walk_structure s cmt_tbl comments; - CommentTable.log cmt_tbl); + let cmt_tbl = Comment_table.make () in + Comment_table.walk_structure s cmt_tbl comments; + Comment_table.log cmt_tbl); Res_driver.print_implementation_from_source = (fun ~width:_ ~source:_ ~comments s -> - let cmt_tbl = CommentTable.make () in - CommentTable.walk_structure s cmt_tbl comments; - CommentTable.log cmt_tbl); + let cmt_tbl = Comment_table.make () in + Comment_table.walk_structure s cmt_tbl comments; + Comment_table.log cmt_tbl); Res_driver.print_interface = (fun ~width:_ ~filename:_ ~comments s -> - let cmt_tbl = CommentTable.make () in - CommentTable.walk_signature s cmt_tbl comments; - CommentTable.log cmt_tbl); + let cmt_tbl = Comment_table.make () in + Comment_table.walk_signature s cmt_tbl comments; + Comment_table.log cmt_tbl); Res_driver.print_interface_from_source = (fun ~width:_ ~source:_ ~comments s -> - let cmt_tbl = CommentTable.make () in - CommentTable.walk_signature s cmt_tbl comments; - CommentTable.log cmt_tbl); + let cmt_tbl = Comment_table.make () in + Comment_table.walk_signature s cmt_tbl comments; + Comment_table.log cmt_tbl); } diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index a1cfd1c05a1..9741d3ece62 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -1,6 +1,6 @@ module Comment = Res_comment module Doc = Res_doc -module ParsetreeViewer = Res_parsetree_viewer +module Parsetree_viewer = Res_parsetree_viewer type t = { leading: (Location.t, Comment.t list) Hashtbl.t; @@ -513,7 +513,7 @@ let get_loc node = { case.pc_lhs.ppat_loc with loc_end = - (match ParsetreeViewer.process_braces_attr case.pc_rhs with + (match Parsetree_viewer.process_braces_attr case.pc_rhs with | None, _ -> case.pc_rhs.pexp_loc.loc_end | Some ({loc}, _), _ -> loc.Location.loc_end); } @@ -545,7 +545,7 @@ let get_loc node = | StructureItem si -> si.pstr_loc | TypeDeclaration td -> td.ptype_loc | ValueBinding vb -> vb.pvb_loc - | JsxProp prop -> ParsetreeViewer.get_jsx_prop_loc prop + | JsxProp prop -> Parsetree_viewer.get_jsx_prop_loc prop let rec walk_structure s t comments = match s with @@ -1622,8 +1622,8 @@ and walk_expression expr t comments = let comments = visit_list_but_continue_with_remaining_comments ~newline_delimited:false ~walk_node:walk_expr_parameter - ~get_loc:(fun (_attrs, argLbl, expr_opt, pattern) -> - let label_loc = Asttypes.get_lbl_loc argLbl in + ~get_loc:(fun (_attrs, arg_lbl, expr_opt, pattern) -> + let label_loc = Asttypes.get_lbl_loc arg_lbl in let open Parsetree in let start_pos = if label_loc <> Location.none then label_loc.loc_start @@ -1685,7 +1685,7 @@ and walk_expression expr t comments = jsx_unary_element_props = props; }) -> ( let closing_token_loc = - ParsetreeViewer.unary_element_closing_token expr.pexp_loc + Parsetree_viewer.unary_element_closing_token expr.pexp_loc in let after_opening_tag_name, rest = @@ -1693,7 +1693,7 @@ and walk_expression expr t comments = let next_token = match props with | [] -> closing_token_loc - | head :: _ -> ParsetreeViewer.get_jsx_prop_loc head + | head :: _ -> Parsetree_viewer.get_jsx_prop_loc head in let name_loc = tag_name.loc in partition_adjacent_trailing_before_next_token_on_same_line name_loc @@ -1739,7 +1739,7 @@ and walk_expression expr t comments = let next_token = match props with | [] -> opening_greater_than_loc - | head :: _ -> ParsetreeViewer.get_jsx_prop_loc head + | head :: _ -> Parsetree_viewer.get_jsx_prop_loc head in let name_loc = tag_name_start.loc in partition_adjacent_trailing_before_next_token_on_same_line name_loc @@ -1777,7 +1777,7 @@ and walk_expression expr t comments = | None -> (rest, []) | Some closing_tag -> let closing_tag_loc = - ParsetreeViewer.container_element_closing_tag_loc closing_tag + Parsetree_viewer.container_element_closing_tag_loc closing_tag in partition_leading_trailing rest closing_tag_loc in @@ -1790,7 +1790,7 @@ and walk_expression expr t comments = () | Some closing_tag -> let closing_tag_loc = - ParsetreeViewer.container_element_closing_tag_loc closing_tag + Parsetree_viewer.container_element_closing_tag_loc closing_tag in if opening_greater_than_loc.loc_end.pos_lnum diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 619f71e6929..b075b9ffa07 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -2,8 +2,8 @@ module Doc = Res_doc module Grammar = Res_grammar module Token = Res_token module Diagnostics = Res_diagnostics -module CommentTable = Res_comments_table -module ResPrinter = Res_printer +module Comment_table = Res_comments_table +module Res_printer = Res_printer module Scanner = Res_scanner module Parser = Res_parser @@ -118,7 +118,7 @@ module Recover = struct check p.breadcrumbs end -module ErrorMessages = struct +module Error_messages = struct let list_pattern_spread = "List pattern matches only supports one `...` spread, at the end.\n\ Explanation: a list spread at the tail is efficient, but a spread in the \ @@ -183,7 +183,7 @@ module ErrorMessages = struct [ Doc.hard_line; Doc.hard_line; - ResPrinter.print_expression switch_expr CommentTable.empty; + Res_printer.print_expression switch_expr Comment_table.empty; ]; ] |> Doc.to_string ~width:80 @@ -260,7 +260,7 @@ module ErrorMessages = struct "Spreading JSX children is no longer supported." end -module InExternal = struct +module In_external = struct let status = ref false end @@ -764,7 +764,7 @@ let parse_hash_ident ~start_pos p = match suffix with | Some _ -> Parser.err p - (Diagnostics.message (ErrorMessages.poly_var_int_with_suffix i)) + (Diagnostics.message (Error_messages.poly_var_int_with_suffix i)) | None -> () in Parser.next p; @@ -772,7 +772,7 @@ let parse_hash_ident ~start_pos p = | Eof -> Parser.err ~start_pos p (Diagnostics.unexpected p.token p.breadcrumbs); ("", mk_loc start_pos p.prev_end_pos) - | _ -> parse_ident ~start_pos ~msg:ErrorMessages.variant_ident p + | _ -> parse_ident ~start_pos ~msg:Error_messages.variant_ident p (* Ldot (Ldot (Lident "Foo", "Bar"), "baz") *) let parse_value_path p = @@ -1098,7 +1098,7 @@ let parse_template_constant ~prefix (p : Parser.t) = in skip_tokens (); Parser.err ~start_pos ~end_pos:p.prev_end_pos p - (Diagnostics.message ErrorMessages.string_interpolation_in_pattern); + (Diagnostics.message Error_messages.string_interpolation_in_pattern); Pconst_string ("", None) let parse_comma_delimited_region p ~grammar ~closing ~f = @@ -1342,7 +1342,7 @@ let rec parse_pattern ?(alias = true) ?(or_ = true) p = | Some _ -> Parser.err p (Diagnostics.message - (ErrorMessages.poly_var_int_with_suffix i)) + (Error_messages.poly_var_int_with_suffix i)) | None -> () in Parser.next p; @@ -1351,7 +1351,7 @@ let rec parse_pattern ?(alias = true) ?(or_ = true) p = Parser.err ~start_pos p (Diagnostics.unexpected p.token p.breadcrumbs); ("", mk_loc start_pos p.prev_end_pos) - | _ -> parse_ident ~msg:ErrorMessages.variant_ident ~start_pos p + | _ -> parse_ident ~msg:Error_messages.variant_ident ~start_pos p in match p.Parser.token with | Lparen -> parse_variant_pattern_args p ident start_pos attrs @@ -1501,7 +1501,7 @@ and parse_record_pattern_row_field ~attrs p = (pat, optional) | Equal -> Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p - (Diagnostics.message ErrorMessages.record_pattern_field_missing_colon); + (Diagnostics.message Error_messages.record_pattern_field_missing_colon); Parser.next p; let optional = parse_optional_label p in let pat = parse_pattern p in @@ -1536,7 +1536,7 @@ and parse_record_pattern_row p = if Token.is_keyword p.token then ( match recover_keyword_field_name_if_probably_field p - ~mk_message:ErrorMessages.keyword_field_in_pattern + ~mk_message:Error_messages.keyword_field_in_pattern with | Some (recovered_field_name, loc) -> Parser.expect Colon p; @@ -1548,7 +1548,7 @@ and parse_record_pattern_row p = Some (false, PatField {lid = field; x = pat; opt = optional}) | None -> emit_keyword_field_error p - ~mk_message:ErrorMessages.keyword_field_in_pattern; + ~mk_message:Error_messages.keyword_field_in_pattern; None) else None @@ -1574,7 +1574,7 @@ and parse_record_pattern ~attrs p = (if has_spread then let pattern = field.x in Parser.err ~start_pos:pattern.Parsetree.ppat_loc.loc_start p - (Diagnostics.message ErrorMessages.record_pattern_spread)); + (Diagnostics.message Error_messages.record_pattern_spread)); (field :: fields, flag) | PatUnderscore -> (fields, flag)) ([], flag) raw_fields @@ -1593,7 +1593,7 @@ and parse_tuple_pattern ~attrs ~first ~start_pos p = match patterns with | [_] -> Parser.err ~start_pos ~end_pos:p.prev_end_pos p - (Diagnostics.message ErrorMessages.tuple_single_element) + (Diagnostics.message Error_messages.tuple_single_element) | _ -> () in let loc = mk_loc start_pos p.prev_end_pos in @@ -1649,7 +1649,7 @@ and parse_list_pattern ~start_pos ~attrs p = let filter_spread (has_spread, pattern) = if has_spread then ( Parser.err ~start_pos:pattern.Parsetree.ppat_loc.loc_start p - (Diagnostics.message ErrorMessages.list_pattern_spread); + (Diagnostics.message Error_messages.list_pattern_spread); pattern) else pattern in @@ -1668,11 +1668,11 @@ and parse_dict_pattern_row p = | String s -> let loc = mk_loc p.start_pos p.end_pos in Parser.next p; - let fieldName = Location.mkloc (Longident.Lident s) loc in + let field_name = Location.mkloc (Longident.Lident s) loc in Parser.expect Colon p; let optional = parse_optional_label p in let pat = parse_pattern p in - Some {Parsetree.lid = fieldName; x = pat; opt = optional} + Some {Parsetree.lid = field_name; x = pat; opt = optional} | _ -> None and parse_dict_pattern ~start_pos ~attrs (p : Parser.t) = @@ -1692,7 +1692,7 @@ and parse_array_pattern ~attrs p = let patterns = parse_comma_delimited_region p ~grammar:Grammar.PatternList ~closing:Rbracket - ~f:(parse_non_spread_pattern ~msg:ErrorMessages.array_pattern_spread) + ~f:(parse_non_spread_pattern ~msg:Error_messages.array_pattern_spread) in Parser.expect Rbracket p; let loc = mk_loc start_pos p.prev_end_pos in @@ -1963,7 +1963,7 @@ and parse_parameter p = in Parser.err ~start_pos ~end_pos:p.prev_end_pos p (Diagnostics.message - (ErrorMessages.missing_tilde_labeled_parameter lbl_name)); + (Error_messages.missing_tilde_labeled_parameter lbl_name)); Asttypes.Optional {txt = lbl_name; loc = lbl_loc} | lbl -> lbl in @@ -2667,10 +2667,10 @@ and over_parse_constrained_or_coerced_or_arrow_expression p expr = [ Doc.line; Doc.text "1) "; - ResPrinter.print_expression arrow1 CommentTable.empty; + Res_printer.print_expression arrow1 Comment_table.empty; Doc.line; Doc.text "2) "; - ResPrinter.print_expression arrow2 CommentTable.empty; + Res_printer.print_expression arrow2 Comment_table.empty; ]); ]) |> Doc.to_string ~width:80 @@ -2695,9 +2695,9 @@ and over_parse_constrained_or_coerced_or_arrow_expression p expr = (Doc.concat [ Doc.line; - ResPrinter.add_parens - (ResPrinter.print_expression expr - CommentTable.empty); + Res_printer.add_parens + (Res_printer.print_expression expr + Comment_table.empty); ]); ]) |> Doc.to_string ~width:80)) @@ -2817,7 +2817,7 @@ and parse_let_bindings ~unwrap ~attrs ~start_pos p = let end_pos = p.Parser.start_pos in if rec_flag = Asttypes.Recursive && unwrap then Parser.err ~start_pos ~end_pos p - (Diagnostics.message ErrorMessages.experimental_let_unwrap_rec); + (Diagnostics.message Error_messages.experimental_let_unwrap_rec); let add_unwrap_attr ~unwrap ~start_pos ~end_pos attrs = if unwrap then ( {Asttypes.txt = "let.unwrap"; loc = mk_loc start_pos end_pos}, @@ -2874,7 +2874,7 @@ and parse_jsx_opening_or_self_closing_element (* start of the opening < *) let children = parse_jsx_children p in let closing_tag_start = match p.token with - | LessThan when Scanner.peekSlash p.scanner -> + | LessThan when Scanner.peek_slash p.scanner -> let pos = p.start_pos in (* Move to slash *) Parser.next p; @@ -3083,7 +3083,7 @@ and parse_jsx_children p : Parsetree.jsx_children = let rec loop p children = match p.Parser.token with | Token.Eof -> children - | LessThan when Scanner.peekSlash p.scanner -> children + | LessThan when Scanner.peek_slash p.scanner -> children | LessThan -> (* Imagine:
< * is `<` the start of a jsx-child?
Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p - (Diagnostics.message ErrorMessages.spread_children_no_longer_supported); + (Diagnostics.message Error_messages.spread_children_no_longer_supported); Parser.next p; [parse_primary_expr ~operand:(parse_atomic_expr p) ~no_call:true p] | _ -> List.rev (loop p []) @@ -3128,7 +3128,7 @@ and parse_braced_or_record_expr p = | token when Token.is_keyword token -> ( match recover_keyword_field_name_if_probably_field p - ~mk_message:ErrorMessages.keyword_field_in_expr + ~mk_message:Error_messages.keyword_field_in_expr with | Some (recovered_field_name, loc) -> Parser.expect Colon p; @@ -3177,7 +3177,7 @@ and parse_braced_or_record_expr p = expr | Equal -> Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p - (Diagnostics.message ErrorMessages.record_field_missing_colon); + (Diagnostics.message Error_messages.record_field_missing_colon); Parser.next p; let field_expr = parse_expr p in Parser.optional p Comma |> ignore; @@ -3283,7 +3283,7 @@ and parse_braced_or_record_expr p = expr) | Equal -> ( Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p - (Diagnostics.message ErrorMessages.record_field_missing_colon); + (Diagnostics.message Error_messages.record_field_missing_colon); Parser.next p; let optional = parse_optional_label p in let field_expr = parse_expr p in @@ -3447,7 +3447,7 @@ and parse_record_expr_row_with_string_key p : Some {lid = field; x = field_expr; opt = false} | Equal -> Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p - (Diagnostics.message ErrorMessages.record_field_missing_colon); + (Diagnostics.message Error_messages.record_field_missing_colon); Parser.next p; let field_expr = parse_expr p in Some {lid = field; x = field_expr; opt = false} @@ -3466,7 +3466,7 @@ and parse_record_expr_row p : let () = match p.Parser.token with | Token.DotDotDot -> - Parser.err p (Diagnostics.message ErrorMessages.record_expr_spread); + Parser.err p (Diagnostics.message Error_messages.record_expr_spread); Parser.next p | _ -> () in @@ -3482,7 +3482,7 @@ and parse_record_expr_row p : Some {lid = field; x = field_expr; opt = optional} | Equal -> Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p - (Diagnostics.message ErrorMessages.record_field_missing_colon); + (Diagnostics.message Error_messages.record_field_missing_colon); Parser.next p; let optional = parse_optional_label p in let field_expr = parse_expr p in @@ -3513,7 +3513,7 @@ and parse_record_expr_row p : if Token.is_keyword p.token then ( match recover_keyword_field_name_if_probably_field p - ~mk_message:ErrorMessages.keyword_field_in_expr + ~mk_message:Error_messages.keyword_field_in_expr with | Some (recovered_field_name, loc) -> Parser.expect Colon p; @@ -3525,7 +3525,7 @@ and parse_record_expr_row p : Some {lid = field; x = field_expr; opt = optional} | None -> emit_keyword_field_error p - ~mk_message:ErrorMessages.keyword_field_in_expr; + ~mk_message:Error_messages.keyword_field_in_expr; None) else None @@ -3546,7 +3546,7 @@ and parse_dict_expr_part p = Some (`Row (field, field_expr)) | Equal -> Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p - (Diagnostics.message ErrorMessages.dict_field_missing_colon); + (Diagnostics.message Error_messages.dict_field_missing_colon); Parser.next p; let field_expr = parse_expr p in Some (`Row (field, field_expr)) @@ -3664,7 +3664,7 @@ and parse_expr_block_item p = let _ = parse_type_definition_or_extension ~attrs p in Parser.end_region p; Parser.err ~start_pos:type_start ~end_pos:p.prev_end_pos p - (Diagnostics.message ErrorMessages.type_definition_in_function); + (Diagnostics.message Error_messages.type_definition_in_function); parse_newline_or_semicolon_expr_block p; parse_expr_block p | _ -> @@ -3831,7 +3831,7 @@ and parse_if_or_if_let_expression p = let if_let_expr = parse_if_let_expr start_pos p in Parser.err ~start_pos:if_let_expr.pexp_loc.loc_start ~end_pos:if_let_expr.pexp_loc.loc_end p - (Diagnostics.message (ErrorMessages.experimental_if_let if_let_expr)); + (Diagnostics.message (Error_messages.experimental_if_let if_let_expr)); if_let_expr | _ -> parse_if_expr start_pos p in @@ -4151,14 +4151,14 @@ and parse_argument2 p : argument option = | Question -> Parser.err ~start_pos:colon_start ~end_pos:colon_end p (Diagnostics.message - ErrorMessages.optional_labelled_argument_missing_equal); + Error_messages.optional_labelled_argument_missing_equal); Parser.next p; let expr = parse_constrained_or_coerced_expr p in (Asttypes.Optional {txt = ident; loc = named_arg_loc}, expr) | _ -> Parser.err ~start_pos:colon_start ~end_pos:colon_end p (Diagnostics.message - ErrorMessages.labelled_argument_missing_equal); + Error_messages.labelled_argument_missing_equal); let expr = match p.Parser.token with | Underscore @@ -4350,7 +4350,7 @@ and parse_tuple_expr ~first ~start_pos p = match exprs with | [_] -> Parser.err ~start_pos ~end_pos:p.prev_end_pos p - (Diagnostics.message ErrorMessages.tuple_single_element) + (Diagnostics.message Error_messages.tuple_single_element) | _ -> () in let loc = mk_loc start_pos p.prev_end_pos in @@ -4422,13 +4422,13 @@ and parse_dict_expr ~start_pos p = let to_key_value_pair (record_item : Longident.t Location.loc * Parsetree.expression) = match record_item with - | ( {Location.txt = Longident.Lident key; loc = keyLoc}, + | ( {Location.txt = Longident.Lident key; loc = key_loc}, ({pexp_loc = value_loc} as value_expr) ) -> Some (Ast_helper.Exp.tuple - ~loc:(mk_loc keyLoc.loc_start value_loc.loc_end) + ~loc:(mk_loc key_loc.loc_start value_loc.loc_end) [ - Ast_helper.Exp.constant ~loc:keyLoc (Pconst_string (key, None)); + Ast_helper.Exp.constant ~loc:key_loc (Pconst_string (key, None)); value_expr; ]) | _ -> None @@ -4595,7 +4595,7 @@ and parse_type_var_list p = | SingleQuote -> Parser.next p; let lident, loc = - parse_ident ~msg:ErrorMessages.type_param ~start_pos:p.start_pos p + parse_ident ~msg:Error_messages.type_param ~start_pos:p.start_pos p in let var = Location.mkloc lident loc in loop p (var :: vars) @@ -4627,7 +4627,7 @@ and parse_atomic_typ_expr ?current_type_name_path ?inline_types_context ~attrs p Parser.err ~start_pos:p.start_pos p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); ("", mk_loc p.start_pos p.prev_end_pos)) - else parse_ident ~msg:ErrorMessages.type_var ~start_pos:p.start_pos p + else parse_ident ~msg:Error_messages.type_var ~start_pos:p.start_pos p in maybe_track_inline_type_param inline_types_context ident loc; Ast_helper.Typ.var ~loc ~attrs ident @@ -4681,7 +4681,7 @@ and parse_atomic_typ_expr ?current_type_name_path ?inline_types_context ~attrs p if number_of_inline_records_in_args > 1 then Parser.err ~start_pos ~end_pos:p.prev_end_pos p (Diagnostics.message - ErrorMessages.multiple_inline_record_definitions_at_same_path); + Error_messages.multiple_inline_record_definitions_at_same_path); Ast_helper.Typ.constr ~loc:(mk_loc start_pos p.prev_end_pos) ~attrs constr args @@ -4805,7 +4805,8 @@ and parse_record_or_object_type ?current_type_name_path ?inline_types_context match p.token with | Lident _ -> Parser.err p - (Diagnostics.message ErrorMessages.forbidden_inline_record_declaration) + (Diagnostics.message + Error_messages.forbidden_inline_record_declaration) | _ -> () in let fields = @@ -4823,7 +4824,7 @@ and parse_type_alias p typ = Parser.next p; Parser.expect SingleQuote p; let ident, _loc = - parse_ident ~msg:ErrorMessages.type_param ~start_pos:p.start_pos p + parse_ident ~msg:Error_messages.type_param ~start_pos:p.start_pos p in (* TODO: how do we parse attributes here? *) Ast_helper.Typ.alias @@ -4887,7 +4888,7 @@ and parse_type_parameter ?current_type_name_path ?inline_types_context let () = let error = Diagnostics.message - (ErrorMessages.missing_tilde_labeled_parameter name) + (Error_messages.missing_tilde_labeled_parameter name) in Parser.err ~start_pos:loc.loc_start ~end_pos:loc.loc_end p error in @@ -5034,7 +5035,7 @@ and parse_es6_arrow_type ?current_type_name_path ?inline_types_context ~attrs p let has_as = Ext_list.exists typ.ptyp_attributes (fun (x, _) -> x.txt = "as") in - if !InExternal.status && typ_is_any && has_as then arity - 1 + if !In_external.status && typ_is_any && has_as then arity - 1 else arity | _ -> arity in @@ -5166,7 +5167,7 @@ and parse_tuple_type ~attrs ~first ~start_pos p = match typexprs with | [_] -> Parser.err ~start_pos ~end_pos:p.prev_end_pos p - (Diagnostics.message ErrorMessages.tuple_single_element) + (Diagnostics.message Error_messages.tuple_single_element) | _ -> () in let tuple_loc = mk_loc start_pos p.prev_end_pos in @@ -5213,7 +5214,7 @@ and parse_type_constructor_args ?inline_types_context ?current_type_name_path (Doc.concat [ Doc.line; - ResPrinter.print_typ_expr typ CommentTable.empty; + Res_printer.print_typ_expr typ Comment_table.empty; ]); ]) |> Doc.to_string ~width:80 @@ -5241,7 +5242,7 @@ and parse_string_field_declaration p = | Colon -> Parser.next p | Equal -> Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p - (Diagnostics.message ErrorMessages.record_type_field_missing_colon); + (Diagnostics.message Error_messages.record_type_field_missing_colon); Parser.next p | _ -> Parser.expect ~grammar:Grammar.TypeExpression Colon p); let typ = parse_poly_type_expr p in @@ -5253,14 +5254,14 @@ and parse_string_field_declaration p = | Lident name -> let name_loc = mk_loc p.start_pos p.end_pos in Parser.err p - (Diagnostics.message (ErrorMessages.object_quoted_field_name name)); + (Diagnostics.message (Error_messages.object_quoted_field_name name)); Parser.next p; let field_name = Location.mkloc name name_loc in (match p.Parser.token with | Colon -> Parser.next p | Equal -> Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p - (Diagnostics.message ErrorMessages.record_type_field_missing_colon); + (Diagnostics.message Error_messages.record_type_field_missing_colon); Parser.next p | _ -> Parser.expect ~grammar:Grammar.TypeExpression Colon p); let typ = parse_poly_type_expr p in @@ -5293,7 +5294,7 @@ and parse_field_declaration ?current_type_name_path ?inline_types_context p = parse_poly_type_expr ?current_type_name_path ?inline_types_context p | Equal -> Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p - (Diagnostics.message ErrorMessages.record_type_field_missing_colon); + (Diagnostics.message Error_messages.record_type_field_missing_colon); Parser.next p; let current_type_name_path = extend_current_type_name_path current_type_name_path name.txt @@ -5342,7 +5343,7 @@ and parse_field_declaration_region ?current_type_name_path ?inline_types_context parse_poly_type_expr ?current_type_name_path ?inline_types_context p | Equal -> Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p - (Diagnostics.message ErrorMessages.record_type_field_missing_colon); + (Diagnostics.message Error_messages.record_type_field_missing_colon); Parser.next p; parse_poly_type_expr ?current_type_name_path ?inline_types_context p | _ -> @@ -5356,7 +5357,7 @@ and parse_field_declaration_region ?current_type_name_path ?inline_types_context if Token.is_keyword p.token then ( match recover_keyword_field_name_if_probably_field p - ~mk_message:ErrorMessages.keyword_field_in_type + ~mk_message:Error_messages.keyword_field_in_type with | Some (recovered_field_name, name_loc) -> let optional = parse_optional_label p in @@ -5369,7 +5370,7 @@ and parse_field_declaration_region ?current_type_name_path ?inline_types_context Some (Ast_helper.Type.field ~attrs ~loc ~mut ~optional name typ) | None -> emit_keyword_field_error p - ~mk_message:ErrorMessages.keyword_field_in_type; + ~mk_message:Error_messages.keyword_field_in_type; None) else ( if attrs <> [] then @@ -5767,7 +5768,7 @@ and parse_type_param p = Parser.err ~start_pos:p.start_pos p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); ("", mk_loc p.start_pos p.prev_end_pos)) - else parse_ident ~msg:ErrorMessages.type_param ~start_pos:p.start_pos p + else parse_ident ~msg:Error_messages.type_param ~start_pos:p.start_pos p in Some (Ast_helper.Typ.var ~loc ident, variance) | Underscore -> @@ -5779,7 +5780,7 @@ and parse_type_param p = (Diagnostics.message ("Type params start with a singlequote: '" ^ Token.to_string token)); let ident, loc = - parse_ident ~msg:ErrorMessages.type_param ~start_pos:p.start_pos p + parse_ident ~msg:Error_messages.type_param ~start_pos:p.start_pos p in Some (Ast_helper.Typ.var ~loc ident, variance) | _token -> None @@ -5818,9 +5819,9 @@ and parse_type_params ~parent p = Doc.line; Doc.concat [ - ResPrinter.print_longident parent.Location.txt; - ResPrinter.print_type_params params - CommentTable.empty; + Res_printer.print_longident parent.Location.txt; + Res_printer.print_type_params params + Comment_table.empty; ]; ]); ]) @@ -6554,7 +6555,7 @@ and parse_type_definition_or_extension ~attrs p = | Lident _ -> () | longident -> Parser.err ~start_pos:name.loc.loc_start ~end_pos:name.loc.loc_end p - (longident |> ErrorMessages.type_declaration_name_longident + (longident |> Error_messages.type_declaration_name_longident |> Diagnostics.message) in let current_type_name_path = Longident.flatten name.txt in @@ -6582,13 +6583,13 @@ and parse_type_definition_or_extension ~attrs p = (* external value-name : typexp = external-declaration *) and parse_external_def ~attrs ~start_pos p = - let in_external = !InExternal.status in - InExternal.status := true; + let in_external = !In_external.status in + In_external.status := true; Parser.leave_breadcrumb p Grammar.External; Fun.protect ~finally:(fun () -> Parser.eat_breadcrumb p; - InExternal.status := in_external) + In_external.status := in_external) (fun () -> Parser.expect Token.External p; let name, loc = parse_lident p in @@ -6790,7 +6791,7 @@ and parse_structure_item_region pending_structure_items p = match attrs with | (({Asttypes.loc = attr_loc}, _) as attr) :: _ -> Parser.err ~start_pos:attr_loc.loc_start ~end_pos:attr_loc.loc_end p - (Diagnostics.message (ErrorMessages.attribute_without_node attr)); + (Diagnostics.message (Error_messages.attribute_without_node attr)); let expr = parse_expr p in Some (Ast_helper.Str.eval @@ -7358,7 +7359,7 @@ and parse_signature_item_region pending_signature_items p = | Let {unwrap} -> if unwrap then ( Parser.err ~start_pos ~end_pos:p.Parser.end_pos p - (Diagnostics.message ErrorMessages.experimental_let_unwrap_sig); + (Diagnostics.message Error_messages.experimental_let_unwrap_sig); Parser.next p); Parser.begin_region p; let value_desc = parse_sign_let_desc ~attrs p in @@ -7463,7 +7464,7 @@ and parse_signature_item_region pending_signature_items p = match attrs with | (({Asttypes.loc = attr_loc}, _) as attr) :: _ -> Parser.err ~start_pos:attr_loc.loc_start ~end_pos:attr_loc.loc_end p - (Diagnostics.message (ErrorMessages.attribute_without_node attr)); + (Diagnostics.message (Error_messages.attribute_without_node attr)); Some Recover.default_signature_item | _ -> None)) [@@progress Parser.next, Parser.expect] diff --git a/compiler/syntax/src/res_doc.ml b/compiler/syntax/src/res_doc.ml index 301c0520bd6..b56c2bee202 100644 --- a/compiler/syntax/src/res_doc.ml +++ b/compiler/syntax/src/res_doc.ml @@ -1,4 +1,4 @@ -module MiniBuffer = Res_minibuffer +module Mini_buffer = Res_minibuffer type mode = Break | Flat @@ -188,7 +188,7 @@ let fits w stack = let to_string ~width doc = propagate_forced_breaks doc; - let buffer = MiniBuffer.create 1000 in + let buffer = Mini_buffer.create 1000 in let rec process ~pos line_suffices stack = match stack with @@ -196,7 +196,7 @@ let to_string ~width doc = match doc with | Nil | BreakParent -> process ~pos line_suffices rest | Text txt -> - MiniBuffer.add_string buffer txt; + Mini_buffer.add_string buffer txt; process ~pos:(String.length txt + pos) line_suffices rest | LineSuffix doc -> process ~pos ((ind, mode, doc) :: line_suffices) rest | Concat docs -> @@ -214,11 +214,12 @@ let to_string ~width doc = match line_suffices with | [] -> if line_style = Literal then ( - MiniBuffer.add_char buffer '\n'; + Mini_buffer.add_char buffer '\n'; process ~pos:0 [] rest) else ( - MiniBuffer.flush_newline buffer; - MiniBuffer.add_string buffer (String.make ind ' ' [@doesNotRaise]); + Mini_buffer.flush_newline buffer; + Mini_buffer.add_string buffer + (String.make ind ' ' [@doesNotRaise]); process ~pos:ind [] rest) | _docs -> process ~pos:ind [] @@ -228,13 +229,13 @@ let to_string ~width doc = let pos = match line_style with | Classic -> - MiniBuffer.add_string buffer " "; + Mini_buffer.add_string buffer " "; pos + 1 | Hard -> - MiniBuffer.flush_newline buffer; + Mini_buffer.flush_newline buffer; 0 | Literal -> - MiniBuffer.add_char buffer '\n'; + Mini_buffer.add_char buffer '\n'; 0 | Soft -> pos in @@ -260,7 +261,7 @@ let to_string ~width doc = | suffices -> process ~pos:0 [] (List.rev suffices)) in process ~pos:0 [] [(0, Flat, doc)]; - MiniBuffer.contents buffer + Mini_buffer.contents buffer let debug t = let rec to_doc = function diff --git a/compiler/syntax/src/res_parens.ml b/compiler/syntax/src/res_parens.ml index 09bfa4196c5..49e6c298624 100644 --- a/compiler/syntax/src/res_parens.ml +++ b/compiler/syntax/src/res_parens.ml @@ -1,8 +1,8 @@ -module ParsetreeViewer = Res_parsetree_viewer +module Parsetree_viewer = Res_parsetree_viewer type kind = Parenthesized | Braced of Location.t | Nothing let expr expr = - let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + let opt_braces, _ = Parsetree_viewer.process_braces_attr expr in match opt_braces with | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | _ -> ( @@ -21,24 +21,24 @@ let expr_record_row_rhs ~optional e = | Nothing when optional -> ( match e.pexp_desc with | Pexp_ifthenelse _ | Pexp_fun _ -> Parenthesized - | _ when ParsetreeViewer.is_binary_expression e -> Parenthesized + | _ when Parsetree_viewer.is_binary_expression e -> Parenthesized | _ -> kind) | _ -> kind let call_expr expr = - let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + let opt_braces, _ = Parsetree_viewer.process_braces_attr expr in match opt_braces with | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | _ -> ( match expr with | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filter_parsing_attrs attrs with + when match Parsetree_viewer.filter_parsing_attrs attrs with | _ :: _ -> true | [] -> false -> Parenthesized | _ - when ParsetreeViewer.is_unary_expression expr - || ParsetreeViewer.is_binary_expression expr -> + when Parsetree_viewer.is_unary_expression expr + || Parsetree_viewer.is_binary_expression expr -> Parenthesized | { Parsetree.pexp_desc = @@ -46,7 +46,7 @@ let call_expr expr = } -> Nothing | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.is_underscore_apply_sugar expr -> + when Parsetree_viewer.is_underscore_apply_sugar expr -> Nothing | { pexp_desc = @@ -56,17 +56,17 @@ let call_expr expr = } -> Parenthesized | _ when Ast_uncurried.expr_is_uncurried_fun expr -> Parenthesized - | _ when ParsetreeViewer.expr_is_await expr -> Parenthesized + | _ when Parsetree_viewer.expr_is_await expr -> Parenthesized | _ -> Nothing) let structure_expr expr = - let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + let opt_braces, _ = Parsetree_viewer.process_braces_attr expr in match opt_braces with | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( match expr with | {pexp_desc = Pexp_jsx_element _} -> Nothing - | _ when ParsetreeViewer.has_attributes expr.pexp_attributes -> + | _ when Parsetree_viewer.has_attributes expr.pexp_attributes -> Parenthesized | { Parsetree.pexp_desc = @@ -77,19 +77,19 @@ let structure_expr expr = | _ -> Nothing) let unary_expr_operand expr = - let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + let opt_braces, _ = Parsetree_viewer.process_braces_attr expr in match opt_braces with | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( match expr with | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filter_parsing_attrs attrs with + when match Parsetree_viewer.filter_parsing_attrs attrs with | _ :: _ -> true | [] -> false -> Parenthesized | expr - when ParsetreeViewer.is_unary_expression expr - || ParsetreeViewer.is_binary_expression expr -> + when Parsetree_viewer.is_unary_expression expr + || Parsetree_viewer.is_binary_expression expr -> Parenthesized | { pexp_desc = @@ -97,7 +97,7 @@ let unary_expr_operand expr = } -> Nothing | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.is_underscore_apply_sugar expr -> + when Parsetree_viewer.is_underscore_apply_sugar expr -> Nothing | { pexp_desc = @@ -107,11 +107,11 @@ let unary_expr_operand expr = | Pexp_for_await_of _ | Pexp_ifthenelse _ ); } -> Parenthesized - | _ when ParsetreeViewer.expr_is_await expr -> Parenthesized + | _ when Parsetree_viewer.expr_is_await expr -> Parenthesized | _ -> Nothing) let binary_expr_operand ~is_lhs expr = - let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + let opt_braces, _ = Parsetree_viewer.process_braces_attr expr in match opt_braces with | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( @@ -122,21 +122,21 @@ let binary_expr_operand ~is_lhs expr = } -> Nothing | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.is_underscore_apply_sugar expr -> + when Parsetree_viewer.is_underscore_apply_sugar expr -> Nothing | {pexp_desc = Pexp_constraint _ | Pexp_fun _ | Pexp_newtype _} -> Parenthesized | _ when Ast_uncurried.expr_is_uncurried_fun expr -> Parenthesized - | expr when ParsetreeViewer.is_binary_expression expr -> Parenthesized - | expr when ParsetreeViewer.is_ternary_expr expr -> Parenthesized + | expr when Parsetree_viewer.is_binary_expression expr -> Parenthesized + | expr when Parsetree_viewer.is_ternary_expr expr -> Parenthesized | {pexp_desc = Pexp_assert _} when is_lhs -> Parenthesized - | _ when ParsetreeViewer.expr_is_await expr -> Parenthesized + | _ when Parsetree_viewer.expr_is_await expr -> Parenthesized | {Parsetree.pexp_attributes = attrs} -> - if ParsetreeViewer.has_printable_attributes attrs then Parenthesized + if Parsetree_viewer.has_printable_attributes attrs then Parenthesized else Nothing) let sub_binary_expr_operand parent_operator child_operator = - let open ParsetreeViewer in + let open Parsetree_viewer in let prec_parent = operator_precedence parent_operator in let prec_child = operator_precedence child_operator in prec_parent > prec_child @@ -158,9 +158,9 @@ let rhs_binary_expr_operand parent_operator rhs = }; args = [(_, _left); (_, _right)]; } - when ParsetreeViewer.not_ghost_operator operator operator_loc -> - let prec_parent = ParsetreeViewer.operator_precedence parent_operator in - let prec_child = ParsetreeViewer.operator_precedence operator in + when Parsetree_viewer.not_ghost_operator operator operator_loc -> + let prec_parent = Parsetree_viewer.operator_precedence parent_operator in + let prec_child = Parsetree_viewer.operator_precedence operator in prec_parent == prec_child | _ -> false @@ -175,29 +175,29 @@ let flatten_operand_rhs parent_operator rhs = }; args = [(_, _left); (_, _right)]; } - when ParsetreeViewer.not_ghost_operator operator operator_loc -> - let prec_parent = ParsetreeViewer.operator_precedence parent_operator in - let prec_child = ParsetreeViewer.operator_precedence operator in + when Parsetree_viewer.not_ghost_operator operator operator_loc -> + let prec_parent = Parsetree_viewer.operator_precedence parent_operator in + let prec_child = Parsetree_viewer.operator_precedence operator in prec_parent >= prec_child || rhs.pexp_attributes <> [] | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> false | Pexp_fun {lhs = {ppat_desc = Ppat_var {txt = "__x"}}} -> false | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_constraint _ -> true - | _ when ParsetreeViewer.is_ternary_expr rhs -> true + | _ when Parsetree_viewer.is_ternary_expr rhs -> true | _ -> false let binary_operator_inside_await_needs_parens operator = - ParsetreeViewer.operator_precedence operator - < ParsetreeViewer.operator_precedence "->" + Parsetree_viewer.operator_precedence operator + < Parsetree_viewer.operator_precedence "->" let assert_or_await_expr_rhs ?(in_await = false) expr = - let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + let opt_braces, _ = Parsetree_viewer.process_braces_attr expr in match opt_braces with | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( match expr with | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filter_parsing_attrs attrs with + when match Parsetree_viewer.filter_parsing_attrs attrs with | _ :: _ -> true | [] -> false -> Parenthesized @@ -206,7 +206,7 @@ let assert_or_await_expr_rhs ?(in_await = false) expr = Pexp_apply {funct = {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}}; } - when ParsetreeViewer.is_binary_expression expr -> + when Parsetree_viewer.is_binary_expression expr -> if in_await && not (binary_operator_inside_await_needs_parens operator) then Nothing else Parenthesized @@ -216,7 +216,7 @@ let assert_or_await_expr_rhs ?(in_await = false) expr = } -> Nothing | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.is_underscore_apply_sugar expr -> + when Parsetree_viewer.is_underscore_apply_sugar expr -> Nothing | { pexp_desc = @@ -225,7 +225,7 @@ let assert_or_await_expr_rhs ?(in_await = false) expr = | Pexp_for_of _ | Pexp_for_await_of _ | Pexp_ifthenelse _ ); } -> Parenthesized - | _ when (not in_await) && ParsetreeViewer.expr_is_await expr -> + | _ when (not in_await) && Parsetree_viewer.expr_is_await expr -> Parenthesized | _ -> Nothing) @@ -240,19 +240,19 @@ let is_negative_constant constant = | _ -> false let field_expr expr = - let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + let opt_braces, _ = Parsetree_viewer.process_braces_attr expr in match opt_braces with | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( match expr with | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filter_parsing_attrs attrs with + when match Parsetree_viewer.filter_parsing_attrs attrs with | _ :: _ -> true | [] -> false -> Parenthesized | expr - when ParsetreeViewer.is_binary_expression expr - || ParsetreeViewer.is_unary_expression expr -> + when Parsetree_viewer.is_binary_expression expr + || Parsetree_viewer.is_unary_expression expr -> Parenthesized | { pexp_desc = @@ -261,7 +261,7 @@ let field_expr expr = Nothing | {pexp_desc = Pexp_constant c} when is_negative_constant c -> Parenthesized | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.is_underscore_apply_sugar expr -> + when Parsetree_viewer.is_underscore_apply_sugar expr -> Nothing | { pexp_desc = @@ -271,11 +271,11 @@ let field_expr expr = | Pexp_for_await_of _ | Pexp_ifthenelse _ ); } -> Parenthesized - | _ when ParsetreeViewer.expr_is_await expr -> Parenthesized + | _ when Parsetree_viewer.expr_is_await expr -> Parenthesized | _ -> Nothing) let set_field_expr_rhs expr = - let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + let opt_braces, _ = Parsetree_viewer.process_braces_attr expr in match opt_braces with | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( @@ -289,7 +289,7 @@ let set_field_expr_rhs expr = | _ -> Nothing) let ternary_operand expr = - let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + let opt_braces, _ = Parsetree_viewer.process_braces_attr expr in match opt_braces with | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( @@ -301,7 +301,7 @@ let ternary_operand expr = Nothing | {pexp_desc = Pexp_constraint _} -> Parenthesized | _ when Res_parsetree_viewer.is_fun_newtype expr -> ( - let _, _parameters, return_expr = ParsetreeViewer.fun_expr expr in + let _, _parameters, return_expr = Parsetree_viewer.fun_expr expr in match return_expr.pexp_desc with | Pexp_constraint _ -> Parenthesized | _ -> Nothing) @@ -320,7 +320,7 @@ let jsx_prop_expr expr = | Pexp_letmodule _ | Pexp_open _ -> Nothing | _ -> ( - let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + let opt_braces, _ = Parsetree_viewer.process_braces_attr expr in match opt_braces with | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( @@ -332,7 +332,7 @@ let jsx_prop_expr expr = } when starts_with_minus x -> Parenthesized - | _ when ParsetreeViewer.expr_is_await expr -> Parenthesized + | _ when Parsetree_viewer.expr_is_await expr -> Parenthesized | { Parsetree.pexp_desc = ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ @@ -357,7 +357,7 @@ let jsx_child_expr expr = | Pexp_letmodule _ | Pexp_open _ -> Nothing | _ -> ( - let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + let opt_braces, _ = Parsetree_viewer.process_braces_attr expr in match opt_braces with | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | _ -> ( @@ -369,7 +369,7 @@ let jsx_child_expr expr = } when starts_with_minus x -> Parenthesized - | _ when ParsetreeViewer.expr_is_await expr -> Parenthesized + | _ when Parsetree_viewer.expr_is_await expr -> Parenthesized | { Parsetree.pexp_desc = ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ @@ -390,13 +390,13 @@ let jsx_child_expr expr = | _ -> Parenthesized)) let binary_expr expr = - let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + let opt_braces, _ = Parsetree_viewer.process_braces_attr expr in match opt_braces with | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( match expr with | {Parsetree.pexp_attributes = _ :: _} as expr - when ParsetreeViewer.is_binary_expression expr -> + when Parsetree_viewer.is_binary_expression expr -> Parenthesized | _ -> Nothing) diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 020aff850ba..1e9a3f5a735 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -1,9 +1,9 @@ module Doc = Res_doc -module CommentTable = Res_comments_table +module Comment_table = Res_comments_table module Comment = Res_comment module Token = Res_token module Parens = Res_parens -module ParsetreeViewer = Res_parsetree_viewer +module Parsetree_viewer = Res_parsetree_viewer let default_print_width = 100 @@ -48,7 +48,7 @@ let has_inline_type_definitions type_declarations = |> Option.is_some let get_first_leading_comment tbl loc = - match Hashtbl.find tbl.CommentTable.leading loc with + match Hashtbl.find tbl.Comment_table.leading loc with | comment :: _ -> Some comment | [] -> None | exception Not_found -> None @@ -60,23 +60,23 @@ let has_leading_line_comment tbl loc = | None -> false let get_leading_line_comment_count tbl loc = - match Hashtbl.find_opt tbl.CommentTable.leading loc with + match Hashtbl.find_opt tbl.Comment_table.leading loc with | Some comments -> List.filter Comment.is_single_line_comment comments |> List.length | None -> 0 let has_trailing_single_line_comment tbl loc = - match Hashtbl.find_opt tbl.CommentTable.trailing loc with + match Hashtbl.find_opt tbl.Comment_table.trailing loc with | Some (comment :: _) -> Comment.is_single_line_comment comment | _ -> false let has_any_trailing_line_comment tbl loc = - match Hashtbl.find_opt tbl.CommentTable.trailing loc with + match Hashtbl.find_opt tbl.Comment_table.trailing loc with | Some comments -> List.exists Comment.is_single_line_comment comments | None -> false let has_comment_below tbl loc = - match Hashtbl.find tbl.CommentTable.trailing loc with + match Hashtbl.find tbl.Comment_table.trailing loc with | comment :: _ -> let comment_loc = Comment.loc comment in comment_loc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum @@ -84,17 +84,17 @@ let has_comment_below tbl loc = | exception Not_found -> false let has_comments_inside tbl loc = - match Hashtbl.find_opt tbl.CommentTable.inside loc with + match Hashtbl.find_opt tbl.Comment_table.inside loc with | None -> false | _ -> true let has_trailing_comments tbl loc = - match Hashtbl.find_opt tbl.CommentTable.trailing loc with + match Hashtbl.find_opt tbl.Comment_table.trailing loc with | None -> false | _ -> true let has_leading_comments tbl loc = - match Hashtbl.find_opt tbl.CommentTable.leading loc with + match Hashtbl.find_opt tbl.Comment_table.leading loc with | None -> false | _ -> true @@ -241,7 +241,7 @@ let print_comments_inside cmt_tbl loc = let cmt_doc = Doc.concat [print_comment comment; Doc.line] in loop (cmt_doc :: acc) rest in - match Hashtbl.find cmt_tbl.CommentTable.inside loc with + match Hashtbl.find cmt_tbl.Comment_table.inside loc with | exception Not_found -> Doc.nil | comments -> Hashtbl.remove cmt_tbl.inside loc; @@ -262,7 +262,7 @@ let print_comments_inside_file cmt_tbl = let cmt_doc = print_leading_comment ~next_comment comment in loop (cmt_doc :: acc) rest in - match Hashtbl.find cmt_tbl.CommentTable.inside Location.none with + match Hashtbl.find cmt_tbl.Comment_table.inside Location.none with | exception Not_found -> Doc.nil | comments -> Hashtbl.remove cmt_tbl.inside Location.none; @@ -320,7 +320,7 @@ let print_trailing_comments node tbl loc = let cmts_doc = loop loc [] comments in Doc.concat [node; cmts_doc] -let print_comments doc (tbl : CommentTable.t) loc = +let print_comments doc (tbl : Comment_table.t) loc = let doc_with_leading_comments = print_leading_comments doc tbl.leading loc in print_trailing_comments doc_with_leading_comments tbl.trailing loc @@ -776,7 +776,7 @@ and print_module_binding ~state ~is_rec module_binding cmt_tbl i = match module_binding.pmb_expr with | {pmod_desc = Pmod_constraint (mod_expr, mod_type)} when not - (ParsetreeViewer.has_await_attribute + (Parsetree_viewer.has_await_attribute module_binding.pmb_expr.pmod_attributes) -> ( print_mod_expr ~state mod_expr cmt_tbl, Doc.concat [Doc.text ": "; print_mod_type ~state mod_type cmt_tbl] ) @@ -861,7 +861,7 @@ and print_mod_type ~state mod_type cmt_tbl = print_attributes ~state mod_type.pmty_attributes cmt_tbl; signature_doc; ] | Pmty_functor _ -> - let parameters, return_type = ParsetreeViewer.functor_type mod_type in + let parameters, return_type = Parsetree_viewer.functor_type mod_type in let parameters_doc = match parameters with | [] -> Doc.nil @@ -1011,7 +1011,8 @@ and print_with_constraint ~state (with_constraint : Parsetree.with_constraint) Doc.group (print_type_declaration ~state ~name:(print_lident_path longident cmt_tbl) - ~equal_sign:"=" ~rec_flag:Doc.nil 0 type_declaration CommentTable.empty) + ~equal_sign:"=" ~rec_flag:Doc.nil 0 type_declaration + Comment_table.empty) (* with module X.Y = Z *) | Pwith_module ({txt = longident1}, {txt = longident2}) -> Doc.concat @@ -1027,7 +1028,7 @@ and print_with_constraint ~state (with_constraint : Parsetree.with_constraint) (print_type_declaration ~state ~name:(print_lident_path longident cmt_tbl) ~equal_sign:":=" ~rec_flag:Doc.nil 0 type_declaration - CommentTable.empty) + Comment_table.empty) | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> Doc.concat [ @@ -1544,9 +1545,9 @@ and print_type_definition_constraint ~state Doc.concat [ Doc.text "constraint "; - print_typ_expr ~state typ1 CommentTable.empty; + print_typ_expr ~state typ1 Comment_table.empty; Doc.text " = "; - print_typ_expr ~state typ2 CommentTable.empty; + print_typ_expr ~state typ2 Comment_table.empty; ] and print_private_flag (flag : Asttypes.private_flag) = @@ -1689,7 +1690,7 @@ and print_literal_dict_expr ~state (e : Parsetree.expression) cmt_tbl = and print_spread_dict_expr ~state parts (expr : Parsetree.expression) cmt_tbl = let print_spread_part spread_expr = let leading_comments_doc = - print_leading_comments Doc.nil cmt_tbl.CommentTable.leading + print_leading_comments Doc.nil cmt_tbl.Comment_table.leading spread_expr.Parsetree.pexp_loc in let spread_doc = @@ -1700,7 +1701,7 @@ and print_spread_dict_expr ~state parts (expr : Parsetree.expression) cmt_tbl = | Nothing -> doc in let spread_with_trailing_comments = - print_trailing_comments spread_doc cmt_tbl.CommentTable.trailing + print_trailing_comments spread_doc cmt_tbl.Comment_table.trailing spread_expr.Parsetree.pexp_loc in Doc.concat @@ -1711,10 +1712,10 @@ and print_spread_dict_expr ~state parts (expr : Parsetree.expression) cmt_tbl = ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map (function - | ParsetreeViewer.DictExprRows rows_expr -> + | Parsetree_viewer.DictExprRows rows_expr -> print_literal_dict_rows ~state ~leading_line:false ~trailing_comma:false rows_expr cmt_tbl - | ParsetreeViewer.DictExprSpread spread_expr -> + | Parsetree_viewer.DictExprSpread spread_expr -> print_spread_part spread_expr) parts) in @@ -1765,7 +1766,7 @@ and print_constructor_declarations ~state ~private_flag and print_constructor_declaration2 ~state i (cd : Parsetree.constructor_declaration) cmt_tbl = let comment_attrs, attrs = - ParsetreeViewer.partition_doc_comment_attributes cd.pcd_attributes + Parsetree_viewer.partition_doc_comment_attributes cd.pcd_attributes in let comment_doc = match comment_attrs with @@ -1898,7 +1899,7 @@ and print_typ_expr ?inline_record_definitions ~(state : State.t) | None -> max_int in let attrs_before, args, return_type = - ParsetreeViewer.arrow_type ~max_arity typ_expr + Parsetree_viewer.arrow_type ~max_arity typ_expr in let return_type_needs_parens = match return_type.ptyp_desc with @@ -2094,7 +2095,7 @@ and print_typ_expr ?inline_record_definitions ~(state : State.t) let print_row_field i = function | Parsetree.Rtag ({txt; loc}, attrs, true, []) -> let comment_attrs, attrs = - ParsetreeViewer.partition_doc_comment_attributes attrs + Parsetree_viewer.partition_doc_comment_attributes attrs in let comment_doc = match comment_attrs with @@ -2117,7 +2118,7 @@ and print_typ_expr ?inline_record_definitions ~(state : State.t) Doc.concat [comment_doc; bar; print_comments tag_doc cmt_tbl loc] | Rtag ({txt; loc}, attrs, truth, types) -> let comment_attrs, attrs = - ParsetreeViewer.partition_doc_comment_attributes attrs + Parsetree_viewer.partition_doc_comment_attributes attrs in let comment_doc = match comment_attrs with @@ -2210,7 +2211,7 @@ and print_typ_expr ?inline_record_definitions ~(state : State.t) match typ_expr.ptyp_attributes with | _ :: _ as attrs when not should_print_its_own_attributes -> let doc_comment_attr, attrs = - ParsetreeViewer.partition_doc_comment_attributes attrs + Parsetree_viewer.partition_doc_comment_attributes attrs in let comment_doc = match doc_comment_attr with @@ -2373,7 +2374,7 @@ and print_value_binding ~state ~rec_flag (vb : Parsetree.value_binding) cmt_tbl }; pvb_expr = {pexp_desc = Pexp_newtype _} as expr; } -> ( - let _, parameters, return_expr = ParsetreeViewer.fun_expr expr in + let _, parameters, return_expr = Parsetree_viewer.fun_expr expr in let abstract_type = match parameters with | [NewTypes {locs = vars}] -> @@ -2438,7 +2439,7 @@ and print_value_binding ~state ~rec_flag (vb : Parsetree.value_binding) cmt_tbl ]); ])) | _ -> - let opt_braces, expr = ParsetreeViewer.process_braces_attr vb.pvb_expr in + let opt_braces, expr = Parsetree_viewer.process_braces_attr vb.pvb_expr in let printed_expr = let doc = print_expression_with_comments ~state vb.pvb_expr cmt_tbl in match Parens.expr vb.pvb_expr with @@ -2467,7 +2468,7 @@ and print_value_binding ~state ~rec_flag (vb : Parsetree.value_binding) cmt_tbl * ->Belt.Array.map(...) * Multiple pipes chained together lend themselves more towards the last layout. *) - if ParsetreeViewer.is_single_pipe_expr vb.pvb_expr then + if Parsetree_viewer.is_single_pipe_expr vb.pvb_expr then Doc.custom_layout [ Doc.group @@ -2488,22 +2489,22 @@ and print_value_binding ~state ~rec_flag (vb : Parsetree.value_binding) cmt_tbl match opt_braces with | Some _ -> false | _ -> ( - ParsetreeViewer.is_binary_expression expr + Parsetree_viewer.is_binary_expression expr || match vb.pvb_expr with | { pexp_attributes = [({Location.txt = "res.ternary"}, _)]; pexp_desc = Pexp_ifthenelse (if_expr, _, _); } -> - ParsetreeViewer.is_binary_expression if_expr - || ParsetreeViewer.has_attributes if_expr.pexp_attributes + Parsetree_viewer.is_binary_expression if_expr + || Parsetree_viewer.has_attributes if_expr.pexp_attributes | {pexp_desc = Pexp_newtype _} -> false | {pexp_attributes = [({Location.txt = "res.taggedTemplate"}, _)]} -> false | {pexp_desc = Pexp_jsx_element _} -> true | e -> - ParsetreeViewer.has_attributes e.pexp_attributes - || ParsetreeViewer.is_array_access e) + Parsetree_viewer.has_attributes e.pexp_attributes + || Parsetree_viewer.is_array_access e) in Doc.group (Doc.concat @@ -2592,7 +2593,7 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = | Ppat_var var -> print_ident_like var.txt | Ppat_constant c -> let template_literal = - ParsetreeViewer.has_template_literal_attr p.ppat_attributes + Parsetree_viewer.has_template_literal_attr p.ppat_attributes in print_constant ~template_literal c | Ppat_tuple patterns -> @@ -2644,12 +2645,12 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = [Doc.text "list{"; print_comments_inside cmt_tbl p.ppat_loc; Doc.rbrace] | Ppat_construct ({txt = Longident.Lident "::"}, _) -> let patterns, tail = - ParsetreeViewer.collect_patterns_from_list_construct [] p + Parsetree_viewer.collect_patterns_from_list_construct [] p in let should_hug = match (patterns, tail) with | [pat], {ppat_desc = Ppat_construct ({txt = Longident.Lident "[]"}, _)} - when ParsetreeViewer.is_huggable_pattern pat -> + when Parsetree_viewer.is_huggable_pattern pat -> true | _ -> false in @@ -2721,7 +2722,7 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = ] | Some arg -> let arg_doc = print_pattern ~state arg cmt_tbl in - let should_hug = ParsetreeViewer.is_huggable_pattern arg in + let should_hug = Parsetree_viewer.is_huggable_pattern arg in Doc.concat [ Doc.lparen; @@ -2774,7 +2775,7 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = ] | Some arg -> let arg_doc = print_pattern ~state arg cmt_tbl in - let should_hug = ParsetreeViewer.is_huggable_pattern arg in + let should_hug = Parsetree_viewer.is_huggable_pattern arg in Doc.concat [ Doc.lparen; @@ -2791,13 +2792,13 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = in Doc.group (Doc.concat [variant_name; args_doc]) | Ppat_type ident - when ParsetreeViewer.has_res_pat_variant_spread_attribute + when Parsetree_viewer.has_res_pat_variant_spread_attribute p.ppat_attributes -> Doc.concat [Doc.text "..."; print_ident_path ident cmt_tbl] | Ppat_type ident -> Doc.concat [Doc.text "#..."; print_ident_path ident cmt_tbl] | Ppat_record (rows, _) - when ParsetreeViewer.has_dict_pattern_attribute p.ppat_attributes -> + when Parsetree_viewer.has_dict_pattern_attribute p.ppat_attributes -> Doc.concat [ Doc.text "dict{"; @@ -2852,7 +2853,7 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = Doc.group (Doc.concat [Doc.text "exception"; Doc.line; pat]) | Ppat_or _ -> (* Blue | Red | Green -> [Blue; Red; Green] *) - let or_chain = ParsetreeViewer.collect_or_pattern_chain p in + let or_chain = Parsetree_viewer.collect_or_pattern_chain p in let docs = List.mapi (fun i pat -> @@ -2967,7 +2968,7 @@ and print_pattern_record_row ~state row cmt_tbl = [ print_lident_path longident cmt_tbl; Doc.text ":"; - (if ParsetreeViewer.is_huggable_pattern pattern then + (if Parsetree_viewer.is_huggable_pattern pattern then Doc.concat [Doc.space; rhs_doc] else Doc.indent (Doc.concat [Doc.line; rhs_doc])); ]) @@ -2996,7 +2997,7 @@ and print_pattern_dict_row ~state [ lbl_doc; Doc.text ":"; - (if ParsetreeViewer.is_huggable_pattern pattern then + (if Parsetree_viewer.is_huggable_pattern pattern then Doc.concat [Doc.space; rhs_doc] else Doc.indent (Doc.concat [Doc.line; rhs_doc])); ]) @@ -3015,9 +3016,9 @@ and print_if_chain ~state pexp_attributes ifs else_expr cmt_tbl = let if_txt = if i > 0 then Doc.text "else if " else Doc.text "if " in let doc = match if_expr with - | ParsetreeViewer.If if_expr -> + | Parsetree_viewer.If if_expr -> let condition = - if ParsetreeViewer.is_block_expr if_expr then + if Parsetree_viewer.is_block_expr if_expr then print_expression_block ~state ~braces:true if_expr cmt_tbl else let doc = @@ -3034,7 +3035,7 @@ and print_if_chain ~state pexp_attributes ifs else_expr cmt_tbl = Doc.group condition; Doc.space; (let then_expr = - match ParsetreeViewer.process_braces_attr then_expr with + match Parsetree_viewer.process_braces_attr then_expr with (* This case only happens when coming from Reason, we strip braces *) | Some _, expr -> expr | _ -> then_expr @@ -3075,12 +3076,14 @@ and print_if_chain ~state pexp_attributes ifs else_expr cmt_tbl = print_expression_block ~state ~braces:true expr cmt_tbl; ] in - let attrs = ParsetreeViewer.filter_fragile_match_attributes pexp_attributes in + let attrs = + Parsetree_viewer.filter_fragile_match_attributes pexp_attributes + in Doc.concat [print_attributes ~state attrs cmt_tbl; if_docs; else_doc] and print_expression ~state (e : Parsetree.expression) cmt_tbl = let print_arrow e = - let async, parameters, return_expr = ParsetreeViewer.fun_expr e in + let async, parameters, return_expr = Parsetree_viewer.fun_expr e in let attrs_on_arrow = e.pexp_attributes in let return_expr, typ_constraint = match return_expr.pexp_desc with @@ -3103,7 +3106,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = ~has_constraint parameters cmt_tbl in let return_expr_doc = - let opt_braces, _ = ParsetreeViewer.process_braces_attr return_expr in + let opt_braces, _ = Parsetree_viewer.process_braces_attr return_expr in let should_inline = match (return_expr.pexp_desc, opt_braces) with | _, Some _ -> true @@ -3167,11 +3170,13 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = } -> (* (__x) => f(a, __x, c) -----> f(a, _, c) *) print_expression_with_comments ~state - (ParsetreeViewer.rewrite_underscore_apply e) + (Parsetree_viewer.rewrite_underscore_apply e) cmt_tbl | Pexp_fun _ | Pexp_newtype _ -> print_arrow e | Parsetree.Pexp_constant c -> - print_constant ~template_literal:(ParsetreeViewer.is_template_literal e) c + print_constant + ~template_literal:(Parsetree_viewer.is_template_literal e) + c | Pexp_jsx_element (Jsx_fragment { @@ -3203,7 +3208,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = Doc.concat [Doc.text "list{"; print_comments_inside cmt_tbl e.pexp_loc; Doc.rbrace] | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - let expressions, spread = ParsetreeViewer.collect_list_expressions e in + let expressions, spread = Parsetree_viewer.collect_list_expressions e in let spread_doc = match spread with | Some expr -> @@ -3299,7 +3304,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = | Braced braces -> print_braces doc arg braces | Nothing -> doc in - let should_hug = ParsetreeViewer.is_huggable_expression arg in + let should_hug = Parsetree_viewer.is_huggable_expression arg in Doc.concat [ Doc.lparen; @@ -3426,7 +3431,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = | Braced braces -> print_braces doc arg braces | Nothing -> doc in - let should_hug = ParsetreeViewer.is_huggable_expression arg in + let should_hug = Parsetree_viewer.is_huggable_expression arg in Doc.concat [ Doc.lparen; @@ -3563,20 +3568,20 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = print_extension ~state ~at_module_lvl:false extension cmt_tbl) | Pexp_apply {funct = e; args = [(Nolabel, {pexp_desc = Pexp_array sub_lists})]} - when ParsetreeViewer.is_spread_belt_array_concat e -> + when Parsetree_viewer.is_spread_belt_array_concat e -> print_belt_array_concat_apply ~state sub_lists cmt_tbl | Pexp_apply {funct = e; args = [(Nolabel, {pexp_desc = Pexp_array sub_lists})]} - when ParsetreeViewer.is_spread_belt_list_concat e -> + when Parsetree_viewer.is_spread_belt_list_concat e -> print_belt_list_concat_apply ~state sub_lists cmt_tbl | Pexp_apply {funct = call_expr; args} -> - if ParsetreeViewer.is_unary_expression e then + if Parsetree_viewer.is_unary_expression e then print_unary_expression ~state e cmt_tbl - else if ParsetreeViewer.is_template_literal e then + else if Parsetree_viewer.is_template_literal e then print_template_literal ~state e cmt_tbl - else if ParsetreeViewer.is_tagged_template_literal e then + else if Parsetree_viewer.is_tagged_template_literal e then print_tagged_template_literal ~state call_expr args cmt_tbl - else if ParsetreeViewer.is_binary_expression e then + else if Parsetree_viewer.is_binary_expression e then print_binary_expression ~state e cmt_tbl else print_pexp_apply ~state e cmt_tbl | Pexp_field (expr, longident_loc) -> @@ -3592,8 +3597,8 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = print_set_field_expr ~state e.pexp_attributes expr1 longident_loc expr2 e.pexp_loc cmt_tbl | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) - when ParsetreeViewer.is_ternary_expr e -> - let parts, alternate = ParsetreeViewer.collect_ternary_parts e in + when Parsetree_viewer.is_ternary_expr e -> + let parts, alternate = Parsetree_viewer.collect_ternary_parts e in let ternary_doc = match parts with | (condition1, consequent1) :: rest -> @@ -3634,9 +3639,11 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = ]) | _ -> Doc.nil in - let attrs = ParsetreeViewer.filter_ternary_attributes e.pexp_attributes in + let attrs = + Parsetree_viewer.filter_ternary_attributes e.pexp_attributes + in let needs_parens = - match ParsetreeViewer.filter_parsing_attrs attrs with + match Parsetree_viewer.filter_parsing_attrs attrs with | [] -> false | _ -> true in @@ -3646,7 +3653,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = (if needs_parens then add_parens ternary_doc else ternary_doc); ] | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> - let ifs, else_expr = ParsetreeViewer.collect_if_expressions e in + let ifs, else_expr = Parsetree_viewer.collect_if_expressions e in print_if_chain ~state e.pexp_attributes ifs else_expr cmt_tbl | Pexp_break -> Doc.text "break" | Pexp_continue -> Doc.text "continue" @@ -3662,7 +3669,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = (Doc.concat [ Doc.text "while "; - (if ParsetreeViewer.is_block_expr expr1 then condition + (if Parsetree_viewer.is_block_expr expr1 then condition else Doc.group (Doc.if_breaks (add_parens condition) condition)); Doc.space; print_expression_block ~state ~braces:true expr2 cmt_tbl; @@ -3792,8 +3799,8 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = Doc.text " catch "; print_cases ~state cases cmt_tbl; ] - | Pexp_match (_, [_; _]) when ParsetreeViewer.is_if_let_expr e -> - let ifs, else_expr = ParsetreeViewer.collect_if_expressions e in + | Pexp_match (_, [_; _]) when Parsetree_viewer.is_if_let_expr e -> + let ifs, else_expr = Parsetree_viewer.collect_if_expressions e in print_if_chain ~state e.pexp_attributes ifs else_expr cmt_tbl | Pexp_match (expr, cases) -> let expr_doc = @@ -3857,7 +3864,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = | Pexp_apply _ | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_ifthenelse _ -> true - | Pexp_match _ when ParsetreeViewer.is_if_let_expr e -> true + | Pexp_match _ when Parsetree_viewer.is_if_let_expr e -> true | Pexp_jsx_element _ -> true | _ -> false in @@ -3869,7 +3876,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = | _ -> printed_expression and print_pexp_fun ~state ~in_callback e cmt_tbl = - let async, parameters, return_expr = ParsetreeViewer.fun_expr e in + let async, parameters, return_expr = Parsetree_viewer.fun_expr e in let attrs_on_arrow = e.pexp_attributes in let return_expr, typ_constraint = match return_expr.pexp_desc with @@ -3898,7 +3905,7 @@ and print_pexp_fun ~state ~in_callback e cmt_tbl = | _ -> true in let return_expr_doc = - let opt_braces, _ = ParsetreeViewer.process_braces_attr return_expr in + let opt_braces, _ = Parsetree_viewer.process_braces_attr return_expr in let should_inline = match (return_expr.pexp_desc, opt_braces) with | _, Some _ -> true @@ -3965,7 +3972,7 @@ and print_set_field_expr ~state attrs lhs longident_loc rhs loc cmt_tbl = | Braced braces -> print_braces doc lhs braces | Nothing -> doc in - let should_indent = ParsetreeViewer.is_binary_expression rhs in + let should_indent = Parsetree_viewer.is_binary_expression rhs in let doc = Doc.group (Doc.concat @@ -4113,7 +4120,7 @@ and print_binary_expression ~state (expr : Parsetree.expression) cmt_tbl = in let print_operand ~is_lhs ~is_multiline expr parent_operator = let rec flatten ~is_lhs ~is_multiline expr parent_operator = - if ParsetreeViewer.is_binary_expression expr then + if Parsetree_viewer.is_binary_expression expr then match expr with | { pexp_desc = @@ -4124,15 +4131,15 @@ and print_binary_expression ~state (expr : Parsetree.expression) cmt_tbl = }; } -> if - ParsetreeViewer.flattenable_operators parent_operator operator - && not (ParsetreeViewer.has_attributes expr.pexp_attributes) + Parsetree_viewer.flattenable_operators parent_operator operator + && not (Parsetree_viewer.has_attributes expr.pexp_attributes) then let left_printed = flatten ~is_lhs:true ~is_multiline left operator in let right_printed = let right_printeable_attrs, right_internal_attrs = - ParsetreeViewer.partition_printable_attributes + Parsetree_viewer.partition_printable_attributes right.pexp_attributes in let doc = @@ -4154,7 +4161,7 @@ and print_binary_expression ~state (expr : Parsetree.expression) cmt_tbl = | _ -> add_parens doc in let doc = - if ParsetreeViewer.expr_is_await expr then + if Parsetree_viewer.expr_is_await expr then let parens = Res_parens.binary_operator_inside_await_needs_parens operator in @@ -4200,7 +4207,7 @@ and print_binary_expression ~state (expr : Parsetree.expression) cmt_tbl = print_comments doc cmt_tbl expr.pexp_loc else let printeable_attrs, internal_attrs = - ParsetreeViewer.partition_printable_attributes + Parsetree_viewer.partition_printable_attributes expr.pexp_attributes in let doc = @@ -4212,8 +4219,8 @@ and print_binary_expression ~state (expr : Parsetree.expression) cmt_tbl = if Parens.sub_binary_expr_operand parent_operator operator || printeable_attrs <> [] - && (ParsetreeViewer.is_binary_expression expr - || ParsetreeViewer.is_ternary_expr expr) + && (Parsetree_viewer.is_binary_expression expr + || Parsetree_viewer.is_ternary_expr expr) then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in @@ -4243,7 +4250,7 @@ and print_binary_expression ~state (expr : Parsetree.expression) cmt_tbl = let rhs_doc = print_expression_with_comments ~state rhs cmt_tbl in let lhs_doc = print_expression_with_comments ~state lhs cmt_tbl in (* TODO: unify indentation of "=" *) - let should_indent = ParsetreeViewer.is_binary_expression rhs in + let should_indent = Parsetree_viewer.is_binary_expression rhs in let doc = Doc.group (Doc.concat @@ -4279,15 +4286,15 @@ and print_binary_expression ~state (expr : Parsetree.expression) cmt_tbl = args = [(Nolabel, lhs); (Nolabel, rhs)]; } when not - (ParsetreeViewer.is_binary_expression lhs - || ParsetreeViewer.is_binary_expression rhs + (Parsetree_viewer.is_binary_expression lhs + || Parsetree_viewer.is_binary_expression rhs || print_attributes ~state expr.pexp_attributes cmt_tbl <> Doc.nil) -> let lhs_has_comment_below = has_comment_below cmt_tbl lhs.pexp_loc in let lhs_doc = print_operand ~is_lhs:true ~is_multiline:false lhs op in (* For pipe RHS, use pipe-specific rewrite to omit redundant first underscore *) let rhs = - if op = "->" then ParsetreeViewer.rewrite_underscore_apply_in_pipe rhs + if op = "->" then Parsetree_viewer.rewrite_underscore_apply_in_pipe rhs else rhs in let rhs_doc = print_operand ~is_lhs:false ~is_multiline:false rhs op in @@ -4315,18 +4322,18 @@ and print_binary_expression ~state (expr : Parsetree.expression) cmt_tbl = let operator_with_rhs = let rhs_doc = print_operand - ~is_lhs:(ParsetreeViewer.is_rhs_binary_operator operator) + ~is_lhs:(Parsetree_viewer.is_rhs_binary_operator operator) ~is_multiline rhs operator in Doc.concat [ print_binary_operator - ~inline_rhs:(ParsetreeViewer.should_inline_rhs_binary_expr rhs) + ~inline_rhs:(Parsetree_viewer.should_inline_rhs_binary_expr rhs) operator; rhs_doc; ] in - if ParsetreeViewer.should_indent_binary_expr expr then + if Parsetree_viewer.should_indent_binary_expr expr then Doc.group (Doc.indent operator_with_rhs) else operator_with_rhs in @@ -4335,7 +4342,7 @@ and print_binary_expression ~state (expr : Parsetree.expression) cmt_tbl = (Doc.concat [ print_operand - ~is_lhs:(not @@ ParsetreeViewer.is_rhs_binary_operator operator) + ~is_lhs:(not @@ Parsetree_viewer.is_rhs_binary_operator operator) ~is_multiline lhs operator; right; ]) @@ -4349,7 +4356,7 @@ and print_binary_expression ~state (expr : Parsetree.expression) cmt_tbl = { expr with pexp_attributes = - ParsetreeViewer.filter_printable_attributes + Parsetree_viewer.filter_printable_attributes expr.pexp_attributes; } with @@ -4364,7 +4371,7 @@ and print_belt_array_concat_apply ~state sub_lists cmt_tbl = | Some expr -> (* Extract leading comments before dotdotdot *) let leading_comments_doc = - print_leading_comments Doc.nil cmt_tbl.CommentTable.leading + print_leading_comments Doc.nil cmt_tbl.Comment_table.leading expr.Parsetree.pexp_loc in (* Print expression without leading comments (they're already extracted) *) @@ -4377,7 +4384,7 @@ and print_belt_array_concat_apply ~state sub_lists cmt_tbl = in (* Print trailing comments with the expression *) let expr_with_trailing_comments = - print_trailing_comments expr_doc cmt_tbl.CommentTable.trailing + print_trailing_comments expr_doc cmt_tbl.Comment_table.trailing expr.Parsetree.pexp_loc in Doc.concat @@ -4421,7 +4428,7 @@ and print_belt_array_concat_apply ~state sub_lists cmt_tbl = Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map make_sub_list_doc - (List.map ParsetreeViewer.collect_array_expressions + (List.map Parsetree_viewer.collect_array_expressions sub_lists)); ]); Doc.trailing_comma; @@ -4477,7 +4484,7 @@ and print_belt_list_concat_apply ~state sub_lists cmt_tbl = Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map make_sub_list_doc - (List.map ParsetreeViewer.collect_list_expressions + (List.map Parsetree_viewer.collect_list_expressions sub_lists)); ]); Doc.trailing_comma; @@ -4534,8 +4541,8 @@ and print_pexp_apply ~state expr cmt_tbl = in (* TODO: unify indentation of "=" *) let should_indent = - (not (ParsetreeViewer.is_braced_expr rhs)) - && ParsetreeViewer.is_binary_expression rhs + (not (Parsetree_viewer.is_braced_expr rhs)) + && Parsetree_viewer.is_binary_expression rhs in let doc = Doc.group @@ -4584,7 +4591,7 @@ and print_pexp_apply ~state expr cmt_tbl = }; args = [(Nolabel, parent_expr); (Nolabel, member_expr)]; } - when not (ParsetreeViewer.is_rewritten_underscore_apply_sugar parent_expr) + when not (Parsetree_viewer.is_rewritten_underscore_apply_sugar parent_expr) -> (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) let member = @@ -4653,21 +4660,21 @@ and print_pexp_apply ~state expr cmt_tbl = [Doc.indent (Doc.concat [Doc.soft_line; member_doc]); Doc.soft_line] in let should_indent_target_expr = - if ParsetreeViewer.is_braced_expr target_expr then false + if Parsetree_viewer.is_braced_expr target_expr then false else - ParsetreeViewer.is_binary_expression target_expr + Parsetree_viewer.is_binary_expression target_expr || match target_expr with | { pexp_attributes = [({Location.txt = "res.ternary"}, _)]; pexp_desc = Pexp_ifthenelse (if_expr, _, _); } -> - ParsetreeViewer.is_binary_expression if_expr - || ParsetreeViewer.has_attributes if_expr.pexp_attributes + Parsetree_viewer.is_binary_expression if_expr + || Parsetree_viewer.has_attributes if_expr.pexp_attributes | {pexp_desc = Pexp_newtype _} -> false | e -> - ParsetreeViewer.has_attributes e.pexp_attributes - || ParsetreeViewer.is_array_access e + Parsetree_viewer.has_attributes e.pexp_attributes + || Parsetree_viewer.is_array_access e in let target_expr = let doc = print_expression_with_comments ~state target_expr cmt_tbl in @@ -4699,7 +4706,7 @@ and print_pexp_apply ~state expr cmt_tbl = | Pexp_apply {funct = call_expr; args; partial} -> let args = List.map - (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewrite_underscore_apply arg)) + (fun (lbl, arg) -> (lbl, Parsetree_viewer.rewrite_underscore_apply arg)) args in let attrs = expr.pexp_attributes in @@ -4716,14 +4723,14 @@ and print_pexp_apply ~state expr cmt_tbl = | Braced braces -> print_braces doc call_expr braces | Nothing -> doc in - if ParsetreeViewer.requires_special_callback_printing_first_arg args then + if Parsetree_viewer.requires_special_callback_printing_first_arg args then let args_doc = print_arguments_with_callback_in_first_position ~state ~partial args cmt_tbl in Doc.concat [print_attributes ~state attrs cmt_tbl; call_expr_doc; args_doc] - else if ParsetreeViewer.requires_special_callback_printing_last_arg args + else if Parsetree_viewer.requires_special_callback_printing_last_arg args then let args_doc = print_arguments_with_callback_in_last_position ~state ~partial args @@ -4766,7 +4773,7 @@ and print_jsx_unary_tag ~state tag_name props expr_loc cmt_tbl = let tag_has_trailing_comment = has_trailing_comments cmt_tbl tag_loc in let tag_has_no_props = List.length props == 0 in let closing_token_loc = - ParsetreeViewer.unary_element_closing_token expr_loc + Parsetree_viewer.unary_element_closing_token expr_loc in let props_doc = if tag_has_no_props then @@ -4847,7 +4854,7 @@ and print_jsx_container_tag ~state tag_name | None -> Doc.nil | Some closing_tag -> let closing_tag_loc = - ParsetreeViewer.container_element_closing_tag_loc closing_tag + Parsetree_viewer.container_element_closing_tag_loc closing_tag in let closing_name = print_jsx_name closing_tag.jsx_closing_container_tag_name.txt @@ -5012,7 +5019,7 @@ and print_jsx_children ~state (children : Parsetree.jsx_children) cmt_tbl = and print_jsx_prop ~state prop cmt_tbl = let open Parsetree in - let prop_loc = ParsetreeViewer.get_jsx_prop_loc prop in + let prop_loc = Parsetree_viewer.get_jsx_prop_loc prop in let doc = match prop with | JSXPropPunning (is_optional, name) -> @@ -5099,7 +5106,7 @@ and print_arguments_with_callback_in_first_position ~state ~partial args cmt_tbl * consumed comments need to be marked not-consumed and reprinted… * Cheng's different comment algorithm will solve this. *) let state = State.next_custom_layout state in - let cmt_tbl_copy = CommentTable.copy cmt_tbl in + let cmt_tbl_copy = Comment_table.copy cmt_tbl in let callback, printed_args = match args with | (lbl, expr) :: args -> @@ -5185,8 +5192,8 @@ and print_arguments_with_callback_in_last_position ~state ~partial args cmt_tbl * consumed comments need to be marked not-consumed and reprinted… * Cheng's different comment algorithm will solve this. *) let state = state |> State.next_custom_layout in - let cmt_tbl_copy = CommentTable.copy cmt_tbl in - let cmt_tbl_copy2 = CommentTable.copy cmt_tbl in + let cmt_tbl_copy = Comment_table.copy cmt_tbl in + let cmt_tbl_copy2 = Comment_table.copy cmt_tbl in let rec loop acc args = match args with | [] -> (lazy Doc.nil, lazy Doc.nil, lazy Doc.nil) @@ -5303,7 +5310,7 @@ and print_arguments ~state ~partial Doc.rparen; ] else Doc.text "()" - | [(Nolabel, arg)] when ParsetreeViewer.is_huggable_expression arg -> + | [(Nolabel, arg)] when Parsetree_viewer.is_huggable_expression arg -> let arg_doc = let doc = print_expression_with_comments ~state arg cmt_tbl in match Parens.expr arg with @@ -5354,7 +5361,7 @@ and print_argument ~state (arg_lbl, arg) cmt_tbl = pexp_attributes = []; pexp_desc = Pexp_ident {txt = Longident.Lident name}; } ) - when lbl = name && not (ParsetreeViewer.is_braced_expr arg) -> + when lbl = name && not (Parsetree_viewer.is_braced_expr arg) -> let loc = {l0 with loc_end = arg.pexp_loc.loc_end} in let doc = Doc.concat [Doc.tilde; print_ident_like lbl] in print_comments doc cmt_tbl loc @@ -5367,7 +5374,7 @@ and print_argument ~state (arg_lbl, arg) cmt_tbl = typ ); pexp_attributes = []; } ) - when lbl = name && not (ParsetreeViewer.is_braced_expr arg_expr) -> + when lbl = name && not (Parsetree_viewer.is_braced_expr arg_expr) -> let loc = {l0 with loc_end = arg.pexp_loc.loc_end} in let doc = Doc.concat @@ -5433,7 +5440,7 @@ and print_cases ~state (cases : Parsetree.case list) cmt_tbl = { n.Parsetree.pc_lhs.ppat_loc with loc_end = - (match ParsetreeViewer.process_braces_attr n.pc_rhs with + (match Parsetree_viewer.process_braces_attr n.pc_rhs with | None, _ -> n.pc_rhs.pexp_loc.loc_end | Some ({loc}, _), _ -> loc.Location.loc_end); }) @@ -5449,7 +5456,7 @@ and print_case ~state (case : Parsetree.case) cmt_tbl = | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ -> print_expression_block ~state - ~braces:(ParsetreeViewer.is_braced_expr case.pc_rhs) + ~braces:(Parsetree_viewer.is_braced_expr case.pc_rhs) case.pc_rhs cmt_tbl | _ -> ( let doc = print_expression_with_comments ~state case.pc_rhs cmt_tbl in @@ -5475,7 +5482,7 @@ and print_case ~state (case : Parsetree.case) cmt_tbl = | Pexp_construct ({txt = Longident.Lident ("()" | "true" | "false")}, _) | Pexp_constant _ | Pexp_ident _ -> true - | _ when ParsetreeViewer.is_huggable_rhs case.pc_rhs -> true + | _ when Parsetree_viewer.is_huggable_rhs case.pc_rhs -> true | _ -> false in let should_indent_pattern = @@ -5507,7 +5514,7 @@ and print_expr_fun_parameters ~state ~in_callback ~async ~has_constraint match parameters with (* let f = _ => () *) | [ - ParsetreeViewer.Parameter + Parsetree_viewer.Parameter { attrs = []; lbl = Nolabel; @@ -5522,7 +5529,7 @@ and print_expr_fun_parameters ~state ~in_callback ~async ~has_constraint if async then add_async any else any (* let f = a => () *) | [ - ParsetreeViewer.Parameter + Parsetree_viewer.Parameter { attrs = []; lbl = Nolabel; @@ -5548,7 +5555,7 @@ and print_expr_fun_parameters ~state ~in_callback ~async ~has_constraint print_comments txt_doc cmt_tbl string_loc.loc (* let f = () => () *) | [ - ParsetreeViewer.Parameter + Parsetree_viewer.Parameter { attrs = []; lbl = Nolabel; @@ -5573,7 +5580,7 @@ and print_expr_fun_parameters ~state ~in_callback ~async ~has_constraint let lparen = Doc.lparen in if async then add_async lparen else lparen in - let should_hug = ParsetreeViewer.parameters_should_hug parameters in + let should_hug = Parsetree_viewer.parameters_should_hug parameters in let printed_paramaters = Doc.concat [ @@ -5602,7 +5609,7 @@ and print_expr_fun_parameters ~state ~in_callback ~async ~has_constraint and print_exp_fun_parameter ~state parameter cmt_tbl = match parameter with - | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> + | Parsetree_viewer.NewTypes {attrs; locs = lbls} -> Doc.group (Doc.concat [ @@ -5697,7 +5704,7 @@ and print_expression_block ~state ~braces expr cmt_tbl = match mod_expr.pmod_desc with | Pmod_constraint (mod_expr2, mod_type) when not - (ParsetreeViewer.has_await_attribute mod_expr.pmod_attributes) + (Parsetree_viewer.has_await_attribute mod_expr.pmod_attributes) -> let name = Doc.concat @@ -5934,11 +5941,11 @@ and print_doc_comments ~state ?(sep = Doc.hard_line) cmt_tbl attrs = * with a line break between, we respect the users' original layout *) and print_attributes ?loc ?(inline = false) ~state (attrs : Parsetree.attributes) cmt_tbl = - match ParsetreeViewer.filter_parsing_attrs attrs with + match Parsetree_viewer.filter_parsing_attrs attrs with | [] -> Doc.nil | attrs -> let comment_attrs, attrs = - ParsetreeViewer.partition_doc_comment_attributes attrs + Parsetree_viewer.partition_doc_comment_attributes attrs in let line_break = match loc with @@ -5983,7 +5990,7 @@ and print_payload ~state (payload : Parsetree.payload) cmt_tbl = | [] -> false | _ -> true in - let should_hug = ParsetreeViewer.is_huggable_expression expr in + let should_hug = Parsetree_viewer.is_huggable_expression expr in if should_hug then Doc.concat [ @@ -6163,7 +6170,7 @@ and print_mod_expr ~state mod_expr cmt_tbl = | Pmod_extension extension -> print_extension ~state ~at_module_lvl:false extension cmt_tbl | Pmod_apply _ -> - let args, call_expr = ParsetreeViewer.mod_expr_apply mod_expr in + let args, call_expr = Parsetree_viewer.mod_expr_apply mod_expr in let is_unit_sugar = match args with | [{pmod_desc = Pmod_structure []}] -> true @@ -6218,7 +6225,7 @@ and print_mod_expr ~state mod_expr cmt_tbl = | Pmod_functor _ -> print_mod_functor ~state mod_expr cmt_tbl in let doc = - if ParsetreeViewer.has_await_attribute mod_expr.pmod_attributes then + if Parsetree_viewer.has_await_attribute mod_expr.pmod_attributes then match mod_expr.pmod_desc with | Pmod_constraint _ -> Doc.concat [Doc.text "await "; Doc.lparen; doc; Doc.rparen] @@ -6228,7 +6235,9 @@ and print_mod_expr ~state mod_expr cmt_tbl = print_comments doc cmt_tbl mod_expr.pmod_loc and print_mod_functor ~state mod_expr cmt_tbl = - let parameters, return_mod_expr = ParsetreeViewer.mod_expr_functor mod_expr in + let parameters, return_mod_expr = + Parsetree_viewer.mod_expr_functor mod_expr + in (* let shouldInline = match returnModExpr.pmod_desc with *) (* | Pmod_structure _ | Pmod_ident _ -> true *) (* | Pmod_constraint ({pmod_desc = Pmod_structure _}, _) -> true *) @@ -6381,8 +6390,8 @@ let print_pattern p = print_pattern ~state:(State.init ()) p let print_implementation ?(width = default_print_width) (s : Parsetree.structure) ~comments = - let cmt_tbl = CommentTable.make () in - CommentTable.walk_structure s cmt_tbl comments; + let cmt_tbl = Comment_table.make () in + Comment_table.walk_structure s cmt_tbl comments; (* CommentTable.log cmt_tbl; *) let doc = print_structure ~state:(State.init ()) s cmt_tbl in (* Doc.debug doc; *) @@ -6390,8 +6399,8 @@ let print_implementation ?(width = default_print_width) let print_interface ?(width = default_print_width) (s : Parsetree.signature) ~comments = - let cmt_tbl = CommentTable.make () in - CommentTable.walk_signature s cmt_tbl comments; + let cmt_tbl = Comment_table.make () in + Comment_table.walk_signature s cmt_tbl comments; Doc.to_string ~width (print_signature ~state:(State.init ()) s cmt_tbl) ^ "\n" let print_structure = print_structure ~state:(State.init ()) diff --git a/compiler/syntax/src/res_scanner.ml b/compiler/syntax/src/res_scanner.ml index 0c4ae58bce2..82fbeb533bf 100644 --- a/compiler/syntax/src/res_scanner.ml +++ b/compiler/syntax/src/res_scanner.ml @@ -137,7 +137,7 @@ let peek3 scanner = String.unsafe_get scanner.src (scanner.offset + 3) else hacky_eof_char -let peekChar scanner target_char = +let peek_char scanner target_char = let rec skip_whitespace_and_check offset = if offset < String.length scanner.src then let ch = String.unsafe_get scanner.src offset in @@ -148,8 +148,8 @@ let peekChar scanner target_char = in skip_whitespace_and_check scanner.offset -let peekMinus scanner = peekChar scanner '-' -let peekSlash scanner = peekChar scanner '/' +let peek_minus scanner = peek_char scanner '-' +let peek_slash scanner = peek_char scanner '/' let make ~filename src = { diff --git a/compiler/syntax/src/res_scanner.mli b/compiler/syntax/src/res_scanner.mli index e55896796d8..cbb78fad4bd 100644 --- a/compiler/syntax/src/res_scanner.mli +++ b/compiler/syntax/src/res_scanner.mli @@ -35,7 +35,7 @@ val scan_template_literal_token : val scan_regex : t -> Lexing.position * Lexing.position * Res_token.t (* Look ahead to see if the next non-whitespace character is a minus *) -val peekMinus : t -> bool +val peek_minus : t -> bool (* Look ahead to see if the next non-whitespace character is a slash *) -val peekSlash : t -> bool +val peek_slash : t -> bool diff --git a/tests/ounit_tests/ounit_analysis_config_tests.ml b/tests/ounit_tests/ounit_analysis_config_tests.ml index 57cc3dbdd2a..9cf524f452a 100644 --- a/tests/ounit_tests/ounit_analysis_config_tests.ml +++ b/tests/ounit_tests/ounit_analysis_config_tests.ml @@ -11,7 +11,7 @@ let assert_namespace ~expected raw = | Some s -> "Some " ^ s | None -> "None") expected - (Analysis.FindFiles.getNamespace (json raw)) + (Analysis.Find_files.get_namespace (json raw)) let assert_string_opt ~expected actual = OUnit.assert_equal @@ -32,24 +32,25 @@ let suites = >::: [ ( "yojson helpers do not raise on type mismatch" >:: fun _ -> assert_string_opt ~expected:(Some "value") - (Analysis.YojsonHelpers.string_opt (`String "value")); + (Analysis.Yojson_helpers.string_opt (`String "value")); assert_string_opt ~expected:None - (Analysis.YojsonHelpers.string_opt (`Bool true)); + (Analysis.Yojson_helpers.string_opt (`Bool true)); assert_bool_opt ~expected:(Some true) - (Analysis.YojsonHelpers.bool_opt (`Bool true)); + (Analysis.Yojson_helpers.bool_opt (`Bool true)); assert_bool_opt ~expected:None - (Analysis.YojsonHelpers.bool_opt (`String "true")); + (Analysis.Yojson_helpers.bool_opt (`String "true")); OUnit.assert_equal ~printer:string_of_int 1 - (Analysis.YojsonHelpers.to_list_opt (`List [`Null]) + (Analysis.Yojson_helpers.to_list_opt (`List [`Null]) |> Option.fold ~none:0 ~some:List.length); OUnit.assert_equal ~printer:string_of_int 0 - (Analysis.YojsonHelpers.to_list_opt (`String "not a list") + (Analysis.Yojson_helpers.to_list_opt (`String "not a list") |> Option.fold ~none:0 ~some:List.length); OUnit.assert_bool "valid JSON parses" - (Analysis.YojsonHelpers.from_string_opt {|{"ok": true}|} + (Analysis.Yojson_helpers.from_string_opt {|{"ok": true}|} |> Option.is_some); OUnit.assert_bool "invalid JSON is ignored" - (Analysis.YojsonHelpers.from_string_opt {|{|} |> Option.is_none) ); + (Analysis.Yojson_helpers.from_string_opt {|{|} |> Option.is_none) + ); ( "absent namespace is disabled" >:: fun _ -> assert_namespace ~expected:None {|{"name": "@tests/pkg"}|} ); ( "false namespace is disabled" >:: fun _ -> diff --git a/tests/ounit_tests/ounit_scc_tests.ml b/tests/ounit_tests/ounit_scc_tests.ml index e0bb9f33a05..281c6491bc3 100644 --- a/tests/ounit_tests/ounit_scc_tests.ml +++ b/tests/ounit_tests/ounit_scc_tests.ml @@ -141,7 +141,7 @@ let medium_test_cases = 33 2 33 8 33 19 -34 2 +34 2 34 19 34 40 35 9 @@ -222,7 +222,7 @@ let read_file file = (* 25 *) let test (input : (string * string list) list) = - (* string -> int mapping + (* string -> int mapping *) let tbl = Hash_string.create 32 in let idx = ref 0 in @@ -243,7 +243,7 @@ let test (input : (string * string list) list) = Ext_scc.graph_check node_array let test2 (input : (string * string list) list) = - (* string -> int mapping + (* string -> int mapping *) let tbl = Hash_string.create 32 in let idx = ref 0 in diff --git a/tests/ounit_tests/ounit_unicode_tests.ml b/tests/ounit_tests/ounit_unicode_tests.ml index abb0523c495..f48c48bc08a 100644 --- a/tests/ounit_tests/ounit_unicode_tests.ml +++ b/tests/ounit_tests/ounit_unicode_tests.ml @@ -29,7 +29,7 @@ let ( ==* ) a b = in OUnit.assert_equal segments b -let varParen : Ast_utf8_string_interp.kind = Var (2, -1) +let var_paren : Ast_utf8_string_interp.kind = Var (2, -1) let var : Ast_utf8_string_interp.kind = Var (1, 0) let suites = __FILE__ @@ -97,7 +97,7 @@ let suites = ( __LOC__ >:: fun _ -> "你好$this" ==~ [(0, 2, String, "你好"); (2, 7, var, "this")] ); ( __LOC__ >:: fun _ -> - "你好$(this)" ==~ [(0, 2, String, "你好"); (2, 9, varParen, "this")]; + "你好$(this)" ==~ [(0, 2, String, "你好"); (2, 9, var_paren, "this")]; "你好$this)" ==~ [(0, 2, String, "你好"); (2, 7, var, "this"); (7, 8, String, ")")]; @@ -122,7 +122,7 @@ let suites = "你好 $(this_is_a_var) x" ==~ [ (0, 3, String, "你好 "); - (3, 19, varParen, "this_is_a_var"); + (3, 19, var_paren, "this_is_a_var"); (19, 22, String, " x"); ] ); ( __LOC__ >:: fun _ -> @@ -144,7 +144,7 @@ let suites = "\n$(x_this_is_cool) " ==* [ (0, 0, 1, 0, String, "\\n"); - (1, 0, 1, 17, varParen, "x_this_is_cool"); + (1, 0, 1, 17, var_paren, "x_this_is_cool"); (1, 17, 1, 18, String, " "); ] ); ( __LOC__ >:: fun _ -> diff --git a/tests/syntax_benchmarks/Benchmark.ml b/tests/syntax_benchmarks/benchmark.ml similarity index 95% rename from tests/syntax_benchmarks/Benchmark.ml rename to tests/syntax_benchmarks/benchmark.ml index 1a7d2ffffaa..53370e4a138 100644 --- a/tests/syntax_benchmarks/Benchmark.ml +++ b/tests/syntax_benchmarks/benchmark.ml @@ -1,6 +1,6 @@ -module ResParser = Res_core +module Res_parser1 = Res_core module Doc = Res_doc -module CommentTable = Res_comments_table +module Comment_table = Res_comments_table module Parser = Res_parser module Printer = Res_printer @@ -159,7 +159,7 @@ end = struct let parse_rescript src filename = let p = Parser.make src filename in - let structure = ResParser.parse_implementation p in + let structure = Res_parser1.parse_implementation p in if p.diagnostics != [] then ( Res_diagnostics.print_report p.diagnostics src; assert false); @@ -179,13 +179,13 @@ end = struct () | Print -> let p = Parser.make src path in - let ast = ResParser.parse_implementation p in + let ast = Res_parser1.parse_implementation p in fun () -> let _ = Sys.opaque_identity - (let cmt_tbl = CommentTable.make () in + (let cmt_tbl = Comment_table.make () in let comments = List.rev p.Parser.comments in - let () = CommentTable.walk_structure ast cmt_tbl comments in + let () = Comment_table.walk_structure ast cmt_tbl comments in Doc.to_string ~width:80 (Printer.print_structure ast cmt_tbl)) in () diff --git a/tests/syntax_tests/res_test.ml b/tests/syntax_tests/res_test.ml index 505637dd048..699dd5fbca3 100644 --- a/tests/syntax_tests/res_test.ml +++ b/tests/syntax_tests/res_test.ml @@ -28,7 +28,7 @@ let x: int let () = print_endline "✅ multi printer api tests" -module OutcomePrinterTests = struct +module Outcome_printer_tests = struct let signature_to_outcome structure = Lazy.force Res_outcome_printer.setup; @@ -87,7 +87,7 @@ module OutcomePrinterTests = struct ~contents:(signature_to_outcome signature) end -module ParserApiTest = struct +module Parser_api_test = struct let make_default () = let src = " let x = 1\nlet y = 2\nlet z = 3" in let parser = Res_parser.make src "test.res" in @@ -125,6 +125,6 @@ module ParserApiTest = struct windows_crlf () end -let () = OutcomePrinterTests.run () -let () = ParserApiTest.run () +let () = Outcome_printer_tests.run () +let () = Parser_api_test.run () let () = Res_utf8_test.run () diff --git a/tools/bin/main.ml b/tools/bin/main.ml index dcc1a3b71bf..bf4df8cecd4 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -1,4 +1,4 @@ -let docHelp = +let doc_help = {|ReScript Tools Output documentation to standard output @@ -7,7 +7,7 @@ Usage: rescript-tools doc Example: rescript-tools doc ./path/to/EntryPointLib.res|} -let formatCodeblocksHelp = +let format_codeblocks_help = {|ReScript Tools Format ReScript code blocks in docstrings or markdown files @@ -16,7 +16,7 @@ Usage: rescript-tools format-codeblocks [--stdout] [--transform-assert-eq Example: rescript-tools format-codeblocks ./path/to/MyModule.res|} -let extractCodeblocksHelp = +let extract_codeblocks_help = {|ReScript Tools Extract ReScript code blocks from docstrings or markdown files @@ -45,7 +45,7 @@ reanalyze-server Start reanalyze server -v, --version Print version -h, --help Print help|} -let logAndExit = function +let log_and_exit = function | Ok log -> Printf.printf "%s\n" log; exit 0 @@ -59,56 +59,56 @@ let main () = match Sys.argv |> Array.to_list |> List.tl with | "doc" :: rest -> ( match rest with - | ["-h"] | ["--help"] -> logAndExit (Ok docHelp) + | ["-h"] | ["--help"] -> log_and_exit (Ok doc_help) | [path] -> (* NOTE: Internal use to generate docs from compiler *) let () = match Sys.getenv_opt "FROM_COMPILER" with - | Some "true" -> Analysis.Cfg.isDocGenFromCompiler := true + | Some "true" -> Analysis.Cfg.is_doc_gen_from_compiler := true | _ -> () in - logAndExit (Tools.extractDocs ~entryPointFile:path ~debug:false) - | _ -> logAndExit (Error docHelp)) + log_and_exit (Tools.extract_docs ~entry_point_file:path ~debug:false) + | _ -> log_and_exit (Error doc_help)) | "migrate" :: file :: opts -> ( - let isStdout = List.mem "--stdout" opts in - let outputMode = if isStdout then `Stdout else `File in + let is_stdout = List.mem "--stdout" opts in + let output_mode = if is_stdout then `Stdout else `File in match - (Tools.Migrate.migrate ~entryPointFile:file ~outputMode, outputMode) + (Tools.Migrate.migrate ~entry_point_file:file ~output_mode, output_mode) with | Ok content, `Stdout -> print_endline content - | result, `File -> logAndExit result - | Error e, _ -> logAndExit (Error e)) + | result, `File -> log_and_exit result + | Error e, _ -> log_and_exit (Error e)) | "migrate-all" :: root :: _opts -> ( - let rootPath = + let root_path = if Filename.is_relative root then Unix.realpath root else root in - match Analysis.Packages.newBsPackage ~rootPath with + match Analysis.Packages.new_bs_package ~root_path with | None -> - logAndExit + log_and_exit (Error (Printf.sprintf "error: failed to load ReScript project at %s (missing \ rescript.json?)" - rootPath)) + root_path)) | Some package -> - let moduleNames = - Analysis.SharedTypes.FileSet.elements package.projectFiles + let module_names = + Analysis.Shared_types.File_set.elements package.project_files in let files = - moduleNames - |> List.filter_map (fun modName -> - Hashtbl.find_opt package.pathsForModule modName - |> Option.map Analysis.SharedTypes.getSrc) + module_names + |> List.filter_map (fun mod_name -> + Hashtbl.find_opt package.paths_for_module mod_name + |> Option.map Analysis.Shared_types.get_src) |> List.concat |> List.filter (fun path -> Filename.check_suffix path ".res" || Filename.check_suffix path ".resi") in let total = List.length files in - if total = 0 then logAndExit (Ok "No source files found to migrate") + if total = 0 then log_and_exit (Ok "No source files found to migrate") else let process_one file = - (file, Tools.Migrate.migrate ~entryPointFile:file ~outputMode:`File) + (file, Tools.Migrate.migrate ~entry_point_file:file ~output_mode:`File) in let results = List.map process_one files in let migrated, unchanged, failures = @@ -133,37 +133,37 @@ let main () = "Migration summary: migrated %d, unchanged %d, failed %d, total %d" migrated unchanged failures total in - if failures > 0 then logAndExit (Error summary) - else logAndExit (Ok summary)) + if failures > 0 then log_and_exit (Error summary) + else log_and_exit (Ok summary)) | "format-codeblocks" :: rest -> ( match rest with - | ["-h"] | ["--help"] -> logAndExit (Ok formatCodeblocksHelp) + | ["-h"] | ["--help"] -> log_and_exit (Ok format_codeblocks_help) | path :: args -> ( - let isStdout = List.mem "--stdout" args in - let transformAssertEqual = List.mem "--transform-assert-equal" args in - let outputMode = if isStdout then `Stdout else `File in + let is_stdout = List.mem "--stdout" args in + let transform_assert_equal = List.mem "--transform-assert-equal" args in + let output_mode = if is_stdout then `Stdout else `File in Clflags.color := Some Misc.Color.Never; match - ( Tools.FormatCodeblocks.formatCodeBlocksInFile ~outputMode - ~transformAssertEqual ~entryPointFile:path, - outputMode ) + ( Tools.Format_codeblocks.format_code_blocks_in_file ~output_mode + ~transform_assert_equal ~entry_point_file:path, + output_mode ) with | Ok content, `Stdout -> print_endline content - | result, `File -> logAndExit result - | Error e, _ -> logAndExit (Error e)) - | _ -> logAndExit (Error formatCodeblocksHelp)) + | result, `File -> log_and_exit result + | Error e, _ -> log_and_exit (Error e)) + | _ -> log_and_exit (Error format_codeblocks_help)) | "extract-codeblocks" :: rest -> ( match rest with - | ["-h"] | ["--help"] -> logAndExit (Ok extractCodeblocksHelp) + | ["-h"] | ["--help"] -> log_and_exit (Ok extract_codeblocks_help) | path :: args -> - let transformAssertEqual = List.mem "--transform-assert-equal" args in + let transform_assert_equal = List.mem "--transform-assert-equal" args in Clflags.color := Some Misc.Color.Never; (* TODO: Add result/JSON mode *) - Tools.ExtractCodeblocks.extractCodeblocksFromFile ~transformAssertEqual - ~entryPointFile:path - |> logAndExit - | _ -> logAndExit (Error extractCodeblocksHelp)) + Tools.Extract_codeblocks.extract_codeblocks_from_file + ~transform_assert_equal ~entry_point_file:path + |> log_and_exit + | _ -> log_and_exit (Error extract_codeblocks_help)) | "reanalyze" :: _ -> if Sys.getenv_opt "RESCRIPT_REANALYZE_NO_SERVER" = Some "1" then ( let len = Array.length Sys.argv in @@ -186,7 +186,7 @@ let main () = rest |> List.filter (fun s -> s <> "") |> Array.of_list in if argv_for_server = [|"-json"|] then ( - match Reanalyze.ReanalyzeServer.try_request_default () with + match Reanalyze.Reanalyze_server.try_request_default () with | Some resp -> output_string stdout resp.stdout; output_string stderr resp.stderr; @@ -213,13 +213,13 @@ let main () = Sys.argv.(i) <- Sys.argv.(i + 1) done; Sys.argv.(len - 1) <- ""; - Reanalyze.ReanalyzeServer.server_cli ~parse_argv:Reanalyze.parse_argv - ~run_analysis:Reanalyze.runAnalysis () - | "extract-embedded" :: extPointNames :: filename :: _ -> - logAndExit + Reanalyze.Reanalyze_server.server_cli ~parse_argv:Reanalyze.parse_argv + ~run_analysis:Reanalyze.run_analysis () + | "extract-embedded" :: ext_point_names :: filename :: _ -> + log_and_exit (Ok - (Tools.extractEmbedded - ~extensionPoints:(extPointNames |> String.split_on_char ',') + (Tools.extract_embedded + ~extension_points:(ext_point_names |> String.split_on_char ',') ~filename)) | ["ppx"; file_in; file_out] -> let ic = open_in_bin file_in in @@ -241,8 +241,8 @@ let main () = output_value oc ast; close_out oc; exit 0 - | ["-h"] | ["--help"] -> logAndExit (Ok help) - | ["-v"] | ["--version"] -> logAndExit (Ok version) - | _ -> logAndExit (Error help) + | ["-h"] | ["--help"] -> log_and_exit (Ok help) + | ["-v"] | ["--version"] -> log_and_exit (Ok version) + | _ -> log_and_exit (Error help) let () = main () diff --git a/tools/src/migrate.ml b/tools/src/migrate.ml index b6251dd2464..30bba2094f7 100644 --- a/tools/src/migrate.ml +++ b/tools/src/migrate.ml @@ -1,8 +1,8 @@ open Analysis -module StringMap = Map.Make (String) -module StringSet = Set.Make (String) -module IntSet = Set.Make (Int) +module String_map = Map.Make (String) +module String_set = Set.Make (String) +module Int_set = Set.Make (Int) (* Public API: migrate ~entryPointFile ~outputMode *) @@ -11,7 +11,7 @@ let is_unit_expr (e : Parsetree.expression) = | Pexp_construct ({txt = Lident "()"}, None) -> true | _ -> false -module InsertExt = struct +module Insert_ext = struct type placeholder = Labelled of string | Unlabelled of int let ext_labelled = "insert.labelledArgument" @@ -46,13 +46,13 @@ module InsertExt = struct | _ -> None end -module ArgUtils = struct +module Arg_utils = struct let map_expr_args mapper args = args |> List.map (fun (label, arg) -> (label, mapper.Ast_mapper.expr mapper arg)) end -module ExprUtils = struct +module Expr_utils = struct let rec is_pipe_apply (e : Parsetree.expression) = match e.pexp_desc with | Pexp_apply {funct = {pexp_desc = Pexp_ident {txt = Lident "->"}}; _} -> @@ -70,8 +70,8 @@ end type args = (Asttypes.arg_label * Parsetree.expression) list -module MapperUtils = struct - module ApplyTransforms = struct +module Mapper_utils = struct + module Apply_transforms = struct let attr_name = "apply.transforms" let split_attrs (attrs : Parsetree.attributes) = @@ -124,19 +124,19 @@ module MapperUtils = struct (* Collect placeholder usages anywhere inside an expression. *) let collect_placeholders (expr : Parsetree.expression) = - let labelled = ref StringSet.empty in - let unlabelled = ref IntSet.empty in + let labelled = ref String_set.empty in + let unlabelled = ref Int_set.empty in let open Ast_iterator in let iter = { default_iterator with expr = (fun self e -> - (match InsertExt.placeholder_of_expr e with - | Some (InsertExt.Labelled name) -> - labelled := StringSet.add name !labelled - | Some (InsertExt.Unlabelled i) when i >= 0 -> - unlabelled := IntSet.add i !unlabelled + (match Insert_ext.placeholder_of_expr e with + | Some (Insert_ext.Labelled name) -> + labelled := String_set.add name !labelled + | Some (Insert_ext.Unlabelled i) when i >= 0 -> + unlabelled := Int_set.add i !unlabelled | _ -> ()); default_iterator.expr self e); } @@ -169,18 +169,18 @@ module MapperUtils = struct Ast_mapper.default_mapper with expr = (fun mapper exp -> - match InsertExt.placeholder_of_expr exp with - | Some (InsertExt.Labelled name) -> ( + match Insert_ext.placeholder_of_expr exp with + | Some (Insert_ext.Labelled name) -> ( match Hashtbl.find_opt labelled name with | Some arg -> - ApplyTransforms.attach_to_replacement ~attrs:exp.pexp_attributes - arg + Apply_transforms.attach_to_replacement + ~attrs:exp.pexp_attributes arg | None -> exp) - | Some (InsertExt.Unlabelled i) -> ( + | Some (Insert_ext.Unlabelled i) -> ( match Hashtbl.find_opt unlabelled i with | Some arg -> - ApplyTransforms.attach_to_replacement ~attrs:exp.pexp_attributes - arg + Apply_transforms.attach_to_replacement + ~attrs:exp.pexp_attributes arg | None -> exp) | None -> Ast_mapper.default_mapper.expr mapper exp); } @@ -190,12 +190,14 @@ module MapperUtils = struct let build_labelled_args_map (template_args : args) = template_args |> List.filter_map (fun (label, arg) -> - match (label, InsertExt.placeholder_of_expr arg) with + match (label, Insert_ext.placeholder_of_expr arg) with | ( (Asttypes.Labelled {txt = label} | Optional {txt = label}), - Some (InsertExt.Labelled arg_name) ) -> + Some (Insert_ext.Labelled arg_name) ) -> Some (arg_name, label) | _ -> None) - |> List.fold_left (fun map (k, v) -> StringMap.add k v map) StringMap.empty + |> List.fold_left + (fun map (k, v) -> String_map.add k v map) + String_map.empty (* Pure computation of which template args to insert and which source args @@ -213,8 +215,8 @@ module MapperUtils = struct *) type template_resolution = { args_to_insert: args; - labelled_to_drop: StringSet.t; - unlabelled_to_drop: IntSet.t; + labelled_to_drop: String_set.t; + unlabelled_to_drop: Int_set.t; } let get_template_args_to_insert mapper (template_args : args) @@ -234,12 +236,12 @@ module MapperUtils = struct let labelled_used_here, unlabelled_used_here = collect_placeholders arg in let arg_replaced = replace_placeholders_in_expr arg source_args in ( (label, mapper.Ast_mapper.expr mapper arg_replaced) :: rev_args, - StringSet.union used_labelled labelled_used_here, - IntSet.union used_unlabelled unlabelled_used_here ) + String_set.union used_labelled labelled_used_here, + Int_set.union used_unlabelled unlabelled_used_here ) in let rev_args, labelled_set, unlabelled_set = List.fold_left accumulate_template_arg - ([], StringSet.empty, IntSet.empty) + ([], String_set.empty, Int_set.empty) template_args in { @@ -258,11 +260,11 @@ module MapperUtils = struct (fun (idx, acc) (label, arg) -> match label with | Asttypes.Nolabel -> - let drop = IntSet.mem idx unlabelled_positions_to_drop in + let drop = Int_set.mem idx unlabelled_positions_to_drop in let idx' = idx + 1 in if drop then (idx', acc) else (idx', (label, arg) :: acc) | Asttypes.Labelled {txt} | Optional {txt} -> - if StringSet.mem txt labelled_names_to_drop then (idx, acc) + if String_set.mem txt labelled_names_to_drop then (idx, acc) else (idx, (label, arg) :: acc)) (0, []) source_args in @@ -273,11 +275,11 @@ module MapperUtils = struct |> List.map (fun (label, arg) -> match label with | Asttypes.Labelled ({loc; txt} as l) -> ( - match StringMap.find_opt txt labelled_args_map with + match String_map.find_opt txt labelled_args_map with | Some mapped -> (Asttypes.Labelled {loc; txt = mapped}, arg) | None -> (Asttypes.Labelled l, arg)) | Optional ({loc; txt} as l) -> ( - match StringMap.find_opt txt labelled_args_map with + match String_map.find_opt txt labelled_args_map with | Some mapped -> (Optional {loc; txt = mapped}, arg) | None -> (Optional l, arg)) | _ -> (label, arg)) @@ -300,9 +302,9 @@ module MapperUtils = struct position 0 in placeholder resolution, but is not part of the inner call's argument list. *) let shift_unlabelled_drop_for_piped set = - IntSet.fold - (fun i acc -> if i > 0 then IntSet.add (i - 1) acc else acc) - set IntSet.empty + Int_set.fold + (fun i acc -> if i > 0 then Int_set.add (i - 1) acc else acc) + set Int_set.empty let migrate_piped_args mapper ~template_args ~lhs ~pipe_args = let full_source_args = lhs :: pipe_args in @@ -322,7 +324,7 @@ module MapperUtils = struct renamed @ resolution.args_to_insert end -module TypeReplace = struct +module Type_replace = struct let ext_replace_type = "replace.type" (* Extract a core_type payload from an expression extension of the form @@ -336,7 +338,7 @@ module TypeReplace = struct | _ -> None end -module ConstructorReplace = struct +module Constructor_replace = struct type target = {lid: Longident.t Location.loc; attrs: Parsetree.attributes} let of_template (expr : Parsetree.expression) : target option = @@ -377,8 +379,8 @@ let migrate_reference_from_info (deprecated_info : Cmt_utils.deprecated_used) | Pexp_apply {funct; args = [(_lbl, unit_arg)]; partial = _; transformed_jsx = _} when is_unit_expr unit_arg -> - MapperUtils.ApplyTransforms.attach_to_replacement ~attrs:e.pexp_attributes - funct + Mapper_utils.Apply_transforms.attach_to_replacement + ~attrs:e.pexp_attributes funct | _ -> e) module Template = struct @@ -391,7 +393,7 @@ module Template = struct } let attach attrs e = - MapperUtils.ApplyTransforms.attach_to_replacement ~attrs e + Mapper_utils.Apply_transforms.attach_to_replacement ~attrs e let of_expr = function | {Parsetree.pexp_desc = Pexp_apply {funct; args; partial; transformed_jsx}} @@ -424,7 +426,7 @@ module Template = struct {funct = template_funct; args = template_args; partial; transformed_jsx} -> let migrated_args = - MapperUtils.apply_migration_template mapper template_args call_args + Mapper_utils.apply_migration_template mapper template_args call_args in let res = mk_apply exp ~funct:template_funct ~args:migrated_args ~partial @@ -438,9 +440,9 @@ module Template = struct | Apply {funct = template_funct; args = template_args; partial; transformed_jsx} -> - let pipe_args_mapped = ArgUtils.map_expr_args mapper pipe_args in + let pipe_args_mapped = Arg_utils.map_expr_args mapper pipe_args in let migrated_args = - MapperUtils.migrate_piped_args mapper ~template_args ~lhs + Mapper_utils.migrate_piped_args mapper ~template_args ~lhs ~pipe_args:pipe_args_mapped in let inner = Ast_helper.Exp.apply template_funct migrated_args in @@ -457,7 +459,7 @@ module Template = struct -> if Ext_list.is_empty pipe_args then let resolution = - MapperUtils.get_template_args_to_insert mapper template_args [] + Mapper_utils.get_template_args_to_insert mapper template_args [] in if Ext_list.is_empty resolution.args_to_insert then let res = @@ -488,9 +490,9 @@ module Template = struct partial = tpartial; transformed_jsx = tjsx; } -> - let pipe_args_mapped = ArgUtils.map_expr_args mapper pipe_args in + let pipe_args_mapped = Arg_utils.map_expr_args mapper pipe_args in let migrated_args = - MapperUtils.apply_migration_template mapper templ_args + Mapper_utils.apply_migration_template mapper templ_args ((Asttypes.Nolabel, lhs_exp) :: pipe_args_mapped) in let res = @@ -515,7 +517,7 @@ let apply_template_direct mapper template_expr call_args exp = let apply_single_step_or_piped ~mapper ~(deprecated_info : Cmt_utils.deprecated_used) ~lhs ~lhs_exp ~pipe_args ~funct exp = - let is_single_pipe_step = not (ExprUtils.is_pipe_apply lhs_exp) in + let is_single_pipe_step = not (Expr_utils.is_pipe_apply lhs_exp) in let in_pipe_template = match deprecated_info.migration_in_pipe_chain_template with | Some e -> Template.of_expr_with_attrs e @@ -549,7 +551,7 @@ let apply_single_step_or_piped ~mapper ~lhs ~pipe_args ~funct exp | None -> exp -let makeMapper (deprecated_used : Cmt_utils.deprecated_used list) = +let make_mapper (deprecated_used : Cmt_utils.deprecated_used list) = let deprecated_function_calls = deprecated_used |> List.filter (fun (d : Cmt_utils.deprecated_used) -> @@ -583,7 +585,7 @@ let makeMapper (deprecated_used : Cmt_utils.deprecated_used list) = |> List.filter_map (fun (d : Cmt_utils.deprecated_used) -> match d.migration_template with | Some template -> ( - match ConstructorReplace.of_template template with + match Constructor_replace.of_template template with | Some target -> Some (d.source_loc, target) | None -> None) | None -> None) @@ -616,7 +618,7 @@ let makeMapper (deprecated_used : Cmt_utils.deprecated_used list) = |> List.filter_map (fun (d : Cmt_utils.deprecated_used) -> match d.migration_template with | Some e -> ( - match TypeReplace.core_type_of_expr_extension e with + match Type_replace.core_type_of_expr_extension e with | Some ct -> Some (d, ct) | None -> None) | None -> None) @@ -675,16 +677,17 @@ let makeMapper (deprecated_used : Cmt_utils.deprecated_used list) = let deprecated_info = Hashtbl.find loc_to_deprecated_fn_call fn_loc in - let call_args = ArgUtils.map_expr_args mapper call_args in + let call_args = Arg_utils.map_expr_args mapper call_args in match deprecated_info.migration_template with | Some e -> apply_template_direct mapper e call_args exp | None -> exp) | {pexp_desc = Pexp_construct (lid, arg); pexp_loc} -> ( match find_constructor_target ~loc:pexp_loc ~lid_loc:lid.loc with - | Some {ConstructorReplace.lid; attrs} -> + | Some {Constructor_replace.lid; attrs} -> let arg = Option.map (mapper.expr mapper) arg in let replaced = {exp with pexp_desc = Pexp_construct (lid, arg)} in - MapperUtils.ApplyTransforms.attach_to_replacement ~attrs replaced + Mapper_utils.Apply_transforms.attach_to_replacement ~attrs + replaced | None -> Ast_mapper.default_mapper.expr mapper exp) | { pexp_desc = @@ -726,21 +729,21 @@ let makeMapper (deprecated_used : Cmt_utils.deprecated_used list) = match pat with | {ppat_desc = Ppat_construct (lid, arg); ppat_loc} -> ( match find_constructor_target ~loc:ppat_loc ~lid_loc:lid.loc with - | Some {ConstructorReplace.lid; attrs} -> + | Some {Constructor_replace.lid; attrs} -> let arg = Option.map (mapper.pat mapper) arg in let replaced = {pat with ppat_desc = Ppat_construct (lid, arg)} in - MapperUtils.ApplyTransforms.attach_attrs_to_pat ~attrs replaced + Mapper_utils.Apply_transforms.attach_attrs_to_pat ~attrs replaced | None -> Ast_mapper.default_mapper.pat mapper pat) | _ -> Ast_mapper.default_mapper.pat mapper pat); } in mapper -let migrate ~entryPointFile ~outputMode = +let migrate ~entry_point_file ~output_mode = let path = - match Filename.is_relative entryPointFile with - | true -> Unix.realpath entryPointFile - | false -> entryPointFile + match Filename.is_relative entry_point_file with + | true -> Unix.realpath entry_point_file + | false -> entry_point_file in let result = if Filename.check_suffix path ".res" then @@ -748,7 +751,7 @@ let migrate ~entryPointFile ~outputMode = Res_driver.parsing_engine.parse_implementation ~for_printer:true in let {Res_driver.parsetree; comments; source} = parser ~filename:path in - match Cmt.loadCmtInfosFromPath ~path with + match Cmt.load_cmt_infos_from_path ~path with | None -> Error (Printf.sprintf @@ -756,22 +759,22 @@ let migrate ~entryPointFile ~outputMode = could not be found. try to build the project" path) | Some {cmt_extra_info = {deprecated_used}} -> - let mapper = makeMapper deprecated_used in - let astMapped = mapper.structure mapper parsetree in + let mapper = make_mapper deprecated_used in + let ast_mapped = mapper.structure mapper parsetree in (* Second pass: apply any post-migration transforms signaled via @apply.transforms *) let apply_transforms = let expr mapper (e : Parsetree.expression) = let e = Ast_mapper.default_mapper.expr mapper e in - MapperUtils.ApplyTransforms.apply_on_self e + Mapper_utils.Apply_transforms.apply_on_self e in {Ast_mapper.default_mapper with expr} in - let astTransformed = - apply_transforms.structure apply_transforms astMapped + let ast_transformed = + apply_transforms.structure apply_transforms ast_mapped in Ok ( Res_printer.print_implementation - ~width:Res_printer.default_print_width astTransformed ~comments, + ~width:Res_printer.default_print_width ast_transformed ~comments, source ) else if Filename.check_suffix path ".resi" then let parser = @@ -781,7 +784,7 @@ let migrate ~entryPointFile ~outputMode = parser ~filename:path in - match Cmt.loadCmtInfosFromPath ~path with + match Cmt.load_cmt_infos_from_path ~path with | None -> Error (Printf.sprintf @@ -789,9 +792,9 @@ let migrate ~entryPointFile ~outputMode = could not be found. try to build the project" path) | Some {cmt_extra_info = {deprecated_used}} -> - let mapper = makeMapper deprecated_used in - let astMapped = mapper.signature mapper signature in - Ok (Res_printer.print_interface astMapped ~comments, source) + let mapper = make_mapper deprecated_used in + let ast_mapped = mapper.signature mapper signature in + Ok (Res_printer.print_interface ast_mapped ~comments, source) else Error (Printf.sprintf @@ -801,7 +804,7 @@ let migrate ~entryPointFile ~outputMode = match result with | Error e -> Error e | Ok (contents, source) when contents <> source -> ( - match outputMode with + match output_mode with | `Stdout -> Ok contents | `File -> let oc = open_out path in @@ -809,6 +812,6 @@ let migrate ~entryPointFile ~outputMode = close_out oc; Ok (Filename.basename path ^ ": File migrated successfully")) | Ok (contents, _) -> ( - match outputMode with + match output_mode with | `Stdout -> Ok contents | `File -> Ok (Filename.basename path ^ ": File did not need migration")) diff --git a/tools/src/migrate.mli b/tools/src/migrate.mli index 1831a90b30c..07b32c3ef47 100644 --- a/tools/src/migrate.mli +++ b/tools/src/migrate.mli @@ -1,4 +1,4 @@ val migrate : - entryPointFile:string -> - outputMode:[`File | `Stdout] -> + entry_point_file:string -> + output_mode:[`File | `Stdout] -> (string, string) result diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 21cf5eea177..521d3f833f4 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1,43 +1,43 @@ open Analysis -module StringSet = Set.Make (String) +module String_set = Set.Make (String) -type fieldDoc = { - fieldName: string; +type field_doc = { + field_name: string; docstrings: string list; signature: string; optional: bool; deprecated: string option; } -type constructorPayload = InlineRecord of {fieldDocs: fieldDoc list} +type constructor_payload = InlineRecord of {field_docs: field_doc list} -type constructorDoc = { - constructorName: string; +type constructor_doc = { + constructor_name: string; docstrings: string list; signature: string; deprecated: string option; - items: constructorPayload option; + items: constructor_payload option; } -type typeDoc = {path: string; genericParameters: typeDoc list} -type valueSignature = {parameters: typeDoc list; returnType: typeDoc} +type type_doc = {path: string; generic_parameters: type_doc list} +type value_signature = {parameters: type_doc list; return_type: type_doc} type source = {filepath: string; line: int; col: int} -type docItemDetail = - | Record of {fieldDocs: fieldDoc list} - | Variant of {constructorDocs: constructorDoc list} - | Signature of valueSignature +type doc_item_detail = + | Record of {field_docs: field_doc list} + | Variant of {constructor_docs: constructor_doc list} + | Signature of value_signature -type docItem = +type doc_item = | Value of { id: string; docstring: string list; signature: string; name: string; deprecated: string option; - detail: docItemDetail option; + detail: doc_item_detail option; source: source; } | Type of { @@ -46,121 +46,122 @@ type docItem = signature: string; name: string; deprecated: string option; - detail: docItemDetail option; + detail: doc_item_detail option; source: source; (** Additional documentation for constructors and record fields, if available. *) } - | Module of docsForModule + | Module of docs_for_module | ModuleType of { id: string; docstring: string list; deprecated: string option; name: string; source: source; - items: docItem list; + items: doc_item list; } | ModuleAlias of { id: string; docstring: string list; name: string; source: source; - items: docItem list; + items: doc_item list; } -and docsForModule = { +and docs_for_module = { id: string; docstring: string list; deprecated: string option; name: string; moduletypeid: string option; source: source; - items: docItem list; + items: doc_item list; } -let stringifyDocstrings docstrings = +let stringify_docstrings docstrings = `List (docstrings |> List.map (fun docstring -> `String (docstring |> String.trim))) -let stringifyFieldDoc (fieldDoc : fieldDoc) = +let stringify_field_doc (field_doc : field_doc) = `Assoc ([ - ("name", `String fieldDoc.fieldName); - ("optional", `Bool fieldDoc.optional); - ("docstrings", stringifyDocstrings fieldDoc.docstrings); - ("signature", `String fieldDoc.signature); + ("name", `String field_doc.field_name); + ("optional", `Bool field_doc.optional); + ("docstrings", stringify_docstrings field_doc.docstrings); + ("signature", `String field_doc.signature); ] @ - match fieldDoc.deprecated with + match field_doc.deprecated with | Some d -> [("deprecated", `String d)] | None -> []) -let stringifyConstructorPayload (constructorPayload : constructorPayload) = - match constructorPayload with - | InlineRecord {fieldDocs} -> +let stringify_constructor_payload (constructor_payload : constructor_payload) = + match constructor_payload with + | InlineRecord {field_docs} -> `Assoc [ ("kind", `String "inlineRecord"); - ("fields", `List (fieldDocs |> List.map stringifyFieldDoc)); + ("fields", `List (field_docs |> List.map stringify_field_doc)); ] -let rec stringifyTypeDoc (td : typeDoc) = +let rec stringify_type_doc (td : type_doc) = let ps = - match td.genericParameters with + match td.generic_parameters with | [] -> `List [] - | ts -> ts |> List.map stringifyTypeDoc |> fun ts -> `List ts + | ts -> ts |> List.map stringify_type_doc |> fun ts -> `List ts in `Assoc [("path", `String td.path); ("genericTypeParameters", ps)] -let stringifyDetail (detail : docItemDetail) = +let stringify_detail (detail : doc_item_detail) = match detail with - | Record {fieldDocs} -> + | Record {field_docs} -> `Assoc [ ("kind", `String "record"); - ("items", `List (fieldDocs |> List.map stringifyFieldDoc)); + ("items", `List (field_docs |> List.map stringify_field_doc)); ] - | Variant {constructorDocs} -> + | Variant {constructor_docs} -> `Assoc [ ("kind", `String "variant"); ( "items", `List - (constructorDocs - |> List.map (fun constructorDoc -> + (constructor_docs + |> List.map (fun constructor_doc -> `Assoc ([ - ("name", `String constructorDoc.constructorName); + ("name", `String constructor_doc.constructor_name); ( "docstrings", - stringifyDocstrings constructorDoc.docstrings ); - ("signature", `String constructorDoc.signature); + stringify_docstrings constructor_doc.docstrings ); + ("signature", `String constructor_doc.signature); ] - @ (match constructorDoc.deprecated with + @ (match constructor_doc.deprecated with | Some d -> [("deprecated", `String d)] | None -> []) @ - match constructorDoc.items with - | Some constructorPayload -> + match constructor_doc.items with + | Some constructor_payload -> [ ( "payload", - stringifyConstructorPayload constructorPayload ); + stringify_constructor_payload constructor_payload ); ] | None -> []))) ); ] - | Signature {parameters; returnType} -> + | Signature {parameters; return_type} -> let ps = match parameters with | [] -> `List [] - | ps -> ps |> List.map stringifyTypeDoc |> fun ps -> `List ps + | ps -> ps |> List.map stringify_type_doc |> fun ps -> `List ps in `Assoc [ ("kind", `String "signature"); ( "details", `Assoc - [("parameters", ps); ("returnType", stringifyTypeDoc returnType)] ); + [("parameters", ps); ("returnType", stringify_type_doc return_type)] + ); ] -let stringifySource source = +let stringify_source source = `Assoc [ ("filepath", `String source.filepath); @@ -168,7 +169,7 @@ let stringifySource source = ("col", `Int source.col); ] -let rec stringifyDocItem ~originalEnv (item : docItem) = +let rec stringify_doc_item ~original_env (item : doc_item) = match item with | Value {id; docstring; signature; name; deprecated; source; detail} -> `Assoc @@ -177,15 +178,15 @@ let rec stringifyDocItem ~originalEnv (item : docItem) = ("kind", `String "value"); ("name", `String name); ("signature", `String (signature |> String.trim)); - ("docstrings", stringifyDocstrings docstring); - ("source", stringifySource source); + ("docstrings", stringify_docstrings docstring); + ("source", stringify_source source); ] @ (match deprecated with | Some d -> [("deprecated", `String d)] | None -> []) @ match detail with - | Some detail -> [("detail", stringifyDetail detail)] + | Some detail -> [("detail", stringify_detail detail)] | None -> []) | Type {id; docstring; signature; name; deprecated; detail; source} -> `Assoc @@ -194,15 +195,15 @@ let rec stringifyDocItem ~originalEnv (item : docItem) = ("kind", `String "type"); ("name", `String name); ("signature", `String signature); - ("docstrings", stringifyDocstrings docstring); - ("source", stringifySource source); + ("docstrings", stringify_docstrings docstring); + ("source", stringify_source source); ] @ (match deprecated with | Some d -> [("deprecated", `String d)] | None -> []) @ match detail with - | Some detail -> [("detail", stringifyDetail detail)] + | Some detail -> [("detail", stringify_detail detail)] | None -> []) | Module m -> `Assoc @@ -210,12 +211,12 @@ let rec stringifyDocItem ~originalEnv (item : docItem) = ("id", `String m.id); ("name", `String m.name); ("kind", `String "module"); - ("docstrings", stringifyDocstrings m.docstring); - ("source", stringifySource m.source); + ("docstrings", stringify_docstrings m.docstring); + ("source", stringify_source m.source); ( "items", `List (m.items - |> List.map (fun item -> stringifyDocItem ~originalEnv item)) ); + |> List.map (fun item -> stringify_doc_item ~original_env item)) ); ] @ (match m.deprecated with | Some d -> [("deprecated", `String d)] @@ -230,12 +231,12 @@ let rec stringifyDocItem ~originalEnv (item : docItem) = ("id", `String m.id); ("name", `String m.name); ("kind", `String "moduleType"); - ("docstrings", stringifyDocstrings m.docstring); - ("source", stringifySource m.source); + ("docstrings", stringify_docstrings m.docstring); + ("source", stringify_source m.source); ( "items", `List (m.items - |> List.map (fun item -> stringifyDocItem ~originalEnv item)) ); + |> List.map (fun item -> stringify_doc_item ~original_env item)) ); ] @ match m.deprecated with @@ -247,66 +248,69 @@ let rec stringifyDocItem ~originalEnv (item : docItem) = ("id", `String m.id); ("kind", `String "moduleAlias"); ("name", `String m.name); - ("docstrings", stringifyDocstrings m.docstring); - ("source", stringifySource m.source); - ("items", `List (m.items |> List.map (stringifyDocItem ~originalEnv))); + ("docstrings", stringify_docstrings m.docstring); + ("source", stringify_source m.source); + ("items", `List (m.items |> List.map (stringify_doc_item ~original_env))); ] -and stringifyDocsForModule ~originalEnv (d : docsForModule) = +and stringify_docs_for_module ~original_env (d : docs_for_module) = `Assoc ([ ("name", `String d.name); - ("docstrings", stringifyDocstrings d.docstring); - ("source", stringifySource d.source); + ("docstrings", stringify_docstrings d.docstring); + ("source", stringify_source d.source); ( "items", `List - (d.items |> List.map (fun item -> stringifyDocItem ~originalEnv item)) - ); + (d.items + |> List.map (fun item -> stringify_doc_item ~original_env item)) ); ] @ match d.deprecated with | Some d -> [("deprecated", `String d)] | None -> []) -let fieldToFieldDoc (field : SharedTypes.field) : fieldDoc = +let field_to_field_doc (field : Shared_types.field) : field_doc = { - fieldName = field.fname.txt; + field_name = field.fname.txt; docstrings = field.docstring; optional = field.optional; - signature = Shared.typeToString field.typ; + signature = Shared.type_to_string field.typ; deprecated = field.deprecated; } -let typeDetail typ ~env ~full = - let open SharedTypes in - match TypeUtils.extractTypeFromResolvedType ~env ~full typ with +let type_detail typ ~env ~full = + let open Shared_types in + match Type_utils.extract_type_from_resolved_type ~env ~full typ with | Some (Trecord {fields}) -> - Some (Record {fieldDocs = fields |> List.map fieldToFieldDoc}) + Some (Record {field_docs = fields |> List.map field_to_field_doc}) | Some (Tvariant {constructors}) -> Some (Variant { - constructorDocs = + constructor_docs = constructors |> List.map (fun (c : Constructor.t) -> { - constructorName = c.cname.txt; + constructor_name = c.cname.txt; docstrings = c.docstring; - signature = CompletionBackEnd.showConstructor c; + signature = Completion_back_end.show_constructor c; deprecated = c.deprecated; items = (match c.args with | InlineRecord fields -> Some (InlineRecord - {fieldDocs = fields |> List.map fieldToFieldDoc}) + { + field_docs = + fields |> List.map field_to_field_doc; + }) | _ -> None); }); }) | _ -> None (* split a list into two parts all the items except the last one and the last item *) -let splitLast l = +let split_last l = let rec splitLast' acc = function | [] -> failwith "splitLast: empty list" | [x] -> (List.rev acc, x) @@ -331,73 +335,73 @@ let path_to_string path = aux path; Buffer.contents buf -let valueDetail (typ : Types.type_expr) = - let rec collectSignatureTypes (typ : Types.type_expr) = +let value_detail (typ : Types.type_expr) = + let rec collect_signature_types (typ : Types.type_expr) = match typ.desc with - | Tlink t | Tsubst t | Tpoly (t, []) -> collectSignatureTypes t + | Tlink t | Tsubst t | Tpoly (t, []) -> collect_signature_types t | Tconstr (path, ts, _) -> ( let p = path_to_string path in match ts with - | [] -> [{path = p; genericParameters = []}] + | [] -> [{path = p; generic_parameters = []}] | ts -> let ts = ts |> List.concat_map (fun (t : Types.type_expr) -> - collectSignatureTypes t) + collect_signature_types t) in - [{path = p; genericParameters = ts}]) + [{path = p; generic_parameters = ts}]) | Tarrow (arg, ret, _, _) -> - collectSignatureTypes arg.typ @ collectSignatureTypes ret - | Tvar None -> [{path = "_"; genericParameters = []}] + collect_signature_types arg.typ @ collect_signature_types ret + | Tvar None -> [{path = "_"; generic_parameters = []}] | _ -> [] in - match collectSignatureTypes typ with + match collect_signature_types typ with | [] -> None | ts -> - let parameters, returnType = splitLast ts in - Some (Signature {parameters; returnType}) + let parameters, return_type = split_last ts in + Some (Signature {parameters; return_type}) -let makeId modulePath ~identifier = - identifier :: modulePath |> List.rev |> SharedTypes.ident +let make_id module_path ~identifier = + identifier :: module_path |> List.rev |> Shared_types.ident -let getSource ~rootPath ({loc_start} : Location.t) = - let line, col = Pos.ofLexing loc_start in +let get_source ~root_path ({loc_start} : Location.t) = + let line, col = Pos.of_lexing loc_start in let filepath = - Files.relpath rootPath loc_start.pos_fname + Files.relpath root_path loc_start.pos_fname |> Files.split Filename.dir_sep |> String.concat "/" in {filepath; line = line + 1; col = col + 1} -let extractDocs ~entryPointFile ~debug = +let extract_docs ~entry_point_file ~debug = let path = - match Filename.is_relative entryPointFile with - | true -> Unix.realpath entryPointFile - | false -> entryPointFile + match Filename.is_relative entry_point_file with + | true -> Unix.realpath entry_point_file + | false -> entry_point_file in if debug then Printf.printf "extracting docs for %s\n" path; let result = match - FindFiles.isImplementation path = false - && FindFiles.isInterface path = false + Find_files.is_implementation path = false + && Find_files.is_interface path = false with | false -> ( let path = - if FindFiles.isImplementation path then - let pathAsResi = + if Find_files.is_implementation path then + let path_as_resi = (path |> Filename.dirname) ^ "/" ^ (path |> Filename.basename |> Filename.chop_extension) ^ ".resi" in - if Sys.file_exists pathAsResi then ( + if Sys.file_exists path_as_resi then ( if debug then Printf.printf "preferring found resi file for impl: %s\n" - pathAsResi; - pathAsResi) + path_as_resi; + path_as_resi) else path else path in - match Cmt.loadFullCmtFromPath ~path with + match Cmt.load_full_cmt_from_path ~path with | None -> Error (Printf.sprintf @@ -406,14 +410,14 @@ let extractDocs ~entryPointFile ~debug = | Some full -> let file = full.file in let structure = file.structure in - let rootPath = full.package.rootPath in - let open SharedTypes in - let env = QueryEnv.fromFile file in - let rec extractDocsForModule ?(modulePath = [env.file.moduleName]) + let root_path = full.package.root_path in + let open Shared_types in + let env = Query_env.from_file file in + let rec extract_docs_for_module ?(module_path = [env.file.module_name]) (structure : Module.structure) = - let valuesSeen = ref StringSet.empty in + let values_seen = ref String_set.empty in { - id = modulePath |> List.rev |> ident; + id = module_path |> List.rev |> ident; docstring = structure.docstring |> List.map String.trim; name = structure.name; moduletypeid = None; @@ -421,10 +425,10 @@ let extractDocs ~entryPointFile ~debug = source = { filepath = - (match rootPath = "." with - | true -> file.uri |> Uri.toPath + (match root_path = "." with + | true -> file.uri |> Uri.to_path | false -> - Files.relpath rootPath (file.uri |> Uri.toPath) + Files.relpath root_path (file.uri |> Uri.to_path) |> Files.split Filename.dir_sep |> String.concat "/"); line = 1; @@ -439,50 +443,50 @@ let extractDocs ~entryPointFile ~debug = name = Ext_ident.unwrap_uppercase_exotic item.name; } in - let source = getSource ~rootPath item.loc in + let source = get_source ~root_path item.loc in match item.kind with | Value typ -> Some (Value { - id = modulePath |> makeId ~identifier:item.name; + id = module_path |> make_id ~identifier:item.name; docstring = item.docstring |> List.map String.trim; signature = "let " ^ item.name ^ ": " - ^ Shared.typeToString typ; + ^ Shared.type_to_string typ; name = item.name; deprecated = item.deprecated; - detail = valueDetail typ; + detail = value_detail typ; source; }) | Type (typ, _) -> Some (Type { - id = modulePath |> makeId ~identifier:item.name; + id = module_path |> make_id ~identifier:item.name; docstring = item.docstring |> List.map String.trim; signature = - typ.decl |> Shared.declToString item.name; + typ.decl |> Shared.decl_to_string item.name; name = item.name; deprecated = item.deprecated; - detail = typeDetail typ ~full ~env; + detail = type_detail typ ~full ~env; source; }) - | Module {type_ = Ident p; isModuleType = false} -> + | Module {type_ = Ident p; is_module_type = false} -> (* module Whatever = OtherModule *) - let aliasToModule = p |> pathIdentToString in + let alias_to_module = p |> path_ident_to_string in let id = - (modulePath |> List.rev |> List.hd) ^ "." ^ item.name + (module_path |> List.rev |> List.hd) ^ "." ^ item.name in - let items, internalDocstrings = + let items, internal_docstrings = match - ProcessCmt.fileForModule ~package:full.package - aliasToModule + Process_cmt.file_for_module ~package:full.package + alias_to_module with | None -> ([], []) | Some file -> let docs = - extractDocsForModule ~modulePath:[id] + extract_docs_for_module ~module_path:[id] file.structure in (docs.items, docs.docstring) @@ -495,17 +499,17 @@ let extractDocs ~entryPointFile ~debug = source; items; docstring = - item.docstring @ internalDocstrings + item.docstring @ internal_docstrings |> List.map String.trim; }) - | Module {type_ = Structure m; isModuleType = false} -> + | Module {type_ = Structure m; is_module_type = false} -> (* module Whatever = {} in res or module Whatever: {} in resi. *) - let modulePath = m.name :: modulePath in - let docs = extractDocsForModule ~modulePath m in + let module_path = m.name :: module_path in + let docs = extract_docs_for_module ~module_path m in Some (Module { - id = modulePath |> List.rev |> ident; + id = module_path |> List.rev |> ident; name = m.name; moduletypeid = None; docstring = item.docstring @ m.docstring; @@ -513,14 +517,14 @@ let extractDocs ~entryPointFile ~debug = source; items = docs.items; }) - | Module {type_ = Structure m; isModuleType = true} -> + | Module {type_ = Structure m; is_module_type = true} -> (* module type Whatever = {} *) - let modulePath = m.name :: modulePath in - let docs = extractDocsForModule ~modulePath m in + let module_path = m.name :: module_path in + let docs = extract_docs_for_module ~module_path m in Some (ModuleType { - id = modulePath |> List.rev |> ident; + id = module_path |> List.rev |> ident; name = m.name; docstring = item.docstring @ m.docstring; deprecated = item.deprecated; @@ -535,25 +539,25 @@ let extractDocs ~entryPointFile ~debug = (* module Whatever: { } = { }. Prefer the interface. *) Some (Module - (extractDocsForModule - ~modulePath:(interface.name :: modulePath) + (extract_docs_for_module + ~module_path:(interface.name :: module_path) interface)) | Module {type_ = Constraint (Structure m, Ident p)} -> (* module M: T = { }. Print M *) let docs = - extractDocsForModule ~modulePath:(m.name :: modulePath) - m + extract_docs_for_module + ~module_path:(m.name :: module_path) m in - let identModulePath = p |> Path.head |> Ident.name in + let ident_module_path = p |> Path.head |> Ident.name in - let moduleTypeIdPath = + let module_type_id_path = match - ProcessCmt.fileForModule ~package:full.package - identModulePath + Process_cmt.file_for_module ~package:full.package + ident_module_path |> Option.is_none with | false -> [] - | true -> [modulePath |> List.rev |> List.hd] + | true -> [module_path |> List.rev |> List.hd] in Some @@ -562,26 +566,26 @@ let extractDocs ~entryPointFile ~debug = docs with moduletypeid = Some - (makeId ~identifier:(Path.name p) - moduleTypeIdPath); + (make_id ~identifier:(Path.name p) + module_type_id_path); }) | _ -> None) (* Filter out shadowed bindings by keeping only the last value associated with an id *) |> List.rev - |> List.filter_map (fun (docItem : docItem) -> - match docItem with + |> List.filter_map (fun (doc_item : doc_item) -> + match doc_item with | Value {id} -> - if StringSet.mem id !valuesSeen then None + if String_set.mem id !values_seen then None else ( - valuesSeen := StringSet.add id !valuesSeen; - Some docItem) - | _ -> Some docItem) + values_seen := String_set.add id !values_seen; + Some doc_item) + | _ -> Some doc_item) |> List.rev; } in - let docs = extractDocsForModule structure in + let docs = extract_docs_for_module structure in Ok - (stringifyDocsForModule ~originalEnv:env docs + (stringify_docs_for_module ~original_env:env docs |> Yojson.Safe.pretty_to_string)) | true -> Error @@ -591,7 +595,7 @@ let extractDocs ~entryPointFile ~debug = result -let extractEmbedded ~extensionPoints ~filename = +let extract_embedded ~extension_points ~filename = let {Res_driver.parsetree = structure} = Res_driver.parsing_engine.parse_implementation ~for_printer:false ~filename in @@ -612,7 +616,7 @@ let extractEmbedded ~extensionPoints ~filename = _ ); }; ] ) - when extensionPoints |> List.exists (fun v -> v = txt) -> + when extension_points |> List.exists (fun v -> v = txt) -> append (pexp_loc, txt, contents) | _ -> ()); Ast_iterator.default_iterator.extension iterator ext @@ -621,20 +625,20 @@ let extractEmbedded ~extensionPoints ~filename = iterator.structure iterator structure; let result = !content - |> List.map (fun (loc, extensionName, contents) -> + |> List.map (fun (loc, extension_name, contents) -> `Assoc [ - ("extensionName", `String extensionName); + ("extensionName", `String extension_name); ("contents", `String contents); ( "loc", - Analysis.Utils.cmtLocToRange loc |> Lsp.Types.Range.yojson_of_t - ); + Analysis.Utils.cmt_loc_to_range loc + |> Lsp.Types.Range.yojson_of_t ); ]) |> List.rev in Yojson.Safe.pretty_to_string (`List result) -let readFile path = +let read_file path = let ic = open_in path in let n = in_channel_length ic in let s = Bytes.create n in @@ -642,7 +646,7 @@ let readFile path = close_in ic; Bytes.to_string s -let isResLang lang = +let is_res_lang lang = match String.lowercase_ascii lang with | "res" | "rescript" | "resi" -> true | lang -> @@ -651,7 +655,7 @@ let isResLang lang = || String.starts_with ~prefix:"rescript " lang || String.starts_with ~prefix:"resi " lang -module FormatCodeblocks = struct +module Format_codeblocks = struct module Transform = struct type transform = AssertEqualFnToEquals (** assertEqual(a, b) -> a == b *) @@ -660,7 +664,7 @@ module FormatCodeblocks = struct match transforms with | [] -> ast | transforms -> - let hasTransform transform = transforms |> List.mem transform in + let has_transform transform = transforms |> List.mem transform in let mapper = { Ast_mapper.default_mapper with @@ -673,12 +677,12 @@ module FormatCodeblocks = struct { pexp_desc = Pexp_ident - ({txt = Lident "assertEqual"} as identTxt); + ({txt = Lident "assertEqual"} as ident_txt); } as ident; partial = false; args = [(Nolabel, _); (Nolabel, _)] as args; } - when hasTransform AssertEqualFnToEquals -> + when has_transform AssertEqualFnToEquals -> { exp with pexp_desc = @@ -688,7 +692,7 @@ module FormatCodeblocks = struct { ident with pexp_desc = - Pexp_ident {identTxt with txt = Lident "=="}; + Pexp_ident {ident_txt with txt = Lident "=="}; }; args; partial = false; @@ -713,7 +717,7 @@ module FormatCodeblocks = struct pexp_desc = Pexp_ident ({txt = Lident "assertEqual"} as - identTxt); + ident_txt); } as ident; partial = false; args = [rhs]; @@ -721,7 +725,7 @@ module FormatCodeblocks = struct } ); ]; } - when hasTransform AssertEqualFnToEquals -> + when has_transform AssertEqualFnToEquals -> { exp with pexp_desc = @@ -731,7 +735,7 @@ module FormatCodeblocks = struct { ident with pexp_desc = - Pexp_ident {identTxt with txt = Lident "=="}; + Pexp_ident {ident_txt with txt = Lident "=="}; }; args = [(Nolabel, lhs); rhs]; partial = false; @@ -744,48 +748,48 @@ module FormatCodeblocks = struct mapper.structure mapper ast end - let formatRescriptCodeBlocks content ~transformAssertEqual ~displayFilename - ~addError ~markdownBlockStartLine = + let format_rescript_code_blocks content ~transform_assert_equal + ~display_filename ~add_error ~markdown_block_start_line = (* Detect ReScript code blocks. *) - let hadCodeBlocks = ref false in + let had_code_blocks = ref false in let block _m = function - | Cmarkit.Block.Code_block (codeBlock, meta) -> ( - match Cmarkit.Block.Code_block.info_string codeBlock with - | Some ((lang, _) as info_string) when isResLang lang -> - hadCodeBlocks := true; + | Cmarkit.Block.Code_block (code_block, meta) -> ( + match Cmarkit.Block.Code_block.info_string code_block with + | Some ((lang, _) as info_string) when is_res_lang lang -> + had_code_blocks := true; - let currentLine = + let current_line = meta |> Cmarkit.Meta.textloc |> Cmarkit.Textloc.first_line |> fst in (* Account for 0-based line numbers *) - let currentLine = currentLine + 1 in - let layout = Cmarkit.Block.Code_block.layout codeBlock in - let code = Cmarkit.Block.Code_block.code codeBlock in - let codeText = + let current_line = current_line + 1 in + let layout = Cmarkit.Block.Code_block.layout code_block in + let code = Cmarkit.Block.Code_block.code code_block in + let code_text = code |> List.map Cmarkit.Block_line.to_string |> String.concat "\n" in let n = List.length code in - let newlinesNeeded = - max 0 (markdownBlockStartLine + currentLine - n) + let newlines_needed = + max 0 (markdown_block_start_line + current_line - n) in - let codeWithOffset = String.make newlinesNeeded '\n' ^ codeText in - let reportParseError diagnostics = + let code_with_offset = String.make newlines_needed '\n' ^ code_text in + let report_parse_error diagnostics = let buf = Buffer.create 1000 in let formatter = Format.formatter_of_buffer buf in Res_diagnostics.print_report ~formatter ~custom_intro:(Some "Syntax error in code block in docstring") - diagnostics codeWithOffset; - addError (Buffer.contents buf) + diagnostics code_with_offset; + add_error (Buffer.contents buf) in - let formattedCode = + let formatted_code = if lang |> String.split_on_char ' ' |> List.hd = "resi" then let {Res_driver.parsetree; comments; invalid; diagnostics} = Res_driver.parse_interface_from_source ~for_printer:true - ~display_filename:displayFilename ~source:codeWithOffset + ~display_filename ~source:code_with_offset in if invalid then ( - reportParseError diagnostics; + report_parse_error diagnostics; code) else Res_printer.print_interface parsetree ~comments @@ -793,14 +797,14 @@ module FormatCodeblocks = struct else let {Res_driver.parsetree; comments; invalid; diagnostics} = Res_driver.parse_implementation_from_source ~for_printer:true - ~display_filename:displayFilename ~source:codeWithOffset + ~display_filename ~source:code_with_offset in if invalid then ( - reportParseError diagnostics; + report_parse_error diagnostics; code) else let parsetree = - if transformAssertEqual then + if transform_assert_equal then Transform.transform ~transforms:[AssertEqualFnToEquals] parsetree else parsetree @@ -809,32 +813,34 @@ module FormatCodeblocks = struct |> String.trim |> Cmarkit.Block_line.list_of_string in - let mappedCodeBlock = - Cmarkit.Block.Code_block.make ~layout ~info_string formattedCode + let mapped_code_block = + Cmarkit.Block.Code_block.make ~layout ~info_string formatted_code in - Cmarkit.Mapper.ret (Cmarkit.Block.Code_block (mappedCodeBlock, meta)) + Cmarkit.Mapper.ret + (Cmarkit.Block.Code_block (mapped_code_block, meta)) | _ -> Cmarkit.Mapper.default) | _ -> Cmarkit.Mapper.default in let mapper = Cmarkit.Mapper.make ~block () in - let newContent = + let new_content = content |> Cmarkit.Doc.of_string ~locs:true |> Cmarkit.Mapper.map_doc mapper |> Cmarkit_commonmark.of_doc in - (newContent, !hadCodeBlocks) + (new_content, !had_code_blocks) - let formatCodeBlocksInFile ~outputMode ~transformAssertEqual ~entryPointFile = + let format_code_blocks_in_file ~output_mode ~transform_assert_equal + ~entry_point_file = let path = - match Filename.is_relative entryPointFile with - | true -> Unix.realpath entryPointFile - | false -> entryPointFile + match Filename.is_relative entry_point_file with + | true -> Unix.realpath entry_point_file + | false -> entry_point_file in let errors = ref [] in - let addError error = errors := error :: !errors in + let add_error error = errors := error :: !errors in - let makeMapper ~transformAssertEqual ~displayFilename = + let make_mapper ~transform_assert_equal ~display_filename = { Ast_mapper.default_mapper with attribute = @@ -843,18 +849,19 @@ module FormatCodeblocks = struct | ( {txt = "res.doc"}, Some (contents, None), PStr [{pstr_desc = Pstr_eval ({pexp_loc}, _)}] ) -> - let formattedContents, hadCodeBlocks = - formatRescriptCodeBlocks ~transformAssertEqual ~addError - ~displayFilename - ~markdownBlockStartLine:pexp_loc.loc_start.pos_lnum contents + let formatted_contents, had_code_blocks = + format_rescript_code_blocks ~transform_assert_equal ~add_error + ~display_filename + ~markdown_block_start_line:pexp_loc.loc_start.pos_lnum + contents in - if hadCodeBlocks && formattedContents <> contents then + if had_code_blocks && formatted_contents <> contents then ( name, PStr [ Ast_helper.Str.eval (Ast_helper.Exp.constant - (Pconst_string (formattedContents, None))); + (Pconst_string (formatted_contents, None))); ] ) else attr | _ -> Ast_mapper.default_mapper.attribute mapper attr); @@ -862,14 +869,14 @@ module FormatCodeblocks = struct in let content = if Filename.check_suffix path ".md" then - let content = readFile path in - let displayFilename = Filename.basename path in - let formattedContents, hadCodeBlocks = - formatRescriptCodeBlocks ~transformAssertEqual ~addError - ~displayFilename ~markdownBlockStartLine:1 content + let content = read_file path in + let display_filename = Filename.basename path in + let formatted_contents, had_code_blocks = + format_rescript_code_blocks ~transform_assert_equal ~add_error + ~display_filename ~markdown_block_start_line:1 content in - if hadCodeBlocks && formattedContents <> content then - Ok (formattedContents, content) + if had_code_blocks && formatted_contents <> content then + Ok (formatted_contents, content) else Ok (content, content) else if Filename.check_suffix path ".res" then let parser = @@ -880,10 +887,10 @@ module FormatCodeblocks = struct in let filename = Filename.basename filename in let mapper = - makeMapper ~transformAssertEqual ~displayFilename:filename + make_mapper ~transform_assert_equal ~display_filename:filename in - let astMapped = mapper.structure mapper structure in - Ok (Res_printer.print_implementation astMapped ~comments, source) + let ast_mapped = mapper.structure mapper structure in + Ok (Res_printer.print_implementation ast_mapped ~comments, source) else if Filename.check_suffix path ".resi" then let parser = Res_driver.parsing_engine.parse_interface ~for_printer:true @@ -892,10 +899,10 @@ module FormatCodeblocks = struct parser ~filename:path in let mapper = - makeMapper ~transformAssertEqual ~displayFilename:filename + make_mapper ~transform_assert_equal ~display_filename:filename in - let astMapped = mapper.signature mapper signature in - Ok (Res_printer.print_interface astMapped ~comments, source) + let ast_mapped = mapper.signature mapper signature in + Ok (Res_printer.print_interface ast_mapped ~comments, source) else Error (Printf.sprintf @@ -912,7 +919,7 @@ module FormatCodeblocks = struct (Printf.sprintf "%s: Error formatting docstrings." (Filename.basename path))) else if formatted_content <> source then ( - match outputMode with + match output_mode with | `Stdout -> Ok formatted_content | `File -> let oc = open_out path in @@ -922,7 +929,7 @@ module FormatCodeblocks = struct else Ok (Filename.basename path ^ ": needed no formatting") end -module ExtractCodeblocks = struct +module Extract_codeblocks = struct module Transform = struct type transform = | EqualsToAssertEqualFn @@ -932,7 +939,7 @@ module ExtractCodeblocks = struct match transforms with | [] -> ast | transforms -> - let hasTransform transform = transforms |> List.mem transform in + let has_transform transform = transforms |> List.mem transform in let mapper = { Ast_mapper.default_mapper with @@ -948,14 +955,14 @@ module ExtractCodeblocks = struct { pexp_desc = Pexp_ident - ({txt = Lident "=="} as identTxt); + ({txt = Lident "=="} as ident_txt); } as ident; partial = false; args = [(Nolabel, _); (Nolabel, _)] as args; }; } as exp), x1 ) - when hasTransform EqualsToAssertEqualFn -> + when has_transform EqualsToAssertEqualFn -> { str_item with pstr_desc = @@ -971,7 +978,7 @@ module ExtractCodeblocks = struct pexp_desc = Pexp_ident { - identTxt with + ident_txt with txt = Lident "assertEqual"; }; }; @@ -988,36 +995,36 @@ module ExtractCodeblocks = struct mapper.structure mapper ast end - type codeBlock = {id: string; code: string; name: string} + type code_block = {id: string; code: string; name: string} - let getDocstring = function + let get_docstring = function | d :: _ -> d | _ -> "" - let extractCodeBlocks ~entryPointFile - ~(processDocstrings : id:string -> name:string -> string -> unit) = + let extract_code_blocks ~entry_point_file + ~(process_docstrings : id:string -> name:string -> string -> unit) = let path = - match Filename.is_relative entryPointFile with - | true -> Unix.realpath entryPointFile - | false -> entryPointFile + match Filename.is_relative entry_point_file with + | true -> Unix.realpath entry_point_file + | false -> entry_point_file in let result = match - FindFiles.isImplementation path = false - && FindFiles.isInterface path = false + Find_files.is_implementation path = false + && Find_files.is_interface path = false with | false -> ( let path = - if FindFiles.isImplementation path then - let pathAsResi = + if Find_files.is_implementation path then + let path_as_resi = (path |> Filename.dirname) ^ "/" ^ (path |> Filename.basename |> Filename.chop_extension) ^ ".resi" in - if Sys.file_exists pathAsResi then pathAsResi else path + if Sys.file_exists path_as_resi then path_as_resi else path else path in - match Cmt.loadFullCmtFromPath ~path with + match Cmt.load_full_cmt_from_path ~path with | None -> Error (Printf.sprintf @@ -1026,69 +1033,69 @@ module ExtractCodeblocks = struct | Some full -> let file = full.file in let structure = file.structure in - let open SharedTypes in - let env = QueryEnv.fromFile file in - let rec extractCodeBlocksForModule - ?(modulePath = [env.file.moduleName]) + let open Shared_types in + let env = Query_env.from_file file in + let rec extract_code_blocks_for_module + ?(module_path = [env.file.module_name]) (structure : Module.structure) = - let id = modulePath |> List.rev |> ident in + let id = module_path |> List.rev |> ident in let name = structure.name in - processDocstrings ~id ~name (getDocstring structure.docstring); + process_docstrings ~id ~name (get_docstring structure.docstring); structure.items |> List.iter (fun (item : Module.item) -> match item.kind with | Value _typ -> - let id = modulePath |> makeId ~identifier:item.name in + let id = module_path |> make_id ~identifier:item.name in let name = item.name in - processDocstrings ~id ~name (getDocstring item.docstring) + process_docstrings ~id ~name (get_docstring item.docstring) | Type (_typ, _) -> - let id = modulePath |> makeId ~identifier:item.name in + let id = module_path |> make_id ~identifier:item.name in let name = item.name in - processDocstrings ~id ~name (getDocstring item.docstring) - | Module {type_ = Ident _p; isModuleType = false} -> + process_docstrings ~id ~name (get_docstring item.docstring) + | Module {type_ = Ident _p; is_module_type = false} -> (* module Whatever = OtherModule *) let id = - (modulePath |> List.rev |> List.hd) ^ "." ^ item.name + (module_path |> List.rev |> List.hd) ^ "." ^ item.name in let name = item.name in - processDocstrings ~id ~name (getDocstring item.docstring) - | Module {type_ = Structure m; isModuleType = false} -> + process_docstrings ~id ~name (get_docstring item.docstring) + | Module {type_ = Structure m; is_module_type = false} -> (* module Whatever = {} in res or module Whatever: {} in resi. *) - let modulePath = m.name :: modulePath in - let id = modulePath |> List.rev |> ident in + let module_path = m.name :: module_path in + let id = module_path |> List.rev |> ident in let name = m.name in - processDocstrings ~id ~name (getDocstring m.docstring); - extractCodeBlocksForModule ~modulePath m - | Module {type_ = Structure m; isModuleType = true} -> + process_docstrings ~id ~name (get_docstring m.docstring); + extract_code_blocks_for_module ~module_path m + | Module {type_ = Structure m; is_module_type = true} -> (* module type Whatever = {} *) - let modulePath = m.name :: modulePath in - let id = modulePath |> List.rev |> ident in + let module_path = m.name :: module_path in + let id = module_path |> List.rev |> ident in let name = m.name in - processDocstrings ~id ~name (getDocstring m.docstring); - extractCodeBlocksForModule ~modulePath m + process_docstrings ~id ~name (get_docstring m.docstring); + extract_code_blocks_for_module ~module_path m | Module { type_ = Constraint (Structure _impl, Structure interface); } -> (* module Whatever: { } = { }. Prefer the interface. *) - let modulePath = interface.name :: modulePath in - let id = modulePath |> List.rev |> ident in + let module_path = interface.name :: module_path in + let id = module_path |> List.rev |> ident in let name = interface.name in - processDocstrings ~id ~name - (getDocstring interface.docstring); - extractCodeBlocksForModule ~modulePath interface + process_docstrings ~id ~name + (get_docstring interface.docstring); + extract_code_blocks_for_module ~module_path interface | Module {type_ = Constraint (Structure m, Ident _p)} -> (* module M: T = { }. Print M *) - let modulePath = m.name :: modulePath in - let id = modulePath |> List.rev |> ident in + let module_path = m.name :: module_path in + let id = module_path |> List.rev |> ident in let name = m.name in - processDocstrings ~id ~name (getDocstring m.docstring); - extractCodeBlocksForModule ~modulePath m + process_docstrings ~id ~name (get_docstring m.docstring); + extract_code_blocks_for_module ~module_path m | Module.Module _ -> ()) in - extractCodeBlocksForModule structure; + extract_code_blocks_for_module structure; Ok ()) | true -> Error @@ -1098,59 +1105,59 @@ module ExtractCodeblocks = struct result - let extractRescriptCodeBlocks content ~transformAssertEqual ~displayFilename - ~addError ~markdownBlockStartLine = + let extract_rescript_code_blocks content ~transform_assert_equal + ~display_filename ~add_error ~markdown_block_start_line = (* Detect ReScript code blocks. *) - let codeBlocks = ref [] in - let addCodeBlock codeBlock = codeBlocks := codeBlock :: !codeBlocks in + let code_blocks = ref [] in + let add_code_block code_block = code_blocks := code_block :: !code_blocks in let block _m = function - | Cmarkit.Block.Code_block (codeBlock, meta) -> ( - match Cmarkit.Block.Code_block.info_string codeBlock with - | Some (lang, _) when isResLang lang -> - let currentLine = + | Cmarkit.Block.Code_block (code_block, meta) -> ( + match Cmarkit.Block.Code_block.info_string code_block with + | Some (lang, _) when is_res_lang lang -> + let current_line = meta |> Cmarkit.Meta.textloc |> Cmarkit.Textloc.first_line |> fst in (* Account for 0-based line numbers *) - let currentLine = currentLine + 1 in - let code = Cmarkit.Block.Code_block.code codeBlock in - let codeText = + let current_line = current_line + 1 in + let code = Cmarkit.Block.Code_block.code code_block in + let code_text = code |> List.map Cmarkit.Block_line.to_string |> String.concat "\n" in let n = List.length code in - let newlinesNeeded = - max 0 (markdownBlockStartLine + currentLine - n) + let newlines_needed = + max 0 (markdown_block_start_line + current_line - n) in - let codeWithOffset = String.make newlinesNeeded '\n' ^ codeText in - let reportParseError diagnostics = + let code_with_offset = String.make newlines_needed '\n' ^ code_text in + let report_parse_error diagnostics = let buf = Buffer.create 1000 in let formatter = Format.formatter_of_buffer buf in Res_diagnostics.print_report ~formatter ~custom_intro:(Some "Syntax error in code block in docstring") - diagnostics codeWithOffset; - addError (Buffer.contents buf) + diagnostics code_with_offset; + add_error (Buffer.contents buf) in - let mappedCode = + let mapped_code = if lang |> String.split_on_char ' ' |> List.hd = "resi" then let {Res_driver.parsetree; comments; invalid; diagnostics} = Res_driver.parse_interface_from_source ~for_printer:true - ~display_filename:displayFilename ~source:codeWithOffset + ~display_filename ~source:code_with_offset in if invalid then ( - reportParseError diagnostics; - codeText) + report_parse_error diagnostics; + code_text) else Res_printer.print_interface parsetree ~comments |> String.trim else let {Res_driver.parsetree; comments; invalid; diagnostics} = Res_driver.parse_implementation_from_source ~for_printer:true - ~display_filename:displayFilename ~source:codeWithOffset + ~display_filename ~source:code_with_offset in if invalid then ( - reportParseError diagnostics; - codeText) + report_parse_error diagnostics; + code_text) else let parsetree = - if transformAssertEqual then + if transform_assert_equal then Transform.transform ~transforms:[EqualsToAssertEqualFn] parsetree else parsetree @@ -1158,7 +1165,7 @@ module ExtractCodeblocks = struct Res_printer.print_implementation parsetree ~comments |> String.trim in - addCodeBlock mappedCode; + add_code_block mapped_code; Cmarkit.Mapper.default | _ -> Cmarkit.Mapper.default) | _ -> Cmarkit.Mapper.default @@ -1169,68 +1176,68 @@ module ExtractCodeblocks = struct |> Cmarkit.Doc.of_string ~locs:true |> Cmarkit.Mapper.map_doc mapper in - !codeBlocks + !code_blocks - let extractCodeblocksFromFile ~transformAssertEqual ~entryPointFile = + let extract_codeblocks_from_file ~transform_assert_equal ~entry_point_file = let path = - match Filename.is_relative entryPointFile with - | true -> Unix.realpath entryPointFile - | false -> entryPointFile + match Filename.is_relative entry_point_file with + | true -> Unix.realpath entry_point_file + | false -> entry_point_file in - let displayFilename = Filename.basename path in + let display_filename = Filename.basename path in let errors = ref [] in - let addError error = errors := error :: !errors in + let add_error error = errors := error :: !errors in - let codeBlocks = ref [] in - let addCodeBlock codeBlock = codeBlocks := codeBlock :: !codeBlocks in + let code_blocks = ref [] in + let add_code_block code_block = code_blocks := code_block :: !code_blocks in let content = if Filename.check_suffix path ".md" then - let content = readFile path in - let displayFilename = Filename.basename path in - let codeBlocks = - extractRescriptCodeBlocks ~transformAssertEqual ~addError - ~displayFilename ~markdownBlockStartLine:1 content + let content = read_file path in + let display_filename = Filename.basename path in + let code_blocks = + extract_rescript_code_blocks ~transform_assert_equal ~add_error + ~display_filename ~markdown_block_start_line:1 content in Ok - (codeBlocks - |> List.mapi (fun index codeBlock -> + (code_blocks + |> List.mapi (fun index code_block -> { id = "codeblock-" ^ string_of_int (index + 1); name = "codeblock-" ^ string_of_int (index + 1); - code = codeBlock; + code = code_block; })) else let extracted = - extractCodeBlocks ~entryPointFile - ~processDocstrings:(fun ~id ~name code -> - let codeBlocks = + extract_code_blocks ~entry_point_file + ~process_docstrings:(fun ~id ~name code -> + let code_blocks = code - |> extractRescriptCodeBlocks ~transformAssertEqual ~addError - ~displayFilename ~markdownBlockStartLine:1 + |> extract_rescript_code_blocks ~transform_assert_equal + ~add_error ~display_filename ~markdown_block_start_line:1 in - if List.length codeBlocks > 1 then - codeBlocks |> List.rev - |> List.iteri (fun index codeBlock -> - addCodeBlock + if List.length code_blocks > 1 then + code_blocks |> List.rev + |> List.iteri (fun index code_block -> + add_code_block { id = id ^ "-" ^ string_of_int (index + 1); name; - code = codeBlock; + code = code_block; }) else - codeBlocks - |> List.iter (fun codeBlock -> - addCodeBlock {id; name; code = codeBlock})) + code_blocks + |> List.iter (fun code_block -> + add_code_block {id; name; code = code_block})) in match extracted with - | Ok () -> Ok !codeBlocks + | Ok () -> Ok !code_blocks | Error e -> Error e in match content with | Error e -> Error e - | Ok codeBlocks -> + | Ok code_blocks -> let errors = !errors in if List.length errors > 0 then let errors = errors |> List.rev |> String.concat "\n" in @@ -1239,13 +1246,13 @@ module ExtractCodeblocks = struct Ok (Yojson.Safe.pretty_to_string ~std:true (`List - (codeBlocks - |> List.map (fun codeBlock -> + (code_blocks + |> List.map (fun code_block -> `Assoc [ - ("id", `String codeBlock.id); - ("name", `String codeBlock.name); - ("code", `String codeBlock.code); + ("id", `String code_block.id); + ("name", `String code_block.name); + ("code", `String code_block.code); ])))) end diff --git a/tools/src/transforms.ml b/tools/src/transforms.ml index 694a5c4e4b6..e4b549c5e95 100644 --- a/tools/src/transforms.ml +++ b/tools/src/transforms.ml @@ -1,7 +1,7 @@ -let labelledToUnlabelledArgumentsInFnDefinition (e : Parsetree.expression) : - Parsetree.expression = +let labelled_to_unlabelled_arguments_in_fn_definition (e : Parsetree.expression) + : Parsetree.expression = (* `(~a, ~b, ~c) => ...` to `(a, b, c) => ...` *) - let rec dropLabels (e : Parsetree.expression) : Parsetree.expression = + let rec drop_labels (e : Parsetree.expression) : Parsetree.expression = match e.pexp_desc with | Pexp_fun {arg_label = Labelled _ | Optional _; default; lhs; rhs; arity; async} @@ -14,7 +14,7 @@ let labelledToUnlabelledArgumentsInFnDefinition (e : Parsetree.expression) : arg_label = Nolabel; default; lhs; - rhs = dropLabels rhs; + rhs = drop_labels rhs; arity; async; }; @@ -23,28 +23,30 @@ let labelledToUnlabelledArgumentsInFnDefinition (e : Parsetree.expression) : { e with pexp_desc = - Pexp_fun {arg_label; default; lhs; rhs = dropLabels rhs; arity; async}; + Pexp_fun + {arg_label; default; lhs; rhs = drop_labels rhs; arity; async}; } | _ -> e in - dropLabels e + drop_labels e -let makerFnToRecord (e : Parsetree.expression) : Parsetree.expression = +let maker_fn_to_record (e : Parsetree.expression) : Parsetree.expression = (* `ReactDOM.Style.make(~width="12px", ~height="12px", ())` to `{height: "12px", width: "12px"}` *) e -let dictFromArrayToDictLiteralSyntax (e : Parsetree.expression) : +let dict_from_array_to_dict_literal_syntax (e : Parsetree.expression) : Parsetree.expression = (* `Dict.fromArray([("a", 1), ("b", 2)])` to `dict{"a": 1, "b": 2}` *) (* Elgible if all keys are strings *) e -let convertedLiteralToPureLiteral (e : Parsetree.expression) : +let converted_literal_to_pure_literal (e : Parsetree.expression) : Parsetree.expression = (* `Float.fromInt(1)` to `1.`, *) e -let dropUnitArgumentsInApply (e : Parsetree.expression) : Parsetree.expression = +let drop_unit_arguments_in_apply (e : Parsetree.expression) : + Parsetree.expression = (* Drop only unlabelled unit arguments from an application expression. *) let is_unit_expr (e : Parsetree.expression) = match e.pexp_desc with @@ -73,11 +75,11 @@ type transform = Parsetree.expression -> Parsetree.expression let registry : (string * transform) list = [ ( "labelledToUnlabelledArgumentsInFnDefinition", - labelledToUnlabelledArgumentsInFnDefinition ); - ("makerFnToRecord", makerFnToRecord); - ("dictFromArrayToDictLiteralSyntax", dictFromArrayToDictLiteralSyntax); - ("convertedLiteralToPureLiteral", convertedLiteralToPureLiteral); - ("dropUnitArgumentsInApply", dropUnitArgumentsInApply); + labelled_to_unlabelled_arguments_in_fn_definition ); + ("makerFnToRecord", maker_fn_to_record); + ("dictFromArrayToDictLiteralSyntax", dict_from_array_to_dict_literal_syntax); + ("convertedLiteralToPureLiteral", converted_literal_to_pure_literal); + ("dropUnitArgumentsInApply", drop_unit_arguments_in_apply); ] let get (id : string) : transform option = List.assoc_opt id registry