From f9aa0f777622275a55b8946a00c70cd83b4eafac Mon Sep 17 00:00:00 2001 From: Pedro Castro Date: Sun, 31 May 2026 09:08:49 -0300 Subject: [PATCH 1/5] Convert to snake case --- analysis/bin/main.ml | 102 +- analysis/reactive/src/Reactive.ml | 2 +- analysis/reactive/src/Reactive.mli | 2 +- analysis/reactive/test/BatchTest.ml | 2 +- analysis/reactive/test/FlatMapTest.ml | 10 +- analysis/reactive/test/GlitchFreeTest.ml | 48 +- analysis/reactive/test/IntegrationTest.ml | 4 +- analysis/reanalyze/src/AnalysisResult.ml | 10 +- analysis/reanalyze/src/AnalysisResult.mli | 4 +- analysis/reanalyze/src/Annotation.ml | 36 +- analysis/reanalyze/src/Arnold.ml | 1066 ++++----- analysis/reanalyze/src/Cli.ml | 10 +- analysis/reanalyze/src/CollectAnnotations.ml | 132 +- analysis/reanalyze/src/CollectAnnotations.mli | 2 +- analysis/reanalyze/src/CrossFileItems.ml | 6 +- analysis/reanalyze/src/CrossFileItemsStore.ml | 8 +- analysis/reanalyze/src/DceConfig.ml | 8 +- analysis/reanalyze/src/DceFileProcessing.ml | 28 +- analysis/reanalyze/src/DceFileProcessing.mli | 2 +- analysis/reanalyze/src/DcePath.ml | 36 +- analysis/reanalyze/src/DeadCode.ml | 2 +- analysis/reanalyze/src/DeadCommon.ml | 314 +-- analysis/reanalyze/src/DeadException.ml | 30 +- analysis/reanalyze/src/DeadException.mli | 10 +- analysis/reanalyze/src/DeadModules.ml | 26 +- analysis/reanalyze/src/DeadOptionalArgs.ml | 86 +- analysis/reanalyze/src/DeadType.ml | 142 +- analysis/reanalyze/src/DeadValue.ml | 356 +-- analysis/reanalyze/src/Decl.ml | 50 +- analysis/reanalyze/src/EmitJson.ml | 26 +- analysis/reanalyze/src/Exception.ml | 490 ++--- analysis/reanalyze/src/Exceptions.ml | 38 +- analysis/reanalyze/src/Exn.ml | 28 +- analysis/reanalyze/src/Exn.mli | 28 +- analysis/reanalyze/src/ExnLib.ml | 380 ++-- analysis/reanalyze/src/FileDeps.ml | 90 +- analysis/reanalyze/src/Issue.ml | 22 +- analysis/reanalyze/src/Issues.ml | 28 +- analysis/reanalyze/src/Liveness.ml | 56 +- analysis/reanalyze/src/Log_.ml | 168 +- analysis/reanalyze/src/ModulePath.ml | 26 +- analysis/reanalyze/src/Name.ml | 20 +- analysis/reanalyze/src/Name.mli | 12 +- analysis/reanalyze/src/OptionalArgs.ml | 42 +- analysis/reanalyze/src/Paths.ml | 78 +- analysis/reanalyze/src/Pos.ml | 2 +- analysis/reanalyze/src/ReactiveAnalysis.ml | 38 +- analysis/reanalyze/src/ReactiveDeclRefs.ml | 22 +- .../reanalyze/src/ReactiveExceptionRefs.ml | 30 +- analysis/reanalyze/src/ReactiveLiveness.ml | 10 +- analysis/reanalyze/src/ReactiveMerge.ml | 58 +- analysis/reanalyze/src/ReactiveSolver.ml | 66 +- analysis/reanalyze/src/ReactiveTypeDeps.ml | 44 +- analysis/reanalyze/src/Reanalyze.ml | 220 +- analysis/reanalyze/src/ReanalyzeServer.ml | 22 +- analysis/reanalyze/src/References.ml | 14 +- analysis/reanalyze/src/References.mli | 4 +- analysis/reanalyze/src/RunConfig.ml | 48 +- analysis/reanalyze/src/SideEffects.ml | 74 +- analysis/reanalyze/src/Suppress.ml | 46 +- analysis/src/BuildSystem.ml | 26 +- analysis/src/Cache.ml | 32 +- analysis/src/Cfg.ml | 8 +- analysis/src/Cli.ml | 284 +-- analysis/src/Cmt.ml | 72 +- analysis/src/CmtViewer.ml | 68 +- analysis/src/CodeActions.ml | 16 +- analysis/src/Codemod.ml | 30 +- analysis/src/Commands.ml | 230 +- analysis/src/CompletionBackEnd.ml | 1924 ++++++++--------- analysis/src/CompletionExpressions.ml | 286 +-- analysis/src/CompletionFrontEnd.ml | 1376 ++++++------ analysis/src/CompletionJsx.ml | 184 +- analysis/src/CompletionPatterns.ml | 252 +-- analysis/src/Completions.ml | 12 +- analysis/src/CreateInterface.ml | 260 +-- analysis/src/DceCommand.ml | 2 +- analysis/src/Debug.ml | 12 +- analysis/src/Diagnostics.ml | 14 +- analysis/src/DocumentSymbol.ml | 108 +- analysis/src/DotCompletionUtils.ml | 48 +- analysis/src/DumpAst.ml | 302 +-- analysis/src/Files.ml | 64 +- analysis/src/FindFiles.ml | 212 +- analysis/src/Hint.ml | 70 +- analysis/src/Hover.ml | 250 +-- analysis/src/JsxHacks.ml | 4 +- analysis/src/Loc.ml | 22 +- analysis/src/LocalTables.ml | 66 +- analysis/src/Markdown.ml | 24 +- analysis/src/ModuleResolution.ml | 8 +- analysis/src/Packages.ml | 168 +- analysis/src/PipeCompletionUtils.ml | 22 +- analysis/src/Pos.ml | 20 +- analysis/src/PrintType.ml | 10 +- analysis/src/ProcessAttributes.ml | 38 +- analysis/src/ProcessCmt.ml | 450 ++-- analysis/src/ProcessExtra.ml | 328 +-- analysis/src/Range.ml | 6 +- analysis/src/References.ml | 416 ++-- analysis/src/ResolvePath.ml | 122 +- analysis/src/Scope.ml | 102 +- analysis/src/SemanticTokens.ml | 230 +- analysis/src/Shared.ml | 28 +- analysis/src/SharedTypes.ml | 618 +++--- analysis/src/SignatureHelp.ml | 472 ++-- analysis/src/StructureUtils.ml | 6 +- analysis/src/TypeUtils.ml | 1072 ++++----- analysis/src/Uri.ml | 24 +- analysis/src/Uri.mli | 16 +- analysis/src/Utils.ml | 100 +- analysis/src/Xform.ml | 748 +++---- compiler/core/js_dump.ml | 18 +- compiler/gentype/Paths.ml | 4 +- compiler/ml/ctype.ml | 4 +- compiler/ml/ctype.mli | 2 +- compiler/ml/printtyp.ml | 2 +- compiler/syntax/src/jsx_v4.ml | 12 +- compiler/syntax/src/res_comments_table.ml | 4 +- compiler/syntax/src/res_core.ml | 14 +- compiler/syntax/src/res_scanner.ml | 6 +- compiler/syntax/src/res_scanner.mli | 4 +- tests/ounit_tests/ounit_unicode_tests.ml | 8 +- tools/bin/main.ml | 102 +- tools/src/migrate.ml | 34 +- tools/src/migrate.mli | 4 +- tools/src/tools.ml | 680 +++--- tools/src/transforms.ml | 28 +- 128 files changed, 8476 insertions(+), 8476 deletions(-) diff --git a/analysis/bin/main.ml b/analysis/bin/main.ml index 98b66acc7f..762ae2807c 100644 --- a/analysis/bin/main.ml +++ b/analysis/bin/main.ml @@ -93,111 +93,111 @@ 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 BuildSystem.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 + Cli.type_definition ~path ~pos:(int_of_string line, int_of_string col) ~debug | [_; "documentSymbol"; path] -> DocumentSymbol.command ~path - | [_; "hover"; path; line; col; currentFile; supportsMarkdownLinks] -> + | [_; "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] + ~max_length ~debug + | [_; "codeLens"; path] -> Cli.code_lens ~path ~debug + | [_; "codeAction"; path; start_line; start_col; end_line; end_col; current_file] -> - Cli.codeAction ~path - ~startPos:(int_of_string startLine, int_of_string startCol) - ~endPos:(int_of_string endLine, int_of_string endCol) - ~currentFile ~debug + 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 (CreateInterface.command ~path ~cmi_file) |> Yojson.Safe.pretty_to_string ~std:true |> print_endline | [_; "format"; path] -> Cli.format ~path diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 9db201901d..903156d9a8 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 diff --git a/analysis/reactive/src/Reactive.mli b/analysis/reactive/src/Reactive.mli index cadaecc969..b666907d5b 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/test/BatchTest.ml b/analysis/reactive/test/BatchTest.ml index 4c750d16cf..54ca68d5c4 100644 --- a/analysis/reactive/test/BatchTest.ml +++ b/analysis/reactive/test/BatchTest.ml @@ -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/FlatMapTest.ml b/analysis/reactive/test/FlatMapTest.ml index b9d2050469..d09261880c 100644 --- a/analysis/reactive/test/FlatMapTest.ml +++ b/analysis/reactive/test/FlatMapTest.ml @@ -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,7 +56,7 @@ 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 () in @@ -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/GlitchFreeTest.ml index 3954075877..dd354ca0ac 100644 --- a/analysis/reactive/test/GlitchFreeTest.ml +++ b/analysis/reactive/test/GlitchFreeTest.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/IntegrationTest.ml index 428a1b2f8e..8b37317c6c 100644 --- a/analysis/reactive/test/IntegrationTest.ml +++ b/analysis/reactive/test/IntegrationTest.ml @@ -15,7 +15,7 @@ let test_file_collection () = (* First flatMap: aggregate word counts across files with merge *) let word_counts = - flatMap ~name:"word_counts" files + flat_map ~name:"word_counts" files ~f:(fun _path counts -> StringMap.bindings counts) (* Each file contributes its word counts *) ~merge:( + ) (* Sum counts from multiple files *) @@ -24,7 +24,7 @@ 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 diff --git a/analysis/reanalyze/src/AnalysisResult.ml b/analysis/reanalyze/src/AnalysisResult.ml index dd145b4c4b..a2075b67d5 100644 --- a/analysis/reanalyze/src/AnalysisResult.ml +++ b/analysis/reanalyze/src/AnalysisResult.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/AnalysisResult.mli index beee4e4d4e..1fd429ad04 100644 --- a/analysis/reanalyze/src/AnalysisResult.mli +++ b/analysis/reanalyze/src/AnalysisResult.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 index ad522762dd..f9df3d9e91 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/Arnold.ml b/analysis/reanalyze/src/Arnold.ml index f648408022..4125aa0496 100644 --- a/analysis/reanalyze/src/Arnold.ml +++ b/analysis/reanalyze/src/Arnold.ml @@ -1,4 +1,4 @@ -let printPos ppf (pos : Lexing.position) = +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@}" @@ -13,26 +13,26 @@ module FunctionName = struct end module FunctionArgs = struct - type arg = {label: string; functionName: FunctionName.t} + type arg = {label: string; function_name: FunctionName.t} type t = arg list let empty = [] - let argToString {label; functionName} = label ^ ":" ^ functionName + let arg_to_string {label; function_name} = label ^ ":" ^ function_name - let toString functionArgs = - match functionArgs = [] with + let to_string function_args = + match function_args = [] with | true -> "" | false -> - "<" ^ (functionArgs |> List.map argToString |> String.concat ",") ^ ">" + "<" ^ (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 {functionName} -> Some functionName + | Some {function_name} -> Some function_name | None -> None - let compareArg a1 a2 = + let compare_arg a1 a2 = let n = compare a1.label a2.label in - if n <> 0 then n else compare a1.functionName a2.functionName + if n <> 0 then n else compare a1.function_name a2.function_name let rec compare l1 l2 = match (l1, l2) with @@ -40,78 +40,78 @@ module FunctionArgs = struct | [], _ :: _ -> -1 | _ :: _, [] -> 1 | x1 :: l1, x2 :: l2 -> - let n = compareArg x1 x2 in + let n = compare_arg x1 x2 in if n <> 0 then n else compare l1 l2 end module FunctionCall = struct - type t = {functionName: FunctionName.t; functionArgs: FunctionArgs.t} + type t = {function_name: FunctionName.t; function_args: FunctionArgs.t} - let substituteName ~sub name = + let substitute_name ~sub name = match sub |> FunctionArgs.find ~label:name with - | Some functionName -> functionName + | Some function_name -> function_name | None -> name - let applySubstitution ~(sub : FunctionArgs.t) (t : t) = + let apply_substitution ~(sub : FunctionArgs.t) (t : t) = if sub = [] then t else { - functionName = t.functionName |> substituteName ~sub; - functionArgs = - t.functionArgs + function_name = t.function_name |> substitute_name ~sub; + function_args = + t.function_args |> List.map (fun (arg : FunctionArgs.arg) -> { arg with - functionName = arg.functionName |> substituteName ~sub; + function_name = arg.function_name |> substitute_name ~sub; }); } - let noArgs functionName = {functionName; functionArgs = []} + let no_args function_name = {function_name; function_args = []} - let toString {functionName; functionArgs} = - functionName ^ FunctionArgs.toString functionArgs + let to_string {function_name; function_args} = + function_name ^ FunctionArgs.to_string function_args 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 + let n = compare x1.function_name x2.function_name in + if n <> 0 then n else FunctionArgs.compare x1.function_args x2.function_args 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 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@}@," !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 "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 newFile () = incr nFiles + let new_file () = incr n_files - let newRecursiveFunctions ~numFunctions = - incr nRecursiveBlocks; - nFunctions := !nFunctions + numFunctions + let new_recursive_functions ~num_functions = + incr n_recursive_blocks; + n_functions := !n_functions + num_functions - let logLoop () = incr nInfiniteLoops + let log_loop () = incr n_infinite_loops - let logCache ~config ~functionCall ~hit ~loc = - incr nCacheChecks; - if hit then incr nCacheHits; + let log_cache ~config ~function_call ~hit ~loc = + incr n_cache_checks; + if hit then incr n_cache_hits; if config.DceConfig.cli.debug then - Log_.warning ~forStats:false ~loc + Log_.warning ~for_stats:false ~loc (Termination { termination = TerminationAnalysisInternal; @@ -120,23 +120,23 @@ module Stats = struct (match hit with | true -> "hit" | false -> "miss") - (FunctionCall.toString functionCall); + (FunctionCall.to_string function_call); }) - let logResult ~config ~functionCall ~loc ~resString = + let log_result ~config ~function_call ~loc ~res_string = if config.DceConfig.cli.debug then - Log_.warning ~forStats:false ~loc + Log_.warning ~for_stats:false ~loc (Termination { termination = TerminationAnalysisInternal; message = Format.asprintf "@{%s@} returns %s" - (FunctionCall.toString functionCall) - resString; + (FunctionCall.to_string function_call) + res_string; }) - let logHygieneParametric ~functionName ~loc = - incr nHygieneErrors; + let log_hygiene_parametric ~function_name ~loc = + incr n_hygiene_errors; Log_.error ~loc (Termination { @@ -144,11 +144,11 @@ module Stats = struct message = Format.asprintf "@{%s@} cannot be analyzed directly as it is parametric" - functionName; + function_name; }) - let logHygieneOnlyCallDirectly ~path ~loc = - incr nHygieneErrors; + let log_hygiene_only_call_directly ~path ~loc = + incr n_hygiene_errors; Log_.error ~loc (Termination { @@ -160,8 +160,8 @@ module Stats = struct (Path.name path); }) - let logHygieneMustHaveNamedArgument ~label ~loc = - incr nHygieneErrors; + let log_hygiene_must_have_named_argument ~label ~loc = + incr n_hygiene_errors; Log_.error ~loc (Termination { @@ -170,8 +170,8 @@ module Stats = struct Format.asprintf "Call must have named argument @{%s@}" label; }) - let logHygieneNamedArgValue ~label ~loc = - incr nHygieneErrors; + let log_hygiene_named_arg_value ~label ~loc = + incr n_hygiene_errors; Log_.error ~loc (Termination { @@ -183,8 +183,8 @@ module Stats = struct label; }) - let logHygieneNoNestedLetRec ~loc = - incr nHygieneErrors; + let log_hygiene_no_nested_let_rec ~loc = + incr n_hygiene_errors; Log_.error ~loc (Termination { @@ -196,32 +196,32 @@ end module Progress = struct type t = Progress | NoProgress - let toString progress = + let to_string progress = match progress = Progress with | true -> "Progress" | false -> "NoProgress" end module Call = struct - type progressFunction = Path.t + type progress_function = Path.t type t = | FunctionCall of FunctionCall.t - | ProgressFunction of progressFunction + | ProgressFunction of progress_function - let toString call = + let to_string call = match call with - | ProgressFunction progressFunction -> "+" ^ Path.name progressFunction - | FunctionCall functionCall -> FunctionCall.toString functionCall + | ProgressFunction progress_function -> "+" ^ Path.name progress_function + | FunctionCall function_call -> FunctionCall.to_string function_call end module Trace = struct - type retOption = Rsome | Rnone + type ret_option = Rsome | Rnone type t = | Tcall of Call.t * Progress.t | Tnondet of t list - | Toption of retOption + | Toption of ret_option | Tseq of t list let empty = Tseq [] @@ -243,51 +243,51 @@ module Trace = struct let some = Toption Rsome let none = Toption Rnone - let retOptionToString r = + let ret_option_to_string r = match r = Rsome with | true -> "Some" | false -> "None" - let rec toString trace = + let rec to_string trace = match trace with - | Tcall (ProgressFunction progressFunction, progress) -> - Path.name progressFunction ^ ":" ^ Progress.toString progress - | Tcall (FunctionCall functionCall, progress) -> - FunctionCall.toString functionCall ^ ":" ^ Progress.toString progress + | Tcall (ProgressFunction progress_function, progress) -> + Path.name progress_function ^ ":" ^ Progress.to_string progress + | Tcall (FunctionCall function_call, progress) -> + FunctionCall.to_string function_call ^ ":" ^ Progress.to_string progress | Tnondet traces -> - "[" ^ (traces |> List.map toString |> String.concat " || ") ^ "]" - | Toption retOption -> retOption |> retOptionToString + "[" ^ (traces |> List.map to_string |> String.concat " || ") ^ "]" + | Toption ret_option -> ret_option |> ret_option_to_string | Tseq traces -> ( - let tracesNotEmpty = traces |> List.filter (( <> ) empty) in - match tracesNotEmpty with + let traces_not_empty = traces |> List.filter (( <> ) empty) in + match traces_not_empty with | [] -> "_" - | [t] -> t |> toString - | _ :: _ -> tracesNotEmpty |> List.map toString |> String.concat "; ") + | [t] -> t |> to_string + | _ :: _ -> traces_not_empty |> List.map to_string |> String.concat "; ") end module Values : sig type t - val getNone : t -> Progress.t option - val getSome : t -> Progress.t option + 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 toString : t -> string + val to_string : t -> string end = struct type t = {none: Progress.t option; some: Progress.t option} - let getNone {none} = none - let getSome {some} = some + let get_none {none} = none + let get_some {some} = some - let toString x = + let to_string x = ((match x.some with | None -> [] - | Some p -> ["some: " ^ Progress.toString p]) + | Some p -> ["some: " ^ Progress.to_string p]) @ match x.none with | None -> [] - | Some p -> ["none: " ^ Progress.toString p]) + | Some p -> ["none: " ^ Progress.to_string p]) |> String.concat ", " let none ~progress = {none = Some progress; some = None} @@ -301,7 +301,7 @@ end = struct (match progress1 = Progress.Progress && progress2 = Progress with | true -> Progress.Progress | false -> NoProgress) - | None, progressOpt | progressOpt, None -> progressOpt + | 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 @@ -309,19 +309,19 @@ end = struct end module State = struct - type t = {progress: Progress.t; trace: Trace.t; valuesOpt: Values.t option} + type t = {progress: Progress.t; trace: Trace.t; values_opt: Values.t option} - let toString {progress; trace; valuesOpt} = - let progressStr = - match valuesOpt with - | None -> progress |> Progress.toString - | Some values -> "{" ^ (values |> Values.toString) ^ "}" + 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 - progressStr ^ " with trace " ^ Trace.toString trace + progress_str ^ " with trace " ^ Trace.to_string trace let init ?(progress = Progress.NoProgress) ?(trace = Trace.empty) - ?(valuesOpt = None) () = - {progress; trace; valuesOpt} + ?(values_opt = None) () = + {progress; trace; values_opt} let seq s1 s2 = let progress = @@ -330,13 +330,13 @@ module State = struct | false -> NoProgress in let trace = Trace.seq s1.trace s2.trace in - let valuesOpt = s2.valuesOpt in - {progress; trace; valuesOpt} + let values_opt = s2.values_opt in + {progress; trace; values_opt} let sequence states = match states with | [] -> assert false - | s :: nextStates -> List.fold_left seq s nextStates + | s :: next_states -> List.fold_left seq s next_states let nd s1 s2 = let progress = @@ -345,70 +345,70 @@ module State = struct | false -> NoProgress in let trace = Trace.nd s1.trace s2.trace in - let valuesOpt = - match (s1.valuesOpt, s2.valuesOpt) with - | None, valuesOpt -> ( + let values_opt = + match (s1.values_opt, s2.values_opt) with + | None, values_opt -> ( match s1.progress = Progress with - | true -> valuesOpt + | true -> values_opt | false -> None) - | valuesOpt, None -> ( + | values_opt, None -> ( match s2.progress = Progress with - | true -> valuesOpt + | true -> values_opt | false -> None) | Some values1, Some values2 -> Some (Values.nd values1 values2) in - {progress; trace; valuesOpt} + {progress; trace; values_opt} let nondet states = match states with | [] -> assert false - | s :: nextStates -> List.fold_left nd s nextStates + | s :: next_states -> List.fold_left nd s next_states - let unorderedSequence states = {(states |> sequence) with valuesOpt = None} + let unordered_sequence states = {(states |> sequence) with values_opt = None} let none ~progress = init ~progress ~trace:Trace.none - ~valuesOpt:(Some (Values.none ~progress)) + ~values_opt:(Some (Values.none ~progress)) () let some ~progress = init ~progress ~trace:Trace.some - ~valuesOpt:(Some (Values.some ~progress)) + ~values_opt:(Some (Values.some ~progress)) () end module Command = struct type progress = Progress.t - type retOption = Trace.retOption + type ret_option = Trace.ret_option type t = | Call of Call.t * Location.t - | ConstrOption of retOption + | ConstrOption of ret_option | Nondet of t list | Nothing | Sequence of t list | SwitchOption of { - functionCall: FunctionCall.t; + function_call: FunctionCall.t; loc: Location.t; some: t; none: t; } | UnorderedSequence of t list - let rec toString command = + let rec to_string command = match command with - | Call (call, _pos) -> call |> Call.toString - | ConstrOption r -> r |> Trace.retOptionToString + | Call (call, _pos) -> call |> Call.to_string + | ConstrOption r -> r |> Trace.ret_option_to_string | Nondet commands -> - "[" ^ (commands |> List.map toString |> String.concat " || ") ^ "]" + "[" ^ (commands |> List.map to_string |> String.concat " || ") ^ "]" | Nothing -> "_" - | Sequence commands -> commands |> List.map toString |> String.concat "; " - | SwitchOption {functionCall; some = cSome; none = cNone} -> + | Sequence commands -> commands |> List.map to_string |> String.concat "; " + | SwitchOption {function_call; some = c_some; none = c_none} -> "switch " - ^ FunctionCall.toString functionCall - ^ " {some: " ^ toString cSome ^ ", none: " ^ toString cNone ^ "}" + ^ FunctionCall.to_string function_call + ^ " {some: " ^ to_string c_some ^ ", none: " ^ to_string c_none ^ "}" | UnorderedSequence commands -> - "{" ^ (commands |> List.map toString |> String.concat ", ") ^ "}" + "{" ^ (commands |> List.map to_string |> String.concat ", ") ^ "}" let nothing = Nothing @@ -436,12 +436,12 @@ module Command = struct let ( +++ ) c1 c2 = sequence [c1; c2] - let unorderedSequence commands = - let relevantCommands = commands |> List.filter (fun x -> x <> nothing) in - match relevantCommands with + let unordered_sequence commands = + let relevant_commands = commands |> List.filter (fun x -> x <> nothing) in + match relevant_commands with | [] -> nothing | [c] -> c - | _ :: _ :: _ -> UnorderedSequence relevantCommands + | _ :: _ :: _ -> UnorderedSequence relevant_commands end module Kind = struct @@ -450,33 +450,33 @@ module Kind = struct let empty = ([] : t) - let hasLabel ~label (k : t) = + let has_label ~label (k : t) = k |> List.exists (fun entry -> entry.label = label) - let rec entryToString {label; k} = + let rec entry_to_string {label; k} = match k = [] with | true -> label - | false -> label ^ ":" ^ (k |> toString) + | false -> label ^ ":" ^ (k |> to_string) - and toString (kind : t) = + and to_string (kind : t) = match kind = [] with | true -> "" | false -> - "<" ^ (kind |> List.map entryToString |> String.concat ", ") ^ ">" + "<" ^ (kind |> List.map entry_to_string |> String.concat ", ") ^ ">" - let addLabelWithEmptyKind ~label kind = - if not (kind |> hasLabel ~label) then + 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 FunctionTable = struct - type functionDefinition = { + type function_definition = { mutable body: Command.t option; mutable kind: Kind.t; } - type t = (FunctionName.t, functionDefinition) Hashtbl.t + type t = (FunctionName.t, function_definition) Hashtbl.t let create () : t = Hashtbl.create 1 @@ -484,82 +484,82 @@ module FunctionTable = struct Format.fprintf ppf "@[@,@{Function Table@}"; let definitions = Hashtbl.fold - (fun functionName {kind; body} definitions -> - (functionName, kind, body) :: definitions) + (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 (functionName, kind, body) -> + |> List.iteri (fun i (function_name, kind, body) -> Format.fprintf ppf "@,@{%d@} @{%s%s@}: %s" (i + 1) - functionName (Kind.toString kind) + function_name (Kind.to_string kind) (match body with - | Some command -> Command.toString command + | Some command -> Command.to_string 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 initial_function_definition () = {kind = Kind.empty; body = None} - let getFunctionDefinition ~functionName (tbl : t) = - try Hashtbl.find tbl functionName with Not_found -> assert false + let get_function_definition ~function_name (tbl : t) = + try Hashtbl.find tbl function_name with Not_found -> assert false - let isInFunctionInTable ~functionTable path = - Hashtbl.mem functionTable (Path.name path) + let is_in_function_in_table ~function_table path = + Hashtbl.mem function_table (Path.name path) - let addFunction ~functionName (tbl : t) = - if Hashtbl.mem tbl functionName then assert false; - Hashtbl.replace tbl functionName (initialFunctionDefinition ()) + 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 addLabelToKind ~functionName ~label (tbl : t) = - let functionDefinition = tbl |> getFunctionDefinition ~functionName in - functionDefinition.kind <- - functionDefinition.kind |> Kind.addLabelWithEmptyKind ~label + 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 addBody ~body ~functionName (tbl : t) = - let functionDefinition = tbl |> getFunctionDefinition ~functionName in - functionDefinition.body <- body + let add_body ~body ~function_name (tbl : t) = + let function_definition = tbl |> get_function_definition ~function_name in + function_definition.body <- body - let functionGetKindOfLabel ~functionName ~label (tbl : t) = - match Hashtbl.find tbl functionName with + let function_get_kind_of_label ~function_name ~label (tbl : t) = + match Hashtbl.find tbl function_name with | {kind} -> ( - match kind |> Kind.hasLabel ~label with + match kind |> Kind.has_label ~label with | true -> Some Kind.empty | false -> None) | exception Not_found -> None end module FindFunctionsCalled = struct - let traverseExpr ~callees = + 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 functionName = Path.name callee in - callees := !callees |> StringSet.add functionName + let function_name = Path.name callee in + callees := !callees |> StringSet.add function_name | _ -> ()); super.expr self e in {super with Tast_mapper.expr} - let findCallees (expression : Typedtree.expression) = - let isFunction = + let find_callees (expression : Typedtree.expression) = + let is_function = 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; + let traverse_expr = traverse_expr ~callees in + if is_function then expression |> traverse_expr.expr traverse_expr |> 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 + 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 { @@ -581,37 +581,37 @@ module ExtendFunctionTable = struct 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 + 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 checkArg then Some (path, loc) else None + if args |> List.for_all check_arg then Some (path, loc) else None | _ -> None - let traverseExpr ~config ~functionTable ~progressFunctions ~valueBindingsTable + 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 valueBindingsTable (Path.name callee) with + match Hashtbl.find_opt value_bindings_table (Path.name callee) with | None -> () | Some (id_pos, _, callees) -> if not (StringSet.is_empty - (StringSet.inter (Lazy.force callees) progressFunctions)) + (StringSet.inter (Lazy.force callees) progress_functions)) then - let functionName = Path.name callee in - if not (callee |> FunctionTable.isInFunctionInTable ~functionTable) + let function_name = Path.name callee in + if not (callee |> FunctionTable.is_in_function_in_table ~function_table) then ( - functionTable |> FunctionTable.addFunction ~functionName; + function_table |> FunctionTable.add_function ~function_name; if config.DceConfig.cli.debug then - Log_.warning ~forStats:false ~loc + Log_.warning ~for_stats:false ~loc (Termination { termination = TerminationAnalysisInternal; @@ -619,21 +619,21 @@ module ExtendFunctionTable = struct Format.asprintf "Extend Function Table with @{%s@} (%a) as it \ calls a progress function" - functionName printPos id_pos; + function_name print_pos id_pos; }))) | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)}; args} - when callee |> FunctionTable.isInFunctionInTable ~functionTable -> - let functionName = Path.name callee in + when callee |> FunctionTable.is_in_function_in_table ~function_table -> + let function_name = Path.name callee in args - |> List.iter (fun ((argLabel : Asttypes.arg_label), argOpt) -> - match (argLabel, argOpt |> extractLabelledArgument) with + |> 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 |> FunctionTable.isInFunctionInTable ~functionTable + when path |> FunctionTable.is_in_function_in_table ~function_table -> - functionTable - |> FunctionTable.addLabelToKind ~functionName ~label; + function_table + |> FunctionTable.add_label_to_kind ~function_name ~label; if config.DceConfig.cli.debug then - Log_.warning ~forStats:false ~loc + Log_.warning ~for_stats:false ~loc (Termination { termination = TerminationAnalysisInternal; @@ -641,7 +641,7 @@ module ExtendFunctionTable = struct Format.asprintf "@{%s@} is parametric \ ~@{%s@}=@{%s@}" - functionName label (Path.name path); + function_name label (Path.name path); }) | _ -> ()) | _ -> ()); @@ -649,58 +649,58 @@ module ExtendFunctionTable = struct in {super with Tast_mapper.expr} - let run ~config ~functionTable ~progressFunctions ~valueBindingsTable + let run ~config ~function_table ~progress_functions ~value_bindings_table (expression : Typedtree.expression) = - let traverseExpr = - traverseExpr ~config ~functionTable ~progressFunctions ~valueBindingsTable + let traverse_expr = + traverse_expr ~config ~function_table ~progress_functions ~value_bindings_table in - expression |> traverseExpr.expr traverseExpr |> ignore + expression |> traverse_expr.expr traverse_expr |> ignore end module CheckExpressionWellFormed = struct - let traverseExpr ~config ~functionTable ~valueBindingsTable = + let traverse_expr ~config ~function_table ~value_bindings_table = let super = Tast_mapper.default in - let checkIdent ~path ~loc = - if path |> FunctionTable.isInFunctionInTable ~functionTable then - Stats.logHygieneOnlyCallDirectly ~path ~loc + let check_ident ~path ~loc = + if path |> FunctionTable.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}, _) -> - checkIdent ~path ~loc; + check_ident ~path ~loc; e - | Texp_apply {funct = {exp_desc = Texp_ident (functionPath, _, _)}; args} + | Texp_apply {funct = {exp_desc = Texp_ident (function_path, _, _)}; args} -> - let functionName = Path.name functionPath in + let function_name = Path.name function_path in args - |> List.iter (fun ((argLabel : Asttypes.arg_label), argOpt) -> - match argOpt |> ExtendFunctionTable.extractLabelledArgument with + |> List.iter (fun ((arg_label : Asttypes.arg_label), arg_opt) -> + match arg_opt |> ExtendFunctionTable.extract_labelled_argument with | Some (path, loc) -> ( - match argLabel with + match arg_label with | Labelled {txt = label} -> ( if - functionTable - |> FunctionTable.functionGetKindOfLabel ~functionName + function_table + |> FunctionTable.function_get_kind_of_label ~function_name ~label <> None then () else - match Hashtbl.find_opt valueBindingsTable functionName with + match Hashtbl.find_opt value_bindings_table function_name with | Some (_pos, (body : Typedtree.expression), _) when path - |> FunctionTable.isInFunctionInTable ~functionTable + |> FunctionTable.is_in_function_in_table ~function_table -> - let inTable = - functionPath - |> FunctionTable.isInFunctionInTable ~functionTable + let in_table = + function_path + |> FunctionTable.is_in_function_in_table ~function_table in - if not inTable then - functionTable - |> FunctionTable.addFunction ~functionName; - functionTable - |> FunctionTable.addLabelToKind ~functionName ~label; + if not in_table then + function_table + |> FunctionTable.add_function ~function_name; + function_table + |> FunctionTable.add_label_to_kind ~function_name ~label; if config.DceConfig.cli.debug then - Log_.warning ~forStats:false ~loc:body.exp_loc + Log_.warning ~for_stats:false ~loc:body.exp_loc (Termination { termination = TerminationAnalysisInternal; @@ -708,39 +708,39 @@ module CheckExpressionWellFormed = struct Format.asprintf "Extend Function Table with @{%s@} \ as parametric ~@{%s@}=@{%s@}" - functionName label (Path.name path); + function_name label (Path.name path); }) - | _ -> checkIdent ~path ~loc) - | Optional _ | Nolabel -> checkIdent ~path ~loc) + | _ -> check_ident ~path ~loc) + | Optional _ | Nolabel -> check_ident ~path ~loc) | _ -> ()); e | _ -> super.expr self e in {super with Tast_mapper.expr} - let run ~config ~functionTable ~valueBindingsTable + let run ~config ~function_table ~value_bindings_table (expression : Typedtree.expression) = - let traverseExpr = - traverseExpr ~config ~functionTable ~valueBindingsTable + let traverse_expr = + traverse_expr ~config ~function_table ~value_bindings_table in - expression |> traverseExpr.expr traverseExpr |> ignore + expression |> traverse_expr.expr traverse_expr |> 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; + current_function_name: FunctionName.t; + function_table: FunctionTable.t; + inner_recursive_functions: (FunctionName.t, FunctionName.t) Hashtbl.t; + is_progress_function: Path.t -> bool; } let rec expression ~ctx (expr : Typedtree.expression) = - let {config; currentFunctionName; functionTable; isProgressFunction} = + let {config; current_function_name; function_table; is_progress_function} = ctx in let loc = expr.exp_loc in - let notImplemented case = + let not_implemented case = Log_.error ~loc (Termination {termination = ErrorNotImplemented; message = Format.asprintf case}) @@ -750,22 +750,22 @@ module Compile = struct | Texp_ident _ -> Command.nothing | Texp_apply { - funct = {exp_desc = Texp_ident (calleeToRename, l, vd)} as expr; - args = argsToExtend; + funct = {exp_desc = Texp_ident (callee_to_rename, l, vd)} as expr; + args = args_to_extend; } -> ( let callee, args = match - Hashtbl.find_opt ctx.innerRecursiveFunctions - (Path.name calleeToRename) + Hashtbl.find_opt ctx.inner_recursive_functions + (Path.name callee_to_rename) with - | Some innerFunctionName -> - let innerFunctionDefinition = - functionTable - |> FunctionTable.getFunctionDefinition - ~functionName:innerFunctionName + | Some inner_function_name -> + let inner_function_definition = + function_table + |> FunctionTable.get_function_definition + ~function_name:inner_function_name in - let argsFromKind = - innerFunctionDefinition.kind + let args_from_kind = + inner_function_definition.kind |> List.map (fun (entry : Kind.entry) -> ( Asttypes.Labelled {txt = entry.label; loc = Location.none}, Some @@ -776,134 +776,134 @@ module Compile = struct (Path.Pident (Ident.create entry.label), l, vd); } )) in - ( Path.Pident (Ident.create innerFunctionName), - argsFromKind @ argsToExtend ) - | None -> (calleeToRename, argsToExtend) + ( Path.Pident (Ident.create inner_function_name), + args_from_kind @ args_to_extend ) + | None -> (callee_to_rename, args_to_extend) in - if callee |> FunctionTable.isInFunctionInTable ~functionTable then - let functionName = Path.name callee in - let functionDefinition = - functionTable |> FunctionTable.getFunctionDefinition ~functionName + if callee |> FunctionTable.is_in_function_in_table ~function_table then + let function_name = Path.name callee in + let function_definition = + function_table |> FunctionTable.get_function_definition ~function_name in let exception ArgError in - let getFunctionArg {Kind.label} = - let argOpt = + 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 argOpt = - match argOpt with + let arg_opt = + match arg_opt with | Some (_, Some e) -> Some e | _ -> None in - let functionArg () = + let function_arg () = match - argOpt - |> ExtendFunctionTable.extractLabelledArgument - ~kindOpt:(Some functionDefinition.kind) + arg_opt + |> ExtendFunctionTable.extract_labelled_argument + ~kind_opt:(Some function_definition.kind) with | None -> - Stats.logHygieneMustHaveNamedArgument ~label ~loc; + Stats.log_hygiene_must_have_named_argument ~label ~loc; raise ArgError | Some (path, _pos) - when path |> FunctionTable.isInFunctionInTable ~functionTable -> - let functionName = Path.name path in - {FunctionArgs.label; functionName} + when path |> FunctionTable.is_in_function_in_table ~function_table -> + let function_name = Path.name path in + {FunctionArgs.label; function_name} | Some (path, _pos) - when functionTable - |> FunctionTable.functionGetKindOfLabel - ~functionName:currentFunctionName + when function_table + |> FunctionTable.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 functionName = Path.name path in - {FunctionArgs.label; functionName} + let function_name = Path.name path in + {FunctionArgs.label; function_name} | _ -> - Stats.logHygieneNamedArgValue ~label ~loc; + Stats.log_hygiene_named_arg_value ~label ~loc; raise ArgError [@@raises ArgError] in - functionArg () + function_arg () [@@raises ArgError] in - let functionArgsOpt = - try Some (functionDefinition.kind |> List.map getFunctionArg) + let function_args_opt = + try Some (function_definition.kind |> List.map get_function_arg) with ArgError -> None in - match functionArgsOpt with + match function_args_opt 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 + | 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 - functionTable - |> FunctionTable.functionGetKindOfLabel - ~functionName:currentFunctionName ~label:(Path.name callee) + function_table + |> FunctionTable.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 |> FunctionCall.noArgs), loc) - |> evalArgs ~args ~ctx + (FunctionCall (Path.name callee |> FunctionCall.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 |> evalArgs ~args ~ctx) + | None -> expr |> expression ~ctx |> eval_args ~args ~ctx) | Texp_apply {funct = expr; args} -> - expr |> expression ~ctx |> evalArgs ~args ~ctx + expr |> expression ~ctx |> eval_args ~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_expr ) -> + let old_function_name = Ident.name id in + let new_function_name = current_function_name ^ "$" ^ old_function_name in + function_table |> FunctionTable.add_function ~function_name:new_function_name; + let new_function_definition = + function_table + |> FunctionTable.get_function_definition ~function_name:new_function_name in - let currentFunctionDefinition = - functionTable - |> FunctionTable.getFunctionDefinition ~functionName:currentFunctionName + let current_function_definition = + function_table + |> FunctionTable.get_function_definition ~function_name:current_function_name 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); + 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.DceConfig.cli.debug then - Log_.warning ~forStats:false ~loc:pat_loc + Log_.warning ~for_stats:false ~loc:pat_loc (Termination { termination = TerminationAnalysisInternal; message = Format.asprintf "Adding recursive definition @{%s@}" - newFunctionName; + new_function_name; }); - inExpr |> expression ~ctx - | Texp_let (recFlag, valueBindings, inExpr) -> - if recFlag = Recursive then Stats.logHygieneNoNestedLetRec ~loc; + 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 = - (valueBindings + (value_bindings |> List.map (fun (vb : Typedtree.value_binding) -> vb.vb_expr |> expression ~ctx)) - @ [inExpr |> 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, eOpt) -> + | Texp_ifthenelse (e1, e2, e_opt) -> let c1 = e1 |> expression ~ctx in let c2 = e2 |> expression ~ctx in - let c3 = eOpt |> expressionOpt ~ctx in + let c3 = e_opt |> expression_opt ~ctx in let open Command in c1 +++ nondet [c2; c3] | Texp_constant _ -> Command.nothing @@ -911,7 +911,7 @@ module Compile = struct let c = expressions |> List.map (fun e -> e |> expression ~ctx) - |> Command.unorderedSequence + |> Command.unordered_sequence in match cstr_name with | "Some" when loc_ghost = false -> @@ -922,34 +922,34 @@ module Compile = struct c +++ ConstrOption Rnone | _ -> c) | Texp_function {case = case_} -> case ~ctx case_ - | Texp_match (e, casesOk, casesExn, _partial) + | Texp_match (e, cases_ok, cases_exn, _partial) when not - (casesExn + (cases_exn |> 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 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 - cE +++ nondet cCases + c_e +++ nondet c_cases in - match (cE, cases) with - | ( Call (FunctionCall functionCall, loc), + 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 casesArr = Array.of_list cCases in + let cases_arr = Array.of_list c_cases in let some, none = try match name1 = "Some" with - | true -> (casesArr.(0), casesArr.(1)) - | false -> (casesArr.(1), casesArr.(0)) + | true -> (cases_arr.(0), cases_arr.(1)) + | false -> (cases_arr.(1), cases_arr.(0)) with Invalid_argument _ -> (Nothing, Nothing) in - Command.SwitchOption {functionCall; loc; some; none} + Command.SwitchOption {function_call; loc; some; none} | _ -> fail ()) | _ -> fail ()) | Texp_match _ -> assert false (* exceptions *) @@ -960,27 +960,27 @@ module Compile = struct |> List.map (fun ( _desc, - (recordLabelDefinition : Typedtree.record_label_definition), + (record_label_definition : Typedtree.record_label_definition), _ ) -> - match recordLabelDefinition with + match record_label_definition with | Kept _typeExpr -> None | Overridden (_loc, e) -> Some e)) - |> List.map (expressionOpt ~ctx) - |> Command.unorderedSequence + |> List.map (expression_opt ~ctx) + |> Command.unordered_sequence | Texp_setfield (e1, _loc, _desc, e2) -> - [e1; e2] |> List.map (expression ~ctx) |> Command.unorderedSequence + [e1; e2] |> List.map (expression ~ctx) |> Command.unordered_sequence | Texp_tuple expressions | Texp_array expressions -> - expressions |> List.map (expression ~ctx) |> Command.unorderedSequence + expressions |> List.map (expression ~ctx) |> Command.unordered_sequence | 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 c_e = e |> expression ~ctx in + let c_cases = cases |> List.map (case ~ctx) |> Command.nondet in let open Command in - cE +++ cCases - | Texp_variant (_label, eOpt) -> eOpt |> expressionOpt ~ctx + c_e +++ c_cases + | Texp_variant (_label, e_opt) -> e_opt |> expression_opt ~ctx | Texp_while _ -> - notImplemented "Texp_while"; + not_implemented "Texp_while"; assert false | Texp_for (_id, _pat, e1, e2, _dir, e3) -> let open Command in @@ -992,37 +992,37 @@ module Compile = struct let open Command in expression ~ctx e1 +++ expression ~ctx e2 | Texp_send _ -> - notImplemented "Texp_send"; + not_implemented "Texp_send"; assert false | Texp_letmodule _ -> - notImplemented "Texp_letmodule"; + not_implemented "Texp_letmodule"; assert false | Texp_letexception _ -> - notImplemented "Texp_letexception"; + not_implemented "Texp_letexception"; assert false | Texp_pack _ -> - notImplemented "Texp_pack"; + not_implemented "Texp_pack"; assert false | Texp_extension_constructor _ when true -> - notImplemented "Texp_extension_constructor"; + not_implemented "Texp_extension_constructor"; assert false | _ -> (* ocaml 4.08: Texp_letop(_) | Texp_open(_) *) - notImplemented "Texp_letop(_) | Texp_open(_)"; + not_implemented "Texp_letop(_) | Texp_open(_)"; assert false - and expressionOpt ~ctx eOpt = - match eOpt with + and expression_opt ~ctx e_opt = + match e_opt with | None -> Command.nothing | Some e -> e |> expression ~ctx - and evalArgs ~args ~ctx command = + and eval_args ~args ~ctx command = (* Don't assume any evaluation order on the arguments *) let commands = - args |> List.map (fun (_, eOpt) -> eOpt |> expressionOpt ~ctx) + args |> List.map (fun (_, e_opt) -> e_opt |> expression_opt ~ctx) in let open Command in - unorderedSequence commands +++ command + unordered_sequence commands +++ command and case : ctx:ctx -> Typedtree.case -> _ = fun ~ctx {c_guard; c_rhs} -> @@ -1034,60 +1034,60 @@ module Compile = struct end module CallStack = struct - type frame = {frameNumber: int; pos: Lexing.position} + type frame = {frame_number: 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} = + let to_set {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 has_function_call ~function_call (t : t) = Hashtbl.mem t.tbl function_call - let addFunctionCall ~functionCall ~pos (t : t) = + let add_function_call ~function_call ~pos (t : t) = t.size <- t.size + 1; - Hashtbl.replace t.tbl functionCall {frameNumber = t.size; pos} + Hashtbl.replace t.tbl function_call {frame_number = t.size; pos} - let removeFunctionCall ~functionCall (t : t) = + let remove_function_call ~function_call (t : t) = t.size <- t.size - 1; - Hashtbl.remove t.tbl functionCall + Hashtbl.remove t.tbl function_call let print ppf (t : t) = Format.fprintf ppf " CallStack:"; let frames = Hashtbl.fold - (fun functionCall {frameNumber; pos} frames -> - (functionCall, frameNumber, pos) :: frames) + (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 ((functionCall : FunctionCall.t), i, pos) -> + |> List.iter (fun ((function_call : FunctionCall.t), i, pos) -> Format.fprintf ppf "\n @{%d@} %s (%a)" i - (FunctionCall.toString functionCall) - printPos pos) + (FunctionCall.to_string function_call) + print_pos pos) end module Eval = struct type progress = Progress.t type cache = (FunctionCall.t, State.t) Hashtbl.t - let createCache () : cache = Hashtbl.create 1 + let create_cache () : cache = Hashtbl.create 1 - let lookupCache ~functionCall (cache : cache) = - Hashtbl.find_opt cache functionCall + let lookup_cache ~function_call (cache : cache) = + Hashtbl.find_opt cache function_call - let updateCache ~config ~functionCall ~loc ~state (cache : cache) = - Stats.logResult ~config ~functionCall ~resString:(state |> State.toString) + 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 functionCall) then - Hashtbl.replace cache functionCall state + if not (Hashtbl.mem cache function_call) then + Hashtbl.replace cache function_call state - let hasInfiniteLoop ~callStack ~functionCallToInstantiate ~functionCall ~loc + let has_infinite_loop ~call_stack ~function_call_to_instantiate ~function_call ~loc ~state = - if callStack |> CallStack.hasFunctionCall ~functionCall then ( + if call_stack |> CallStack.has_function_call ~function_call then ( if state.State.progress = NoProgress then ( Log_.error ~loc (Termination @@ -1097,77 +1097,77 @@ module Eval = struct Format.asprintf "%a" (fun ppf () -> Format.fprintf ppf "Possible infinite loop when calling "; - (match functionCallToInstantiate = functionCall with + (match function_call_to_instantiate = function_call with | true -> Format.fprintf ppf "@{%s@}" - (functionCallToInstantiate |> FunctionCall.toString) + (function_call_to_instantiate |> FunctionCall.to_string) | false -> Format.fprintf ppf "@{%s@} which is @{%s@}" - (functionCallToInstantiate |> FunctionCall.toString) - (functionCall |> FunctionCall.toString)); - Format.fprintf ppf "@,%a" CallStack.print callStack) + (function_call_to_instantiate |> FunctionCall.to_string) + (function_call |> FunctionCall.to_string)); + Format.fprintf ppf "@,%a" CallStack.print call_stack) (); }); - Stats.logLoop ()); + Stats.log_loop ()); true) else false - let rec runFunctionCall ~config ~cache ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~loc ~state functionCallToInstantiate : State.t = + 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 functionCall = - functionCallToInstantiate - |> FunctionCall.applySubstitution ~sub:functionArgs + let function_call = + function_call_to_instantiate + |> FunctionCall.apply_substitution ~sub:function_args 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; + 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; { - stateAfterCall with - trace = Trace.Tcall (call, stateAfterCall.progress); + state_after_call with + trace = Trace.Tcall (call, state_after_call.progress); } | None -> - if FunctionCallSet.mem functionCall madeProgressOn then + if FunctionCallSet.mem function_call made_progress_on then State.init ~progress:Progress ~trace:(Trace.Tcall (call, Progress)) () else if - hasInfiniteLoop ~callStack ~functionCallToInstantiate ~functionCall + has_infinite_loop ~call_stack ~function_call_to_instantiate ~function_call ~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 + Stats.log_cache ~config ~function_call ~hit:false ~loc; + let function_definition = + function_table |> FunctionTable.get_function_definition ~function_name in - callStack |> CallStack.addFunctionCall ~functionCall ~pos; + call_stack |> CallStack.add_function_call ~function_call ~pos; let body = - match functionDefinition.body with + match function_definition.body with | Some body -> body | None -> assert false in - let stateAfterCall = + let state_after_call = body - |> run ~config ~cache ~callStack - ~functionArgs:functionCall.functionArgs ~functionTable - ~madeProgressOn ~state:(State.init ()) + |> run ~config ~cache ~call_stack + ~function_args:function_call.function_args ~function_table + ~made_progress_on ~state:(State.init ()) in - cache |> updateCache ~config ~functionCall ~loc ~state:stateAfterCall; + cache |> update_cache ~config ~function_call ~loc ~state:state_after_call; (* Invariant: run should restore the callStack *) - callStack |> CallStack.removeFunctionCall ~functionCall; - let trace = Trace.Tcall (call, stateAfterCall.progress) in - {stateAfterCall with trace}) + call_stack |> CallStack.remove_function_call ~function_call; + let trace = Trace.Tcall (call, state_after_call.progress) in + {state_after_call with trace}) in - State.seq state stateAfterCall + State.seq state state_after_call - and run ~config ~(cache : cache) ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~state (command : Command.t) : State.t = + 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 functionCall, loc) -> - functionCall - |> runFunctionCall ~config ~cache ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~loc ~state + | 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)) () @@ -1185,204 +1185,204 @@ module Eval = struct State.seq state state1 | Sequence commands -> (* if one command makes progress, then the sequence makes progress *) - let rec findFirstProgress ~callStack ~commands ~madeProgressOn ~state = + let rec find_first_progress ~call_stack ~commands ~made_progress_on ~state = match commands with | [] -> state - | c :: nextCommands -> + | c :: next_commands -> let state1 = c - |> run ~config ~cache ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~state + |> run ~config ~cache ~call_stack ~function_args ~function_table + ~made_progress_on ~state in - let madeProgressOn, callStack = + 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 *) - ( FunctionCallSet.union madeProgressOn - (callStack |> CallStack.toSet), + ( FunctionCallSet.union made_progress_on + (call_stack |> CallStack.to_set), CallStack.create () ) - | NoProgress -> (madeProgressOn, callStack) + | NoProgress -> (made_progress_on, call_stack) in - findFirstProgress ~callStack ~commands:nextCommands ~madeProgressOn + find_first_progress ~call_stack ~commands:next_commands ~made_progress_on ~state:state1 in - findFirstProgress ~callStack ~commands ~madeProgressOn ~state + find_first_progress ~call_stack ~commands ~made_progress_on ~state | UnorderedSequence commands -> - let stateNoTrace = {state with trace = Trace.empty} in + 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 ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~state:stateNoTrace) + |> run ~config ~cache ~call_stack ~function_args ~function_table + ~made_progress_on ~state:state_no_trace) in - State.seq state (states |> State.unorderedSequence) + State.seq state (states |> State.unordered_sequence) | Nondet commands -> - let stateNoTrace = {state with trace = Trace.empty} in + 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 ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~state:stateNoTrace) + |> run ~config ~cache ~call_stack ~function_args ~function_table + ~made_progress_on ~state:state_no_trace) in State.seq state (states |> State.nondet) - | SwitchOption {functionCall; loc; some; none} -> ( - let stateAfterCall = - functionCall - |> runFunctionCall ~config ~cache ~callStack ~functionArgs - ~functionTable ~madeProgressOn ~loc ~state + | 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 stateAfterCall.valuesOpt with + match state_after_call.values_opt with | None -> Command.nondet [some; none] - |> run ~config ~cache ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~state:stateAfterCall + |> run ~config ~cache ~call_stack ~function_args ~function_table + ~made_progress_on ~state:state_after_call | Some values -> - let runOpt c progressOpt = - match progressOpt with + let run_opt c progress_opt = + match progress_opt with | None -> State.init ~progress:Progress () | Some progress -> c - |> run ~config ~cache ~callStack ~functionArgs ~functionTable - ~madeProgressOn ~state:(State.init ~progress ()) + |> run ~config ~cache ~call_stack ~function_args ~function_table + ~made_progress_on ~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 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 analyzeFunction ~config ~cache ~functionTable ~loc functionName = + let analyze_function ~config ~cache ~function_table ~loc function_name = if config.DceConfig.cli.debug then Log_.log "@[@,@{Termination Analysis@} for @{%s@}@]@." - functionName; + function_name; 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 + let call_stack = CallStack.create () in + let function_args = FunctionArgs.empty in + let function_call = FunctionCall.no_args function_name in + call_stack |> CallStack.add_function_call ~function_call ~pos; + let function_definition = + function_table |> FunctionTable.get_function_definition ~function_name in - if functionDefinition.kind <> Kind.empty then - Stats.logHygieneParametric ~functionName ~loc + if function_definition.kind <> Kind.empty then + Stats.log_hygiene_parametric ~function_name ~loc else let body = - match functionDefinition.body with + match function_definition.body with | Some body -> body | None -> assert false in let state = body - |> run ~config ~cache ~callStack ~functionArgs ~functionTable - ~madeProgressOn:FunctionCallSet.empty ~state:(State.init ()) + |> run ~config ~cache ~call_stack ~function_args ~function_table + ~made_progress_on:FunctionCallSet.empty ~state:(State.init ()) in - cache |> updateCache ~config ~functionCall ~loc ~state + cache |> update_cache ~config ~function_call ~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 +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.getAttributePayload isProgress with + (match attributes |> Annotation.get_attribute_payload is_progress with | None -> [] - | Some (IdentPayload lid) -> [lidToString lid] + | Some (IdentPayload lid) -> [lid_to_string lid] | Some (TuplePayload l) -> l |> List.filter_map (function - | Annotation.IdentPayload lid -> Some (lidToString lid) + | Annotation.IdentPayload lid -> Some (lid_to_string lid) | _ -> None) | _ -> []) else None -let traverseAst ~config ~valueBindingsTable = +let traverse_ast ~config ~value_bindings_table = let super = Tast_mapper.default in - let value_bindings (self : Tast_mapper.mapper) (recFlag, valueBindings) = + let value_bindings (self : Tast_mapper.mapper) (rec_flag, value_bindings) = (* Update the table of value bindings for variables *) - valueBindings + 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 (FindFunctionsCalled.findCallees vb.vb_expr) in - Hashtbl.replace valueBindingsTable (Ident.name id) + let callees = lazy (FindFunctionsCalled.find_callees vb.vb_expr) in + Hashtbl.replace value_bindings_table (Ident.name id) (pos, vb.vb_expr, callees) | _ -> ()); - let progressFunctions, functionsToAnalyze = - if recFlag = Asttypes.Nonrecursive then (StringSet.empty, []) + let progress_functions, functions_to_analyze = + if rec_flag = Asttypes.Nonrecursive then (StringSet.empty, []) else - let progressFunctions0, functionsToAnalyze0 = - valueBindings + let progress_functions0, functions_to_analyze0 = + value_bindings |> List.fold_left - (fun (progressFunctions, functionsToAnalyze) - (valueBinding : Typedtree.value_binding) -> + (fun (progress_functions, functions_to_analyze) + (value_binding : Typedtree.value_binding) -> match - progressFunctionsFromAttributes valueBinding.vb_attributes + progress_functions_from_attributes value_binding.vb_attributes with - | None -> (progressFunctions, functionsToAnalyze) - | Some newProgressFunctions -> + | None -> (progress_functions, functions_to_analyze) + | Some new_progress_functions -> ( StringSet.union - (StringSet.of_list newProgressFunctions) - progressFunctions, - match valueBinding.vb_pat.pat_desc with + (StringSet.of_list new_progress_functions) + progress_functions, + match value_binding.vb_pat.pat_desc with | Tpat_var (id, _) -> - (Ident.name id, valueBinding.vb_expr.exp_loc) - :: functionsToAnalyze - | _ -> functionsToAnalyze )) + (Ident.name id, value_binding.vb_expr.exp_loc) + :: functions_to_analyze + | _ -> functions_to_analyze )) (StringSet.empty, []) in - (progressFunctions0, functionsToAnalyze0 |> List.rev) + (progress_functions0, functions_to_analyze0 |> List.rev) in - if functionsToAnalyze <> [] then ( - let functionTable = FunctionTable.create () in - let isProgressFunction path = - StringSet.mem (Path.name path) progressFunctions + if functions_to_analyze <> [] then ( + let function_table = FunctionTable.create () in + let is_progress_function path = + StringSet.mem (Path.name path) progress_functions in - let recursiveFunctions = + let recursive_functions = List.fold_left - (fun defs (valueBinding : Typedtree.value_binding) -> - match valueBinding.vb_pat.pat_desc with + (fun defs (value_binding : Typedtree.value_binding) -> + match value_binding.vb_pat.pat_desc with | Tpat_var (id, _) -> Ident.name id :: defs | _ -> defs) - [] valueBindings + [] value_bindings |> List.rev in - let recursiveDefinitions = - recursiveFunctions + let recursive_definitions = + recursive_functions |> List.fold_left - (fun acc functionName -> - match Hashtbl.find_opt valueBindingsTable functionName with - | Some (_pos, e, _set) -> (functionName, e) :: acc + (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 - recursiveDefinitions - |> List.iter (fun (functionName, _body) -> - functionTable |> FunctionTable.addFunction ~functionName); - recursiveDefinitions + recursive_definitions + |> List.iter (fun (function_name, _body) -> + function_table |> FunctionTable.add_function ~function_name); + recursive_definitions |> List.iter (fun (_, body) -> body - |> ExtendFunctionTable.run ~config ~functionTable - ~progressFunctions ~valueBindingsTable); - recursiveDefinitions + |> ExtendFunctionTable.run ~config ~function_table + ~progress_functions ~value_bindings_table); + recursive_definitions |> List.iter (fun (_, body) -> body - |> CheckExpressionWellFormed.run ~config ~functionTable - ~valueBindingsTable); - functionTable + |> CheckExpressionWellFormed.run ~config ~function_table + ~value_bindings_table); + function_table |> Hashtbl.iter (fun - functionName - (functionDefinition : FunctionTable.functionDefinition) + function_name + (function_definition : FunctionTable.function_definition) -> - if functionDefinition.body = None then - match Hashtbl.find_opt valueBindingsTable functionName with + if function_definition.body = None then + match Hashtbl.find_opt value_bindings_table function_name with | None -> () | Some (_pos, body, _) -> - functionTable - |> FunctionTable.addBody + function_table + |> FunctionTable.add_body ~body: (Some (body @@ -1390,36 +1390,36 @@ let traverseAst ~config ~valueBindingsTable = ~ctx: { config; - currentFunctionName = functionName; - functionTable; - innerRecursiveFunctions = Hashtbl.create 1; - isProgressFunction; + current_function_name = function_name; + function_table; + inner_recursive_functions = Hashtbl.create 1; + is_progress_function; })) - ~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) + ~function_name); + if config.DceConfig.cli.debug then FunctionTable.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 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 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 processCmt ~config ~file:_ (cmt_infos : Cmt_format.cmt_infos) = +let process_cmt ~config ~file:_ (cmt_infos : Cmt_format.cmt_infos) = match cmt_infos.cmt_annots with | Interface _ -> () - | Implementation structure -> processStructure ~config structure + | Implementation structure -> process_structure ~config structure | _ -> () -let reportStats ~config:_ = Stats.dump ~ppf:Format.std_formatter +let report_stats ~config:_ = Stats.dump ~ppf:Format.std_formatter diff --git a/analysis/reanalyze/src/Cli.ml b/analysis/reanalyze/src/Cli.ml index ca8a4f5479..806a11af64 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/CollectAnnotations.ml b/analysis/reanalyze/src/CollectAnnotations.ml index 2f6b53f457..c37021f960 100644 --- a/analysis/reanalyze/src/CollectAnnotations.ml +++ b/analysis/reanalyze/src/CollectAnnotations.ml @@ -7,23 +7,23 @@ open DeadCommon type scope_default = FileAnnotations.annotated_as option -let processAttributes ~(scope_default : scope_default) ~state ~config ~doGenType +let process_attributes ~(scope_default : scope_default) ~state ~config ~do_gen_type ~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) + 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 - doGenType - && getPayloadFun Annotation.tagIsOneOfTheGenTypeAnnotations <> None + do_gen_type + && get_payload_fun Annotation.tag_is_one_of_the_gen_type_annotations <> None then FileAnnotations.annotate_gentype state pos; - if getPayload "dead" <> None then FileAnnotations.annotate_dead state pos; - let nameIsInLiveNamesOrPaths () = + if get_payload "dead" <> None then FileAnnotations.annotate_dead state pos; + let name_is_in_live_names_or_paths () = config.DceConfig.cli.live_names |> List.mem name || let fname = @@ -31,33 +31,33 @@ let processAttributes ~(scope_default : scope_default) ~state ~config ~doGenType | true -> pos.pos_fname | false -> Filename.concat (Sys.getcwd ()) pos.pos_fname in - let fnameLen = String.length fname in + let fname_len = String.length fname in config.DceConfig.cli.live_paths |> List.exists (fun prefix -> - String.length prefix <= fnameLen + String.length prefix <= fname_len && try String.sub fname 0 (String.length prefix) = prefix with Invalid_argument _ -> false) in - if getPayload liveAnnotation <> None || nameIsInLiveNamesOrPaths () then + if get_payload live_annotation <> None || name_is_in_live_names_or_paths () then FileAnnotations.annotate_live state pos; - if attributes |> Annotation.isOcamlSuppressDeadWarning then + if attributes |> Annotation.is_ocaml_suppress_dead_warning then FileAnnotations.annotate_live state pos -let collectExportLocations ~state ~config ~doGenType = +let collect_export_locations ~state ~config ~do_gen_type = let super = Tast_mapper.default in - let currentlyDisableWarnings = ref false in - let currentScopeDefault : scope_default ref = ref None in + let currently_disable_warnings = ref false in + let current_scope_default : scope_default ref = ref None in - let scopeDefaultFromToplevelAttribute (attribute : Parsetree.attribute) : + let scope_default_from_toplevel_attribute (attribute : Parsetree.attribute) : scope_default = let attrs = [attribute] in - let getPayload (x : string) = - attrs |> Annotation.getAttributePayload (( = ) x) + let get_payload (x : string) = + attrs |> Annotation.get_attribute_payload (( = ) 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 + if get_payload "dead" <> None then Some FileAnnotations.Dead + else if get_payload "live" <> None then Some FileAnnotations.Live + else if get_payload "genType" <> None then Some FileAnnotations.GenType else None in @@ -66,24 +66,24 @@ let collectExportLocations ~state ~config ~doGenType = (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; + if !currently_disable_warnings then FileAnnotations.annotate_live state pos; vb_attributes - |> processAttributes ~scope_default:!currentScopeDefault ~state ~config - ~doGenType ~name:(id |> Ident.name) ~pos + |> 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 toplevelAttrs self (typeKind : Typedtree.type_kind) = - (match typeKind with - | Ttype_record labelDeclarations -> - labelDeclarations + 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) -> - toplevelAttrs @ ld_attributes - |> processAttributes ~scope_default:!currentScopeDefault ~state - ~config ~doGenType:false ~name:"" ~pos:ld_loc.loc_start) - | Ttype_variant constructorDeclarations -> - constructorDeclarations + 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} : @@ -95,70 +95,70 @@ let collectExportLocations ~state ~config ~doGenType = List.iter (fun ({ld_attributes; ld_loc} : Typedtree.label_declaration) -> - toplevelAttrs @ cd_attributes @ ld_attributes - |> processAttributes ~scope_default:!currentScopeDefault - ~state ~config ~doGenType:false ~name:"" + 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 - toplevelAttrs @ cd_attributes - |> processAttributes ~scope_default:!currentScopeDefault ~state - ~config ~doGenType:false ~name:"" ~pos:cd_loc.loc_start) + 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 typeKind + super.type_kind self type_kind 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 + 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 !currentlyDisableWarnings then FileAnnotations.annotate_live state pos; + if !currently_disable_warnings then FileAnnotations.annotate_live state pos; val_attributes - |> processAttributes ~scope_default:!currentScopeDefault ~state ~config - ~doGenType ~name:(val_id |> Ident.name) ~pos; + |> 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 scopeDefaultFromToplevelAttribute attribute with - | Some _ as newDefault -> currentScopeDefault := newDefault + match scope_default_from_toplevel_attribute attribute with + | Some _ as new_default -> current_scope_default := new_default | None -> - if [attribute] |> Annotation.isOcamlSuppressDeadWarning then - currentlyDisableWarnings := true) + 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 oldDisableWarnings = !currentlyDisableWarnings in - let oldScopeDefault = !currentScopeDefault in + let old_disable_warnings = !currently_disable_warnings in + let old_scope_default = !current_scope_default in super.structure self structure |> ignore; - currentlyDisableWarnings := oldDisableWarnings; - currentScopeDefault := oldScopeDefault; + 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 scopeDefaultFromToplevelAttribute attribute with - | Some _ as newDefault -> currentScopeDefault := newDefault + match scope_default_from_toplevel_attribute attribute with + | Some _ as new_default -> current_scope_default := new_default | None -> - if [attribute] |> Annotation.isOcamlSuppressDeadWarning then - currentlyDisableWarnings := true) + 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 oldDisableWarnings = !currentlyDisableWarnings in - let oldScopeDefault = !currentScopeDefault in + let old_disable_warnings = !currently_disable_warnings in + let old_scope_default = !current_scope_default in super.signature self signature |> ignore; - currentlyDisableWarnings := oldDisableWarnings; - currentScopeDefault := oldScopeDefault; + currently_disable_warnings := old_disable_warnings; + current_scope_default := old_scope_default; signature in { @@ -172,10 +172,10 @@ let collectExportLocations ~state ~config ~doGenType = value_description; } -let structure ~state ~config ~doGenType structure = - let mapper = collectExportLocations ~state ~config ~doGenType in +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 = collectExportLocations ~state ~config ~doGenType:true in + 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/CollectAnnotations.mli index c81279e396..a08a91ae56 100644 --- a/analysis/reanalyze/src/CollectAnnotations.mli +++ b/analysis/reanalyze/src/CollectAnnotations.mli @@ -5,7 +5,7 @@ val structure : state:FileAnnotations.builder -> config:DceConfig.t -> - doGenType:bool -> + do_gen_type:bool -> Typedtree.structure -> unit (** Traverse a structure and collect annotations. *) diff --git a/analysis/reanalyze/src/CrossFileItems.ml b/analysis/reanalyze/src/CrossFileItems.ml index f51e55a468..efc3070581 100644 --- a/analysis/reanalyze/src/CrossFileItems.ml +++ b/analysis/reanalyze/src/CrossFileItems.ml @@ -75,6 +75,6 @@ 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) + DeadCommon.add_value_reference ~config ~refs ~file_deps + ~binding:Location.none ~add_file_reference:true ~loc_from:loc_from + ~loc_to:loc_to) diff --git a/analysis/reanalyze/src/CrossFileItemsStore.ml b/analysis/reanalyze/src/CrossFileItemsStore.ml index 33e5a756d6..d2eb54fbe3 100644 --- a/analysis/reanalyze/src/CrossFileItemsStore.ml +++ b/analysis/reanalyze/src/CrossFileItemsStore.ml @@ -40,7 +40,7 @@ let compute_optional_args_state (store : t) ~find_decl ~is_live : | Some s -> s | None -> ( match find_decl pos with - | Some {Decl.declKind = Value {optionalArgs}} -> optionalArgs + | Some {Decl.decl_kind = Value {optional_args}} -> optional_args | _ -> OptionalArgs.empty) in let set_state pos s = OptionalArgsState.set state pos s in @@ -50,8 +50,8 @@ let compute_optional_args_state (store : t) ~find_decl ~is_live : 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 + OptionalArgs.apply_call ~arg_names:arg_names + ~arg_names_maybe:arg_names_maybe current in set_state pos_to updated); (* Process function references *) @@ -59,7 +59,7 @@ let compute_optional_args_state (store : t) ~find_decl ~is_live : 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 (OptionalArgs.is_empty state_to) then ( let updated_from, updated_to = OptionalArgs.combine_pair state_from state_to in diff --git a/analysis/reanalyze/src/DceConfig.ml b/analysis/reanalyze/src/DceConfig.ml index ce7a074061..396185a1bb 100644 --- a/analysis/reanalyze/src/DceConfig.ml +++ b/analysis/reanalyze/src/DceConfig.ml @@ -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 = RunConfig.run_config; cli} diff --git a/analysis/reanalyze/src/DceFileProcessing.ml b/analysis/reanalyze/src/DceFileProcessing.ml index 8b18d01aa1..c0c9a59318 100644 --- a/analysis/reanalyze/src/DceFileProcessing.ml +++ b/analysis/reanalyze/src/DceFileProcessing.ml @@ -15,11 +15,11 @@ 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 = { @@ -30,9 +30,9 @@ 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 + DeadValue.process_signature_item ~config ~decls ~file:dead_common_file + ~do_values ~do_types ~module_loc:Location.none + ~module_path:ModulePath.initial ~path:[module_name_tagged file] sig_item) @@ -46,7 +46,7 @@ type file_data = { file_deps: FileDeps.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 = @@ -67,19 +67,19 @@ let process_cmt_file ~config ~(file : file_context) ~cmtFilePath (match cmt_infos.cmt_annots with | Interface signature -> CollectAnnotations.signature ~state:annotations ~config signature; - processSignature ~config ~decls ~file ~doValues:true ~doTypes:true + 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 + ~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 + DeadValue.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/DceFileProcessing.mli index 09b12aa322..ce2a63fa35 100644 --- a/analysis/reanalyze/src/DceFileProcessing.mli +++ b/analysis/reanalyze/src/DceFileProcessing.mli @@ -23,7 +23,7 @@ type file_data = { val process_cmt_file : config:DceConfig.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/DcePath.ml b/analysis/reanalyze/src/DcePath.ml index 5d73e9ff04..dbac43222c 100644 --- a/analysis/reanalyze/src/DcePath.ml +++ b/analysis/reanalyze/src/DcePath.ml @@ -3,46 +3,46 @@ type t = Name.t list -let toName (path : t) = - path |> List.rev_map Name.toString |> String.concat "." |> Name.create +let to_name (path : t) = + path |> List.rev_map Name.to_string |> String.concat "." |> Name.create -let toString path = path |> toName |> Name.toString +let to_string path = path |> to_name |> Name.to_string -let withoutHead path = +let without_head path = match - path |> List.rev_map (fun n -> n |> Name.toInterface |> Name.toString) + path |> List.rev_map (fun n -> n |> Name.to_interface |> Name.to_string) with | _ :: tl -> tl |> String.concat "." | [] -> "" -let onOkPath ~whenContainsApply ~f path = +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 -> whenContainsApply + | `Contains_apply -> when_contains_apply -let fromPathT path = +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 moduleToImplementation path = +let module_to_implementation path = match path |> List.rev with - | moduleName :: rest -> - (moduleName |> Name.toImplementation) :: rest |> List.rev + | module_name :: rest -> + (module_name |> Name.to_implementation) :: rest |> List.rev | [] -> path -let moduleToInterface path = +let module_to_interface path = match path |> List.rev with - | moduleName :: rest -> (moduleName |> Name.toInterface) :: rest |> List.rev + | module_name :: rest -> (module_name |> Name.to_interface) :: rest |> List.rev | [] -> path -let toModuleName ~isType path = +let to_module_name ~is_type path = match path with - | _ :: tl when not isType -> tl |> toName - | _ :: _ :: tl when isType -> tl |> toName + | _ :: tl when not is_type -> tl |> to_name + | _ :: _ :: tl when is_type -> tl |> to_name | _ -> "" |> Name.create -let typeToInterface path = +let type_to_interface path = match path with - | typeName :: rest -> (typeName |> Name.toInterface) :: rest + | type_name :: rest -> (type_name |> Name.to_interface) :: rest | [] -> path diff --git a/analysis/reanalyze/src/DeadCode.ml b/analysis/reanalyze/src/DeadCode.ml index d52b784a47..3119f86365 100644 --- a/analysis/reanalyze/src/DeadCode.ml +++ b/analysis/reanalyze/src/DeadCode.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 = DceFileProcessing.process_cmt_file diff --git a/analysis/reanalyze/src/DeadCommon.ml b/analysis/reanalyze/src/DeadCommon.ml index a2434473c0..0efabf86f1 100644 --- a/analysis/reanalyze/src/DeadCommon.ml +++ b/analysis/reanalyze/src/DeadCommon.ml @@ -3,32 +3,32 @@ module FileContext = struct (** 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 alias for declaration hashtables *) @@ -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 ( +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.DceConfig.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) + FileDeps.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 : FileContext.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. @@ -104,61 +104,61 @@ let addDeclaration_ ~config ~decls ~(file : FileContext.t) ?posEnd ?posStart if (not loc.loc_ghost) && pos.pos_fname = file.source_path then ( if config.DceConfig.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 |> DcePath.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 = OptionalArgs.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 + AnalysisResult.make_dead_issue ~loc ~dead_warning + ~path:(DcePath.without_head decl.path) ~message -let isInsideReportedValue (ctx : ReportingContext.t) decl = +let is_inside_reported_value (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 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 + ReportingContext.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 +167,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) && PosSet.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 +177,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 +let report_declaration ~config ~has_ref_below ?check_module_dead ?should_report (ctx : ReportingContext.t) decl : Issue.t list = - let insideReportedValue = decl |> isInsideReportedValue ctx in + 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 +191,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,40 +226,40 @@ 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.DceConfig.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) + |> DcePath.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 + DeadModules.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 = +let do_report_dead ~ann_store pos = not (AnnotationStore.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 : +let solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state + ~check_optional_arg: + (check_optional_arg_fn : optional_args_state:OptionalArgsState.t -> ann_store:AnnotationStore.t -> config:DceConfig.t -> @@ -304,19 +304,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 + |> List.fast_sort Decl.compare_for_reporting in all_decls @@ -337,8 +337,8 @@ 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 |> DcePath.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 = @@ -390,7 +390,7 @@ let solveDeadForward ~ann_store ~config ~decl_store ~refs ~optional_args_state if PosHash.mem live src_pos then "live" else "dead" in Log_.item " <- %s (%s)@." - (src_decl.path |> DcePath.toString) + (src_decl.path |> DcePath.to_string) src_status | None -> ())) sources; @@ -404,7 +404,7 @@ let solveDeadForward ~ann_store ~config ~decl_store ~refs ~optional_args_state match DeclarationStore.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 |> DcePath.to_string); true in let shown = ref 0 in @@ -421,46 +421,46 @@ 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) + |> DeadModules.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; + |> DeadModules.mark_live ~config + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + ~loc:decl.module_loc; if AnnotationStore.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 + |> DcePath.to_module_name ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + |> DeadModules.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 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 @@ -468,11 +468,11 @@ let solveDeadForward ~ann_store ~config ~decl_store ~refs ~optional_args_state (** 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 : + ~check_optional_arg: + (check_optional_arg_fn : optional_args_state:OptionalArgsState.t -> ann_store:AnnotationStore.t -> config:DceConfig.t -> @@ -484,7 +484,7 @@ let solveDeadReactive ~ann_store ~config ~decl_store ~value_refs_from 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,7 +493,7 @@ 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 @@ -502,7 +502,7 @@ let solveDeadReactive ~ann_store ~config ~decl_store ~value_refs_from DeclarationStore.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 @@ -535,53 +535,53 @@ 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 |> DcePath.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) + |> DeadModules.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; + |> DeadModules.mark_live ~config + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + ~loc:decl.module_loc; if AnnotationStore.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 + |> DcePath.to_module_name ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + |> DeadModules.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 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 @@ -612,12 +612,12 @@ let solveDeadReactive ~ann_store ~config ~decl_store ~value_refs_from AnalysisResult.add_issues AnalysisResult.empty all_issues (** Main entry point - uses forward solver. *) -let solveDead ~ann_store ~config ~decl_store ~ref_store ~optional_args_state - ~checkOptionalArg : AnalysisResult.t = +let solve_dead ~ann_store ~config ~decl_store ~ref_store ~optional_args_state + ~check_optional_arg : AnalysisResult.t = match ReferenceStore.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/DeadException.ml b/analysis/reanalyze/src/DeadException.ml index f0b6a7f255..d9b5306860 100644 --- a/analysis/reanalyze/src/DeadException.ml +++ b/analysis/reanalyze/src/DeadException.ml @@ -11,13 +11,13 @@ let find_exception_from_decls (decls : Declarations.t) : let index = Declarations.fold (fun _pos (decl : Decl.t) acc -> - match decl.Decl.declKind with + 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.posEnd; + loc_end = decl.pos_end; loc_ghost = false; } in @@ -27,21 +27,21 @@ let find_exception_from_decls (decls : Declarations.t) : 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; +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 markAsUsed ~config ~refs ~file_deps ~cross_file ~(binding : Location.t) - ~(locFrom : Location.t) ~(locTo : Location.t) path_ = - if locTo.loc_ghost then +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 exceptionPath = - path_ |> DcePath.fromPathT |> DcePath.moduleToImplementation + let exception_path = + path_ |> DcePath.from_path_t |> DcePath.module_to_implementation in - CrossFileItems.add_exception_ref cross_file ~exception_path:exceptionPath - ~loc_from:locFrom + CrossFileItems.add_exception_ref cross_file ~exception_path:exception_path + ~loc_from:loc_from else - addValueReference ~config ~refs ~file_deps ~binding ~addFileReference:true - ~locFrom ~locTo + add_value_reference ~config ~refs ~file_deps ~binding ~add_file_reference:true + ~loc_from ~loc_to diff --git a/analysis/reanalyze/src/DeadException.mli b/analysis/reanalyze/src/DeadException.mli index 5988ee80eb..9cd4f2cd6d 100644 --- a/analysis/reanalyze/src/DeadException.mli +++ b/analysis/reanalyze/src/DeadException.mli @@ -8,18 +8,18 @@ val add : file:FileContext.t -> path:DcePath.t -> loc:Location.t -> - strLoc:Location.t -> - moduleLoc:Location.t -> + str_loc:Location.t -> + module_loc:Location.t -> Name.t -> Name.t -val markAsUsed : +val mark_as_used : config:DceConfig.t -> refs:References.builder -> file_deps:FileDeps.builder -> cross_file:CrossFileItems.builder -> binding:Location.t -> - locFrom:Location.t -> - locTo:Location.t -> + loc_from:Location.t -> + loc_to:Location.t -> Path.t -> unit diff --git a/analysis/reanalyze/src/DeadModules.ml b/analysis/reanalyze/src/DeadModules.ml index c8d512c371..0f6478675e 100644 --- a/analysis/reanalyze/src/DeadModules.ml +++ b/analysis/reanalyze/src/DeadModules.ml @@ -4,28 +4,28 @@ let active ~config = let table = Hashtbl.create 1 -let markDead ~config ~isType ~loc path = +let mark_dead ~config ~is_type ~loc path = if active ~config then - let moduleName = path |> DcePath.toModuleName ~isType in - match Hashtbl.find_opt table moduleName with + let module_name = path |> DcePath.to_module_name ~is_type in + match Hashtbl.find_opt table module_name with | Some _ -> () - | _ -> Hashtbl.replace table moduleName (false, loc) + | _ -> Hashtbl.replace table module_name (false, loc) -let markLive ~config ~isType ~(loc : Location.t) path = +let mark_live ~config ~is_type ~(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) + let module_name = path |> DcePath.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 checkModuleDead ~config ~fileName:pos_fname moduleName : Issue.t option = +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 moduleName with + match Hashtbl.find_opt table module_name with | Some (false, loc) -> - Hashtbl.remove table moduleName; + Hashtbl.remove table module_name; (* only report once *) let loc = if loc.loc_ghost then @@ -35,5 +35,5 @@ let checkModuleDead ~config ~fileName:pos_fname moduleName : Issue.t option = {Location.loc_start = pos; loc_end = pos; loc_ghost = false} else loc in - Some (AnalysisResult.make_dead_module_issue ~loc ~moduleName) + Some (AnalysisResult.make_dead_module_issue ~loc ~module_name) | _ -> None diff --git a/analysis/reanalyze/src/DeadOptionalArgs.ml b/analysis/reanalyze/src/DeadOptionalArgs.ml index 71bef0ac99..b4df1f9a0f 100644 --- a/analysis/reanalyze/src/DeadOptionalArgs.ml +++ b/analysis/reanalyze/src/DeadOptionalArgs.ml @@ -2,66 +2,66 @@ open DeadCommon let active () = true -let addFunctionReference ~config ~decls ~cross_file ~(locFrom : Location.t) - ~(locTo : Location.t) = +let add_function_reference ~config ~decls ~cross_file ~(loc_from : Location.t) + ~(loc_to : Location.t) = if active () then - let posTo = locTo.loc_start in - let posFrom = locFrom.loc_start in + 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 shouldAdd = - match Declarations.find_opt_builder decls posTo with - | Some {declKind = Value {optionalArgs}} -> - not (OptionalArgs.isEmpty optionalArgs) + let should_add = + match Declarations.find_opt_builder decls pos_to with + | Some {decl_kind = Value {optional_args}} -> + not (OptionalArgs.is_empty optional_args) | _ -> false in - if shouldAdd then ( + if should_add 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) + (pos_from |> Pos.to_string) (pos_to |> Pos.to_string); + CrossFileItems.add_function_reference cross_file ~pos_from:pos_from + ~pos_to:pos_to) -let rec hasOptionalArgs (texpr : Types.type_expr) = +let rec has_optional_args (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 + | Tarrow (_, t_to, _, _) -> has_optional_args t_to + | Tlink t -> has_optional_args t + | Tsubst t -> has_optional_args t | _ -> false -let rec fromTypeExpr (texpr : Types.type_expr) = +let rec from_type_expr (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 + | 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 addReferences ~config ~cross_file ~(locFrom : Location.t) - ~(locTo : Location.t) ~(binding : Location.t) ~path (argNames, argNamesMaybe) +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 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; + let pos_to = loc_to.loc_start in + let pos_from = binding.loc_start in + CrossFileItems.add_optional_arg_call cross_file ~pos_from:pos_from + ~pos_to:pos_to ~arg_names:arg_names ~arg_names_maybe:arg_names_maybe; if config.DceConfig.cli.debug then - let callPos = locFrom.loc_start in + let call_pos = loc_from.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)) + (path |> DcePath.from_path_t |> DcePath.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.declKind = Value {optionalArgs}} + | {Decl.decl_kind = Value {optional_args}} when active () && not (AnnotationStore.is_annotated_gentype_or_live ann_store decl.pos) @@ -70,11 +70,11 @@ let check ~optional_args_state ~ann_store ~config:_ decl : Issue.t list = let state = match OptionalArgsState.find_opt optional_args_state decl.pos with | Some s -> s - | None -> optionalArgs + | None -> optional_args in - let loc = decl |> declGetLoc in + let loc = decl |> decl_get_loc in let unused_issues = - OptionalArgs.foldUnused + OptionalArgs.fold_unused (fun s acc -> let issue : Issue.t = { @@ -84,13 +84,13 @@ let check ~optional_args_state ~ann_store ~config:_ decl : Issue.t list = description = DeadOptional { - deadOptional = WarningUnusedArgument; + dead_optional = WarningUnusedArgument; message = Format.asprintf "optional argument @{%s@} of function \ @{%s@} is never used" s - (decl.path |> DcePath.withoutHead); + (decl.path |> DcePath.without_head); }; } in @@ -98,8 +98,8 @@ let check ~optional_args_state ~ann_store ~config:_ decl : Issue.t list = state [] in let redundant_issues = - OptionalArgs.foldAlwaysUsed - (fun s nCalls acc -> + OptionalArgs.fold_always_used + (fun s n_calls acc -> let issue : Issue.t = { name = "Warning Redundant Optional Argument"; @@ -108,14 +108,14 @@ let check ~optional_args_state ~ann_store ~config:_ decl : Issue.t list = description = DeadOptional { - deadOptional = WarningRedundantOptionalArgument; + dead_optional = WarningRedundantOptionalArgument; message = Format.asprintf "optional argument @{%s@} of function \ @{%s@} is always supplied (%d calls)" s - (decl.path |> DcePath.withoutHead) - nCalls; + (decl.path |> DcePath.without_head) + n_calls; }; } in diff --git a/analysis/reanalyze/src/DeadType.ml b/analysis/reanalyze/src/DeadType.ml index 3d486aac38..9b45c6f1f1 100644 --- a/analysis/reanalyze/src/DeadType.ml +++ b/analysis/reanalyze/src/DeadType.ml @@ -2,38 +2,38 @@ open DeadCommon -let addTypeReference ~config ~refs ~posFrom ~posTo = +let add_type_reference ~config ~refs ~pos_from ~pos_to = if config.DceConfig.cli.debug then - Log_.item "addTypeReference %s --> %s@." (posFrom |> Pos.toString) - (posTo |> Pos.toString); - References.add_type_ref refs ~posTo ~posFrom + 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 extendTypeDependencies ~config ~refs (loc1 : Location.t) (loc2 : Location.t) +let extend_type_dependencies ~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 ( + 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.DceConfig.cli.debug then - Log_.item "extendTypeDependencies %s --> %s@." (posTo |> Pos.toString) - (posFrom |> Pos.toString); - addTypeReference ~config ~refs ~posFrom ~posTo) + 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 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 +let add_declaration ~config ~decls ~file ~(module_path : ModulePath.t) + ~(type_id : Ident.t) ~(type_kind : Types.type_kind) + ~(manifest_type_path : DcePath.t option) = + let module_context = module_path.path @ [FileContext.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 ~declKind ~path:pathToType ~loc - ?manifestTypePath ~moduleLoc:modulePath.loc ~posAdjustment typeLabelName + 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 typeKind with + match type_kind with | Type_record (l, _) -> List.iter (fun {Types.ld_id; ld_loc} -> Ident.name ld_id |> Name.create - |> processTypeLabel ~declKind:RecordLabel ~loc:ld_loc) + |> process_type_label ~decl_kind:RecordLabel ~loc:ld_loc) l | Type_variant decls -> List.iteri @@ -45,22 +45,22 @@ let addDeclaration ~config ~decls ~file ~(modulePath : ModulePath.t) (fun {Types.ld_id; ld_loc} -> Ident.name cd_id ^ "." ^ Ident.name ld_id |> Name.create - |> processTypeLabel ~declKind:RecordLabel ~loc:ld_loc) + |> process_type_label ~decl_kind:RecordLabel ~loc:ld_loc) lbls | Cstr_tuple _ -> () in - let posAdjustment = + let pos_adjustment = (* In Res the variant loc can include the | and spaces after it *) - let isRes = + let is_res = 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 + if is_res 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) + |> process_type_label ~decl_kind:VariantCase ~loc:cd_loc ~pos_adjustment) decls | _ -> () @@ -76,13 +76,13 @@ let process_type_label_dependencies ~config ~decls ~refs = 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} + {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.declKind with + match decl.Decl.decl_kind with | RecordLabel | VariantCase -> let loc = decl |> decl_raw_loc in let path = decl.path in @@ -102,9 +102,9 @@ let process_type_label_dependencies ~config ~decls ~refs = | loc0 :: rest -> rest |> List.iter (fun loc -> - extendTypeDependencies ~config ~refs loc loc0; - if not Config.reportTypesDeadOnlyInInterface then - extendTypeDependencies ~config ~refs loc0 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 @@ -117,49 +117,49 @@ let process_type_label_dependencies ~config ~decls ~refs = | 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] <> '+' + let is_interface_of_pathToType (path_to_type : DcePath.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.declKind with + match decl.Decl.decl_kind with | RecordLabel | VariantCase -> ( match decl.path with | [] -> () - | typeLabelName :: pathToType -> ( + | type_label_name :: path_to_type -> ( 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 + let is_interface = is_interface_of_pathToType path_to_type in + if not is_interface then + let path_1 = path_to_type |> DcePath.module_to_interface in + let path_2 = path_1 |> DcePath.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 -> - extendTypeDependencies ~config ~refs loc loc1; - if not Config.reportTypesDeadOnlyInInterface then - extendTypeDependencies ~config ~refs loc1 loc + 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 -> - extendTypeDependencies ~config ~refs loc loc2; - if not Config.reportTypesDeadOnlyInInterface then - extendTypeDependencies ~config ~refs loc2 loc + 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 = pathToType |> DcePath.moduleToImplementation in - let path1 = typeLabelName :: path_1 in + let path_1 = path_to_type |> DcePath.module_to_implementation in + let path1 = type_label_name :: 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)) + 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; @@ -184,36 +184,36 @@ let process_type_label_dependencies ~config ~decls ~refs = in Declarations.iter (fun _pos decl -> - match (decl.Decl.declKind, decl.manifestTypePath, decl.path) with + match (decl.Decl.decl_kind, decl.manifest_type_path, 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 + 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 currentTypePath - (decl.pos, manifestTypePath, [item]) + 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 currentTypePath (rep_pos, mtp0, item :: items)) + Hashtbl.replace groups current_type_path (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)) + |> 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, manifestTypePath, items) -> + |> 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, fieldName, currentLoc) -> - let manifestFieldPath = fieldName :: manifestTypePath in - match find_one manifestFieldPath with + |> 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 manifestLoc -> - extendTypeDependencies ~config ~refs currentLoc manifestLoc; - extendTypeDependencies ~config ~refs manifestLoc currentLoc)) + | 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/DeadValue.ml b/analysis/reanalyze/src/DeadValue.ml index 0bb26e9dca..ab97424abd 100644 --- a/analysis/reanalyze/src/DeadValue.ml +++ b/analysis/reanalyze/src/DeadValue.ml @@ -2,86 +2,86 @@ open DeadCommon -let checkAnyValueBindingWithNoSideEffects ~config ~decls ~file - ~(modulePath : ModulePath.t) +let check_any_value_binding_with_no_side_effects ~config ~decls ~file + ~(module_path : 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 + | Tpat_any when (not (SideEffects.check_expr expr)) && not loc.loc_ghost -> + let name = "_" |> Name.create ~is_interface:false in + let path = module_path.path @ [FileContext.module_name_tagged file] in name - |> addValueDeclaration ~config ~decls ~file ~path ~loc - ~moduleLoc:modulePath.loc ~sideEffects:false + |> add_value_declaration ~config ~decls ~file ~path ~loc + ~module_loc:module_path.loc ~side_effects: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 collect_value_binding ~config ~decls ~file ~(current_binding : Location.t) + ~(module_path : ModulePath.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 ~isInterface:false in - let optionalArgs = - vb.vb_expr.exp_type |> DeadOptionalArgs.fromTypeExpr - |> OptionalArgs.fromList + let name = Ident.name id |> Name.create ~is_interface:false in + let optional_args = + vb.vb_expr.exp_type |> DeadOptionalArgs.from_type_expr + |> OptionalArgs.from_list in let exists = match Declarations.find_opt_builder decls loc_start with - | Some {declKind = Value r} -> - r.optionalArgs <- optionalArgs; + | Some {decl_kind = Value r} -> + r.optional_args <- optional_args; true | _ -> false in - let path = modulePath.path @ [FileContext.module_name_tagged file] in - let isFirstClassModule = + let path = module_path.path @ [FileContext.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 isFirstClassModule then + (if (not exists) && not is_first_class_module then (* This is never toplevel currently *) - let isToplevel = oldLastBinding = Location.none in - let sideEffects = SideEffects.checkExpr vb.vb_expr in + let is_toplevel = old_last_binding = Location.none in + let side_effects = SideEffects.check_expr vb.vb_expr in name - |> addValueDeclaration ~config ~decls ~file ~isToplevel ~loc - ~moduleLoc:modulePath.loc ~optionalArgs ~path ~sideEffects); + |> 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 declKind = - match decl.declKind with + let decl_kind = + match decl.decl_kind with | Value vk -> Decl.Kind.Value - {vk with sideEffects = SideEffects.checkExpr vb.vb_expr} + {vk with side_effects = SideEffects.check_expr 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; + decl_kind; + pos_end = vb.vb_loc.loc_end; + pos_start = 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 process_optional_args ~config ~cross_file ~exp_type ~(loc_from : Location.t) + ~(binding : Location.t) ~loc_to ~path args = + if exp_type |> DeadOptionalArgs.has_optional_args then ( let supplied = ref [] in - let suppliedMaybe = ref [] in + let supplied_maybe = ref [] in args |> List.iter (fun (lbl, arg) -> - let argIsSupplied = + let arg_is_supplied = match arg with | Some { @@ -99,59 +99,59 @@ let processOptionalArgs ~config ~cross_file ~expType ~(locFrom : Location.t) | 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 + | 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, !suppliedMaybe) - |> DeadOptionalArgs.addReferences ~config ~cross_file ~locFrom ~locTo + (!supplied, !supplied_maybe) + |> DeadOptionalArgs.add_references ~config ~cross_file ~loc_from ~loc_to ~binding ~path) -let rec collectExpr ~config ~refs ~file_deps ~cross_file +let rec collect_expr ~config ~refs ~file_deps ~cross_file ~(last_binding : Location.t) super self (e : Typedtree.expression) = - let locFrom = e.exp_loc in + 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 locTo}) -> + | Texp_ident (_path, _, {Types.val_loc = {loc_ghost = false; _} as loc_to}) -> (* if Path.name _path = "rc" then assert false; *) - if locFrom = locTo && _path |> Path.name = "emptyArray" then ( + 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.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) + (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 - addValueReference ~config ~refs ~file_deps ~binding ~addFileReference:true - ~locFrom ~locTo + 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 locTo}); + (path, _, {Types.val_loc = {loc_ghost = false; _} as loc_to}); exp_type; }; args; } -> args - |> processOptionalArgs ~config ~cross_file ~expType:exp_type - ~locFrom:(locFrom : Location.t) - ~binding:last_binding ~locTo ~path + |> process_optional_args ~config ~cross_file ~exp_type: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 (idArg, _)}; + vb_pat = {pat_desc = Tpat_var (id_arg, _)}; vb_expr = { exp_desc = Texp_ident - (path, _, {Types.val_loc = {loc_ghost = false; _} as locTo}); + (path, _, {Types.val_loc = {loc_ghost = false; _} as loc_to}); exp_type; }; }; @@ -162,42 +162,42 @@ let rec collectExpr ~config ~refs ~file_deps ~cross_file { case = { - c_lhs = {pat_desc = Tpat_var (etaArg, _)}; + c_lhs = {pat_desc = Tpat_var (eta_arg, _)}; c_rhs = { exp_desc = Texp_apply { - funct = {exp_desc = Texp_ident (idArg2, _, _)}; + funct = {exp_desc = Texp_ident (id_arg2, _, _)}; args; }; }; }; }; } ) - when Ident.name idArg = "arg" - && Ident.name etaArg = "eta" - && Path.name idArg2 = "arg" -> + when Ident.name id_arg = "arg" + && Ident.name eta_arg = "eta" + && Path.name id_arg2 = "arg" -> args - |> processOptionalArgs ~config ~cross_file ~expType:exp_type - ~locFrom:(locFrom : Location.t) - ~binding:last_binding ~locTo ~path + |> process_optional_args ~config ~cross_file ~exp_type:exp_type + ~loc_from:(loc_from : Location.t) + ~binding:last_binding ~loc_to ~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 + (_, _, {lbl_loc = {Location.loc_start = pos_to; loc_ghost = false}; _}) -> + if !Config.analyze_types then + DeadType.add_type_reference ~config ~refs ~pos_to ~pos_from:loc_from.loc_start | Texp_construct ( _, - {cstr_loc = {Location.loc_start = posTo; loc_ghost} as locTo; cstr_tag}, + {cstr_loc = {Location.loc_start = pos_to; loc_ghost} as loc_to; cstr_tag}, _ ) -> (match cstr_tag with | Cstr_extension path -> path - |> DeadException.markAsUsed ~config ~refs ~file_deps ~cross_file ~binding - ~locFrom ~locTo + |> DeadException.mark_as_used ~config ~refs ~file_deps ~cross_file ~binding + ~loc_from ~loc_to | _ -> ()); - if !Config.analyzeTypes && not loc_ghost then - DeadType.addTypeReference ~config ~refs ~posTo ~posFrom:locFrom.loc_start + if !Config.analyze_types && not loc_ghost then + DeadType.add_type_reference ~config ~refs ~pos_to ~pos_from:loc_from.loc_start | Texp_record {fields} -> fields |> Array.iter (fun (_, record_label_definition, _) -> @@ -206,7 +206,7 @@ let rec collectExpr ~config ~refs ~file_deps ~cross_file -> (* 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 + collect_expr ~config ~refs ~file_deps ~cross_file ~last_binding super self e |> ignore | _ -> ()) @@ -223,75 +223,75 @@ let rec collectExpr ~config ~refs ~file_deps ~cross_file With this annotation we declare a new type for each branch to allow the function to be typed. *) -let collectPattern ~config ~refs : +let collect_pattern ~config ~refs : _ -> _ -> Typedtree.pattern -> Typedtree.pattern = fun super self pat -> - let posFrom = pat.Typedtree.pat_loc.loc_start in + 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 = posTo}}, _pat, _) -> - if !Config.analyzeTypes then - DeadType.addTypeReference ~config ~refs ~posFrom ~posTo) + |> List.iter (fun (_loc, {Types.lbl_loc = {loc_start = pos_to}}, _pat, _) -> + if !Config.analyze_types then + DeadType.add_type_reference ~config ~refs ~pos_from ~pos_to) | _ -> ()); super.Tast_mapper.pat self pat -let rec getSignature (moduleType : Types.module_type) = - match moduleType with +let rec get_signature (module_type : Types.module_type) = + match module_type with | Mty_signature signature -> signature - | Mty_functor (_, _mtParam, mt) -> getSignature mt + | Mty_functor (_, _mtParam, mt) -> get_signature mt | _ -> [] -let rec processSignatureItem ~config ~decls ~file ~doTypes ~doValues ~moduleLoc - ~(modulePath : ModulePath.t) ~path (si : Types.signature_item) = +let rec process_signature_item ~config ~decls ~file ~do_types ~do_values ~module_loc + ~(module_path : ModulePath.t) ~path (si : Types.signature_item) = match si with - | Sig_type (id, t, _) when doTypes -> - if !Config.analyzeTypes then + | 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 manifestTypePath = + let manifest_type_path = match t.type_manifest with | Some {desc = Tconstr (path, _, _)} -> ( - let p = path |> DcePath.fromPathT in + let p = path |> DcePath.from_path_t in match p with - | [typeName] -> - let moduleContext = - modulePath.path @ [FileContext.module_name_tagged file] + | [type_name] -> + let module_context = + module_path.path @ [FileContext.module_name_tagged file] in - Some (typeName :: moduleContext) + Some (type_name :: module_context) | _ -> Some - (if FileContext.isInterface file then DcePath.moduleToInterface p - else DcePath.moduleToImplementation p)) + (if FileContext.is_interface file then DcePath.module_to_interface p + else DcePath.module_to_implementation p)) | _ -> None in - DeadType.addDeclaration ~config ~decls ~file ~modulePath ~typeId:id - ~typeKind:t.type_kind ~manifestTypePath + DeadType.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 doValues -> + when do_values -> if not loc.Location.loc_ghost then - let isPrimitive = + let is_primitive = match kind with | Val_prim _ -> true | _ -> false in - if (not isPrimitive) || !Config.analyzeExternals then - let optionalArgs = - val_type |> DeadOptionalArgs.fromTypeExpr |> OptionalArgs.fromList + if (not is_primitive) || !Config.analyze_externals then + let optional_args = + val_type |> DeadOptionalArgs.from_type_expr |> OptionalArgs.from_list 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}) -> + |> 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' = - ModulePath.enterModule modulePath + ModulePath.enter_module module_path ~name:(id |> Ident.name |> Name.create) - ~loc:moduleLoc + ~loc:module_loc in let collect = match si with @@ -299,17 +299,17 @@ let rec processSignatureItem ~config ~decls ~file ~doTypes ~doValues ~moduleLoc | _ -> true in if collect then - getSignature moduleType + get_signature module_type |> List.iter - (processSignatureItem ~config ~decls ~file ~doTypes ~doValues - ~moduleLoc ~modulePath:modulePath' + (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 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 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 : ModulePath.t) = let super = Tast_mapper.default in let rec mapper = @@ -318,48 +318,48 @@ let traverseStructure ~config ~decls ~refs ~file_deps ~cross_file ~file ~doTypes expr = (fun _self e -> e - |> collectExpr ~config ~refs ~file_deps ~cross_file ~last_binding + |> collect_expr ~config ~refs ~file_deps ~cross_file ~last_binding super mapper); - pat = (fun _self p -> p |> collectPattern ~config ~refs super mapper); + pat = (fun _self p -> p |> collect_pattern ~config ~refs super mapper); structure_item = - (fun _self (structureItem : Typedtree.structure_item) -> + (fun _self (structure_item : Typedtree.structure_item) -> let modulePath_for_item_opt = - match structureItem.str_desc with + match structure_item.str_desc with | Tstr_module {mb_expr; mb_id; mb_loc} -> - let hasInterface = + let has_interface = match mb_expr.mod_desc with | Tmod_constraint _ -> true | _ -> false in let modulePath' = - ModulePath.enterModule modulePath + ModulePath.enter_module module_path ~name:(mb_id |> Ident.name |> Name.create) ~loc:mb_loc in - if hasInterface then + if has_interface 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' + (process_signature_item ~config ~decls ~file ~do_types + ~do_values:false ~module_loc:mb_expr.mod_loc + ~module_path:modulePath' ~path: (modulePath'.path @ [FileContext.module_name_tagged file])) | _ -> () else (); Some modulePath' - | Tstr_primitive vd when doExternals && !Config.analyzeExternals + | Tstr_primitive vd when do_externals && !Config.analyze_externals -> let path = - modulePath.path @ [FileContext.module_name_tagged file] + module_path.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 + | Some {decl_kind = Value _} -> true | _ -> false in let id = vd.val_id |> Ident.name in @@ -369,62 +369,62 @@ let traverseStructure ~config ~decls ~refs ~file_deps ~cross_file ~file ~doTypes (* 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; + |> 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, typeDeclarations) when doTypes -> - if !Config.analyzeTypes then - typeDeclarations + | Tstr_type (_recFlag, type_declarations) when do_types -> + if !Config.analyze_types then + type_declarations |> List.iter - (fun (typeDeclaration : Typedtree.type_declaration) -> + (fun (type_declaration : Typedtree.type_declaration) -> (* Extract manifest type path for type re-exports (type y = x = {...}). *) - let manifestTypePath = - match typeDeclaration.typ_manifest with + let manifest_type_path = + match type_declaration.typ_manifest with | Some {ctyp_desc = Ttyp_constr (path, _, _)} -> ( - let p = path |> DcePath.fromPathT in + let p = path |> DcePath.from_path_t in match p with - | [typeName] -> - let moduleContext = - modulePath.path + | [type_name] -> + let module_context = + module_path.path @ [FileContext.module_name_tagged file] in - Some (typeName :: moduleContext) + Some (type_name :: module_context) | _ -> Some - (if FileContext.isInterface file then - DcePath.moduleToInterface p - else DcePath.moduleToImplementation p)) + (if FileContext.is_interface file then + DcePath.module_to_interface p + else DcePath.module_to_implementation p)) | _ -> None in - DeadType.addDeclaration ~config ~decls ~file - ~modulePath ~typeId:typeDeclaration.typ_id - ~typeKind:typeDeclaration.typ_type.type_kind - ~manifestTypePath); + DeadType.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 currentPath = - modulePath.path @ [FileContext.module_name_tagged file] + let current_path = + module_path.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) + (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 = - modulePath.path @ [FileContext.module_name_tagged file] + module_path.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 + ~str_loc:structure_item.str_loc ~module_loc:module_path.loc name); None | _ -> None @@ -435,15 +435,15 @@ let traverseStructure ~config ~decls ~refs ~file_deps ~cross_file ~file ~doTypes | Some modulePath_for_item -> create_mapper last_binding modulePath_for_item in - super.structure_item mapper_for_item structureItem); + super.structure_item mapper_for_item structure_item); value_binding = (fun _self vb -> let loc = vb - |> collectValueBinding ~config ~decls ~file - ~current_binding:last_binding ~modulePath + |> collect_value_binding ~config ~decls ~file + ~current_binding:last_binding ~module_path in - let nested_mapper = create_mapper loc modulePath in + let nested_mapper = create_mapper loc module_path in super.Tast_mapper.value_binding nested_mapper vb); } in @@ -453,32 +453,32 @@ let traverseStructure ~config ~decls ~refs ~file_deps ~cross_file ~file ~doTypes mapper.structure mapper structure |> ignore (* Merge a location's references to another one's *) -let processValueDependency ~config ~decls ~refs ~file_deps ~cross_file +let process_value_dependency ~config ~decls ~refs ~file_deps ~cross_file ( ({ val_loc = - {loc_start = {pos_fname = fnTo} as posTo; loc_ghost = ghost1} as - locTo; + {loc_start = {pos_fname = fn_to} as pos_to; loc_ghost = ghost1} as + loc_to; } : Types.value_description), ({ val_loc = - {loc_start = {pos_fname = fnFrom} as posFrom; loc_ghost = ghost2} as - locFrom; + {loc_start = {pos_fname = fn_from} as pos_from; loc_ghost = ghost2} as + loc_from; } : 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) + 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; + DeadOptionalArgs.add_function_reference ~config ~decls ~cross_file ~loc_from + ~loc_to) -let processStructure ~config ~decls ~refs ~file_deps ~cross_file ~file - ~cmt_value_dependencies ~doTypes ~doExternals +let process_structure ~config ~decls ~refs ~file_deps ~cross_file ~file + ~cmt_value_dependencies ~do_types ~do_externals (structure : Typedtree.structure) = - traverseStructure ~config ~decls ~refs ~file_deps ~cross_file ~file ~doTypes - ~doExternals structure; - let valueDependencies = cmt_value_dependencies |> List.rev in - valueDependencies + 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 - (processValueDependency ~config ~decls ~refs ~file_deps ~cross_file) + (process_value_dependency ~config ~decls ~refs ~file_deps ~cross_file) diff --git a/analysis/reanalyze/src/Decl.ml b/analysis/reanalyze/src/Decl.ml index d36b825eb1..e98a33d553 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: OptionalArgs.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; + decl_kind: Kind.t; + module_loc: Location.t; + pos_adjustment: pos_adjustment; path: DcePath.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: DcePath.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/EmitJson.ml b/analysis/reanalyze/src/EmitJson.ml index 6a636bc8c0..5a10de9c63 100644 --- a/analysis/reanalyze/src/EmitJson.ml +++ b/analysis/reanalyze/src/EmitJson.ml @@ -3,28 +3,28 @@ 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 emit_close () = "\n}" +let json_string text = Yojson.Safe.to_string (`String text) -let emitItem ~ppf ~name ~kind ~file ~range ~message = +let emit_item ~ppf ~name ~kind ~file ~range ~message = let open Format in items := !items + 1; - let startLine, startCharacter, endLine, endCharacter = range in + 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" (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) + 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 locToPos (loc : Location.t) = +let loc_to_pos (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 emit_annotate ~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) + line character (json_string text) (json_string action) diff --git a/analysis/reanalyze/src/Exception.ml b/analysis/reanalyze/src/Exception.ml index 0cd48824b0..2a568a5d36 100644 --- a/analysis/reanalyze/src/Exception.ml +++ b/analysis/reanalyze/src/Exception.ml @@ -8,57 +8,57 @@ type values_table = (string, (Name.t, Exceptions.t) Hashtbl.t) Hashtbl.t 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 +let values_builder_add (builder : values_builder) ~module_path ~name exceptions = + let path = (name |> Name.create) :: module_path.ModulePath.path in + Hashtbl.replace builder (path |> DcePath.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 (moduleName, builder) -> - Hashtbl.replace table moduleName builder); + |> List.iter (fun (module_name, builder) -> + Hashtbl.replace table module_name builder); table module Values = struct - let getFromModule (table : values_table) ~moduleName ~modulePath + let get_from_module (table : values_table) ~module_name ~module_path (path_ : DcePath.t) = - let name = path_ @ modulePath |> DcePath.toName in - match Hashtbl.find_opt table (String.capitalize_ascii moduleName) with + let name = path_ @ module_path |> DcePath.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 moduleName) with + match Hashtbl.find_opt table (String.uncapitalize_ascii module_name) 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 + 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 modulePath with + match module_path with | [] -> None - | _ :: restModulePath -> - path |> findLocal table ~moduleName ~modulePath:restModulePath) + | _ :: rest_module_path -> + path |> find_local table ~module_name ~module_path:rest_module_path) - let findPath (table : values_table) ~moduleName ~modulePath path = - let findExternal ~externalModuleName ~pathRev = - pathRev |> List.rev - |> getFromModule table - ~moduleName:(externalModuleName |> Name.toString) - ~modulePath:[] + 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 |> findLocal table ~moduleName ~modulePath with + match path |> find_local table ~module_name ~module_path with | None -> ( (* Search in another file *) match path |> List.rev with - | externalModuleName :: pathRev -> ( - match (findExternal ~externalModuleName ~pathRev, pathRev) with + | external_module_name :: path_rev -> ( + match (find_external ~external_module_name ~path_rev, path_rev) with | (Some _ as found), _ -> found - | None, externalModuleName2 :: pathRev2 - when !Cli.cmtCommand && pathRev2 <> [] -> + | None, external_module_name2 :: path_rev2 + when !Cli.cmt_command && path_rev2 <> [] -> (* Simplistic namespace resolution for dune namespace: skip the root of the path *) - findExternal ~externalModuleName:externalModuleName2 ~pathRev:pathRev2 + find_external ~external_module_name:external_module_name2 ~path_rev:path_rev2 | None, _ -> None) | [] -> None) | Some exceptions -> Some exceptions @@ -67,7 +67,7 @@ end module Event = struct type kind = | Catches of t list (* with | E => ... *) - | Call of {callee: DcePath.t; modulePath: DcePath.t} (* foo() *) + | Call of {callee: DcePath.t; module_path: DcePath.t} (* foo() *) | DoesNotThrow of t list (* DoesNotThrow(events) where events come from an expression *) | Throws (** throw E *) @@ -76,59 +76,59 @@ module Event = struct let rec print ppf event = match event with - | {kind = Call {callee; modulePath}; exceptions; loc} -> + | {kind = Call {callee; module_path}; 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) + (loc.loc_start |> Pos.to_string) + (callee |> DcePath.to_string) + (module_path |> DcePath.to_string) + (Exceptions.pp ~exn_table:None) exceptions - | {kind = DoesNotThrow nestedEvents; loc} -> + | {kind = DoesNotThrow nested_events; loc} -> Format.fprintf ppf "%s DoesNotThrow(%a)@." - (loc.loc_start |> Pos.toString) + (loc.loc_start |> Pos.to_string) (fun ppf () -> - nestedEvents |> List.iter (fun e -> Format.fprintf ppf "%a " print e)) + 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.toString) - (Exceptions.pp ~exnTable:None) + (loc.loc_start |> Pos.to_string) + (Exceptions.pp ~exn_table:None) exceptions - | {kind = Catches nestedEvents; exceptions; loc} -> + | {kind = Catches nested_events; exceptions; loc} -> Format.fprintf ppf "%s Catches exceptions:%a nestedEvents:%a@." - (loc.loc_start |> Pos.toString) - (Exceptions.pp ~exnTable:None) + (loc.loc_start |> Pos.to_string) + (Exceptions.pp ~exn_table:None) exceptions (fun ppf () -> - nestedEvents |> List.iter (fun e -> Format.fprintf ppf "%a " print e)) + nested_events |> List.iter (fun e -> Format.fprintf ppf "%a " print e)) () - let combine ~(values_table : values_table) ~config ~moduleName events = + let combine ~(values_table : values_table) ~config ~module_name 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) + 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 (LocSet.add loc loc_set) + | None -> Hashtbl.replace exn_table 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) + let shrink_exn_table exn loc = + match Hashtbl.find_opt exn_table exn with + | Some loc_set -> Hashtbl.replace exn_table exn (LocSet.remove loc loc_set) | None -> () in - let rec loop exnSet events = + let rec loop exn_set 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 -> + 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.DceConfig.cli.debug then Log_.item "%a@." print ev; let exceptions = match - callee |> Values.findPath values_table ~moduleName ~modulePath + callee |> Values.find_path values_table ~module_name ~module_path with | Some exceptions -> exceptions | _ -> ( @@ -136,15 +136,15 @@ module Event = struct | 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 -> + 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.DceConfig.cli.debug then Log_.item "%a@." print ev; - let nestedExceptions = loop Exceptions.empty nestedEvents in - (if Exceptions.isEmpty nestedExceptions (* catch-all *) then + let nested_exceptions = loop Exceptions.empty nested_events in + (if Exceptions.is_empty nested_exceptions (* catch-all *) then let name = - match nestedEvents with - | {kind = Call {callee}} :: _ -> callee |> DcePath.toName + match nested_events with + | {kind = Call {callee}} :: _ -> callee |> DcePath.to_name | _ -> "expression" |> Name.create in Log_.warning ~loc @@ -154,24 +154,24 @@ module Event = struct Format.asprintf "@{%s@} does not throw and is annotated with \ redundant @doesNotThrow" - (name |> Name.toString); + (name |> Name.to_string); })); - loop exnSet rest - | ({kind = Catches nestedEvents; exceptions} as ev) :: rest -> + loop exn_set rest + | ({kind = Catches nested_events; exceptions} as ev) :: rest -> if config.DceConfig.cli.debug then Log_.item "%a@." print ev; - if Exceptions.isEmpty exceptions then loop exnSet rest + if Exceptions.is_empty exceptions then loop exn_set rest else - let nestedExceptions = loop Exceptions.empty nestedEvents in - let newThrows = Exceptions.diff nestedExceptions exceptions in + let nested_exceptions = loop Exceptions.empty nested_events in + let new_throws = Exceptions.diff nested_exceptions exceptions in exceptions |> Exceptions.iter (fun exn -> - nestedEvents - |> List.iter (fun event -> shrinkExnTable exn event.loc)); - loop (Exceptions.union exnSet newThrows) rest - | [] -> exnSet + nested_events + |> List.iter (fun event -> shrink_exn_table exn event.loc)); + loop (Exceptions.union exn_set new_throws) rest + | [] -> exn_set in - let exnSet = loop Exceptions.empty events in - (exnSet, exnTable) + let exn_set = loop Exceptions.empty events in + (exn_set, exn_table) end type checks_builder = check list ref @@ -180,112 +180,112 @@ type checks_builder = check list ref and check = { events: Event.t list; loc: Location.t; - locFull: Location.t; - moduleName: string; - exnName: string; + 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 - ?(locFull = loc) ~moduleName exnName = - builder := {events; exceptions; loc; locFull; moduleName; exnName} :: !builder + ?(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 doCheck ~(values_table : values_table) ~config - {events; exceptions; loc; locFull; moduleName; exnName} = - let throwSet, exnTable = - events |> Event.combine ~values_table ~config ~moduleName + 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 missingAnnotations = Exceptions.diff throwSet exceptions in - let redundantAnnotations = Exceptions.diff exceptions throwSet in - (if not (Exceptions.isEmpty missingAnnotations) then + 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 - {exnName; exnTable; throwSet; missingAnnotations; locFull} + {exn_name; exn_table; throw_set; missing_annotations; loc_full} in Log_.warning ~loc description); - if not (Exceptions.isEmpty redundantAnnotations) then + if not (Exceptions.is_empty redundant_annotations) then Log_.warning ~loc (Issue.ExceptionAnalysis { message = - (let throwsDescription ppf () = - if throwSet |> Exceptions.isEmpty then + (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 ~exnTable:(Some exnTable)) - throwSet + (Exceptions.pp ~exn_table:(Some exn_table)) + throw_set in Format.asprintf "@{%s@} %a and is annotated with redundant @throws(%a)" - exnName throwsDescription () - (Exceptions.pp ~exnTable:None) - redundantAnnotations); + exn_name throws_description () + (Exceptions.pp ~exn_table:None) + redundant_annotations); }) - let doChecks ~values_table ~config (checks : check list) = - checks |> List.iter (doCheck ~values_table ~config) + let do_checks ~values_table ~config (checks : check list) = + checks |> List.iter (do_check ~values_table ~config) end -let traverseAst ~file ~values_builder ~checks_builder () = +let traverse_ast ~file ~values_builder ~checks_builder () = let super = Tast_mapper.default in - let currentId = ref "" in - let currentEvents = ref [] 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 findLocalExceptions ~modulePath path = - let name = path @ modulePath |> DcePath.toName in + let find_local_exceptions ~module_path path = + let name = path @ module_path |> DcePath.to_name in Hashtbl.find_opt values_builder name in - let rec findLocalPath ~modulePath path = - match path |> findLocalExceptions ~modulePath with + let rec find_local_path ~module_path path = + match path |> find_local_exceptions ~module_path with | Some exceptions -> Some exceptions | None -> ( - match modulePath with + match module_path with | [] -> None - | _ :: restModulePath -> path |> findLocalPath ~modulePath:restModulePath) + | _ :: rest_module_path -> path |> find_local_path ~module_path:rest_module_path) in - let exceptionsOfPatterns patterns = + let exceptions_of_patterns patterns = patterns |> List.fold_left (fun acc desc -> match desc with | Typedtree.Tpat_construct ({txt}, _, _) -> - Exceptions.add (Exn.fromLid txt) acc + Exceptions.add (Exn.from_lid txt) acc | _ -> acc) Exceptions.empty in - let iterExpr self e = self.Tast_mapper.expr self e |> ignore in - let iterExprOpt self eo = + 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 |> iterExpr self + | Some e -> e |> iter_expr self in - let iterPat self p = self.Tast_mapper.pat self p |> ignore in - let iterCases self cases = + 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 |> iterPat self; - case.c_guard |> iterExprOpt self; - case.c_rhs |> iterExpr self) + case.Typedtree.c_lhs |> iter_pat self; + case.c_guard |> iter_expr_opt self; + case.c_rhs |> iter_expr self) in - let isThrow s = s = "Pervasives.raise" || s = "Pervasives.throw" in - let throwArgs args = + 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.fromLid txt] |> Exceptions.fromList + [Exn.from_lid txt] |> Exceptions.from_list | [(_, Some {Typedtree.exp_desc = Texp_ident _})] -> - [Exn.fromString "genericException"] |> Exceptions.fromList - | _ -> [Exn.fromString "TODO_from_raise1"] |> Exceptions.fromList + [Exn.from_string "genericException"] |> Exceptions.from_list + | _ -> [Exn.from_string "TODO_from_raise1"] |> Exceptions.from_list in - let doesNotThrow attributes = + let does_not_throw attributes = attributes - |> Annotation.getAttributePayload (function + |> Annotation.get_attribute_payload (function | "doesNotRaise" | "doesnotraise" | "DoesNoRaise" | "doesNotraise" | "doNotRaise" | "donotraise" | "DoNoRaise" | "doNotraise" | "doesNotThrow" | "doesnotthrow" | "DoesNoThrow" | "doesNotthrow" @@ -294,244 +294,244 @@ let traverseAst ~file ~values_builder ~checks_builder () = | _ -> false) <> None in - let expr ~(modulePath : ModulePath.t) (self : Tast_mapper.mapper) + let expr ~(module_path : 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 := []; + 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_ |> DcePath.fromPathT |> ModulePath.resolveAlias modulePath + callee_ |> DcePath.from_path_t |> ModulePath.resolve_alias module_path in - let calleeName = callee |> DcePath.toName in - if calleeName |> Name.toString |> isThrow then + let callee_name = callee |> DcePath.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" - (calleeName |> Name.toString); + (callee_name |> Name.to_string); }); - currentEvents := + current_events := { Event.exceptions = Exceptions.empty; loc; - kind = Call {callee; modulePath = modulePath.path}; + kind = Call {callee; module_path = module_path.path}; } - :: !currentEvents + :: !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 |> isThrow + atat |> Path.name = "Pervasives.@@" && callee |> Path.name |> is_throw -> - let exceptions = [arg] |> throwArgs in - currentEvents := {Event.exceptions; loc; kind = Throws} :: !currentEvents; - arg |> snd |> iterExprOpt self + 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 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 + 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 = 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; + 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 - currentEvents := + current_events := { - Event.exceptions = [Exn.matchFailure] |> Exceptions.fromList; + Event.exceptions = [Exn.match_failure] |> Exceptions.from_list; loc; kind = Throws; } - :: !currentEvents + :: !current_events | Texp_try (e, cases) -> let exceptions = cases |> List.map (fun case -> case.Typedtree.c_lhs.pat_desc) - |> exceptionsOfPatterns + |> exceptions_of_patterns in - let oldEvents = !currentEvents in - currentEvents := []; - e |> iterExpr self; - currentEvents := - {Event.exceptions; loc; kind = Catches !currentEvents} :: oldEvents; - cases |> iterCases self + 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 isDoesNoThrow then - let nestedEvents = !currentEvents in - currentEvents := + (if is_does_no_throw then + let nested_events = !current_events in + current_events := { Event.exceptions = Exceptions.empty; loc; - kind = DoesNotThrow nestedEvents; + kind = DoesNotThrow nested_events; } - :: oldEvents); + :: old_events); expr in - let getExceptionsFromAnnotations attributes = - let throwsAnnotationPayload = + let get_exceptions_from_annotations attributes = + let throws_annotation_payload = attributes - |> Annotation.getAttributePayload (fun s -> + |> Annotation.get_attribute_payload (fun s -> s = "throws" || s = "throw" || s = "raises" || s = "raise") in - let rec getExceptions payload = + let rec get_exceptions payload = match payload with - | Annotation.StringPayload s -> [Exn.fromString s] |> Exceptions.fromList + | Annotation.StringPayload s -> [Exn.from_string s] |> Exceptions.from_list | Annotation.ConstructPayload s when s <> "::" -> - [Exn.fromString s] |> Exceptions.fromList + [Exn.from_string s] |> Exceptions.from_list | Annotation.IdentPayload s -> - [Exn.fromString (s |> Longident.flatten |> String.concat ".")] - |> Exceptions.fromList + [Exn.from_string (s |> Longident.flatten |> String.concat ".")] + |> Exceptions.from_list | Annotation.TuplePayload tuple -> tuple |> List.map (fun payload -> - payload |> getExceptions |> Exceptions.toList) - |> List.concat |> Exceptions.fromList + payload |> get_exceptions |> Exceptions.to_list) + |> List.concat |> Exceptions.from_list | _ -> Exceptions.empty in - match throwsAnnotationPayload with + match throws_annotation_payload with | None -> Exceptions.empty - | Some payload -> payload |> getExceptions + | Some payload -> payload |> get_exceptions in - let toplevelEval (self : Tast_mapper.mapper) (expr : Typedtree.expression) + let toplevel_eval (self : Tast_mapper.mapper) (expr : Typedtree.expression) attributes = - let oldId = !currentId in - let oldEvents = !currentEvents in + let old_id = !current_id in + let old_events = !current_events in let name = "Toplevel expression" in - currentId := name; - currentEvents := []; - let moduleName = file.FileContext.module_name in + current_id := name; + current_events := []; + let module_name = 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 + 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 ~(modulePath : ModulePath.t) (self : Tast_mapper.mapper) + let value_binding ~(module_path : ModulePath.t) (self : Tast_mapper.mapper) (vb : Typedtree.value_binding) = - let oldId = !currentId in - let oldEvents = !currentEvents in - let isFunction = + 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 isToplevel = !currentId = "" in - let processBinding name = - currentId := name; - currentEvents := []; - let exceptionsFromAnnotations = - getExceptionsFromAnnotations vb.vb_attributes + 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 ~modulePath ~name - exceptionsFromAnnotations; + values_builder_add values_builder ~module_path ~name + exceptions_from_annotations; let res = super.value_binding self vb in - let moduleName = file.FileContext.module_name in + let module_name = file.FileContext.module_name in let path = [name |> Name.create] in let exceptions = - match path |> findLocalPath ~modulePath:modulePath.path with + match path |> find_local_path ~module_path:module_path.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; + 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 isToplevel && not vb.vb_loc.loc_ghost -> processBinding "_" + | Tpat_any when is_toplevel && not vb.vb_loc.loc_ghost -> process_binding "_" | Tpat_construct ({txt}, _, _) - when isToplevel && (not vb.vb_loc.loc_ghost) + when is_toplevel && (not vb.vb_loc.loc_ghost) && txt = Longident.Lident "()" -> - processBinding "()" + process_binding "()" | Tpat_var (id, {loc = {loc_ghost}}) - when (isFunction || isToplevel) && (not loc_ghost) + when (is_function || is_toplevel) && (not loc_ghost) && not vb.vb_loc.loc_ghost -> - processBinding (id |> Ident.name) + process_binding (id |> Ident.name) | _ -> super.value_binding self vb in - let make_mapper (modulePath : ModulePath.t) : Tast_mapper.mapper = + let make_mapper (module_path : ModulePath.t) : Tast_mapper.mapper = let open Tast_mapper in { super with - expr = expr ~modulePath; - value_binding = value_binding ~modulePath; + expr = expr ~module_path; + value_binding = value_binding ~module_path; } in - let rec process_module_expr (modulePath : ModulePath.t) + let rec process_module_expr (module_path : ModulePath.t) (me : Typedtree.module_expr) = match me.mod_desc with - | Tmod_structure structure -> process_structure modulePath structure + | Tmod_structure structure -> process_structure module_path structure | Tmod_constraint (me1, _mty, _mtc, _coercion) -> - process_module_expr modulePath me1 + process_module_expr module_path me1 | Tmod_apply (me1, me2, _) -> - process_module_expr modulePath me1; - process_module_expr modulePath me2 + process_module_expr module_path me1; + process_module_expr module_path me2 | _ -> - let mapper = make_mapper modulePath in + let mapper = make_mapper module_path in super.module_expr mapper me |> ignore - and process_structure (modulePath : ModulePath.t) + and process_structure (module_path : ModulePath.t) (structure : Typedtree.structure) = let rec loop (mp : ModulePath.t) (items : Typedtree.structure_item list) = match items with | [] -> () - | structureItem :: rest -> + | structure_item :: rest -> let mapper = make_mapper mp in let mp' = - match structureItem.str_desc with + match structure_item.str_desc with | Tstr_eval (expr, attributes) -> - toplevelEval mapper 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 = ModulePath.enterModule mp ~name ~loc:mb_loc in + let mp_inside = ModulePath.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) -> - ModulePath.addAlias mp ~name ~path:(path_ |> DcePath.fromPathT) + ModulePath.add_alias mp ~name ~path:(path_ |> DcePath.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 = ModulePath.enterModule acc ~name ~loc:mb_loc in + let mp_inside = ModulePath.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) -> - ModulePath.addAlias acc ~name - ~path:(path_ |> DcePath.fromPathT) + ModulePath.add_alias acc ~name + ~path:(path_ |> DcePath.from_path_t) | _ -> acc) mp mbs | _ -> - super.structure_item mapper structureItem |> ignore; + super.structure_item mapper structure_item |> ignore; mp in loop mp' rest in - loop modulePath structure.str_items + loop module_path structure.str_items in fun (structure : Typedtree.structure) -> process_structure ModulePath.initial structure @@ -543,18 +543,18 @@ type file_result = { } (** Result of processing a single file *) -let processStructure ~file ~values_builder ~checks_builder +let process_structure ~file ~values_builder ~checks_builder (structure : Typedtree.structure) = - let process = traverseAst ~file ~values_builder ~checks_builder () in + let process = traverse_ast ~file ~values_builder ~checks_builder () in process structure -let processCmt ~file (cmt_infos : Cmt_format.cmt_infos) : file_result option = +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 |> processStructure ~file ~values_builder ~checks_builder; + structure |> process_structure ~file ~values_builder ~checks_builder; Some { module_name = file.FileContext.module_name; @@ -564,7 +564,7 @@ let processCmt ~file (cmt_infos : Cmt_format.cmt_infos) : file_result option = | _ -> None (** Process all accumulated checks using merged values table *) -let runChecks ~config (all_results : file_result list) = +let run_checks ~config (all_results : file_result list) = (* Merge all values builders *) let values_table = all_results @@ -574,4 +574,4 @@ let runChecks ~config (all_results : file_result list) = (* 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 + Checks.do_checks ~values_table ~config all_checks diff --git a/analysis/reanalyze/src/Exceptions.ml b/analysis/reanalyze/src/Exceptions.ml index 91ae2000aa..910c9a0db1 100644 --- a/analysis/reanalyze/src/Exceptions.ml +++ b/analysis/reanalyze/src/Exceptions.ml @@ -5,32 +5,32 @@ 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 from_list = ExnSet.of_list +let to_list = ExnSet.elements +let is_empty = 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 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 = - locSet |> LocSet.elements + loc_set |> 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 " ") + (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 isList = exceptions |> ExnSet.cardinal > 1 in - if isList then Format.fprintf ppf "["; - exceptions |> ExnSet.iter ppExn; - if isList then Format.fprintf ppf "]" + let is_list = exceptions |> ExnSet.cardinal > 1 in + if is_list then Format.fprintf ppf "["; + exceptions |> ExnSet.iter pp_exn; + if is_list then Format.fprintf ppf "]" diff --git a/analysis/reanalyze/src/Exn.ml b/analysis/reanalyze/src/Exn.ml index 1970d035b1..0f83bc988b 100644 --- a/analysis/reanalyze/src/Exn.ml +++ b/analysis/reanalyze/src/Exn.ml @@ -1,19 +1,19 @@ 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 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 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" +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 index c9c991847d..694e2ea442 100644 --- a/analysis/reanalyze/src/Exn.mli +++ b/analysis/reanalyze/src/Exn.mli @@ -1,19 +1,19 @@ type t val compare : t -> t -> int -val assertFailure : t -val decodeError : t -val divisionByZero : t -val endOfFile : t +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 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 +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/ExnLib.ml b/analysis/reanalyze/src/ExnLib.ml index 1104661b71..24a88a8fc6 100644 --- a/analysis/reanalyze/src/ExnLib.ml +++ b/analysis/reanalyze/src/ExnLib.ml @@ -1,244 +1,244 @@ -let raisesLibTable : (Name.t, Exceptions.t) Hashtbl.t = +let raises_lib_table : (Name.t, Exceptions.t) Hashtbl.t = let table = Hashtbl.create 15 in let open Exn in - let beltArray = + let belt_array = [ - ("getExn", [assertFailure]); - ("getOrThrow", [assertFailure]); - ("setExn", [assertFailure]); - ("setOrThrow", [assertFailure]); + ("getExn", [assert_failure]); + ("getOrThrow", [assert_failure]); + ("setExn", [assert_failure]); + ("setOrThrow", [assert_failure]); ] in - let beltList = + let belt_list = [ - ("getExn", [notFound]); - ("getOrThrow", [notFound]); - ("headExn", [notFound]); - ("headOrThrow", [notFound]); - ("tailExn", [notFound]); - ("tailOrThrow", [notFound]); + ("getExn", [not_found]); + ("getOrThrow", [not_found]); + ("headExn", [not_found]); + ("headOrThrow", [not_found]); + ("tailExn", [not_found]); + ("tailOrThrow", [not_found]); ] in - let beltMap = [("getExn", [notFound]); ("getOrThrow", [notFound])] in - let beltMutableMap = beltMap in - let beltMutableQueue = + let belt_map = [("getExn", [not_found]); ("getOrThrow", [not_found])] in + let belt_mutable_map = belt_map in + let belt_mutable_queue = [ - ("peekExn", [notFound]); - ("peekOrThrow", [notFound]); - ("popExn", [notFound]); - ("popOrThrow", [notFound]); + ("peekExn", [not_found]); + ("peekOrThrow", [not_found]); + ("popExn", [not_found]); + ("popOrThrow", [not_found]); ] 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 = + 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", [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]); + ("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", [jsExn]); - ("assertEqual", [jsExn]); - ("invalid_arg", [invalidArgument]); + ("panic", [js_exn]); + ("assertEqual", [js_exn]); + ("invalid_arg", [invalid_argument]); ("failwith", [failure]); - ("/", [divisionByZero]); - ("mod", [divisionByZero]); - ("char_of_int", [invalidArgument]); - ("bool_of_string", [invalidArgument]); + ("/", [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 stdlibBigInt = + let stdlib_big_int = [ - ("fromStringExn", [jsExn]); - ("fromStringOrThrow", [jsExn]); - ("fromFloatOrThrow", [jsExn]); + ("fromStringExn", [js_exn]); + ("fromStringOrThrow", [js_exn]); + ("fromFloatOrThrow", [js_exn]); ] in - let stdlibBool = + let stdlib_bool = [ - ("fromStringExn", [invalidArgument]); - ("fromStringOrThrow", [invalidArgument]); + ("fromStringExn", [invalid_argument]); + ("fromStringOrThrow", [invalid_argument]); ] in - let stdlibJsError = + let stdlib_js_error = [ - ("EvalError.throwWithMessage", [jsExn]); - ("RangeError.throwWithMessage", [jsExn]); - ("ReferenceError.throwWithMessage", [jsExn]); - ("SyntaxError.throwWithMessage", [jsExn]); - ("TypeError.throwWithMessage", [jsExn]); - ("URIError.throwWithMessage", [jsExn]); - ("panic", [jsExn]); - ("throw", [jsExn]); - ("throwWithMessage", [jsExn]); + ("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 stdlibError = - [("raise", [jsExn]); ("panic", [jsExn]); ("throw", [jsExn])] + let stdlib_error = + [("raise", [js_exn]); ("panic", [js_exn]); ("throw", [js_exn])] in - let stdlibExn = + let stdlib_exn = [ - ("raiseError", [jsExn]); - ("raiseEvalError", [jsExn]); - ("raiseRangeError", [jsExn]); - ("raiseReferenceError", [jsExn]); - ("raiseSyntaxError", [jsExn]); - ("raiseTypeError", [jsExn]); - ("raiseUriError", [jsExn]); + ("raiseError", [js_exn]); + ("raiseEvalError", [js_exn]); + ("raiseRangeError", [js_exn]); + ("raiseReferenceError", [js_exn]); + ("raiseSyntaxError", [js_exn]); + ("raiseTypeError", [js_exn]); + ("raiseUriError", [js_exn]); ] in - let stdlibJson = + let stdlib_json = [ - ("parseExn", [jsExn]); - ("parseExnWithReviver", [jsExn]); - ("parseOrThrow", [jsExn]); - ("stringifyAny", [jsExn]); - ("stringifyAnyWithIndent", [jsExn]); - ("stringifyAnyWithReplacer", [jsExn]); - ("stringifyAnyWithReplacerAndIndent", [jsExn]); - ("stringifyAnyWithFilter", [jsExn]); - ("stringifyAnyWithFilterAndIndent", [jsExn]); + ("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 stdlibList = - [("headExn", [notFound]); ("tailExn", [notFound]); ("getExn", [notFound])] + let stdlib_list = + [("headExn", [not_found]); ("tailExn", [not_found]); ("getExn", [not_found])] 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 = + 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", [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]); + ("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", 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); + ("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", stdlibResult); + ("Result", stdlib_result); ("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); + ("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.fromList))); + (e |> Exceptions.from_list))); table let find (path : DcePath.t) = - Hashtbl.find_opt raisesLibTable (path |> DcePath.toName) + Hashtbl.find_opt raises_lib_table (path |> DcePath.to_name) diff --git a/analysis/reanalyze/src/FileDeps.ml b/analysis/reanalyze/src/FileDeps.ml index ec83cb2896..b85c8d2858 100644 --- a/analysis/reanalyze/src/FileDeps.ml +++ b/analysis/reanalyze/src/FileDeps.ml @@ -94,60 +94,60 @@ let deps_count (t : t) = FileHash.length t.deps (** {2 Topological ordering} *) -let iter_files_from_roots_to_leaves (t : t) iterFun = +let iter_files_from_roots_to_leaves (t : t) iter_fun = (* For each file, the number of incoming references *) - let inverseReferences = (Hashtbl.create 256 : (string, int) Hashtbl.t) in + let inverse_references = (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 + let references_by_number = (Hashtbl.create 256 : (int, FileSet.t) Hashtbl.t) in + let get_num file_name = + try Hashtbl.find inverse_references file_name with Not_found -> 0 in - let getSet num = - try Hashtbl.find referencesByNumber num with Not_found -> FileSet.empty + let get_set num = + try Hashtbl.find references_by_number 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 + 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 = FileSet.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 = FileSet.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 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 + 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 = FileSet.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 = FileSet.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 addEdge fromFile toFile = - if file_exists t fromFile then addIncomingEdge toFile + let add_edge from_file to_file = + if file_exists t from_file then add_incoming_edge to_file in - let removeEdge fromFile toFile = - if file_exists t fromFile then removeIncomingEdge toFile + let remove_edge from_file to_file = + if file_exists t from_file then remove_incoming_edge to_file 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)) + iter_deps t (fun from_file set -> + if get_num from_file = 0 then + Hashtbl.replace references_by_number 0 (FileSet.add from_file (get_set 0)); + set |> FileSet.iter (fun to_file -> add_edge from_file to_file)); + while get_set 0 <> FileSet.empty do + let files_with_no_incoming_references = get_set 0 in + Hashtbl.remove references_by_number 0; + files_with_no_incoming_references + |> FileSet.iter (fun file_name -> + iter_fun file_name; + let references = get_deps t file_name in + references |> FileSet.iter (fun to_file -> remove_edge file_name to_file)) done; (* Process any remaining items in case of circular references *) - referencesByNumber + references_by_number |> Hashtbl.iter (fun _num set -> if FileSet.is_empty set then () - else set |> FileSet.iter (fun fileName -> iterFun fileName)) + else set |> FileSet.iter (fun file_name -> iter_fun file_name)) diff --git a/analysis/reanalyze/src/Issue.ml b/analysis/reanalyze/src/Issue.ml index ed9ab87b22..1cf66aa29a 100644 --- a/analysis/reanalyze/src/Issue.ml +++ b/analysis/reanalyze/src/Issue.ml @@ -4,16 +4,16 @@ module ExnSet = 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, LocSet.t) Hashtbl.t; + loc_full: Location.t; + missing_annotations: ExnSet.t; + throw_set: ExnSet.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 index d1c1a3ca3f..309196b8e0 100644 --- a/analysis/reanalyze/src/Issues.ml +++ b/analysis/reanalyze/src/Issues.ml @@ -1,14 +1,14 @@ -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" +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 index ed80c436a4..196860a911 100644 --- a/analysis/reanalyze/src/Liveness.ml +++ b/analysis/reanalyze/src/Liveness.ml @@ -26,8 +26,8 @@ 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. @@ -37,23 +37,23 @@ let find_externally_referenced ~(decl_store : DeclarationStore.t) let externally_referenced = PosHash.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 = + DeclarationStore.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 + References.iter_value_refs_from refs (fun pos_from pos_to_set -> + if not (is_decl_pos pos_from) then PosSet.iter - (fun posTo -> PosHash.replace externally_referenced posTo true) - posToSet); + (fun pos_to -> PosHash.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 + References.iter_type_refs_from refs (fun pos_from pos_to_set -> + if not (is_decl_pos pos_from) then PosSet.iter - (fun posTo -> PosHash.replace externally_referenced posTo true) - posToSet); + (fun pos_to -> PosHash.replace externally_referenced pos_to true) + pos_to_set); externally_referenced @@ -99,22 +99,22 @@ let build_decl_refs_index ~(decl_store : DeclarationStore.t) 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 @@ -179,8 +179,8 @@ let compute_forward ~debug ~(decl_store : DeclarationStore.t) 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 |> DcePath.to_string))) decl_store; if debug then Log_.item "@. %d roots found@.@." !root_count; @@ -202,14 +202,14 @@ let compute_forward ~debug ~(decl_store : DeclarationStore.t) if not (PosHash.mem live target) then match DeclarationStore.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; 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 |> DcePath.to_string) + (target_decl.path |> DcePath.to_string) | Some _ -> (* Type target from value ref - see below *) () @@ -223,15 +223,15 @@ let compute_forward ~debug ~(decl_store : DeclarationStore.t) (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 + | Some target_decl when target_decl.decl_kind |> Decl.Kind.is_type -> incr propagated_count; PosHash.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 |> DcePath.to_string) + (target_decl.path |> DcePath.to_string) | Some _ -> (* Value target from type ref - skip *) () diff --git a/analysis/reanalyze/src/Log_.ml b/analysis/reanalyze/src/Log_.ml index 19e03cf8ae..df7112505a 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) + EmitJson.emit_annotate ~action:"Add @throws annotation" + ~pos:(EmitJson.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 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 + EmitJson.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.DceConfig.cli.json then EmitJson.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 + |> List.iter (fun issue -> log_issue ~config ~issue |> print_string); + let sorted_issues, n_issues = get_sorted_issues () in if not config.DceConfig.cli.json then ( - if sortedIssues <> [] then item "@."; - item "Analysis reported %d issues%s@." nIssues - (match sortedIssues with + 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/ModulePath.ml b/analysis/reanalyze/src/ModulePath.ml index f32087d7fa..1f917b28ca 100644 --- a/analysis/reanalyze/src/ModulePath.ml +++ b/analysis/reanalyze/src/ModulePath.ml @@ -5,28 +5,28 @@ 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 = +let normalize_path ~aliases path = match path |> List.rev with - | name :: restRev when restRev <> [] -> ( + | name :: rest_rev when rest_rev <> [] -> ( match aliases |> NameMap.find_opt name with | None -> path | Some path1 -> - let newPath = List.rev (path1 @ restRev) in + let new_path = List.rev (path1 @ rest_rev) in if !Cli.debug then - Log_.item "Resolve Alias: %s to %s@." (path |> DcePath.toString) - (newPath |> DcePath.toString); - newPath) + Log_.item "Resolve Alias: %s to %s@." (path |> DcePath.to_string) + (new_path |> DcePath.to_string); + new_path) | _ -> path -let addAlias (t : t) ~name ~path : t = +let add_alias (t : t) ~name ~path : t = let aliases = t.aliases in - let pathNormalized = path |> normalizePath ~aliases in + let path_normalized = path |> normalize_path ~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} + Log_.item "Module Alias: %s = %s@." (name |> Name.to_string) + (DcePath.to_string path_normalized); + {t with aliases = NameMap.add name path_normalized aliases} -let resolveAlias (t : t) path = path |> normalizePath ~aliases:t.aliases +let resolve_alias (t : t) path = path |> normalize_path ~aliases:t.aliases -let enterModule (t : t) ~(name : Name.t) ~(loc : Location.t) : t = +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 index 2f9565410d..2ca477e866 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 index 3f515e3065..3837496415 100644 --- a/analysis/reanalyze/src/Name.mli +++ b/analysis/reanalyze/src/Name.mli @@ -1,9 +1,9 @@ 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 +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/OptionalArgs.ml b/analysis/reanalyze/src/OptionalArgs.ml index 1010075979..b651d991c8 100644 --- a/analysis/reanalyze/src/OptionalArgs.ml +++ b/analysis/reanalyze/src/OptionalArgs.ml @@ -5,41 +5,41 @@ module StringSet = Set.Make (String) -type t = {count: int; unused: StringSet.t; alwaysUsed: StringSet.t} +type t = {count: int; unused: StringSet.t; always_used: StringSet.t} -let empty = {unused = StringSet.empty; alwaysUsed = StringSet.empty; count = 0} +let empty = {unused = StringSet.empty; always_used = StringSet.empty; count = 0} -let fromList l = - {unused = StringSet.of_list l; alwaysUsed = StringSet.empty; count = 0} +let from_list l = + {unused = StringSet.of_list l; always_used = StringSet.empty; count = 0} -let isEmpty x = StringSet.is_empty x.unused +let is_empty 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 +let apply_call ~arg_names ~arg_names_maybe x = + let name_set = arg_names |> StringSet.of_list in + let name_set_maybe = arg_names_maybe |> StringSet.of_list in + let name_set_always = StringSet.diff name_set name_set_maybe in + let always_used = + if x.count = 0 then name_set_always + else StringSet.inter name_set_always x.always_used in let unused = - argNames + arg_names |> List.fold_left (fun acc name -> StringSet.remove name acc) x.unused in - {count = x.count + 1; unused; alwaysUsed} + {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 = 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 always_used = StringSet.inter x.always_used y.always_used in + ({x with unused; always_used}, {y with unused; always_used}) -let iterUnused f x = StringSet.iter f x.unused -let iterAlwaysUsed f x = StringSet.iter (fun s -> f s x.count) x.alwaysUsed +let iter_unused f x = StringSet.iter f x.unused +let iter_always_used f x = StringSet.iter (fun s -> f s x.count) x.always_used -let foldUnused f x init = StringSet.fold f x.unused init +let fold_unused 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 +let fold_always_used f x init = + StringSet.fold (fun s acc -> f s x.count acc) x.always_used init diff --git a/analysis/reanalyze/src/Paths.ml b/analysis/reanalyze/src/Paths.ml index f47282ee08..1a826d4820 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 = RunConfig.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,10 +61,10 @@ 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 @@ -79,33 +79,33 @@ module Config = struct (* if no "analysis" specified, default to dce *) RunConfig.dce () - let readTransitive conf = + let read_transitive conf = match conf |> get "transitive" with | Some (`Bool bool) -> RunConfig.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 ()) | _ -> () 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,10 +145,10 @@ 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 @@ -174,7 +174,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 index 07b053bb4c..87f9a919a9 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/ReactiveAnalysis.ml b/analysis/reanalyze/src/ReactiveAnalysis.ml index eafd54a40a..c881bc6902 100644 --- a/analysis/reanalyze/src/ReactiveAnalysis.ml +++ b/analysis/reanalyze/src/ReactiveAnalysis.ml @@ -27,50 +27,50 @@ 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 = +let process_cmt_infos ~config ~cmt_file_path cmt_infos : cmt_file_result option = + let exclude_path source_file = config.DceConfig.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) -> + | 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 let dce_file_context : DceFileProcessing.file_context = - {source_path = sourceFile; module_name; is_interface} + {source_path = source_file; module_name; is_interface} in let file_context = DeadCommon.FileContext. - {source_path = sourceFile; module_name; is_interface} + {source_path = source_file; module_name; is_interface} in let dce_data = if config.DceConfig.run.dce then Some (cmt_infos |> DceFileProcessing.process_cmt_file ~config ~file:dce_file_context - ~cmtFilePath) + ~cmt_file_path) else None in let exception_data = if config.DceConfig.run.exception_ then - cmt_infos |> Exception.processCmt ~file:file_context + 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; + cmt_infos |> Arnold.process_cmt ~config ~file:file_context; Some {dce_data; exception_data} | _ -> None @@ -78,25 +78,25 @@ let process_cmt_infos ~config ~cmtFilePath cmt_infos : cmt_file_result option = let create ~config : t = ReactiveFileCollection.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 + cmt_file_paths |> List.filter (fun p -> ReactiveFileCollection.mem collection p) |> List.length in (* Process all files as a batch - emits single Batch delta *) let processed = - ReactiveFileCollection.process_files_batch collection cmtFilePaths + ReactiveFileCollection.process_files_batch collection cmt_file_paths in let from_cache = total_files - processed in let stats = {total_files; processed; from_cache} in @@ -136,7 +136,7 @@ let length (collection : t) = ReactiveFileCollection.length collection 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" + Reactive.flat_map ~name:"file_data_collection" (ReactiveFileCollection.to_collection collection) ~f:(fun path result_opt -> match result_opt with diff --git a/analysis/reanalyze/src/ReactiveDeclRefs.ml b/analysis/reanalyze/src/ReactiveDeclRefs.ml index 9f5a2ea26c..6797b8ed4e 100644 --- a/analysis/reanalyze/src/ReactiveDeclRefs.ml +++ b/analysis/reanalyze/src/ReactiveDeclRefs.ml @@ -14,44 +14,44 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (Lexing.position, PosSet.t * PosSet.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 = 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 () in let type_decl_refs : (Lexing.position, PosSet.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 () in diff --git a/analysis/reanalyze/src/ReactiveExceptionRefs.ml b/analysis/reanalyze/src/ReactiveExceptionRefs.ml index 81e23bfbe6..7dd1822da2 100644 --- a/analysis/reanalyze/src/ReactiveExceptionRefs.ml +++ b/analysis/reanalyze/src/ReactiveExceptionRefs.ml @@ -26,14 +26,14 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~(exception_refs : (DcePath.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 @@ -60,10 +60,10 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* 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))) + Reactive.flat_map ~name:"exc_refs.resolved_refs_from" resolved_refs + ~f:(fun pos_to pos_from_set -> + PosSet.elements pos_from_set + |> List.map (fun pos_from -> (pos_from, PosSet.singleton pos_to))) ~merge:PosSet.union () in @@ -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 -> + (fun pos_to pos_from_set -> PosSet.iter - (fun posFrom -> References.add_value_ref refs ~posTo ~posFrom) - posFromSet) + (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 = Reactive.iter - (fun posTo posFromSet -> + (fun pos_to pos_from_set -> PosSet.iter - (fun posFrom -> - let from_file = posFrom.Lexing.pos_fname in - let to_file = posTo.Lexing.pos_fname in + (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) + pos_from_set) t.resolved_refs diff --git a/analysis/reanalyze/src/ReactiveLiveness.ml b/analysis/reanalyze/src/ReactiveLiveness.ml index 4322bd0992..6433faa4cd 100644 --- a/analysis/reanalyze/src/ReactiveLiveness.ml +++ b/analysis/reanalyze/src/ReactiveLiveness.ml @@ -36,7 +36,7 @@ let create ~(merged : ReactiveMerge.t) : t = (* 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)]) @@ -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, ()))) + PosSet.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, ()))) + PosSet.elements targets |> List.map (fun pos_to -> (pos_to, ()))) ~merge:(fun () () -> ()) () in diff --git a/analysis/reanalyze/src/ReactiveMerge.ml b/analysis/reanalyze/src/ReactiveMerge.ml index f0a340f6c1..9f309d6eee 100644 --- a/analysis/reanalyze/src/ReactiveMerge.ml +++ b/analysis/reanalyze/src/ReactiveMerge.ml @@ -25,7 +25,7 @@ let create (source : (string, DceFileProcessing.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 -> [] @@ -36,7 +36,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* 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 -> [] @@ -48,7 +48,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* 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 -> [] @@ -60,7 +60,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* 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 -> [] @@ -72,7 +72,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* 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 -> [] @@ -93,7 +93,7 @@ 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 -> [] @@ -104,7 +104,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* 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 -> [] @@ -119,7 +119,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* 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) -> @@ -131,7 +131,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : let type_deps = ReactiveTypeDeps.create ~decls ~report_types_dead_only_in_interface: - DeadCommon.Config.reportTypesDeadOnlyInInterface + DeadCommon.Config.report_types_dead_only_in_interface in (* Create reactive exception refs resolution *) @@ -173,48 +173,48 @@ let freeze_refs (t : t) : References.t = let type_refs_from = PosHash.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 PosHash.find_opt tbl pos_from with | Some s -> s | None -> PosSet.empty in - PosHash.replace tbl posFrom (PosSet.add posTo existing) + PosHash.replace tbl pos_from (PosSet.add pos_to existing) in (* Merge per-file value refs_from *) Reactive.iter - (fun posFrom posToSet -> + (fun pos_from pos_to_set -> PosSet.iter - (fun posTo -> add_to_from value_refs_from posFrom posTo) - posToSet) + (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 -> + (fun pos_from pos_to_set -> PosSet.iter - (fun posTo -> add_to_from type_refs_from posFrom posTo) - posToSet) + (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 -> + (fun pos_from pos_to_set -> PosSet.iter - (fun posTo -> add_to_from type_refs_from posFrom posTo) - posToSet) + (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 -> + (fun pos_from pos_to_set -> PosSet.iter - (fun posTo -> add_to_from value_refs_from posFrom posTo) - posToSet) + (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 @@ -252,11 +252,11 @@ let freeze_file_deps (t : t) : FileDeps.t = t.file_deps_map; (* Add file deps from exception refs - iterate value_refs_from *) Reactive.iter - (fun posFrom posToSet -> + (fun pos_from pos_to_set -> PosSet.iter - (fun posTo -> - let from_file = posFrom.Lexing.pos_fname in - let to_file = posTo.Lexing.pos_fname in + (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 @@ -265,6 +265,6 @@ let freeze_file_deps (t : t) : FileDeps.t = in FileDeps.FileHash.replace deps from_file (FileSet.add to_file existing)) - posToSet) + pos_to_set) t.exception_refs.resolved_refs_from; FileDeps.create ~files ~deps diff --git a/analysis/reanalyze/src/ReactiveSolver.ml b/analysis/reanalyze/src/ReactiveSolver.ml index dbe21b2b43..f7a5ded54d 100644 --- a/analysis/reanalyze/src/ReactiveSolver.ml +++ b/analysis/reanalyze/src/ReactiveSolver.ml @@ -46,7 +46,7 @@ type 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 |> DcePath.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) @@ -79,41 +79,41 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let dead_modules = if not config.DceConfig.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) () @@ -129,7 +129,7 @@ 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 @@ -137,12 +137,12 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) | 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 @@ -153,13 +153,13 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~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 sorted = decls |> List.fast_sort Decl.compare_for_reporting in let reporting_ctx = DeadCommon.ReportingContext.create () in let file_issues = sorted |> List.concat_map (fun decl -> - DeadCommon.reportDeclaration ~config ~hasRefBelow ~checkModuleDead - ~shouldReport reporting_ctx decl) + DeadCommon.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 +169,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 _ _ -> ()) () @@ -200,7 +200,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* 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 +210,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 +227,7 @@ 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, AnalysisResult.make_dead_module_issue ~loc ~module_name)] | None -> []) () in @@ -250,24 +250,24 @@ 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 (AnalysisResult.make_dead_module_issue ~loc ~module_name) | None -> None (** Collect issues from reactive issues_by_file. @@ -286,13 +286,13 @@ let collect_issues ~(t : t) ~(config : DceConfig.t) Reactive.iter (fun _pos (decl : Decl.t) -> let issue = - DeadCommon.makeDeadIssue ~decl + DeadCommon.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/ReactiveTypeDeps.ml b/analysis/reanalyze/src/ReactiveTypeDeps.ml index 5fd0694405..2264dd0b4d 100644 --- a/analysis/reanalyze/src/ReactiveTypeDeps.ml +++ b/analysis/reanalyze/src/ReactiveTypeDeps.ml @@ -18,15 +18,15 @@ type decl_info = { (** 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} *) @@ -49,7 +49,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 +59,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 | [] | [_] -> [] @@ -81,18 +81,18 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* 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 |> DcePath.module_to_interface in + let path_2 = path_1 |> DcePath.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))]) | _ -> []) () @@ -149,15 +149,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 :: DcePath.module_to_implementation path_to_type in [(info.pos, (info, impl_path))]) | _ -> []) @@ -218,10 +218,10 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~merge:PosSet.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))) + Reactive.flat_map ~name:"type_deps.all_type_refs_from" combined_refs_to + ~f:(fun pos_to pos_from_set -> + PosSet.elements pos_from_set + |> List.map (fun pos_from -> (pos_from, PosSet.singleton pos_to))) ~merge:PosSet.union () in @@ -240,8 +240,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 -> + (fun pos_to pos_from_set -> PosSet.iter - (fun posFrom -> References.add_type_ref refs ~posTo ~posFrom) - posFromSet) + (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/Reanalyze.ml b/analysis/reanalyze/src/Reanalyze.ml index 64db1247b0..c122940536 100644 --- a/analysis/reanalyze/src/Reanalyze.ml +++ b/analysis/reanalyze/src/Reanalyze.ml @@ -1,4 +1,4 @@ -let runConfig = RunConfig.runConfig +let run_config = RunConfig.run_config type cmt_file_result = { dce_data: DceFileProcessing.file_data option; @@ -8,63 +8,63 @@ type cmt_file_result = { (** 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 = +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.DceConfig.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) -> + | 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} + {source_path = source_file; module_name; is_interface} in (* File context for Exception/Arnold (uses DeadCommon.FileContext) *) let file_context = DeadCommon.FileContext. - {source_path = sourceFile; module_name; is_interface} + {source_path = source_file; module_name; 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 Some (cmt_infos |> DceFileProcessing.process_cmt_file ~config ~file:dce_file_context - ~cmtFilePath) + ~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 + 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; + cmt_infos |> Arnold.process_cmt ~config ~file:file_context; Some {dce_data; exception_data} | _ -> None @@ -75,40 +75,40 @@ type all_files_result = { (** 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 +117,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 +125,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 +135,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 +156,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 +let process_cmt_files ~config ~cmt_root ~reactive_collection ~skip_file ?(file_stats : ReactiveAnalysis.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 +169,7 @@ let processCmtFiles ~config ~cmtRoot ~reactive_collection ~skip_file match reactive_collection with | Some collection -> let result, stats = - ReactiveAnalysis.process_files ~collection ~config cmtFilePaths + ReactiveAnalysis.process_files ~collection ~config cmt_file_paths in (match file_stats with | Some fs -> @@ -181,7 +181,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,11 +195,11 @@ 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 + process_cmt_files ~config:dce_config ~cmt_root ~reactive_collection ~skip_file ?file_stats () in (* Get exception results from reactive collection if available *) @@ -210,7 +210,7 @@ let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge 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 Log_.item "Shuffling file order for order-independence test@."; @@ -380,16 +380,16 @@ let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge (* Non-reactive path: use old solver with optional args *) let empty_optional_args_state = OptionalArgsState.create () in let analysis_result_core = - DeadCommon.solveDead ~ann_store ~decl_store ~ref_store + DeadCommon.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 + | Some decl -> Decl.is_live decl | None -> true in let optional_args_state = @@ -401,7 +401,7 @@ let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge let optional_args_issues = DeclarationStore.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 ~config:dce_config decl @@ -425,11 +425,11 @@ let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge Log_.warning ~loc:issue.loc issue.description) | None -> ()); if dce_config.DceConfig.run.exception_ then - Exception.runChecks ~config:dce_config exception_results; + Exception.run_checks ~config:dce_config exception_results; if dce_config.DceConfig.run.termination && dce_config.DceConfig.cli.debug - then Arnold.reportStats ~config:dce_config) + 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. @@ -437,7 +437,7 @@ let runAnalysisAndReport ~cmtRoot = Reactive.set_debug !Cli.timing; if !Cli.json then EmitJson.start (); let dce_config = DceConfig.current () in - let numRuns = max 1 !Cli.runs 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) @@ -480,8 +480,8 @@ let runAnalysisAndReport ~cmtRoot = | _ -> 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 +493,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 ( @@ -533,9 +533,9 @@ let runAnalysisAndReport ~cmtRoot = | 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; @@ -565,7 +565,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 +586,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 (); @@ -617,44 +617,44 @@ let runAnalysisAndReport ~cmtRoot = if !Cli.json then EmitJson.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 = + let rec set_all cmt_root = RunConfig.all (); - cmtRootRef := cmtRoot; - analysisKindSet := true - and setConfig () = - Paths.Config.processConfig (); - analysisKindSet := true - and setDCE cmtRoot = + 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 = RunConfig.dce (); - cmtRootRef := cmtRoot; - analysisKindSet := true - and setException cmtRoot = + cmt_root_ref := cmt_root; + analysis_kind_set := true + and set_exception cmt_root = RunConfig.exception_ (); - cmtRootRef := cmtRoot; - analysisKindSet := true - and setTermination cmtRoot = + cmt_root_ref := cmt_root; + analysis_kind_set := true + and set_termination cmt_root = RunConfig.termination (); - cmtRootRef := cmtRoot; - analysisKindSet := true + 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 +663,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 DeadCommon.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 +745,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 + !cmt_root_ref (** Default socket location invariant: - the socket lives in the project root @@ -764,8 +764,8 @@ 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). diff --git a/analysis/reanalyze/src/ReanalyzeServer.ml b/analysis/reanalyze/src/ReanalyzeServer.ml index 09ceb3f5ec..a92d363790 100644 --- a/analysis/reanalyze/src/ReanalyzeServer.ml +++ b/analysis/reanalyze/src/ReanalyzeServer.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 = @@ -108,7 +108,7 @@ module Server = struct parse_argv: string array -> string option; run_analysis: dce_config:DceConfig.t -> - cmtRoot:string option -> + cmt_root:string option -> reactive_collection:ReactiveAnalysis.t option -> reactive_merge:ReactiveMerge.t option -> reactive_liveness:ReactiveLiveness.t option -> @@ -118,7 +118,7 @@ module Server = struct unit -> unit; config: server_config; - cmtRoot: string option; + cmt_root: string option; mutable pipeline: reactive_pipeline; stats: server_stats; mutable config_snapshot: RunConfig.snapshot; @@ -295,7 +295,7 @@ Examples: let init_state ~(parse_argv : string array -> string option) ~(run_analysis : dce_config:DceConfig.t -> - cmtRoot:string option -> + cmt_root:string option -> reactive_collection:ReactiveAnalysis.t option -> reactive_merge:ReactiveMerge.t option -> reactive_liveness:ReactiveLiveness.t option -> @@ -307,7 +307,7 @@ Examples: 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,7 +328,7 @@ Examples: parse_argv; run_analysis; config; - cmtRoot; + cmt_root; pipeline; stats = {request_count = 0}; config_snapshot = RunConfig.snapshot (); @@ -358,7 +358,7 @@ Examples: (* Re-read config from rescript.json to detect changes. If changed, recreate the entire reactive pipeline from scratch. *) RunConfig.reset (); - Paths.Config.processConfig (); + Paths.Config.process_config (); let new_snapshot = RunConfig.snapshot () in if not @@ -377,7 +377,7 @@ Examples: Printf.printf "\n"; EmitJson.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) @@ -453,7 +453,7 @@ Examples: let cli ~(parse_argv : string array -> string option) ~(run_analysis : dce_config:DceConfig.t -> - cmtRoot:string option -> + cmt_root:string option -> reactive_collection:ReactiveAnalysis.t option -> reactive_merge:ReactiveMerge.t option -> reactive_liveness:ReactiveLiveness.t option -> @@ -479,7 +479,7 @@ end let server_cli ~(parse_argv : string array -> string option) ~(run_analysis : dce_config:DceConfig.t -> - cmtRoot:string option -> + cmt_root:string option -> reactive_collection:ReactiveAnalysis.t option -> reactive_merge:ReactiveMerge.t option -> reactive_liveness:ReactiveLiveness.t option -> diff --git a/analysis/reanalyze/src/References.ml b/analysis/reanalyze/src/References.ml index fd324ed434..e073216fd5 100644 --- a/analysis/reanalyze/src/References.ml +++ b/analysis/reanalyze/src/References.ml @@ -10,7 +10,7 @@ This is what the forward liveness algorithm needs. *) (* Helper to add to a set in a hashtable *) -let addSet h k v = +let add_set h k v = let set = try PosHash.find h k with Not_found -> PosSet.empty in PosHash.replace h k (PosSet.add v set) @@ -26,20 +26,20 @@ type t = {value_refs_from: refs_table; type_refs_from: refs_table} let create_builder () : builder = {value_refs_from = PosHash.create 256; type_refs_from = PosHash.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 (fun pos refs -> - refs |> PosSet.iter (fun toPos -> addSet into.value_refs_from pos toPos)) + refs |> PosSet.iter (fun to_pos -> add_set into.value_refs_from pos to_pos)) from.value_refs_from; PosHash.iter (fun pos refs -> - refs |> PosSet.iter (fun toPos -> addSet into.type_refs_from pos toPos)) + refs |> PosSet.iter (fun to_pos -> add_set into.type_refs_from pos to_pos)) from.type_refs_from let merge_all (builders : builder list) : t = diff --git a/analysis/reanalyze/src/References.mli b/analysis/reanalyze/src/References.mli index 84939aa2f1..b71aa0635f 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 diff --git a/analysis/reanalyze/src/RunConfig.ml b/analysis/reanalyze/src/RunConfig.ml index b6b1d28008..1fe02a6d44 100644 --- a/analysis/reanalyze/src/RunConfig.ml +++ b/analysis/reanalyze/src/RunConfig.ml @@ -1,20 +1,20 @@ type t = { - mutable bsbProjectRoot: string; + mutable bsb_project_root: string; mutable dce: bool; mutable exception_: bool; - mutable projectRoot: string; + mutable project_root: string; mutable suppress: string list; mutable termination: bool; mutable transitive: bool; mutable unsuppress: string list; } -let runConfig = +let run_config = { - bsbProjectRoot = ""; + bsb_project_root = ""; dce = false; exception_ = false; - projectRoot = ""; + project_root = ""; suppress = []; termination = false; transitive = false; @@ -22,23 +22,23 @@ let runConfig = } let reset () = - runConfig.dce <- false; - runConfig.exception_ <- false; - runConfig.suppress <- []; - runConfig.termination <- false; - runConfig.transitive <- false; - runConfig.unsuppress <- [] + run_config.dce <- false; + run_config.exception_ <- false; + run_config.suppress <- []; + run_config.termination <- false; + run_config.transitive <- false; + run_config.unsuppress <- [] let all () = - runConfig.dce <- true; - runConfig.exception_ <- true; - runConfig.termination <- true + run_config.dce <- true; + run_config.exception_ <- true; + run_config.termination <- true -let dce () = runConfig.dce <- true -let exception_ () = runConfig.exception_ <- true -let termination () = runConfig.termination <- true +let dce () = run_config.dce <- true +let exception_ () = run_config.exception_ <- true +let termination () = run_config.termination <- true -let transitive b = runConfig.transitive <- b +let transitive b = run_config.transitive <- b type snapshot = { dce: bool; @@ -51,12 +51,12 @@ type snapshot = { let snapshot () = { - dce = runConfig.dce; - exception_ = runConfig.exception_; - suppress = runConfig.suppress; - termination = runConfig.termination; - transitive = runConfig.transitive; - unsuppress = runConfig.unsuppress; + 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/SideEffects.ml b/analysis/reanalyze/src/SideEffects.ml index ab49b36ea9..dfdb6396b3 100644 --- a/analysis/reanalyze/src/SideEffects.ml +++ b/analysis/reanalyze/src/SideEffects.ml @@ -1,4 +1,4 @@ -let whiteListSideEffects = +let white_list_side_effects = [ "Pervasives./."; "Pervasives.ref"; @@ -10,78 +10,78 @@ let whiteListSideEffects = "String.length"; ] -let whiteTableSideEffects = +let white_table_side_effects = lazy (let tbl = Hashtbl.create 11 in - whiteListSideEffects |> List.iter (fun s -> Hashtbl.add tbl s ()); + white_list_side_effects |> List.iter (fun s -> Hashtbl.add tbl s ()); tbl) -let pathIsWhitelistedForSideEffects path = +let path_is_whitelisted_for_side_effects path = path - |> DcePath.onOkPath ~whenContainsApply:false ~f:(fun s -> - Hashtbl.mem (Lazy.force whiteTableSideEffects) s) + |> DcePath.on_ok_path ~when_contains_apply:false ~f:(fun s -> + Hashtbl.mem (Lazy.force white_table_side_effects) s) -let rec exprNoSideEffects (expr : Typedtree.expression) = +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 exprNoSideEffects + | 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 |> pathIsWhitelistedForSideEffects -> - args |> List.for_all (fun (_, eo) -> eo |> exprOptNoSideEffects) + 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 |> exprNoSideEffects && e2 |> exprNoSideEffects + | 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 |> exprNoSideEffects) - && e |> exprNoSideEffects + vb.vb_expr |> expr_no_side_effects) + && e |> expr_no_side_effects | Texp_record {fields; extended_expression} -> - fields |> Array.for_all fieldNoSideEffects - && extended_expression |> exprOptNoSideEffects + fields |> Array.for_all field_no_side_effects + && extended_expression |> expr_opt_no_side_effects | Texp_assert _ -> false - | Texp_match (e, casesOk, casesExn, partial) -> - let cases = casesOk @ casesExn in - partial = Total && e |> exprNoSideEffects - && cases |> List.for_all caseNoSideEffects + | 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 |> 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 + 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 exprNoSideEffects + | Texp_array el -> el |> List.for_all expr_no_side_effects | Texp_ifthenelse (e1, e2, eo) -> - e1 |> exprNoSideEffects && e2 |> exprNoSideEffects - && eo |> exprOptNoSideEffects - | Texp_while (e1, e2) -> e1 |> exprNoSideEffects && e2 |> exprNoSideEffects + 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 |> exprNoSideEffects && e2 |> exprNoSideEffects - && e3 |> exprNoSideEffects + 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 |> exprNoSideEffects + | 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 exprOptNoSideEffects eo = +and expr_opt_no_side_effects eo = match eo with | None -> true - | Some e -> e |> exprNoSideEffects + | Some e -> e |> expr_no_side_effects -and fieldNoSideEffects +and field_no_side_effects ((_ld, rld, _) : _ * Typedtree.record_label_definition * _) = match rld with | Kept _typeExpr -> true - | Overridden (_lid, e) -> e |> exprNoSideEffects + | Overridden (_lid, e) -> e |> expr_no_side_effects -and caseNoSideEffects : Typedtree.case -> _ = +and case_no_side_effects : Typedtree.case -> _ = fun {c_guard; c_rhs} -> - c_guard |> exprOptNoSideEffects && c_rhs |> exprNoSideEffects + c_guard |> expr_opt_no_side_effects && c_rhs |> expr_no_side_effects -let checkExpr e = not (exprNoSideEffects e) +let check_expr e = not (expr_no_side_effects e) diff --git a/analysis/reanalyze/src/Suppress.ml b/analysis/reanalyze/src/Suppress.ml index b40d6af2c7..19f65eea55 100644 --- a/analysis/reanalyze/src/Suppress.ml +++ b/analysis/reanalyze/src/Suppress.ml @@ -1,4 +1,4 @@ -let runConfig = RunConfig.runConfig +let run_config = RunConfig.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/src/BuildSystem.ml b/analysis/src/BuildSystem.ml index de8f9c9bbe..fe640f2cb8 100644 --- a/analysis/src/BuildSystem.ml +++ b/analysis/src/BuildSystem.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 + ModuleResolution.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 index 5e7b3203fc..3df0bbb30b 100644 --- a/analysis/src/Cache.ml +++ b/analysis/src/Cache.ml @@ -1,18 +1,18 @@ open SharedTypes type cached = { - projectFiles: FileSet.t; - dependenciesFiles: FileSet.t; - pathsForModule: (file, paths) Hashtbl.t; + project_files: FileSet.t; + dependencies_files: FileSet.t; + paths_for_module: (file, paths) Hashtbl.t; } -let writeCache filename (data : cached) = +let write_cache 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 +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 @@ -21,21 +21,21 @@ let readCache filename = with _ -> None else None -let deleteCache filename = try Sys.remove filename with _ -> () +let delete_cache filename = try Sys.remove filename with _ -> () -let targetFileFromLibBs libBs = Filename.concat libBs ".project-files-cache" +let target_file_from_lib_bs lib_bs = Filename.concat lib_bs ".project-files-cache" -let cacheProject (package : package) = +let cache_project (package : package) = let cached = { - projectFiles = package.projectFiles; - dependenciesFiles = package.dependenciesFiles; - pathsForModule = package.pathsForModule; + project_files = package.project_files; + dependencies_files = package.dependencies_files; + paths_for_module = package.paths_for_module; } in - match BuildSystem.getLibBs package.rootPath with + match BuildSystem.get_lib_bs package.root_path with | None -> print_endline "\"ERR\"" - | Some libBs -> - let targetFile = targetFileFromLibBs libBs in - writeCache targetFile cached; + | 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 index bd4166d5ab..f4bf9d0574 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 index 727313cb80..d795f84e10 100644 --- a/analysis/src/Cli.ml +++ b/analysis/src/Cli.ml @@ -3,107 +3,107 @@ 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 + SignatureHelp.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 {document_changes = Some document_changes} -> + document_changes |> List.map (fun c -> match c with | `RenameFile r -> Lsp.Types.RenameFile.yojson_of_t r @@ -113,9 +113,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 +128,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 - | {newText} :: _ -> print_string (`String newText) + let kind_file = Files.classify_source_file path in + match Commands.format ~source ~kind_file with + | Ok text_edits -> ( + match text_edits with + | {new_text} :: _ -> print_string (`String new_text) | _ -> 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 = SemanticTokens.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 +176,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 +200,21 @@ 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,18 +224,18 @@ 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.RunConfig.run_config.suppress <- ["src"]; + Reanalyze.RunConfig.run_config.unsuppress <- [Filename.concat "src" "dce"]; DceCommand.command () | "doc" -> @@ -243,38 +243,38 @@ let test ~path = DocumentSymbol.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 + ~emitter:(SemanticTokens.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" (CreateInterface.command ~path ~cmi_file) | "ref" -> print_endline ("References " ^ path ^ " " ^ string_of_int line ^ ":" @@ -284,50 +284,50 @@ 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 + 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 - | Some {documentChanges} -> - documentChanges |> Option.get + | Some {document_changes} -> + document_changes |> Option.get |> List.iter (fun (dc : @@ -340,7 +340,7 @@ let test ~path = match dc with | `TextDocumentEdit tde -> let filename = - tde.textDocument.uri |> Uri.toPath + tde.text_document.uri |> Uri.to_path |> Filename.basename in Printf.printf "\nTextDocumentEdit: %s\n" filename; @@ -353,15 +353,15 @@ 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, - te.newText, + te.new_text, te.range ) | `AnnotatedTextEdit te -> ( te.range.start.character, - te.newText, + te.new_text, te.range ) in let indent = String.make start_char ' ' in @@ -369,10 +369,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 +383,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 +397,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 + DumpAst.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 index ac1d5ae595..013c6fa3e0 100644 --- a/analysis/src/Cmt.ml +++ b/analysis/src/Cmt.ml @@ -1,67 +1,67 @@ open SharedTypes -let fullForCmt ~moduleName ~package ~uri cmt = - match Shared.tryReadCmt cmt with +let full_for_cmt ~module_name ~package ~uri cmt = + match Shared.try_read_cmt cmt with | None -> None | Some infos -> - let file = ProcessCmt.fileForCmtInfos ~moduleName ~uri infos in - let extra = ProcessExtra.getExtra ~file ~infos in + let file = ProcessCmt.file_for_cmt_infos ~module_name ~uri infos in + let extra = ProcessExtra.get_extra ~file ~infos in Some {file; extra; package} -let fullFromUri ~uri = - let path = Uri.toPath uri in - match Packages.getPackage ~uri with +let full_from_uri ~uri = + let path = Uri.to_path uri in + match Packages.get_package ~uri with | None -> None | Some package -> ( - let moduleName = - BuildSystem.namespacedName package.namespace (FindFiles.getName path) + let module_name = + BuildSystem.namespaced_name package.namespace (FindFiles.get_name path) in let incremental = - if !Cfg.inIncrementalTypecheckingMode then - let incrementalCmtPath = - package.rootPath ^ "/lib/bs/___incremental" ^ "/" ^ moduleName + if !Cfg.in_incremental_typechecking_mode then + let incremental_cmt_path = + package.root_path ^ "/lib/bs/___incremental" ^ "/" ^ module_name ^ - match Files.classifySourceFile path with + match Files.classify_source_file path with | Resi -> ".cmti" | _ -> ".cmt" in - fullForCmt ~moduleName ~package ~uri incrementalCmtPath + full_for_cmt ~module_name ~package ~uri incremental_cmt_path else None in match incremental with - | Some cmtInfo -> + | Some cmt_info -> if Debug.verbose () then Printf.printf "[cmt] Found incremental cmt\n"; - Some cmtInfo + Some cmt_info | None -> ( - match Hashtbl.find_opt package.pathsForModule moduleName with + match Hashtbl.find_opt package.paths_for_module module_name with | Some paths -> - let cmt = getCmtPath ~uri paths in - fullForCmt ~moduleName ~package ~uri cmt + let cmt = get_cmt_path ~uri paths in + full_for_cmt ~module_name ~package ~uri cmt | None -> - prerr_endline ("can't find module " ^ moduleName); + prerr_endline ("can't find module " ^ module_name); 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) +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 loadFullCmtFromPath ~path = - let uri = Uri.fromPath path in - fullFromUri ~uri +let load_full_cmt_from_path ~path = + let uri = Uri.from_path path in + full_from_uri ~uri -let loadCmtInfosFromPath ~path = - let uri = Uri.fromPath path in - match Packages.getPackage ~uri with +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 moduleName = - BuildSystem.namespacedName package.namespace (FindFiles.getName path) + let module_name = + BuildSystem.namespaced_name package.namespace (FindFiles.get_name path) in - match Hashtbl.find_opt package.pathsForModule moduleName with + match Hashtbl.find_opt package.paths_for_module module_name with | Some paths -> - let cmt = getCmtPath ~uri paths in - Shared.tryReadCmt cmt + 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/CmtViewer.ml index 99e71b9537..b270a2e92a 100644 --- a/analysis/src/CmtViewer.ml +++ b/analysis/src/CmtViewer.ml @@ -17,36 +17,36 @@ 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 = + BuildSystem.namespaced_name package.namespace (FindFiles.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 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 +55,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 +106,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 = SharedTypes.loc_type_to_string loc_type in + Printf.printf "%s %s\n" loc_str kind_str) diff --git a/analysis/src/CodeActions.ml b/analysis/src/CodeActions.ml index 8f64eaba9a..2db97b0157 100644 --- a/analysis/src/CodeActions.ml +++ b/analysis/src/CodeActions.ml @@ -1,23 +1,23 @@ (* This is the return that's expected when resolving code actions *) -let make ~title ~kind ~uri ~newText ~range = - let textDocument = +let make ~title ~kind ~uri ~new_text ~range = + let text_document = Lsp.Types.OptionalVersionedTextDocumentIdentifier.create - ~uri:(Uri.fromString uri) () + ~uri:(Uri.from_string uri) () in let edit = Lsp.Types.WorkspaceEdit.create - ~documentChanges: + ~document_changes: [ `TextDocumentEdit (Lsp.Types.TextDocumentEdit.create - ~edits:[`TextEdit (Lsp.Types.TextEdit.create ~range ~newText)] - ~textDocument); + ~edits:[`TextEdit (Lsp.Types.TextEdit.create ~range ~new_text)] + ~text_document); ] () in Lsp.Types.CodeAction.create ~title ~kind ~edit () -let makeWithDocumentChanges ~title ~kind ~documentChanges = - let edit = Lsp.Types.WorkspaceEdit.create ~documentChanges () in +let make_with_document_changes ~title ~kind ~document_changes = + let edit = Lsp.Types.WorkspaceEdit.create ~document_changes () in Lsp.Types.CodeAction.create ~title ~kind ~edit () diff --git a/analysis/src/Codemod.ml b/analysis/src/Codemod.ml index 970dfb7941..ab9712eb49 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 (TypeUtils.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 index 78d35a331b..eb115f395e 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -1,21 +1,21 @@ -let completion ~debug ~source ~kindFile ~pos ~full = +let completion ~debug ~source ~kind_file ~pos ~full = match - Completions.getCompletions ~debug ~source ~kindFile ~pos ~full - ~forHover:false + Completions.get_completions ~debug ~source ~kind_file ~pos ~full + ~for_hover:false with | None -> [] | Some (completions, full, _) -> - completions |> List.map (CompletionBackEnd.completionToItem ~full) + completions |> List.map (CompletionBackEnd.completion_to_item ~full) -let completionResolve ~(full : SharedTypes.full option) ~modulePath = +let completion_resolve ~(full : SharedTypes.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 moduleName, _innerModulePath = - match modulePath |> String.split_on_char '.' with - | [moduleName] -> (moduleName, []) - | moduleName :: rest -> (moduleName, rest) + 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 = @@ -25,11 +25,11 @@ let completionResolve ~(full : SharedTypes.full option) ~modulePath = Printf.printf "[completion_resolve] Could not load cmt\n"; None | Some full -> ( - match ProcessCmt.fileForModule ~package:full.package moduleName with + match ProcessCmt.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" - moduleName; + module_name; None | Some file -> Some (file.structure.docstring |> String.concat "\n\n")) in @@ -41,42 +41,42 @@ let completionResolve ~(full : SharedTypes.full option) ~modulePath = (Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown ~value)) -let hover ~source ~kindFile ~pos ~supportsMarkdownLinks ~full ~debug = +let hover ~source ~kind_file ~pos ~supports_markdown_links ~full ~debug = let result = match full with | None -> None | Some full -> ( - match References.getLocItem ~full ~pos ~debug with + 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.getHoverViaCompletions ~debug ~source ~kindFile ~pos - ~forHover:true ~supportsMarkdownLinks ~full:(Some full) + 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 locItem -> - let isModule = - match locItem.locType with + | Some loc_item -> + let is_module = + match loc_item.loc_type with | LModule _ | TopLevelModule _ -> true | TypeDefinition _ | Typed _ | Constant _ -> false in - let uriLocOpt = References.definitionForLocItem ~full locItem in - let skipZero = - match uriLocOpt with + 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 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 + 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 isModule) && posIsZero loc.loc_start && posIsZero loc.loc_end + (not is_module) && pos_is_zero loc.loc_start && pos_is_zero loc.loc_end in - if skipZero then None - else Hover.newHover ~supportsMarkdownLinks ~full locItem) + if skip_zero then None + else Hover.new_hover ~supports_markdown_links ~full loc_item) in match result with | None -> None @@ -89,185 +89,185 @@ let hover ~source ~kindFile ~pos ~supportsMarkdownLinks ~full ~debug = ~kind:Lsp.Types.MarkupKind.Markdown ~value)) ()) -let signatureHelp ~source ~kindFile ~pos ~allowForConstructorPayloads ~full +let signature_help ~source ~kind_file ~pos ~allow_for_constructor_payloads ~full ~debug = - SignatureHelp.signatureHelp ~debug ~source ~kindFile ~pos - ~allowForConstructorPayloads ~full + SignatureHelp.signature_help ~debug ~source ~kind_file ~pos + ~allow_for_constructor_payloads ~full let definition ~full ~pos ~debug = - let locationOpt = + let location_opt = match full with | None -> None | Some full -> ( - match References.getLocItem ~full ~pos ~debug with + match References.get_loc_item ~full ~pos ~debug with | None -> None - | Some locItem -> ( - match References.definitionForLocItem ~full locItem with + | Some loc_item -> ( + match References.definition_for_loc_item ~full loc_item 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} = + 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 isModule = - match locItem.locType with + let is_module = + match loc_item.loc_type with | LModule _ | TopLevelModule _ -> true | TypeDefinition _ | Typed _ | Constant _ -> false in - let skipLoc = - (not isModule) && (not isInterface) && posIsZero loc.loc_start - && posIsZero loc.loc_end + let skip_loc = + (not is_module) && (not is_interface) && pos_is_zero loc.loc_start + && pos_is_zero loc.loc_end in - if skipLoc then None + if skip_loc then None else Some - (Lsp.Types.Location.create ~range:(Utils.cmtLocToRange loc) - ~uri:(Files.canonicalizeUri uri |> Uri.fromString)) + (Lsp.Types.Location.create ~range:(Utils.cmt_loc_to_range loc) + ~uri:(Files.canonicalize_uri uri |> Uri.from_string)) | Some _ -> None)) in - locationOpt + location_opt -let typeDefinition ~full ~pos ~debug = - let maybeLocation = +let type_definition ~full ~pos ~debug = + let maybe_location = match full with | None -> None | Some full -> ( - match References.getLocItem ~full ~pos ~debug with + match References.get_loc_item ~full ~pos ~debug with | None -> None - | Some locItem -> ( - match References.typeDefinitionForLocItem ~full locItem with + | 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.cmtLocToRange loc) - ~uri:(Files.canonicalizeUri uri |> Uri.fromString)))) + (Lsp.Types.Location.create ~range:(Utils.cmt_loc_to_range loc) + ~uri:(Files.canonicalize_uri uri |> Uri.from_string)))) in - maybeLocation + maybe_location let references ~full ~pos ~debug = - let allLocs = + let all_locs = match full with | None -> [] | Some full -> ( - match References.getLocItem ~full ~pos ~debug with + match References.get_loc_item ~full ~pos ~debug with | None -> [] - | Some locItem -> - let allReferences = References.allReferencesForLocItem ~full locItem in - allReferences + | 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; locOpt} -> + (fun acc {References.uri = uri2; loc_opt} -> let loc = - match locOpt with + match loc_opt with | Some loc -> loc - | None -> Uri.toTopLevelLoc uri2 + | None -> Uri.to_top_level_loc uri2 in - Lsp.Types.Location.create ~range:(Utils.cmtLocToRange loc) - ~uri:(Uri.toString uri2 |> Uri.fromString) + Lsp.Types.Location.create ~range:(Utils.cmt_loc_to_range loc) + ~uri:(Uri.to_string uri2 |> Uri.from_string) :: acc) []) in - allLocs + all_locs -let rename ~full ~pos ~newName ~debug = +let rename ~full ~pos ~new_name ~debug = let result = match full with | None -> None | Some full -> ( - match References.getLocItem ~full ~pos ~debug with + match References.get_loc_item ~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) + | 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 referencesToItems = - allReferences - |> Utils.filterMap (function - | {References.uri = uri2; locOpt = Some loc} -> Some (uri2, loc) - | {locOpt = None} -> None) + 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 fileRenames = - referencesToToplevelModules + let file_renames = + references_to_toplevel_modules |> List.map (fun uri -> - let path = Uri.toPath uri in + let path = Uri.to_path uri in let dir = match Filename.dirname path with | "." -> "" | other -> other in - let newPath = - Filename.concat dir (newName ^ Filename.extension path) + let new_path = + Filename.concat dir (new_name ^ Filename.extension path) in `RenameFile (Lsp.Types.RenameFile.create - ~newUri: - (newPath |> Uri.fromPath |> Uri.toString |> Uri.fromPath) - ~oldUri:(uri |> Uri.toString |> Uri.fromString) + ~new_uri: + (new_path |> Uri.from_path |> Uri.to_string |> Uri.from_path) + ~old_uri:(uri |> Uri.to_string |> Uri.from_string) ())) in - let textDocumentEdits = + let text_document_edits = let module StringMap = Misc.StringMap in - let textEditsByUri = - referencesToItems - |> List.map (fun (uri, loc) -> (Uri.toString uri, loc)) + 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 textEdit = + let text_edit = `TextEdit - (Lsp.Types.TextEdit.create ~newText:newName - ~range:(Utils.cmtLocToRange loc)) + (Lsp.Types.TextEdit.create ~new_text:new_name + ~range:(Utils.cmt_loc_to_range loc)) in match StringMap.find_opt uri acc with - | None -> StringMap.add uri [textEdit] acc - | Some prevEdits -> - StringMap.add uri (textEdit :: prevEdits) acc) + | None -> StringMap.add uri [text_edit] acc + | Some prev_edits -> + StringMap.add uri (text_edit :: prev_edits) acc) StringMap.empty in StringMap.fold (fun uri edits acc -> - let textDocument = + let text_document = Lsp.Types.OptionalVersionedTextDocumentIdentifier.create - ~version:0 ~uri:(Uri.fromString uri) () + ~version:0 ~uri:(Uri.from_string uri) () in - let textDocumentEdit = + let text_document_edit = `TextDocumentEdit - (Lsp.Types.TextDocumentEdit.create ~edits ~textDocument) + (Lsp.Types.TextDocumentEdit.create ~edits ~text_document) in - textDocumentEdit :: acc) - textEditsByUri [] + text_document_edit :: acc) + text_edits_by_uri [] in - let documentChanges = fileRenames @ textDocumentEdits in - Some (Lsp.Types.WorkspaceEdit.create ~documentChanges ())) + let document_changes = file_renames @ text_document_edits in + Some (Lsp.Types.WorkspaceEdit.create ~document_changes ())) in result -type prepareRenameResult = { +type prepare_rename_result = { range: Lsp.Types.Range.t; placeholder: string option; } -let prepareRename ~full ~pos ~debug = +let prepare_rename ~full ~pos ~debug = match full with | None -> None | Some full -> ( - match References.getLocItem ~full ~pos ~debug with + match References.get_loc_item ~full ~pos ~debug with | None -> None - | Some locItem -> - let range = Utils.cmtLocToRange locItem.loc in - let placeholderOpt = - match locItem.locType with + | 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 = placeholderOpt}) + Some {range; placeholder = placeholder_opt}) -let format ~source ~kindFile = +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 @@ -281,11 +281,11 @@ let format ~source ~kindFile = ~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 + Lsp.Types.TextEdit.create ~new_text:text ~range in let result = - match kindFile with + match kind_file with | Files.Res -> ( let {Res_driver.parsetree = structure; comments; diagnostics} = Res_driver.parsing_engine.parse_implementation_from_source @@ -309,5 +309,5 @@ let format ~source ~kindFile = in match result with - | Ok textEdit -> Ok [textEdit] + | Ok text_edit -> Ok [text_edit] | Error e -> Error e diff --git a/analysis/src/CompletionBackEnd.ml b/analysis/src/CompletionBackEnd.ml index 8d934ca165..5caf211e4a 100644 --- a/analysis/src/CompletionBackEnd.ml +++ b/analysis/src/CompletionBackEnd.ml @@ -1,6 +1,6 @@ open SharedTypes -let showConstructor {Constructor.cname = {txt}; args; res} = +let show_constructor {Constructor.cname = {txt}; args; res} = txt ^ (match args with | Args [] -> "" @@ -10,24 +10,24 @@ let showConstructor {Constructor.cname = {txt}; args; res} = |> 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 + (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.typeToString) + |> List.map (fun (typ, _) -> typ |> Shared.type_to_string) |> String.concat ", ") ^ ")") ^ match res with | None -> "" - | Some typ -> "\n" ^ (typ |> Shared.typeToString) + | Some typ -> "\n" ^ (typ |> Shared.type_to_string) (* TODO: local opens *) -let resolveOpens ~env opens ~package = +let resolve_opens ~env opens ~package = List.fold_left (fun previous path -> (* Finding an open, first trying to find it in previoulsly resolved opens *) @@ -37,13 +37,13 @@ let resolveOpens ~env opens ~package = match path with | [] | [_] -> previous | name :: path -> ( - match ProcessCmt.fileForModule ~package name with + match ProcessCmt.file_for_module ~package name with | None -> Log.log ("Could not get module " ^ name); previous (* TODO: warn? *) | Some file -> ( match - ResolvePath.resolvePath ~env:(QueryEnv.fromFile file) ~package + ResolvePath.resolve_path ~env:(QueryEnv.from_file file) ~package ~path with | None -> @@ -51,12 +51,12 @@ let resolveOpens ~env opens ~package = previous | Some (env, _placeholder) -> previous @ [env]))) | env :: rest -> ( - match ResolvePath.resolvePath ~env ~package ~path with + match ResolvePath.resolve_path ~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 + Log.log ("resolving open " ^ path_to_string path); + match ResolvePath.resolve_path ~env ~package ~path with | None -> Log.log "Not local"; loop previous @@ -66,20 +66,20 @@ let resolveOpens ~env opens ~package = (* loop(previous) *) [] opens -let completionForExporteds iterExported getDeclared ~prefix ~exact ~env - ~namesUsed transformContents = +let completion_for_exporteds iter_exported get_declared ~prefix ~exact ~env + ~names_used transform_contents = let res = ref [] in - iterExported (fun name stamp -> + iter_exported (fun name stamp -> (* Log.log("checking exported: " ++ name); *) - if Utils.checkName name ~prefix ~exact then - match getDeclared stamp with + if Utils.check_name name ~prefix ~exact then + match get_declared stamp with | Some (declared : _ Declared.t) - when not (Hashtbl.mem namesUsed declared.name.txt) -> - Hashtbl.add namesUsed declared.name.txt (); + when not (Hashtbl.mem names_used declared.name.txt) -> + Hashtbl.add names_used declared.name.txt (); res := { (Completion.create declared.name.txt ~env - ~kind:(transformContents declared)) + ~kind:(transform_contents declared)) with deprecated = declared.deprecated; docstring = declared.docstring; @@ -88,112 +88,112 @@ let completionForExporteds iterExported getDeclared ~prefix ~exact ~env | _ -> ()); !res -let completionForExportedModules ~env ~prefix ~exact ~namesUsed = - completionForExporteds (Exported.iter env.QueryEnv.exported Exported.Module) - (Stamps.findModule env.file.stamps) ~prefix ~exact ~env ~namesUsed +let completion_for_exported_modules ~env ~prefix ~exact ~names_used = + completion_for_exporteds (Exported.iter env.QueryEnv.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 completionForExportedValues ~env ~prefix ~exact ~namesUsed = - completionForExporteds (Exported.iter env.QueryEnv.exported Exported.Value) - (Stamps.findValue env.file.stamps) ~prefix ~exact ~env ~namesUsed +let completion_for_exported_values ~env ~prefix ~exact ~names_used = + completion_for_exporteds (Exported.iter env.QueryEnv.exported Exported.Value) + (Stamps.find_value env.file.stamps) ~prefix ~exact ~env ~names_used (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 +let completion_for_exported_types ~env ~prefix ~exact ~names_used = + completion_for_exporteds (Exported.iter env.QueryEnv.exported Exported.Type) + (Stamps.find_type env.file.stamps) ~prefix ~exact ~env ~names_used (fun declared -> Completion.Type declared.item) -let completionsForExportedConstructors ~(env : QueryEnv.t) ~prefix ~exact - ~namesUsed = +let completions_for_exported_constructors ~(env : QueryEnv.t) ~prefix ~exact + ~names_used = let res = ref [] in Exported.iter env.exported Exported.Type (fun _name stamp -> - match Stamps.findType env.file.stamps stamp with + match Stamps.find_type 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 -> + 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 namesUsed name) then - let () = Hashtbl.add namesUsed name () 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.declToString t.name.txt))) + (c, t.item.decl |> Shared.decl_to_string t.name.txt))) else None)) @ !res | _ -> ()); !res -let completionForExportedFields ~(env : QueryEnv.t) ~prefix ~exact ~namesUsed = +let completion_for_exported_fields ~(env : QueryEnv.t) ~prefix ~exact ~names_used = let res = ref [] in Exported.iter env.exported Exported.Type (fun _name stamp -> - match Stamps.findType env.file.stamps stamp with + match Stamps.find_type 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 -> + |> 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 namesUsed name) then - let () = Hashtbl.add namesUsed name () 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.declToString t.name.txt))) + (f, t.item.decl |> Shared.decl_to_string t.name.txt))) else None)) @ !res | _ -> ()); !res -let findModuleInScope ~env ~moduleName ~scope = - let modulesTable = Hashtbl.create 10 in +let find_module_in_scope ~env ~module_name ~scope = + let modules_table = Hashtbl.create 10 in env.QueryEnv.file.stamps - |> Stamps.iterModules (fun _ declared -> - Hashtbl.replace modulesTable - (declared.name.txt, declared.extentLoc |> Loc.start) + |> Stamps.iter_modules (fun _ declared -> + Hashtbl.replace modules_table + (declared.name.txt, declared.extent_loc |> 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 + 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.toString loc)) + (Printf.sprintf "Module Not Found %s loc:%s\n" name (Loc.to_string loc)) in - scope |> Scope.iterModulesBeforeFirstOpen processModule; - scope |> Scope.iterModulesAfterFirstOpen processModule; + scope |> Scope.iter_modules_before_first_open process_module; + scope |> Scope.iter_modules_after_first_open process_module; !result -let rec moduleItemToStructureEnv ~(env : QueryEnv.t) ~package (item : Module.t) +let rec module_item_to_structure_env ~(env : QueryEnv.t) ~package (item : Module.t) = match item with | Module.Structure structure -> Some (env, structure) - | Module.Constraint (_, moduleType) -> - moduleItemToStructureEnv ~env ~package moduleType + | Module.Constraint (_, module_type) -> + module_item_to_structure_env ~env ~package module_type | Module.Ident p -> ( - match ResolvePath.resolveModuleFromCompilerPath ~env ~package p with + match ResolvePath.resolve_module_from_compiler_path ~env ~package p with | Some (env2, Some declared2) -> - moduleItemToStructureEnv ~env:env2 ~package declared2.item + 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 enterStructureFromDeclared ~(env : QueryEnv.t) ~package +let enter_structure_from_declared ~(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) + match module_item_to_structure_env ~env ~package declared.item with + | Some (env, s) -> Some (QueryEnv.enter_structure env s, s) | None -> None -let completionsFromStructureItems ~(env : QueryEnv.t) +let completions_from_structure_items ~(env : QueryEnv.t) (structure : Module.structure) = StructureUtils.unique_items structure |> List.filter_map (fun (it : Module.item) -> @@ -213,99 +213,99 @@ let completionsFromStructureItems ~(env : QueryEnv.t) (Completion.create ~env ~docstring:it.docstring ~kind:(Completion.Type t) it.name)) -let resolvePathFromStamps ~(env : QueryEnv.t) ~package ~scope ~moduleName ~path +let resolve_path_from_stamps ~(env : QueryEnv.t) ~package ~scope ~module_name ~path = (* Log.log("Finding from stamps " ++ name); *) - match findModuleInScope ~env ~moduleName ~scope with + 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 moduleItemToStructureEnv ~env ~package declared.item with - | Some (env, structure) -> Some (QueryEnv.enterStructure env structure, "") + match module_item_to_structure_env ~env ~package declared.item with + | Some (env, structure) -> Some (QueryEnv.enter_structure env structure, "") | None -> None) | _ -> ( - match ResolvePath.findInModule ~env declared.item path with + match ResolvePath.find_in_module ~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 + | `Global (module_name, full_path) -> ( + match ProcessCmt.file_for_module ~package module_name with | None -> None | Some file -> - ResolvePath.resolvePath ~env:(QueryEnv.fromFile file) ~path:fullPath + ResolvePath.resolve_path ~env:(QueryEnv.from_file file) ~path:full_path ~package)))) -let resolveModuleWithOpens ~opens ~package ~moduleName = +let resolve_module_with_opens ~opens ~package ~module_name = 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 + Log.log ("Looking for env in " ^ Uri.to_string env.file.uri); + match ResolvePath.resolve_path ~env ~package ~path:[module_name; ""] 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 +let resolve_file_module ~module_name ~package = + Log.log ("Getting module " ^ module_name); + match ProcessCmt.file_for_module ~package module_name with | None -> None | Some file -> Log.log "got it"; - let env = QueryEnv.fromFile file in + let env = QueryEnv.from_file file in Some env -let getEnvWithOpens ~scope ~(env : QueryEnv.t) ~package - ~(opens : QueryEnv.t list) ~moduleName (path : string list) = +let get_env_with_opens ~scope ~(env : QueryEnv.t) ~package + ~(opens : QueryEnv.t list) ~module_name (path : string list) = (* TODO: handle interleaving of opens and local modules correctly *) - match resolvePathFromStamps ~env ~scope ~moduleName ~path ~package with + match resolve_path_from_stamps ~env ~scope ~module_name ~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 + 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, "") - | _ -> ResolvePath.resolvePath ~env ~package ~path)) + | _ -> ResolvePath.resolve_path ~env ~package ~path)) -let rec expandTypeExpr ~env ~package typeExpr = - match typeExpr |> Shared.digConstructor with +let rec expand_type_expr ~env ~package type_expr = + match type_expr |> Shared.dig_constructor with | Some path -> ( - match References.digConstructor ~env ~package path with + match References.dig_constructor ~env ~package path with | None -> None | Some (env, {item = {decl = {type_manifest = Some t}}}) -> - expandTypeExpr ~env ~package t + expand_type_expr ~env ~package t | Some (_, {docstring; item}) -> Some (docstring, item)) | None -> None -let kindToDocumentation ~env ~full ~currentDocstring name +let kind_to_documentation ~env ~full ~current_docstring name (kind : Completion.kind) = - let docsFromKind = + let docs_from_kind = match kind with | ObjLabel _ | Label _ | FileModule _ | Snippet _ | FollowContextPath _ -> [] | Module {docstring} -> docstring | Type {decl; name} -> - [decl |> Shared.declToString name |> Markdown.codeBlock] + [decl |> Shared.decl_to_string name |> Markdown.code_block] | Value typ -> ( - match expandTypeExpr ~env ~package:full.package typ with + match expand_type_expr ~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) + Markdown.code_block (Shared.decl_to_string name decl) | _ -> ""); ]) | Field ({typ; optional; docstring}, s) -> @@ -314,181 +314,181 @@ let kindToDocumentation ~env ~full ~currentDocstring name need to _also_ add a "?" after the field name, as that looks weird. *) docstring @ [ - Markdown.codeBlock - (if optional && Utils.startsWith name "?" = false then + Markdown.code_block + (if optional && Utils.starts_with name "?" = false then name ^ "?: " - ^ (typ |> Utils.unwrapIfOption |> Shared.typeToString) - else name ^ ": " ^ (typ |> Shared.typeToString)); - Markdown.codeBlock s; + ^ (typ |> Utils.unwrap_if_option |> Shared.type_to_string) + else name ^ ": " ^ (typ |> Shared.type_to_string)); + Markdown.code_block s; ] | Constructor (c, s) -> - [Markdown.codeBlock (showConstructor c); Markdown.codeBlock s] - | PolyvariantConstructor ({displayName; args}, s) -> + [Markdown.code_block (show_constructor c); Markdown.code_block s] + | PolyvariantConstructor ({display_name; args}, s) -> [ - Markdown.codeBlock - ("#" ^ displayName + Markdown.code_block + ("#" ^ display_name ^ match args with | [] -> "" - | typeExprs -> + | type_exprs -> "(" - ^ (typeExprs - |> List.map (fun typeExpr -> typeExpr |> Shared.typeToString) + ^ (type_exprs + |> List.map (fun type_expr -> type_expr |> Shared.type_to_string) |> String.concat ", ") ^ ")"); - Markdown.codeBlock s; + Markdown.code_block s; ] - | ExtractedType (extractedType, _) -> - [Markdown.codeBlock (TypeUtils.extractedTypeToString extractedType)] + | ExtractedType (extracted_type, _) -> + [Markdown.code_block (TypeUtils.extracted_type_to_string extracted_type)] in - currentDocstring @ docsFromKind + current_docstring @ docs_from_kind |> List.filter (fun s -> s <> "") |> String.concat "\n\n" -let kindToDetail name (kind : Completion.kind) = +let kind_to_detail name (kind : Completion.kind) = match kind with | Type {name} -> "type " ^ name - | Value typ -> typ |> Shared.typeToString - | ObjLabel typ -> typ |> Shared.typeToString - | Label typString -> typString + | 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.startsWith name "?" = false then - typ |> Utils.unwrapIfOption |> Shared.typeToString - else typ |> Shared.typeToString - | Constructor (c, _) -> showConstructor c - | PolyvariantConstructor ({displayName; args}, _) -> ( - "#" ^ displayName + 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 | [] -> "" - | typeExprs -> + | type_exprs -> "(" - ^ (typeExprs - |> List.map (fun typeExpr -> typeExpr |> Shared.typeToString) + ^ (type_exprs + |> List.map (fun type_expr -> type_expr |> Shared.type_to_string) |> String.concat ", ") ^ ")") | Snippet s -> s | FollowContextPath _ -> "" - | ExtractedType (extractedType, _) -> - TypeUtils.extractedTypeToString ~nameOnly:true extractedType + | ExtractedType (extracted_type, _) -> + TypeUtils.extracted_type_to_string ~name_only:true extracted_type -let kindToData filePath (kind : Completion.kind) = +let kind_to_data file_path (kind : Completion.kind) = match kind with | FileModule f -> - Some (`Assoc [("modulePath", `String f); ("filePath", `String filePath)]) + Some (`Assoc [("modulePath", `String f); ("filePath", `String file_path)]) | _ -> 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 +let find_all_completions ~(env : QueryEnv.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 -> - completionForExportedValues ~env ~prefix ~exact ~namesUsed - @ completionsForExportedConstructors ~env ~prefix ~exact ~namesUsed - @ completionForExportedModules ~env ~prefix ~exact ~namesUsed + 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 -> - completionForExportedTypes ~env ~prefix ~exact ~namesUsed - @ completionForExportedModules ~env ~prefix ~exact ~namesUsed - | Module -> completionForExportedModules ~env ~prefix ~exact ~namesUsed + 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 -> - completionForExportedFields ~env ~prefix ~exact ~namesUsed - @ completionForExportedModules ~env ~prefix ~exact ~namesUsed + completion_for_exported_fields ~env ~prefix ~exact ~names_used + @ completion_for_exported_modules ~env ~prefix ~exact ~names_used | 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 + 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 : LocalTables.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 localTables.namesUsed name) then ( - Hashtbl.add localTables.namesUsed name (); - localTables.resultRev <- + 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; } - :: localTables.resultRev) + :: local_tables.result_rev) | None -> - if !Cfg.debugFollowCtxPath then + if !Cfg.debug_follow_ctx_path then Printf.printf "Completion Value Not Found %s loc:%s\n" name - (Loc.toString loc); - localTables.resultRev <- + (Loc.to_string loc); + local_tables.result_rev <- Completion.create name ~env ~kind: - (match contextPath with - | Some contextPath -> FollowContextPath (contextPath, scope) + (match context_path with + | Some context_path -> FollowContextPath (context_path, scope) | None -> Value (Ctype.newconstr (Path.Pident (Ident.create "Type Not Known")) [])) - :: localTables.resultRev + :: local_tables.result_rev -let processLocalConstructor name loc ~prefix ~exact ~env - ~(localTables : LocalTables.t) = - if Utils.checkName name ~prefix ~exact then +let process_local_constructor name loc ~prefix ~exact ~env + ~(local_tables : LocalTables.t) = + if Utils.check_name name ~prefix ~exact then match - Hashtbl.find_opt localTables.constructorTable (name, Loc.start loc) + Hashtbl.find_opt local_tables.constructor_table (name, Loc.start loc) with | Some declared -> - if not (Hashtbl.mem localTables.namesUsed name) then ( - Hashtbl.add localTables.namesUsed name (); - localTables.resultRev <- + 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.typeDecl - |> Shared.declToString (fst declared.item.typeDecl) ))) + snd declared.item.type_decl + |> Shared.decl_to_string (fst declared.item.type_decl) ))) with deprecated = declared.deprecated; docstring = declared.docstring; } - :: localTables.resultRev) + :: local_tables.result_rev) | None -> Log.log (Printf.sprintf "Completion Constructor Not Found %s loc:%s\n" name - (Loc.toString loc)) + (Loc.to_string loc)) -let processLocalType name loc ~prefix ~exact ~env ~(localTables : LocalTables.t) +let process_local_type name loc ~prefix ~exact ~env ~(local_tables : LocalTables.t) = - if Utils.checkName name ~prefix ~exact then - match Hashtbl.find_opt localTables.typesTable (name, Loc.start loc) with + 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 localTables.namesUsed name) then ( - Hashtbl.add localTables.namesUsed name (); - localTables.resultRev <- + 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; } - :: localTables.resultRev) + :: local_tables.result_rev) | None -> Log.log (Printf.sprintf "Completion Type Not Found %s loc:%s\n" name - (Loc.toString loc)) + (Loc.to_string 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 +let process_local_module name loc ~prefix ~exact ~env + ~(local_tables : LocalTables.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 localTables.namesUsed name) then ( - Hashtbl.add localTables.namesUsed name (); - localTables.resultRev <- + 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: @@ -498,26 +498,26 @@ let processLocalModule name loc ~prefix ~exact ~env deprecated = declared.deprecated; docstring = declared.docstring; } - :: localTables.resultRev) + :: local_tables.result_rev) | None -> Log.log (Printf.sprintf "Completion Module Not Found %s loc:%s\n" name - (Loc.toString loc)) + (Loc.to_string loc)) -let processLocalInclude includePath _loc ~prefix ~exact ~(env : QueryEnv.t) - ~(localTables : LocalTables.t) = +let process_local_include include_path _loc ~prefix ~exact ~(env : QueryEnv.t) + ~(local_tables : LocalTables.t) = (* process only values for now *) - localTables.includedValueTable + 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:includePath source_module_path then + 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.checkName name ~prefix ~exact then - if not (Hashtbl.mem localTables.namesUsed name) then ( - Hashtbl.add localTables.namesUsed name (); - localTables.resultRev <- + 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))) @@ -526,286 +526,286 @@ let processLocalInclude includePath _loc ~prefix ~exact ~(env : QueryEnv.t) docstring = declared.docstring; synthetic = true; } - :: localTables.resultRev)) + :: local_tables.result_rev)) -let getItemsFromOpens ~opens ~localTables ~prefix ~exact ~completionContext = +let get_items_from_opens ~opens ~local_tables ~prefix ~exact ~completion_context = opens |> List.fold_left (fun results env -> - let completionsFromThisOpen = - findAllCompletions ~env ~prefix ~exact - ~namesUsed:localTables.LocalTables.namesUsed ~completionContext + let completions_from_this_open = + find_all_completions ~env ~prefix ~exact + ~names_used:local_tables.LocalTables.names_used ~completion_context in - completionsFromThisOpen @ results) + completions_from_this_open @ results) [] -let findLocalCompletionsForValuesAndConstructors ~(localTables : LocalTables.t) +let find_local_completions_for_values_and_constructors ~(local_tables : LocalTables.t) ~env ~prefix ~exact ~opens ~scope = - localTables |> LocalTables.populateValues ~env; - localTables |> LocalTables.populateIncludedValues ~env; - localTables |> LocalTables.populateConstructors ~env; - localTables |> LocalTables.populateModules ~env; + local_tables |> LocalTables.populate_values ~env; + local_tables |> LocalTables.populate_included_values ~env; + local_tables |> LocalTables.populate_constructors ~env; + local_tables |> LocalTables.populate_modules ~env; scope - |> Scope.iterValuesBeforeFirstOpen - (processLocalValue ~prefix ~exact ~env ~localTables); + |> Scope.iter_values_before_first_open + (process_local_value ~prefix ~exact ~env ~local_tables); scope - |> Scope.iterConstructorsBeforeFirstOpen - (processLocalConstructor ~prefix ~exact ~env ~localTables); + |> Scope.iter_constructors_before_first_open + (process_local_constructor ~prefix ~exact ~env ~local_tables); scope - |> Scope.iterModulesBeforeFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); + |> Scope.iter_modules_before_first_open + (process_local_module ~prefix ~exact ~env ~local_tables); - let valuesFromOpens = - getItemsFromOpens ~opens ~localTables ~prefix ~exact - ~completionContext:Value + let values_from_opens = + get_items_from_opens ~opens ~local_tables ~prefix ~exact + ~completion_context:Value in scope - |> Scope.iterValuesAfterFirstOpen - (processLocalValue ~prefix ~exact ~env ~localTables); + |> Scope.iter_values_after_first_open + (process_local_value ~prefix ~exact ~env ~local_tables); scope - |> Scope.iterConstructorsAfterFirstOpen - (processLocalConstructor ~prefix ~exact ~env ~localTables); + |> Scope.iter_constructors_after_first_open + (process_local_constructor ~prefix ~exact ~env ~local_tables); scope - |> Scope.iterModulesAfterFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); + |> Scope.iter_modules_after_first_open + (process_local_module ~prefix ~exact ~env ~local_tables); scope - |> Scope.iterIncludes (processLocalInclude ~prefix ~exact ~env ~localTables); + |> Scope.iter_includes (process_local_include ~prefix ~exact ~env ~local_tables); - List.rev_append localTables.resultRev valuesFromOpens + List.rev_append local_tables.result_rev values_from_opens -let findLocalCompletionsForValues ~(localTables : LocalTables.t) ~env ~prefix +let find_local_completions_for_values ~(local_tables : LocalTables.t) ~env ~prefix ~exact ~opens ~scope = - localTables |> LocalTables.populateValues ~env; - localTables |> LocalTables.populateIncludedValues ~env; - localTables |> LocalTables.populateModules ~env; + local_tables |> LocalTables.populate_values ~env; + local_tables |> LocalTables.populate_included_values ~env; + local_tables |> LocalTables.populate_modules ~env; scope - |> Scope.iterValuesBeforeFirstOpen - (processLocalValue ~prefix ~exact ~env ~localTables); + |> Scope.iter_values_before_first_open + (process_local_value ~prefix ~exact ~env ~local_tables); scope - |> Scope.iterModulesBeforeFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); + |> Scope.iter_modules_before_first_open + (process_local_module ~prefix ~exact ~env ~local_tables); - let valuesFromOpens = - getItemsFromOpens ~opens ~localTables ~prefix ~exact - ~completionContext:Value + let values_from_opens = + get_items_from_opens ~opens ~local_tables ~prefix ~exact + ~completion_context:Value in scope - |> Scope.iterValuesAfterFirstOpen - (processLocalValue ~prefix ~exact ~env ~localTables); + |> Scope.iter_values_after_first_open + (process_local_value ~prefix ~exact ~env ~local_tables); scope - |> Scope.iterModulesAfterFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); + |> Scope.iter_modules_after_first_open + (process_local_module ~prefix ~exact ~env ~local_tables); scope - |> Scope.iterIncludes (processLocalInclude ~prefix ~exact ~env ~localTables); + |> Scope.iter_includes (process_local_include ~prefix ~exact ~env ~local_tables); - List.rev_append localTables.resultRev valuesFromOpens + List.rev_append local_tables.result_rev values_from_opens -let findLocalCompletionsForTypes ~(localTables : LocalTables.t) ~env ~prefix +let find_local_completions_for_types ~(local_tables : LocalTables.t) ~env ~prefix ~exact ~opens ~scope = - localTables |> LocalTables.populateTypes ~env; - localTables |> LocalTables.populateModules ~env; + local_tables |> LocalTables.populate_types ~env; + local_tables |> LocalTables.populate_modules ~env; scope - |> Scope.iterTypesBeforeFirstOpen - (processLocalType ~prefix ~exact ~env ~localTables); + |> Scope.iter_types_before_first_open + (process_local_type ~prefix ~exact ~env ~local_tables); scope - |> Scope.iterModulesBeforeFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); + |> Scope.iter_modules_before_first_open + (process_local_module ~prefix ~exact ~env ~local_tables); - let valuesFromOpens = - getItemsFromOpens ~opens ~localTables ~prefix ~exact ~completionContext:Type + let values_from_opens = + get_items_from_opens ~opens ~local_tables ~prefix ~exact ~completion_context:Type in scope - |> Scope.iterTypesAfterFirstOpen - (processLocalType ~prefix ~exact ~env ~localTables); + |> Scope.iter_types_after_first_open + (process_local_type ~prefix ~exact ~env ~local_tables); scope - |> Scope.iterModulesAfterFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); - List.rev_append localTables.resultRev valuesFromOpens + |> 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 findLocalCompletionsForModules ~(localTables : LocalTables.t) ~env ~prefix +let find_local_completions_for_modules ~(local_tables : LocalTables.t) ~env ~prefix ~exact ~opens ~scope = - localTables |> LocalTables.populateModules ~env; + local_tables |> LocalTables.populate_modules ~env; scope - |> Scope.iterModulesBeforeFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); + |> Scope.iter_modules_before_first_open + (process_local_module ~prefix ~exact ~env ~local_tables); - let valuesFromOpens = - getItemsFromOpens ~opens ~localTables ~prefix ~exact - ~completionContext:Module + let values_from_opens = + get_items_from_opens ~opens ~local_tables ~prefix ~exact + ~completion_context:Module in scope - |> Scope.iterModulesAfterFirstOpen - (processLocalModule ~prefix ~exact ~env ~localTables); - List.rev_append localTables.resultRev valuesFromOpens + |> 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 findLocalCompletionsWithOpens ~pos ~(env : QueryEnv.t) ~prefix ~exact ~opens - ~scope ~(completionContext : Completable.completionContext) = +let find_local_completions_with_opens ~pos ~(env : QueryEnv.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.toString env.file.uri ^ " pos:" - ^ Pos.toString pos); - let localTables = LocalTables.create () in - match completionContext with + ("findLocalCompletionsWithOpens uri:" ^ Uri.to_string env.file.uri ^ " pos:" + ^ Pos.to_string pos); + let local_tables = LocalTables.create () in + match completion_context with | Value | ValueOrField -> - findLocalCompletionsForValuesAndConstructors ~localTables ~env ~prefix + find_local_completions_for_values_and_constructors ~local_tables ~env ~prefix ~exact ~opens ~scope | Type -> - findLocalCompletionsForTypes ~localTables ~env ~prefix ~exact ~opens ~scope + find_local_completions_for_types ~local_tables ~env ~prefix ~exact ~opens ~scope | Module -> - findLocalCompletionsForModules ~localTables ~env ~prefix ~exact ~opens + find_local_completions_for_modules ~local_tables ~env ~prefix ~exact ~opens ~scope | Field -> (* There's no local completion for fields *) [] -let getComplementaryCompletionsForTypedValue ~opens ~allFiles ~scope ~env prefix +let get_complementary_completions_for_typed_value ~opens ~all_files ~scope ~env prefix = let exact = false in - let localCompletionsWithOpens = - let localTables = LocalTables.create () in - findLocalCompletionsForValues ~localTables ~env ~prefix ~exact ~opens ~scope + let local_completions_with_opens = + let local_tables = LocalTables.create () in + find_local_completions_for_values ~local_tables ~env ~prefix ~exact ~opens ~scope in - let fileModules = - allFiles |> FileSet.elements - |> Utils.filterMap (fun name -> + let file_modules = + all_files |> FileSet.elements + |> Utils.filter_map (fun name -> if - Utils.checkName name ~prefix ~exact + Utils.check_name name ~prefix ~exact && not (* TODO complete the namespaced name too *) - (Utils.fileNameHasUnallowedChars name) + (Utils.file_name_has_unallowed_chars name) then Some (Completion.create name ~synthetic:true ~env ~kind:(Completion.FileModule name)) else None) in - localCompletionsWithOpens @ fileModules + local_completions_with_opens @ file_modules -let getCompletionsForPath ~debug ~opens ~full ~pos ~exact ~scope - ~completionContext ~env path = +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 allFiles = allFilesInPackage full.package in + let all_files = all_files_in_package full.package in match path with | [] -> [] | [prefix] -> - let localCompletionsWithOpens = - findLocalCompletionsWithOpens ~pos ~env ~prefix ~exact ~opens ~scope - ~completionContext + let local_completions_with_opens = + find_local_completions_with_opens ~pos ~env ~prefix ~exact ~opens ~scope + ~completion_context in - let fileModules = - allFiles |> FileSet.elements - |> Utils.filterMap (fun name -> + let file_modules = + all_files |> FileSet.elements + |> Utils.filter_map (fun name -> if - Utils.checkName name ~prefix ~exact + Utils.check_name name ~prefix ~exact && not (* TODO complete the namespaced name too *) - (Utils.fileNameHasUnallowedChars name) + (Utils.file_name_has_unallowed_chars name) then Some (Completion.create name ~env ~kind:(Completion.FileModule name)) else None) in - localCompletionsWithOpens @ fileModules - | moduleName :: path -> ( - Log.log ("Path " ^ pathToString path); + 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 envFile = env in - let declaredOpt = - match findModuleInScope ~env:envFile ~moduleName ~scope 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 envFile.exported Exported.Module moduleName with - | Some stamp -> Stamps.findModule envFile.file.stamps stamp + 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 declaredOpt with - | Some (declared : Module.t Declared.t) when declared.isExported = false + match declared_opt with + | Some (declared : Module.t Declared.t) when declared.is_exported = false -> ( match - enterStructureFromDeclared ~env:envFile ~package:full.package declared + enter_structure_from_declared ~env:env_file ~package:full.package declared with | None -> [] - | Some (envInModule, structure) -> - completionsFromStructureItems ~env:envInModule structure) + | Some (env_in_module, structure) -> + completions_from_structure_items ~env:env_in_module structure) | _ -> ( match - getEnvWithOpens ~scope ~env ~package:full.package ~opens ~moduleName + get_env_with_opens ~scope ~env ~package:full.package ~opens ~module_name path with | Some (env, prefix) -> Log.log "Got the env"; - let namesUsed = Hashtbl.create 10 in - findAllCompletions ~env ~prefix ~exact ~namesUsed ~completionContext + let names_used = Hashtbl.create 10 in + find_all_completions ~env ~prefix ~exact ~names_used ~completion_context | None -> [])) | _ -> ( match - getEnvWithOpens ~scope ~env ~package:full.package ~opens ~moduleName + get_env_with_opens ~scope ~env ~package:full.package ~opens ~module_name path with | Some (env, prefix) -> Log.log "Got the env"; - let namesUsed = Hashtbl.create 10 in - findAllCompletions ~env ~prefix ~exact ~namesUsed ~completionContext + 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 completionsForPipeFromCompletionPath ~envCompletionIsMadeFrom ~opens ~pos - ~scope ~debug ~prefix ~env ~rawOpens ~full completionPath = - let completionPathWithoutCurrentModule = - TypeUtils.removeCurrentModuleIfNeeded ~envCompletionIsMadeFrom - completionPath +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 = + TypeUtils.remove_current_module_if_needed ~env_completion_is_made_from + completion_path in - let completionPathMinusOpens = - TypeUtils.removeOpensFromCompletionPath ~rawOpens ~package:full.package - completionPathWithoutCurrentModule + let completion_path_minus_opens = + TypeUtils.remove_opens_from_completion_path ~raw_opens ~package:full.package + completion_path_without_current_module |> String.concat "." in - let completionName name = - if completionPathMinusOpens = "" then name - else completionPathMinusOpens ^ "." ^ name + let completion_name name = + if completion_path_minus_opens = "" then name + else completion_path_minus_opens ^ "." ^ name in let completions = - completionPath @ [prefix] - |> getCompletionsForPath ~debug ~completionContext:Value ~exact:false ~opens + 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 = completionName completion.name}) + {completion with name = completion_name completion.name}) in completions -let rec digToRecordFieldsForCompletion ~debug ~package ~opens ~full ~pos ~env +let rec dig_to_record_fields_for_completion ~debug ~package ~opens ~full ~pos ~env ~scope path = match path - |> getCompletionsForPath ~debug ~completionContext:Type ~exact:true ~opens + |> 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 pathRev = p |> Utils.expandPath in - pathRev |> List.rev - |> digToRecordFieldsForCompletion ~debug ~package ~opens ~full ~pos ~env + 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 mkItem ?data ?additionalTextEdits name ~kind ~detail ~deprecated ~docstring +let mk_item ?data ?additional_text_edits name ~kind ~detail ~deprecated ~docstring = - let docContent = + let doc_content = (match deprecated with | None -> "" | Some s -> "Deprecated: " ^ s ^ "\n\n") @@ -821,12 +821,12 @@ let mkItem ?data ?additionalTextEdits name ~kind ~detail ~deprecated ~docstring in let documentation = - match String.length docContent > 0 with + match String.length doc_content > 0 with | true -> Some (`MarkupContent (Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown - ~value:docContent)) + ~value:doc_content)) | false -> None in @@ -838,115 +838,115 @@ let mkItem ?data ?additionalTextEdits name ~kind ~detail ~deprecated ~docstring in Lsp.Types.CompletionItem.create ~label:name ~kind ~tags ~detail ?documentation - ?deprecated ?data ?additionalTextEdits ?sortText:None ?insertText:None - ?insertTextFormat:None ?filterText:None () + ?deprecated ?data ?additional_text_edits ?sort_text:None ?insert_text:None + ?insert_text_format:None ?filter_text:None () -let completionToItem +let completion_to_item { Completion.name; deprecated; docstring; kind; - sortText; - insertText; - insertTextFormat; - filterText; + sort_text; + insert_text; + insert_text_format; + filter_text; detail; env; - additionalTextEdits; + additional_text_edits; } ~full = let item = - mkItem name ?additionalTextEdits - ?data:(kindToData (full.file.uri |> Uri.toPath) kind) - ~kind:(Completion.kindToLspCompletionItem kind) + 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 -> kindToDetail name kind + | None -> kind_to_detail name kind | Some detail -> detail) ~docstring: (match - kindToDocumentation ~currentDocstring:docstring ~full ~env name kind + kind_to_documentation ~current_docstring:docstring ~full ~env name kind with | "" -> [] | docstring -> [docstring]) in - {item with sortText; insertText; insertTextFormat; filterText} + {item with sort_text; insert_text; insert_text_format; filter_text} -let completionsGetTypeEnv = function +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 getCompletionsForContextPathMode = Regular | Pipe +type get_completions_for_context_path_mode = Regular | Pipe -let completionsGetCompletionType ~full completions = - let firstNonSyntheticCompletion = +let completions_get_completion_type ~full completions = + let first_non_synthetic_completion = List.find_opt (fun c -> not c.Completion.synthetic) completions in - match firstNonSyntheticCompletion with + 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 - |> TypeUtils.extractType ~env ~package:full.package + |> TypeUtils.extract_type ~env ~package:full.package |> Option.map (fun (typ, _) -> (typ, env)) | Some {Completion.kind = Type typ; env} -> ( - match TypeUtils.extractTypeFromResolvedType typ ~env ~full with + match TypeUtils.extract_type_from_resolved_type typ ~env ~full with | None -> None - | Some extractedType -> Some (extractedType, env)) + | Some extracted_type -> Some (extracted_type, env)) | Some {Completion.kind = ExtractedType (typ, _); env} -> Some (typ, env) | _ -> None -let rec completionsGetCompletionType2 ~debug ~full ~opens ~rawOpens ~pos +let rec completions_get_completion_type2 ~debug ~full ~opens ~raw_opens ~pos completions = - let firstNonSyntheticCompletion = + let first_non_synthetic_completion = List.find_opt (fun c -> not c.Completion.synthetic) completions in - match firstNonSyntheticCompletion with + 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 (ctxPath, scope); env} -> - ctxPath - |> getCompletionsForContextPath ~debug ~full ~env ~exact:true ~opens - ~rawOpens ~pos ~scope - |> completionsGetCompletionType2 ~debug ~full ~opens ~rawOpens ~pos + | 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 TypeUtils.extractTypeFromResolvedType typ ~env ~full with + match TypeUtils.extract_type_from_resolved_type typ ~env ~full with | None -> None - | Some extractedType -> Some (ExtractedType extractedType, env)) + | Some extracted_type -> Some (ExtractedType extracted_type, 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 = +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 firstNonSyntheticCompletion with + 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 (ctxPath, scope); env} -> - ctxPath - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~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 - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~pos | _ -> None -and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact - ~scope ?(mode = Regular) contextPath = - let envCompletionIsMadeFrom = env in +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.contextPathToString contextPath); + (Completable.context_path_to_string context_path); let package = full.package in - match contextPath with + match context_path with | CPString -> if Debug.verbose () then print_endline "[ctx_path]--> CPString"; [Completion.create "dummy" ~env ~kind:(Completion.Value Predef.type_string)] @@ -972,9 +972,9 @@ and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact | Regular -> ( match cp - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~exact:true ~scope - |> completionsGetCompletionType ~full + |> completions_get_completion_type ~full with | None -> [] | Some (typ, env) -> @@ -994,9 +994,9 @@ and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact if Debug.verbose () then print_endline "[ctx_path]--> CPOption"; match cp - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~exact:true ~scope - |> completionsGetCompletionType ~full + |> completions_get_completion_type ~full with | None -> [] | Some (typ, env) -> @@ -1009,14 +1009,14 @@ and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact if Debug.verbose () then print_endline "[ctx_path]--> CPAwait"; match cp - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~exact:true ~scope - |> completionsGetCompletionType ~full + |> completions_get_completion_type ~full with | Some (Tpromise (env, typ), _env) -> [Completion.create "dummy" ~env ~kind:(Completion.Value typ)] | _ -> []) - | CPId {path; completionContext; loc} -> + | CPId {path; completion_context; loc} -> if Debug.verbose () then print_endline "[ctx_path]--> CPId"; (* Looks up the type of an identifier. @@ -1033,157 +1033,157 @@ and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact 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 = + let use_tvar_lookup = !Cfg.in_incremental_typechecking_mode in + let by_path = path - |> getCompletionsForPath ~debug ~opens ~full ~pos ~exact - ~completionContext ~env ~scope + |> get_completions_for_path ~debug ~opens ~full ~pos ~exact + ~completion_context ~env ~scope in - let hasTvars = - if useTvarLookup then - match byPath with - | [{kind = Value typ}] when TypeUtils.hasTvar typ -> true + let has_tvars = + if use_tvar_lookup then + match by_path with + | [{kind = Value typ}] when TypeUtils.has_tvar typ -> true | _ -> false else false in let result = - if hasTvars then - let byLoc = TypeUtils.findTypeViaLoc loc ~full ~debug in - match (byLoc, byPath) with + if has_tvars then + let by_loc = TypeUtils.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}] - | _ -> byPath - else byPath + | _ -> by_path + else by_path in result | CPApply (cp, labels) -> ( if Debug.verbose () then print_endline "[ctx_path]--> CPApply"; match cp - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~exact:true ~scope - |> completionsGetCompletionType2 ~debug ~full ~opens ~rawOpens ~pos + |> completions_get_completion_type2 ~debug ~full ~opens ~raw_opens ~pos with | Some ((TypeExpr typ | ExtractedType (Tfunction {typ})), env) -> ( - let rec reconstructFunctionType args tRet = + let rec reconstruct_function_type args t_ret = match args with - | [] -> tRet - | (label, tArg) :: rest -> - let restType = reconstructFunctionType rest tRet in + | [] -> t_ret + | (label, t_arg) :: rest -> + let rest_type = reconstruct_function_type rest t_ret in { typ with - desc = Tarrow ({lbl = label; typ = tArg}, restType, Cok, None); + desc = Tarrow ({lbl = label; typ = t_arg}, rest_type, Cok, None); } in - let rec processApply args labels = + let rec process_apply args labels = match (args, labels) with | _, [] -> args - | _, label :: (_ :: _ as nextLabels) -> + | _, label :: (_ :: _ as next_labels) -> (* 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, + 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 nextArgs else arg :: processApply nextArgs labels - | ((Nolabel, _) as arg) :: nextArgs, [(Labelled _ | Optional _)] -> - arg :: processApply nextArgs labels + 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 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)] + match TypeUtils.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 {contextPath = CPId {path; completionContext = Module}; fieldName} + | CPField {context_path = CPId {path; completion_context = Module}; field_name} -> 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} -> ( + 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 completionsFromCtxPath = + let completions_from_ctx_path = cp - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~exact:true ~scope in - let mainTypeCompletionEnv = - completionsFromCtxPath - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos + let main_type_completion_env = + completions_from_ctx_path + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~pos in - match mainTypeCompletionEnv with + 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 fieldCompletions = - DotCompletionUtils.fieldCompletionsForDotCompletion typ ~env ~package - ~prefix:fieldName ?posOfDot ~exact + let field_completions = + DotCompletionUtils.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 cpAsPipeCompletion = + let cp_as_pipe_completion = Completable.CPPipe { synthetic = true; - contextPath = + context_path = (match cp with | CPApply (c, args) -> CPApply (c, args @ [Asttypes.Nolabel]) - | CPId _ when TypeUtils.isFunctionType ~env ~package typ -> + | CPId _ when TypeUtils.is_function_type ~env ~package typ -> CPApply (cp, [Asttypes.Nolabel]) | _ -> cp); - id = fieldName; - inJsx; - lhsLoc = exprLoc; + id = field_name; + in_jsx; + lhs_loc = expr_loc; } in - let pipeCompletions = - cpAsPipeCompletion - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos - ~env:envCompletionIsMadeFrom ~exact ~scope + 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 -> - TypeUtils.transformCompletionToPipeCompletion ~synthetic:true - ~env ?posOfDot c) + TypeUtils.transform_completion_to_pipe_completion ~synthetic:true + ~env ?pos_of_dot c) in - fieldCompletions @ pipeCompletions) + field_completions @ pipe_completions) | 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 + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~exact:true ~scope - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~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 + match typ |> TypeUtils.extract_object_type ~env ~package with + | Some (env, t_obj) -> + t_obj |> TypeUtils.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 {contextPath = cp; id = prefix; lhsLoc; inJsx; synthetic} -> ( + | 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 - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~exact:true ~scope ~mode:Pipe - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~pos with | None -> if Debug.verbose () then @@ -1192,22 +1192,22 @@ and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact | Some (typ, env) -> ( let env, typ = typ - |> TypeUtils.resolveTypeForPipeCompletion ~env ~package:full.package - ~full ~lhsLoc + |> TypeUtils.resolve_type_for_pipe_completion ~env ~package:full.package + ~full ~lhs_loc in - let mainTypeId = TypeUtils.findRootTypeId ~full ~env typ in - let typePath = TypeUtils.pathFromTypeExpr typ in - match mainTypeId with + let main_type_id = TypeUtils.find_root_type_id ~full ~env typ in + let type_path = TypeUtils.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 mainTypeId -> + | Some main_type_id -> if Debug.verbose () then - Printf.printf "[pipe_completion] mainTypeId: %s\n" mainTypeId; - let pipeCompletions = + 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. @@ -1219,155 +1219,155 @@ and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact 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 + let complete_as_builtin = + match type_path with + | Some t -> TypeUtils.completion_path_from_maybe_builtin t | None -> None in - let completionPath = - match (completeAsBuiltin, typePath) with - | Some completionPathForBuiltin, _ -> - Some (false, completionPathForBuiltin) + 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 - TypeUtils.getModulePathRelativeToEnv ~debug - ~env:envCompletionIsMadeFrom ~envFromItem:env - (Utils.expandPath p) + TypeUtils.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.moduleName]) + | None -> Some (true, [env.file.module_name]) | Some p -> Some (false, p)) | _ -> None in - match completionPath with + match completion_path with | None -> [] - | Some (isFromCurrentModule, completionPath) -> - completionsForPipeFromCompletionPath ~envCompletionIsMadeFrom ~opens - ~pos ~scope ~debug ~prefix ~env ~rawOpens ~full completionPath - |> TypeUtils.filterPipeableFunctions ~env ~full ~synthetic - ~targetTypeId:mainTypeId + | 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 + |> TypeUtils.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 isFromCurrentModule then + if is_from_current_module then match c.kind with | Value _ -> scope |> List.find_opt (fun (item : ScopeTypes.item) -> match item with - | Value (scopeItemName, _, _, _) -> - scopeItemName = c.name + | Value (scope_item_name, _, _, _) -> + scope_item_name = c.name | _ -> false) |> Option.is_some | _ -> false else true) in - let globallyConfiguredCompletionsForType = - match package.autocomplete |> Misc.StringMap.find_opt mainTypeId with + let globally_configured_completions_for_type = + match package.autocomplete |> Misc.StringMap.find_opt main_type_id with | None -> [] - | Some completionPaths -> - completionPaths |> List.map (fun p -> String.split_on_char '.' p) + | Some completion_paths -> + completion_paths |> 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) + 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 - |> TypeUtils.filterPipeableFunctions ~synthetic:true ~env ~full - ~targetTypeId:mainTypeId + |> TypeUtils.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 extraCompletions = - TypeUtils.getExtraModulesToCompleteFromForType ~env ~full typ - |> List.map (fun completionPath -> - completionsForPipeFromCompletionPath ~envCompletionIsMadeFrom - ~opens ~pos ~scope ~debug ~prefix ~env ~rawOpens ~full - completionPath) + let extra_completions = + TypeUtils.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 - |> TypeUtils.filterPipeableFunctions ~synthetic:true ~env ~full - ~targetTypeId:mainTypeId + |> TypeUtils.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 jsxCompletions = - if inJsx then - PipeCompletionUtils.addJsxCompletionItems ~env ~mainTypeId ~prefix - ~full ~rawOpens typ + let jsx_completions = + if in_jsx then + PipeCompletionUtils.add_jsx_completion_items ~env ~main_type_id ~prefix + ~full ~raw_opens typ else [] in (* Add completions from the current module. *) - let currentModuleCompletions = - getCompletionsForPath ~debug ~completionContext:Value ~exact:false + let current_module_completions = + get_completions_for_path ~debug ~completion_context:Value ~exact:false ~opens:[] ~full ~pos ~env:env_at_cursor ~scope [prefix] - |> TypeUtils.filterPipeableFunctions ~synthetic:true ~env ~full - ~targetTypeId:mainTypeId + |> TypeUtils.filter_pipeable_functions ~synthetic:true ~env ~full + ~target_type_id:main_type_id in - jsxCompletions @ pipeCompletions @ extraCompletions - @ currentModuleCompletions @ globallyConfiguredCompletions)) - | CTuple ctxPaths -> + 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 typeExrps = - ctxPaths - |> List.map (fun contextPath -> - contextPath - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos + 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 completionItems -> - match completionItems with + |> List.filter_map (fun completion_items -> + match completion_items with | {Completion.kind = Value typ} :: _ -> Some typ | _ -> None) in - if List.length ctxPaths = List.length typeExrps then + if List.length ctx_paths = List.length type_exrps then [ Completion.create "dummy" ~env - ~kind:(Completion.Value (Ctype.newty (Ttuple typeExrps))); + ~kind:(Completion.Value (Ctype.newty (Ttuple type_exrps))); ] else [] - | CJsxPropValue {pathToComponent; propName; emptyJsxPropNameHint} -> ( + | CJsxPropValue {path_to_component; prop_name; empty_jsx_prop_name_hint} -> ( if Debug.verbose () then print_endline "[ctx_path]--> CJsxPropValue"; - let findTypeOfValue path = + let find_type_of_value path = path - |> getCompletionsForPath ~debug ~completionContext:Value ~exact:true + |> get_completions_for_path ~debug ~completion_context:Value ~exact:true ~opens ~full ~pos ~env ~scope - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~pos in - let lowercaseComponent = - match pathToComponent with - | [elName] when Char.lowercase_ascii elName.[0] = elName.[0] -> true + 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 lowercaseComponent then - let rec digToTypeForCompletion path = + if lowercase_component then + let rec dig_to_type_for_completion path = match path - |> getCompletionsForPath ~debug ~completionContext:Type ~exact:true + |> 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 pathRev = p |> Utils.expandPath in - pathRev |> List.rev |> digToTypeForCompletion + 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 - TypeUtils.pathToElementProps package |> digToTypeForCompletion + TypeUtils.path_to_element_props package |> dig_to_type_for_completion else - CompletionJsx.getJsxLabels ~componentPath:pathToComponent - ~findTypeOfValue ~package + CompletionJsx.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 />. @@ -1380,68 +1380,68 @@ and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact 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 -> + 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 = identName) + |> List.find_opt (fun (f, _, _) -> f = ident_name) |> Option.is_some | Some _ -> false | None -> true in - let targetLabel = - if emptyJsxPropNameHintIsCorrect then - labels |> List.find_opt (fun (f, _, _) -> f = propName) + 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 targetLabel with + match target_label with | None -> [] | Some (_, typ, env) -> [ Completion.create "dummy" ~env - ~kind:(Completion.Value (Utils.unwrapIfOption typ)); + ~kind:(Completion.Value (Utils.unwrap_if_option typ)); ]) - | CArgument {functionContextPath; argumentLabel} -> ( + | 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 argumentLabel with + (match argument_label with | Labelled n | Optional n -> n - | Unlabelled {argumentPosition} -> "$" ^ string_of_int argumentPosition); + | Unlabelled {argument_position} -> "$" ^ string_of_int argument_position); let labels, env = match - functionContextPath - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env + function_context_path + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~exact:true ~scope - |> completionsGetCompletionType2 ~debug ~full ~opens ~rawOpens ~pos + |> 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 |> TypeUtils.getArgs ~full ~env, env) + (typ |> TypeUtils.get_args ~full ~env, env) | _ -> if Debug.verbose () then print_endline "--> could not find function type"; ([], env) in - let targetLabel = + let target_label = labels |> List.find_opt (fun (label, _) -> - match (argumentLabel, label) with - | ( Unlabelled {argumentPosition = pos1}, - Completable.Unlabelled {argumentPosition = pos2} ) -> + 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 expandOption = - match targetLabel with + let expand_option = + match target_label with | None | Some ((Unlabelled _ | Labelled _), _) -> false | Some (Optional _, _) -> true in - match targetLabel with + match target_label with | None -> if Debug.verbose () then print_endline "--> could not look up function argument"; @@ -1452,99 +1452,99 @@ and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact Completion.create "dummy" ~env ~kind: (Completion.Value - (if expandOption then Utils.unwrapIfOption typ else typ)); + (if expand_option then Utils.unwrap_if_option typ else typ)); ]) - | CPatternPath {rootCtxPath; nested} -> ( + | CPatternPath {root_ctx_path; 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 + root_ctx_path + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~exact:true ~scope - |> completionsGetCompletionType2 ~debug ~full ~opens ~rawOpens ~pos + |> completions_get_completion_type2 ~debug ~full ~opens ~raw_opens ~pos with | Some (typ, env) -> ( - match typ |> TypeUtils.resolveNestedPatternPath ~env ~full ~nested with + match typ |> TypeUtils.resolve_nested_pattern_path ~env ~full ~nested with | Some (typ, env) -> - [Completion.create "dummy" ~env ~kind:(kindFromInnerType typ)] + [Completion.create "dummy" ~env ~kind:(kind_from_inner_type typ)] | None -> []) | None -> []) | CTypeAtPos loc -> ( if Debug.verbose () then print_endline "[ctx_path]--> CTypeAtPos"; - match TypeUtils.findTypeViaLoc loc ~full ~debug with + match TypeUtils.find_type_via_loc loc ~full ~debug with | None -> [] - | Some typExpr -> [Completion.create "dummy" ~env ~kind:(Value typExpr)]) + | Some typ_expr -> [Completion.create "dummy" ~env ~kind:(Value typ_expr)]) -let getOpens ~debug ~rawOpens ~package ~env = - if debug && rawOpens <> [] then +let get_opens ~debug ~raw_opens ~package ~env = + if debug && raw_opens <> [] then Printf.printf "%s\n" ("Raw opens: " - ^ string_of_int (List.length rawOpens) + ^ string_of_int (List.length raw_opens) ^ " " - ^ String.concat " ... " (rawOpens |> List.map pathToString)); - let packageOpens = package.opens in - if debug && packageOpens <> [] then + ^ 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 " " (packageOpens |> List.map (fun p -> p |> pathToString)) + ^ String.concat " " (package_opens |> List.map (fun p -> p |> path_to_string)) ); - let resolvedOpens = - resolveOpens ~env (List.rev (rawOpens @ packageOpens)) ~package + let resolved_opens = + resolve_opens ~env (List.rev (raw_opens @ package_opens)) ~package in - if debug && resolvedOpens <> [] then + if debug && resolved_opens <> [] then Printf.printf "%s\n" ("Resolved opens " - ^ string_of_int (List.length resolvedOpens) + ^ string_of_int (List.length resolved_opens) ^ " " ^ String.concat " " - (resolvedOpens |> List.map (fun (e : QueryEnv.t) -> e.file.moduleName)) + (resolved_opens |> List.map (fun (e : QueryEnv.t) -> e.file.module_name)) ); (* Last open takes priority *) - List.rev resolvedOpens + List.rev resolved_opens -let filterItems items ~prefix = +let filter_items items ~prefix = if prefix = "" then items else items |> List.filter (fun (item : Completion.t) -> - Utils.startsWith item.name prefix) + Utils.starts_with item.name prefix) -type completionMode = Pattern of Completable.patternMode | Expression +type completion_mode = Pattern of Completable.pattern_mode | Expression -let emptyCase ~mode num = +let empty_case ~mode num = match mode with | Expression -> "$" ^ string_of_int (num - 1) | Pattern _ -> "${" ^ string_of_int num ^ ":_}" -let printConstructorArgs ~mode ~asSnippet argsLen = +let print_constructor_args ~mode ~as_snippet args_len = let args = ref [] in - for argNum = 1 to argsLen do + for arg_num = 1 to args_len do args := !args @ [ - (match (asSnippet, argsLen) with - | true, l when l > 1 -> Printf.sprintf "${%i:_}" argNum - | true, l when l > 0 -> emptyCase ~mode argNum + (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 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 = +let rec complete_typed_value ?(type_arg_context : type_arg_context option) ~raw_opens + ~full ~prefix ~completion_context ~mode (t : SharedTypes.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 completionContext with - | Some (Completable.RecordField {seenFields}) -> + match completion_context with + | Some (Completable.RecordField {seen_fields}) -> fields |> List.filter (fun (field : field) -> - List.mem field.fname.txt seenFields = false) + List.mem field.fname.txt seen_fields = false) |> List.map (fun (field : field) -> match (field.optional, mode) with | true, Pattern Destructuring -> @@ -1556,21 +1556,21 @@ let rec completeTypedValue ?(typeArgContext : typeArgContext option) ~rawOpens using '?'."; ] ~kind: - (Field (field, TypeUtils.extractedTypeToString extractedType)) + (Field (field, TypeUtils.extracted_type_to_string extracted_type)) ~env | _ -> create field.fname.txt ?deprecated:field.deprecated ~kind: - (Field (field, TypeUtils.extractedTypeToString extractedType)) + (Field (field, TypeUtils.extracted_type_to_string extracted_type)) ~env) - |> filterItems ~prefix + |> filter_items ~prefix | _ -> if prefix = "" then [ - create "{}" ~includesSnippets:true ~insertText:"{$0}" ~sortText:"A" + create "{}" ~includes_snippets:true ~insert_text:"{$0}" ~sort_text:"A" ~kind: (ExtractedType - ( extractedType, + ( extracted_type, match mode with | Pattern _ -> `Type | Expression -> `Value )) @@ -1583,17 +1583,17 @@ let rec completeTypedValue ?(typeArgContext : typeArgContext option) ~rawOpens if Debug.verbose () then print_endline "[complete_typed_value]--> TtypeT (Expression)"; (* Find all values in the module with type t *) - let valueWithTypeT 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 fnReturnsTypeT t = + let rec fn_returns_type_t t = match t.Types.desc with - | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> fnReturnsTypeT t1 + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> fn_returns_type_t t1 | Tarrow _ -> ( - match TypeUtils.extractFunctionType ~env ~package:full.package t with + match TypeUtils.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 @@ -1604,259 +1604,259 @@ let rec completeTypedValue ?(typeArgContext : typeArgContext option) ~rawOpens | _ -> false) | _ -> false in - let getCompletionName exportedValueName = - let fnNname = - TypeUtils.getModulePathRelativeToEnv ~debug:false - ~env:(QueryEnv.fromFile full.file) - ~envFromItem:env (Utils.expandPath path) + let get_completion_name exported_value_name = + let fn_nname = + TypeUtils.get_module_path_relative_to_env ~debug:false + ~env:(QueryEnv.from_file full.file) + ~env_from_item:env (Utils.expand_path path) in - match fnNname with + match fn_nname with | None -> None | Some base -> let base = - TypeUtils.removeOpensFromCompletionPath ~rawOpens + TypeUtils.remove_opens_from_completion_path ~raw_opens ~package:full.package base in - Some ((base |> String.concat ".") ^ "." ^ exportedValueName) + Some ((base |> String.concat ".") ^ "." ^ exported_value_name) in - let getExportedValueCompletion name (declared : Types.type_expr Declared.t) + let get_exported_value_completion name (declared : Types.type_expr Declared.t) = - let typeExpr = declared.item in - if valueWithTypeT typeExpr then - getCompletionName name + let type_expr = declared.item in + if value_with_type_t type_expr then + get_completion_name name |> Option.map (fun name -> - create name ~includesSnippets:true ~insertText:name - ~kind:(Value typeExpr) ~env) - else if fnReturnsTypeT typeExpr then - getCompletionName 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) - ~includesSnippets:true ~insertText:(name ^ "($0)") - ~kind:(Value typeExpr) ~env) + ~includes_snippets:true ~insert_text:(name ^ "($0)") + ~kind:(Value type_expr) ~env) else None in - let completionItems = + let completion_items = Hashtbl.fold (fun name stamp all -> - match Stamps.findValue env.file.stamps stamp with + match Stamps.find_value env.file.stamps stamp with | None -> all - | Some declaredTypeExpr -> ( - match getExportedValueCompletion name declaredTypeExpr with + | 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 completionItems = + 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" ~insertText:"/$0/g" ~includesSnippets:true + create "//g" ~insert_text:"/$0/g" ~includes_snippets:true ~kind:(Label "Regular expression") ~env - :: completionItems - | _ -> completionItems + :: completion_items + | _ -> completion_items in - completionItems + 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; ] - |> filterItems ~prefix + |> 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 moduleName = - match path |> Utils.expandPath with - | _t :: moduleName :: _rest -> String.uncapitalize_ascii moduleName + let module_name = + match path |> Utils.expand_path with + | _t :: module_name :: _rest -> String.uncapitalize_ascii module_name | _ -> "value" in [ - create moduleName ~kind:(Label moduleName) ~env - ~insertText:("${0:" ^ moduleName ^ "}") - ~includesSnippets:true; + create module_name ~kind:(Label module_name) ~env + ~insert_text:("${0:" ^ module_name ^ "}") + ~includes_snippets:true; ] - | Tvariant {env; constructors; variantDecl; variantName} -> + | 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 numArgs = + let num_args = match constructor.args with | InlineRecord _ -> 1 | Args args -> List.length args in - create ?deprecated:constructor.deprecated ~includesSnippets:true + create ?deprecated:constructor.deprecated ~includes_snippets:true (constructor.cname.txt - ^ printConstructorArgs numArgs ~asSnippet:false) - ~insertText: + ^ print_constructor_args num_args ~as_snippet:false) + ~insert_text: (constructor.cname.txt - ^ printConstructorArgs numArgs ~asSnippet:true) + ^ print_constructor_args num_args ~as_snippet:true) ~kind: (Constructor - (constructor, variantDecl |> Shared.declToString variantName)) + (constructor, variant_decl |> Shared.decl_to_string variant_name)) ~env) - |> filterItems ~prefix - | Tpolyvariant {env; constructors; typeExpr} -> + |> filter_items ~prefix + | Tpolyvariant {env; constructors; type_expr} -> if Debug.verbose () then print_endline "[complete_typed_value]--> Tpolyvariant"; constructors - |> List.map (fun (constructor : polyVariantConstructor) -> + |> List.map (fun (constructor : poly_variant_constructor) -> create - ("#" ^ constructor.displayName - ^ printConstructorArgs + ("#" ^ constructor.display_name + ^ print_constructor_args (List.length constructor.args) - ~asSnippet:false) - ~includesSnippets:true - ~insertText: - ((if Utils.startsWith prefix "#" then "" else "#") - ^ constructor.displayName - ^ printConstructorArgs + ~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) - ~asSnippet:true) + ~as_snippet:true) ~kind: (PolyvariantConstructor - (constructor, typeExpr |> Shared.typeToString)) + (constructor, type_expr |> Shared.type_to_string)) ~env) - |> filterItems - ~prefix:(if Utils.startsWith prefix "#" then prefix else "#" ^ prefix) + |> 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 innerType = + let inner_type = match t with | ExtractedType t -> Some (t, None) - | TypeExpr t -> t |> TypeUtils.extractType ~env ~package:full.package + | TypeExpr t -> t |> TypeUtils.extract_type ~env ~package:full.package in - let expandedCompletions = - match innerType with + let expanded_completions = + match inner_type with | None -> [] - | Some (innerType, _typeArgsContext) -> - innerType - |> completeTypedValue ~rawOpens ~full ~prefix ~completionContext ~mode + | 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 ^ ")"; - sortText = None; - insertText = - (match c.insertText with + sort_text = None; + insert_text = + (match c.insert_text with | None -> None - | Some insertText -> Some ("Some(" ^ insertText ^ ")")); + | Some insert_text -> Some ("Some(" ^ insert_text ^ ")")); }) 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)) + 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 completionContext with - | Some (Completable.CameFromRecordField fieldName) -> + match completion_context with + | Some (Completable.CameFromRecordField field_name) -> [ create - ("Some(" ^ fieldName ^ ")") - ~includesSnippets:true ~kind:(kindFromInnerType t) ~env - ~insertText:("Some(" ^ fieldName ^ ")$0"); - someAnyCase; - noneCase; + ("Some(" ^ field_name ^ ")") + ~includes_snippets:true ~kind:(kind_from_inner_type t) ~env + ~insert_text:("Some(" ^ field_name ^ ")$0"); + some_any_case; + none_case; ] - | _ -> [noneCase; someAnyCase] + | _ -> [none_case; some_any_case] in - completions @ expandedCompletions |> filterItems ~prefix - | Tresult {env; okType; errorType} -> + completions @ expanded_completions |> filter_items ~prefix + | Tresult {env; ok_type; error_type} -> if Debug.verbose () then print_endline "[complete_typed_value]--> Tresult"; - let okInnerType = - okType |> TypeUtils.extractType ~env ~package:full.package + let ok_inner_type = + ok_type |> TypeUtils.extract_type ~env ~package:full.package in - let errorInnerType = - errorType |> TypeUtils.extractType ~env ~package:full.package + let error_inner_type = + error_type |> TypeUtils.extract_type ~env ~package:full.package in - let expandedOkCompletions = - match okInnerType with + let expanded_ok_completions = + match ok_inner_type with | None -> [] - | Some (innerType, _) -> - innerType - |> completeTypedValue ~rawOpens ~full ~prefix ~completionContext ~mode + | 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 ^ ")"; - sortText = None; - insertText = - (match c.insertText with + sort_text = None; + insert_text = + (match c.insert_text with | None -> None - | Some insertText -> Some ("Ok(" ^ insertText ^ ")")); + | Some insert_text -> Some ("Ok(" ^ insert_text ^ ")")); }) in - let expandedErrorCompletions = - match errorInnerType with + let expanded_error_completions = + match error_inner_type with | None -> [] - | Some (innerType, _) -> - innerType - |> completeTypedValue ~rawOpens ~full ~prefix ~completionContext ~mode + | 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 ^ ")"; - sortText = None; - insertText = - (match c.insertText with + sort_text = None; + insert_text = + (match c.insert_text with | None -> None - | Some insertText -> Some ("Error(" ^ insertText ^ ")")); + | Some insert_text -> Some ("Error(" ^ insert_text ^ ")")); }) in - let okAnyCase = - create "Ok(_)" ~includesSnippets:true ~kind:(Value okType) ~env - ~insertText:(Printf.sprintf "Ok(%s)" (emptyCase 1)) + 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 errorAnyCase = - create "Error(_)" ~includesSnippets:true ~kind:(Value errorType) ~env - ~insertText:(Printf.sprintf "Error(%s)" (emptyCase 1)) + 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 completionContext with - | Some (Completable.CameFromRecordField fieldName) -> + match completion_context with + | Some (Completable.CameFromRecordField field_name) -> [ create - ("Ok(" ^ fieldName ^ ")") - ~includesSnippets:true ~kind:(Value okType) ~env - ~insertText:("Ok(" ^ fieldName ^ ")$0"); - okAnyCase; - errorAnyCase; + ("Ok(" ^ field_name ^ ")") + ~includes_snippets:true ~kind:(Value ok_type) ~env + ~insert_text:("Ok(" ^ field_name ^ ")$0"); + ok_any_case; + error_any_case; ] - | _ -> [okAnyCase; errorAnyCase] + | _ -> [ok_any_case; error_any_case] in - completions @ expandedOkCompletions @ expandedErrorCompletions - |> filterItems ~prefix + 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 numExprs = List.length exprs in + let num_exprs = List.length exprs in [ create - (printConstructorArgs numExprs ~asSnippet:false) - ~includesSnippets:true - ~insertText:(printConstructorArgs numExprs ~asSnippet:true) + (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 extractedType -> + | Trecord {env; fields} as extracted_type -> if Debug.verbose () then print_endline "[complete_typed_value]--> Trecord"; - getRecordCompletions ~env ~fields ~extractedType - | TinlineRecord {env; fields} as extractedType -> + get_record_completions ~env ~fields ~extracted_type + | TinlineRecord {env; fields} as extracted_type -> if Debug.verbose () then print_endline "[complete_typed_value]--> TinlineRecord"; - getRecordCompletions ~env ~fields ~extractedType + get_record_completions ~env ~fields ~extracted_type | Tarray (env, typ) -> if Debug.verbose () then print_endline "[complete_typed_value]--> Tarray"; if prefix = "" then [ - create "[]" ~includesSnippets:true ~insertText:"[$0]" ~sortText:"A" + create "[]" ~includes_snippets:true ~insert_text:"[$0]" ~sort_text:"A" ~kind: (match typ with | ExtractedType typ -> @@ -1873,69 +1873,69 @@ let rec completeTypedValue ?(typeArgContext : typeArgContext option) ~rawOpens if Debug.verbose () then print_endline "[complete_typed_value]--> Tstring"; if prefix = "" then [ - create "\"\"" ~includesSnippets:true ~insertText:"\"$0\"" ~sortText:"A" + create "\"\"" ~includes_snippets:true ~insert_text:"\"$0\"" ~sort_text:"A" ~kind:(Value Predef.type_string) ~env; ] else [] - | Tfunction {env; typ; args; returnType} when prefix = "" && mode = Expression + | Tfunction {env; typ; args; return_type} when prefix = "" && mode = Expression -> if Debug.verbose () then print_endline "[complete_typed_value]--> Tfunction #1"; - let mkFnArgs ~asSnippet = + let mk_fn_args ~as_snippet = match args with - | [(Nolabel, argTyp)] when TypeUtils.typeIsUnit argTyp -> "()" - | [(Nolabel, argTyp)] -> - let varName = - CompletionExpressions.prettyPrintFnTemplateArgName ~env ~full argTyp + | [(Nolabel, arg_typ)] when TypeUtils.type_is_unit arg_typ -> "()" + | [(Nolabel, arg_typ)] -> + let var_name = + CompletionExpressions.pretty_print_fn_template_arg_name ~env ~full arg_typ in - if asSnippet then "${1:" ^ varName ^ "}" else varName + if as_snippet then "${1:" ^ var_name ^ "}" else var_name | _ -> - let currentUnlabelledIndex = ref 0 in - let argsText = + let current_unlabelled_index = ref 0 in + let args_text = args - |> List.map (fun ((label, typ) : typedFnArg) -> + |> List.map (fun ((label, typ) : typed_fn_arg) -> match label with | Optional {txt = name} -> "~" ^ name ^ "=?" | Labelled {txt = name} -> "~" ^ name | Nolabel -> - if TypeUtils.typeIsUnit typ then "()" + if TypeUtils.type_is_unit typ then "()" else ( - currentUnlabelledIndex := !currentUnlabelledIndex + 1; - let num = !currentUnlabelledIndex in - let varName = - CompletionExpressions.prettyPrintFnTemplateArgName - ~currentIndex:num ~env ~full typ + current_unlabelled_index := !current_unlabelled_index + 1; + let num = !current_unlabelled_index in + let var_name = + CompletionExpressions.pretty_print_fn_template_arg_name + ~current_index:num ~env ~full typ in - if asSnippet then - "${" ^ string_of_int num ^ ":" ^ varName ^ "}" - else varName)) + if as_snippet then + "${" ^ string_of_int num ^ ":" ^ var_name ^ "}" + else var_name)) |> String.concat ", " in - "(" ^ argsText ^ ")" + "(" ^ args_text ^ ")" in - let isAsync = - match TypeUtils.extractType ~env ~package:full.package returnType with + let is_async = + match TypeUtils.extract_type ~env ~package:full.package return_type with | Some (Tpromise _, _) -> true | _ -> false in - let asyncPrefix = if isAsync then "async " else "" in - let functionBody, functionBodyInsertText = + let async_prefix = if is_async then "async " else "" in + let function_body, function_body_insert_text = match args with - | [(Nolabel, argTyp)] -> - let varName = - CompletionExpressions.prettyPrintFnTemplateArgName ~env ~full argTyp + | [(Nolabel, arg_typ)] -> + let var_name = + CompletionExpressions.pretty_print_fn_template_arg_name ~env ~full arg_typ in - ( (" => " ^ if varName = "()" then "{}" else varName), - " => ${0:" ^ varName ^ "}" ) + ( (" => " ^ if var_name = "()" then "{}" else var_name), + " => ${0:" ^ var_name ^ "}" ) | _ -> (" => {}", " => {${0:()}}") in [ create - (asyncPrefix ^ mkFnArgs ~asSnippet:false ^ functionBody) - ~includesSnippets:true - ~insertText: - (asyncPrefix ^ mkFnArgs ~asSnippet:true ^ functionBodyInsertText) - ~sortText:"A" ~kind:(Value typ) ~env; + (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 @@ -1961,42 +1961,42 @@ let rec completeTypedValue ?(typeArgContext : typeArgContext option) ~rawOpens module StringSet = Set.Make (String) -let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover completable = +let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable = if debug then - Printf.printf "Completable: %s\n" (Completable.toString completable); + Printf.printf "Completable: %s\n" (Completable.to_string 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 = + 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 - |> getCompletionsForPath ~debug ~completionContext:Value ~exact:true ~opens + |> get_completions_for_path ~debug ~completion_context:Value ~exact:true ~opens ~full ~pos ~env ~scope - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~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 -> ( + | 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 mkLabel (name, typString) = - Completion.create name ~kind:(Label typString) ~env + let mk_label (name, typ_string) = + Completion.create name ~kind:(Label typ_string) ~env in - let keyLabels = - if Utils.startsWith "key" prefix then [mkLabel ("key", "string")] else [] + let key_labels = + if Utils.starts_with "key" prefix then [mk_label ("key", "string")] else [] in - let pathToElementProps = TypeUtils.pathToElementProps package in + let path_to_element_props = TypeUtils.path_to_element_props package in if Debug.verbose () then Printf.printf "[completing-lowercase-jsx] Attempting to complete from type at %s\n" - (pathToElementProps |> String.concat "."); - let fromElementProps = + (path_to_element_props |> String.concat "."); + let from_element_props = match - pathToElementProps - |> digToRecordFieldsForCompletion ~debug ~package ~opens ~full ~pos ~env + path_to_element_props + |> dig_to_record_fields_for_completion ~debug ~package ~opens ~full ~pos ~env ~scope with | None -> None @@ -2005,47 +2005,47 @@ let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover completable = (fields |> List.filter_map (fun (f : field) -> if - Utils.startsWith f.fname.txt prefix - && (forHover || not (List.mem f.fname.txt identsSeen)) + Utils.starts_with f.fname.txt prefix + && (for_hover || not (List.mem f.fname.txt idents_seen)) then Some ( f.fname.txt, - Shared.typeToString (Utils.unwrapIfOption f.typ) ) + Shared.type_to_string (Utils.unwrap_if_option f.typ) ) else None) - |> List.map mkLabel) + |> List.map mk_label) in - match fromElementProps with - | Some elementProps -> elementProps + 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"; - keyLabels) - | Cjsx (componentPath, prefix, identsSeen) -> + key_labels) + | Cjsx (component_path, prefix, idents_seen) -> let labels = - CompletionJsx.getJsxLabels ~componentPath ~findTypeOfValue ~package + CompletionJsx.get_jsx_labels ~component_path ~find_type_of_value ~package in - let mkLabel_ name typString = - Completion.create name ~kind:(Label typString) ~env + let mkLabel_ name typ_string = + Completion.create name ~kind:(Label typ_string) ~env in - let mkLabel (name, typ, _env) = - mkLabel_ name (typ |> Shared.typeToString) + let mk_label (name, typ, _env) = + mkLabel_ name (typ |> Shared.type_to_string) in - let keyLabels = - if Utils.startsWith "key" prefix then [mkLabel_ "key" "string"] else [] + 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.startsWith name prefix + Utils.starts_with name prefix && name <> "key" - && (forHover || not (List.mem name identsSeen))) - |> List.map mkLabel) - @ keyLabels + && (for_hover || not (List.mem name idents_seen))) + |> List.map mk_label) + @ key_labels | CdecoratorPayload (JsxConfig {prefix; nested}) -> ( - let mkField ~name ~primitive = + let mk_field ~name ~primitive = { stamp = -1; fname = {loc = Location.none; txt = name}; @@ -2055,27 +2055,27 @@ let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover completable = deprecated = None; } in - let typ : completionType = + let typ : completion_type = 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; + 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 |> TypeUtils.resolveNested ~env ~full ~nested with + match typ |> TypeUtils.resolve_nested ~env ~full ~nested with | None -> [] - | Some (typ, _env, completionContext, typeArgContext) -> + | Some (typ, _env, completion_context, type_arg_context) -> typ - |> completeTypedValue ?typeArgContext ~rawOpens ~mode:Expression ~full - ~prefix ~completionContext) + |> complete_typed_value ?type_arg_context ~raw_opens ~mode:Expression ~full + ~prefix ~completion_context) | CdecoratorPayload (ModuleWithImportAttributes {prefix; nested}) -> ( - let mkField ~name ~primitive = + let mk_field ~name ~primitive = { stamp = -1; fname = {loc = Location.none; txt = name}; @@ -2085,52 +2085,52 @@ let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover completable = deprecated = None; } in - let importAttributesConfig : completionType = + let import_attributes_config : completion_type = Trecord { env; definition = `NameOnly "importAttributesConfig"; - fields = [mkField ~name:"type_" ~primitive:Predef.path_string]; + fields = [mk_field ~name:"type_" ~primitive:Predef.path_string]; } in - let rootConfig : completionType = + let root_config : completion_type = Trecord { env; definition = `NameOnly "moduleConfig"; fields = [ - mkField ~name:"from" ~primitive:Predef.path_string; - mkField ~name:"with" ~primitive:Predef.path_string; + mk_field ~name:"from" ~primitive:Predef.path_string; + mk_field ~name:"with" ~primitive:Predef.path_string; ]; } in let nested, typ = match nested with - | NFollowRecordField {fieldName = "with"} :: rest -> - (rest, importAttributesConfig) - | _ -> (nested, rootConfig) + | NFollowRecordField {field_name = "with"} :: rest -> + (rest, import_attributes_config) + | _ -> (nested, root_config) in - match typ |> TypeUtils.resolveNested ~env ~full ~nested with + match typ |> TypeUtils.resolve_nested ~env ~full ~nested with | None -> [] - | Some (typ, _env, completionContext, typeArgContext) -> + | Some (typ, _env, completion_context, type_arg_context) -> typ - |> completeTypedValue ?typeArgContext ~rawOpens ~mode:Expression ~full - ~prefix ~completionContext) + |> complete_typed_value ?type_arg_context ~raw_opens ~mode:Expression ~full + ~prefix ~completion_context) | CdecoratorPayload (Module prefix) -> - let packageJsonPath = - Utils.findPackageJson (full.package.rootPath |> Uri.fromPath) + let package_json_path = + Utils.find_package_json (full.package.root_path |> Uri.from_path) in - let itemsFromPackageJson = - match packageJsonPath with + 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.rootPath; + full.package.root_path; [] | Some path -> ( - match Files.readFile path with + match Files.read_file path with | None -> if debug then print_endline "Could not read package.json"; [] @@ -2143,10 +2143,10 @@ let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover completable = | ("dependencies" | "devDependencies"), `Assoc o -> Some (o - |> List.filter_map (fun (pkgName, _) -> - match pkgName with + |> List.filter_map (fun (pkg_name, _) -> + match pkg_name with | "rescript" -> None - | pkgName -> Some pkgName)) + | pkg_name -> Some pkg_name)) | _ -> None) |> List.flatten | _ -> @@ -2154,14 +2154,14 @@ let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover completable = [])) in (* TODO: Resolve relatives? *) - let localItems = + let local_items = try let files = - Sys.readdir (Filename.dirname (env.file.uri |> Uri.toPath)) + Sys.readdir (Filename.dirname (env.file.uri |> Uri.to_path)) |> Array.to_list in (* Filter out generated build artifacts from in-source builds. *) - let resFiles = + let res_files = StringSet.of_list (files |> List.filter_map (fun f -> @@ -2174,53 +2174,53 @@ let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover completable = | _ -> false in files - |> List.filter_map (fun fileName -> - let withoutExtension = - try Filename.chop_extension fileName with _ -> fileName + |> List.filter_map (fun file_name -> + let without_extension = + try Filename.chop_extension file_name with _ -> file_name in if - String.ends_with fileName ~suffix:package.suffix - && resFiles |> StringSet.mem withoutExtension + String.ends_with file_name ~suffix:package.suffix + && res_files |> StringSet.mem without_extension then None else - match Filename.extension fileName with + match Filename.extension file_name with | ".res" | ".resi" | "" -> None | ext when is_internal_artifact_extension ext -> None - | _ -> Some ("./" ^ fileName)) + | _ -> Some ("./" ^ file_name)) |> List.sort String.compare with _ -> if debug then print_endline "Could not read relative directory"; [] in - let items = itemsFromPackageJson @ localItems in + let items = items_from_package_json @ local_items in items - |> List.filter (fun name -> Utils.startsWith name prefix) + |> List.filter (fun name -> Utils.starts_with name prefix) |> List.map (fun name -> - let isLocal = Utils.startsWith name "./" in + let is_local = Utils.starts_with name "./" in Completion.create name - ~kind:(Label (if isLocal then "Local file" else "Package")) + ~kind:(Label (if is_local then "Local file" else "Package")) ~env) | Cdecorator prefix -> - let mkDecorator (name, docstring, maybeInsertText) = + let mk_decorator (name, docstring, maybe_insert_text) = { - (Completion.create name ~synthetic:true ~includesSnippets:true - ~kind:(Label "") ~env ?insertText:maybeInsertText) + (Completion.create name ~synthetic:true ~includes_snippets:true + ~kind:(Label "") ~env ?insert_text:maybe_insert_text) with docstring; } in - let isTopLevel = String.starts_with ~prefix:"@" prefix in + let is_top_level = String.starts_with ~prefix:"@" prefix in let prefix = - if isTopLevel then String.sub prefix 1 (String.length prefix - 1) + if is_top_level then String.sub prefix 1 (String.length prefix - 1) else prefix in let decorators = - if isTopLevel then CompletionDecorators.toplevel + if is_top_level then CompletionDecorators.toplevel else CompletionDecorators.local in decorators - |> List.filter (fun (decorator, _, _) -> Utils.startsWith decorator prefix) - |> List.map (fun (decorator, maybeInsertText, doc) -> + |> 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 = @@ -2228,23 +2228,23 @@ let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover completable = String.sub decorator len (String.length decorator - len) else decorator in - (dec2, doc, maybeInsertText)) - |> List.map mkDecorator - | CnamedArg (cp, prefix, identsSeen) -> + (dec2, doc, maybe_insert_text)) + |> List.map mk_decorator + | CnamedArg (cp, prefix, idents_seen) -> let labels = match cp - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~exact:true ~scope - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos + |> 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.typeToString); + (typ |> Shared.type_to_string); typ - |> TypeUtils.getArgs ~full ~env + |> TypeUtils.get_args ~full ~env |> List.filter_map (fun arg -> match arg with | SharedTypes.Completable.Labelled name, a -> Some (name, a) @@ -2252,47 +2252,47 @@ let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover completable = | _ -> None) | None -> [] in - let mkLabel (name, typ) = - Completion.create name ~kind:(Label (typ |> Shared.typeToString)) ~env + let mk_label (name, typ) = + Completion.create name ~kind:(Label (typ |> Shared.type_to_string)) ~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 () = + 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 |> processCompletable ~debug ~full ~scope ~env ~pos ~forHover + fallback |> process_completable ~debug ~full ~scope ~env ~pos ~for_hover | _, Some items -> items | None, None -> [] in match - contextPath - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env + context_path + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~exact:true ~scope - |> completionsGetTypeEnv2 ~debug ~full ~opens ~rawOpens ~pos + |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~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) + |> TypeUtils.extract_type ~env ~package:full.package + |> Utils.Option.flat_map (fun (typ, type_arg_context) -> + typ |> TypeUtils.resolve_nested ?type_arg_context ~env ~full ~nested) with - | None -> fallbackOrEmpty () - | Some (typ, _env, completionContext, typeArgContext) -> + | None -> fallback_or_empty () + | Some (typ, _env, completion_context, type_arg_context) -> let items = typ - |> completeTypedValue ?typeArgContext ~rawOpens - ~mode:(Pattern patternMode) ~full ~prefix ~completionContext + |> complete_typed_value ?type_arg_context ~raw_opens + ~mode:(Pattern pattern_mode) ~full ~prefix ~completion_context in - fallbackOrEmpty ~items ()) - | None -> fallbackOrEmpty ()) - | Cexpression {contextPath; prefix; nested} -> ( - let isAmbigiousRecordBodyOrJsxWrap = - match (contextPath, nested) with + 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 @@ -2302,7 +2302,7 @@ let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover completable = `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 + 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" @@ -2311,97 +2311,97 @@ let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover completable = 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 = + let regular_completions = if prefix = "" then [] else prefix - |> getComplementaryCompletionsForTypedValue ~opens ~allFiles ~env ~scope + |> get_complementary_completions_for_typed_value ~opens ~all_files ~env ~scope in match - contextPath - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env + context_path + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~exact:true ~scope - |> completionsGetCompletionType ~full + |> completions_get_completion_type ~full with | None -> if Debug.verbose () then print_endline "[process_completable]--> could not get completions for context path"; - regularCompletions + regular_completions | Some (typ, env) -> ( - match typ |> TypeUtils.resolveNested ~env ~full ~nested with + match typ |> TypeUtils.resolve_nested ~env ~full ~nested with | None -> if Debug.verbose () then print_endline "[process_completable]--> could not resolve nested expression path"; - if isAmbigiousRecordBodyOrJsxWrap then ( + 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 itemsForRawJsxPropValue = + let items_for_raw_jsx_prop_value = typ - |> completeTypedValue ~rawOpens ~mode:Expression ~full ~prefix - ~completionContext:None + |> complete_typed_value ~raw_opens ~mode:Expression ~full ~prefix + ~completion_context:None in - itemsForRawJsxPropValue @ regularCompletions) - else regularCompletions - | Some (typ, _env, completionContext, typeArgContext) -> ( + 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 wrapInsertTextInBraces = + let wrap_insert_text_in_braces = if List.length nested > 0 then false else - match contextPath with + match context_path with | CJsxPropValue _ -> true | _ -> false in let items = typ - |> completeTypedValue ?typeArgContext ~rawOpens ~mode:Expression ~full - ~prefix ~completionContext + |> complete_typed_value ?type_arg_context ~raw_opens ~mode:Expression ~full + ~prefix ~completion_context |> List.map (fun (c : Completion.t) -> - if wrapInsertTextInBraces then + if wrap_insert_text_in_braces then { c with - insertText = - (match c.insertText with + insert_text = + (match c.insert_text with | None -> None | Some text -> Some ("{" ^ text ^ "}")); } else c) in - match (prefix, completionContext) with + match (prefix, completion_context) with | "", _ -> items | _, None -> let items = - if List.length regularCompletions > 0 then + 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 sortText = Some ("A" ^ " " ^ c.name)}) + {c with sort_text = Some ("A" ^ " " ^ c.name)}) else items in - items @ regularCompletions + items @ regular_completions | _ -> 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) = + | 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 newText = + let new_text = c.name ^ " {\n" ^ (cases - |> List.mapi (fun index caseText -> - "| " ^ caseText ^ " => " - ^ printFailwithStr (startIndex + index + 1)) + |> List.mapi (fun index case_text -> + "| " ^ case_text ^ " => " + ^ print_failwith_str (start_index + index + 1)) |> String.concat "\n") ^ "\n}" |> Utils.indent range.start.character @@ -2411,25 +2411,25 @@ let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover completable = { c with name = c.name ^ " (exhaustive switch)"; - filterText = Some c.name; - insertTextFormat = Some Snippet; - insertText = Some newText; + filter_text = Some c.name; + insert_text_format = Some Snippet; + insert_text = Some new_text; kind = Snippet "insert exhaustive switch for value"; }; ] in - let completionsForContextPath = - contextPath - |> getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env - ~exact:forHover ~scope + let completions_for_context_path = + context_path + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env + ~exact:for_hover ~scope in - completionsForContextPath + completions_for_context_path |> List.map (fun (c : Completion.t) -> match c.kind with - | Value typExpr -> ( - match typExpr |> TypeUtils.extractType ~env:c.env ~package with + | Value typ_expr -> ( + match typ_expr |> TypeUtils.extract_type ~env:c.env ~package with | Some (Tvariant v, _) -> - withExhaustiveItem c + with_exhaustive_item c ~cases: (v.constructors |> List.map (fun (constructor : Constructor.t) -> @@ -2439,50 +2439,50 @@ let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover completable = | Args [] -> "" | _ -> "(_)")) | Some (Tpolyvariant v, _) -> - withExhaustiveItem c + with_exhaustive_item c ~cases: (v.constructors - |> List.map (fun (constructor : polyVariantConstructor) -> - "#" ^ constructor.displayName + |> List.map (fun (constructor : poly_variant_constructor) -> + "#" ^ constructor.display_name ^ match constructor.args with | [] -> "" | _ -> "(_)")) | Some (Toption (_env, _typ), _) -> - withExhaustiveItem c ~cases:["Some($1)"; "None"] ~startIndex:1 + with_exhaustive_item c ~cases:["Some($1)"; "None"] ~start_index:1 | Some (Tresult _, _) -> - withExhaustiveItem c ~cases:["Ok($1)"; "Error($1)"] ~startIndex:1 + with_exhaustive_item c ~cases:["Ok($1)"; "Error($1)"] ~start_index:1 | Some (Tbool _, _) -> - withExhaustiveItem c ~cases:["true"; "false"] + with_exhaustive_item 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 + CompletionJsx.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] - ~insertText:elementName + ~insert_text:element_name ?deprecated: (match deprecated with | true -> Some "true" | false -> None)) else None) | CextensionNode prefix -> - if Utils.startsWith "todo" prefix then + 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 ~insertText:"todo"; + ~env ~insert_text:"todo"; Completion.create "todo (with payload)" ~synthetic:true - ~includesSnippets:true ~kind:(Label "todo") + ~includes_snippets:true ~kind:(Label "todo") ~detail:(detail ^ " With a payload.") - ~env ~insertText:"todo(\"${0:TODO}\")"; + ~env ~insert_text:"todo(\"${0:TODO}\")"; ] else [] diff --git a/analysis/src/CompletionExpressions.ml b/analysis/src/CompletionExpressions.ml index 8356a48cfd..36aae15cb3 100644 --- a/analysis/src/CompletionExpressions.ml +++ b/analysis/src/CompletionExpressions.ml @@ -1,105 +1,105 @@ open SharedTypes -let isExprHole exp = +let is_expr_hole exp = match exp.Parsetree.pexp_desc with | Pexp_extension ({txt = "rescript.exprhole"}, _) -> true | _ -> false -let isExprTuple expr = +let is_expr_tuple 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 +let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos + ~first_char_before_cursor_no_white = + let loc_has_cursor loc = loc |> CursorPosition.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.hasBraces exp.pexp_attributes -> + | 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. *) - 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 + 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 arrayPatterns = 0 && locHasCursor exp.pexp_loc then - Some ("", nextExprPath) + if List.length array_patterns = 0 && loc_has_cursor exp.pexp_loc then + Some ("", next_expr_path) else - let arrayItemWithCursor = - arrayPatterns + let array_item_with_cursor = + array_patterns |> List.find_map (fun e -> e - |> traverseExpr ~exprPath:nextExprPath - ~firstCharBeforeCursorNoWhite ~pos) + |> traverse_expr ~expr_path:next_expr_path + ~first_char_before_cursor_no_white ~pos) in - match (arrayItemWithCursor, locHasCursor exp.pexp_loc) with - | Some arrayItemWithCursor, _ -> Some arrayItemWithCursor - | None, true when firstCharBeforeCursorNoWhite = Some ',' -> + 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 ("", nextExprPath) + Some ("", next_expr_path) | _ -> 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_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. *) - someIfHasCursor ("", [Completable.NRecordBody {seenFields = []}] @ exprPath) + some_if_has_cursor ("", [Completable.NRecordBody {seen_fields = []}] @ expr_path) | Pexp_record (fields, _) -> ( - let fieldWithCursor = ref None in - let fieldWithExprHole = ref None in + 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 |> CursorPosition.classifyLoc ~pos ) + exp.Parsetree.pexp_loc |> CursorPosition.classify_loc ~pos ) with | Longident.Lident fname, HasCursor -> - fieldWithCursor := Some (fname, exp) - | Lident fname, _ when isExprHole exp -> - fieldWithExprHole := Some (fname, exp) + field_with_cursor := Some (fname, exp) + | Lident fname, _ when is_expr_hole exp -> + field_with_expr_hole := Some (fname, exp) | _ -> ()); - let seenFields = - Ext_list.filter_map fields (fun {lid = fieldName} -> - match fieldName with - | {Location.txt = Longident.Lident fieldName} -> Some fieldName + 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 (!fieldWithCursor, !fieldWithExprHole) with + 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`. *) - someIfHasCursor - ("", [Completable.NFollowRecordField {fieldName = fname}] @ exprPath) + 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}. *) - someIfHasCursor (txt, [Completable.NRecordBody {seenFields}] @ exprPath) + 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. *) - someIfHasCursor (txt, exprPath) + some_if_has_cursor (txt, expr_path) | _ -> f - |> traverseExpr ~firstCharBeforeCursorNoWhite ~pos - ~exprPath: - ([Completable.NFollowRecordField {fieldName = fname}] @ exprPath) + |> 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 firstCharBeforeCursorNoWhite with + match first_char_before_cursor_no_white with | None -> () | Some c -> Printf.printf "[traverse_expr] firstCharBeforeCursorNoWhite: %c.\n" c); @@ -109,169 +109,169 @@ let rec traverseExpr (exp : Parsetree.expression) ~exprPath ~pos 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 + match first_char_before_cursor_no_white with | Some (',' | '{') -> - someIfHasCursor ("", [Completable.NRecordBody {seenFields}] @ exprPath) + some_if_has_cursor ("", [Completable.NRecordBody {seen_fields}] @ expr_path) | _ -> None)) | Pexp_construct ( {txt}, Some {pexp_loc; pexp_desc = Pexp_construct ({txt = Lident "()"}, _)} ) - when locHasCursor pexp_loc -> + when loc_has_cursor pexp_loc -> (* Empty payload with cursor, like: Test() *) Some ( "", [ Completable.NVariantPayload - {constructorName = Utils.getUnqualifiedName txt; itemNum = 0}; + {constructor_name = Utils.get_unqualified_name txt; item_num = 0}; ] - @ exprPath ) + @ expr_path ) | Pexp_construct ({txt}, Some e) when pos >= (e.pexp_loc |> Loc.end_) - && firstCharBeforeCursorNoWhite = Some ',' - && isExprTuple e = false -> + && first_char_before_cursor_no_white = Some ',' + && is_expr_tuple e = false -> (* Empty payload with trailing ',', like: Test(true, ) *) Some ( "", [ Completable.NVariantPayload - {constructorName = Utils.getUnqualifiedName txt; itemNum = 1}; + {constructor_name = Utils.get_unqualified_name txt; item_num = 1}; ] - @ exprPath ) - | Pexp_construct ({txt}, Some {pexp_loc; pexp_desc = Pexp_tuple tupleItems}) - when locHasCursor pexp_loc -> - tupleItems - |> traverseExprTupleItems ~firstCharBeforeCursorNoWhite ~pos - ~nextExprPath:(fun itemNum -> + @ 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 - {constructorName = Utils.getUnqualifiedName txt; itemNum}; + {constructor_name = Utils.get_unqualified_name txt; item_num}; ] - @ exprPath) - ~resultFromFoundItemNum:(fun itemNum -> + @ expr_path) + ~result_from_found_item_num:(fun item_num -> [ Completable.NVariantPayload { - constructorName = Utils.getUnqualifiedName txt; - itemNum = itemNum + 1; + constructor_name = Utils.get_unqualified_name txt; + item_num = item_num + 1; }; ] - @ exprPath) - | Pexp_construct ({txt}, Some p) when locHasCursor exp.pexp_loc -> + @ expr_path) + | Pexp_construct ({txt}, Some p) when loc_has_cursor exp.pexp_loc -> p - |> traverseExpr ~firstCharBeforeCursorNoWhite ~pos - ~exprPath: + |> traverse_expr ~first_char_before_cursor_no_white ~pos + ~expr_path: ([ Completable.NVariantPayload - {constructorName = Utils.getUnqualifiedName txt; itemNum = 0}; + {constructor_name = Utils.get_unqualified_name txt; item_num = 0}; ] - @ exprPath) + @ expr_path) | Pexp_variant (txt, Some {pexp_loc; pexp_desc = Pexp_construct ({txt = Lident "()"}, _)}) - when locHasCursor pexp_loc -> + when loc_has_cursor pexp_loc -> (* Empty payload with cursor, like: #test() *) Some ( "", - [Completable.NPolyvariantPayload {constructorName = txt; itemNum = 0}] - @ exprPath ) + [Completable.NPolyvariantPayload {constructor_name = txt; item_num = 0}] + @ expr_path ) | Pexp_variant (txt, Some e) when pos >= (e.pexp_loc |> Loc.end_) - && firstCharBeforeCursorNoWhite = Some ',' - && isExprTuple e = false -> + && first_char_before_cursor_no_white = Some ',' + && is_expr_tuple 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 {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 - {constructorName = txt; itemNum = itemNum + 1}; + {constructor_name = txt; item_num = item_num + 1}; ] - @ exprPath) - | Pexp_variant (txt, Some p) when locHasCursor exp.pexp_loc -> + @ expr_path) + | Pexp_variant (txt, Some p) when loc_has_cursor exp.pexp_loc -> p - |> traverseExpr ~firstCharBeforeCursorNoWhite ~pos - ~exprPath: + |> traverse_expr ~first_char_before_cursor_no_white ~pos + ~expr_path: ([ Completable.NPolyvariantPayload - {constructorName = txt; itemNum = 0}; + {constructor_name = txt; item_num = 0}; ] - @ exprPath) + @ expr_path) | _ -> None -and traverseExprTupleItems tupleItems ~nextExprPath ~resultFromFoundItemNum ~pos - ~firstCharBeforeCursorNoWhite = - let itemNum = ref (-1) in - let itemWithCursor = - tupleItems +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 -> - itemNum := !itemNum + 1; + item_num := !item_num + 1; e - |> traverseExpr ~exprPath:(nextExprPath !itemNum) - ~firstCharBeforeCursorNoWhite ~pos) + |> traverse_expr ~expr_path:(next_expr_path !item_num) + ~first_char_before_cursor_no_white ~pos) in - match (itemWithCursor, firstCharBeforeCursorNoWhite) with + 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 posNum = ref (-1) in - tupleItems + let pos_num = ref (-1) in + tuple_items |> 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 + 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 prettyPrintFnTemplateArgName ?currentIndex ~env ~full - (argTyp : Types.type_expr) = - let indexText = - match currentIndex with +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 defaultVarName = "v" ^ indexText in - let argTyp, suffix, _env = - TypeUtils.digToRelevantTemplateNameType ~env ~package:full.package argTyp + let default_var_name = "v" ^ index_text in + let arg_typ, suffix, _env = + TypeUtils.dig_to_relevant_template_name_type ~env ~package:full.package arg_typ in - match argTyp |> TypeUtils.pathFromTypeExpr with - | None -> defaultVarName + match arg_typ |> TypeUtils.path_from_type_expr with + | None -> default_var_name | Some p -> ( - let trailingElementsOfPath = - p |> Utils.expandPath |> List.rev |> Utils.lastElements + let trailing_elements_of_path = + p |> Utils.expand_path |> List.rev |> Utils.last_elements in - match trailingElementsOfPath with - | [] | ["t"] -> defaultVarName + 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. *) - | [someName; "t"] | [_; someName] | [someName] -> ( - match someName with + | [some_name; "t"] | [_; some_name] | [some_name] -> ( + match some_name with | "string" | "int" | "float" | "array" | "option" | "bool" -> - defaultVarName - | someName when String.length someName < 30 -> - if someName = "synthetic" then + default_var_name + | some_name when String.length some_name < 30 -> + if some_name = "synthetic" then Printf.printf "synthetic! %s\n" - (trailingElementsOfPath |> SharedTypes.ident); + (trailing_elements_of_path |> 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) + (some_name |> Utils.lowercase_first_char) ^ suffix + | _ -> default_var_name) + | _ -> default_var_name) -let completeConstructorPayload ~posBeforeCursor ~firstCharBeforeCursorNoWhite - (constructorLid : Longident.t Location.loc) expr = +let complete_constructor_payload ~pos_before_cursor ~first_char_before_cursor_no_white + (constructor_lid : Longident.t Location.loc) expr = match - traverseExpr expr ~exprPath:[] ~pos:posBeforeCursor - ~firstCharBeforeCursorNoWhite + traverse_expr expr ~expr_path:[] ~pos:pos_before_cursor + ~first_char_before_cursor_no_white with | None -> None | Some (prefix, nested) -> @@ -281,22 +281,22 @@ let completeConstructorPayload ~posBeforeCursor ~firstCharBeforeCursorNoWhite being represented as tuples. *) let nested = match List.rev nested with - | Completable.NTupleItem {itemNum} :: rest -> + | Completable.NTupleItem {item_num} :: rest -> [ Completable.NVariantPayload - {constructorName = Longident.last constructorLid.txt; itemNum}; + {constructor_name = Longident.last constructor_lid.txt; item_num}; ] @ rest | nested -> [ Completable.NVariantPayload - {constructorName = Longident.last constructorLid.txt; itemNum = 0}; + {constructor_name = Longident.last constructor_lid.txt; item_num = 0}; ] @ nested in - let variantCtxPath = + let variant_ctx_path = Completable.CTypeAtPos - {constructorLid.loc with loc_start = constructorLid.loc.loc_end} + {constructor_lid.loc with loc_start = constructor_lid.loc.loc_end} in Some - (Completable.Cexpression {contextPath = variantCtxPath; prefix; nested}) + (Completable.Cexpression {context_path = variant_ctx_path; prefix; nested}) diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/CompletionFrontEnd.ml index cdb879290d..cb58f2e9a4 100644 --- a/analysis/src/CompletionFrontEnd.ml +++ b/analysis/src/CompletionFrontEnd.ml @@ -1,39 +1,39 @@ open SharedTypes -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 + CompletionExpressions.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 CompletionExpressions.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); + (DumpAst.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 CursorPosition.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:[] + CompletionExpressions.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 CompletionExpressions.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,26 +187,26 @@ 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 @@ -218,22 +218,22 @@ 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 +241,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 +270,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 +288,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 +301,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 +339,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 +348,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 +let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_expr_loc text = - let offsetNoWhite = Utils.skipWhite text (offset - 1) in - let posNoWhite = - let line, col = posCursor in - (line, max 0 col - offset + offsetNoWhite) + 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 +433,207 @@ 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:(TypeUtils.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 = CursorPosition.loc_has_cursor ~pos:pos_before_cursor in + let loc_is_empty = CursorPosition.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 ) + |> CompletionPatterns.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 |> CursorPosition.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 + && CompletionExpressions.is_expr_hole pc_rhs + && CompletionPatterns.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 +649,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 +744,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 +752,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, + ( TypeUtils.context_path_from_core_type core_type, pvb_expr - |> CompletionExpressions.traverseExpr ~exprPath:[] - ~pos:posBeforeCursor ~firstCharBeforeCursorNoWhite ) + |> CompletionExpressions.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 +779,82 @@ 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 + |> CompletionExpressions.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 + && CompletionExpressions.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 TypeUtils.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 ) + |> CompletionPatterns.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 +866,18 @@ 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 +887,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 +902,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 +916,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 +928,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 + && CompletionExpressions.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, + CompletionExpressions.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 + CompletionExpressions.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 +980,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 + CompletionExpressions.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 +1005,141 @@ 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 : CompletionJsx.jsx_props) = props.props |> List.iter (fun (prop : CompletionJsx.prop) -> - let previousCtxPath = !currentCtxPath in - setCurrentCtxPath + 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 +1151,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 +1181,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 + CompletionExpressions.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 +1352,58 @@ 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) + (CompletionJsx.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} : CompletionJsx.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 +1412,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, _ -> + CompletionJsx.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 +1435,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 +1451,55 @@ 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 +1507,189 @@ 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 +1697,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 +1722,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 +1739,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 +1783,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/CompletionJsx.ml index 4ddba8c642..5b78a13e99 100644 --- a/analysis/src/CompletionJsx.ml +++ b/analysis/src/CompletionJsx.ml @@ -2,7 +2,7 @@ open SharedTypes (* 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,11 +207,11 @@ 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, { @@ -219,72 +219,72 @@ let getJsxLabels ~componentPath ~findTypeOfValue ~package = { decl = { - type_kind = Type_record (labelDecls, _repr); - type_params = typeParams; + type_kind = Type_record (label_decls, _repr); + type_params = 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 |> TypeUtils.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 +297,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 +313,39 @@ 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 +354,36 @@ 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 + CompletionExpressions.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 +393,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 + CompletionExpressions.is_expr_hole prop.exp + || is_regexp_jsx_heuristic_expr prop.exp then ( if Debug.verbose () then print_endline @@ -403,21 +403,21 @@ 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 +430,35 @@ 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 +470,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 +479,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/CompletionPatterns.ml b/analysis/src/CompletionPatterns.ml index 8755c48457..009e89aca8 100644 --- a/analysis/src/CompletionPatterns.ml +++ b/analysis/src/CompletionPatterns.ml @@ -1,46 +1,46 @@ open SharedTypes -let isPatternHole pat = +let is_pattern_hole pat = match pat.Parsetree.ppat_desc with | Ppat_extension ({txt = "rescript.patternhole"}, _) -> true | _ -> false -let isPatternTuple pat = +let is_pattern_tuple 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 +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 -> - itemNum := !itemNum + 1; + item_num := !item_num + 1; pat - |> traversePattern ~patternPath:(nextPatternPath !itemNum) - ~locHasCursor ~firstCharBeforeCursorNoWhite ~posBeforeCursor) + |> traverse_pattern ~pattern_path:(next_pattern_path !item_num) + ~loc_has_cursor ~first_char_before_cursor_no_white ~pos_before_cursor) in - match (itemWithCursor, firstCharBeforeCursorNoWhite) with + 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 posNum = ref (-1) in - tupleItems + let pos_num = ref (-1) in + tuple_items |> 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 + 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 traversePattern (pat : Parsetree.pattern) ~patternPath ~locHasCursor - ~firstCharBeforeCursorNoWhite ~posBeforeCursor = - let someIfHasCursor v debugId = - if locHasCursor pat.Parsetree.ppat_loc then ( +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" - debugId; + debug_id; Some v) else None in @@ -51,207 +51,207 @@ and traversePattern (pat : Parsetree.pattern) ~patternPath ~locHasCursor | Ppat_exception p | Ppat_open (_, p) -> p - |> traversePattern ~patternPath ~locHasCursor ~firstCharBeforeCursorNoWhite - ~posBeforeCursor + |> traverse_pattern ~pattern_path ~loc_has_cursor ~first_char_before_cursor_no_white + ~pos_before_cursor | Ppat_or (p1, p2) -> ( - let orPatWithItem = + let or_pat_with_item = [p1; p2] |> List.find_map (fun p -> p - |> traversePattern ~patternPath ~locHasCursor - ~firstCharBeforeCursorNoWhite ~posBeforeCursor) + |> traverse_pattern ~pattern_path ~loc_has_cursor + ~first_char_before_cursor_no_white ~pos_before_cursor) in - match orPatWithItem with - | None when isPatternHole p1 || isPatternHole p2 -> + 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 ("", patternPath) + 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. *) - someIfHasCursor ("", patternPath) "Ppat_any" - | Ppat_var {txt} -> someIfHasCursor (txt, patternPath) "Ppat_var" + 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 { | () }*) - someIfHasCursor - ("", patternPath @ [Completable.NTupleItem {itemNum = 0}]) + some_if_has_cursor + ("", pattern_path @ [Completable.NTupleItem {item_num = 0}]) "Ppat_construct()" | Ppat_construct ({txt = Lident prefix}, None) -> - someIfHasCursor (prefix, patternPath) "Ppat_construct(Lident)" + some_if_has_cursor (prefix, pattern_path) "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) + 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 - arrayPatterns + array_patterns |> 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) + |> 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. *) - someIfHasCursor - ("", [Completable.NRecordBody {seenFields = []}] @ patternPath) + some_if_has_cursor + ("", [Completable.NRecordBody {seen_fields = []}] @ pattern_path) "Ppat_record(empty)" | Ppat_record (fields, _) -> ( - let fieldWithCursor = ref None in - let fieldWithPatHole = ref None in + 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 - |> CursorPosition.classifyLoc ~pos:posBeforeCursor ) + |> CursorPosition.classify_loc ~pos:pos_before_cursor ) with - | Longident.Lident fname, HasCursor -> fieldWithCursor := Some (fname, f) - | Lident fname, _ when isPatternHole f -> - fieldWithPatHole := Some (fname, f) + | 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 seenFields = - Ext_list.filter_map fields (fun {lid = fieldName} -> - match fieldName with - | {Location.txt = Longident.Lident fieldName} -> Some fieldName + 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 (!fieldWithCursor, !fieldWithPatHole) with + 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`. *) - someIfHasCursor + some_if_has_cursor ( "", - [Completable.NFollowRecordField {fieldName = fname}] @ patternPath + [Completable.NFollowRecordField {field_name = fname}] @ pattern_path ) "patternhole" | Ppat_var {txt} -> (* A var means `{s}` or similar. Complete for fields. *) - someIfHasCursor - (txt, [Completable.NRecordBody {seenFields}] @ patternPath) + some_if_has_cursor + (txt, [Completable.NRecordBody {seen_fields}] @ pattern_path) "Ppat_var #2" | _ -> f - |> traversePattern - ~patternPath: - ([Completable.NFollowRecordField {fieldName = fname}] - @ patternPath) - ~locHasCursor ~firstCharBeforeCursorNoWhite ~posBeforeCursor) + |> 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 firstCharBeforeCursorNoWhite with + match first_char_before_cursor_no_white with | Some ',' -> - someIfHasCursor - ("", [Completable.NRecordBody {seenFields}] @ patternPath) + 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 locHasCursor ppat_loc -> + when loc_has_cursor ppat_loc -> (* Empty payload with cursor, like: Test() *) Some ( "", [ Completable.NVariantPayload - {constructorName = Utils.getUnqualifiedName txt; itemNum = 0}; + {constructor_name = Utils.get_unqualified_name txt; item_num = 0}; ] - @ patternPath ) + @ pattern_path ) | Ppat_construct ({txt}, Some pat) - when posBeforeCursor >= (pat.ppat_loc |> Loc.end_) - && firstCharBeforeCursorNoWhite = Some ',' - && isPatternTuple pat = false -> + 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 - {constructorName = Utils.getUnqualifiedName txt; itemNum = 1}; + {constructor_name = Utils.get_unqualified_name txt; item_num = 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 -> + @ 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 - {constructorName = Utils.getUnqualifiedName txt; itemNum}; + {constructor_name = Utils.get_unqualified_name txt; item_num}; ] - @ patternPath) - ~resultFromFoundItemNum:(fun itemNum -> + @ pattern_path) + ~result_from_found_item_num:(fun item_num -> [ Completable.NVariantPayload { - constructorName = Utils.getUnqualifiedName txt; - itemNum = itemNum + 1; + constructor_name = Utils.get_unqualified_name txt; + item_num = item_num + 1; }; ] - @ patternPath) - | Ppat_construct ({txt}, Some p) when locHasCursor pat.ppat_loc -> + @ pattern_path) + | Ppat_construct ({txt}, Some p) when loc_has_cursor pat.ppat_loc -> p - |> traversePattern ~locHasCursor ~firstCharBeforeCursorNoWhite - ~posBeforeCursor - ~patternPath: + |> traverse_pattern ~loc_has_cursor ~first_char_before_cursor_no_white + ~pos_before_cursor + ~pattern_path: ([ Completable.NVariantPayload - {constructorName = Utils.getUnqualifiedName txt; itemNum = 0}; + {constructor_name = Utils.get_unqualified_name txt; item_num = 0}; ] - @ patternPath) + @ pattern_path) | Ppat_variant (txt, Some {ppat_loc; ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}) - when locHasCursor ppat_loc -> + when loc_has_cursor ppat_loc -> (* Empty payload with cursor, like: #test() *) Some ( "", - [Completable.NPolyvariantPayload {constructorName = txt; itemNum = 0}] - @ patternPath ) + [Completable.NPolyvariantPayload {constructor_name = txt; item_num = 0}] + @ pattern_path ) | Ppat_variant (txt, Some pat) - when posBeforeCursor >= (pat.ppat_loc |> Loc.end_) - && firstCharBeforeCursorNoWhite = Some ',' - && isPatternTuple pat = false -> + 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 {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 {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 - {constructorName = txt; itemNum = itemNum + 1}; + {constructor_name = txt; item_num = item_num + 1}; ] - @ patternPath) - | Ppat_variant (txt, Some p) when locHasCursor pat.ppat_loc -> + @ pattern_path) + | Ppat_variant (txt, Some p) when loc_has_cursor pat.ppat_loc -> p - |> traversePattern ~locHasCursor ~firstCharBeforeCursorNoWhite - ~posBeforeCursor - ~patternPath: + |> traverse_pattern ~loc_has_cursor ~first_char_before_cursor_no_white + ~pos_before_cursor + ~pattern_path: ([ Completable.NPolyvariantPayload - {constructorName = txt; itemNum = 0}; + {constructor_name = txt; item_num = 0}; ] - @ patternPath) + @ pattern_path) | _ -> None diff --git a/analysis/src/Completions.ml b/analysis/src/Completions.ml index ae35a5a0d3..45ba813929 100644 --- a/analysis/src/Completions.ml +++ b/analysis/src/Completions.ml @@ -1,11 +1,11 @@ -let getCompletions ~debug ~source ~kindFile ~pos ~forHover +let get_completions ~debug ~source ~kind_file ~pos ~for_hover ~(full : SharedTypes.full option) = match source with | "" -> None | source -> ( match - CompletionFrontEnd.completionWithParser ~debug ~source ~kindFile - ~posCursor:pos + CompletionFrontEnd.completion_with_parser ~debug ~source ~kind_file + ~pos_cursor:pos with | None -> None | Some (completable, scope) -> ( @@ -21,10 +21,10 @@ let getCompletions ~debug ~source ~kindFile ~pos ~forHover match full with | None -> None | Some full -> - let env = SharedTypes.QueryEnv.fromFile full.file in + let env = SharedTypes.QueryEnv.from_file full.file in let completables = completable - |> CompletionBackEnd.processCompletable ~debug ~full ~pos ~scope ~env - ~forHover + |> CompletionBackEnd.process_completable ~debug ~full ~pos ~scope ~env + ~for_hover in Some (completables, full, scope))) diff --git a/analysis/src/CreateInterface.ml b/analysis/src/CreateInterface.ml index c78548e0d9..825d59b290 100644 --- a/analysis/src/CreateInterface.ml +++ b/analysis/src/CreateInterface.ml @@ -1,31 +1,31 @@ module SourceFileExtractor = struct let create ~path = - match Files.readFile path with + match Files.read_file 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 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 lineStart < 0 || lineStart > lineEnd || lineEnd >= Array.length lines + if line_start < 0 || line_start > line_end || line_end >= Array.length lines then [] else ( - for n = lineEnd downto lineStart do + for n = line_end downto line_start 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 + 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 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) + (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) @@ -38,59 +38,59 @@ module AttributesUtils : sig val contains : string -> t -> bool - val toString : t -> string + val to_string : t -> string end = struct type attribute = {line: int; offset: int; name: string} type t = attribute list - type parseState = Search | Collect of int + type parse_state = Search | Collect of int let make lines = - let makeAttr lineIdx attrOffsetStart attrOffsetEnd line = + let make_attr line_idx attr_offset_start attr_offset_end line = { - line = lineIdx; - offset = attrOffsetStart; - name = String.sub line attrOffsetStart (attrOffsetEnd - attrOffsetStart); + 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 lineIdx line -> + |> 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 attrOffset, ' ' -> - res := makeAttr lineIdx attrOffset i line :: !res; + | Collect attr_offset, ' ' -> + res := make_attr line_idx attr_offset i line :: !res; state := Search | Search, _ | Collect _, _ -> () done; match !state with - | Collect attrOffset -> + | Collect attr_offset -> res := - makeAttr lineIdx attrOffset (String.length line) line :: !res + make_attr line_idx attr_offset (String.length line) line :: !res | _ -> ()); !res |> List.rev - let contains attributeForSearch t = - t |> List.exists (fun {name} -> name = attributeForSearch) + let contains attribute_for_search t = + t |> List.exists (fun {name} -> name = attribute_for_search) - let toString t = + let to_string t = match t with | [] -> "" | {line} :: _ -> - let prevLine = ref line in + 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 <> !prevLine then ( + if line <> !prev_line then ( res := !buffer :: !res; buffer := ""; - prevLine := line); + prev_line := line); let indent = String.make (offset - String.length !buffer) ' ' in buffer := !buffer ^ indent ^ name); @@ -98,124 +98,124 @@ end = struct !res |> List.rev |> String.concat "\n" end -let printSignature ~extractor ~signature = +let print_signature ~extractor ~signature = Printtyp.reset_names (); - let sigItemToString (item : Outcometree.out_sig_item) = + 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 genSigStrForInlineAttr lines attributes id vd = + let gen_sig_str_for_inline_attr lines attributes id vd = let divider = if List.length lines > 1 then "\n" else " " in - let sigStr = - sigItemToString + let sig_str = + sig_item_to_string (Printtyp.tree_of_value_description id {vd with val_kind = Val_reg}) in - (attributes |> AttributesUtils.toString) ^ divider ^ sigStr ^ "\n" + (attributes |> AttributesUtils.to_string) ^ divider ^ sig_str ^ "\n" in let buf = Buffer.create 10 in - let getComponentType (typ : Types.type_expr) = - let reactElement = + 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 propsId, typeArgs, _)}}, - retType, + ( {typ = {desc = Tconstr (Path.Pident props_id, type_args, _)}}, + ret_type, _, _ ) - when Ident.name propsId = "props" -> - Some (typeArgs, retType) + when Ident.name props_id = "props" -> + Some (type_args, ret_type) | Tconstr ( Pdot (Pident {name = "React"}, "component", _), - [{desc = Tconstr (Path.Pident propsId, typeArgs, _)}], + [{desc = Tconstr (Path.Pident props_id, type_args, _)}], _ ) - when Ident.name propsId = "props" -> - Some (typeArgs, reactElement) + when Ident.name props_id = "props" -> + Some (type_args, react_element) | Tconstr ( Pdot (Pident {name = "React"}, "componentLike", _), - [{desc = Tconstr (Path.Pident propsId, typeArgs, _)}; retType], + [{desc = Tconstr (Path.Pident props_id, type_args, _)}; ret_type], _ ) - when Ident.name propsId = "props" -> - Some (typeArgs, retType) + when Ident.name props_id = "props" -> + Some (type_args, ret_type) | _ -> None in - let rec processSignature ~indent (signature : Types.signature) : unit = + let rec process_signature ~indent (signature : Types.signature) : unit = match signature with | Sig_type - (propsId, {type_params; type_kind = Type_record (labelDecls, _)}, _) - :: Sig_value (makeId (* make *), makeValueDesc) + (props_id, {type_params; type_kind = Type_record (label_decls, _)}, _) + :: Sig_value (make_id (* make *), make_value_desc) :: rest - when Ident.name propsId = "props" - && getComponentType makeValueDesc.val_type <> None -> + when Ident.name props_id = "props" + && get_component_type make_value_desc.val_type <> None -> (* PPX V4 component declaration: type props = {...} let v = ... *) - let newItemStr = - let typeArgs, retType = - match getComponentType makeValueDesc.val_type with + 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 mkFunType (labelDecls : Types.label_declaration list) = - match labelDecls with - | [] -> retType - | labelDecl :: rest -> - let propType = - TypeUtils.instantiateType ~typeParams:type_params ~typeArgs - labelDecl.ld_type + let rec mk_fun_type (label_decls : Types.label_declaration list) = + match label_decls with + | [] -> ret_type + | label_decl :: rest -> + let prop_type = + TypeUtils.instantiate_type ~type_params:type_params ~type_args + label_decl.ld_type in - let lblName = labelDecl.ld_id |> Ident.name in + let lbl_name = label_decl.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} + if label_decl.ld_optional then + Asttypes.Optional {txt = lbl_name; loc = Location.none} + else Asttypes.Labelled {txt = lbl_name; loc = Location.none} in { - retType with - desc = Tarrow ({lbl; typ = propType}, mkFunType rest, Cok, None); + ret_type with + desc = Tarrow ({lbl; typ = prop_type}, mk_fun_type rest, Cok, None); } in - let funType = - if List.length labelDecls = 0 (* No props *) then - let tUnit = + let fun_type = + if List.length label_decls = 0 (* No props *) then + let t_unit = Ctype.newconstr (Path.Pident (Ident.create "unit")) [] in { - retType with - desc = Tarrow ({lbl = Nolabel; typ = tUnit}, retType, Cok, None); + ret_type with + desc = Tarrow ({lbl = Nolabel; typ = t_unit}, ret_type, Cok, None); } - else mkFunType labelDecls + else mk_fun_type label_decls in - sigItemToString - (Printtyp.tree_of_value_description makeId - {makeValueDesc with val_type = funType}) + 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 ^ newItemStr ^ "\n"); - processSignature ~indent rest - | Sig_module (id, modDecl, recStatus) :: rest -> - let colonOrEquals = - match modDecl.md_type with + 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 recStatus with + ^ (match rec_status with | Trec_not -> "module " | Trec_first -> "module rec " | Trec_next -> "and ") - ^ Ident.name id ^ colonOrEquals); - processModuleType ~indent modDecl.md_type; + ^ Ident.name id ^ colon_or_equals); + process_module_type ~indent mod_decl.md_type; Buffer.add_string buf "\n"; - processSignature ~indent rest + process_signature ~indent rest | Sig_modtype (id, mtd) :: rest -> let () = match mtd.mtd_type with @@ -223,72 +223,72 @@ let printSignature ~extractor ~signature = 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; + process_module_type ~indent mt; Buffer.add_string buf "\n" in - processSignature ~indent rest + 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 posStart, posEnd = Loc.range val_loc in - extractor |> SourceFileExtractor.extract ~posStart ~posEnd + let pos_start, pos_end = Loc.range val_loc in + extractor |> SourceFileExtractor.extract ~pos_start ~pos_end 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) + 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"); - processSignature ~indent items + process_signature ~indent items | Sig_value (id, vd) :: items -> - let newItemStr = - sigItemToString (Printtyp.tree_of_value_description id vd) + let new_item_str = + sig_item_to_string (Printtyp.tree_of_value_description id vd) in - Buffer.add_string buf (indent ^ newItemStr ^ "\n"); - processSignature ~indent items - | Sig_type (_id, typeDecl, _recStatus) :: items -> + Buffer.add_string buf (indent ^ new_item_str ^ "\n"); + process_signature ~indent items + | Sig_type (_id, type_decl, _recStatus) :: items -> let lines = - let posStart, posEnd = Loc.range typeDecl.type_loc in - extractor |> SourceFileExtractor.extract ~posStart ~posEnd + let pos_start, pos_end = Loc.range type_decl.type_loc in + extractor |> SourceFileExtractor.extract ~pos_start ~pos_end 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) + 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 ^ newItemStr ^ "\n"); - processSignature ~indent items + Buffer.add_string buf (indent ^ new_item_str ^ "\n"); + process_signature ~indent items | Sig_class _ :: items -> (* not needed *) - processSignature ~indent items + process_signature ~indent items | Sig_class_type _ :: items -> (* not needed *) - processSignature ~indent items + process_signature ~indent items | [] -> () - and processModuleType ~indent (mt : Types.module_type) = + and process_module_type ~indent (mt : Types.module_type) = match mt with | Mty_signature signature -> Buffer.add_string buf "{\n"; - processSignature ~indent:(indent ^ " ") signature; + process_signature ~indent:(indent ^ " ") signature; Buffer.add_string buf (indent ^ "}") | Mty_functor _ -> - let rec collectFunctorArgs ~args (mt : Types.module_type) = + 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 *) - collectFunctorArgs ~args mt + collect_functor_args ~args mt | Mty_functor (id, mto, mt) -> - collectFunctorArgs ~args:((id, mto) :: args) mt + collect_functor_args ~args:((id, mto) :: args) mt | mt -> (List.rev args, mt) in - let args, retMt = collectFunctorArgs ~args:[] mt in + let args, ret_mt = collect_functor_args ~args:[] mt in Buffer.add_string buf "("; args |> List.iter (fun (id, mto) -> @@ -297,30 +297,30 @@ let printSignature ~extractor ~signature = | None -> Buffer.add_string buf (Ident.name id) | Some mt -> Buffer.add_string buf (Ident.name id ^ ": "); - processModuleType ~indent:(indent ^ " ") mt); + 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); - processModuleType ~indent retMt + process_module_type ~indent ret_mt | Mty_ident path | Mty_alias (_, path) -> - let rec outIdentToString (ident : Outcometree.out_ident) = + let rec out_ident_to_string (ident : Outcometree.out_ident) = match ident with | Oide_ident s -> s - | Oide_dot (ident, s) -> outIdentToString ident ^ "." ^ s + | Oide_dot (ident, s) -> out_ident_to_string ident ^ "." ^ s | Oide_apply (call, arg) -> - outIdentToString call ^ "(" ^ outIdentToString arg ^ ")" + out_ident_to_string call ^ "(" ^ out_ident_to_string arg ^ ")" in - Buffer.add_string buf (outIdentToString (Printtyp.tree_of_path path)) + Buffer.add_string buf (out_ident_to_string (Printtyp.tree_of_path path)) in - processSignature ~indent:"" signature; + process_signature ~indent:"" signature; Buffer.contents buf -let command ~path ~cmiFile = - match Shared.tryReadCmi cmiFile with +let command ~path ~cmi_file = + match Shared.try_read_cmi cmi_file with | Some cmi_info -> (* For reading the config *) - let _ = Cmt.loadFullCmtFromPath ~path in + let _ = Cmt.load_full_cmt_from_path ~path in let extractor = SourceFileExtractor.create ~path in - printSignature ~extractor ~signature:cmi_info.cmi_sign + print_signature ~extractor ~signature:cmi_info.cmi_sign | None -> "" diff --git a/analysis/src/DceCommand.ml b/analysis/src/DceCommand.ml index 8bce148efe..0e340c453c 100644 --- a/analysis/src/DceCommand.ml +++ b/analysis/src/DceCommand.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_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 index d19d7dfa5a..58bc945b72 100644 --- a/analysis/src/Debug.ml +++ b/analysis/src/Debug.ml @@ -1,13 +1,13 @@ -type debugLevel = Off | Regular | Verbose +type debug_level = Off | Regular | Verbose -let debugLevel = ref Off +let debug_level = ref Off let log s = - match !debugLevel with + match !debug_level with | Regular | Verbose -> print_endline s | Off -> () -let debugPrintEnv (env : SharedTypes.QueryEnv.t) = - env.pathRev @ [env.file.moduleName] |> List.rev |> String.concat "." +let debug_print_env (env : SharedTypes.QueryEnv.t) = + env.path_rev @ [env.file.module_name] |> List.rev |> String.concat "." -let verbose () = !debugLevel = Verbose +let verbose () = !debug_level = Verbose diff --git a/analysis/src/Diagnostics.ml b/analysis/src/Diagnostics.ml index 1dad9a9b6f..bcc537b966 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/DocumentSymbol.ml index 856b029906..f6b90c882a 100644 --- a/analysis/src/DocumentSymbol.ml +++ b/analysis/src/DocumentSymbol.ml @@ -2,70 +2,70 @@ 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 + Lsp.Types.DocumentSymbol.create ~name ~range ~selection_range: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 +73,31 @@ 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 +123,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 +143,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 +155,30 @@ 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/DotCompletionUtils.ml b/analysis/src/DotCompletionUtils.ml index fc25742790..35f1bc13b6 100644 --- a/analysis/src/DotCompletionUtils.ml +++ b/analysis/src/DotCompletionUtils.ml @@ -1,42 +1,42 @@ -let filterRecordFields ~env ~recordAsString ~prefix ~exact fields = +let filter_record_fields ~env ~record_as_string ~prefix ~exact fields = fields - |> Utils.filterMap (fun (field : SharedTypes.field) -> - if Utils.checkName field.fname.txt ~prefix ~exact then + |> Utils.filter_map (fun (field : SharedTypes.field) -> + if Utils.check_name 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))) + ~kind:(SharedTypes.Completion.Field (field, record_as_string))) else None) -let fieldCompletionsForDotCompletion ?posOfDot typ ~env ~package ~prefix ~exact +let field_completions_for_dot_completion ?pos_of_dot typ ~env ~package ~prefix ~exact = - let asObject = typ |> TypeUtils.extractObjectType ~env ~package in - match asObject with - | Some (objEnv, obj) -> + let as_object = typ |> TypeUtils.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 |> TypeUtils.getObjFields - |> Utils.filterMap (fun (field, _typ) -> - if Utils.checkName field ~prefix ~exact then - let fullObjFieldName = Printf.sprintf "[\"%s\"]" field in + obj |> TypeUtils.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 - (SharedTypes.Completion.create fullObjFieldName ~synthetic:true - ~insertText:fullObjFieldName ~env:objEnv + (SharedTypes.Completion.create full_obj_field_name ~synthetic:true + ~insert_text:full_obj_field_name ~env:obj_env ~kind:(SharedTypes.Completion.ObjLabel typ) - ?additionalTextEdits: - (match posOfDot with + ?additional_text_edits: + (match pos_of_dot with | None -> None - | Some posOfDot -> + | Some pos_of_dot -> Some - (TypeUtils.makeAdditionalTextEditsForRemovingDot - posOfDot))) + (TypeUtils.make_additional_text_edits_for_removing_dot + pos_of_dot))) else None) | None -> ( - match typ |> TypeUtils.extractRecordType ~env ~package with - | Some (env, fields, typDecl) -> + match typ |> TypeUtils.extract_record_type ~env ~package with + | Some (env, fields, typ_decl) -> fields - |> filterRecordFields ~env ~prefix ~exact - ~recordAsString: - (typDecl.item.decl |> Shared.declToString typDecl.name.txt) + |> 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/DumpAst.ml b/analysis/src/DumpAst.ml index c21cff6b66..3cb09c737f 100644 --- a/analysis/src/DumpAst.ml +++ b/analysis/src/DumpAst.ml @@ -1,35 +1,35 @@ 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 empty_loc_denom = "" +let has_cursor_denom = "<*>" +let no_cursor_denom = "" -let printLocDenominator loc ~pos = - match loc |> CursorPosition.classifyLoc ~pos with - | EmptyLoc -> emptyLocDenom - | HasCursor -> hasCursorDenom - | NoCursor -> noCursorDenom +let print_loc_denominator loc ~pos = + match loc |> CursorPosition.classify_loc ~pos with + | EmptyLoc -> empty_loc_denom + | HasCursor -> has_cursor_denom + | NoCursor -> no_cursor_denom -let printLocDenominatorLoc loc ~pos = - match loc |> CursorPosition.classifyLocationLoc ~pos with - | CursorPosition.EmptyLoc -> emptyLocDenom - | HasCursor -> hasCursorDenom - | NoCursor -> noCursorDenom +let print_loc_denominator_loc loc ~pos = + match loc |> CursorPosition.classify_location_loc ~pos with + | CursorPosition.EmptyLoc -> empty_loc_denom + | HasCursor -> has_cursor_denom + | NoCursor -> no_cursor_denom -let printLocDenominatorPos pos ~posStart ~posEnd = - match CursorPosition.classifyPositions pos ~posStart ~posEnd with - | CursorPosition.EmptyLoc -> emptyLocDenom - | HasCursor -> hasCursorDenom - | NoCursor -> noCursorDenom +let print_loc_denominator_pos pos ~pos_start ~pos_end = + match CursorPosition.classify_positions pos ~pos_start ~pos_end with + | CursorPosition.EmptyLoc -> empty_loc_denom + | HasCursor -> has_cursor_denom + | NoCursor -> no_cursor_denom -let addIndentation indentation = +let add_indentation indentation = let rec indent str indentation = if indentation < 1 then str else indent (str ^ " ") (indentation - 1) in indent "" indentation -let printAttributes attributes = +let print_attributes attributes = match List.length attributes with | 0 -> "" | _ -> @@ -39,7 +39,7 @@ let printAttributes attributes = |> String.concat ",") ^ "]" -let printConstant const = +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) ^ ")" @@ -52,272 +52,272 @@ let printConstant const = "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) +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 |> printLocDenominatorLoc ~pos) - ^ (Utils.flattenLongIdent lid.txt |> ident |> str) + ^ (lid |> print_loc_denominator_loc ~pos) + ^ (Utils.flatten_long_ident lid.txt |> ident |> str) ^ ")" | Ptyp_variant _ -> "Ptyp_variant()" | _ -> "" -let rec printPattern pattern ~pos ~indentation = - printAttributes pattern.Parsetree.ppat_attributes - ^ (pattern.ppat_loc |> printLocDenominator ~pos) +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" - ^ addIndentation (indentation + 1) - ^ printPattern pat1 ~pos ~indentation:(indentation + 2) + ^ add_indentation (indentation + 1) + ^ print_pattern pat1 ~pos ~indentation:(indentation + 2) ^ ",\n" - ^ addIndentation (indentation + 1) - ^ printPattern pat2 ~pos ~indentation:(indentation + 2) - ^ "\n" ^ addIndentation indentation ^ ")" + ^ add_indentation (indentation + 1) + ^ print_pattern pat2 ~pos ~indentation:(indentation + 2) + ^ "\n" ^ add_indentation indentation ^ ")" | Ppat_extension (({txt} as loc), _) -> - "Ppat_extension(%" ^ (loc |> printLocDenominatorLoc ~pos) ^ txt ^ ")" + "Ppat_extension(%" ^ (loc |> print_loc_denominator_loc ~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_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 |> printLocDenominatorLoc ~pos) - ^ (Utils.flattenLongIdent txt |> ident |> str) - ^ (match maybePat with + ^ (loc |> print_loc_denominator_loc ~pos) + ^ (Utils.flatten_long_ident txt |> ident |> str) + ^ (match maybe_pat with | None -> "" - | Some pat -> "," ^ printPattern pat ~pos ~indentation) + | Some pat -> "," ^ print_pattern pat ~pos ~indentation) ^ ")" - | Ppat_variant (label, maybePat) -> + | Ppat_variant (label, maybe_pat) -> "Ppat_variant(" ^ str label - ^ (match maybePat with + ^ (match maybe_pat with | None -> "" - | Some pat -> "," ^ printPattern pat ~pos ~indentation) + | Some pat -> "," ^ print_pattern pat ~pos ~indentation) ^ ")" | Ppat_record (fields, _) -> "Ppat_record(\n" - ^ addIndentation (indentation + 1) + ^ add_indentation (indentation + 1) ^ "fields:\n" ^ (Ext_list.map fields (fun {lid; x = pat} -> - addIndentation (indentation + 2) - ^ (lid |> printLocDenominatorLoc ~pos) - ^ (Utils.flattenLongIdent lid.txt |> ident |> str) + add_indentation (indentation + 2) + ^ (lid |> print_loc_denominator_loc ~pos) + ^ (Utils.flatten_long_ident lid.txt |> ident |> str) ^ ": " - ^ printPattern pat ~pos ~indentation:(indentation + 2)) + ^ print_pattern pat ~pos ~indentation:(indentation + 2)) |> String.concat "\n") - ^ "\n" ^ addIndentation indentation ^ ")" + ^ "\n" ^ add_indentation indentation ^ ")" | Ppat_tuple patterns -> "Ppat_tuple(\n" ^ (patterns |> List.map (fun pattern -> - addIndentation (indentation + 2) - ^ (pattern |> printPattern ~pos ~indentation:(indentation + 2))) + add_indentation (indentation + 2) + ^ (pattern |> print_pattern ~pos ~indentation:(indentation + 2))) |> String.concat ",\n") - ^ "\n" ^ addIndentation indentation ^ ")" + ^ "\n" ^ add_indentation 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) + ^ 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 printCase case ~pos ~indentation ~caseNum = - addIndentation indentation - ^ Printf.sprintf "case %i:\n" caseNum - ^ addIndentation (indentation + 1) +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 |> printLocDenominator ~pos) + ^ (case.Parsetree.pc_lhs.ppat_loc |> print_loc_denominator ~pos) ^ ":\n" - ^ addIndentation (indentation + 2) - ^ printPattern case.Parsetree.pc_lhs ~pos ~indentation + ^ add_indentation (indentation + 2) + ^ print_pattern case.Parsetree.pc_lhs ~pos ~indentation ^ "\n" - ^ addIndentation (indentation + 1) + ^ add_indentation (indentation + 1) ^ "expr" - ^ (case.Parsetree.pc_rhs.pexp_loc |> printLocDenominator ~pos) + ^ (case.Parsetree.pc_rhs.pexp_loc |> print_loc_denominator ~pos) ^ ":\n" - ^ addIndentation (indentation + 2) - ^ printExprItem case.pc_rhs ~pos ~indentation:(indentation + 2) + ^ add_indentation (indentation + 2) + ^ print_expr_item case.pc_rhs ~pos ~indentation:(indentation + 2) -and printExprItem expr ~pos ~indentation = - printAttributes expr.Parsetree.pexp_attributes - ^ (expr.pexp_loc |> printLocDenominator ~pos) +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" - ^ addIndentation (indentation + 1) + ^ add_indentation (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) -> + 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(" - ^ printExprItem matchExpr ~pos ~indentation:0 + ^ print_expr_item match_expr ~pos ~indentation:0 ^ ")\n" ^ (cases - |> List.mapi (fun caseNum case -> - printCase case ~pos ~caseNum:(caseNum + 1) + |> 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.flattenLongIdent txt |> SharedTypes.ident) + "Pexp_ident:" ^ (Utils.flatten_long_ident txt |> SharedTypes.ident) | Pexp_break -> "Pexp_break" | Pexp_continue -> "Pexp_continue" | Pexp_apply {funct = expr; args} -> - let printLabel labelled ~pos = + let print_label labelled ~pos = match labelled with | None -> "" | Some labelled -> - printLocDenominatorPos pos ~posStart:labelled.posStart - ~posEnd:labelled.posEnd + 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 = extractExpApplyArgs ~args in + let args = extract_exp_apply_args ~args in "Pexp_apply(\n" - ^ addIndentation (indentation + 1) + ^ add_indentation (indentation + 1) ^ "expr:\n" - ^ addIndentation (indentation + 2) - ^ printExprItem expr ~pos ~indentation:(indentation + 2) + ^ add_indentation (indentation + 2) + ^ print_expr_item expr ~pos ~indentation:(indentation + 2) ^ "\n" - ^ addIndentation (indentation + 1) + ^ add_indentation (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)) + 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" ^ addIndentation indentation ^ ")" - | Pexp_constant constant -> "Pexp_constant(" ^ printConstant constant ^ ")" - | Pexp_construct (({txt} as loc), maybeExpr) -> + ^ "\n" ^ add_indentation indentation ^ ")" + | Pexp_constant constant -> "Pexp_constant(" ^ print_constant constant ^ ")" + | Pexp_construct (({txt} as loc), maybe_expr) -> "Pexp_construct(" - ^ (loc |> printLocDenominatorLoc ~pos) - ^ (Utils.flattenLongIdent txt |> ident |> str) - ^ (match maybeExpr with + ^ (loc |> print_loc_denominator_loc ~pos) + ^ (Utils.flatten_long_ident txt |> ident |> str) + ^ (match maybe_expr with | None -> "" - | Some expr -> ", " ^ printExprItem expr ~pos ~indentation) + | Some expr -> ", " ^ print_expr_item expr ~pos ~indentation) ^ ")" - | Pexp_variant (label, maybeExpr) -> + | Pexp_variant (label, maybe_expr) -> "Pexp_variant(" ^ str label - ^ (match maybeExpr with + ^ (match maybe_expr with | None -> "" - | Some expr -> "," ^ printExprItem expr ~pos ~indentation) + | Some expr -> "," ^ print_expr_item expr ~pos ~indentation) ^ ")" - | Pexp_fun {arg_label = arg; lhs = pattern; rhs = nextExpr} -> + | Pexp_fun {arg_label = arg; lhs = pattern; rhs = next_expr} -> "Pexp_fun(\n" - ^ addIndentation (indentation + 1) + ^ add_indentation (indentation + 1) ^ "arg: " ^ (match arg with | Nolabel -> "Nolabel" | Labelled {txt = name} -> "Labelled(" ^ name ^ ")" | Optional {txt = name} -> "Optional(" ^ name ^ ")") ^ ",\n" - ^ addIndentation (indentation + 2) + ^ add_indentation (indentation + 2) ^ "pattern: " - ^ printPattern pattern ~pos ~indentation:(indentation + 2) + ^ print_pattern pattern ~pos ~indentation:(indentation + 2) ^ ",\n" - ^ addIndentation (indentation + 1) + ^ add_indentation (indentation + 1) ^ "next expr:\n" - ^ addIndentation (indentation + 2) - ^ printExprItem nextExpr ~pos ~indentation:(indentation + 2) - ^ "\n" ^ addIndentation indentation ^ ")" + ^ 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 |> printLocDenominatorLoc ~pos) ^ txt ^ ")" + "Pexp_extension(%" ^ (loc |> print_loc_denominator_loc ~pos) ^ txt ^ ")" | Pexp_assert expr -> - "Pexp_assert(" ^ printExprItem expr ~pos ~indentation ^ ")" + "Pexp_assert(" ^ print_expr_item expr ~pos ~indentation ^ ")" | Pexp_field (exp, loc) -> "Pexp_field(" - ^ (loc |> printLocDenominatorLoc ~pos) - ^ printExprItem exp ~pos ~indentation + ^ (loc |> print_loc_denominator_loc ~pos) + ^ print_expr_item exp ~pos ~indentation ^ ")" | Pexp_record (fields, _) -> "Pexp_record(\n" - ^ addIndentation (indentation + 1) + ^ add_indentation (indentation + 1) ^ "fields:\n" ^ (Ext_list.map fields (fun {lid; x = expr} -> - addIndentation (indentation + 2) - ^ (lid |> printLocDenominatorLoc ~pos) - ^ (Utils.flattenLongIdent lid.txt |> ident |> str) + add_indentation (indentation + 2) + ^ (lid |> print_loc_denominator_loc ~pos) + ^ (Utils.flatten_long_ident lid.txt |> ident |> str) ^ ": " - ^ printExprItem expr ~pos ~indentation:(indentation + 2)) + ^ print_expr_item expr ~pos ~indentation:(indentation + 2)) |> String.concat "\n") - ^ "\n" ^ addIndentation indentation ^ ")" + ^ "\n" ^ add_indentation indentation ^ ")" | Pexp_tuple exprs -> "Pexp_tuple(\n" ^ (exprs |> List.map (fun expr -> - addIndentation (indentation + 2) - ^ (expr |> printExprItem ~pos ~indentation:(indentation + 2))) + add_indentation (indentation + 2) + ^ (expr |> print_expr_item ~pos ~indentation:(indentation + 2))) |> String.concat ",\n") - ^ "\n" ^ addIndentation indentation ^ ")" - | v -> Printf.sprintf "" (Utils.identifyPexp v) + ^ "\n" ^ add_indentation indentation ^ ")" + | v -> Printf.sprintf "" (Utils.identify_pexp v) -let printValueBinding value ~pos ~indentation = - printAttributes value.Parsetree.pvb_attributes +let print_value_binding value ~pos ~indentation = + print_attributes 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) + ^ 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 printStructItem structItem ~pos ~source = - match structItem.Parsetree.pstr_loc |> CursorPosition.classifyLoc ~pos with +let print_struct_item struct_item ~pos ~source = + match struct_item.Parsetree.pstr_loc |> CursorPosition.classify_loc ~pos with | HasCursor -> ( - let startOffset = - match Pos.positionToOffset source (structItem.pstr_loc |> Loc.start) with + let start_offset = + match Pos.position_to_offset source (struct_item.pstr_loc |> Loc.start) with | None -> 0 | Some offset -> offset in - let endOffset = + 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 = structItem.pstr_loc |> Loc.end_ in - match Pos.positionToOffset source (line + 2, 0) with + 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 startOffset (endOffset - startOffset) + ^ String.sub source start_offset (end_offset - start_offset) ^ "\n") - ^ printLocDenominator structItem.pstr_loc ~pos + ^ print_loc_denominator struct_item.pstr_loc ~pos ^ - match structItem.pstr_desc with + match struct_item.pstr_desc with | Pstr_eval (expr, _attributes) -> - "Pstr_eval(\n" ^ printExprItem expr ~pos ~indentation:1 ^ "\n)" - | Pstr_value (recFlag, values) -> + "Pstr_eval(\n" ^ print_expr_item expr ~pos ~indentation:1 ^ "\n)" + | Pstr_value (rec_flag, values) -> "Pstr_value(\n" - ^ (match recFlag with + ^ (match rec_flag with | Recursive -> " rec,\n" | Nonrecursive -> "") ^ (values |> List.map (fun value -> - addIndentation 1 ^ printValueBinding value ~pos ~indentation:1) + add_indentation 1 ^ print_value_binding value ~pos ~indentation:1) |> String.concat ",\n") ^ "\n)" | _ -> "") | _ -> "" -let dump ~currentFile ~pos = +let dump ~current_file ~pos = let {Res_driver.parsetree = structure; source} = Res_driver.parsing_engine.parse_implementation ~for_printer:true - ~filename:currentFile + ~filename:current_file in print_endline (structure - |> List.map (fun structItem -> printStructItem structItem ~pos ~source) + |> 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 index aafe201253..2c71d6a736 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/FindFiles.ml b/analysis/src/FindFiles.ml index 9457640f95..423afb37b2 100644 --- a/analysis/src/FindFiles.ml +++ b/analysis/src/FindFiles.ml @@ -1,12 +1,12 @@ -let ifDebug debug name fn v = if debug then Log.log (name ^ ": " ^ fn v) +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 getSourceDirectories ~includeDev ~baseDir config = - let rec handleItem current item = +let get_source_directories ~include_dev ~base_dir config = + let rec handle_item current item = match item with - | `List contents -> List.map (handleItem current) contents |> List.concat + | `List contents -> List.map (handle_item current) contents |> List.concat | `String text -> [current /+ text] | `Assoc _ -> ( let dir = @@ -15,7 +15,7 @@ let getSourceDirectories ~includeDev ~baseDir config = |> Option.value ~default:"Must specify directory" in let typ = - if includeDev then "lib" + if include_dev then "lib" else item |> YojsonHelpers.get "type" |> bind Yojson.Safe.Util.to_string_option @@ -27,32 +27,32 @@ let getSourceDirectories ~includeDev ~baseDir config = match item |> YojsonHelpers.get "subdirs" with | None | Some (`Bool false) -> [current /+ dir] | Some (`Bool true) -> - Files.collectDirs (baseDir /+ current /+ dir) + Files.collect_dirs (base_dir /+ current /+ dir) |> List.filter (fun name -> name <> Filename.current_dir_name) - |> List.map (Files.relpath baseDir) - | Some item -> (current /+ dir) :: handleItem (current /+ dir) item) + |> List.map (Files.relpath base_dir) + | Some item -> (current /+ dir) :: handle_item (current /+ dir) item) | _ -> failwith "Invalid subdirs entry" in match config |> YojsonHelpers.get "sources" with | None -> [] - | Some item -> handleItem "" item + | Some item -> handle_item "" item -let isCompiledFile name = +let is_compiled_file name = Filename.check_suffix name ".cmt" || Filename.check_suffix name ".cmti" -let isImplementation name = +let is_implementation name = Filename.check_suffix name ".re" || Filename.check_suffix name ".res" || Filename.check_suffix name ".ml" -let isInterface name = +let is_interface name = Filename.check_suffix name ".rei" || Filename.check_suffix name ".resi" || Filename.check_suffix name ".mli" -let isSourceFile name = isImplementation name || isInterface name +let is_source_file name = is_implementation name || is_interface name -let compiledNameSpace name = +let compiled_name_space name = String.split_on_char '-' name |> List.map String.capitalize_ascii |> String.concat "" @@ -60,17 +60,17 @@ let compiledNameSpace name = |> String.split_on_char '_' |> String.concat "" -let compiledBaseName ~namespace name = +let compiled_base_name ~namespace name = Filename.chop_extension name ^ match namespace with | None -> "" - | Some n -> "-" ^ compiledNameSpace n + | Some n -> "-" ^ compiled_name_space n -let getName x = +let get_name x = Filename.basename x |> Filename.chop_extension |> String.capitalize_ascii -let filterDuplicates cmts = +let filter_duplicates cmts = (* Remove .cmt's that have .cmti's *) let intfs = Hashtbl.create 100 in cmts @@ -79,41 +79,41 @@ let filterDuplicates cmts = Filename.check_suffix path ".rei" || Filename.check_suffix path ".mli" || Filename.check_suffix path ".cmti" - then Hashtbl.add intfs (getName path) true); + 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 (getName path))) + && Hashtbl.mem intfs (get_name path))) -let nameSpaceToName n = +let name_space_to_name n = n |> Str.split (Str.regexp "[-/@]") |> List.map String.capitalize_ascii |> String.concat "" -let getNamespace config = +let get_namespace config = let ns = config |> YojsonHelpers.get "namespace" in - let fromString = ns |> bind Yojson.Safe.Util.to_string_option in - let isNamespaced = + let from_string = ns |> bind Yojson.Safe.Util.to_string_option in + let is_namespaced = ns |> bind Yojson.Safe.Util.to_bool_option - |> Option.value ~default:(fromString |> Option.is_some) + |> Option.value ~default:(from_string |> Option.is_some) in let either x y = if x = None then y else x in - if isNamespaced then - let fromName = + if is_namespaced then + let from_name = config |> YojsonHelpers.get "name" |> bind Yojson.Safe.Util.to_string_option in - either fromString fromName |> Option.map nameSpaceToName + either from_string from_name |> Option.map name_space_to_name else None module StringSet = Set.Make (String) -let getPublic config = +let get_public config = let public = config |> YojsonHelpers.get "public" in match public with | None -> None @@ -126,36 +126,36 @@ let getPublic config = |> List.filter_map Yojson.Safe.Util.to_string_option |> 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 +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.filterMap (fun path -> - let modName = getName path in + |> Utils.filter_map (fun path -> + let mod_name = get_name path in let cmt = directory /+ path in - let resOpt = + let res_opt = Utils.find (fun name -> - if getName name = modName then Some (directory /+ name) else None) + if get_name name = mod_name then Some (directory /+ name) else None) sources in - match resOpt with + match res_opt with | None -> None - | Some res -> Some (modName, SharedTypes.Impl {cmt; res})) + | Some res -> Some (mod_name, 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 +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.readFile sourceDirsFile with + match Files.read_file source_dirs_file with | None -> [] | Some text -> ( match YojsonHelpers.from_string_opt text with @@ -165,72 +165,72 @@ let readSourcedirsPackageRoots base = json |> YojsonHelpers.get "pkgs" |> bind YojsonHelpers.to_list_opt with | None -> [] - | Some packages -> packages |> List.filter_map readPackageEntry)) + | Some packages -> packages |> List.filter_map read_package_entry)) -let findPackageRoot ~base ~sourcedirsPackageRoots name = - match List.assoc_opt name sourcedirsPackageRoots with +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 - | _ -> ModuleResolution.resolveNodeModulePath ~startPath:base name + | _ -> ModuleResolution.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 findProjectFiles ~public ~namespace ~path ~sourceDirectories ~libBs = +let find_project_files ~public ~namespace ~path ~source_directories ~lib_bs = let dirs = - sourceDirectories |> List.map (Filename.concat path) |> StringSet.of_list + source_directories |> 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.map (fun name -> Files.collect ~max_depth:2 name is_source_file) |> List.concat |> StringSet.of_list in dirs - |> ifDebug true "Source directories" (fun s -> - s |> StringSet.elements |> List.map Utils.dumpPath |> String.concat " "); + |> if_debug true "Source directories" (fun s -> + s |> StringSet.elements |> List.map Utils.dump_path |> String.concat " "); files - |> ifDebug true "Source files" (fun s -> - s |> StringSet.elements |> List.map Utils.dumpPath |> String.concat " "); + |> if_debug true "Source files" (fun s -> + s |> StringSet.elements |> List.map Utils.dump_path |> String.concat " "); let interfaces = Hashtbl.create 100 in files |> StringSet.iter (fun path -> - if isInterface path then Hashtbl.replace interfaces (getName path) path); + if is_interface path then Hashtbl.replace interfaces (get_name 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 + |> 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 = (libBs /+ base) ^ ".cmti" in - let cmt = (libBs /+ base) ^ ".cmt" in + 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 - ( moduleName, + ( module_name, 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)); + Log.log ("Bad source file (no cmt/cmti/cmi) " ^ (lib_bs /+ base)); None) | None -> - let cmt = (libBs /+ base) ^ ".cmt" in - if Files.exists cmt then Some (moduleName, Impl {cmt; res = file}) + 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) " ^ (libBs /+ base)); + 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 originalName = name in + let original_name = name in let name = match namespace with | None -> name @@ -238,19 +238,19 @@ let findProjectFiles ~public ~namespace ~path ~sourceDirectories ~libBs = in match public with | Some public -> - if public |> StringSet.mem originalName then Some (name, paths) + if public |> StringSet.mem original_name 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 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 findDependencyFiles base config = +let find_dependency_files base config = let deps = match ( config @@ -264,7 +264,7 @@ let findDependencyFiles base config = | Some deps, None | _, Some deps -> deps |> List.filter_map Yojson.Safe.Util.to_string_option in - let devDeps = + let dev_deps = match ( config |> YojsonHelpers.get "dev-dependencies" @@ -274,51 +274,51 @@ let findDependencyFiles base config = |> bind YojsonHelpers.to_list_opt ) with | None, None -> [] - | Some devDeps, None | _, Some devDeps -> - devDeps |> List.filter_map (fun x -> Some (Yojson.Safe.Util.to_string x)) + | Some dev_deps, None | _, Some dev_deps -> + dev_deps |> List.filter_map (fun x -> Some (Yojson.Safe.Util.to_string x)) in - let deps = deps @ devDeps in + let deps = deps @ dev_deps in Log.log ("Dependencies: " ^ String.concat " " deps); - let sourcedirsPackageRoots = readSourcedirsPackageRoots base in - let depFiles = + let sourcedirs_package_roots = read_sourcedirs_package_roots base in + let dep_files = deps |> List.map (fun name -> let result = bind (fun path -> - let rescriptJsonPath = path /+ "rescript.json" in + let rescript_json_path = path /+ "rescript.json" in - let parseText text = + let parse_text text = match YojsonHelpers.from_string_opt text with | Some inner -> ( - let namespace = getNamespace inner in - let sourceDirectories = - getSourceDirectories ~includeDev:false ~baseDir:path + let namespace = get_namespace inner in + let source_directories = + get_source_directories ~include_dev:false ~base_dir:path inner in - match BuildSystem.getLibBs path with + match BuildSystem.get_lib_bs path with | None -> None - | Some libBs -> - let compiledDirectories = - sourceDirectories |> List.map (Filename.concat libBs) + | Some lib_bs -> + let compiled_directories = + source_directories |> List.map (Filename.concat lib_bs) in - let compiledDirectories = + let compiled_directories = match namespace with - | None -> compiledDirectories - | Some _ -> libBs :: compiledDirectories + | None -> compiled_directories + | Some _ -> lib_bs :: compiled_directories in - let projectFiles = - findProjectFiles ~public:(getPublic inner) ~namespace - ~path ~sourceDirectories ~libBs + let project_files = + find_project_files ~public:(get_public inner) ~namespace + ~path ~source_directories ~lib_bs in - Some (compiledDirectories, projectFiles)) + Some (compiled_directories, project_files)) | None -> None in - match Files.readFile rescriptJsonPath with - | Some text -> parseText text + match Files.read_file rescript_json_path with + | Some text -> parse_text text | None -> None) - (findPackageRoot ~base ~sourcedirsPackageRoots name) + (find_package_root ~base ~sourcedirs_package_roots name) in match result with @@ -327,12 +327,12 @@ let findDependencyFiles base config = Log.log ("Skipping nonexistent dependency: " ^ name); ([], [])) in - match BuildSystem.getStdlib base with + match BuildSystem.get_stdlib base with | None -> None - | Some stdlibDirectory -> - let compiledDirectories, projectFiles = - let files, directories = List.split depFiles in + | Some stdlib_directory -> + let compiled_directories, project_files = + let files, directories = List.split dep_files in (List.concat files, List.concat directories) in - let allFiles = projectFiles @ collectFiles stdlibDirectory in - Some (compiledDirectories, allFiles) + 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 index d5f1083807..49278fed75 100644 --- a/analysis/src/Hint.ml +++ b/analysis/src/Hint.ml @@ -1,11 +1,11 @@ open SharedTypes -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,25 +83,25 @@ 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 - ~paddingRight:false ~label:(`String label) () + Lsp.Types.InlayHint.create ~position ~kind ~padding_left:true + ~padding_right:false ~label:(`String label) () in match maxlen with | Some value -> @@ -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 index 4f1a98da27..1193de78ec 100644 --- a/analysis/src/Hover.ml +++ b/analysis/src/Hover.ml @@ -2,25 +2,25 @@ open SharedTypes module StringSet = Set.Make (String) -let showModuleTopLevel ~docstring ~isType ~name (topLevel : Module.item list) = +let show_module_top_level ~docstring ~is_type ~name (top_level : Module.item list) = let contents = - topLevel + top_level |> List.map (fun item -> match item.Module.kind with (* TODO pretty print module contents *) - | Type ({decl}, recStatus) -> - " " ^ (decl |> Shared.declToString ~recStatus item.name) + | Type ({decl}, rec_status) -> + " " ^ (decl |> Shared.decl_to_string ~rec_status item.name) | Module _ -> " module " ^ item.name | Value typ -> - " let " ^ item.name ^ ": " ^ (typ |> Shared.typeToString)) + " let " ^ item.name ^ ": " ^ (typ |> Shared.type_to_string)) (* TODO indent *) |> String.concat "\n" in - let name = Utils.cutAfterDash name in + let name = Utils.cut_after_dash name in let full = - Markdown.codeBlock + Markdown.code_block ("module " - ^ (if isType then "type " ^ name ^ " = " else name ^ ": ") + ^ (if is_type then "type " ^ name ^ " = " else name ^ ": ") ^ "{" ^ "\n" ^ contents ^ "\n}") in let doc = @@ -33,28 +33,28 @@ let showModuleTopLevel ~docstring ~isType ~name (topLevel : Module.item list) = in Some (doc ^ full) -let rec showModule ~docstring ~(file : File.t) ~package ~name +let rec show_module ~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 + 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 - showModuleTopLevel ~docstring ~isType ~name items - | Some ({item = Constraint (_moduleItem, moduleTypeItem)} as declared) -> + show_module_top_level ~docstring ~is_type ~name items + | Some ({item = Constraint (_moduleItem, module_type_item)} as declared) -> (* show the interface *) - showModule ~docstring ~file ~name ~package - (Some {declared with item = moduleTypeItem}) + show_module ~docstring ~file ~name ~package + (Some {declared with item = module_type_item}) | Some ({item = Ident path} as declared) -> ( - match References.resolveModuleReference ~file ~package declared with + match References.resolve_module_reference ~file ~package declared with | None -> Some ("Unable to resolve module reference " ^ Path.name path) - | Some (_, declared) -> showModule ~docstring ~file ~name ~package declared) + | Some (_, declared) -> show_module ~docstring ~file ~name ~package declared) -type extractedType = { +type extracted_type = { name: string; path: Path.t; decl: Types.type_declaration; @@ -62,225 +62,225 @@ type extractedType = { loc: Warnings.loc; } -let findRelevantTypesFromType ~file ~package typ = +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 = QueryEnv.fromFile file in - let envToSearch, typesToSearch = - match typ |> Shared.digConstructor with + let env = QueryEnv.from_file file in + let env_to_search, types_to_search = + match typ |> Shared.dig_constructor with | Some path -> ( - let labelDeclarationsTypes lds = + let label_declarations_types lds = lds |> List.map (fun (ld : Types.label_declaration) -> ld.ld_type) in - match References.digConstructor ~env ~package path with + 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 |> labelDeclarationsTypes)) + | Type_record (lds, _) -> (env1, typ :: (lds |> label_declarations_types)) | Type_variant cds -> ( env1, cds |> List.map (fun (cd : Types.constructor_declaration) -> - let fromArgs = + let from_args = match cd.cd_args with | Cstr_tuple ts -> ts - | Cstr_record lds -> lds |> labelDeclarationsTypes + | Cstr_record lds -> lds |> label_declarations_types in typ :: (match cd.cd_res with - | None -> fromArgs - | Some t -> t :: fromArgs)) + | None -> from_args + | Some t -> t :: from_args)) |> List.flatten ) | _ -> (env, [typ]))) | None -> (env, [typ]) in - let fromConstructorPath ~env path = - match References.digConstructor ~env ~package path with + let from_constructor_path ~env path = + match References.dig_constructor ~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} + | 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.findTypeConstructors typesToSearch in - constructors |> List.filter_map (fromConstructorPath ~env:envToSearch) + let constructors = Shared.find_type_constructors types_to_search in + constructors |> List.filter_map (from_constructor_path ~env:env_to_search) -let expandTypes ~file ~package ~supportsMarkdownLinks typ = - match findRelevantTypesFromType typ ~file ~package with +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.codeBlock + Markdown.code_block (decl - |> Shared.declToString ~printNameAsIs:true - (SharedTypes.pathIdentToString path)); + |> Shared.decl_to_string ~print_name_as_is:true + (SharedTypes.path_ident_to_string 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 "." + let types_seen = ref StringSet.empty in + let type_id ~(env : QueryEnv.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 typeId = typeId ~env ~name in - if StringSet.mem typeId !typesSeen then false + let type_id = type_id ~env ~name in + if StringSet.mem type_id !types_seen then false else ( - typesSeen := StringSet.add typeId !typesSeen; + types_seen := StringSet.add type_id !types_seen; true)) |> List.map (fun {decl; env; loc; path} -> - let linkToTypeDefinitionStr = + let link_to_type_definition_str = if - supportsMarkdownLinks + supports_markdown_links && not (Res_parsetree_viewer .has_inline_record_definition_attribute decl.type_attributes) - then Markdown.goToDefinitionText ~env ~pos:loc.Warnings.loc_start + then Markdown.go_to_definition_text ~env ~pos:loc.Warnings.loc_start else "" in Markdown.divider - ^ (if supportsMarkdownLinks then Markdown.spacing else "") - ^ Markdown.codeBlock + ^ (if supports_markdown_links then Markdown.spacing else "") + ^ Markdown.code_block (decl - |> Shared.declToString ~printNameAsIs:true - (SharedTypes.pathIdentToString path)) - ^ linkToTypeDefinitionStr ^ "\n"), + |> Shared.decl_to_string ~print_name_as_is:true + (SharedTypes.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 hoverWithExpandedTypes ~file ~package ~supportsMarkdownLinks ?docstring +let hover_with_expanded_types ~file ~package ~supports_markdown_links ?docstring ?constructor typ = - let expandedTypes, expansionType = - expandTypes ~file ~package ~supportsMarkdownLinks typ + let expanded_types, expansion_type = + expand_types ~file ~package ~supports_markdown_links typ in - match expansionType with + match expansion_type with | `Default -> - let typeString = Shared.typeToString typ in - let typeString = + let type_string = Shared.type_to_string typ in + let type_string = match constructor with | Some constructor -> - typeString ^ "\n" ^ CompletionBackEnd.showConstructor constructor - | None -> typeString + type_string ^ "\n" ^ CompletionBackEnd.show_constructor constructor + | None -> type_string in - let typeString = + let type_string = match docstring with - | Some [] | None -> Markdown.codeBlock typeString + | Some [] | None -> Markdown.code_block type_string | Some docstring -> - Markdown.codeBlock typeString + Markdown.code_block type_string ^ Markdown.divider ^ (docstring |> String.concat "\n") in - typeString :: expandedTypes |> String.concat "\n" - | `InlineType -> expandedTypes |> String.concat "\n" + 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 getHoverViaCompletions ~debug ~source ~kindFile ~pos ~forHover - ~supportsMarkdownLinks ~full = +let get_hover_via_completions ~debug ~source ~kind_file ~pos ~for_hover + ~supports_markdown_links ~full = match - Completions.getCompletions ~debug ~source ~kindFile ~pos ~forHover ~full + Completions.get_completions ~debug ~source ~kind_file ~pos ~for_hover ~full with | None -> None | Some (completions, ({file; package} as full), scope) -> ( - let rawOpens = Scope.getRawOpens scope in + let raw_opens = Scope.get_raw_opens scope in match completions with - | {kind = Label typString; docstring} :: _ -> + | {kind = Label typ_string; docstring} :: _ -> let parts = docstring - @ if typString = "" then [] else [Markdown.codeBlock typString] + @ if typ_string = "" then [] else [Markdown.code_block typ_string] in Some (String.concat "\n\n" parts) | {kind = Field _; env; docstring} :: _ -> ( - let opens = CompletionBackEnd.getOpens ~debug ~rawOpens ~package ~env in + let opens = CompletionBackEnd.get_opens ~debug ~raw_opens ~package ~env in match - CompletionBackEnd.completionsGetTypeEnv2 ~debug ~full ~rawOpens ~opens + CompletionBackEnd.completions_get_type_env2 ~debug ~full ~raw_opens ~opens ~pos completions with | Some (typ, _env) -> - let typeString = - hoverWithExpandedTypes ~file ~package ~docstring - ~supportsMarkdownLinks typ + let type_string = + hover_with_expanded_types ~file ~package ~docstring + ~supports_markdown_links typ in - Some typeString + Some type_string | None -> None) | {env} :: _ -> ( - let opens = CompletionBackEnd.getOpens ~debug ~rawOpens ~package ~env in + let opens = CompletionBackEnd.get_opens ~debug ~raw_opens ~package ~env in match - CompletionBackEnd.completionsGetTypeEnv2 ~debug ~full ~rawOpens ~opens + CompletionBackEnd.completions_get_type_env2 ~debug ~full ~raw_opens ~opens ~pos completions with | Some (typ, _env) -> - let typeString = - hoverWithExpandedTypes ~file ~package ~supportsMarkdownLinks typ + let type_string = + hover_with_expanded_types ~file ~package ~supports_markdown_links typ in - Some typeString + Some type_string | None -> None) | _ -> None) -let newHover ~full:{file; package} ~supportsMarkdownLinks locItem = - match locItem.locType with +let new_hover ~full:{file; package} ~supports_markdown_links loc_item = + match loc_item.loc_type with | TypeDefinition (name, decl, _stamp) -> ( - let typeDef = Markdown.codeBlock (Shared.declToString name decl) in + let type_def = Markdown.code_block (Shared.decl_to_string name decl) in match decl.type_manifest with - | None -> Some typeDef + | None -> Some type_def | Some typ -> ( - let expandedTypes, expansionType = - expandTypes ~file ~package ~supportsMarkdownLinks typ + let expanded_types, expansion_type = + expand_types ~file ~package ~supports_markdown_links typ in - match expansionType with - | `Default -> Some (typeDef :: expandedTypes |> String.concat "\n") - | `InlineType -> Some (expandedTypes |> String.concat "\n"))) + 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.findModule file.stamps stamp with + match Stamps.find_module file.stamps stamp with | None -> None | Some md -> ( - match References.resolveModuleReference ~file ~package md with + 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.moduleName, file.structure.docstring) + | None -> (file.module_name, file.structure.docstring) in - showModule ~docstring ~name ~file declared ~package)) - | LModule (GlobalReference (moduleName, path, tip)) -> ( - match ProcessCmt.fileForModule ~package moduleName with + show_module ~docstring ~name ~file declared ~package)) + | LModule (GlobalReference (module_name, path, tip)) -> ( + match ProcessCmt.file_for_module ~package module_name with | None -> None | Some file -> ( - let env = QueryEnv.fromFile file in - match References.exportedForTip ~env ~path ~package ~tip with + let env = QueryEnv.from_file file in + match References.exported_for_tip ~env ~path ~package ~tip with | None -> None | Some (_env, _name, stamp) -> ( - match Stamps.findModule file.stamps stamp with + match Stamps.find_module file.stamps stamp with | None -> None | Some md -> ( - match References.resolveModuleReference ~file ~package md with + 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.moduleName, file.structure.docstring) + | None -> (file.module_name, file.structure.docstring) in - showModule ~docstring ~name ~file ~package declared)))) + show_module ~docstring ~name ~file ~package declared)))) | LModule NotFound -> None | TopLevelModule name -> ( - match ProcessCmt.fileForModule ~package name with + match ProcessCmt.file_for_module ~package name with | None -> None | Some file -> - showModule ~docstring:file.structure.docstring ~name:file.moduleName ~file + show_module ~docstring:file.structure.docstring ~name:file.module_name ~file ~package None) | Typed (_, _, Definition (_, (Field _ | Constructor _))) -> None | Constant t -> Some - (Markdown.codeBlock + (Markdown.code_block (match t with | Const_int _ -> "int" | Const_char _ -> "char" @@ -289,29 +289,29 @@ let newHover ~full:{file; package} ~supportsMarkdownLinks locItem = | Const_int32 _ -> "int32" | Const_int64 _ -> "int64" | Const_bigint _ -> "bigint")) - | Typed (_, t, locKind) -> ( - let fromType ?docstring ?constructor typ = - hoverWithExpandedTypes ~file ~package ~supportsMarkdownLinks ?docstring + | 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 = QueryEnv.fromFile file in - match ResolvePath.resolveModuleFromCompilerPath ~env ~package path with - | None -> Some (fromType t) - | Some (envForModule, Some declared) -> + let env = QueryEnv.from_file file in + match ResolvePath.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 - showModule ~docstring:declared.docstring ~name ~file:envForModule.file + show_module ~docstring:declared.docstring ~name ~file:env_for_module.file ~package (Some declared) - | Some (_, None) -> Some (fromType t)) + | Some (_, None) -> Some (from_type t)) | _ -> Some - (match References.definedForLoc ~file ~package locKind with - | None -> t |> fromType + (match References.defined_for_loc ~file ~package loc_kind with + | None -> t |> from_type | Some (docstring, res) -> ( match res with - | `Declared | `Field -> t |> fromType ~docstring + | `Declared | `Field -> t |> from_type ~docstring | `Constructor constructor -> - t |> fromType ~docstring:constructor.docstring ~constructor))) + t |> from_type ~docstring:constructor.docstring ~constructor))) diff --git a/analysis/src/JsxHacks.ml b/analysis/src/JsxHacks.ml index 81ffe200a8..70db806dbf 100644 --- a/analysis/src/JsxHacks.ml +++ b/analysis/src/JsxHacks.ml @@ -1,5 +1,5 @@ -let pathIsFragment path = Path.name path = "ReasonReact.fragment" +let path_is_fragment path = Path.name path = "ReasonReact.fragment" -let primitiveIsFragment (vd : Typedtree.value_description) = +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 index 6febb9a626..abb5669ed1 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/LocalTables.ml b/analysis/src/LocalTables.ml index d690d969d1..35995f0775 100644 --- a/analysis/src/LocalTables.ml +++ b/analysis/src/LocalTables.ml @@ -1,65 +1,65 @@ open SharedTypes type 'a table = (string * (int * int), 'a Declared.t) Hashtbl.t -type namesUsed = (string, unit) Hashtbl.t +type names_used = (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; + 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 () = { - 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; + 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 populateValues ~env localTables = +let populate_values ~env local_tables = env.QueryEnv.file.stamps - |> Stamps.iterValues (fun _ declared -> - Hashtbl.replace localTables.valueTable + |> Stamps.iter_values (fun _ declared -> + Hashtbl.replace local_tables.value_table (declared.name.txt, declared.name.loc |> Loc.start) declared) -let populateIncludedValues ~env localTables = +let populate_included_values ~env local_tables = env.QueryEnv.file.stamps - |> Stamps.iterValues (fun _ declared -> - match declared.modulePath with + |> Stamps.iter_values (fun _ declared -> + match declared.module_path with | ModulePath.IncludedModule (source, _) -> let path = Path.name source in let declared = {declared with item = (path, declared.item)} in - Hashtbl.replace localTables.includedValueTable + Hashtbl.replace local_tables.included_value_table (declared.name.txt, declared.name.loc |> Loc.start) declared | _ -> ()) -let populateConstructors ~env localTables = +let populate_constructors ~env local_tables = env.QueryEnv.file.stamps - |> Stamps.iterConstructors (fun _ declared -> - Hashtbl.replace localTables.constructorTable - (declared.name.txt, declared.extentLoc |> Loc.start) + |> Stamps.iter_constructors (fun _ declared -> + Hashtbl.replace local_tables.constructor_table + (declared.name.txt, declared.extent_loc |> Loc.start) declared) -let populateTypes ~env localTables = +let populate_types ~env local_tables = env.QueryEnv.file.stamps - |> Stamps.iterTypes (fun _ declared -> - Hashtbl.replace localTables.typesTable + |> Stamps.iter_types (fun _ declared -> + Hashtbl.replace local_tables.types_table (declared.name.txt, declared.name.loc |> Loc.start) declared) -let populateModules ~env localTables = +let populate_modules ~env local_tables = env.QueryEnv.file.stamps - |> Stamps.iterModules (fun _ declared -> - Hashtbl.replace localTables.modulesTable - (declared.name.txt, declared.extentLoc |> Loc.start) + |> 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/Markdown.ml b/analysis/src/Markdown.ml index 16d7f0c7a2..ca1dc08336 100644 --- a/analysis/src/Markdown.ml +++ b/analysis/src/Markdown.ml @@ -1,23 +1,23 @@ let spacing = "\n```\n \n```\n" -let codeBlock code = Printf.sprintf "```rescript\n%s\n```" code +let code_block code = Printf.sprintf "```rescript\n%s\n```" code let divider = "\n---\n" -type link = {startPos: Lsp.Types.Position.t; file: string; label: string} +type link = {start_pos: 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 link_to_command_args link = + Printf.sprintf "[\"%s\",%i,%i]" link.file link.start_pos.line + link.start_pos.character -let makeGotoCommand link = +let make_goto_command link = Printf.sprintf "[%s](command:rescript-vscode.go_to_location?%s)" link.label - (Uri.encodeURIComponent (linkToCommandArgs link)) + (Uri.encode_u_r_i_component (link_to_command_args link)) -let goToDefinitionText ~env ~pos = - let startLine, startCol = Pos.ofLexing pos in +let go_to_definition_text ~env ~pos = + let start_line, start_col = Pos.of_lexing pos in "\nGo to: " - ^ makeGotoCommand + ^ make_goto_command { label = "Type definition"; - file = Uri.toString env.SharedTypes.QueryEnv.file.uri; - startPos = {line = startLine; character = startCol}; + file = Uri.to_string env.SharedTypes.QueryEnv.file.uri; + start_pos = {line = start_line; character = start_col}; } diff --git a/analysis/src/ModuleResolution.ml b/analysis/src/ModuleResolution.ml index 343e5381d1..622fc83227 100644 --- a/analysis/src/ModuleResolution.ml +++ b/analysis/src/ModuleResolution.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 index 5edab49e2c..36ef44d06f 100644 --- a/analysis/src/Packages.ml +++ b/analysis/src/Packages.ml @@ -1,24 +1,24 @@ 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 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 overrideRescriptVersion = ref None +let override_rescript_version = ref None -let getReScriptVersion () = - match !overrideRescriptVersion with - | Some overrideRescriptVersion -> overrideRescriptVersion +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 defaultVersion = (11, 0) in + let default_version = (11, 0) in try let value = Sys.getenv "RESCRIPT_VERSION" in let version = @@ -26,43 +26,43 @@ let getReScriptVersion () = | major :: minor :: _rest -> ( match (int_of_string_opt major, int_of_string_opt minor) with | Some major, Some minor -> (major, minor) - | _ -> defaultVersion) - | _ -> defaultVersion + | _ -> default_version) + | _ -> default_version in version - with Not_found -> defaultVersion) + with Not_found -> default_version) -let newBsPackage ~rootPath = - let rescriptJson = Filename.concat rootPath "rescript.json" in +let new_bs_package ~root_path = + let rescript_json = Filename.concat root_path "rescript.json" in - let parseRaw raw = - let libBs = - match !Cfg.isDocGenFromCompiler with - | true -> BuildSystem.getStdlib rootPath - | false -> BuildSystem.getLibBs rootPath + let parse_raw raw = + let lib_bs = + match !Cfg.is_doc_gen_from_compiler with + | true -> BuildSystem.get_stdlib root_path + | false -> BuildSystem.get_lib_bs root_path in match YojsonHelpers.from_string_opt raw with | Some config -> ( - let namespace = FindFiles.getNamespace config in - let rescriptVersion = getReScriptVersion () in + let namespace = FindFiles.get_namespace config in + let rescript_version = get_re_script_version () 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 + let generic_jsx_module = + let jsx_config = config |> YojsonHelpers.get "jsx" in + match jsx_config with + | Some jsx_config -> ( + match jsx_config |> 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 editor_config -> ( + match editor_config |> YojsonHelpers.get "autocomplete" with | Some (`Assoc map) -> map |> List.fold_left @@ -81,52 +81,52 @@ let newBsPackage ~rootPath = | _ -> Misc.StringMap.empty) | None -> Misc.StringMap.empty in - match libBs with + match lib_bs with | None -> None - | Some libBs -> - let cached = Cache.readCache (Cache.targetFileFromLibBs libBs) in - let projectFiles, dependenciesFiles, pathsForModule = + | 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.projectFiles, - cached.dependenciesFiles, - cached.pathsForModule ) + ( cached.project_files, + cached.dependencies_files, + cached.paths_for_module ) | None -> - let dependenciesFilesAndPaths = - match FindFiles.findDependencyFiles rootPath config with + let dependencies_files_and_paths = + match FindFiles.find_dependency_files root_path config with | None -> [] - | Some (_dependencyDirectories, dependenciesFilesAndPaths) -> - dependenciesFilesAndPaths + | Some (_dependencyDirectories, dependencies_files_and_paths) -> + dependencies_files_and_paths in - let sourceDirectories = - FindFiles.getSourceDirectories ~includeDev:true ~baseDir:rootPath + let source_directories = + FindFiles.get_source_directories ~include_dev:true ~base_dir:root_path config in - let projectFilesAndPaths = - FindFiles.findProjectFiles - ~public:(FindFiles.getPublic config) - ~namespace ~path:rootPath ~sourceDirectories ~libBs + let project_files_and_paths = + FindFiles.find_project_files + ~public:(FindFiles.get_public config) + ~namespace ~path:root_path ~source_directories ~lib_bs in - let pathsForModule = - makePathsForModule ~projectFilesAndPaths - ~dependenciesFilesAndPaths + let paths_for_module = + make_paths_for_module ~project_files_and_paths + ~dependencies_files_and_paths in - let projectFiles = - projectFilesAndPaths |> List.map fst |> FileSet.of_list + let project_files = + project_files_and_paths |> List.map fst |> FileSet.of_list in - let dependenciesFiles = - dependenciesFilesAndPaths |> List.map fst |> FileSet.of_list + let dependencies_files = + dependencies_files_and_paths |> List.map fst |> FileSet.of_list in - (projectFiles, dependenciesFiles, pathsForModule) + (project_files, dependencies_files, paths_for_module) 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 + let cmt = Filename.concat lib_bs namespace ^ ".cmt" in + Hashtbl.replace paths_for_module namespace (Namespace {cmt}); + let path = [FindFiles.name_space_to_name namespace] in [path] in let bind f x = Option.bind x f in @@ -172,13 +172,13 @@ let newBsPackage ~rootPath = |> List.map (fun path -> path @ ["place holder"]) in { - genericJsxModule; + generic_jsx_module; suffix; - rescriptVersion; - rootPath; - projectFiles; - dependenciesFiles; - pathsForModule; + rescript_version; + root_path; + project_files; + dependencies_files; + paths_for_module; opens; namespace; autocomplete; @@ -186,17 +186,17 @@ let newBsPackage ~rootPath = | None -> None in - match Files.readFile rescriptJson with - | Some raw -> parseRaw raw + match Files.read_file rescript_json with + | Some raw -> parse_raw raw | None -> - Log.log ("Unable to read " ^ rescriptJson); + Log.log ("Unable to read " ^ rescript_json); None -let findRoot ~uri packagesByRoot = - let path = Uri.toPath uri in +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 packagesByRoot path then Some (`Root path) + 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 @@ -205,23 +205,23 @@ let findRoot ~uri packagesByRoot = in loop (if Sys.is_directory path then path else Filename.dirname path) -let getPackage ~uri = +let get_package ~uri = let open SharedTypes in - if Hashtbl.mem state.rootForUri uri then - Some (Hashtbl.find state.packagesByRoot (Hashtbl.find state.rootForUri uri)) + 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 findRoot ~uri state.packagesByRoot with + match find_root ~uri state.packages_by_root with | None -> Log.log "No root directory found"; None - | Some (`Root rootPath) -> - Hashtbl.replace state.rootForUri uri rootPath; + | Some (`Root root_path) -> + Hashtbl.replace state.root_for_uri uri root_path; Some - (Hashtbl.find state.packagesByRoot (Hashtbl.find state.rootForUri uri)) - | Some (`Bs rootPath) -> ( - match newBsPackage ~rootPath with + (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.rootForUri uri package.rootPath; - Hashtbl.replace state.packagesByRoot package.rootPath 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/PipeCompletionUtils.ml b/analysis/src/PipeCompletionUtils.ml index f66c93e231..142fa707f3 100644 --- a/analysis/src/PipeCompletionUtils.ml +++ b/analysis/src/PipeCompletionUtils.ml @@ -1,24 +1,24 @@ -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 add_jsx_completion_items ~main_type_id ~env ~prefix ~(full : SharedTypes.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.genericJsxModule with - | None -> "React." ^ builtinNameToComplete + match full.package.generic_jsx_module with + | None -> "React." ^ builtin_name_to_complete | Some g -> - g ^ "." ^ builtinNameToComplete + g ^ "." ^ builtin_name_to_complete |> String.split_on_char '.' - |> TypeUtils.removeOpensFromCompletionPath ~rawOpens + |> TypeUtils.remove_opens_from_completion_path ~raw_opens ~package:full.package |> String.concat "." in [ SharedTypes.Completion.create name ~synthetic:true - ~includesSnippets:true ~kind:(Value typ) ~env ~sortText:"A" + ~includes_snippets:true ~kind:(Value typ) ~env ~sort_text:"A" ~docstring: [ - "Turns `" ^ builtinNameToComplete + "Turns `" ^ builtin_name_to_complete ^ "` into a JSX element so it can be used inside of JSX."; ]; ] diff --git a/analysis/src/Pos.ml b/analysis/src/Pos.ml index d739c9dae1..0418aeabf7 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/PrintType.ml index 3234d11b45..9c8f122f05 100644 --- a/analysis/src/PrintType.ml +++ b/analysis/src/PrintType.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: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/ProcessAttributes.ml index 31d994d5e0..dc93a87de0 100644 --- a/analysis/src/ProcessAttributes.ml +++ b/analysis/src/ProcessAttributes.ml @@ -1,7 +1,7 @@ open SharedTypes (* 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,44 @@ 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/ProcessCmt.ml index 96601f6e3b..17463aba24 100644 --- a/analysis/src/ProcessCmt.ml +++ b/analysis/src/ProcessCmt.ml @@ -1,26 +1,26 @@ open SharedTypes -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 + ProcessAttributes.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 ProcessAttributes.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 ProcessAttributes.find_doc_attribute ld_attributes with | None -> [] | Some docstring -> [docstring]); - deprecated = ProcessAttributes.findDeprecatedAttribute ld_attributes; + deprecated = ProcessAttributes.find_deprecated_attribute ld_attributes; } -let rec forTypeSignatureItem ~(env : SharedTypes.Env.t) ~(exported : Exported.t) +let rec for_type_signature_item ~(env : SharedTypes.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,84 @@ 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 + ProcessAttributes.find_deprecated_attribute cd_attributes; } in let declared = - ProcessAttributes.newDeclared ~item ~extent:cd_loc + ProcessAttributes.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 +196,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 +237,7 @@ let forTypeDeclaration ~env ~(exported : Exported.t) Constructor.stamp; cname; deprecated = - ProcessAttributes.findDeprecatedAttribute + ProcessAttributes.find_deprecated_attribute cd_attributes; args = (match cd_args with @@ -263,29 +263,29 @@ let forTypeDeclaration ~env ~(exported : Exported.t) docstring = (match ProcessAttributes - .findDocAttribute f.ld_attributes + .find_doc_attribute f.ld_attributes with | None -> [] | Some docstring -> [docstring]); deprecated = ProcessAttributes - .findDeprecatedAttribute + .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 + ProcessAttributes.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 +306,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 + ProcessAttributes.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 +341,102 @@ 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 = ProcessAttributes.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 : SharedTypes.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 +444,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 +455,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) + ProcessAttributes.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 +489,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 +506,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 +530,76 @@ 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 JsxHacks.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 +607,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 [] + ProcessAttributes.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 +660,136 @@ 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 [] + ProcessAttributes.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 = ProcessAttributes.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/ProcessExtra.ml index 75390cefba..8b79084bb8 100644 --- a/analysis/src/ProcessExtra.ml +++ b/analysis/src/ProcessExtra.ml @@ -1,45 +1,45 @@ open SharedTypes -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 +let add_file_reference ~extra module_name loc = + let new_locs = + match Hashtbl.find_opt extra.file_references module_name with + | Some old_locs -> LocationSet.add loc old_locs | None -> LocationSet.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,35 @@ 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 ResolvePath.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 +162,109 @@ 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 ResolvePath.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 ResolvePath.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 +272,36 @@ 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 +let rec add_for_longident ~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 + 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 +310,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 +327,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 +336,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 + ProcessAttributes.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 +352,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 +377,77 @@ 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 + ProcessAttributes.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 + ProcessAttributes.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 + ProcessAttributes.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 (JsxHacks.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 = QueryEnv.from_file file in let iterator = { Tast_iterator.default_iterator with @@ -458,5 +458,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 index a743490757..6ff4e3dcc0 100644 --- a/analysis/src/Range.ml +++ b/analysis/src/Range.ml @@ -1,6 +1,6 @@ type t = Pos.t * Pos.t -let toString ((posStart, posEnd) : t) = - Printf.sprintf "[%s->%s]" (Pos.toString posStart) (Pos.toString posEnd) +let to_string ((pos_start, pos_end) : t) = + Printf.sprintf "[%s->%s]" (Pos.to_string pos_start) (Pos.to_string pos_end) -let hasPos ~pos ((posStart, posEnd) : t) = posStart <= pos && pos < posEnd +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 index e047a2ba18..79da7726cb 100644 --- a/analysis/src/References.ml +++ b/analysis/src/References.ml @@ -1,9 +1,9 @@ open SharedTypes -let debugReferences = ref true -let maybeLog m = if !debugReferences then Log.log ("[ref] " ^ m) +let debug_references = ref true +let maybe_log m = if !debug_references then Log.log ("[ref] " ^ m) -let checkPos (line, char) +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 @@ -13,39 +13,39 @@ let checkPos (line, char) then false else true -let locItemsForPos ~extra pos = - extra.locItems |> List.filter (fun {loc; locType = _} -> checkPos pos loc) +let loc_items_for_pos ~extra pos = + extra.loc_items |> List.filter (fun {loc; loc_type = _} -> check_pos pos loc) -let lineColToCmtLoc ~pos:(line, col) = (line + 1, col) +let line_col_to_cmt_loc ~pos:(line, col) = (line + 1, col) -let getLocItem ~full ~pos ~debug = +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 = lineColToCmtLoc ~pos in - let locItems = locItemsForPos ~extra:full.extra pos 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 " - ^ (locItems |> List.map locItemToString |> String.concat "\n ")); - let nameOf li = - match li.locType with + ^ (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 locItems with - | li1 :: li2 :: li3 :: ({locType = Typed ("makeProps", _, _)} as li4) :: _ - when full.file.uri |> Uri.isInterface -> + 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" (nameOf li1) (nameOf li2) (nameOf li3); + Printf.printf "n1:%s n2:%s n3:%s\n" (name_of li1) (name_of li2) (name_of li3); Some li4 | [ - {locType = Constant _}; - ({locType = Typed ("createDOMElementVariadic", _, _)} as li2); + {loc_type = Constant _}; + ({loc_type = Typed ("createDOMElementVariadic", _, _)} as li2); ] -> log 3 "heuristic for
"; Some li2 - | {locType = Typed ("makeProps", _, _)} - :: ({locType = Typed ("make", _, _)} as li2) + | {loc_type = Typed ("makeProps", _, _)} + :: ({loc_type = Typed ("make", _, _)} as li2) :: _ -> log 4 "heuristic for within fragments: take make as makeProps does not \ @@ -53,19 +53,19 @@ let getLocItem ~full ~pos ~debug = the type is not great but jump to definition works"; Some li2 | [ - ({locType = Typed (_, _, LocalReference _)} as li1); - ({locType = Typed (_, _, _)} as 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" (nameOf li1) (nameOf li2); + if debug then Printf.printf "n1:%s n2:%s\n" (name_of li1) (name_of li2); Some li2 | [ - ({locType = Typed (_, _, LocalReference _)} as li1); - ({locType = Typed (_, _, GlobalReference ("Js_OO", ["unsafe_downgrade"], _))} + ({loc_type = Typed (_, _, LocalReference _)} as li1); + ({loc_type = Typed (_, _, GlobalReference ("Js_OO", ["unsafe_downgrade"], _))} as li2); li3; ] @@ -78,8 +78,8 @@ let getLocItem ~full ~pos ~debug = heuristic for: [Props, unsafe_downgrade, x], give loc of `x`"; Some li3 | [ - ({locType = Typed (_, _, LocalReference (_, Value))} as li1); - ({locType = Typed (_, _, Definition (_, Value))} as li2); + ({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\ @@ -87,7 +87,7 @@ let getLocItem ~full ~pos ~debug = 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); + 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 *) @@ -102,37 +102,37 @@ let getLocItem ~full ~pos ~debug = 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); + 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 - | {locType = Typed (_, {desc = Tconstr (path, _, _)}, _)} :: li :: _ - when Utils.isUncurriedInternal path -> + | {loc_type = Typed (_, {desc = Tconstr (path, _, _)}, _)} :: li :: _ + when Utils.is_uncurried_internal path -> Some li | li :: _ -> Some li | _ -> None -let declaredForTip ~(stamps : Stamps.t) stamp (tip : Tip.t) = +let declared_for_tip ~(stamps : Stamps.t) stamp (tip : Tip.t) = match tip with | Value -> - Stamps.findValue stamps stamp + Stamps.find_value stamps stamp |> Option.map (fun x -> {x with Declared.item = ()}) | Field _ | Constructor _ | Type -> - Stamps.findType stamps stamp + Stamps.find_type stamps stamp |> Option.map (fun x -> {x with Declared.item = ()}) | Module -> - Stamps.findModule stamps stamp + Stamps.find_module stamps stamp |> Option.map (fun x -> {x with Declared.item = ()}) -let getField (file : File.t) stamp name = - match Stamps.findType file.stamps stamp with +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 getConstructor (file : File.t) stamp name = - match Stamps.findType file.stamps stamp with +let get_constructor (file : File.t) stamp name = + match Stamps.find_type file.stamps stamp with | None -> None | Some {item = {kind}} -> ( match kind with @@ -145,10 +145,10 @@ let getConstructor (file : File.t) stamp name = | Some const -> Some const) | _ -> None) -let exportedForTip ~env ~path ~package ~(tip : Tip.t) = - match ResolvePath.resolvePath ~env ~path ~package with +let exported_for_tip ~env ~path ~package ~(tip : Tip.t) = + match ResolvePath.resolve_path ~env ~path ~package with | None -> - Log.log ("Cannot resolve path " ^ pathToString path); + Log.log ("Cannot resolve path " ^ path_to_string path); None | Some (env, name) -> ( let kind = @@ -159,131 +159,131 @@ let exportedForTip ~env ~path ~package ~(tip : Tip.t) = in match Exported.find env.exported kind name with | None -> - Log.log ("Exported not found for tip " ^ name ^ " > " ^ Tip.toString tip); + Log.log ("Exported not found for tip " ^ name ^ " > " ^ Tip.to_string tip); None | Some stamp -> Some (env, name, stamp)) -let definedForLoc ~file ~package locKind = +let defined_for_loc ~file ~package loc_kind = let inner ~file stamp (tip : Tip.t) = match tip with | Constructor name -> ( - match getConstructor file stamp name with + match get_constructor file stamp name with | None -> None | Some constructor -> Some (constructor.docstring, `Constructor constructor)) | Field name -> Some - ( (match getField file stamp name with + ( (match get_field 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 + 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 locKind with + match loc_kind 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 + | GlobalReference (module_name, path, tip) -> ( + maybe_log ("Getting global " ^ module_name); + match ProcessCmt.file_for_module ~package module_name with | None -> - Log.log ("Cannot get module " ^ moduleName); + Log.log ("Cannot get module " ^ module_name); None | Some file -> ( - let env = QueryEnv.fromFile file in - match exportedForTip ~env ~path ~package ~tip with + let env = QueryEnv.from_file file in + match exported_for_tip ~env ~path ~package ~tip with | None -> None | Some (env, name, stamp) -> ( - maybeLog ("Getting for " ^ string_of_int stamp ^ " in " ^ name); + 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 -> - maybeLog "Yes!! got it"; + maybe_log "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 +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} -> ( - 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 + 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 = 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 + let env = QueryEnv.from_file file in + let path = ModulePath.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) -> - declaredForTip ~stamps:file.stamps stamp tip + declared_for_tip ~stamps:file.stamps stamp tip in - match declaredOpt with + match declared_opt with | None -> None | Some declared -> Some (file, extra, declared))) | _ -> - maybeLog ("alternateDeclared for " ^ file.moduleName ^ " not found"); + maybe_log ("alternateDeclared for " ^ file.module_name ^ " not found"); None) -let rec resolveModuleReference ?(pathsSeen = []) ~file ~package +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, moduleTypeItem) -> - resolveModuleReference ~pathsSeen ~file ~package - {declared with item = moduleTypeItem} + | Constraint (_moduleItem, module_type_item) -> + resolve_module_reference ~paths_seen ~file ~package + {declared with item = module_type_item} | Ident path -> ( - let env = QueryEnv.fromFile file in - match ResolvePath.fromCompilerPath ~env path with + let env = QueryEnv.from_file file in + match ResolvePath.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.findModule env.file.stamps stamp with + match Stamps.find_module env.file.stamps stamp with | None -> None | Some md -> Some (env.file, Some md))) - | Global (moduleName, path) -> ( - match ProcessCmt.fileForModule ~package moduleName with + | Global (module_name, path) -> ( + match ProcessCmt.file_for_module ~package module_name with | None -> None | Some file -> ( - let env = QueryEnv.fromFile file in - match ResolvePath.resolvePath ~env ~package ~path with + let env = QueryEnv.from_file file in + match ResolvePath.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.findModule env.file.stamps stamp with + match Stamps.find_module env.file.stamps stamp with | None -> None | Some md -> Some (env.file, Some md))))) | Stamp stamp -> ( - match Stamps.findModule file.stamps stamp with + match Stamps.find_module file.stamps stamp with | None -> None - | Some ({item = Ident path} as md) when not (List.mem path pathsSeen) -> + | Some ({item = Ident path} as md) when not (List.mem path paths_seen) -> (* avoid possible infinite loops *) - resolveModuleReference ~file ~package ~pathsSeen:(path :: pathsSeen) md + resolve_module_reference ~file ~package ~paths_seen:(path :: paths_seen) md | Some md -> Some (file, Some md)) | GlobalMod name -> ( - match ProcessCmt.fileForModule ~package name with + match ProcessCmt.file_for_module ~package name with | None -> None | Some file -> Some (file, None))) -let validateLoc (loc : Location.t) (backup : Location.t) = +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 { @@ -294,65 +294,65 @@ let validateLoc (loc : Location.t) (backup : Location.t) = else backup else loc -let resolveModuleDefinition ~(file : File.t) ~package stamp = - match Stamps.findModule file.stamps stamp with +let resolve_module_definition ~(file : File.t) ~package stamp = + match Stamps.find_module file.stamps stamp with | None -> None | Some md -> ( - match resolveModuleReference ~file ~package md with + match resolve_module_reference ~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 + | 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 getConstructor file stamp name with + match get_constructor file stamp name with | None -> None | Some constructor -> Some (file.uri, constructor.cname.loc)) | Field name -> ( - match getField file stamp name with + match get_field file stamp name with | None -> None | Some field -> Some (file.uri, field.fname.loc)) - | Module -> resolveModuleDefinition ~file ~package stamp + | Module -> resolve_module_definition ~file ~package stamp | _ -> ( - match declaredForTip ~stamps:file.stamps stamp tip with + match declared_for_tip ~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) + 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 = validateLoc declaredImpl.name.loc declaredImpl.extentLoc in - let env = QueryEnv.fromFile fileImpl in + let loc = validate_loc declared_impl.name.loc declared_impl.extent_loc in + let env = QueryEnv.from_file file_impl in let uri = - ResolvePath.getSourceUri ~env ~package declaredImpl.modulePath + ResolvePath.get_source_uri ~env ~package declared_impl.module_path in - maybeLog ("Inner uri " ^ Uri.toString uri); + maybe_log ("Inner uri " ^ Uri.to_string uri); Some (uri, loc)) -let definitionForLocItem ~full:{file; package} locItem = - match locItem.locType with +let definition_for_loc_item ~full:{file; package} loc_item = + match loc_item.loc_type with | Typed (_, _, Definition (stamp, tip)) -> ( - maybeLog + maybe_log ("Typed Definition stamp:" ^ string_of_int stamp ^ " tip:" - ^ Tip.toString tip); - match declaredForTip ~stamps:file.stamps stamp tip with + ^ Tip.to_string tip); + match declared_for_tip ~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 + 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 = validateLoc declared.name.loc declared.extentLoc in + let loc = validate_loc declared.name.loc declared.extent_loc in Some (file.uri, loc)) else None) | Typed (_, _, NotFound) @@ -361,213 +361,213 @@ let definitionForLocItem ~full:{file; package} locItem = | Constant _ -> None | TopLevelModule name -> ( - maybeLog ("Toplevel " ^ name); - match Hashtbl.find_opt package.pathsForModule name with + maybe_log ("Toplevel " ^ name); + match Hashtbl.find_opt package.paths_for_module name with | None -> None | Some paths -> - let uri = getUri paths in - Some (uri, Uri.toTopLevelLoc uri)) + let uri = get_uri paths in + Some (uri, Uri.to_top_level_loc uri)) | LModule (LocalReference (stamp, tip)) | Typed (_, _, LocalReference (stamp, tip)) -> - maybeLog ("Local defn " ^ Tip.toString tip); + maybe_log ("Local defn " ^ Tip.to_string 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 + | 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 ProcessCmt.file_for_module ~package module_name with | None -> None | Some file -> ( - let env = QueryEnv.fromFile file in - match exportedForTip ~env ~path ~package ~tip with + let env = QueryEnv.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? *) - maybeLog ("Got stamp " ^ string_of_int stamp); + maybe_log ("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 +let dig_constructor ~env ~package path = + match ResolvePath.resolve_from_compiler_path ~env ~package path with | NotFound -> None | Stamp stamp -> ( - match Stamps.findType env.file.stamps stamp with + 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.findType env.file.stamps stamp with + match Stamps.find_type env.file.stamps stamp with | None -> None | Some t -> Some (env, t))) | _ -> None -let typeDefinitionForLocItem ~full:{file; package} locItem = - match locItem.locType with +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, locItem.loc) + | TypeDefinition _ -> Some (file.uri, loc_item.loc) | Typed (_, typ, _) -> ( - let env = QueryEnv.fromFile file in - match Shared.digConstructor typ with + let env = QueryEnv.from_file file in + match Shared.dig_constructor typ with | None -> None | Some path -> ( - match digConstructor ~env ~package path with + match dig_constructor ~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 is_visible (declared : _ Declared.t) = + declared.is_exported && let rec loop (v : ModulePath.t) = match v with | File _ -> true | NotVisible -> false | IncludedModule (_, inner) -> loop inner - | ExportedModule {modulePath = inner} -> loop inner + | ExportedModule {module_path = inner} -> loop inner in - loop declared.modulePath + loop declared.module_path type references = { uri: Uri.t; - locOpt: Location.t option; (* None: reference to a toplevel module *) + loc_opt: 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 +let for_local_stamp ~full:{file; extra; package} stamp (tip : Tip.t) = + let env = QueryEnv.from_file file in match match tip with | Constructor name -> - getConstructor file stamp name + get_constructor file stamp name |> Option.map (fun x -> x.Constructor.stamp) - | Field name -> getField file stamp name |> Option.map (fun x -> x.stamp) + | Field name -> get_field file stamp name |> Option.map (fun x -> x.stamp) | _ -> Some stamp with | None -> [] - | Some localStamp -> ( - match Hashtbl.find_opt extra.internalReferences localStamp with + | Some local_stamp -> ( + match Hashtbl.find_opt extra.internal_references local_stamp with | None -> [] | Some locs -> - maybeLog ("Checking externals: " ^ string_of_int stamp); + maybe_log ("Checking externals: " ^ string_of_int stamp); let externals = - match declaredForTip ~stamps:env.file.stamps stamp tip with + match declared_for_tip ~stamps:env.file.stamps stamp tip with | None -> [] | Some declared -> - if isVisible declared then ( - let alternativeReferences = - match alternateDeclared ~package ~file declared tip with + 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 -> - getConstructor file stamp name + get_constructor file stamp name |> Option.map (fun x -> x.Constructor.stamp) | Field name -> - getField file stamp name |> Option.map (fun x -> x.stamp) + get_field file stamp name |> Option.map (fun x -> x.stamp) | _ -> Some stamp with | None -> [] - | Some localStamp -> ( + | Some local_stamp -> ( match - Hashtbl.find_opt extra.internalReferences localStamp + Hashtbl.find_opt extra.internal_references local_stamp with | None -> [] | Some locs -> locs - |> List.map (fun loc -> {uri = file.uri; locOpt = Some loc}) + |> 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 = - ModulePath.toPath declared.modulePath declared.name.txt + ModulePath.to_path declared.module_path declared.name.txt in - maybeLog ("Now checking path " ^ pathToString path); - let thisModuleName = file.moduleName in + maybe_log ("Now checking path " ^ path_to_string path); + let this_module_name = file.module_name in let externals = - package.projectFiles |> FileSet.elements - |> List.filter (fun name -> name <> file.moduleName) - |> List.map (fun moduleName -> - Cmt.fullsFromModule ~package ~moduleName + package.project_files |> FileSet.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.externalReferences - thisModuleName + Hashtbl.find_opt extra.external_references + this_module_name with | None -> [] | Some refs -> let locs = refs - |> Utils.filterMap (fun (p, t, locs) -> + |> 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; locOpt = Some loc}))) + {uri = file.uri; loc_opt = Some loc}))) |> List.concat |> List.concat in - alternativeReferences @ externals) + alternative_references @ externals) else ( - maybeLog "Not visible"; + maybe_log "Not visible"; []) in List.append - (locs |> List.map (fun loc -> {uri = file.uri; locOpt = Some loc})) + (locs |> List.map (fun loc -> {uri = file.uri; loc_opt = 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 +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 |> FileSet.elements + |> Utils.filter_map (fun name -> + match ProcessCmt.file_for_module ~package name with | None -> None - | Some file -> Cmt.fullFromUri ~uri:file.uri) + | Some file -> Cmt.full_from_uri ~uri:file.uri) |> List.map (fun full -> - match Hashtbl.find_opt full.extra.fileReferences moduleName with + match Hashtbl.find_opt full.extra.file_references module_name with | None -> [] | Some locs -> locs |> LocationSet.elements |> List.map (fun loc -> { - uri = Uri.fromPath loc.Location.loc_start.pos_fname; - locOpt = Some loc; + uri = Uri.from_path loc.Location.loc_start.pos_fname; + loc_opt = Some loc; })) |> List.flatten in - let targetModuleReferences = - match Hashtbl.find_opt package.pathsForModule moduleName with + let target_module_references = + match Hashtbl.find_opt package.paths_for_module module_name with | None -> [] | Some paths -> - let moduleSrcToRef src = {uri = Uri.fromPath src; locOpt = None} in - getSrc paths |> List.map moduleSrcToRef + 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 targetModuleReferences otherModulesReferences + List.append target_module_references other_modules_references | Typed (_, _, NotFound) | LModule NotFound | Constant _ -> [] - | TypeDefinition (_, _, stamp) -> forLocalStamp ~full stamp Type + | TypeDefinition (_, _, stamp) -> for_local_stamp ~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 + 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 ProcessCmt.file_for_module ~package module_name with | None -> [] | Some file -> ( - let env = QueryEnv.fromFile file in - match exportedForTip ~env ~path ~package ~tip with + let env = QueryEnv.from_file file in + match exported_for_tip ~env ~path ~package ~tip with | None -> [] | Some (env, _name, stamp) -> ( - match Cmt.fullFromUri ~uri:env.file.uri with + match Cmt.full_from_uri ~uri:env.file.uri with | None -> [] | Some full -> - maybeLog - ("Finding references for (global) " ^ Uri.toString env.file.uri + maybe_log + ("Finding references for (global) " ^ Uri.to_string env.file.uri ^ " and stamp " ^ string_of_int stamp ^ " and tip " - ^ Tip.toString tip); - forLocalStamp ~full stamp tip))) + ^ Tip.to_string tip); + for_local_stamp ~full stamp tip))) diff --git a/analysis/src/ResolvePath.ml b/analysis/src/ResolvePath.ml index 877e273fe8..a7740b6ea0 100644 --- a/analysis/src/ResolvePath.ml +++ b/analysis/src/ResolvePath.ml @@ -1,130 +1,130 @@ open SharedTypes type resolution = - | Exported of QueryEnv.t * filePath - | Global of filePath * filePath list - | GlobalMod of filePath + | Exported of QueryEnv.t * file_path + | Global of file_path * file_path list + | GlobalMod of file_path | NotFound | Stamp of int -let rec joinPaths modulePath path = - match modulePath with +let rec join_paths module_path path = + match module_path with | Path.Pident ident -> (ident.stamp, ident.name, path) - | Papply (fnPath, _argPath) -> joinPaths fnPath path - | Pdot (inner, name, _) -> joinPaths inner (name :: path) + | Papply (fn_path, _argPath) -> join_paths fn_path path + | Pdot (inner, name, _) -> join_paths inner (name :: path) -let rec makePath ~(env : QueryEnv.t) modulePath = - match modulePath with +let rec make_path ~(env : QueryEnv.t) module_path = + match module_path with | Path.Pident ident when ident.stamp == 0 -> GlobalMod ident.name | Pident ident -> Stamp ident.stamp - | Papply (fnPath, _argPath) -> makePath ~env fnPath + | Papply (fn_path, _argPath) -> make_path ~env fn_path | Pdot (inner, name, _) -> ( - match joinPaths inner [name] with - | 0, moduleName, path -> Global (moduleName, path) + match join_paths inner [name] with + | 0, module_name, path -> Global (module_name, path) | stamp, _moduleName, path -> ( let res = - match Stamps.findModule env.file.stamps stamp with + match Stamps.find_module env.file.stamps stamp with | None -> None - | Some {item = kind} -> findInModule ~env kind path + | Some {item = kind} -> find_in_module ~env kind path in match res with | None -> NotFound | Some (`Local (env, name)) -> Exported (env, name) - | Some (`Global (moduleName, fullPath)) -> Global (moduleName, fullPath))) + | Some (`Global (module_name, full_path)) -> Global (module_name, full_path))) -and resolvePathInner ~(env : QueryEnv.t) ~path = +and resolve_path_inner ~(env : QueryEnv.t) ~path = match path with | [] -> None | [name] -> Some (`Local (env, name)) - | subName :: subPath -> ( - match Exported.find env.exported Exported.Module subName with + | sub_name :: sub_path -> ( + match Exported.find env.exported Exported.Module sub_name with | None -> None | Some stamp -> ( - match Stamps.findModule env.file.stamps stamp with + match Stamps.find_module env.file.stamps stamp with | None -> None - | Some {item} -> findInModule ~env item subPath)) + | Some {item} -> find_in_module ~env item sub_path)) -and findInModule ~(env : QueryEnv.t) module_ path = +and find_in_module ~(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)) + resolve_path_inner ~env:(QueryEnv.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.findModule env.file.stamps stamp with + match Stamps.find_module env.file.stamps stamp with | None -> None - | Some {item} -> findInModule ~env item fullPath) + | Some {item} -> find_in_module ~env item full_path) -let rec resolvePath ~env ~path ~package = - Log.log ("resolvePath path:" ^ pathToString path); - match resolvePathInner ~env ~path with +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 (moduleName, fullPath) -> ( + | `Global (module_name, full_path) -> ( Log.log - ("resolvePath Global path:" ^ pathToString fullPath ^ " module:" - ^ moduleName); - match ProcessCmt.fileForModule ~package moduleName with + ("resolvePath Global path:" ^ path_to_string full_path ^ " module:" + ^ module_name); + match ProcessCmt.file_for_module ~package module_name with | None -> None | Some file -> - resolvePath ~env:(QueryEnv.fromFile file) ~path:fullPath ~package)) + resolve_path ~env:(QueryEnv.from_file file) ~path:full_path ~package)) -let fromCompilerPath ~(env : QueryEnv.t) path : resolution = - match makePath ~env path with +let from_compiler_path ~(env : QueryEnv.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 (moduleName, fullPath) -> Global (moduleName, fullPath) + | Global (module_name, full_path) -> Global (module_name, full_path) -let resolveModuleFromCompilerPath ~env ~package path = - match fromCompilerPath ~env path with - | Global (moduleName, path) -> ( - match ProcessCmt.fileForModule ~package moduleName with +let resolve_module_from_compiler_path ~env ~package path = + match from_compiler_path ~env path with + | Global (module_name, path) -> ( + match ProcessCmt.file_for_module ~package module_name with | None -> None | Some file -> ( - let env = QueryEnv.fromFile file in - match resolvePath ~env ~package ~path with + let env = QueryEnv.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.findModule env.file.stamps stamp with + match Stamps.find_module env.file.stamps stamp with | None -> None | Some declared -> Some (env, Some declared))))) | Stamp stamp -> ( - match Stamps.findModule env.file.stamps stamp with + match Stamps.find_module env.file.stamps stamp with | None -> None | Some declared -> Some (env, Some declared)) - | GlobalMod moduleName -> ( - match ProcessCmt.fileForModule ~package moduleName with + | GlobalMod module_name -> ( + match ProcessCmt.file_for_module ~package module_name with | None -> None | Some file -> - let env = QueryEnv.fromFile file in + let env = QueryEnv.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.findModule env.file.stamps stamp with + match Stamps.find_module 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 resolve_from_compiler_path ~env ~package path = + match from_compiler_path ~env path with + | Global (module_name, path) -> ( let res = - match ProcessCmt.fileForModule ~package moduleName with + match ProcessCmt.file_for_module ~package module_name with | None -> None | Some file -> - let env = QueryEnv.fromFile file in - resolvePath ~env ~package ~path + let env = QueryEnv.from_file file in + resolve_path ~env ~package ~path in match res with | None -> NotFound @@ -134,15 +134,15 @@ let resolveFromCompilerPath ~env ~package path = | NotFound -> NotFound | Exported (env, name) -> Exported (env, name) -let rec getSourceUri ~(env : QueryEnv.t) ~package (path : ModulePath.t) = +let rec get_source_uri ~(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 + match resolve_module_from_compiler_path ~env ~package path with | None -> Log.log "NOT FOUND"; - getSourceUri ~env ~package inner + get_source_uri ~env ~package inner | Some (env, _declared) -> env.file.uri) - | ExportedModule {modulePath = inner} -> getSourceUri ~env ~package inner + | ExportedModule {module_path = inner} -> get_source_uri ~env ~package inner diff --git a/analysis/src/Scope.ml b/analysis/src/Scope.ml index 33e850bc02..a905ea685c 100644 --- a/analysis/src/Scope.ml +++ b/analysis/src/Scope.ml @@ -4,42 +4,42 @@ type t = item list open SharedTypes.ScopeTypes -let itemToString item = +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.toString loc - | Field (s, loc) -> "Field " ^ s ^ " " ^ Loc.toString loc + | 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.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 + | 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 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 +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 contextPath -> - if showDebug then + | Some context_path -> + if show_debug 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 + (SharedTypes.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 iterValuesBeforeFirstOpen f x = +let iter_values_before_first_open f x = let rec loop items = match items with - | Value (s, loc, contextPath, scope) :: rest -> - f s loc contextPath scope; + | Value (s, loc, context_path, scope) :: rest -> + f s loc context_path scope; loop rest | Open _ :: _ -> () | _ :: rest -> loop rest @@ -47,19 +47,19 @@ let iterValuesBeforeFirstOpen f x = in loop x -let iterValuesAfterFirstOpen f x = - let rec loop foundOpen items = +let iter_values_after_first_open f x = + let rec loop found_open items = match items with - | Value (s, loc, contextPath, scope) :: rest -> - if foundOpen then f s loc contextPath scope; - loop foundOpen rest + | 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 foundOpen rest + | _ :: rest -> loop found_open rest | [] -> () in loop false x -let iterConstructorsBeforeFirstOpen f x = +let iter_constructors_before_first_open f x = let rec loop items = match items with | Constructor (s, loc) :: rest -> @@ -71,19 +71,19 @@ let iterConstructorsBeforeFirstOpen f x = in loop x -let iterConstructorsAfterFirstOpen f x = - let rec loop foundOpen items = +let iter_constructors_after_first_open f x = + let rec loop found_open items = match items with | Constructor (s, loc) :: rest -> - if foundOpen then f s loc; - loop foundOpen rest + if found_open then f s loc; + loop found_open rest | Open _ :: rest -> loop true rest - | _ :: rest -> loop foundOpen rest + | _ :: rest -> loop found_open rest | [] -> () in loop false x -let iterTypesBeforeFirstOpen f x = +let iter_types_before_first_open f x = let rec loop items = match items with | Type (s, loc) :: rest -> @@ -95,19 +95,19 @@ let iterTypesBeforeFirstOpen f x = in loop x -let iterTypesAfterFirstOpen f x = - let rec loop foundOpen items = +let iter_types_after_first_open f x = + let rec loop found_open items = match items with | Type (s, loc) :: rest -> - if foundOpen then f s loc; - loop foundOpen rest + if found_open then f s loc; + loop found_open rest | Open _ :: rest -> loop true rest - | _ :: rest -> loop foundOpen rest + | _ :: rest -> loop found_open rest | [] -> () in loop false x -let iterModulesBeforeFirstOpen f x = +let iter_modules_before_first_open f x = let rec loop items = match items with | Module (s, loc) :: rest -> @@ -119,19 +119,19 @@ let iterModulesBeforeFirstOpen f x = in loop x -let iterModulesAfterFirstOpen f x = - let rec loop foundOpen items = +let iter_modules_after_first_open f x = + let rec loop found_open items = match items with | Module (s, loc) :: rest -> - if foundOpen then f s loc; - loop foundOpen rest + if found_open then f s loc; + loop found_open rest | Open _ :: rest -> loop true rest - | _ :: rest -> loop foundOpen rest + | _ :: rest -> loop found_open rest | [] -> () in loop false x -let iterIncludes f x = +let iter_includes f x = let rec loop items = match items with | [] -> () @@ -142,8 +142,8 @@ let iterIncludes f x = in loop x -let getRawOpens x = +let get_raw_opens x = x - |> Utils.filterMap (function + |> Utils.filter_map (function | Open path -> Some path | _ -> None) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index 1862ba612f..4224dee0c3 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.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,71 @@ 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 +123,112 @@ 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 +258,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 +273,31 @@ 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 +316,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 +336,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 +363,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 +371,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 +380,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 +391,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 +400,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 +409,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 +417,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 +425,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 +435,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 +444,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 +469,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 +489,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 index b2d7edf76e..858b12b4ee 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 = + PrintType.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 = PrintType.print_expr ?line_width t in + Hashtbl.replace type_tbl (t.id, t) s; s | Some s -> s diff --git a/analysis/src/SharedTypes.ml b/analysis/src/SharedTypes.ml index cce06e969e..ad7bcfa20a 100644 --- a/analysis/src/SharedTypes.ml +++ b/analysis/src/SharedTypes.ml @@ -4,36 +4,36 @@ let ident l = l |> List.map str |> String.concat "." type path = string list -type typedFnArg = Asttypes.arg_label * Types.type_expr +type typed_fn_arg = Asttypes.arg_label * Types.type_expr -let pathToString (path : path) = path |> String.concat "." +let path_to_string (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} + | ExportedModule of {name: string; module_path: t; is_type: bool} - let toPath modulePath tipName : path = - let rec loop modulePath current = - match modulePath with + 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; modulePath = inner} -> loop inner (name :: current) + | ExportedModule {name; module_path = inner} -> loop inner (name :: current) | NotVisible -> current in - loop modulePath [tipName] + loop module_path [tip_name] - let toPathWithPrefix modulePath prefix : path = - let rec loop modulePath current = - match modulePath with + 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; modulePath = inner} -> loop inner (name :: current) + | ExportedModule {name; module_path = inner} -> loop inner (name :: current) | NotVisible -> current in - prefix :: loop modulePath [] + prefix :: loop module_path [] end type field = { @@ -45,7 +45,7 @@ type field = { deprecated: string option; } -type constructorArgs = +type constructor_args = | InlineRecord of field list | Args of (Types.type_expr * Location.t) list @@ -53,9 +53,9 @@ module Constructor = struct type t = { stamp: int; cname: string Location.loc; - args: constructorArgs; + args: constructor_args; res: Types.type_expr option; - typeDecl: string * Types.type_declaration; + type_decl: string * Types.type_declaration; docstring: string list; deprecated: string option; } @@ -78,12 +78,12 @@ module Type = struct end module Exported = struct - type namedStampMap = (string, int) Hashtbl.t + type named_stamp_map = (string, int) Hashtbl.t type t = { - types_: namedStampMap; - values_: namedStampMap; - modules_: namedStampMap; + types_: named_stamp_map; + values_: named_stamp_map; + modules_: named_stamp_map; } type kind = Type | Value | Module @@ -130,7 +130,7 @@ module Module = struct type kind = | Value of Types.type_expr | Type of Type.t * Types.rec_status - | Module of {type_: t; isModuleType: bool} + | Module of {type_: t; is_module_type: bool} and item = { kind: kind; @@ -154,10 +154,10 @@ end module Declared = struct type 'item t = { name: string Location.loc; - extentLoc: Location.t; + extent_loc: Location.t; stamp: int; - modulePath: ModulePath.t; - isExported: bool; + module_path: ModulePath.t; + is_exported: bool; deprecated: string option; docstring: string list; item: 'item; @@ -171,25 +171,25 @@ module Stamps : sig | KModule of Module.t Declared.t | KConstructor of Constructor.t Declared.t - val locOfKind : kind -> Warnings.loc + val loc_of_kind : 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 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 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 + 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 stampMap = (int, 't Declared.t) Hashtbl.t + type 't stamp_map = (int, 't Declared.t) Hashtbl.t type kind = | KType of Type.t Declared.t @@ -197,43 +197,43 @@ end = struct | 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 + 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 addConstructor (stamps : t) stamp declared = + let add_constructor (stamps : t) stamp declared = Hashtbl.add stamps stamp (KConstructor declared) - let addModule stamps stamp declared = + let add_module stamps stamp declared = Hashtbl.add stamps stamp (KModule declared) - let addType stamps stamp declared = Hashtbl.add stamps stamp (KType declared) + let add_type stamps stamp declared = Hashtbl.add stamps stamp (KType declared) - let addValue stamps stamp declared = + let add_value stamps stamp declared = Hashtbl.add stamps stamp (KValue declared) - let findModule stamps stamp = + let find_module stamps stamp = match Hashtbl.find_opt stamps stamp with | Some (KModule declared) -> Some declared | _ -> None - let findType stamps stamp = + let find_type stamps stamp = match Hashtbl.find_opt stamps stamp with | Some (KType declared) -> Some declared | _ -> None - let findValue stamps stamp = + let find_value stamps stamp = match Hashtbl.find_opt stamps stamp with | Some (KValue declared) -> Some declared | _ -> None - let iterModules f stamps = + let iter_modules f stamps = Hashtbl.iter (fun stamp d -> match d with @@ -241,7 +241,7 @@ end = struct | _ -> ()) stamps - let iterTypes f stamps = + let iter_types f stamps = Hashtbl.iter (fun stamp d -> match d with @@ -249,7 +249,7 @@ end = struct | _ -> ()) stamps - let iterValues f stamps = + let iter_values f stamps = Hashtbl.iter (fun stamp d -> match d with @@ -257,7 +257,7 @@ end = struct | _ -> ()) stamps - let iterConstructors f stamps = + let iter_constructors f stamps = Hashtbl.iter (fun stamp d -> match d with @@ -265,25 +265,25 @@ end = struct | _ -> ()) stamps - let getEntries t = t |> Hashtbl.to_seq |> List.of_seq + let get_entries t = t |> Hashtbl.to_seq |> List.of_seq end module File = struct type t = { uri: Uri.t; stamps: Stamps.t; - moduleName: string; + module_name: string; structure: Module.structure; } - let create moduleName uri = + let create module_name uri = { uri; stamps = Stamps.init (); - moduleName; + module_name; structure = { - name = moduleName; + name = module_name; docstring = []; exported = Exported.init (); items = []; @@ -296,87 +296,87 @@ module QueryEnv : sig type t = private { file: File.t; exported: Exported.t; - pathRev: path; + path_rev: path; parent: t option; } - val fromFile : File.t -> t - val enterStructure : t -> Module.structure -> t + 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 pathFromEnv : t -> path -> bool * path + val path_from_env : t -> path -> bool * path - val toString : t -> string + val to_string : t -> string end = struct - type t = {file: File.t; exported: Exported.t; pathRev: path; parent: t option} + type t = {file: File.t; exported: Exported.t; path_rev: path; parent: t option} - let toString {file; pathRev} = - file.moduleName :: List.rev pathRev |> String.concat "." + let to_string {file; path_rev} = + file.module_name :: List.rev path_rev |> String.concat "." - let fromFile (file : File.t) = - {file; exported = file.structure.exported; pathRev = []; parent = None} + 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 prunePath pathRev env name = - if Exported.find env.exported Module name <> None then (true, pathRev) + let rec prune_path path_rev env name = + if Exported.find env.exported Module name <> None then (true, path_rev) else - match (pathRev, env.parent) with - | _ :: rest, Some env -> prunePath rest env name + match (path_rev, env.parent) with + | _ :: rest, Some env -> prune_path rest env name | _ -> (false, []) - let pathFromEnv env path = + let path_from_env env path = match path with - | [] -> (true, env.pathRev |> List.rev) + | [] -> (true, env.path_rev |> List.rev) | name :: _ -> - let found, prunedPathRev = prunePath env.pathRev env name in - (found, List.rev_append prunedPathRev path) + let found, pruned_path_rev = prune_path env.path_rev env name in + (found, List.rev_append pruned_path_rev path) - let enterStructure env (structure : Module.structure) = + let enter_structure 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} + 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 typeArgContext = { +type type_arg_context = { env: QueryEnv.t; - typeArgs: Types.type_expr list; - typeParams: Types.type_expr list; + type_args: Types.type_expr list; + type_params: Types.type_expr list; } -type polyVariantConstructor = { +type poly_variant_constructor = { name: string; - displayName: string; + display_name: 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 = +type inner_type = TypeExpr of Types.type_expr | ExtractedType of completion_type +and completion_type = | 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 + | Toption of QueryEnv.t * inner_type | Tresult of { env: QueryEnv.t; - okType: Types.type_expr; - errorType: Types.type_expr; + ok_type: Types.type_expr; + error_type: Types.type_expr; } | Tbool of QueryEnv.t - | Tarray of QueryEnv.t * innerType + | Tarray of QueryEnv.t * inner_type | 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; + variant_decl: Types.type_declaration; + variant_name: string; } | Tpolyvariant of { env: QueryEnv.t; - constructors: polyVariantConstructor list; - typeExpr: Types.type_expr; + constructors: poly_variant_constructor list; + type_expr: Types.type_expr; } | Trecord of { env: QueryEnv.t; @@ -390,75 +390,75 @@ and completionType = | TinlineRecord of {env: QueryEnv.t; fields: field list} | Tfunction of { env: QueryEnv.t; - args: typedFnArg list; + args: typed_fn_arg list; typ: Types.type_expr; - returnType: Types.type_expr; + return_type: Types.type_expr; } module Env = struct - type t = {stamps: Stamps.t; modulePath: ModulePath.t} - let addExportedModule ~name ~isType env = + type t = {stamps: Stamps.t; module_path: ModulePath.t} + let add_exported_module ~name ~is_type env = { env with - modulePath = ExportedModule {name; modulePath = env.modulePath; isType}; + module_path = ExportedModule {name; module_path = env.module_path; is_type}; } - let addModule ~name env = env |> addExportedModule ~name ~isType:false - let addModuleType ~name env = env |> addExportedModule ~name ~isType:true + 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 filePath = string +type file_path = string type paths = - | Impl of {cmt: filePath; res: filePath} - | Namespace of {cmt: filePath} + | Impl of {cmt: file_path; res: file_path} + | Namespace of {cmt: file_path} | IntfAndImpl of { - cmti: filePath; - resi: filePath; - cmt: filePath; - res: filePath; + cmti: file_path; + resi: file_path; + cmt: file_path; + res: file_path; } -let showPaths paths = +let show_paths 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) + 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.dumpPath cmti) (Utils.dumpPath resi) (Utils.dumpPath cmt) - (Utils.dumpPath res) + (Utils.dump_path cmti) (Utils.dump_path resi) (Utils.dump_path cmt) + (Utils.dump_path res) -let getSrc p = +let get_src p = match p with | Impl {res} -> [res] | Namespace _ -> [] | IntfAndImpl {resi; res} -> [resi; res] -let getUri p = +let get_uri p = match p with - | Impl {res} -> Uri.fromPath res - | Namespace {cmt} -> Uri.fromPath cmt - | IntfAndImpl {resi} -> Uri.fromPath resi + | Impl {res} -> Uri.from_path res + | Namespace {cmt} -> Uri.from_path cmt + | IntfAndImpl {resi} -> Uri.from_path resi -let getUris p = +let get_uris p = match p with - | Impl {res} -> [Uri.fromPath res] - | Namespace {cmt} -> [Uri.fromPath cmt] - | IntfAndImpl {res; resi} -> [Uri.fromPath res; Uri.fromPath resi] + | Impl {res} -> [Uri.from_path res] + | Namespace {cmt} -> [Uri.from_path cmt] + | IntfAndImpl {res; resi} -> [Uri.from_path res; Uri.from_path resi] -let getCmtPath ~uri p = +let get_cmt_path ~uri p = match p with | Impl {cmt} -> cmt | Namespace {cmt} -> cmt | IntfAndImpl {cmti; cmt} -> - let interface = Utils.endsWith (Uri.toPath uri) "i" in + 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 toString tip = + let to_string tip = match tip with | Value -> "Value" | Type -> "Type" @@ -467,27 +467,27 @@ module Tip = struct | Module -> "Module" end -let rec pathIdentToString (p : Path.t) = +let rec path_ident_to_string (p : Path.t) = match p with | Pident {name} -> name - | Pdot (nextPath, id, _) -> - Printf.sprintf "%s.%s" (pathIdentToString nextPath) id + | Pdot (next_path, id, _) -> + Printf.sprintf "%s.%s" (path_ident_to_string next_path) id | Papply _ -> "" -type locKind = +type loc_kind = | 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 +type loc_type = + | Typed of string * Types.type_expr * loc_kind | Constant of Asttypes.constant - | LModule of locKind + | LModule of loc_kind | TopLevelModule of string | TypeDefinition of string * Types.type_declaration * int -type locItem = {loc: Location.t; locType: locType} +type loc_item = {loc: Location.t; loc_type: loc_type} module LocationSet = Set.Make (struct include Location @@ -498,11 +498,11 @@ module LocationSet = Set.Make (struct end) type extra = { - internalReferences: (int, Location.t list) Hashtbl.t; - externalReferences: + internal_references: (int, Location.t list) Hashtbl.t; + external_references: (string, (string list * Tip.t * Location.t) list) Hashtbl.t; - fileReferences: (string, LocationSet.t) Hashtbl.t; - mutable locItems: locItem list; + file_references: (string, LocationSet.t) Hashtbl.t; + mutable loc_items: loc_item list; } type file = string @@ -510,200 +510,200 @@ type file = string module FileSet = Set.Make (String) type package = { - genericJsxModule: string option; + generic_jsx_module: string option; suffix: string; - rootPath: filePath; - projectFiles: FileSet.t; - dependenciesFiles: FileSet.t; - pathsForModule: (file, paths) Hashtbl.t; + root_path: file_path; + project_files: FileSet.t; + dependencies_files: FileSet.t; + paths_for_module: (file, paths) Hashtbl.t; namespace: string option; opens: path list; - rescriptVersion: int * int; + rescript_version: int * int; autocomplete: file list Misc.StringMap.t; } -let allFilesInPackage package = - FileSet.union package.projectFiles package.dependenciesFiles +let all_files_in_package package = + FileSet.union package.project_files package.dependencies_files type full = {extra: extra; file: File.t; package: package} -let initExtra () = +let init_extra () = { - internalReferences = Hashtbl.create 10; - externalReferences = Hashtbl.create 10; - fileReferences = Hashtbl.create 10; - locItems = []; + internal_references = Hashtbl.create 10; + external_references = Hashtbl.create 10; + file_references = Hashtbl.create 10; + loc_items = []; } type state = { - packagesByRoot: (string, package) Hashtbl.t; - rootForUri: (Uri.t, string) Hashtbl.t; - cmtCache: (filePath, File.t) Hashtbl.t; + 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 = { - packagesByRoot = Hashtbl.create 1; - rootForUri = Hashtbl.create 30; - cmtCache = Hashtbl.create 30; + packages_by_root = Hashtbl.create 1; + root_for_uri = Hashtbl.create 30; + cmt_cache = Hashtbl.create 30; } -let locKindToString = function - | LocalReference (_, tip) -> "(LocalReference " ^ Tip.toString tip ^ ")" +let loc_kind_to_string = function + | LocalReference (_, tip) -> "(LocalReference " ^ Tip.to_string tip ^ ")" | GlobalReference _ -> "GlobalReference" | NotFound -> "NotFound" - | Definition (_, tip) -> "(Definition " ^ Tip.toString tip ^ ")" + | Definition (_, tip) -> "(Definition " ^ Tip.to_string tip ^ ")" -let locTypeToString = function - | Typed (name, e, locKind) -> - "Typed " ^ name ^ " " ^ Shared.typeToString e ^ " " - ^ locKindToString locKind +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 locKind -> "LModule " ^ locKindToString locKind + | LModule loc_kind -> "LModule " ^ loc_kind_to_string loc_kind | 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 +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 (locTypeToString locType) + pos2.character (loc_type_to_string loc_type) (* needed for debugging *) -let _ = locItemToString +let _ = loc_item_to_string module Completable = struct (* Completion context *) - type completionContext = Type | Value | Module | Field | ValueOrField + type completion_context = Type | Value | Module | Field | ValueOrField - type argumentLabel = - | Unlabelled of {argumentPosition: int} + type argument_label = + | Unlabelled of {argument_position: int} | Labelled of string | Optional of string (** Additional context for nested completion where needed. *) - type nestedContext = - | RecordField of {seenFields: string list} + 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 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} + 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 nestedPathToString p = + let nested_path_to_string p = match p with - | NTupleItem {itemNum} -> "tuple($" ^ string_of_int itemNum ^ ")" - | NFollowRecordField {fieldName} -> "recordField(" ^ fieldName ^ ")" + | NTupleItem {item_num} -> "tuple($" ^ string_of_int item_num ^ ")" + | NFollowRecordField {field_name} -> "recordField(" ^ field_name ^ ")" | NRecordBody _ -> "recordBody" - | NVariantPayload {constructorName; itemNum} -> - "variantPayload::" ^ constructorName ^ "($" ^ string_of_int itemNum ^ ")" - | NPolyvariantPayload {constructorName; itemNum} -> - "polyvariantPayload::" ^ constructorName ^ "($" ^ string_of_int itemNum + | 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 contextPath = + type context_path = | CPString - | CPArray of contextPath option + | CPArray of context_path option | CPInt | CPFloat | CPBool - | CPOption of contextPath - | CPApply of contextPath * Asttypes.arg_label list + | CPOption of context_path + | CPApply of context_path * Asttypes.arg_label list | CPId of { path: string list; - completionContext: completionContext; + completion_context: completion_context; loc: Location.t; } | CPField of { - contextPath: contextPath; - fieldName: string; - posOfDot: (int * int) option; - exprLoc: Location.t; - inJsx: bool; + 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 contextPath * string - | CPAwait of contextPath + | CPObj of context_path * string + | CPAwait of context_path | CPPipe of { synthetic: bool; (** Whether this pipe completion is synthetic. *) - contextPath: contextPath; + context_path: context_path; id: string; - inJsx: bool; (** Whether this pipe was found in a JSX context. *) - lhsLoc: Location.t; + 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 contextPath list + | CTuple of context_path list | CArgument of { - functionContextPath: contextPath; - argumentLabel: argumentLabel; + function_context_path: context_path; + argument_label: argument_label; } | CJsxPropValue of { - pathToComponent: string list; - propName: string; - emptyJsxPropNameHint: string option; + 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 {rootCtxPath: contextPath; nested: nestedPath list} + | 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 patternMode = Default | Destructuring + type pattern_mode = Default | Destructuring - type decoratorPayload = + type decorator_payload = | Module of string - | ModuleWithImportAttributes of {nested: nestedPath list; prefix: string} - | JsxConfig of {nested: nestedPath list; prefix: 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 decoratorPayload + | CdecoratorPayload of decorator_payload | CextensionNode of string (** e.g. %todo *) - | CnamedArg of contextPath * string * string list + | 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 contextPath + | 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 contextPathToString = function + let rec context_path_to_string = function | CPString -> "string" | CPInt -> "int" | CPFloat -> "float" | CPBool -> "bool" - | CPAwait ctxPath -> "await " ^ contextPathToString ctxPath - | CPOption ctxPath -> "option<" ^ contextPathToString ctxPath ^ ">" + | CPAwait ctx_path -> "await " ^ context_path_to_string ctx_path + | CPOption ctx_path -> "option<" ^ context_path_to_string ctx_path ^ ">" | CPApply (cp, labels) -> - contextPathToString cp ^ "(" + context_path_to_string cp ^ "(" ^ (labels |> List.map (function | Asttypes.Nolabel -> "Nolabel" @@ -711,43 +711,43 @@ module Completable = struct | Optional {txt} -> "?" ^ txt) |> String.concat ", ") ^ ")" - | CPArray (Some ctxPath) -> "array<" ^ contextPathToString ctxPath ^ ">" + | CPArray (Some ctx_path) -> "array<" ^ context_path_to_string ctx_path ^ ">" | 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 + | 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 inJsx then " <>" else "" - | CTuple ctxPaths -> + ^ if in_jsx then " <>" else "" + | CTuple ctx_paths -> "CTuple(" - ^ (ctxPaths |> List.map contextPathToString |> String.concat ", ") + ^ (ctx_paths |> List.map context_path_to_string |> String.concat ", ") ^ ")" - | CArgument {functionContextPath; argumentLabel} -> + | CArgument {function_context_path; argument_label} -> "CArgument " - ^ contextPathToString functionContextPath + ^ context_path_to_string function_context_path ^ "(" - ^ (match argumentLabel with - | Unlabelled {argumentPosition} -> "$" ^ string_of_int argumentPosition + ^ (match argument_label with + | Unlabelled {argument_position} -> "$" ^ string_of_int argument_position | Labelled name -> "~" ^ name | Optional name -> "~" ^ name ^ "=?") ^ ")" - | CJsxPropValue {pathToComponent; propName} -> - "CJsxPropValue " ^ (pathToComponent |> list) ^ " " ^ propName - | CPatternPath {rootCtxPath; nested} -> + | CJsxPropValue {path_to_component; prop_name} -> + "CJsxPropValue " ^ (path_to_component |> list) ^ " " ^ prop_name + | CPatternPath {root_ctx_path; nested} -> "CPatternPath(" - ^ contextPathToString rootCtxPath + ^ context_path_to_string root_ctx_path ^ ")" ^ "->" ^ (nested - |> List.map (fun nestedPath -> nestedPathToString nestedPath) + |> List.map (fun nested_path -> nested_path_to_string nested_path) |> String.concat "->") | CTypeAtPos _loc -> "CTypeAtPos()" - let toString = function - | Cpath cp -> "Cpath " ^ contextPathToString cp + 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 ^ ")" @@ -756,37 +756,37 @@ module Completable = struct | CdecoratorPayload (JsxConfig _) -> "JsxConfig" | CnamedArg (cp, s, sl2) -> "CnamedArg(" - ^ (cp |> contextPathToString) + ^ (cp |> context_path_to_string) ^ ", " ^ str s ^ ", " ^ (sl2 |> list) ^ ")" | Cnone -> "Cnone" | Cjsx (sl1, s, sl2) -> "Cjsx(" ^ (sl1 |> list) ^ ", " ^ str s ^ ", " ^ (sl2 |> list) ^ ")" - | Cpattern {contextPath; nested; prefix} -> ( + | Cpattern {context_path; nested; prefix} -> ( "Cpattern " - ^ contextPathToString contextPath + ^ context_path_to_string context_path ^ (if prefix = "" then "" else "=" ^ prefix) ^ match nested with | [] -> "" - | nestedPaths -> + | nested_paths -> "->" - ^ (nestedPaths - |> List.map (fun nestedPath -> nestedPathToString nestedPath) + ^ (nested_paths + |> List.map (fun nested_path -> nested_path_to_string nested_path) |> String.concat ", ")) - | Cexpression {contextPath; nested; prefix} -> ( + | Cexpression {context_path; nested; prefix} -> ( "Cexpression " - ^ contextPathToString contextPath + ^ context_path_to_string context_path ^ (if prefix = "" then "" else "=" ^ prefix) ^ match nested with | [] -> "" - | nestedPaths -> + | nested_paths -> "->" - ^ (nestedPaths - |> List.map (fun nestedPath -> nestedPathToString nestedPath) + ^ (nested_paths + |> List.map (fun nested_path -> nested_path_to_string nested_path) |> String.concat ", ")) - | CexhaustiveSwitch {contextPath} -> - "CexhaustiveSwitch " ^ contextPathToString contextPath + | CexhaustiveSwitch {context_path} -> + "CexhaustiveSwitch " ^ context_path_to_string context_path | ChtmlElement {prefix} -> "ChtmlElement <" ^ prefix end @@ -797,7 +797,7 @@ module ScopeTypes = struct | Module of string * Location.t | Open of string list | Type of string * Location.t - | Value of string * Location.t * Completable.contextPath option * item list + | Value of string * Location.t * Completable.context_path option * item list | Include of string * Location.t let item_to_string = function @@ -821,56 +821,56 @@ module Completion = struct | Label of string | Type of Type.t | Constructor of Constructor.t * string - | PolyvariantConstructor of polyVariantConstructor * string + | PolyvariantConstructor of poly_variant_constructor * string | Field of field * string | FileModule of string | Snippet of string - | ExtractedType of completionType * [`Value | `Type] - | FollowContextPath of Completable.contextPath * ScopeTypes.item list + | ExtractedType of completion_type * [`Value | `Type] + | FollowContextPath of Completable.context_path * ScopeTypes.item list type t = { name: string; - sortText: string option; - insertText: string option; - filterText: string option; - insertTextFormat: Lsp.Types.InsertTextFormat.t option; + sort_text: string option; + insert_text: string option; + filter_text: string option; + insert_text_format: Lsp.Types.InsertTextFormat.t option; env: QueryEnv.t; deprecated: string option; docstring: string list; kind: kind; detail: string option; - typeArgContext: typeArgContext option; + type_arg_context: type_arg_context option; data: (string * string) list option; - additionalTextEdits: Lsp.Types.TextEdit.t 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) ?additionalTextEdits ?data ?typeArgContext - ?(includesSnippets = false) ?insertText ~kind ~env ?sortText ?deprecated - ?filterText ?detail ?(docstring = []) name = + 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; - sortText; - insertText; - insertTextFormat = - (if includesSnippets then Some Lsp.Types.InsertTextFormat.Snippet + sort_text; + insert_text; + insert_text_format = + (if includes_snippets then Some Lsp.Types.InsertTextFormat.Snippet else None); - filterText; + filter_text; detail; - typeArgContext; + type_arg_context; data; - additionalTextEdits; + 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 kindToLspCompletionItem kind = + let kind_to_lsp_completion_item kind = match kind with | Module _ -> Lsp.Types.CompletionItemKind.Module | FileModule _ -> Lsp.Types.CompletionItemKind.Module @@ -884,54 +884,54 @@ module Completion = struct | Snippet _ | FollowContextPath _ -> Lsp.Types.CompletionItemKind.Snippet end -let kindFromInnerType (t : innerType) = +let kind_from_inner_type (t : inner_type) = match t with - | ExtractedType extractedType -> - Completion.ExtractedType (extractedType, `Value) + | ExtractedType extracted_type -> + Completion.ExtractedType (extracted_type, `Value) | TypeExpr typ -> Value typ module CursorPosition = struct type t = NoCursor | HasCursor | EmptyLoc - let classifyLoc loc ~pos = - if loc |> Loc.hasPos ~pos then HasCursor + 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 classifyLocationLoc (loc : 'a Location.loc) ~pos = + 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 classifyPositions pos ~posStart ~posEnd = - if posStart <= pos && pos <= posEnd then HasCursor - else if posEnd = (Location.none |> Loc.end_) then EmptyLoc + 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 locHasCursor loc ~pos = loc |> classifyLoc ~pos = HasCursor + let loc_has_cursor loc ~pos = loc |> classify_loc ~pos = HasCursor - let locIsEmpty loc ~pos = loc |> classifyLoc ~pos = EmptyLoc + let loc_is_empty loc ~pos = loc |> classify_loc ~pos = EmptyLoc end type labelled = { name: string; opt: bool; - posStart: int * int; - posEnd: int * int; + pos_start: int * int; + pos_end: int * int; } type label = labelled option type arg = {label: label; exp: Parsetree.expression} -let extractExpApplyArgs ~args = - let rec processArgs ~acc args = +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 namedArgLoc = if loc = Location.none then None else Some loc in - match namedArgLoc with + let named_arg_loc = if loc = Location.none then None else Some loc in + match named_arg_loc with | Some loc -> let labelled = { @@ -940,15 +940,15 @@ let extractExpApplyArgs ~args = (match label with | Optional _ -> true | _ -> false); - posStart = Loc.start loc; - posEnd = Loc.end_ loc; + pos_start = Loc.start loc; + pos_end = Loc.end_ loc; } in - processArgs ~acc:({label = Some labelled; exp = e} :: acc) rest - | None -> processArgs ~acc rest) + 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 processArgs ~acc rest - else processArgs ~acc:({label = None; exp = e} :: acc) 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 |> processArgs ~acc:[] + args |> process_args ~acc:[] diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/SignatureHelp.ml index 27a53a0ccb..cf5f51c2e6 100644 --- a/analysis/src/SignatureHelp.ml +++ b/analysis/src/SignatureHelp.ml @@ -1,61 +1,61 @@ open SharedTypes -type cursorAtArg = Unlabelled of int | Labelled of string +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 |> SharedTypes.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 = QueryEnv.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 + TypeUtils.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 + CompletionFrontEnd.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, + |> CompletionBackEnd.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 + TypeUtils.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 TypeUtils.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 + (TypeUtils.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 + (TypeUtils.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 + (TypeUtils.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 +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 |> CursorPosition.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,52 @@ 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 |> CursorPosition.classify_positions ~pos_start ~pos_end with | HasCursor -> Some (Labelled name) | NoCursor | EmptyLoc -> ( @@ -328,7 +328,7 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads match ( arg.exp.pexp_desc, arg.exp.pexp_loc - |> CursorPosition.classifyLoc ~pos:posBeforeCursor ) + |> CursorPosition.classify_loc ~pos:pos_before_cursor ) with | Pexp_extension ({txt = "rescript.exprhole"}, _), _ | _, HasCursor -> @@ -340,9 +340,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 +353,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 +377,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 + || CompletionExpressions.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 +422,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 +440,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,7 +483,7 @@ 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) @@ -491,20 +491,20 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads | 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 @@ -513,19 +513,19 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads (`MarkupContent (Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown ~value:docs))) - ~activeParameter: - (match activeParameter with + ~active_parameter: + (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 + ~active_parameter: + (match active_parameter with | None -> Some (-1) - | activeParameter -> activeParameter) - ~activeSignature:0 () + | active_parameter -> active_parameter) + ~active_signature:0 () in Some signature | _ -> None) @@ -540,19 +540,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 = QueryEnv.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 +561,77 @@ 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 +639,41 @@ 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 +681,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 +721,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 +734,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 +744,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 +767,11 @@ let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads (`MarkupContent (Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown ~value:docs))) - ~activeParameter:(Some activeParameter) () + ~active_parameter:(Some active_parameter) () in let signature = Lsp.Types.SignatureHelp.create ~signatures:[signatures] - ~activeParameter:(Some activeParameter) ~activeSignature:0 () + ~active_parameter:(Some active_parameter) ~active_signature:0 () in Some signature)) | _ -> None)) diff --git a/analysis/src/StructureUtils.ml b/analysis/src/StructureUtils.ml index 2421f92a4b..97c1d17b2d 100644 --- a/analysis/src/StructureUtils.ml +++ b/analysis/src/StructureUtils.ml @@ -1,10 +1,10 @@ open SharedTypes 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/TypeUtils.ml b/analysis/src/TypeUtils.ml index fa85e92e41..f980310adf 100644 --- a/analysis/src/TypeUtils.ml +++ b/analysis/src/TypeUtils.ml @@ -1,60 +1,60 @@ open SharedTypes -let modulePathFromEnv env = - let moduleName = env.QueryEnv.file.moduleName in - let transformedModuleName = +let module_path_from_env env = + let module_name = env.QueryEnv.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 moduleName '-' with - | None -> moduleName + match String.rindex_opt module_name '-' with + | None -> module_name | Some i -> let namespace = - String.sub moduleName (i + 1) (String.length moduleName - i - 1) + String.sub module_name (i + 1) (String.length module_name - i - 1) in - let module_ = String.sub moduleName 0 i in + let module_ = String.sub module_name 0 i in namespace ^ "." ^ module_ in - transformedModuleName :: List.rev env.pathRev + transformed_module_name :: List.rev env.path_rev -let fullTypeIdFromDecl ~env ~name ~modulePath = - env.QueryEnv.file.moduleName :: ModulePath.toPath modulePath name +let full_type_id_from_decl ~env ~name ~module_path = + env.QueryEnv.file.module_name :: ModulePath.to_path module_path name |> String.concat "." -let debugLogTypeArgContext {env; typeArgs; typeParams} = +let debug_log_type_arg_context {env; type_args; type_params} = 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 ", ") + (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 hasTvar (ty : Types.type_expr) : bool = +let rec has_tvar (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 + | 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 -> hasTvar ty - | Tsubst ty -> hasTvar ty + | Tlink ty -> has_tvar ty + | Tsubst ty -> has_tvar ty | Tvariant {row_fields; _} -> List.exists (function - | _, Types.Rpresent (Some ty) -> hasTvar ty - | _, Reither (_, tyl, _, _) -> List.exists hasTvar tyl + | _, Types.Rpresent (Some ty) -> has_tvar ty + | _, Reither (_, tyl, _, _) -> List.exists has_tvar tyl | _ -> false) row_fields | Tunivar _ -> true - | Tpoly (ty, tyl) -> hasTvar ty || List.exists hasTvar tyl - | Tpackage (_, _, tyl) -> List.exists hasTvar tyl + | Tpoly (ty, tyl) -> has_tvar ty || List.exists has_tvar tyl + | Tpackage (_, _, tyl) -> List.exists has_tvar 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 +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 pathFromTypeExpr (t : Types.type_expr) = +let path_from_type_expr (t : Types.type_expr) = match t.desc with | Tconstr (path, _typeArgs, _) | Tlink {desc = Tconstr (path, _typeArgs, _)} @@ -63,77 +63,77 @@ let pathFromTypeExpr (t : Types.type_expr) = Some path | _ -> None -let printRecordFromFields ?name (fields : field list) = +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.typeToString f.typ) + |> List.map (fun f -> f.fname.txt ^ ": " ^ Shared.type_to_string f.typ) |> String.concat ", ") ^ "}" -let rec extractedTypeToString ?(nameOnly = false) ?(inner = false) = function - | Tuple (_, _, typ) | Tpolyvariant {typeExpr = typ} | Tfunction {typ} -> +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 |> pathFromTypeExpr |> Option.get |> SharedTypes.pathIdentToString + try typ |> path_from_type_expr |> Option.get |> SharedTypes.path_ident_to_string with _ -> "" - else Shared.typeToString typ + else Shared.type_to_string typ | Trecord {definition; fields} -> let name = match definition with | `TypeExpr typ -> ( try - typ |> pathFromTypeExpr |> Option.get |> SharedTypes.pathIdentToString + typ |> path_from_type_expr |> Option.get |> SharedTypes.path_ident_to_string with _ -> "") | `NameOnly name -> name in - if inner || nameOnly then name else printRecordFromFields ~name fields + if inner || name_only then name else print_record_from_fields ~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 + | 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 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 + | 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 getExtractedType maybeRes = - match maybeRes with +let get_extracted_type maybe_res = + match maybe_res with | None -> None - | Some (extractedType, _) -> Some extractedType + | Some (extracted_type, _) -> Some extracted_type -let instantiateType ~typeParams ~typeArgs (t : Types.type_expr) = - if typeParams = [] || typeArgs = [] then t +let instantiate_type ~type_params ~type_args (t : Types.type_expr) = + if type_params = [] || type_args = [] then t else - let rec applySub tp ta t = + let rec apply_sub tp ta t = match (tp, ta) with - | t1 :: tRest1, t2 :: tRest2 -> - if t1 = t then t2 else applySub tRest1 tRest2 t + | 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 _ -> applySub typeParams typeArgs 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 (rowDesc rd)} + | Tvariant rd -> {t with desc = Tvariant (row_desc rd)} | Tnil -> t | Tarrow (arg, ret, c, arity) -> { @@ -147,9 +147,9 @@ let instantiateType ~typeParams ~typeArgs (t : Types.type_expr) = | 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) = + and row_desc (rd : Types.row_desc) = let row_fields = - rd.row_fields |> List.map (fun (l, rf) -> (l, rowField rf)) + rd.row_fields |> List.map (fun (l, rf) -> (l, row_field rf)) in let row_more = loop rd.row_more in let row_name = @@ -158,7 +158,7 @@ let instantiateType ~typeParams ~typeArgs (t : Types.type_expr) = | Some (p, tl) -> Some (p, tl |> List.map loop) in {rd with row_fields; row_more; row_name} - and rowField (rf : Types.row_field) = + and row_field (rf : Types.row_field) = match rf with | Rpresent None -> rf | Rpresent (Some t) -> Rpresent (Some (loop t)) @@ -167,29 +167,29 @@ let instantiateType ~typeParams ~typeArgs (t : Types.type_expr) = in loop t -let instantiateType2 ?(typeArgContext : typeArgContext option) +let instantiate_type2 ?(type_arg_context : type_arg_context option) (t : Types.type_expr) = - match typeArgContext with - | None | Some {typeArgs = []} | Some {typeParams = []} -> t - | Some {typeArgs; typeParams} -> - let rec applySub tp ta name = + 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 varName)} :: tRest1, t2 :: tRest2 -> - if varName = name then t2 else applySub tRest1 tRest2 name - | _ :: tRest1, _ :: tRest2 -> applySub tRest1 tRest2 name + | {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) -> applySub typeParams typeArgs name + | 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 (rowDesc rd)} + | Tvariant rd -> {t with desc = Tvariant (row_desc rd)} | Tnil -> t | Tarrow (arg, ret, c, arity) -> { @@ -203,9 +203,9 @@ let instantiateType2 ?(typeArgContext : typeArgContext option) | 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) = + and row_desc (rd : Types.row_desc) = let row_fields = - rd.row_fields |> List.map (fun (l, rf) -> (l, rowField rf)) + rd.row_fields |> List.map (fun (l, rf) -> (l, row_field rf)) in let row_more = loop rd.row_more in let row_name = @@ -214,7 +214,7 @@ let instantiateType2 ?(typeArgContext : typeArgContext option) | Some (p, tl) -> Some (p, tl |> List.map loop) in {rd with row_fields; row_more; row_name} - and rowField (rf : Types.row_field) = + and row_field (rf : Types.row_field) = match rf with | Rpresent None -> rf | Rpresent (Some t) -> Rpresent (Some (loop t)) @@ -223,78 +223,78 @@ let instantiateType2 ?(typeArgContext : typeArgContext option) in loop t -let rec extractRecordType ~env ~package (t : Types.type_expr) = +let rec extract_record_type ~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 + | 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 typeParams = typ.item.decl.type_params in + let type_params = typ.item.decl.type_params in let fields = fields |> List.map (fun field -> - let fieldTyp = - field.typ |> instantiateType ~typeParams ~typeArgs + let field_typ = + field.typ |> instantiate_type ~type_params ~type_args in - {field with typ = fieldTyp}) + {field with typ = field_typ}) in Some (env, fields, typ) | Some ( env, - {item = {decl = {type_manifest = Some t1; type_params = typeParams}}} + {item = {decl = {type_manifest = Some t1; type_params = type_params}}} ) -> - let t1 = t1 |> instantiateType ~typeParams ~typeArgs in - extractRecordType ~env ~package t1 + let t1 = t1 |> instantiate_type ~type_params ~type_args in + extract_record_type ~env ~package t1 | _ -> None) | _ -> None -let rec extractObjectType ~env ~package (t : Types.type_expr) = +let rec extract_object_type ~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 + | 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 = typeParams}}} + {item = {decl = {type_manifest = Some t1; type_params = type_params}}} ) -> - let t1 = t1 |> instantiateType ~typeParams ~typeArgs in - extractObjectType ~env ~package t1 + let t1 = t1 |> instantiate_type ~type_params ~type_args in + extract_object_type ~env ~package t1 | _ -> None) | _ -> None -let extractFunctionType ~env ~package ?(digInto = true) typ = +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, tRet, _, _) -> loop ~env ((arg.lbl, arg.typ) :: acc) tRet - | Tconstr (path, typeArgs, _) when digInto -> ( - match References.digConstructor ~env ~package path with + | 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 = typeParams}}; + item = {decl = {type_manifest = Some t1; type_params = type_params}}; } ) -> - let t1 = t1 |> instantiateType ~typeParams ~typeArgs in + 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 extractFunctionTypeWithEnv ~env ~package 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, tRet, _, _) -> loop ~env ((arg.lbl, arg.typ) :: acc) tRet - | Tconstr (path, typeArgs, _) -> ( - match References.digConstructor ~env ~package path with + | 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 = typeParams}}; + item = {decl = {type_manifest = Some t1; type_params = type_params}}; } ) -> - let t1 = t1 |> instantiateType ~typeParams ~typeArgs in + 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)) @@ -302,91 +302,91 @@ let extractFunctionTypeWithEnv ~env ~package typ = in loop ~env [] typ -let maybeSetTypeArgCtx ?typeArgContextFromTypeManifest ~typeParams ~typeArgs env +let maybe_set_type_arg_ctx ?type_arg_context_from_type_manifest ~type_params ~type_args env = - match typeArgContextFromTypeManifest with - | Some typeArgContextFromTypeManifest -> Some typeArgContextFromTypeManifest + match type_arg_context_from_type_manifest with + | Some type_arg_context_from_type_manifest -> Some type_arg_context_from_type_manifest | None -> - let typeArgContext = - if List.length typeParams > 0 then Some {env; typeParams; typeArgs} + let type_arg_context = + if List.length type_params > 0 then Some {env; type_params; type_args} else None in - (match typeArgContext with + (match type_arg_context with | None -> () - | Some typeArgContext -> + | Some type_arg_context -> if Debug.verbose () then Printf.printf "[#type_arg_ctx]--> setting new type arg ctx: %s" - (debugLogTypeArgContext typeArgContext)); - typeArgContext + (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 extractFunctionType2 ?typeArgContext ~env ~package typ = - let rec loop ?typeArgContext ~env acc (t : Types.type_expr) = +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 ?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 + | 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 = typeParams}}; + item = {decl = {type_manifest = Some t1; type_params = type_params}}; } ) -> - let typeArgContext = maybeSetTypeArgCtx ~typeParams ~typeArgs env in - loop ?typeArgContext ~env acc t1 - | _ -> (List.rev acc, t, typeArgContext)) - | _ -> (List.rev acc, t, typeArgContext) + 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 ?typeArgContext ~env [] typ + loop ?type_arg_context ~env [] typ -let rec extractType ?(printOpeningDebug = true) - ?(typeArgContext : typeArgContext option) - ?(typeArgContextFromTypeManifest : typeArgContext option) ~env ~package +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 maybeSetTypeArgCtx = maybeSetTypeArgCtx ?typeArgContextFromTypeManifest in - if Debug.verbose () && printOpeningDebug then + 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.typeToString t) (Debug.debugPrintEnv env) - (Option.is_some typeArgContext); - (match typeArgContext with + (Shared.type_to_string t) (Debug.debug_print_env env) + (Option.is_some type_arg_context); + (match type_arg_context with | None -> () - | Some typeArgContext -> - if Debug.verbose () && printOpeningDebug then + | Some type_arg_context -> + if Debug.verbose () && print_opening_debug then Printf.printf "[extract_type]--> %s" - (debugLogTypeArgContext typeArgContext)); - let instantiateType = instantiateType2 in + (debug_log_type_arg_context type_arg_context)); + let instantiate_type = instantiate_type2 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) + 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, typeArgContext) + Some (Tbool env, type_arg_context) | Tconstr (Path.Pident {name = "string"}, [], _) -> - Some (Tstring env, typeArgContext) + Some (Tstring env, type_arg_context) | Tconstr (Path.Pident {name = "exn"}, [], _) -> - Some (Texn env, typeArgContext) + Some (Texn env, type_arg_context) | Tarrow _ -> ( - match extractFunctionType2 ?typeArgContext t ~env ~package with - | args, tRet, typeArgContext when args <> [] -> - Some (Tfunction {env; args; typ = t; returnType = tRet}, typeArgContext) + 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, typeArgs, _) -> ( + | Tconstr (path, type_args, _) -> ( 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 + (Path.name path) (Debug.debug_print_env env); + match References.dig_constructor ~env ~package path with | Some - ( envFromDeclaration, + ( env_from_declaration, {item = {decl = {type_manifest = Some t1; type_params}}} ) -> if Debug.verbose () then print_endline "[extract_type]--> found type manifest"; @@ -394,41 +394,41 @@ let rec extractType ?(printOpeningDebug = true) (* 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 + let type_arg_context = + maybe_set_type_arg_ctx ~type_params:type_params ~type_args env in t1 - |> extractType ?typeArgContextFromTypeManifest:typeArgContext - ~env:envFromDeclaration ~package - | Some (envFromItem, {name; item = {decl; kind = Type.Variant constructors}}) + |> 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 typeArgContext = - maybeSetTypeArgCtx ~typeParams:decl.type_params ~typeArgs env + let type_arg_context = + maybe_set_type_arg_ctx ~type_params:decl.type_params ~type_args env in Some ( Tvariant { - env = envFromItem; + env = env_from_item; constructors; - variantName = name.txt; - variantDecl = decl; + variant_name = name.txt; + variant_decl = decl; }, - typeArgContext ) - | Some (envFromDeclaration, {item = {kind = Record fields; 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 typeArgContext = - maybeSetTypeArgCtx ~typeParams:decl.type_params ~typeArgs env + let type_arg_context = + maybe_set_type_arg_ctx ~type_params:decl.type_params ~type_args 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 + ( 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_params ~type_args env in - Some (TtypeT {env = envFromDeclaration; path}, typeArgContext) + Some (TtypeT {env = env_from_declaration; path}, type_arg_context) | None -> if Debug.verbose () then print_endline "[extract_type]--> found nothing when digging"; @@ -437,126 +437,126 @@ let rec extractType ?(printOpeningDebug = true) if Debug.verbose () then print_endline "[extract_type]--> found something else when digging"; None) - | Ttuple expressions -> Some (Tuple (env, expressions, t), typeArgContext) + | Ttuple expressions -> Some (Tuple (env, expressions, t), type_arg_context) | Tvariant {row_fields} -> let constructors = row_fields |> List.map (fun (label, field) -> { name = label; - displayName = Utils.printMaybeExoticIdent ~allowUident:true 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 typeExpr) -> ( - match typeExpr.desc with + | Types.Rpresent (Some type_expr) -> ( + match type_expr.desc with | Ttuple args -> args - | _ -> [typeExpr]) + | _ -> [type_expr]) | _ -> []); }) in - Some (Tpolyvariant {env; constructors; typeExpr = t}, typeArgContext) - | Tvar (Some varName) -> ( + 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" - varName - (match typeArgContext with + var_name + (match type_arg_context with | None -> "with no type args ctx\n" - | Some typeArgContext -> - Printf.sprintf "with %s" (debugLogTypeArgContext typeArgContext)); + | Some type_arg_context -> + Printf.sprintf "with %s" (debug_log_type_arg_context type_arg_context)); - let instantiated = t |> instantiateType ?typeArgContext in - let rec extractInstantiated t = + 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, []) -> extractInstantiated t1 + | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> extract_instantiated t1 | _ -> t in - match extractInstantiated instantiated with + match extract_instantiated instantiated with | {desc = Tvar _} -> if Debug.verbose () then Printf.printf "[extract_type]--> could not instantiate '%s. Skipping.\n" - varName; + var_name; None | _ -> if Debug.verbose () then Printf.printf "[extract_type]--> SUCCEEDED instantiation, new type is: %s\n" - (Shared.typeToString instantiated); + (Shared.type_to_string instantiated); (* Use the env from instantiation if we managed to instantiate the type param *) - let nextEnv = - match typeArgContext with + let next_env = + match type_arg_context with | Some {env} -> env | None -> env in - instantiated |> extractType ?typeArgContext ~env:nextEnv ~package) + instantiated |> extract_type ?type_arg_context ~env:next_env ~package) | _ -> if Debug.verbose () then print_endline "[extract_type]--> miss"; None -let isFunctionType ~env ~package t = - match extractType ~env ~package t with +let is_function_type ~env ~package t = + match extract_type ~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 +let find_return_type_of_function_at_loc loc ~(env : QueryEnv.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 digToRelevantTemplateNameType ~env ~package ?(suffix = "") +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, []) -> - digToRelevantTemplateNameType ~suffix ~env ~package t1 + dig_to_relevant_template_name_type ~suffix ~env ~package t1 | Tconstr (Path.Pident {name = "option"}, [t1], _) -> - digToRelevantTemplateNameType ~suffix ~env ~package t1 + dig_to_relevant_template_name_type ~suffix ~env ~package t1 | Tconstr (Path.Pident {name = "array"}, [t1], _) -> - digToRelevantTemplateNameType ~suffix:"s" ~env ~package t1 + dig_to_relevant_template_name_type ~suffix:"s" ~env ~package t1 | Tconstr (path, _, _) -> ( - match References.digConstructor ~env ~package path with + match References.dig_constructor ~env ~package path with | Some (env, {item = {decl = {type_manifest = Some typ}}}) -> - digToRelevantTemplateNameType ~suffix ~env ~package typ + dig_to_relevant_template_name_type ~suffix ~env ~package typ | _ -> (t, suffix, env)) | _ -> (t, suffix, env) -let rec resolveTypeForPipeCompletion ~env ~package ~lhsLoc ~full +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 typFromLoc = + let typ_from_loc = match t with | {Types.desc = Tvar _} -> - findReturnTypeOfFunctionAtLoc lhsLoc ~env ~full ~debug:false + find_return_type_of_function_at_loc lhs_loc ~env ~full ~debug:false | _ -> None in - match typFromLoc with + match typ_from_loc with | Some ({desc = Tvar _} as t) -> (env, t) - | Some typFromLoc -> - typFromLoc |> resolveTypeForPipeCompletion ~lhsLoc ~env ~package ~full + | Some typ_from_loc -> + typ_from_loc |> resolve_type_for_pipe_completion ~lhs_loc ~env ~package ~full | None -> - let rec digToRelevantType ~env ~package (t : Types.type_expr) = + let rec dig_to_relevant_type ~env ~package (t : Types.type_expr) = match t.desc with | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> - digToRelevantType ~env ~package 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.digConstructor ~env ~package path with + match References.dig_constructor ~env ~package path with | Some (env, {item = {decl = {type_manifest = Some typ}}}) -> - digToRelevantType ~env ~package typ + dig_to_relevant_type ~env ~package typ | _ -> (env, t)) | _ -> (env, t) in - digToRelevantType ~env ~package t + dig_to_relevant_type ~env ~package t -let extractTypeFromResolvedType (typ : Type.t) ~env ~full = +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 -> @@ -564,28 +564,28 @@ let extractTypeFromResolvedType (typ : Type.t) ~env ~full = | Variant constructors -> Some (Tvariant - {env; constructors; variantName = typ.name; variantDecl = typ.decl}) + {env; constructors; variant_name = typ.name; variant_decl = typ.decl}) | Abstract _ | Open -> ( match typ.decl.type_manifest with | None -> None - | Some t -> t |> extractType ~env ~package:full.package |> getExtractedType) + | 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 resolveNested ?typeArgContext ~env ~full ~nested ?ctx - (typ : completionType) = - let extractType = extractType ?typeArgContext in +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.debugPrintEnv env) - (Option.is_some typeArgContext); - (match typeArgContext with + (Debug.debug_print_env env) + (Option.is_some type_arg_context); + (match type_arg_context with | None -> () - | Some typeArgContext -> + | Some type_arg_context -> if Debug.verbose () then - Printf.printf "[nested]--> %s" (debugLogTypeArgContext typeArgContext)); + Printf.printf "[nested]--> %s" (debug_log_type_arg_context type_arg_context)); match nested with | [] -> if Debug.verbose () then @@ -595,31 +595,31 @@ let rec resolveNested ?typeArgContext ~env ~full ~nested ?ctx 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, _) -> ( + | 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 tupleItems itemNum with + 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 - |> extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (typ, typeArgContext) -> - typ |> resolveNested ?typeArgContext ~env ~full ~nested)) - | ( NFollowRecordField {fieldName}, + |> 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 = fieldName) + |> List.find_opt (fun (field : field) -> field.fname.txt = field_name) with | None -> if Debug.verbose () then @@ -628,82 +628,82 @@ let rec resolveNested ?typeArgContext ~env ~full ~nested ?ctx | 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 + 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.typeToString typ) (Debug.debugPrintEnv env); + (Shared.type_to_string typ) (Debug.debug_print_env env); typ - |> extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (typ, typeArgContext) -> + |> extract_type ~env ~package:full.package + |> Utils.Option.flat_map (fun (typ, type_arg_context) -> typ - |> resolveNested ?typeArgContext ~ctx:(Rfield fieldName) ~env + |> resolve_nested ?type_arg_context ~ctx:(Rfield field_name) ~env ~full ~nested)) - | NRecordBody {seenFields}, Trecord {env; definition = `TypeExpr typeExpr} + | NRecordBody {seen_fields}, Trecord {env; definition = `TypeExpr type_expr} -> - typeExpr - |> extractType ~env ~package:full.package - |> Option.map (fun (typ, typeArgContext) -> + type_expr + |> extract_type ~env ~package:full.package + |> Option.map (fun (typ, type_arg_context) -> ( typ, env, - Some (Completable.RecordField {seenFields}), - typeArgContext )) - | ( NRecordBody {seenFields}, - (Trecord {env; definition = `NameOnly _} as extractedType) ) -> + Some (Completable.RecordField {seen_fields}), + type_arg_context )) + | ( NRecordBody {seen_fields}, + (Trecord {env; definition = `NameOnly _} as extracted_type) ) -> Some - ( extractedType, + ( extracted_type, env, - Some (Completable.RecordField {seenFields}), - typeArgContext ) - | NRecordBody {seenFields}, TinlineRecord {env; fields} -> + Some (Completable.RecordField {seen_fields}), + type_arg_context ) + | NRecordBody {seen_fields}, TinlineRecord {env; fields} -> Some ( TinlineRecord {fields; env}, env, - Some (Completable.RecordField {seenFields}), - typeArgContext ) - | ( NVariantPayload {constructorName = "Some"; itemNum = 0}, + 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 |> resolveNested ?typeArgContext ~env ~full ~nested - | ( NVariantPayload {constructorName = "Some"; itemNum = 0}, + 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 - |> extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (t, typeArgContext) -> - t |> resolveNested ?typeArgContext ~env ~full ~nested) - | NVariantPayload {constructorName = "Ok"; itemNum = 0}, Tresult {okType} -> + |> 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"; - 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} ) -> + 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"; - errorType - |> extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (t, typeArgContext) -> - t |> resolveNested ?typeArgContext ~env ~full ~nested) - | NVariantPayload {constructorName; itemNum}, Tvariant {env; constructors} + 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" - itemNum constructorName; + item_num constructor_name; match constructors |> List.find_opt (fun (c : Constructor.t) -> - c.cname.txt = constructorName) + 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 itemNum with + match List.nth_opt args item_num with | None -> if Debug.verbose () then print_endline "[nested]--> did not find relevant args num"; @@ -711,220 +711,220 @@ let rec resolveNested ?typeArgContext ~env ~full ~nested ?ctx | Some (typ, _) -> if Debug.verbose () then Printf.printf "[nested]--> found arg of type: %s\n" - (Shared.typeToString typ); + (Shared.type_to_string typ); typ - |> extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (typ, typeArgContext) -> + |> 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" - (extractedTypeToString typ) + (extracted_type_to_string typ) (List.length nested); - typ |> resolveNested ?typeArgContext ~env ~full ~nested)) - | Some {args = InlineRecord fields} when itemNum = 0 -> + 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} - |> resolveNested ?typeArgContext ~env ~full ~nested + |> resolve_nested ?type_arg_context ~env ~full ~nested | _ -> None) - | ( NPolyvariantPayload {constructorName; itemNum}, + | ( NPolyvariantPayload {constructor_name; item_num}, Tpolyvariant {env; constructors} ) -> ( match constructors - |> List.find_opt (fun (c : polyVariantConstructor) -> - c.name = constructorName) + |> List.find_opt (fun (c : poly_variant_constructor) -> + c.name = constructor_name) with | None -> None | Some constructor -> ( - match List.nth_opt constructor.args itemNum with + match List.nth_opt constructor.args item_num with | None -> None | Some typ -> typ - |> extractType ~env ~package:full.package - |> Utils.Option.flatMap (fun (typ, typeArgContext) -> - typ |> resolveNested ?typeArgContext ~env ~full ~nested))) + |> 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 |> resolveNested ?typeArgContext ~env ~full ~nested + typ |> resolve_nested ?type_arg_context ~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) + |> 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 findTypeOfRecordField fields ~fieldName = +let find_type_of_record_field fields ~field_name = match - fields |> List.find_opt (fun (field : field) -> field.fname.txt = fieldName) + fields |> List.find_opt (fun (field : field) -> field.fname.txt = field_name) with | None -> None | Some {typ; optional} -> - let typ = if optional then Utils.unwrapIfOption typ else typ in + let typ = if optional then Utils.unwrap_if_option typ else typ in Some typ -let findTypeOfConstructorArg constructors ~constructorName ~payloadNum ~env = +let find_type_of_constructor_arg constructors ~constructor_name ~payload_num ~env = match constructors - |> List.find_opt (fun (c : Constructor.t) -> c.cname.txt = constructorName) + |> List.find_opt (fun (c : Constructor.t) -> c.cname.txt = constructor_name) with | Some {args = Args args} -> ( - match List.nth_opt args payloadNum with + match List.nth_opt args payload_num with | None -> None | Some (typ, _) -> Some (TypeExpr typ)) - | Some {args = InlineRecord fields} when payloadNum = 0 -> + | Some {args = InlineRecord fields} when payload_num = 0 -> Some (ExtractedType (TinlineRecord {env; fields})) | _ -> None -let findTypeOfPolyvariantArg constructors ~constructorName ~payloadNum = +let find_type_of_polyvariant_arg constructors ~constructor_name ~payload_num = match constructors - |> List.find_opt (fun (c : polyVariantConstructor) -> - c.name = constructorName) + |> List.find_opt (fun (c : poly_variant_constructor) -> + c.name = constructor_name) with | Some {args} -> ( - match List.nth_opt args payloadNum with + match List.nth_opt args payload_num with | None -> None | Some typ -> Some typ) | None -> None -let rec resolveNestedPatternPath (typ : innerType) ~env ~full ~nested = +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 |> extractType ~env ~package:full.package |> getExtractedType + t |> extract_type ~env ~package:full.package |> get_extracted_type | ExtractedType t -> Some t in match nested with | [] -> None - | [finalPatternPath] -> ( + | [final_pattern_path] -> ( match t with | None -> None - | Some completionType -> ( - match (finalPatternPath, completionType) with - | ( Completable.NFollowRecordField {fieldName}, + | Some completion_type -> ( + match (final_pattern_path, completion_type) with + | ( Completable.NFollowRecordField {field_name}, (TinlineRecord {fields} | Trecord {fields}) ) -> ( - match fields |> findTypeOfRecordField ~fieldName with + match fields |> find_type_of_record_field ~field_name with | None -> None | Some typ -> Some (TypeExpr typ, env)) - | NTupleItem {itemNum}, Tuple (env, tupleItems, _) -> ( - match List.nth_opt tupleItems itemNum with + | 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 {constructorName; itemNum}, Tvariant {env; constructors} + | NVariantPayload {constructor_name; item_num}, Tvariant {env; constructors} -> ( match constructors - |> findTypeOfConstructorArg ~constructorName ~payloadNum:itemNum ~env + |> find_type_of_constructor_arg ~constructor_name ~payload_num:item_num ~env with | Some typ -> Some (typ, env) | None -> None) - | ( NPolyvariantPayload {constructorName; itemNum}, + | ( NPolyvariantPayload {constructor_name; item_num}, Tpolyvariant {env; constructors} ) -> ( match constructors - |> findTypeOfPolyvariantArg ~constructorName ~payloadNum:itemNum + |> find_type_of_polyvariant_arg ~constructor_name ~payload_num:item_num with | Some typ -> Some (TypeExpr typ, env) | None -> None) - | ( NVariantPayload {constructorName = "Some"; itemNum = 0}, + | ( NVariantPayload {constructor_name = "Some"; item_num = 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) + | ( 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)) - | patternPath :: nested -> ( + | pattern_path :: nested -> ( match t with | None -> None - | Some completionType -> ( - match (patternPath, completionType) with - | ( Completable.NFollowRecordField {fieldName}, + | Some completion_type -> ( + match (pattern_path, completion_type) with + | ( Completable.NFollowRecordField {field_name}, (TinlineRecord {env; fields} | Trecord {env; fields}) ) -> ( - match fields |> findTypeOfRecordField ~fieldName with + match fields |> find_type_of_record_field ~field_name with | None -> None | Some typ -> typ - |> extractType ~env ~package:full.package - |> getExtractedType - |> Utils.Option.flatMap (fun typ -> + |> extract_type ~env ~package:full.package + |> get_extracted_type + |> Utils.Option.flat_map (fun typ -> ExtractedType typ - |> resolveNestedPatternPath ~env ~full ~nested)) - | NTupleItem {itemNum}, Tuple (env, tupleItems, _) -> ( - match List.nth_opt tupleItems itemNum with + |> 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 - |> extractType ~env ~package:full.package - |> getExtractedType - |> Utils.Option.flatMap (fun typ -> + |> extract_type ~env ~package:full.package + |> get_extracted_type + |> Utils.Option.flat_map (fun typ -> ExtractedType typ - |> resolveNestedPatternPath ~env ~full ~nested)) - | NVariantPayload {constructorName; itemNum}, Tvariant {env; constructors} + |> resolve_nested_pattern_path ~env ~full ~nested)) + | NVariantPayload {constructor_name; item_num}, Tvariant {env; constructors} -> ( match constructors - |> findTypeOfConstructorArg ~constructorName ~payloadNum:itemNum ~env + |> find_type_of_constructor_arg ~constructor_name ~payload_num:item_num ~env with - | Some typ -> typ |> resolveNestedPatternPath ~env ~full ~nested + | Some typ -> typ |> resolve_nested_pattern_path ~env ~full ~nested | None -> None) - | ( NPolyvariantPayload {constructorName; itemNum}, + | ( NPolyvariantPayload {constructor_name; item_num}, Tpolyvariant {env; constructors} ) -> ( match constructors - |> findTypeOfPolyvariantArg ~constructorName ~payloadNum:itemNum + |> find_type_of_polyvariant_arg ~constructor_name ~payload_num:item_num with | Some typ -> - TypeExpr typ |> resolveNestedPatternPath ~env ~full ~nested + TypeExpr typ |> resolve_nested_pattern_path ~env ~full ~nested | None -> None) - | ( NVariantPayload {constructorName = "Some"; itemNum = 0}, + | ( NVariantPayload {constructor_name = "Some"; item_num = 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 + 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 |> resolveNestedPatternPath ~env ~full ~nested + typ |> resolve_nested_pattern_path ~env ~full ~nested | _ -> None)) -let getArgs ~env (t : Types.type_expr) ~full = - let rec getArgsLoop ~env (t : Types.type_expr) ~full ~currentArgumentPosition +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, []) -> - 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 + get_args_loop ~full ~env ~current_argument_position t1 + | Tarrow ({lbl = Labelled {txt = l}; typ = t_arg}, t_ret, _, _) -> + (SharedTypes.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 = typeParams}}; + item = {decl = {type_manifest = Some t1; type_params = type_params}}; } ) -> - let t1 = t1 |> instantiateType ~typeParams ~typeArgs in - getArgsLoop ~full ~env ~currentArgumentPosition t1 + let t1 = t1 |> instantiate_type ~type_params ~type_args in + get_args_loop ~full ~env ~current_argument_position t1 | _ -> []) | _ -> [] in - t |> getArgsLoop ~env ~full ~currentArgumentPosition:0 + t |> get_args_loop ~env ~full ~current_argument_position:0 -let typeIsUnit (typ : Types.type_expr) = +let type_is_unit (typ : Types.type_expr) = match typ.desc with | Tconstr (Pident id, _typeArgs, _) | Tlink {desc = Tconstr (Pident id, _typeArgs, _)} @@ -934,50 +934,50 @@ let typeIsUnit (typ : Types.type_expr) = 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)) +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.flattenLongIdent; - completionContext = Type; + path = lid.txt |> Utils.flatten_long_ident; + completion_context = Type; loc = lid.loc; }) | _ -> None -let unwrapCompletionTypeIfOption (t : SharedTypes.completionType) = +let unwrap_completion_type_if_option (t : SharedTypes.completion_type) = match t with | Toption (_, ExtractedType unwrapped) -> unwrapped | _ -> t module Codegen = struct - let mkFailWithExp () = + 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 mkConstructPat ?payload name = + let mk_construct_pat ?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 mk_tag_pat ?payload name = Ast_helper.Pat.variant name payload let any () = Ast_helper.Pat.any () - let rec extractedTypeToExhaustivePatterns ~env ~full extractedType = - match extractedType with + let rec extracted_type_to_exhaustive_patterns ~env ~full extracted_type = + match extracted_type with | Tvariant v -> Some (v.constructors |> List.map (fun (c : SharedTypes.Constructor.t) -> - mkConstructPat + mk_construct_pat ?payload: (match c.args with | Args [] -> None @@ -986,71 +986,71 @@ module Codegen = struct | Tpolyvariant v -> Some (v.constructors - |> List.map (fun (c : SharedTypes.polyVariantConstructor) -> - mkTagPat + |> List.map (fun (c : SharedTypes.poly_variant_constructor) -> + mk_tag_pat ?payload: (match c.args with | [] -> None | _ -> Some (any ())) - c.displayName)) - | Toption (_, innerType) -> - let extractedType = - match innerType with + c.display_name)) + | Toption (_, inner_type) -> + let extracted_type = + match inner_type with | ExtractedType t -> Some t | TypeExpr t -> - extractType t ~env ~package:full.package |> getExtractedType + extract_type t ~env ~package:full.package |> get_extracted_type in - let expandedBranches = - match extractedType with + let expanded_branches = + match extracted_type with | None -> [] - | Some extractedType -> ( - match extractedTypeToExhaustivePatterns ~env ~full extractedType with + | Some extracted_type -> ( + match extracted_type_to_exhaustive_patterns ~env ~full extracted_type with | None -> [] | Some patterns -> patterns) in Some ([ - mkConstructPat "None"; - mkConstructPat ~payload:(Ast_helper.Pat.any ()) "Some"; + mk_construct_pat "None"; + mk_construct_pat ~payload:(Ast_helper.Pat.any ()) "Some"; ] - @ (expandedBranches + @ (expanded_branches |> List.map (fun (pat : Parsetree.pattern) -> - mkConstructPat ~payload:pat "Some"))) - | Tresult {okType; errorType} -> - let extractedOkType = - okType |> extractType ~env ~package:full.package |> getExtractedType + 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 extractedErrorType = - errorType |> extractType ~env ~package:full.package |> getExtractedType + let extracted_error_type = + error_type |> extract_type ~env ~package:full.package |> get_extracted_type in - let expandedOkBranches = - match extractedOkType with + let expanded_ok_branches = + match extracted_ok_type with | None -> [] - | Some extractedType -> ( - match extractedTypeToExhaustivePatterns ~env ~full extractedType with + | Some extracted_type -> ( + match extracted_type_to_exhaustive_patterns ~env ~full extracted_type with | None -> [] | Some patterns -> patterns) in - let expandedErrorBranches = - match extractedErrorType with + let expanded_error_branches = + match extracted_error_type with | None -> [] - | Some extractedType -> ( - match extractedTypeToExhaustivePatterns ~env ~full extractedType with + | Some extracted_type -> ( + match extracted_type_to_exhaustive_patterns ~env ~full extracted_type with | None -> [] | Some patterns -> patterns) in Some - ((expandedOkBranches + ((expanded_ok_branches |> List.map (fun (pat : Parsetree.pattern) -> - mkConstructPat ~payload:pat "Ok")) - @ (expandedErrorBranches + mk_construct_pat ~payload:pat "Ok")) + @ (expanded_error_branches |> List.map (fun (pat : Parsetree.pattern) -> - mkConstructPat ~payload:pat "Error"))) - | Tbool _ -> Some [mkConstructPat "true"; mkConstructPat "false"] + mk_construct_pat ~payload:pat "Error"))) + | Tbool _ -> Some [mk_construct_pat "true"; mk_construct_pat "false"] | _ -> None - let extractedTypeToExhaustiveCases ~env ~full extractedType = - let patterns = extractedTypeToExhaustivePatterns ~env ~full extractedType in + 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 @@ -1058,158 +1058,158 @@ module Codegen = struct Some (patterns |> List.map (fun (pat : Parsetree.pattern) -> - Ast_helper.Exp.case pat (mkFailWithExp ()))) + Ast_helper.Exp.case pat (mk_fail_with_exp ()))) end -let getModulePathRelativeToEnv ~debug ~(env : QueryEnv.t) ~envFromItem path = +let get_module_path_relative_to_env ~debug ~(env : QueryEnv.t) ~env_from_item path = match path with - | _ :: pathRev -> + | _ :: path_rev -> (* 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) + let found, path_from_env = + QueryEnv.path_from_env env_from_item (List.rev path_rev) in if debug then Printf.printf "CPPipe pathFromEnv:%s found:%b\n" - (pathFromEnv |> String.concat ".") + (path_from_env |> String.concat ".") found; - if pathFromEnv = [] then None + if path_from_env = [] then None else if - env.file.moduleName <> envFromItem.file.moduleName && found + 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 (envFromItem.file.moduleName :: pathFromEnv) - else Some pathFromEnv + then Some (env_from_item.file.module_name :: path_from_env) + else Some path_from_env | _ -> 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 +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 removeRawOpens rawOpens modulePath = - match rawOpens with - | rawOpen :: restOpens -> ( - let newModulePath = removeRawOpens restOpens modulePath in - match removeRawOpen rawOpen newModulePath with - | None -> newModulePath + 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) - | [] -> modulePath + | [] -> module_path in - let completionPathMinusOpens = - completionPath |> Utils.flattenAnyNamespaceInPath - |> removeRawOpens package.opens - |> removeRawOpens rawOpens + let completion_path_minus_opens = + completion_path |> Utils.flatten_any_namespace_in_path + |> remove_raw_opens package.opens + |> remove_raw_opens raw_opens in - completionPathMinusOpens + completion_path_minus_opens -let pathToElementProps package = - match package.genericJsxModule with +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 StringSet = Set.Make (String) -let getExtraModulesToCompleteFromForType ~env ~full (t : Types.type_expr) = - let foundModulePaths = ref StringSet.empty in - let addToModulePaths attributes = - ProcessAttributes.findEditorCompleteFromAttribute attributes +let get_extra_modules_to_complete_from_for_type ~env ~full (t : Types.type_expr) = + let found_module_paths = ref StringSet.empty in + let add_to_module_paths attributes = + ProcessAttributes.find_editor_complete_from_attribute attributes |> List.iter (fun e -> - foundModulePaths := - StringSet.add (e |> String.concat ".") !foundModulePaths) + found_module_paths := + StringSet.add (e |> String.concat ".") !found_module_paths) in let rec inner ~env ~full (t : Types.type_expr) = - match t |> Shared.digConstructor with + match t |> Shared.dig_constructor with | Some path -> ( - match References.digConstructor ~env ~package:full.package path with + match References.dig_constructor ~env ~package:full.package path with | None -> () | Some (env, {item = {decl = {type_manifest = Some t}; attributes}}) -> - addToModulePaths attributes; + add_to_module_paths attributes; inner ~env ~full t - | Some (_, {item = {attributes}}) -> addToModulePaths attributes) + | Some (_, {item = {attributes}}) -> add_to_module_paths attributes) | None -> () in inner ~env ~full t; - !foundModulePaths |> StringSet.elements + !found_module_paths |> StringSet.elements |> List.map (fun l -> String.split_on_char '.' l) -let getFirstFnUnlabelledArgType ~env ~full t = +let get_first_fn_unlabelled_arg_type ~env ~full t = let labels, _, env = - extractFunctionTypeWithEnv ~env ~package:full.package t + extract_function_type_with_env ~env ~package:full.package t in - let rec findFirstUnlabelledArgType labels = + let rec find_first_unlabelled_arg_type labels = match labels with | (Asttypes.Nolabel, t) :: _ -> Some t - | _ :: rest -> findFirstUnlabelledArgType rest + | _ :: rest -> find_first_unlabelled_arg_type rest | [] -> None in - match findFirstUnlabelledArgType labels with + match find_first_unlabelled_arg_type labels with | Some t -> Some (t, env) | _ -> None -let makeAdditionalTextEditsForRemovingDot posOfDot = +let make_additional_text_edits_for_removing_dot pos_of_dot = let start = - Lsp.Types.Position.create ~line:(fst posOfDot) ~character:(snd posOfDot - 1) + Lsp.Types.Position.create ~line:(fst pos_of_dot) ~character:(snd pos_of_dot - 1) in let end_ = - Lsp.Types.Position.create ~line:(fst posOfDot) ~character:(snd posOfDot) + Lsp.Types.Position.create ~line:(fst pos_of_dot) ~character:(snd pos_of_dot) in [ - Lsp.Types.TextEdit.create ~newText:"" + Lsp.Types.TextEdit.create ~new_text:"" ~range:(Lsp.Types.Range.create ~start ~end_); ] (** Turns a completion into a pipe completion. *) -let transformCompletionToPipeCompletion ?(synthetic = false) ~env ?posOfDot +let transform_completion_to_pipe_completion ?(synthetic = false) ~env ?pos_of_dot (completion : Completion.t) = let name = completion.name in - let nameWithPipe = "->" ^ name in + let name_with_pipe = "->" ^ name in Some { completion with - name = nameWithPipe; - sortText = - (match completion.sortText with - | Some _ -> completion.sortText + 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)); - insertText = Some nameWithPipe; + insert_text = Some name_with_pipe; env; synthetic; - additionalTextEdits = - (match posOfDot with + additional_text_edits = + (match pos_of_dot with | None -> None - | Some posOfDot -> Some (makeAdditionalTextEditsForRemovingDot posOfDot)); + | 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 findRootTypeId ~full ~env (t : Types.type_expr) = +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, []) -> findRootTypeId ~full ~env t1 + | 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.digConstructor ~env ~package:full.package path with + 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" - (modulePathFromEnv env |> String.concat "."); - findRootTypeId ~full ~env t1 - | Some (env, {item = {name}; modulePath}) -> + (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" - (modulePathFromEnv env |> String.concat ".") - (ModulePath.toPath modulePath name |> String.concat "."); - Some (fullTypeIdFromDecl ~env ~name ~modulePath) + (module_path_from_env env |> String.concat ".") + (ModulePath.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"; @@ -1225,55 +1225,55 @@ let rec findRootTypeId ~full ~env (t : Types.type_expr) = | _ -> None (** Filters out completions that are not pipeable from a list of completions. *) -let filterPipeableFunctions ~env ~full ?synthetic ?targetTypeId ?posOfDot +let filter_pipeable_functions ~env ~full ?synthetic ?target_type_id ?pos_of_dot completions = - match targetTypeId with + match target_type_id with | None -> completions - | Some targetTypeId -> + | Some target_type_id -> completions |> List.filter_map (fun (completion : Completion.t) -> - let thisCompletionItemTypeId = + let this_completion_item_type_id = match completion.kind with | Value t -> ( match - getFirstFnUnlabelledArgType ~full ~env:completion.env t + get_first_fn_unlabelled_arg_type ~full ~env:completion.env t with | None -> None - | Some (t, envFromLabelledArg) -> - findRootTypeId ~full ~env:envFromLabelledArg t) + | Some (t, env_from_labelled_arg) -> + find_root_type_id ~full ~env:env_from_labelled_arg t) | _ -> None in - match thisCompletionItemTypeId with - | Some mainTypeId when mainTypeId = targetTypeId -> ( - match posOfDot with + 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 posOfDot -> - transformCompletionToPipeCompletion ?synthetic ~env ~posOfDot + | Some pos_of_dot -> + transform_completion_to_pipe_completion ?synthetic ~env ~pos_of_dot completion) | _ -> None) -let removeCurrentModuleIfNeeded ~envCompletionIsMadeFrom completionPath = +let remove_current_module_if_needed ~env_completion_is_made_from completion_path = if - List.length completionPath > 0 - && List.hd completionPath = envCompletionIsMadeFrom.QueryEnv.file.moduleName - then List.tl completionPath - else completionPath + List.length completion_path > 0 + && List.hd completion_path = env_completion_is_made_from.QueryEnv.file.module_name + then List.tl completion_path + else completion_path -let rec getObjFields (texp : Types.type_expr) = +let rec get_obj_fields (texp : Types.type_expr) = match texp.desc with | Tfield (name, _, t1, t2) -> - let fields = t2 |> getObjFields in + let fields = t2 |> get_obj_fields in (name, t1) :: fields - | Tlink te | Tsubst te | Tpoly (te, []) -> te |> getObjFields + | Tlink te | Tsubst te | Tpoly (te, []) -> te |> get_obj_fields | Tvar None -> [] | _ -> [] -let pathToBuiltin path = +let path_to_builtin path = Predef.builtin_idents |> List.find_opt (fun (_, i) -> Ident.same i (Path.head path)) -let completionPathFromMaybeBuiltin path = - match pathToBuiltin path with +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"] @@ -1285,10 +1285,10 @@ let completionPathFromMaybeBuiltin path = | 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 -> + 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 '_' mainModule) + 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 index 912acbecbf..6b4ae5c96e 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 index 9079b6323c..ecf4cff770 100644 --- a/analysis/src/Uri.mli +++ b/analysis/src/Uri.mli @@ -1,10 +1,10 @@ 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 +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 index a4bfc33bec..3beab0f74f 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,35 @@ 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 +185,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 +233,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 +260,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 index a9ca37d8bc..bffbf57ee3 100644 --- a/analysis/src/Xform.ml +++ b/analysis/src/Xform.ml @@ -1,39 +1,39 @@ (** Code transformations using the parser/printer and ast operations *) -let isBracedExpr = Res_parsetree_viewer.is_braced_expr +let is_braced_expr = Res_parsetree_viewer.is_braced_expr -let extractTypeFromExpr expr ~debug ~source ~kindFile ~full ~pos = +let extract_type_from_expr expr ~debug ~source ~kind_file ~full ~pos = match expr.Parsetree.pexp_loc - |> CompletionFrontEnd.findTypeOfExpressionAtLoc ~debug ~source ~kindFile - ~posCursor:(Pos.ofLexing expr.Parsetree.pexp_loc.loc_start) + |> CompletionFrontEnd.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 = SharedTypes.QueryEnv.fromFile full.SharedTypes.file in + let env = SharedTypes.QueryEnv.from_file full.SharedTypes.file in let completions = completable - |> CompletionBackEnd.processCompletable ~debug ~full ~pos ~scope ~env - ~forHover:true + |> CompletionBackEnd.process_completable ~debug ~full ~pos ~scope ~env + ~for_hover:true in - let rawOpens = Scope.getRawOpens scope in + let raw_opens = Scope.get_raw_opens scope in match completions with | {env} :: _ -> ( let opens = - CompletionBackEnd.getOpens ~debug ~rawOpens ~package:full.package ~env + CompletionBackEnd.get_opens ~debug ~raw_opens ~package:full.package ~env in match - CompletionBackEnd.completionsGetCompletionType2 ~debug ~full ~rawOpens + CompletionBackEnd.completions_get_completion_type2 ~debug ~full ~raw_opens ~opens ~pos completions with | Some (typ, _env) -> - let extractedType = + let extracted_type = match typ with | ExtractedType t -> Some t | TypeExpr t -> - TypeUtils.extractType t ~env ~package:full.package - |> TypeUtils.getExtractedType + TypeUtils.extract_type t ~env ~package:full.package + |> TypeUtils.get_extracted_type in - extractedType + extracted_type | None -> None) | _ -> None) | _ -> None @@ -41,48 +41,48 @@ let extractTypeFromExpr expr ~debug ~source ~kindFile ~full ~pos = module IfThenElse = struct (* Convert if-then-else to switch *) - let rec listToPat ~itemToPat = function + let rec list_to_pat ~item_to_pat = function | [] -> Some [] - | x :: xList -> ( - match (itemToPat x, listToPat ~itemToPat xList) with - | Some p, Some pList -> Some (p :: pList) + | 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 expToPat (exp : Parsetree.expression) = - let mkPat ppat_desc = + 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 (mkPat (Ppat_construct (lid, None))) + | Pexp_construct (lid, None) -> Some (mk_pat (Ppat_construct (lid, None))) | Pexp_construct (lid, Some e1) -> ( - match expToPat e1 with + match exp_to_pat e1 with | None -> None - | Some p1 -> Some (mkPat (Ppat_construct (lid, Some p1)))) - | Pexp_variant (label, None) -> Some (mkPat (Ppat_variant (label, 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 expToPat e1 with + match exp_to_pat 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 + | 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 patList -> Some (mkPat (Ppat_tuple patList))) + | Some pat_list -> Some (mk_pat (Ppat_tuple pat_list))) | Pexp_record (items, None) -> ( - let itemToPat {Parsetree.lid; x = e; opt} = - match expToPat e with + 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 listToPat ~itemToPat items with + match list_to_pat ~item_to_pat items with | None -> None - | Some patItems -> Some (mkPat (Ppat_record (patItems, Closed)))) + | Some pat_items -> Some (mk_pat (Ppat_record (pat_items, Closed)))) | Pexp_record (_, Some _) -> None | _ -> None - let mkIterator ~pos ~changed = + let mk_iterator ~pos ~changed = let expr (iterator : Ast_iterator.iterator) (e : Parsetree.expression) = - let newExp = + let new_exp = match e.pexp_desc with | Pexp_ifthenelse ( { @@ -100,9 +100,9 @@ module IfThenElse = struct }, e1, Some e2 ) - when Loc.hasPos ~pos e.pexp_loc -> ( + when Loc.has_pos ~pos e.pexp_loc -> ( let e1, e2 = if op = "==" then (e1, e2) else (e2, e1) in - let mkMatch ~arg ~pat = + let mk_match ~arg ~pat = let cases = [ Ast_helper.Exp.case pat e1; @@ -113,66 +113,66 @@ module IfThenElse = struct cases in - match expToPat arg2 with + match exp_to_pat arg2 with | None -> ( - match expToPat arg1 with + match exp_to_pat arg1 with | None -> None | Some pat1 -> - let newExp = mkMatch ~arg:arg2 ~pat:pat1 in - Some newExp) + let new_exp = mk_match ~arg:arg2 ~pat:pat1 in + Some new_exp) | Some pat2 -> - let newExp = mkMatch ~arg:arg1 ~pat:pat2 in - Some newExp) + let new_exp = mk_match ~arg:arg1 ~pat:pat2 in + Some new_exp) | _ -> None in - match newExp with - | Some newExp -> changed := Some newExp + 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 ~codeActions ~printExpr ~path structure = + let xform ~pos ~code_actions ~print_expr ~path structure = let changed = ref None in - let iterator = mkIterator ~pos ~changed in + let iterator = mk_iterator ~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 = + | 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 = CodeActions.make ~title:"Replace with switch" ~kind:RefactorRewrite - ~uri:path ~newText ~range + ~uri:path ~new_text ~range in - codeActions := codeAction :: !codeActions + code_actions := code_action :: !code_actions end module ModuleToFile = struct - let mkIterator ~pos ~changed ~path ~printStandaloneStructure = + 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.hasPos ~pos -> - let range = Loc.rangeOfLoc structure_item.pstr_loc in - let newTextInCurrentFile = "" in - let textForExtractedFile = - printStandaloneStructure ~loc:pmb_loc 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 moduleName = pmb_name.txt in - let newFilePath = - Filename.concat (Filename.dirname path) moduleName ^ ".res" + let module_name = pmb_name.txt in + let new_file_path = + Filename.concat (Filename.dirname path) module_name ^ ".res" in - let uri = Uri.fromString newFilePath in - let documentChanges = + 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 ()) + ~ignore_if_exists:true ()) ()); `TextDocumentEdit (Lsp.Types.TextDocumentEdit.create @@ -180,9 +180,9 @@ module ModuleToFile = struct [ `TextEdit (Lsp.Types.TextEdit.create ~range - ~newText:textForExtractedFile); + ~new_text:text_for_extracted_file); ] - ~textDocument: + ~text_document: (Lsp.Types.OptionalVersionedTextDocumentIdentifier.create ~uri ())); `TextDocumentEdit @@ -191,20 +191,20 @@ module ModuleToFile = struct [ `TextEdit (Lsp.Types.TextEdit.create ~range - ~newText:newTextInCurrentFile); + ~new_text:new_text_in_current_file); ] - ~textDocument: + ~text_document: (Lsp.Types.OptionalVersionedTextDocumentIdentifier.create - ~uri:(Uri.fromString path) ())); + ~uri:(Uri.from_string path) ())); ] in changed := Some - (CodeActions.makeWithDocumentChanges + (CodeActions.make_with_document_changes ~title: (Printf.sprintf "Extract local module \"%s\" to file \"%s\"" - moduleName (moduleName ^ ".res")) - ~kind:RefactorRewrite ~documentChanges); + module_name (module_name ^ ".res")) + ~kind:RefactorRewrite ~document_changes); () | _ -> ()); Ast_iterator.default_iterator.structure_item iterator structure_item @@ -212,33 +212,33 @@ module ModuleToFile = struct {Ast_iterator.default_iterator with structure_item} - let xform ~pos ~codeActions ~path ~printStandaloneStructure structure = + let xform ~pos ~code_actions ~path ~print_standalone_structure structure = let changed = ref None in - let iterator = mkIterator ~pos ~path ~changed ~printStandaloneStructure in + let iterator = mk_iterator ~pos ~path ~changed ~print_standalone_structure in iterator.structure iterator structure; match !changed with | None -> () - | Some codeAction -> codeActions := codeAction :: !codeActions + | Some code_action -> code_actions := code_action :: !code_actions end module AddBracesToFn = struct (* Add braces to fn without braces *) - let mkIterator ~pos ~changed = + 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 currentStructureItem = ref None in + let current_structure_item = ref None in let structure_item (iterator : Ast_iterator.iterator) (item : Parsetree.structure_item) = - let saved = !currentStructureItem in - currentStructureItem := Some item; + let saved = !current_structure_item in + current_structure_item := Some item; Ast_iterator.default_iterator.structure_item iterator item; - currentStructureItem := saved + current_structure_item := saved in let expr (iterator : Ast_iterator.iterator) (e : Parsetree.expression) = - let bracesAttribute = + let braces_attribute = let loc = { Location.none with @@ -252,37 +252,37 @@ module AddBracesToFn = struct in (Location.mkloc "res.braces" loc, Parsetree.PStr []) in - let isFunction = function + let is_function = 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 + | 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 ~codeActions ~path ~printStructureItem structure = + let xform ~pos ~code_actions ~path ~print_structure_item structure = let changed = ref None in - let iterator = mkIterator ~pos ~changed in + let iterator = mk_iterator ~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 = + | 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 = CodeActions.make ~title:"Add braces to function" ~kind:RefactorRewrite - ~uri:path ~newText ~range + ~uri:path ~new_text ~range in - codeActions := codeAction :: !codeActions + code_actions := code_action :: !code_actions end module AddTypeAnnotation = struct @@ -290,140 +290,140 @@ module AddTypeAnnotation = struct type annotation = Plain | WithParens - let mkIterator ~pos ~result = - let processPattern ?(isUnlabeledOnlyArg = false) (pat : Parsetree.pattern) = + 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.hasPos ~pos loc -> - result := Some (if isUnlabeledOnlyArg then WithParens else Plain) + | Ppat_var {loc} when Loc.has_pos ~pos loc -> + result := Some (if is_unlabeled_only_arg then WithParens else Plain) | _ -> () in - let rec processFunction ~argNum (e : Parsetree.expression) = + let rec process_function ~arg_num (e : Parsetree.expression) = match e.pexp_desc with | Pexp_fun {arg_label; lhs = pat; rhs = e} -> - let isUnlabeledOnlyArg = - argNum = 1 && arg_label = Nolabel + let is_unlabeled_only_arg = + arg_num = 1 && arg_label = Nolabel && match e.pexp_desc with | Pexp_fun _ -> false | _ -> true in - processPattern ~isUnlabeledOnlyArg pat; - processFunction ~argNum:(argNum + 1) e + 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 processBinding (vb : Parsetree.value_binding) = + let process_binding (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 + 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 (processBinding ~argNum:1); + 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 ~codeActions ~debug = + let xform ~path ~pos ~full ~structure ~code_actions ~debug = let result = ref None in - let iterator = mkIterator ~pos ~result in + let iterator = mk_iterator ~pos ~result in iterator.structure iterator structure; match !result with | None -> () | Some annotation -> ( - match References.getLocItem ~full ~pos ~debug with + match References.get_loc_item ~full ~pos ~debug with | None -> () - | Some locItem -> ( - match locItem.locType with + | Some loc_item -> ( + match loc_item.loc_type with | Typed (name, typ, _) -> - let range, newText = + let range, new_text = match annotation with | Plain -> - ( Loc.rangeOfLoc {locItem.loc with loc_start = locItem.loc.loc_end}, - ": " ^ (typ |> Shared.typeToString) ) + ( Loc.range_of_loc {loc_item.loc with loc_start = loc_item.loc.loc_end}, + ": " ^ (typ |> Shared.type_to_string) ) | WithParens -> - ( Loc.rangeOfLoc locItem.loc, - "(" ^ name ^ ": " ^ (typ |> Shared.typeToString) ^ ")" ) + ( Loc.range_of_loc loc_item.loc, + "(" ^ name ^ ": " ^ (typ |> Shared.type_to_string) ^ ")" ) in - let codeAction = + let code_action = CodeActions.make ~title:"Add type annotation" ~kind:RefactorRewrite - ~uri:path ~newText ~range + ~uri:path ~new_text ~range in - codeActions := codeAction :: !codeActions + code_actions := code_action :: !code_actions | _ -> ())) end module ExpandCatchAllForVariants = struct - let mkIterator ~pos ~result = + let mk_iterator ~pos ~result = let expr (iterator : Ast_iterator.iterator) (e : Parsetree.expression) = - (if e.pexp_loc |> Loc.hasPos ~pos then + (if e.pexp_loc |> Loc.has_pos ~pos then match e.pexp_desc with - | Pexp_match (switchExpr, cases) -> ( - let catchAllCase = + | 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 catchAllCase with + match catch_all_case with | None -> () - | Some catchAllCase -> - result := Some (switchExpr, catchAllCase, cases)) + | 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 ~kindFile ~path ~pos ~full ~structure ~codeActions ~debug = + let xform ~source ~kind_file ~path ~pos ~full ~structure ~code_actions ~debug = let result = ref None in - let iterator = mkIterator ~pos ~result in + let iterator = mk_iterator ~pos ~result in iterator.structure iterator structure; match !result with | None -> () - | Some (switchExpr, catchAllCase, cases) -> ( + | Some (switch_expr, catch_all_case, cases) -> ( if Debug.verbose () then print_endline "[codeAction - ExpandCatchAllForVariants] Found target switch"; - let rec findAllConstructorNames ?(mode : [`option | `default] = `default) - ?(constructorNames = []) (p : Parsetree.pattern) = + 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 -> - findAllConstructorNames ~mode ~constructorNames payload - | Ppat_construct ({txt}, _) -> Longident.last txt :: constructorNames - | Ppat_variant (name, _) -> name :: constructorNames + 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) -> - findAllConstructorNames ~mode ~constructorNames a - @ findAllConstructorNames ~mode ~constructorNames b - @ constructorNames - | _ -> constructorNames + find_all_constructor_names ~mode ~constructor_names a + @ find_all_constructor_names ~mode ~constructor_names b + @ constructor_names + | _ -> constructor_names in - let getCurrentConstructorNames ?mode cases = + let get_current_constructor_names ?mode cases = cases |> List.map (fun (c : Parsetree.case) -> if Option.is_some c.pc_guard then [] - else findAllConstructorNames ?mode c.pc_lhs) + else find_all_constructor_names ?mode c.pc_lhs) |> List.flatten in - let currentConstructorNames = getCurrentConstructorNames cases in + let current_constructor_names = get_current_constructor_names cases in match - switchExpr - |> extractTypeFromExpr ~debug ~source ~kindFile ~full - ~pos:(Pos.ofLexing switchExpr.pexp_loc.loc_end) + 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 missingConstructors = + let missing_constructors = constructors |> List.filter (fun (c : SharedTypes.Constructor.t) -> - currentConstructorNames |> List.mem c.cname.txt = false) + current_constructor_names |> List.mem c.cname.txt = false) in - if List.length missingConstructors > 0 then - let newText = - missingConstructors + if List.length missing_constructors > 0 then + let new_text = + missing_constructors |> List.map (fun (c : SharedTypes.Constructor.t) -> c.cname.txt ^ @@ -432,23 +432,23 @@ module ExpandCatchAllForVariants = struct | Args _ | InlineRecord _ -> "(_)") |> String.concat " | " in - let range = Loc.rangeOfLoc catchAllCase.pc_lhs.ppat_loc in - let codeAction = + let range = Loc.range_of_loc catch_all_case.pc_lhs.ppat_loc in + let code_action = CodeActions.make ~title:"Expand catch-all" ~kind:RefactorRewrite - ~uri:path ~newText ~range + ~uri:path ~new_text ~range in - codeActions := codeAction :: !codeActions + code_actions := code_action :: !code_actions else () | Some (Tpolyvariant {constructors}) -> - let missingConstructors = + let missing_constructors = constructors - |> List.filter (fun (c : SharedTypes.polyVariantConstructor) -> - currentConstructorNames |> List.mem c.name = false) + |> List.filter (fun (c : SharedTypes.poly_variant_constructor) -> + current_constructor_names |> List.mem c.name = false) in - if List.length missingConstructors > 0 then - let newText = - missingConstructors - |> List.map (fun (c : SharedTypes.polyVariantConstructor) -> + if List.length missing_constructors > 0 then + let new_text = + missing_constructors + |> List.map (fun (c : SharedTypes.poly_variant_constructor) -> Res_printer.polyvar_ident_to_string c.name ^ match c.args with @@ -456,43 +456,43 @@ module ExpandCatchAllForVariants = struct | _ -> "(_)") |> String.concat " | " in - let range = Loc.rangeOfLoc catchAllCase.pc_lhs.ppat_loc in - let codeAction = + let range = Loc.range_of_loc catch_all_case.pc_lhs.ppat_loc in + let code_action = CodeActions.make ~title:"Expand catch-all" ~kind:RefactorRewrite - ~uri:path ~newText ~range + ~uri:path ~new_text ~range in - codeActions := codeAction :: !codeActions + code_actions := code_action :: !code_actions else () - | Some (Toption (env, innerType)) -> ( + | Some (Toption (env, inner_type)) -> ( if Debug.verbose () then print_endline "[codeAction - ExpandCatchAllForVariants] Found option type"; - let innerType = - match innerType with + let inner_type = + match inner_type with | ExtractedType t -> Some t | TypeExpr t -> ( - match TypeUtils.extractType ~env ~package:full.package t with + match TypeUtils.extract_type ~env ~package:full.package t with | None -> None | Some (t, _) -> Some t) in - match innerType with + match inner_type with | Some ((Tvariant _ | Tpolyvariant _) as variant) -> - let currentConstructorNames = - getCurrentConstructorNames ~mode:`option cases + let current_constructor_names = + get_current_constructor_names ~mode:`option cases in - let hasNoneCase = + 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 missingConstructors = + let missing_constructors = match variant with | Tvariant {constructors} -> constructors |> List.filter_map (fun (c : SharedTypes.Constructor.t) -> - if currentConstructorNames |> List.mem c.cname.txt = false + if current_constructor_names |> List.mem c.cname.txt = false then Some ( c.cname.txt, @@ -503,8 +503,8 @@ module ExpandCatchAllForVariants = struct | Tpolyvariant {constructors} -> constructors |> List.filter_map - (fun (c : SharedTypes.polyVariantConstructor) -> - if currentConstructorNames |> List.mem c.name = false then + (fun (c : SharedTypes.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 @@ -513,24 +513,24 @@ module ExpandCatchAllForVariants = struct else None) | _ -> [] in - if List.length missingConstructors > 0 || not hasNoneCase then - let newText = + if List.length missing_constructors > 0 || not has_none_case then + let new_text = "Some(" - ^ (missingConstructors - |> List.map (fun (name, hasArgs) -> - name ^ if hasArgs then "(_)" else "") + ^ (missing_constructors + |> List.map (fun (name, has_args) -> + name ^ if has_args then "(_)" else "") |> String.concat " | ") ^ ")" in - let newText = - if hasNoneCase then newText else newText ^ " | None" + let new_text = + if has_none_case then new_text else new_text ^ " | None" in - let range = Loc.rangeOfLoc catchAllCase.pc_lhs.ppat_loc in - let codeAction = + let range = Loc.range_of_loc catch_all_case.pc_lhs.ppat_loc in + let code_action = CodeActions.make ~title:"Expand catch-all" ~kind:RefactorRewrite - ~uri:path ~newText ~range + ~uri:path ~new_text ~range in - codeActions := codeAction :: !codeActions + code_actions := code_action :: !code_actions else () | _ -> ()) | _ -> ()) @@ -538,135 +538,135 @@ 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 pos_type = Single of Pos.t | Range of Pos.t * Pos.t - type completionType = + type completion_type = | Switch of { pos: Pos.t; - switchExpr: Parsetree.expression; - completionExpr: Parsetree.expression; + switch_expr: Parsetree.expression; + completion_expr: Parsetree.expression; } | Selection of {expr: Parsetree.expression} - let mkIteratorSingle ~pos ~result = + let mk_iterator_single ~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 -> + | 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 (completionExpr, []) - when Loc.hasPosInclusiveEnd ~pos exp.pexp_loc -> + | 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; switchExpr = exp; completionExpr}) + result := Some (Switch {pos; switch_expr = exp; completion_expr}) | _ -> ()); Ast_iterator.default_iterator.expr iterator exp in {Ast_iterator.default_iterator with expr} - let mkIteratorRange ~startPos ~endPos ~foundSelection = + let mk_iterator_range ~start_pos ~end_pos ~found_selection = 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 + 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 expStartPos = startPos then - match !foundSelection with - | None, endExpr -> foundSelection := (Some exp, endExpr) + (if exp_start_pos = start_pos then + match !found_selection with + | None, end_expr -> found_selection := (Some exp, end_expr) | _ -> ()); - (if expEndPos = endPos then - match !foundSelection with - | startExp, _ -> foundSelection := (startExp, Some exp)); + (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 ~printExpr ~path ~source ~kindFile ~pos ~full ~structure - ~codeActions ~debug = + 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 foundSelection = ref (None, None) in + let found_selection = ref (None, None) in let iterator = match pos with - | Single pos -> mkIteratorSingle ~pos ~result - | Range (startPos, endPos) -> - mkIteratorRange ~startPos ~endPos ~foundSelection + | 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 !foundSelection with - | Some startExp, Some endExp -> + (match !found_selection with + | Some start_exp, Some end_exp -> 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}) + (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 - |> extractTypeFromExpr ~debug ~source ~kindFile ~full - ~pos:(Pos.ofLexing expr.pexp_loc.loc_start) + |> extract_type_from_expr ~debug ~source ~kind_file ~full + ~pos:(Pos.of_lexing expr.pexp_loc.loc_start) with | None -> () - | Some extractedType -> ( + | Some extracted_type -> ( let open TypeUtils.Codegen in - let exhaustiveSwitch = - extractedTypeToExhaustiveCases - ~env:(SharedTypes.QueryEnv.fromFile full.file) - ~full extractedType + let exhaustive_switch = + extracted_type_to_exhaustive_cases + ~env:(SharedTypes.QueryEnv.from_file full.file) + ~full extracted_type in - match exhaustiveSwitch with + match exhaustive_switch with | None -> () | Some cases -> - let range = Loc.rangeOfLoc expr.pexp_loc in - let newText = - printExpr ~range {expr with pexp_desc = Pexp_match (expr, 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 codeAction = + let code_action = CodeActions.make ~title:"Exhaustive switch" ~kind:RefactorRewrite - ~uri:path ~newText ~range + ~uri:path ~new_text ~range in - codeActions := codeAction :: !codeActions)) - | Some (Switch {switchExpr; completionExpr; pos}) -> ( + code_actions := code_action :: !code_actions)) + | Some (Switch {switch_expr; completion_expr; pos}) -> ( match - completionExpr - |> extractTypeFromExpr ~debug ~source ~kindFile ~full ~pos + completion_expr + |> extract_type_from_expr ~debug ~source ~kind_file ~full ~pos with | None -> () - | Some extractedType -> ( + | Some extracted_type -> ( let open TypeUtils.Codegen in - let exhaustiveSwitch = - extractedTypeToExhaustiveCases - ~env:(SharedTypes.QueryEnv.fromFile full.file) - ~full extractedType + let exhaustive_switch = + extracted_type_to_exhaustive_cases + ~env:(SharedTypes.QueryEnv.from_file full.file) + ~full extracted_type in - match exhaustiveSwitch with + match exhaustive_switch with | None -> () | Some cases -> - let range = Loc.rangeOfLoc switchExpr.pexp_loc in - let newText = - printExpr ~range - {switchExpr with pexp_desc = Pexp_match (completionExpr, 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 codeAction = + let code_action = CodeActions.make ~title:"Exhaustive switch" ~kind:RefactorRewrite - ~uri:path ~newText ~range + ~uri:path ~new_text ~range in - codeActions := codeAction :: !codeActions)) + code_actions := code_action :: !code_actions)) end module AddDocTemplate = struct - let createTemplate () = - let docContent = ["\n"; "\n"] in + let create_template () = + let doc_content = ["\n"; "\n"] in let expression = Ast_helper.Exp.constant - (Parsetree.Pconst_string (String.concat "" docContent, None)) + (Parsetree.Pconst_string (String.concat "" doc_content, None)) in - let structureItemDesc = Parsetree.Pstr_eval (expression, []) in - let structureItem = Ast_helper.Str.mk structureItemDesc in - let attrLoc = + 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; @@ -677,22 +677,22 @@ module AddDocTemplate = struct }; } in - (Location.mkloc "res.doc" attrLoc, Parsetree.PStr [structureItem]) + (Location.mkloc "res.doc" attr_loc, Parsetree.PStr [structure_item]) module Interface = struct - let mkIterator ~pos ~result = + 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.hasPos ~pos value_description.pval_loc - && ProcessAttributes.findDocAttribute + when Loc.has_pos ~pos value_description.pval_loc + && ProcessAttributes.find_doc_attribute 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 + when Loc.has_pos ~pos hd.ptype_loc + && ProcessAttributes.find_doc_attribute hd.ptype_attributes = None -> result := Some (r, item.psig_loc) | Psig_module {pmd_name = {loc}} as r -> @@ -702,72 +702,72 @@ module AddDocTemplate = struct 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} + 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 newValueBinding in + let signature_item_desc = Parsetree.Psig_value new_value_binding in Ast_helper.Sig.mk ~loc signature_item_desc - let processTypeDecl (typ : Parsetree.type_declaration) = - let attr = createTemplate () in - let newTypeDeclaration = + 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 - newTypeDeclaration + new_type_declaration - let processModDecl (modDecl : Parsetree.module_declaration) loc = - let attr = createTemplate () in - let newModDecl = - {modDecl with pmd_attributes = attr :: modDecl.pmd_attributes} + 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 newModDecl) + Ast_helper.Sig.mk ~loc (Parsetree.Psig_module new_mod_decl) - let xform ~path ~pos ~codeActions ~signature ~printSignatureItem = + let xform ~path ~pos ~code_actions ~signature ~print_signature_item = let result = ref None in - let iterator = mkIterator ~pos ~result in + let iterator = mk_iterator ~pos ~result in iterator.signature iterator signature; match !result with - | Some (signatureItem, loc) -> ( - let newSignatureItem = - match signatureItem with + | Some (signature_item, loc) -> ( + let new_signature_item = + match signature_item with | Psig_value value_desc -> - Some (processSigValue value_desc value_desc.pval_loc) (* Some loc *) + Some (process_sig_value value_desc value_desc.pval_loc) (* Some loc *) | Psig_type (flag, hd :: tl) -> - let newFirstTypeDecl = processTypeDecl hd in + let new_first_type_decl = process_type_decl hd in Some (Ast_helper.Sig.mk ~loc - (Parsetree.Psig_type (flag, newFirstTypeDecl :: tl))) - | Psig_module modDecl -> Some (processModDecl modDecl loc) + (Parsetree.Psig_type (flag, new_first_type_decl :: tl))) + | Psig_module mod_decl -> Some (process_mod_decl mod_decl loc) | _ -> None in - match newSignatureItem with - | Some signatureItem -> - let range = Loc.rangeOfLoc signatureItem.psig_loc in - let newText = printSignatureItem ~range signatureItem in - let codeAction = + 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 = CodeActions.make ~title:"Add Documentation template" - ~kind:RefactorRewrite ~uri:path ~newText ~range + ~kind:RefactorRewrite ~uri:path ~new_text ~range in - codeActions := codeAction :: !codeActions + code_actions := code_action :: !code_actions | None -> ()) | None -> () end module Implementation = struct - let mkIterator ~pos ~result = + 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.hasPos ~pos ppat_loc - && ProcessAttributes.findDocAttribute pvb_attributes = None -> + when Loc.has_pos ~pos ppat_loc + && ProcessAttributes.find_doc_attribute 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 + when Loc.has_pos ~pos value_description.pval_loc + && ProcessAttributes.find_doc_attribute value_description.pval_attributes = None -> result := Some (r, si.pstr_loc) @@ -775,162 +775,162 @@ module AddDocTemplate = struct 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 + when Loc.has_pos ~pos hd.ptype_loc + && ProcessAttributes.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 processValueBinding (valueBinding : Parsetree.value_binding) = - let attr = createTemplate () in - let newValueBinding = - {valueBinding with pvb_attributes = attr :: valueBinding.pvb_attributes} + 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 - newValueBinding + new_value_binding - let processPrimitive (valueDesc : Parsetree.value_description) loc = - let attr = createTemplate () in - let newValueDesc = - {valueDesc with pval_attributes = attr :: valueDesc.pval_attributes} + 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 newValueDesc + Ast_helper.Str.primitive ~loc new_value_desc - let processModuleBinding (modBind : Parsetree.module_binding) loc = - let attr = createTemplate () in - let newModBinding = - {modBind with pmb_attributes = attr :: modBind.pmb_attributes} + 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 newModBinding + Ast_helper.Str.module_ ~loc new_mod_binding - let xform ~pos ~codeActions ~path ~printStructureItem ~structure = + let xform ~pos ~code_actions ~path ~print_structure_item ~structure = let result = ref None in - let iterator = mkIterator ~pos ~result in + let iterator = mk_iterator ~pos ~result in iterator.structure iterator structure; match !result with | None -> () - | Some (structureItem, loc) -> ( - let newStructureItem = - match structureItem with + | Some (structure_item, loc) -> ( + let new_structure_item = + match structure_item with | Pstr_value (flag, hd :: tl) -> - let newValueBinding = processValueBinding hd in + let new_value_binding = process_value_binding 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) + (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 newFirstTypeDecl = Interface.processTypeDecl hd in + let new_first_type_decl = Interface.process_type_decl hd in Some (Ast_helper.Str.mk ~loc - (Parsetree.Pstr_type (flag, newFirstTypeDecl :: tl))) + (Parsetree.Pstr_type (flag, new_first_type_decl :: tl))) | _ -> None in - match newStructureItem with - | Some structureItem -> - let range = Loc.rangeOfLoc structureItem.pstr_loc in - let newText = printStructureItem ~range structureItem in - let codeAction = + 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 = CodeActions.make ~title:"Add Documentation template" - ~kind:RefactorRewrite ~uri:path ~newText ~range + ~kind:RefactorRewrite ~uri:path ~new_text ~range in - codeActions := codeAction :: !codeActions + code_actions := code_action :: !code_actions | None -> ()) end end -let parseImplementation ~source = +let parse_implementation ~source = let {Res_driver.parsetree = structure; comments} = Res_driver.parsing_engine.parse_implementation_from_source ~for_printer:false ~source in - let filterComments ~loc comments = + let filter_comments ~loc comments = (* Relevant comments in the range of the expression *) let filter comment = - Loc.hasPos ~pos:(Loc.start (Res_comment.loc comment)) loc + Loc.has_pos ~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 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 |> filterComments ~loc:expr.pexp_loc) + ~comments:(comments |> filter_comments ~loc:expr.pexp_loc) |> Utils.indent range.start.character in - let printStructureItem ~(range : Lsp.Types.Range.t) + let print_structure_item ~(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) + ~comments:(comments |> filter_comments ~loc:item.pstr_loc) |> Utils.indent range.start.character in - let printStandaloneStructure ~(loc : Location.t) structure = + let print_standalone_structure ~(loc : Location.t) structure = structure |> Res_printer.print_implementation - ~comments:(comments |> filterComments ~loc) + ~comments:(comments |> filter_comments ~loc) in - (structure, printExpr, printStructureItem, printStandaloneStructure) + (structure, print_expr, print_structure_item, print_standalone_structure) -let parseInterface ~source = +let parse_interface ~source = let {Res_driver.parsetree = structure; comments} = Res_driver.parsing_engine.parse_interface_from_source ~for_printer:false ~source in - let filterComments ~loc comments = + let filter_comments ~loc comments = (* Relevant comments in the range of the expression *) let filter comment = - Loc.hasPos ~pos:(Loc.start (Res_comment.loc comment)) loc + Loc.has_pos ~pos:(Loc.start (Res_comment.loc comment)) loc in comments |> List.filter filter in - let printSignatureItem ~(range : Lsp.Types.Range.t) + 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 |> filterComments ~loc:item.psig_loc) + ~comments:(comments |> filter_comments ~loc:item.psig_loc) |> Utils.indent range.start.character in - (structure, printSignatureItem) + (structure, print_signature_item) -let extractCodeActions ~path ~startPos ~endPos ~source ~kindFile ~debug = - let pos = startPos in - let codeActions = ref [] in - match kindFile with +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, printExpr, printStructureItem, printStandaloneStructure = - parseImplementation ~source + let structure, print_expr, print_structure_item, print_standalone_structure = + parse_implementation ~source in - IfThenElse.xform ~pos ~codeActions ~printExpr ~path structure; - ModuleToFile.xform ~pos ~codeActions ~path ~printStandaloneStructure + IfThenElse.xform ~pos ~code_actions ~print_expr ~path structure; + ModuleToFile.xform ~pos ~code_actions ~path ~print_standalone_structure structure; - AddBracesToFn.xform ~pos ~codeActions ~path ~printStructureItem structure; - AddDocTemplate.Implementation.xform ~pos ~codeActions ~path - ~printStructureItem ~structure; + AddBracesToFn.xform ~pos ~code_actions ~path ~print_structure_item structure; + AddDocTemplate.Implementation.xform ~pos ~code_actions ~path + ~print_structure_item ~structure; (* This Code Action needs type info *) let () = - match Cmt.loadFullCmtFromPath ~path with + match Cmt.load_full_cmt_from_path ~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 + AddTypeAnnotation.xform ~path ~pos ~full ~structure ~code_actions ~debug; + ExpandCatchAllForVariants.xform ~path ~source ~kind_file ~pos ~full + ~structure ~code_actions ~debug; + ExhaustiveSwitch.xform ~print_expr ~path ~source ~kind_file ~pos: - (if startPos = endPos then Single startPos - else Range (startPos, endPos)) - ~full ~structure ~codeActions ~debug + (if start_pos = end_pos then Single start_pos + else Range (start_pos, end_pos)) + ~full ~structure ~code_actions ~debug | None -> () in - !codeActions + !code_actions | Resi -> - let signature, printSignatureItem = parseInterface ~source in - AddDocTemplate.Interface.xform ~pos ~codeActions ~path ~signature - ~printSignatureItem; - !codeActions + let signature, print_signature_item = parse_interface ~source in + AddDocTemplate.Interface.xform ~pos ~code_actions ~path ~signature + ~print_signature_item; + !code_actions | Other -> [] diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 4310b1f80d..6f6da8b605 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/gentype/Paths.ml b/compiler/gentype/Paths.ml index c1407ae499..f058e238ec 100644 --- a/compiler/gentype/Paths.ml +++ b/compiler/gentype/Paths.ml @@ -46,10 +46,10 @@ let append_suffix ~config source_path = ^ ModuleExtension.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 diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index e15adf31b4..ccc2129d88 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; @@ -3684,7 +3684,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 diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 6785374ac9..91c065442c 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/printtyp.ml b/compiler/ml/printtyp.ml index 9cf370da44..40105e0258 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -1751,7 +1751,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/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index 5b8e83bedb..5cf7eaf37c 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_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index a1cfd1c05a..bd2e73ba56 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -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 diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 619f71e692..4c79ff0f8f 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -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) = @@ -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?
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 diff --git a/compiler/syntax/src/res_scanner.ml b/compiler/syntax/src/res_scanner.ml index 0c4ae58bce..82fbeb533b 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 e55896796d..cbb78fad4b 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_unicode_tests.ml b/tests/ounit_tests/ounit_unicode_tests.ml index abb0523c49..f48c48bc08 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/tools/bin/main.ml b/tools/bin/main.ml index dcc1a3b71b..d1f92181d5 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.SharedTypes.FileSet.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.SharedTypes.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.FormatCodeblocks.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.ExtractCodeblocks.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 @@ -214,12 +214,12 @@ let main () = done; Sys.argv.(len - 1) <- ""; Reanalyze.ReanalyzeServer.server_cli ~parse_argv:Reanalyze.parse_argv - ~run_analysis:Reanalyze.runAnalysis () - | "extract-embedded" :: extPointNames :: filename :: _ -> - logAndExit + ~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 b6251dd246..185f9629d7 100644 --- a/tools/src/migrate.ml +++ b/tools/src/migrate.ml @@ -549,7 +549,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) -> @@ -736,11 +736,11 @@ let makeMapper (deprecated_used : Cmt_utils.deprecated_used list) = 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 +748,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,8 +756,8 @@ 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) = @@ -766,12 +766,12 @@ let migrate ~entryPointFile ~outputMode = 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 +781,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 +789,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 +801,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 +809,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 1831a90b30..07b32c3ef4 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 21cf5eea17..73ffa3324a 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -2,42 +2,42 @@ open Analysis module StringSet = 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,121 @@ 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 +168,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 +177,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 +194,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 +210,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 +230,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,20 +247,20 @@ 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)) ); ] @ @@ -268,45 +268,45 @@ and stringifyDocsForModule ~originalEnv (d : docsForModule) = | Some d -> [("deprecated", `String d)] | None -> []) -let fieldToFieldDoc (field : SharedTypes.field) : fieldDoc = +let field_to_field_doc (field : SharedTypes.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 type_detail typ ~env ~full = let open SharedTypes in - match TypeUtils.extractTypeFromResolvedType ~env ~full typ with + match TypeUtils.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 = CompletionBackEnd.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 +331,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 |> SharedTypes.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 + FindFiles.is_implementation path = false + && FindFiles.is_interface path = false with | false -> ( let path = - if FindFiles.isImplementation path then - let pathAsResi = + if FindFiles.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 +406,14 @@ let extractDocs ~entryPointFile ~debug = | Some full -> let file = full.file in let structure = file.structure in - let rootPath = full.package.rootPath in + let root_path = full.package.root_path in let open SharedTypes in - let env = QueryEnv.fromFile file in - let rec extractDocsForModule ?(modulePath = [env.file.moduleName]) + let env = QueryEnv.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 StringSet.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 +421,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 +439,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 + ProcessCmt.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 +495,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 +513,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 +535,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) + 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 + ProcessCmt.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 +562,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 StringSet.mem id !values_seen then None else ( - valuesSeen := StringSet.add id !valuesSeen; - Some docItem) - | _ -> Some docItem) + values_seen := StringSet.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 +591,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 +612,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 +621,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 +642,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 -> @@ -660,7 +660,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 +673,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 +688,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 +713,7 @@ module FormatCodeblocks = struct pexp_desc = Pexp_ident ({txt = Lident "assertEqual"} as - identTxt); + ident_txt); } as ident; partial = false; args = [rhs]; @@ -721,7 +721,7 @@ module FormatCodeblocks = struct } ); ]; } - when hasTransform AssertEqualFnToEquals -> + when has_transform AssertEqualFnToEquals -> { exp with pexp_desc = @@ -731,7 +731,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 +744,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: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 +793,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: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 +809,32 @@ 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 +843,18 @@ 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 +862,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 +880,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 +892,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 +912,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 @@ -932,7 +932,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 +948,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 +971,7 @@ module ExtractCodeblocks = struct pexp_desc = Pexp_ident { - identTxt with + ident_txt with txt = Lident "assertEqual"; }; }; @@ -988,36 +988,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 + FindFiles.is_implementation path = false + && FindFiles.is_interface path = false with | false -> ( let path = - if FindFiles.isImplementation path then - let pathAsResi = + if FindFiles.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 @@ -1027,68 +1027,68 @@ module ExtractCodeblocks = struct 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 env = QueryEnv.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 +1098,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: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: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 +1158,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 +1169,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 +1239,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 694a5c4e4b..3c7dfff646 100644 --- a/tools/src/transforms.ml +++ b/tools/src/transforms.ml @@ -1,7 +1,7 @@ -let labelledToUnlabelledArgumentsInFnDefinition (e : 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,28 @@ 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 +73,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 From 553477704bc09b30a1d24084bfce733ac9909255 Mon Sep 17 00:00:00 2001 From: Pedro Castro Date: Sun, 31 May 2026 09:33:02 -0300 Subject: [PATCH 2/5] Fix dune build errors --- analysis/bin/main.ml | 20 +- analysis/reanalyze/src/Arnold.ml | 81 +++-- analysis/reanalyze/src/CollectAnnotations.ml | 11 +- analysis/reanalyze/src/CrossFileItems.ml | 3 +- analysis/reanalyze/src/CrossFileItemsStore.ml | 3 +- analysis/reanalyze/src/DcePath.ml | 3 +- analysis/reanalyze/src/DeadCommon.ml | 18 +- analysis/reanalyze/src/DeadException.ml | 10 +- analysis/reanalyze/src/DeadModules.ml | 3 +- analysis/reanalyze/src/DeadOptionalArgs.ml | 14 +- analysis/reanalyze/src/DeadType.ml | 27 +- analysis/reanalyze/src/DeadValue.ml | 48 ++- analysis/reanalyze/src/EmitJson.ml | 4 +- analysis/reanalyze/src/Exception.ml | 32 +- analysis/reanalyze/src/ExnLib.ml | 4 +- analysis/reanalyze/src/FileDeps.ml | 10 +- analysis/reanalyze/src/Issues.ml | 3 +- analysis/reanalyze/src/ModulePath.ml | 3 +- analysis/reanalyze/src/ReactiveAnalysis.ml | 9 +- analysis/reanalyze/src/ReactiveSolver.ml | 12 +- analysis/reanalyze/src/ReactiveTypeDeps.ml | 3 +- analysis/reanalyze/src/Reanalyze.ml | 13 +- analysis/reanalyze/src/ReanalyzeServer.ml | 3 +- analysis/reanalyze/src/References.ml | 3 +- analysis/reanalyze/src/SideEffects.ml | 6 +- analysis/src/Cache.ml | 3 +- analysis/src/Cli.ml | 31 +- analysis/src/CmtViewer.ml | 3 +- analysis/src/CodeActions.ml | 13 +- analysis/src/Commands.ml | 37 +- analysis/src/CompletionBackEnd.ml | 329 ++++++++++-------- analysis/src/CompletionExpressions.ml | 46 ++- analysis/src/CompletionFrontEnd.ml | 63 ++-- analysis/src/CompletionJsx.ml | 23 +- analysis/src/CompletionPatterns.ml | 33 +- analysis/src/CreateInterface.ml | 11 +- analysis/src/DocumentSymbol.ml | 16 +- analysis/src/DotCompletionUtils.ml | 8 +- analysis/src/DumpAst.ml | 44 ++- analysis/src/FindFiles.ml | 30 +- analysis/src/Hint.ml | 4 +- analysis/src/Hover.ml | 39 ++- analysis/src/Packages.ml | 14 +- analysis/src/PipeCompletionUtils.ml | 4 +- analysis/src/PrintType.ml | 2 +- analysis/src/ProcessAttributes.ml | 3 +- analysis/src/ProcessCmt.ml | 32 +- analysis/src/ProcessExtra.ml | 30 +- analysis/src/References.ml | 18 +- analysis/src/ResolvePath.ml | 3 +- analysis/src/Scope.ml | 3 +- analysis/src/SemanticTokens.ml | 31 +- analysis/src/SharedTypes.ml | 36 +- analysis/src/SignatureHelp.ml | 46 +-- analysis/src/TypeUtils.ml | 204 ++++++----- analysis/src/Utils.ml | 3 +- analysis/src/Xform.ml | 63 ++-- tools/bin/main.ml | 4 +- tools/src/tools.ml | 49 +-- tools/src/transforms.ml | 10 +- 60 files changed, 997 insertions(+), 637 deletions(-) diff --git a/analysis/bin/main.ml b/analysis/bin/main.ml index 762ae2807c..0c70fd7fc7 100644 --- a/analysis/bin/main.ml +++ b/analysis/bin/main.ml @@ -142,7 +142,9 @@ let main () = | [_; "definition"; path; line; col] -> Cli.definition ~path ~pos:(int_of_string line, int_of_string col) ~debug | [_; "typeDefinition"; path; line; col] -> - Cli.type_definition ~path ~pos:(int_of_string line, int_of_string col) ~debug + Cli.type_definition ~path + ~pos:(int_of_string line, int_of_string col) + ~debug | [_; "documentSymbol"; path] -> DocumentSymbol.command ~path | [_; "hover"; path; line; col; current_file; supports_markdown_links] -> Cli.hover ~path @@ -153,7 +155,13 @@ let main () = | "true" -> true | _ -> false) | [ - _; "signatureHelp"; path; line; col; current_file; allow_for_constructor_payloads; + _; + "signatureHelp"; + path; + line; + col; + current_file; + allow_for_constructor_payloads; ] -> Cli.signature_help ~path ~pos:(int_of_string line, int_of_string col) @@ -167,8 +175,9 @@ let main () = ~pos:(int_of_string line_start, int_of_string line_end) ~max_length ~debug | [_; "codeLens"; path] -> Cli.code_lens ~path ~debug - | [_; "codeAction"; path; start_line; start_col; end_line; end_col; current_file] - -> + | [ + _; "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) @@ -195,7 +204,8 @@ let main () = Cli.rename ~path ~pos:(int_of_string line, int_of_string col) ~new_name ~debug - | [_; "semanticTokens"; current_file] -> Cli.semantic_tokens ~path:current_file + | [_; "semanticTokens"; current_file] -> + Cli.semantic_tokens ~path:current_file | [_; "createInterface"; path; cmi_file] -> `String (CreateInterface.command ~path ~cmi_file) |> Yojson.Safe.pretty_to_string ~std:true diff --git a/analysis/reanalyze/src/Arnold.ml b/analysis/reanalyze/src/Arnold.ml index 4125aa0496..c23a122914 100644 --- a/analysis/reanalyze/src/Arnold.ml +++ b/analysis/reanalyze/src/Arnold.ml @@ -591,8 +591,8 @@ module ExtendFunctionTable = struct 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 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 @@ -607,7 +607,9 @@ module ExtendFunctionTable = struct (StringSet.inter (Lazy.force callees) progress_functions)) then let function_name = Path.name callee in - if not (callee |> FunctionTable.is_in_function_in_table ~function_table) + if + not + (callee |> FunctionTable.is_in_function_in_table ~function_table) then ( function_table |> FunctionTable.add_function ~function_name; if config.DceConfig.cli.debug then @@ -628,7 +630,8 @@ module ExtendFunctionTable = struct |> 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 |> FunctionTable.is_in_function_in_table ~function_table + when path + |> FunctionTable.is_in_function_in_table ~function_table -> function_table |> FunctionTable.add_label_to_kind ~function_name ~label; @@ -652,7 +655,8 @@ module ExtendFunctionTable = struct 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 + traverse_expr ~config ~function_table ~progress_functions + ~value_bindings_table in expression |> traverse_expr.expr traverse_expr |> ignore end @@ -674,7 +678,9 @@ module CheckExpressionWellFormed = struct let function_name = Path.name function_path in args |> List.iter (fun ((arg_label : Asttypes.arg_label), arg_opt) -> - match arg_opt |> ExtendFunctionTable.extract_labelled_argument with + match + arg_opt |> ExtendFunctionTable.extract_labelled_argument + with | Some (path, loc) -> ( match arg_label with | Labelled {txt = label} -> ( @@ -685,14 +691,17 @@ module CheckExpressionWellFormed = struct <> None then () else - match Hashtbl.find_opt value_bindings_table function_name with + match + Hashtbl.find_opt value_bindings_table function_name + with | Some (_pos, (body : Typedtree.expression), _) when path - |> FunctionTable.is_in_function_in_table ~function_table - -> + |> FunctionTable.is_in_function_in_table + ~function_table -> let in_table = function_path - |> FunctionTable.is_in_function_in_table ~function_table + |> FunctionTable.is_in_function_in_table + ~function_table in if not in_table then function_table @@ -809,7 +818,8 @@ module Compile = struct Stats.log_hygiene_must_have_named_argument ~label ~loc; raise ArgError | Some (path, _pos) - when path |> FunctionTable.is_in_function_in_table ~function_table -> + when path |> FunctionTable.is_in_function_in_table ~function_table + -> let function_name = Path.name path in {FunctionArgs.label; function_name} | Some (path, _pos) @@ -864,14 +874,17 @@ module Compile = struct in_expr ) -> let old_function_name = Ident.name id in let new_function_name = current_function_name ^ "$" ^ old_function_name in - function_table |> FunctionTable.add_function ~function_name:new_function_name; + function_table + |> FunctionTable.add_function ~function_name:new_function_name; let new_function_definition = function_table - |> FunctionTable.get_function_definition ~function_name:new_function_name + |> FunctionTable.get_function_definition + ~function_name:new_function_name in let current_function_definition = function_table - |> FunctionTable.get_function_definition ~function_name:current_function_name + |> FunctionTable.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 @@ -1080,13 +1093,13 @@ module Eval = struct 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; + 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 = + let has_infinite_loop ~call_stack ~function_call_to_instantiate ~function_call + ~loc ~state = if call_stack |> CallStack.has_function_call ~function_call then ( if state.State.progress = NoProgress then ( Log_.error ~loc @@ -1112,8 +1125,9 @@ module Eval = struct 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 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 @@ -1133,13 +1147,14 @@ module Eval = struct if FunctionCallSet.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 + 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 |> FunctionTable.get_function_definition ~function_name + function_table + |> FunctionTable.get_function_definition ~function_name in call_stack |> CallStack.add_function_call ~function_call ~pos; let body = @@ -1153,7 +1168,8 @@ module Eval = struct ~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; + cache + |> update_cache ~config ~function_call ~loc ~state:state_after_call; (* Invariant: run should restore the callStack *) call_stack |> CallStack.remove_function_call ~function_call; let trace = Trace.Tcall (call, state_after_call.progress) in @@ -1166,8 +1182,8 @@ module Eval = struct 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 + |> 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)) () @@ -1185,7 +1201,8 @@ module Eval = struct 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 = + let rec find_first_progress ~call_stack ~commands ~made_progress_on ~state + = match commands with | [] -> state | c :: next_commands -> @@ -1203,8 +1220,8 @@ module Eval = struct CallStack.create () ) | NoProgress -> (made_progress_on, call_stack) in - find_first_progress ~call_stack ~commands:next_commands ~made_progress_on - ~state:state1 + 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 -> @@ -1318,7 +1335,8 @@ let traverse_ast ~config ~value_bindings_table = (fun (progress_functions, functions_to_analyze) (value_binding : Typedtree.value_binding) -> match - progress_functions_from_attributes value_binding.vb_attributes + progress_functions_from_attributes + value_binding.vb_attributes with | None -> (progress_functions, functions_to_analyze) | Some new_progress_functions -> @@ -1402,7 +1420,8 @@ let traverse_ast ~config ~value_bindings_table = |> 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)); + Stats.new_recursive_functions + ~num_functions:(Hashtbl.length function_table)); value_bindings |> List.iter (fun value_binding -> super.value_binding self value_binding |> ignore); diff --git a/analysis/reanalyze/src/CollectAnnotations.ml b/analysis/reanalyze/src/CollectAnnotations.ml index c37021f960..318348edf0 100644 --- a/analysis/reanalyze/src/CollectAnnotations.ml +++ b/analysis/reanalyze/src/CollectAnnotations.ml @@ -7,8 +7,8 @@ open DeadCommon type scope_default = FileAnnotations.annotated_as option -let process_attributes ~(scope_default : scope_default) ~state ~config ~do_gen_type - ~name ~pos attributes = +let process_attributes ~(scope_default : scope_default) ~state ~config + ~do_gen_type ~name ~pos attributes = (match scope_default with | Some FileAnnotations.Live -> FileAnnotations.annotate_live state pos | Some FileAnnotations.Dead -> FileAnnotations.annotate_dead state pos @@ -39,8 +39,8 @@ let process_attributes ~(scope_default : scope_default) ~state ~config ~do_gen_t 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 - FileAnnotations.annotate_live state pos; + if get_payload live_annotation <> None || name_is_in_live_names_or_paths () + then FileAnnotations.annotate_live state pos; if attributes |> Annotation.is_ocaml_suppress_dead_warning then FileAnnotations.annotate_live state pos @@ -66,7 +66,8 @@ let collect_export_locations ~state ~config ~do_gen_type = (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 FileAnnotations.annotate_live state pos; + if !currently_disable_warnings then + FileAnnotations.annotate_live state pos; vb_attributes |> process_attributes ~scope_default:!current_scope_default ~state ~config ~do_gen_type ~name:(id |> Ident.name) ~pos diff --git a/analysis/reanalyze/src/CrossFileItems.ml b/analysis/reanalyze/src/CrossFileItems.ml index efc3070581..fde8a22e2b 100644 --- a/analysis/reanalyze/src/CrossFileItems.ml +++ b/analysis/reanalyze/src/CrossFileItems.ml @@ -76,5 +76,4 @@ let process_exception_refs (t : t) ~refs ~file_deps ~find_exception ~config = | None -> () | Some loc_to -> DeadCommon.add_value_reference ~config ~refs ~file_deps - ~binding:Location.none ~add_file_reference:true ~loc_from:loc_from - ~loc_to:loc_to) + ~binding:Location.none ~add_file_reference:true ~loc_from ~loc_to) diff --git a/analysis/reanalyze/src/CrossFileItemsStore.ml b/analysis/reanalyze/src/CrossFileItemsStore.ml index d2eb54fbe3..2648fa886e 100644 --- a/analysis/reanalyze/src/CrossFileItemsStore.ml +++ b/analysis/reanalyze/src/CrossFileItemsStore.ml @@ -50,8 +50,7 @@ let compute_optional_args_state (store : t) ~find_decl ~is_live : if is_live pos_from then let current = get_state pos_to in let updated = - OptionalArgs.apply_call ~arg_names:arg_names - ~arg_names_maybe:arg_names_maybe current + OptionalArgs.apply_call ~arg_names ~arg_names_maybe current in set_state pos_to updated); (* Process function references *) diff --git a/analysis/reanalyze/src/DcePath.ml b/analysis/reanalyze/src/DcePath.ml index dbac43222c..c6913548a3 100644 --- a/analysis/reanalyze/src/DcePath.ml +++ b/analysis/reanalyze/src/DcePath.ml @@ -33,7 +33,8 @@ let module_to_implementation path = let module_to_interface path = match path |> List.rev with - | module_name :: rest -> (module_name |> Name.to_interface) :: rest |> List.rev + | module_name :: rest -> + (module_name |> Name.to_interface) :: rest |> List.rev | [] -> path let to_module_name ~is_type path = diff --git a/analysis/reanalyze/src/DeadCommon.ml b/analysis/reanalyze/src/DeadCommon.ml index 0efabf86f1..5c36c8b6db 100644 --- a/analysis/reanalyze/src/DeadCommon.ml +++ b/analysis/reanalyze/src/DeadCommon.ml @@ -105,7 +105,8 @@ let addDeclaration_ ~config ~decls ~(file : FileContext.t) ?pos_end ?pos_start if config.DceConfig.cli.debug then Log_.item "add%sDeclaration %s %s path:%s@." (decl_kind |> Decl.Kind.to_string) - (name |> Name.to_string) (pos |> Pos.to_string) (path |> DcePath.to_string); + (name |> Name.to_string) (pos |> Pos.to_string) + (path |> DcePath.to_string); let decl = { Decl.decl_kind; @@ -404,7 +405,8 @@ let solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state match DeclarationStore.find_opt decl_store target with | None -> false | Some target_decl -> - Log_.item " -> %s@." (target_decl.path |> DcePath.to_string); + Log_.item " -> %s@." + (target_decl.path |> DcePath.to_string); true in let shown = ref 0 in @@ -445,8 +447,10 @@ let solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state IncorrectDeadAnnotation in decl.path - |> DcePath.to_module_name ~is_type:(decl.decl_kind |> Decl.Kind.is_type) - |> DeadModules.check_module_dead ~config ~file_name:decl.pos.pos_fname + |> DcePath.to_module_name + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + |> DeadModules.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))); @@ -564,8 +568,10 @@ let solve_dead_reactive ~ann_store ~config ~decl_store ~value_refs_from IncorrectDeadAnnotation in decl.path - |> DcePath.to_module_name ~is_type:(decl.decl_kind |> Decl.Kind.is_type) - |> DeadModules.check_module_dead ~config ~file_name:decl.pos.pos_fname + |> DcePath.to_module_name + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + |> DeadModules.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))); diff --git a/analysis/reanalyze/src/DeadException.ml b/analysis/reanalyze/src/DeadException.ml index d9b5306860..ccd03c9a62 100644 --- a/analysis/reanalyze/src/DeadException.ml +++ b/analysis/reanalyze/src/DeadException.ml @@ -30,7 +30,8 @@ let find_exception_from_decls (decls : Declarations.t) : 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; + ~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) @@ -40,8 +41,7 @@ let mark_as_used ~config ~refs ~file_deps ~cross_file ~(binding : Location.t) let exception_path = path_ |> DcePath.from_path_t |> DcePath.module_to_implementation in - CrossFileItems.add_exception_ref cross_file ~exception_path:exception_path - ~loc_from:loc_from + CrossFileItems.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 + add_value_reference ~config ~refs ~file_deps ~binding + ~add_file_reference:true ~loc_from ~loc_to diff --git a/analysis/reanalyze/src/DeadModules.ml b/analysis/reanalyze/src/DeadModules.ml index 0f6478675e..2c3fec7663 100644 --- a/analysis/reanalyze/src/DeadModules.ml +++ b/analysis/reanalyze/src/DeadModules.ml @@ -20,7 +20,8 @@ let mark_live ~config ~is_type ~(loc : Location.t) path = | 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 = +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 diff --git a/analysis/reanalyze/src/DeadOptionalArgs.ml b/analysis/reanalyze/src/DeadOptionalArgs.ml index b4df1f9a0f..6083869454 100644 --- a/analysis/reanalyze/src/DeadOptionalArgs.ml +++ b/analysis/reanalyze/src/DeadOptionalArgs.ml @@ -17,9 +17,9 @@ let add_function_reference ~config ~decls ~cross_file ~(loc_from : Location.t) if should_add then ( if config.DceConfig.cli.debug then Log_.item "OptionalArgs.addFunctionReference %s %s@." - (pos_from |> Pos.to_string) (pos_to |> Pos.to_string); - CrossFileItems.add_function_reference cross_file ~pos_from:pos_from - ~pos_to:pos_to) + (pos_from |> Pos.to_string) + (pos_to |> Pos.to_string); + CrossFileItems.add_function_reference cross_file ~pos_from ~pos_to) let rec has_optional_args (texpr : Types.type_expr) = match texpr.desc with @@ -40,13 +40,13 @@ let rec from_type_expr (texpr : Types.type_expr) = | _ -> [] let add_references ~config ~cross_file ~(loc_from : Location.t) - ~(loc_to : Location.t) ~(binding : Location.t) ~path (arg_names, arg_names_maybe) - = + ~(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 - CrossFileItems.add_optional_arg_call cross_file ~pos_from:pos_from - ~pos_to:pos_to ~arg_names:arg_names ~arg_names_maybe:arg_names_maybe; + CrossFileItems.add_optional_arg_call cross_file ~pos_from ~pos_to ~arg_names + ~arg_names_maybe; if config.DceConfig.cli.debug then let call_pos = loc_from.loc_start in Log_.item diff --git a/analysis/reanalyze/src/DeadType.ml b/analysis/reanalyze/src/DeadType.ml index 9b45c6f1f1..c3dd09df04 100644 --- a/analysis/reanalyze/src/DeadType.ml +++ b/analysis/reanalyze/src/DeadType.ml @@ -4,12 +4,13 @@ open DeadCommon let add_type_reference ~config ~refs ~pos_from ~pos_to = if config.DceConfig.cli.debug then - Log_.item "addTypeReference %s --> %s@." (pos_from |> Pos.to_string) + 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 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 ( @@ -21,12 +22,15 @@ let extend_type_dependencies ~config ~refs (loc1 : Location.t) (loc2 : Location. let add_declaration ~config ~decls ~file ~(module_path : ModulePath.t) ~(type_id : Ident.t) ~(type_kind : Types.type_kind) ~(manifest_type_path : DcePath.t option) = - let module_context = module_path.path @ [FileContext.module_name_tagged file] in + let module_context = + module_path.path @ [FileContext.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) = + 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 + ?manifest_type_path ~module_loc:module_path.loc ~pos_adjustment + type_label_name in match type_kind with | Type_record (l, _) -> @@ -198,7 +202,8 @@ let process_type_label_dependencies ~config ~decls ~refs = 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)) + Hashtbl.replace groups current_type_path (rep_pos, mtp0, item :: items) + ) | _ -> ()) decls; @@ -215,5 +220,7 @@ let process_type_label_dependencies ~config ~decls ~refs = 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)) + extend_type_dependencies ~config ~refs current_loc + manifest_loc; + extend_type_dependencies ~config ~refs manifest_loc + current_loc)) diff --git a/analysis/reanalyze/src/DeadValue.ml b/analysis/reanalyze/src/DeadValue.ml index ab97424abd..898aef49f3 100644 --- a/analysis/reanalyze/src/DeadValue.ml +++ b/analysis/reanalyze/src/DeadValue.ml @@ -18,7 +18,8 @@ let check_any_value_binding_with_no_side_effects ~config ~decls ~file let collect_value_binding ~config ~decls ~file ~(current_binding : Location.t) ~(module_path : ModulePath.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; + 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}) @@ -101,7 +102,8 @@ let process_optional_args ~config ~cross_file ~exp_type ~(loc_from : Location.t) 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 + if arg_is_supplied = None then + supplied_maybe := s :: !supplied_maybe | _ -> ()); (!supplied, !supplied_maybe) |> DeadOptionalArgs.add_references ~config ~cross_file ~loc_from ~loc_to @@ -124,8 +126,8 @@ let rec collect_expr ~config ~refs ~file_deps ~cross_file 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 + add_value_reference ~config ~refs ~file_deps ~binding + ~add_file_reference:true ~loc_from ~loc_to | Texp_apply { funct = @@ -138,7 +140,7 @@ let rec collect_expr ~config ~refs ~file_deps ~cross_file args; } -> args - |> process_optional_args ~config ~cross_file ~exp_type:exp_type + |> process_optional_args ~config ~cross_file ~exp_type ~loc_from:(loc_from : Location.t) ~binding:last_binding ~loc_to ~path | Texp_let @@ -179,25 +181,30 @@ let rec collect_expr ~config ~refs ~file_deps ~cross_file && Ident.name eta_arg = "eta" && Path.name id_arg2 = "arg" -> args - |> process_optional_args ~config ~cross_file ~exp_type:exp_type + |> 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 - DeadType.add_type_reference ~config ~refs ~pos_to ~pos_from:loc_from.loc_start + DeadType.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}, + { + cstr_loc = {Location.loc_start = pos_to; loc_ghost} as loc_to; + cstr_tag; + }, _ ) -> (match cstr_tag with | Cstr_extension path -> path - |> DeadException.mark_as_used ~config ~refs ~file_deps ~cross_file ~binding - ~loc_from ~loc_to + |> DeadException.mark_as_used ~config ~refs ~file_deps ~cross_file + ~binding ~loc_from ~loc_to | _ -> ()); if !Config.analyze_types && not loc_ghost then - DeadType.add_type_reference ~config ~refs ~pos_to ~pos_from:loc_from.loc_start + DeadType.add_type_reference ~config ~refs ~pos_to + ~pos_from:loc_from.loc_start | Texp_record {fields} -> fields |> Array.iter (fun (_, record_label_definition, _) -> @@ -242,8 +249,9 @@ let rec get_signature (module_type : Types.module_type) = | Mty_functor (_, _mtParam, mt) -> get_signature mt | _ -> [] -let rec process_signature_item ~config ~decls ~file ~do_types ~do_values ~module_loc - ~(module_path : ModulePath.t) ~path (si : Types.signature_item) = +let rec process_signature_item ~config ~decls ~file ~do_types ~do_values + ~module_loc ~(module_path : ModulePath.t) ~path (si : Types.signature_item) + = match si with | Sig_type (id, t, _) when do_types -> if !Config.analyze_types then @@ -261,7 +269,8 @@ let rec process_signature_item ~config ~decls ~file ~do_types ~do_values ~module Some (type_name :: module_context) | _ -> Some - (if FileContext.is_interface file then DcePath.module_to_interface p + (if FileContext.is_interface file then + DcePath.module_to_interface p else DcePath.module_to_implementation p)) | _ -> None in @@ -287,7 +296,8 @@ let rec process_signature_item ~config ~decls ~file ~do_types ~do_values ~module |> 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}) -> + | Sig_modtype (id, {Types.mtd_type = Some module_type; mtd_loc = module_loc}) + -> let modulePath' = ModulePath.enter_module module_path ~name:(id |> Ident.name |> Name.create) @@ -307,8 +317,8 @@ let rec process_signature_item ~config ~decls ~file ~do_types ~do_values ~module | _ -> () (* Traverse the AST *) -let traverse_structure ~config ~decls ~refs ~file_deps ~cross_file ~file ~do_types - ~do_externals (structure : Typedtree.structure) : unit = +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 : ModulePath.t) = let super = Tast_mapper.default in @@ -462,8 +472,8 @@ let process_value_dependency ~config ~decls ~refs ~file_deps ~cross_file Types.value_description), ({ val_loc = - {loc_start = {pos_fname = fn_from} as pos_from; loc_ghost = ghost2} as - loc_from; + {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 ( diff --git a/analysis/reanalyze/src/EmitJson.ml b/analysis/reanalyze/src/EmitJson.ml index 5a10de9c63..841f79e14b 100644 --- a/analysis/reanalyze/src/EmitJson.ml +++ b/analysis/reanalyze/src/EmitJson.ml @@ -14,8 +14,8 @@ let emit_item ~ppf ~name ~kind ~file ~range ~message = 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 " \"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) = diff --git a/analysis/reanalyze/src/Exception.ml b/analysis/reanalyze/src/Exception.ml index 2a568a5d36..90792d018d 100644 --- a/analysis/reanalyze/src/Exception.ml +++ b/analysis/reanalyze/src/Exception.ml @@ -8,7 +8,8 @@ type values_table = (string, (Name.t, Exceptions.t) Hashtbl.t) Hashtbl.t let create_values_builder () : values_builder = Hashtbl.create 15 -let values_builder_add (builder : values_builder) ~module_path ~name exceptions = +let values_builder_add (builder : values_builder) ~module_path ~name exceptions + = let path = (name |> Name.create) :: module_path.ModulePath.path in Hashtbl.replace builder (path |> DcePath.to_name) exceptions @@ -58,7 +59,8 @@ module Values = struct | 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 + find_external ~external_module_name:external_module_name2 + ~path_rev:path_rev2 | None, _ -> None) | [] -> None) | Some exceptions -> Some exceptions @@ -115,7 +117,8 @@ module Event = struct in let shrink_exn_table exn loc = match Hashtbl.find_opt exn_table exn with - | Some loc_set -> Hashtbl.replace exn_table exn (LocSet.remove loc loc_set) + | Some loc_set -> + Hashtbl.replace exn_table exn (LocSet.remove loc loc_set) | None -> () in let rec loop exn_set events = @@ -190,7 +193,8 @@ 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 + builder := + {events; exceptions; loc; loc_full; module_name; exn_name} :: !builder let checks_builder_to_list (builder : checks_builder) : check list = !builder |> List.rev @@ -248,7 +252,8 @@ let traverse_ast ~file ~values_builder ~checks_builder () = | None -> ( match module_path with | [] -> None - | _ :: rest_module_path -> path |> find_local_path ~module_path:rest_module_path) + | _ :: rest_module_path -> + path |> find_local_path ~module_path:rest_module_path) in let exceptions_of_patterns patterns = patterns @@ -328,10 +333,11 @@ let traverse_ast ~file ~values_builder ~checks_builder () = args = [(_lbl1, Some {exp_desc = Texp_ident (callee, _, _)}); arg]; } when (* raise @@ Exn(...) *) - atat |> Path.name = "Pervasives.@@" && callee |> Path.name |> is_throw - -> + atat |> Path.name = "Pervasives.@@" + && callee |> Path.name |> is_throw -> let exceptions = [arg] |> throw_args in - current_events := {Event.exceptions; loc; kind = Throws} :: !current_events; + 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 @@ -396,7 +402,8 @@ let traverse_ast ~file ~values_builder ~checks_builder () = in let rec get_exceptions payload = match payload with - | Annotation.StringPayload s -> [Exn.from_string s] |> Exceptions.from_list + | 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 -> @@ -461,14 +468,15 @@ let traverse_ast ~file ~values_builder ~checks_builder () = res in match vb.vb_pat.pat_desc with - | Tpat_any when is_toplevel && not vb.vb_loc.loc_ghost -> process_binding "_" + | 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 -> + 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 diff --git a/analysis/reanalyze/src/ExnLib.ml b/analysis/reanalyze/src/ExnLib.ml index 24a88a8fc6..8f5601fac5 100644 --- a/analysis/reanalyze/src/ExnLib.ml +++ b/analysis/reanalyze/src/ExnLib.ml @@ -125,7 +125,9 @@ let raises_lib_table : (Name.t, Exceptions.t) Hashtbl.t = ] in let stdlib_list = - [("headExn", [not_found]); ("tailExn", [not_found]); ("getExn", [not_found])] + [ + ("headExn", [not_found]); ("tailExn", [not_found]); ("getExn", [not_found]); + ] in let stdlib_null = [("getExn", [invalid_argument])] in let stdlib_nullable = [("getExn", [invalid_argument])] in diff --git a/analysis/reanalyze/src/FileDeps.ml b/analysis/reanalyze/src/FileDeps.ml index b85c8d2858..b84fd04642 100644 --- a/analysis/reanalyze/src/FileDeps.ml +++ b/analysis/reanalyze/src/FileDeps.ml @@ -98,7 +98,9 @@ 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, FileSet.t) Hashtbl.t) in + let references_by_number = + (Hashtbl.create 256 : (int, FileSet.t) Hashtbl.t) + in let get_num file_name = try Hashtbl.find inverse_references file_name with Not_found -> 0 in @@ -135,7 +137,8 @@ let iter_files_from_roots_to_leaves (t : t) iter_fun = in iter_deps t (fun from_file set -> if get_num from_file = 0 then - Hashtbl.replace references_by_number 0 (FileSet.add from_file (get_set 0)); + Hashtbl.replace references_by_number 0 + (FileSet.add from_file (get_set 0)); set |> FileSet.iter (fun to_file -> add_edge from_file to_file)); while get_set 0 <> FileSet.empty do let files_with_no_incoming_references = get_set 0 in @@ -144,7 +147,8 @@ let iter_files_from_roots_to_leaves (t : t) iter_fun = |> FileSet.iter (fun file_name -> iter_fun file_name; let references = get_deps t file_name in - references |> FileSet.iter (fun to_file -> remove_edge file_name to_file)) + references + |> FileSet.iter (fun to_file -> remove_edge file_name to_file)) done; (* Process any remaining items in case of circular references *) references_by_number diff --git a/analysis/reanalyze/src/Issues.ml b/analysis/reanalyze/src/Issues.ml index 309196b8e0..62f6452370 100644 --- a/analysis/reanalyze/src/Issues.ml +++ b/analysis/reanalyze/src/Issues.ml @@ -9,6 +9,7 @@ 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_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/ModulePath.ml b/analysis/reanalyze/src/ModulePath.ml index 1f917b28ca..6d41467bf0 100644 --- a/analysis/reanalyze/src/ModulePath.ml +++ b/analysis/reanalyze/src/ModulePath.ml @@ -13,7 +13,8 @@ let normalize_path ~aliases path = | Some path1 -> let new_path = List.rev (path1 @ rest_rev) in if !Cli.debug then - Log_.item "Resolve Alias: %s to %s@." (path |> DcePath.to_string) + Log_.item "Resolve Alias: %s to %s@." + (path |> DcePath.to_string) (new_path |> DcePath.to_string); new_path) | _ -> path diff --git a/analysis/reanalyze/src/ReactiveAnalysis.ml b/analysis/reanalyze/src/ReactiveAnalysis.ml index c881bc6902..55ea80050d 100644 --- a/analysis/reanalyze/src/ReactiveAnalysis.ml +++ b/analysis/reanalyze/src/ReactiveAnalysis.ml @@ -27,7 +27,8 @@ type processing_stats = { (** Stats from a process_files call *) (** Process cmt_infos into a file result *) -let process_cmt_infos ~config ~cmt_file_path cmt_infos : cmt_file_result option = +let process_cmt_infos ~config ~cmt_file_path cmt_infos : cmt_file_result option + = let exclude_path source_file = config.DceConfig.cli.exclude_paths |> List.exists (fun prefix_ -> @@ -43,18 +44,18 @@ let process_cmt_infos ~config ~cmt_file_path cmt_infos : cmt_file_result option in match cmt_infos.Cmt_format.cmt_annots |> FindSourceFile.cmt with | Some source_file when not (exclude_path source_file) -> - let is_interface = + let is_interface_ = match cmt_infos.cmt_annots with | Interface _ -> true | _ -> Filename.check_suffix source_file "i" in let module_name = source_file |> Paths.get_module_name in let dce_file_context : DceFileProcessing.file_context = - {source_path = source_file; module_name; is_interface} + {source_path = source_file; module_name; is_interface = is_interface_} in let file_context = DeadCommon.FileContext. - {source_path = source_file; module_name; is_interface} + {source_path = source_file; module_name; is_interface = is_interface_} in let dce_data = if config.DceConfig.run.dce then diff --git a/analysis/reanalyze/src/ReactiveSolver.ml b/analysis/reanalyze/src/ReactiveSolver.ml index f7a5ded54d..dd303f1c37 100644 --- a/analysis/reanalyze/src/ReactiveSolver.ml +++ b/analysis/reanalyze/src/ReactiveSolver.ml @@ -46,7 +46,8 @@ type t = { (** Extract module name from a declaration *) let decl_module_name (decl : Decl.t) : Name.t = - decl.path |> DcePath.to_module_name ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + decl.path + |> DcePath.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) @@ -158,8 +159,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let file_issues = sorted |> List.concat_map (fun decl -> - DeadCommon.report_declaration ~config ~has_ref_below ~check_module_dead - ~should_report reporting_ctx decl) + DeadCommon.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 [] @@ -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 - [(module_name, AnalysisResult.make_dead_module_issue ~loc ~module_name)] + [ + ( module_name, + AnalysisResult.make_dead_module_issue ~loc ~module_name ); + ] | None -> []) () in diff --git a/analysis/reanalyze/src/ReactiveTypeDeps.ml b/analysis/reanalyze/src/ReactiveTypeDeps.ml index 2264dd0b4d..fdb538a67f 100644 --- a/analysis/reanalyze/src/ReactiveTypeDeps.ml +++ b/analysis/reanalyze/src/ReactiveTypeDeps.ml @@ -26,7 +26,8 @@ let decl_to_info (decl : Decl.t) : decl_info option = | module_name_tag :: _ -> ( try (module_name_tag |> Name.to_string).[0] <> '+' with _ -> true) in - Some {pos = decl.pos; pos_end = decl.pos_end; path = decl.path; is_interface} + Some + {pos = decl.pos; pos_end = decl.pos_end; path = decl.path; is_interface} | _ -> None (** {1 Reactive Collections} *) diff --git a/analysis/reanalyze/src/Reanalyze.ml b/analysis/reanalyze/src/Reanalyze.ml index c122940536..2fde62c28e 100644 --- a/analysis/reanalyze/src/Reanalyze.ml +++ b/analysis/reanalyze/src/Reanalyze.ml @@ -25,7 +25,7 @@ let load_cmt_file ~config cmt_file_path : cmt_file_result option = in match cmt_infos.cmt_annots |> FindSourceFile.cmt with | Some source_file when not (exclude_path source_file) -> - let is_interface = + let is_interface_ = match cmt_infos.cmt_annots with | Interface _ -> true | _ -> Filename.check_suffix source_file "i" @@ -33,12 +33,12 @@ let load_cmt_file ~config cmt_file_path : cmt_file_result option = 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 = source_file; module_name; is_interface} + {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 = source_file; module_name; is_interface} + {source_path = source_file; module_name; is_interface = is_interface_} in if config.cli.debug then Log_.item "Scanning %s Source:%s@." @@ -93,7 +93,8 @@ let collect_cmt_file_paths ~cmt_root : string list = in 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)) + abs_dir |> Sys.readdir + |> Array.iter (fun d -> walk_sub_dirs (dir +++ d)) else if Filename.check_suffix abs_dir ".cmt" || Filename.check_suffix abs_dir ".cmti" @@ -199,8 +200,8 @@ 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} = - process_cmt_files ~config:dce_config ~cmt_root ~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 = diff --git a/analysis/reanalyze/src/ReanalyzeServer.ml b/analysis/reanalyze/src/ReanalyzeServer.ml index a92d363790..66cd16789a 100644 --- a/analysis/reanalyze/src/ReanalyzeServer.ml +++ b/analysis/reanalyze/src/ReanalyzeServer.ml @@ -377,7 +377,8 @@ Examples: Printf.printf "\n"; EmitJson.start (); let p = state.pipeline in - state.run_analysis ~dce_config:p.dce_config ~cmt_root:state.cmt_root + 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) diff --git a/analysis/reanalyze/src/References.ml b/analysis/reanalyze/src/References.ml index e073216fd5..1d9dd90ae5 100644 --- a/analysis/reanalyze/src/References.ml +++ b/analysis/reanalyze/src/References.ml @@ -35,7 +35,8 @@ let add_type_ref (builder : builder) ~pos_to ~pos_from = let merge_into_builder ~(from : builder) ~(into : builder) = PosHash.iter (fun pos refs -> - refs |> PosSet.iter (fun to_pos -> add_set into.value_refs_from pos to_pos)) + refs + |> PosSet.iter (fun to_pos -> add_set into.value_refs_from pos to_pos)) from.value_refs_from; PosHash.iter (fun pos refs -> diff --git a/analysis/reanalyze/src/SideEffects.ml b/analysis/reanalyze/src/SideEffects.ml index dfdb6396b3..0d1a9c5d54 100644 --- a/analysis/reanalyze/src/SideEffects.ml +++ b/analysis/reanalyze/src/SideEffects.ml @@ -33,7 +33,8 @@ let rec expr_no_side_effects (expr : Typedtree.expression) = 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_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) -> @@ -58,7 +59,8 @@ let rec expr_no_side_effects (expr : Typedtree.expression) = | 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_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 diff --git a/analysis/src/Cache.ml b/analysis/src/Cache.ml index 3df0bbb30b..f2c704a156 100644 --- a/analysis/src/Cache.ml +++ b/analysis/src/Cache.ml @@ -23,7 +23,8 @@ let read_cache filename = 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 target_file_from_lib_bs lib_bs = + Filename.concat lib_bs ".project-files-cache" let cache_project (package : package) = let cached = diff --git a/analysis/src/Cli.ml b/analysis/src/Cli.ml index d795f84e10..2e4e9bc7fd 100644 --- a/analysis/src/Cli.ml +++ b/analysis/src/Cli.ml @@ -50,12 +50,14 @@ let hover ~path ~pos ~current_file ~debug ~supports_markdown_links = | None -> print_null () | Some source -> ( match - Commands.hover ~source ~kind_file ~pos ~debug ~supports_markdown_links ~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 signature_help ~path ~pos ~current_file ~debug ~allow_for_constructor_payloads = +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 @@ -73,7 +75,8 @@ let code_action ~path ~start_pos ~end_pos ~current_file ~debug = match Files.read_file current_file with | None -> print_null () | Some source -> - Xform.extract_code_actions ~path ~start_pos ~end_pos ~source ~kind_file ~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 @@ -102,7 +105,7 @@ let references ~path ~pos ~debug = 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 {document_changes = Some document_changes} -> + | Some {documentChanges = Some document_changes} -> document_changes |> List.map (fun c -> match c with @@ -135,7 +138,7 @@ let format ~path = match Commands.format ~source ~kind_file with | Ok text_edits -> ( match text_edits with - | {new_text} :: _ -> print_string (`String new_text) + | {newText} :: _ -> print_string (`String newText) | _ -> print_null ()) | Error _ -> print_null ()) @@ -211,7 +214,9 @@ let test ~path = Printf.printf "Setting version: %s\n" version; match String.split_on_char '.' version with | [major_raw; minor_raw] -> - let version = (int_of_string major_raw, int_of_string minor_raw) in + let version = + (int_of_string major_raw, int_of_string minor_raw) + in Packages.override_rescript_version := Some version | _ -> ()) | "ve-" -> Packages.override_rescript_version := None @@ -318,16 +323,16 @@ let test ~path = in 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 + Xform.extract_code_actions ~path ~start_pos ~end_pos ~source + ~kind_file ~debug:true in Sys.remove current_file; code_actions |> List.iter (fun {Lsp.Types.CodeAction.title; edit} -> Printf.printf "Hit: %s\n" title; match edit with - | Some {document_changes} -> - document_changes |> Option.get + | Some {documentChanges} -> + documentChanges |> Option.get |> List.iter (fun (dc : @@ -340,7 +345,7 @@ let test ~path = match dc with | `TextDocumentEdit tde -> let filename = - tde.text_document.uri |> Uri.to_path + tde.textDocument.uri |> Uri.to_path |> Filename.basename in Printf.printf "\nTextDocumentEdit: %s\n" filename; @@ -357,11 +362,11 @@ let test ~path = match edit with | `TextEdit te -> ( te.range.start.character, - te.new_text, + te.newText, te.range ) | `AnnotatedTextEdit te -> ( te.range.start.character, - te.new_text, + te.newText, te.range ) in let indent = String.make start_char ' ' in diff --git a/analysis/src/CmtViewer.ml b/analysis/src/CmtViewer.ml index b270a2e92a..3f32d395fd 100644 --- a/analysis/src/CmtViewer.ml +++ b/analysis/src/CmtViewer.ml @@ -40,7 +40,8 @@ let dump ?filter rescript_json cmt_path = | 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.to_string loc)); + | Some (Loc loc) -> + Printf.printf "Filtering by loc %s\n" (Loc.to_string loc)); Printf.printf "file moduleName: %s\n\n" full.file.module_name; diff --git a/analysis/src/CodeActions.ml b/analysis/src/CodeActions.ml index 2db97b0157..c876bc7e52 100644 --- a/analysis/src/CodeActions.ml +++ b/analysis/src/CodeActions.ml @@ -7,17 +7,22 @@ let make ~title ~kind ~uri ~new_text ~range = in let edit = Lsp.Types.WorkspaceEdit.create - ~document_changes: + ~documentChanges: [ `TextDocumentEdit (Lsp.Types.TextDocumentEdit.create - ~edits:[`TextEdit (Lsp.Types.TextEdit.create ~range ~new_text)] - ~text_document); + ~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 ~document_changes () in + let edit = + Lsp.Types.WorkspaceEdit.create ~documentChanges:document_changes () + in Lsp.Types.CodeAction.create ~title ~kind ~edit () diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index eb115f395e..92acdcfb81 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -73,7 +73,8 @@ let hover ~source ~kind_file ~pos ~supports_markdown_links ~full ~debug = (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 + (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) @@ -122,7 +123,8 @@ let definition ~full ~pos ~debug = if skip_loc then None else Some - (Lsp.Types.Location.create ~range:(Utils.cmt_loc_to_range loc) + (Lsp.Types.Location.create + ~range:(Utils.cmt_loc_to_range loc) ~uri:(Files.canonicalize_uri uri |> Uri.from_string)) | Some _ -> None)) in @@ -140,7 +142,8 @@ let type_definition ~full ~pos ~debug = | None -> None | Some (uri, loc) -> Some - (Lsp.Types.Location.create ~range:(Utils.cmt_loc_to_range loc) + (Lsp.Types.Location.create + ~range:(Utils.cmt_loc_to_range loc) ~uri:(Files.canonicalize_uri uri |> Uri.from_string)))) in maybe_location @@ -153,7 +156,9 @@ let references ~full ~pos ~debug = 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 + 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} -> @@ -163,7 +168,8 @@ let references ~full ~pos ~debug = | None -> Uri.to_top_level_loc uri2 in - Lsp.Types.Location.create ~range:(Utils.cmt_loc_to_range loc) + Lsp.Types.Location.create + ~range:(Utils.cmt_loc_to_range loc) ~uri:(Uri.to_string uri2 |> Uri.from_string) :: acc) []) @@ -178,7 +184,9 @@ let rename ~full ~pos ~new_name ~debug = 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 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} -> @@ -204,9 +212,10 @@ let rename ~full ~pos ~new_name ~debug = in `RenameFile (Lsp.Types.RenameFile.create - ~new_uri: - (new_path |> Uri.from_path |> Uri.to_string |> Uri.from_path) - ~old_uri:(uri |> Uri.to_string |> Uri.from_string) + ~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 = @@ -218,7 +227,7 @@ let rename ~full ~pos ~new_name ~debug = (fun acc (uri, loc) -> let text_edit = `TextEdit - (Lsp.Types.TextEdit.create ~new_text:new_name + (Lsp.Types.TextEdit.create ~newText:new_name ~range:(Utils.cmt_loc_to_range loc)) in match StringMap.find_opt uri acc with @@ -235,13 +244,15 @@ let rename ~full ~pos ~new_name ~debug = in let text_document_edit = `TextDocumentEdit - (Lsp.Types.TextDocumentEdit.create ~edits ~text_document) + (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 ~document_changes ())) + Some + (Lsp.Types.WorkspaceEdit.create ~documentChanges:document_changes ())) in result @@ -281,7 +292,7 @@ let format ~source ~kind_file = ~start:(Lsp.Types.Position.create ~line:0 ~character:0) ~end_:(Lsp.Types.Position.create ~line:(lines_len - 1) ~character) in - Lsp.Types.TextEdit.create ~new_text:text ~range + Lsp.Types.TextEdit.create ~newText:text ~range in let result = diff --git a/analysis/src/CompletionBackEnd.ml b/analysis/src/CompletionBackEnd.ml index 5caf211e4a..75d5edebf3 100644 --- a/analysis/src/CompletionBackEnd.ml +++ b/analysis/src/CompletionBackEnd.ml @@ -130,7 +130,8 @@ let completions_for_exported_constructors ~(env : QueryEnv.t) ~prefix ~exact | _ -> ()); !res -let completion_for_exported_fields ~(env : QueryEnv.t) ~prefix ~exact ~names_used = +let completion_for_exported_fields ~(env : QueryEnv.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 @@ -167,14 +168,15 @@ let find_module_in_scope ~env ~module_name ~scope = | Some declared -> result := Some declared | None -> Log.log - (Printf.sprintf "Module Not Found %s loc:%s\n" name (Loc.to_string loc)) + (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 : QueryEnv.t) ~package (item : Module.t) - = +let rec module_item_to_structure_env ~(env : QueryEnv.t) ~package + (item : Module.t) = match item with | Module.Structure structure -> Some (env, structure) | Module.Constraint (_, module_type) -> @@ -213,8 +215,8 @@ let completions_from_structure_items ~(env : QueryEnv.t) (Completion.create ~env ~docstring:it.docstring ~kind:(Completion.Type t) it.name)) -let resolve_path_from_stamps ~(env : QueryEnv.t) ~package ~scope ~module_name ~path - = +let resolve_path_from_stamps ~(env : QueryEnv.t) ~package ~scope ~module_name + ~path = (* Log.log("Finding from stamps " ++ name); *) match find_module_in_scope ~env ~module_name ~scope with | None -> None @@ -224,7 +226,8 @@ let resolve_path_from_stamps ~(env : QueryEnv.t) ~package ~scope ~module_name ~p match path with | [""] -> ( match module_item_to_structure_env ~env ~package declared.item with - | Some (env, structure) -> Some (QueryEnv.enter_structure env structure, "") + | Some (env, structure) -> + Some (QueryEnv.enter_structure env structure, "") | None -> None) | _ -> ( match ResolvePath.find_in_module ~env declared.item path with @@ -236,8 +239,8 @@ let resolve_path_from_stamps ~(env : QueryEnv.t) ~package ~scope ~module_name ~p match ProcessCmt.file_for_module ~package module_name with | None -> None | Some file -> - ResolvePath.resolve_path ~env:(QueryEnv.from_file file) ~path:full_path - ~package)))) + ResolvePath.resolve_path ~env:(QueryEnv.from_file file) + ~path:full_path ~package)))) let resolve_module_with_opens ~opens ~package ~module_name = let rec loop opens = @@ -461,8 +464,8 @@ let process_local_constructor name loc ~prefix ~exact ~env (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 : LocalTables.t) - = +let process_local_type name loc ~prefix ~exact ~env + ~(local_tables : LocalTables.t) = if Utils.check_name name ~prefix ~exact then match Hashtbl.find_opt local_tables.types_table (name, Loc.start loc) with | Some declared -> @@ -528,7 +531,8 @@ let process_local_include include_path _loc ~prefix ~exact ~(env : QueryEnv.t) } :: local_tables.result_rev)) -let get_items_from_opens ~opens ~local_tables ~prefix ~exact ~completion_context = +let get_items_from_opens ~opens ~local_tables ~prefix ~exact ~completion_context + = opens |> List.fold_left (fun results env -> @@ -539,8 +543,8 @@ let get_items_from_opens ~opens ~local_tables ~prefix ~exact ~completion_context completions_from_this_open @ results) [] -let find_local_completions_for_values_and_constructors ~(local_tables : LocalTables.t) - ~env ~prefix ~exact ~opens ~scope = +let find_local_completions_for_values_and_constructors + ~(local_tables : LocalTables.t) ~env ~prefix ~exact ~opens ~scope = local_tables |> LocalTables.populate_values ~env; local_tables |> LocalTables.populate_included_values ~env; local_tables |> LocalTables.populate_constructors ~env; @@ -572,12 +576,13 @@ let find_local_completions_for_values_and_constructors ~(local_tables : LocalTab (process_local_module ~prefix ~exact ~env ~local_tables); scope - |> Scope.iter_includes (process_local_include ~prefix ~exact ~env ~local_tables); + |> 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 : LocalTables.t) ~env ~prefix - ~exact ~opens ~scope = +let find_local_completions_for_values ~(local_tables : LocalTables.t) ~env + ~prefix ~exact ~opens ~scope = local_tables |> LocalTables.populate_values ~env; local_tables |> LocalTables.populate_included_values ~env; local_tables |> LocalTables.populate_modules ~env; @@ -601,12 +606,13 @@ let find_local_completions_for_values ~(local_tables : LocalTables.t) ~env ~pref (process_local_module ~prefix ~exact ~env ~local_tables); scope - |> Scope.iter_includes (process_local_include ~prefix ~exact ~env ~local_tables); + |> 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 : LocalTables.t) ~env ~prefix - ~exact ~opens ~scope = +let find_local_completions_for_types ~(local_tables : LocalTables.t) ~env + ~prefix ~exact ~opens ~scope = local_tables |> LocalTables.populate_types ~env; local_tables |> LocalTables.populate_modules ~env; scope @@ -617,7 +623,8 @@ let find_local_completions_for_types ~(local_tables : LocalTables.t) ~env ~prefi (process_local_module ~prefix ~exact ~env ~local_tables); let values_from_opens = - get_items_from_opens ~opens ~local_tables ~prefix ~exact ~completion_context:Type + get_items_from_opens ~opens ~local_tables ~prefix ~exact + ~completion_context:Type in scope @@ -628,8 +635,8 @@ let find_local_completions_for_types ~(local_tables : LocalTables.t) ~env ~prefi (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 : LocalTables.t) ~env ~prefix - ~exact ~opens ~scope = +let find_local_completions_for_modules ~(local_tables : LocalTables.t) ~env + ~prefix ~exact ~opens ~scope = local_tables |> LocalTables.populate_modules ~env; scope |> Scope.iter_modules_before_first_open @@ -645,8 +652,8 @@ let find_local_completions_for_modules ~(local_tables : LocalTables.t) ~env ~pre (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 : QueryEnv.t) ~prefix ~exact ~opens - ~scope ~(completion_context : Completable.completion_context) = +let find_local_completions_with_opens ~pos ~(env : QueryEnv.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:" @@ -654,10 +661,11 @@ let find_local_completions_with_opens ~pos ~(env : QueryEnv.t) ~prefix ~exact ~o let local_tables = LocalTables.create () in match completion_context with | Value | ValueOrField -> - find_local_completions_for_values_and_constructors ~local_tables ~env ~prefix - ~exact ~opens ~scope + 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 + 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 @@ -665,12 +673,13 @@ let find_local_completions_with_opens ~pos ~(env : QueryEnv.t) ~prefix ~exact ~o (* There's no local completion for fields *) [] -let get_complementary_completions_for_typed_value ~opens ~all_files ~scope ~env prefix - = +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 = LocalTables.create () in - find_local_completions_for_values ~local_tables ~env ~prefix ~exact ~opens ~scope + find_local_completions_for_values ~local_tables ~env ~prefix ~exact ~opens + ~scope in let file_modules = all_files |> FileSet.elements @@ -731,20 +740,22 @@ let get_completions_for_path ~debug ~opens ~full ~pos ~exact ~scope | Some (declared : Module.t Declared.t) when declared.is_exported = false -> ( match - enter_structure_from_declared ~env:env_file ~package:full.package declared + 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 + 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 + find_all_completions ~env ~prefix ~exact ~names_used + ~completion_context | None -> [])) | _ -> ( match @@ -758,8 +769,8 @@ let get_completions_for_path ~debug ~opens ~full ~pos ~exact ~scope | 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 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 = TypeUtils.remove_current_module_if_needed ~env_completion_is_made_from completion_path @@ -775,8 +786,8 @@ let completions_for_pipe_from_completion_path ~env_completion_is_made_from ~open in let completions = completion_path @ [prefix] - |> get_completions_for_path ~debug ~completion_context:Value ~exact:false ~opens - ~full ~pos ~env ~scope + |> get_completions_for_path ~debug ~completion_context:Value ~exact:false + ~opens ~full ~pos ~env ~scope in let completions = completions @@ -785,12 +796,12 @@ let completions_for_pipe_from_completion_path ~env_completion_is_made_from ~open in completions -let rec dig_to_record_fields_for_completion ~debug ~package ~opens ~full ~pos ~env - ~scope path = +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 + |> 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. @@ -798,13 +809,13 @@ let rec dig_to_record_fields_for_completion ~debug ~package ~opens ~full ~pos ~e 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 + |> 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 mk_item ?data ?additional_text_edits name ~kind ~detail ~deprecated + ~docstring = let doc_content = (match deprecated with | None -> "" @@ -838,8 +849,8 @@ let mk_item ?data ?additional_text_edits name ~kind ~detail ~deprecated ~docstri in Lsp.Types.CompletionItem.create ~label:name ~kind ~tags ~detail ?documentation - ?deprecated ?data ?additional_text_edits ?sort_text:None ?insert_text:None - ?insert_text_format:None ?filter_text:None () + ?deprecated ?data ?additionalTextEdits:additional_text_edits ?sortText:None + ?insertText:None ?insertTextFormat:None ?filterText:None () let completion_to_item { @@ -866,12 +877,19 @@ let completion_to_item | Some detail -> detail) ~docstring: (match - kind_to_documentation ~current_docstring:docstring ~full ~env name kind + kind_to_documentation ~current_docstring:docstring ~full ~env name + kind with | "" -> [] | docstring -> [docstring]) in - {item with sort_text; insert_text; insert_text_format; filter_text} + { + 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) @@ -923,8 +941,8 @@ let rec completions_get_completion_type2 ~debug ~full ~opens ~raw_opens ~pos Some (ExtractedType typ, env) | _ -> None -and completions_get_type_env2 ~debug (completions : Completion.t list) ~full ~opens - ~raw_opens ~pos = +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 @@ -939,8 +957,8 @@ and completions_get_type_env2 ~debug (completions : Completion.t list) ~full ~op |> 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 = +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" @@ -972,8 +990,8 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e | Regular -> ( match cp - |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env - ~exact:true ~scope + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope |> completions_get_completion_type ~full with | None -> [] @@ -994,8 +1012,8 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e 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 + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope |> completions_get_completion_type ~full with | None -> [] @@ -1009,8 +1027,8 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e 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 + |> 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) -> @@ -1059,8 +1077,8 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e 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 + |> 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) -> ( @@ -1084,8 +1102,10 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e | (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, + | (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 _)] -> @@ -1094,15 +1114,17 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e (* should not happen, but just ignore extra arguments *) [] in - match TypeUtils.extract_function_type ~env ~package ~dig_into:false typ with + match + TypeUtils.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} - -> + | 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] @@ -1112,8 +1134,8 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e 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 + |> 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 @@ -1127,8 +1149,8 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e [] | Some (typ, env) -> let field_completions = - DotCompletionUtils.field_completions_for_dot_completion typ ~env ~package - ~prefix:field_name ?pos_of_dot ~exact + DotCompletionUtils.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 = @@ -1160,8 +1182,8 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e 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 + |> 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) -> ( @@ -1181,8 +1203,8 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e 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 + |> 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 -> @@ -1245,8 +1267,9 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e 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 + completions_for_pipe_from_completion_path + ~env_completion_is_made_from ~opens ~pos ~scope ~debug ~prefix + ~env ~raw_opens ~full completion_path |> TypeUtils.filter_pipeable_functions ~env ~full ~synthetic ~target_type_id:main_type_id |> List.filter (fun (c : Completion.t) -> @@ -1267,7 +1290,9 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e in let globally_configured_completions_for_type = - match package.autocomplete |> Misc.StringMap.find_opt main_type_id with + match + package.autocomplete |> Misc.StringMap.find_opt main_type_id + with | None -> [] | Some completion_paths -> completion_paths |> List.map (fun p -> String.split_on_char '.' p) @@ -1276,9 +1301,9 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e 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) + completions_for_pipe_from_completion_path + ~env_completion_is_made_from ~opens ~pos ~scope ~debug + ~prefix ~env ~raw_opens ~full completion_path) |> List.flatten |> TypeUtils.filter_pipeable_functions ~synthetic:true ~env ~full ~target_type_id:main_type_id @@ -1289,9 +1314,9 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e let extra_completions = TypeUtils.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) + completions_for_pipe_from_completion_path + ~env_completion_is_made_from ~opens ~pos ~scope ~debug + ~prefix ~env ~raw_opens ~full completion_path) |> List.flatten |> TypeUtils.filter_pipeable_functions ~synthetic:true ~env ~full ~target_type_id:main_type_id @@ -1299,8 +1324,8 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e (* Add JSX completion items if we're in a JSX context. *) let jsx_completions = if in_jsx then - PipeCompletionUtils.add_jsx_completion_items ~env ~main_type_id ~prefix - ~full ~raw_opens typ + PipeCompletionUtils.add_jsx_completion_items ~env ~main_type_id + ~prefix ~full ~raw_opens typ else [] in (* Add completions from the current module. *) @@ -1319,8 +1344,8 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e ctx_paths |> List.map (fun context_path -> context_path - |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos - ~env ~exact:true ~scope) + |> 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 @@ -1351,8 +1376,8 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e 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 + |> 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. @@ -1407,13 +1432,14 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e Printf.printf "--> function argument: %s\n" (match argument_label with | Labelled n | Optional n -> n - | Unlabelled {argument_position} -> "$" ^ string_of_int argument_position); + | 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 + |> 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) -> @@ -1459,8 +1485,8 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~e (* 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 + |> 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) -> ( @@ -1486,8 +1512,8 @@ let get_opens ~debug ~raw_opens ~package ~env = if debug && package_opens <> [] then Printf.printf "%s\n" ("Package opens " - ^ String.concat " " (package_opens |> List.map (fun p -> p |> path_to_string)) - ); + ^ 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 @@ -1497,8 +1523,8 @@ let get_opens ~debug ~raw_opens ~package ~env = ^ string_of_int (List.length resolved_opens) ^ " " ^ String.concat " " - (resolved_opens |> List.map (fun (e : QueryEnv.t) -> e.file.module_name)) - ); + (resolved_opens + |> List.map (fun (e : QueryEnv.t) -> e.file.module_name))); (* Last open takes priority *) List.rev resolved_opens @@ -1531,8 +1557,9 @@ let print_constructor_args ~mode ~as_snippet args_len = 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 : SharedTypes.completion_type) = +let rec complete_typed_value ?(type_arg_context : type_arg_context option) + ~raw_opens ~full ~prefix ~completion_context ~mode + (t : SharedTypes.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 @@ -1556,12 +1583,14 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) ~raw_ using '?'."; ] ~kind: - (Field (field, TypeUtils.extracted_type_to_string extracted_type)) + (Field + (field, TypeUtils.extracted_type_to_string extracted_type)) ~env | _ -> create field.fname.txt ?deprecated:field.deprecated ~kind: - (Field (field, TypeUtils.extracted_type_to_string extracted_type)) + (Field + (field, TypeUtils.extracted_type_to_string extracted_type)) ~env) |> filter_items ~prefix | _ -> @@ -1619,8 +1648,8 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) ~raw_ in Some ((base |> String.concat ".") ^ "." ^ exported_value_name) in - let get_exported_value_completion name (declared : Types.type_expr Declared.t) - = + 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 @@ -1701,7 +1730,8 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) ~raw_ ^ print_constructor_args num_args ~as_snippet:true) ~kind: (Constructor - (constructor, variant_decl |> Shared.decl_to_string variant_name)) + ( constructor, + variant_decl |> Shared.decl_to_string variant_name )) ~env) |> filter_items ~prefix | Tpolyvariant {env; constructors; type_expr} -> @@ -1739,7 +1769,8 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) ~raw_ | None -> [] | Some (inner_type, _typeArgsContext) -> inner_type - |> complete_typed_value ~raw_opens ~full ~prefix ~completion_context ~mode + |> complete_typed_value ~raw_opens ~full ~prefix ~completion_context + ~mode |> List.map (fun (c : Completion.t) -> { c with @@ -1751,9 +1782,12 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) ~raw_ | Some insert_text -> Some ("Some(" ^ insert_text ^ ")")); }) in - let none_case = Completion.create "None" ~kind:(kind_from_inner_type t) ~env 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 + create "Some(_)" ~includes_snippets:true ~kind:(kind_from_inner_type t) + ~env ~insert_text:(Printf.sprintf "Some(%s)" (empty_case 1)) in let completions = @@ -1783,7 +1817,8 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) ~raw_ | None -> [] | Some (inner_type, _) -> inner_type - |> complete_typed_value ~raw_opens ~full ~prefix ~completion_context ~mode + |> complete_typed_value ~raw_opens ~full ~prefix ~completion_context + ~mode |> List.map (fun (c : Completion.t) -> { c with @@ -1800,7 +1835,8 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) ~raw_ | None -> [] | Some (inner_type, _) -> inner_type - |> complete_typed_value ~raw_opens ~full ~prefix ~completion_context ~mode + |> complete_typed_value ~raw_opens ~full ~prefix ~completion_context + ~mode |> List.map (fun (c : Completion.t) -> { c with @@ -1873,12 +1909,12 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) ~raw_ 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; + 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 - -> + | 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 = @@ -1886,7 +1922,8 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) ~raw_ | [(Nolabel, arg_typ)] when TypeUtils.type_is_unit arg_typ -> "()" | [(Nolabel, arg_typ)] -> let var_name = - CompletionExpressions.pretty_print_fn_template_arg_name ~env ~full arg_typ + CompletionExpressions.pretty_print_fn_template_arg_name ~env ~full + arg_typ in if as_snippet then "${1:" ^ var_name ^ "}" else var_name | _ -> @@ -1923,7 +1960,8 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) ~raw_ match args with | [(Nolabel, arg_typ)] -> let var_name = - CompletionExpressions.pretty_print_fn_template_arg_name ~env ~full arg_typ + CompletionExpressions.pretty_print_fn_template_arg_name ~env ~full + arg_typ in ( (" => " ^ if var_name = "()" then "{}" else var_name), " => ${0:" ^ var_name ^ "}" ) @@ -1934,7 +1972,9 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) ~raw_ (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) + (async_prefix + ^ mk_fn_args ~as_snippet:true + ^ function_body_insert_text) ~sort_text:"A" ~kind:(Value typ) ~env; ] | Tfunction _ -> @@ -1961,7 +2001,8 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) ~raw_ module StringSet = Set.Make (String) -let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable = +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 @@ -1970,8 +2011,8 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable 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 + |> 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 @@ -1986,7 +2027,8 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable Completion.create name ~kind:(Label typ_string) ~env in let key_labels = - if Utils.starts_with "key" prefix then [mk_label ("key", "string")] else [] + if Utils.starts_with "key" prefix then [mk_label ("key", "string")] + else [] in let path_to_element_props = TypeUtils.path_to_element_props package in if Debug.verbose () then @@ -1996,8 +2038,8 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable let from_element_props = match path_to_element_props - |> dig_to_record_fields_for_completion ~debug ~package ~opens ~full ~pos ~env - ~scope + |> dig_to_record_fields_for_completion ~debug ~package ~opens ~full ~pos + ~env ~scope with | None -> None | Some fields -> @@ -2072,8 +2114,8 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable | None -> [] | Some (typ, _env, completion_context, type_arg_context) -> typ - |> complete_typed_value ?type_arg_context ~raw_opens ~mode:Expression ~full - ~prefix ~completion_context) + |> complete_typed_value ?type_arg_context ~raw_opens ~mode:Expression + ~full ~prefix ~completion_context) | CdecoratorPayload (ModuleWithImportAttributes {prefix; nested}) -> ( let mk_field ~name ~primitive = { @@ -2115,8 +2157,8 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable | None -> [] | Some (typ, _env, completion_context, type_arg_context) -> typ - |> complete_typed_value ?type_arg_context ~raw_opens ~mode:Expression ~full - ~prefix ~completion_context) + |> 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) @@ -2234,8 +2276,8 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable let labels = match cp - |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env - ~exact:true ~scope + |> 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) -> @@ -2270,8 +2312,8 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable in match context_path - |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env - ~exact:true ~scope + |> 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) -> ( @@ -2279,7 +2321,8 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable typ |> TypeUtils.extract_type ~env ~package:full.package |> Utils.Option.flat_map (fun (typ, type_arg_context) -> - typ |> TypeUtils.resolve_nested ?type_arg_context ~env ~full ~nested) + typ + |> TypeUtils.resolve_nested ?type_arg_context ~env ~full ~nested) with | None -> fallback_or_empty () | Some (typ, _env, completion_context, type_arg_context) -> @@ -2315,12 +2358,13 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable if prefix = "" then [] else prefix - |> get_complementary_completions_for_typed_value ~opens ~all_files ~env ~scope + |> 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 + |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos + ~env ~exact:true ~scope |> completions_get_completion_type ~full with | None -> @@ -2362,8 +2406,8 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable in let items = typ - |> complete_typed_value ?type_arg_context ~raw_opens ~mode:Expression ~full - ~prefix ~completion_context + |> 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 { @@ -2420,8 +2464,8 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable in let completions_for_context_path = context_path - |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env - ~exact:for_hover ~scope + |> 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) -> @@ -2451,7 +2495,8 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable | 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 + with_exhaustive_item c ~cases:["Ok($1)"; "Error($1)"] + ~start_index:1 | Some (Tbool _, _) -> with_exhaustive_item c ~cases:["true"; "false"] | _ -> [c]) diff --git a/analysis/src/CompletionExpressions.ml b/analysis/src/CompletionExpressions.ml index 36aae15cb3..f807675e3e 100644 --- a/analysis/src/CompletionExpressions.ml +++ b/analysis/src/CompletionExpressions.ml @@ -13,15 +13,19 @@ let is_expr_tuple expr = let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos ~first_char_before_cursor_no_white = let loc_has_cursor loc = loc |> CursorPosition.loc_has_cursor ~pos in - let some_if_has_cursor v = if loc_has_cursor exp.pexp_loc then Some v else None 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) + 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_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 @@ -55,7 +59,8 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos [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) + 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 @@ -85,7 +90,8 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos | 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) + 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) @@ -93,8 +99,8 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos f |> traverse_expr ~first_char_before_cursor_no_white ~pos ~expr_path: - ([Completable.NFollowRecordField {field_name = fname}] @ 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"; @@ -111,7 +117,8 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos 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) + some_if_has_cursor + ("", [Completable.NRecordBody {seen_fields}] @ expr_path) | _ -> None)) | Pexp_construct ( {txt}, @@ -162,7 +169,10 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos ~expr_path: ([ Completable.NVariantPayload - {constructor_name = Utils.get_unqualified_name txt; item_num = 0}; + { + constructor_name = Utils.get_unqualified_name txt; + item_num = 0; + }; ] @ expr_path) | Pexp_variant @@ -206,8 +216,8 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos @ 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 = +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 @@ -225,7 +235,8 @@ and traverse_expr_tuple_items tuple_items ~next_expr_path ~result_from_found_ite 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 + 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 @@ -237,7 +248,8 @@ let pretty_print_fn_template_arg_name ?current_index ~env ~full in let default_var_name = "v" ^ index_text in let arg_typ, suffix, _env = - TypeUtils.dig_to_relevant_template_name_type ~env ~package:full.package arg_typ + TypeUtils.dig_to_relevant_template_name_type ~env ~package:full.package + arg_typ in match arg_typ |> TypeUtils.path_from_type_expr with | None -> default_var_name @@ -267,7 +279,8 @@ let pretty_print_fn_template_arg_name ?current_index ~env ~full | _ -> default_var_name) | _ -> default_var_name) -let complete_constructor_payload ~pos_before_cursor ~first_char_before_cursor_no_white +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 @@ -290,7 +303,10 @@ let complete_constructor_payload ~pos_before_cursor ~first_char_before_cursor_no | nested -> [ Completable.NVariantPayload - {constructor_name = Longident.last constructor_lid.txt; item_num = 0}; + { + constructor_name = Longident.last constructor_lid.txt; + item_num = 0; + }; ] @ nested in diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/CompletionFrontEnd.ml index cb58f2e9a4..66024cba69 100644 --- a/analysis/src/CompletionFrontEnd.ml +++ b/analysis/src/CompletionFrontEnd.ml @@ -206,8 +206,8 @@ let find_arg_completables ~(args : arg list) ~end_pos ~pos_before_cursor }) | _ -> loop args -let rec expr_to_context_path_inner ~(in_jsx_context : 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 @@ -222,7 +222,8 @@ let rec expr_to_context_path_inner ~(in_jsx_context : bool) (e : Parsetree.expre | Pexp_ident {txt = Lident "->"} -> None | Pexp_ident {txt; loc} -> Some - (CPId {path = Utils.flatten_long_ident txt; completion_context = Value; loc}) + (CPId + {path = Utils.flatten_long_ident txt; completion_context = Value; loc}) | Pexp_field (e1, {txt = Lident name}) -> ( match expr_to_context_path ~in_jsx_context e1 with | Some context_path -> @@ -352,8 +353,8 @@ let complete_pipe_chain ~(in_jsx_context : bool) (exp : Parsetree.expression) = |> Option.map (fun ctx_path -> (ctx_path, pexp_loc)) | _ -> None -let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_expr_loc - text = +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 @@ -458,7 +459,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp | Ppat_any -> () | Ppat_var {txt; loc} -> scope := - !scope |> Scope.add_value ~name:txt ~loc ?context_path:context_path_to_save + !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 = @@ -471,7 +473,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp else None in scope := - !scope |> Scope.add_value ~name:as_a.txt ~loc:as_a.loc ?context_path:ctx_path + !scope + |> Scope.add_value ~name:as_a.txt ~loc:as_a.loc ?context_path:ctx_path | Ppat_constant _ | Ppat_interval _ -> () | Ppat_tuple pl -> pl @@ -622,7 +625,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp match expr_to_context_path ~in_jsx_context:!in_jsx_context expr with | None -> () | Some context_path -> - set_result (CexhaustiveSwitch {context_path; expr_loc = exp.pexp_loc})) + set_result + (CexhaustiveSwitch {context_path; expr_loc = exp.pexp_loc})) | Pexp_match (_expr, []) -> (* switch x { } *) if Debug.verbose () && debug_typed_completion_expr then @@ -779,8 +783,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp E.g: let x = {name: "name", }, when `x` has compiled. *) match pvb_expr - |> CompletionExpressions.traverse_expr ~expr_path:[] ~pos:pos_before_cursor - ~first_char_before_cursor_no_white + |> CompletionExpressions.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 @@ -812,8 +816,9 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp E.g: let {} = someVar *) match ( pvb_pat - |> CompletionPatterns.traverse_pattern ~pattern_path:[] ~loc_has_cursor - ~first_char_before_cursor_no_white ~pos_before_cursor, + |> CompletionPatterns.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 ctx_path -> @@ -869,7 +874,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp else if id.loc |> Loc.has_pos ~pos:pos_before_cursor then let pos_start, pos_end = Loc.range id.loc in match - (Pos.position_to_offset text pos_start, Pos.position_to_offset text pos_end) + ( Pos.position_to_offset text pos_start, + Pos.position_to_offset text pos_end ) with | Some offset_start, Some offset_end when offset_start >= 0 && offset_end >= offset_start -> @@ -1067,7 +1073,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp found := true; if debug then Printf.printf "posCursor:[%s] posNoWhite:[%s] Found expr:%s\n" - (Pos.to_string pos_cursor) (Pos.to_string pos_no_white) + (Pos.to_string pos_cursor) + (Pos.to_string pos_no_white) (Loc.to_string expr.pexp_loc) in (match find_this_expr_loc with @@ -1114,7 +1121,9 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp && Option.is_none find_this_expr_loc -> if Debug.verbose () then print_endline "[completionFrontend] Checking each case"; - let ctx_path = expr_to_context_path ~in_jsx_context:!in_jsx_context expr 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) -> @@ -1377,7 +1386,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp (jsx_props.props |> List.map (fun - ({name; pos_start; pos_end; exp} : CompletionJsx.prop) -> + ({name; pos_start; pos_end; exp} : CompletionJsx.prop) + -> Printf.sprintf "%s[%s->%s]=...%s" name (Pos.to_string pos_start) (Pos.to_string pos_end) (Loc.to_string exp.pexp_loc)) @@ -1497,7 +1507,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp | 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; + 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 @@ -1550,7 +1561,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp | 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; + 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}) -> ( @@ -1577,7 +1589,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp || (label = "" && pos_cursor = fst label_range) then match expr_to_context_path ~in_jsx_context:!in_jsx_context lhs with - | Some context_path -> set_result (Cpath (CPObj (context_path, label))) + | Some context_path -> + set_result (Cpath (CPObj (context_path, label))) | None -> ()) | Pexp_fun {arg_label = lbl; default = default_exp_opt; lhs = pat; rhs = e} -> @@ -1602,7 +1615,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp argument_label = (match lbl with | Nolabel -> - Unlabelled {argument_position = current_unlabelled_count} + Unlabelled + {argument_position = current_unlabelled_count} | Optional {txt = name} -> Optional name | Labelled {txt = name} -> Labelled name); }) @@ -1621,7 +1635,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp 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 rec_flag = Nonrecursive then bindings |> List.iter scope_value_binding; + if rec_flag = Nonrecursive then + bindings |> List.iter scope_value_binding; iterator.expr iterator e; scope := old_scope; processed := true @@ -1652,7 +1667,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp found := true; if debug then Printf.printf "posCursor:[%s] posNoWhite:[%s] Found type:%s\n" - (Pos.to_string pos_cursor) (Pos.to_string pos_no_white) + (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) -> @@ -1673,7 +1689,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ?find_this_exp found := true; if debug then Printf.printf "posCursor:[%s] posNoWhite:[%s] Found pattern:%s\n" - (Pos.to_string pos_cursor) (Pos.to_string pos_no_white) + (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, _) -> ( diff --git a/analysis/src/CompletionJsx.ml b/analysis/src/CompletionJsx.ml index 5b78a13e99..0abd4fbc3a 100644 --- a/analysis/src/CompletionJsx.ml +++ b/analysis/src/CompletionJsx.ml @@ -218,17 +218,15 @@ let get_jsx_labels ~component_path ~find_type_of_value ~package = item = { decl = - { - type_kind = Type_record (label_decls, _repr); - type_params = type_params; - }; + {type_kind = Type_record (label_decls, _repr); type_params}; }; } ) -> label_decls |> List.map (fun (ld : Types.label_declaration) -> let name = Ident.name ld.ld_id in let t = - ld.ld_type |> TypeUtils.instantiate_type ~type_params ~type_args + ld.ld_type + |> TypeUtils.instantiate_type ~type_params ~type_args in (name, t, env)) | _ -> [] @@ -328,7 +326,8 @@ let find_jsx_props_completable ~jsx_props ~end_pos ~pos_before_cursor let rec loop props = match props with | prop :: rest -> - if prop.pos_start <= pos_before_cursor && pos_before_cursor < prop.pos_end 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"; @@ -358,7 +357,8 @@ let find_jsx_props_completable ~jsx_props ~end_pos ~pos_before_cursor CJsxPropValue { path_to_component = - Utils.flatten_long_ident ~jsx:true jsx_props.comp_name.txt; + Utils.flatten_long_ident ~jsx:true + jsx_props.comp_name.txt; prop_name = prop.name; empty_jsx_prop_name_hint = Some txt; }; @@ -381,7 +381,8 @@ let find_jsx_props_completable ~jsx_props ~end_pos ~pos_before_cursor CJsxPropValue { path_to_component = - Utils.flatten_long_ident ~jsx:true jsx_props.comp_name.txt; + Utils.flatten_long_ident ~jsx:true + jsx_props.comp_name.txt; prop_name = prop.name; empty_jsx_prop_name_hint = None; }; @@ -407,7 +408,8 @@ let find_jsx_props_completable ~jsx_props ~end_pos ~pos_before_cursor CJsxPropValue { path_to_component = - Utils.flatten_long_ident ~jsx:true jsx_props.comp_name.txt; + Utils.flatten_long_ident ~jsx:true + jsx_props.comp_name.txt; prop_name = prop.name; empty_jsx_prop_name_hint = None; }; @@ -434,7 +436,8 @@ let find_jsx_props_completable ~jsx_props ~end_pos ~pos_before_cursor CJsxPropValue { path_to_component = - Utils.flatten_long_ident ~jsx:true jsx_props.comp_name.txt; + Utils.flatten_long_ident ~jsx:true + jsx_props.comp_name.txt; prop_name = prop.name; empty_jsx_prop_name_hint = None; }; diff --git a/analysis/src/CompletionPatterns.ml b/analysis/src/CompletionPatterns.ml index 009e89aca8..14aa970631 100644 --- a/analysis/src/CompletionPatterns.ml +++ b/analysis/src/CompletionPatterns.ml @@ -10,16 +10,19 @@ let is_pattern_tuple pat = | 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 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) + |> 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 ',' -> @@ -30,7 +33,8 @@ let rec traverse_tuple_items tuple_items ~next_pattern_path ~result_from_found_i |> 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 + 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 @@ -51,8 +55,8 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor | Ppat_exception p | Ppat_open (_, p) -> p - |> traverse_pattern ~pattern_path ~loc_has_cursor ~first_char_before_cursor_no_white - ~pos_before_cursor + |> 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] @@ -96,8 +100,8 @@ and traverse_pattern (pat : Parsetree.pattern) ~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 + |> 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 -> @@ -116,7 +120,8 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor f.Parsetree.ppat_loc |> CursorPosition.classify_loc ~pos:pos_before_cursor ) with - | Longident.Lident fname, HasCursor -> field_with_cursor := Some (fname, f) + | Longident.Lident fname, HasCursor -> + field_with_cursor := Some (fname, f) | Lident fname, _ when is_pattern_hole f -> field_with_pat_hole := Some (fname, f) | _ -> ()); @@ -147,7 +152,8 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor ~pattern_path: ([Completable.NFollowRecordField {field_name = fname}] @ pattern_path) - ~loc_has_cursor ~first_char_before_cursor_no_white ~pos_before_cursor) + ~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, @@ -210,7 +216,10 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor ~pattern_path: ([ Completable.NVariantPayload - {constructor_name = Utils.get_unqualified_name txt; item_num = 0}; + { + constructor_name = Utils.get_unqualified_name txt; + item_num = 0; + }; ] @ pattern_path) | Ppat_variant diff --git a/analysis/src/CreateInterface.ml b/analysis/src/CreateInterface.ml index 825d59b290..14eb9cb7c7 100644 --- a/analysis/src/CreateInterface.ml +++ b/analysis/src/CreateInterface.ml @@ -22,7 +22,8 @@ module SourceFileExtractor = struct 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) + 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) @@ -49,7 +50,8 @@ end = struct { line = line_idx; offset = attr_offset_start; - name = String.sub line attr_offset_start (attr_offset_end - attr_offset_start); + name = + String.sub line attr_offset_start (attr_offset_end - attr_offset_start); } in let res = ref [] in @@ -168,7 +170,7 @@ let print_signature ~extractor ~signature = | [] -> ret_type | label_decl :: rest -> let prop_type = - TypeUtils.instantiate_type ~type_params:type_params ~type_args + TypeUtils.instantiate_type ~type_params ~type_args label_decl.ld_type in let lbl_name = label_decl.ld_id |> Ident.name in @@ -238,7 +240,8 @@ let print_signature ~extractor ~signature = if AttributesUtils.contains "@inline" attributes then (* Generate type signature for @inline declaration *) - Buffer.add_string buf (gen_sig_str_for_inline_attr lines attributes id vd) + 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"); diff --git a/analysis/src/DocumentSymbol.ml b/analysis/src/DocumentSymbol.ml index f6b90c882a..49ae7b32d7 100644 --- a/analysis/src/DocumentSymbol.ml +++ b/analysis/src/DocumentSymbol.ml @@ -10,7 +10,7 @@ let command ~path = then let range = Utils.cmt_loc_to_range loc in let symbol = - Lsp.Types.DocumentSymbol.create ~name ~range ~selection_range:range + Lsp.Types.DocumentSymbol.create ~name ~range ~selectionRange:range ~children:[] ~kind () in symbols := symbol :: !symbols @@ -64,7 +64,9 @@ let command ~path = let expr (iterator : Ast_iterator.iterator) (e : Parsetree.expression) = (match e.pexp_desc with | Pexp_letmodule ({txt}, mod_expr, _) -> - add_symbol txt {e.pexp_loc with loc_end = mod_expr.pmod_loc.loc_end} Module + 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 @@ -74,7 +76,8 @@ let command ~path = (match item.pstr_desc with | Pstr_value _ -> () | Pstr_primitive vd -> process_value_description vd - | Pstr_type (_, typ_decls) -> typ_decls |> List.iter process_type_declaration + | 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 @@ -85,7 +88,8 @@ let command ~path = (item : Parsetree.signature_item) = (match item.psig_desc with | Psig_value vd -> process_value_description vd - | Psig_type (_, typ_decls) -> typ_decls |> List.iter process_type_declaration + | 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 @@ -178,7 +182,9 @@ let command ~path = |> add_sorted_symbols_to_children ~sorted_symbols:rest in let sorted_symbols = !symbols |> List.sort compare_symbol in - let symbols_with_children = [] |> add_sorted_symbols_to_children ~sorted_symbols 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/DotCompletionUtils.ml b/analysis/src/DotCompletionUtils.ml index 35f1bc13b6..52d7daf309 100644 --- a/analysis/src/DotCompletionUtils.ml +++ b/analysis/src/DotCompletionUtils.ml @@ -8,8 +8,8 @@ let filter_record_fields ~env ~record_as_string ~prefix ~exact fields = ~kind:(SharedTypes.Completion.Field (field, record_as_string))) else None) -let field_completions_for_dot_completion ?pos_of_dot typ ~env ~package ~prefix ~exact - = +let field_completions_for_dot_completion ?pos_of_dot typ ~env ~package ~prefix + ~exact = let as_object = typ |> TypeUtils.extract_object_type ~env ~package in match as_object with | Some (obj_env, obj) -> @@ -21,8 +21,8 @@ let field_completions_for_dot_completion ?pos_of_dot typ ~env ~package ~prefix ~ if Utils.check_name field ~prefix ~exact then let full_obj_field_name = Printf.sprintf "[\"%s\"]" field in Some - (SharedTypes.Completion.create full_obj_field_name ~synthetic:true - ~insert_text:full_obj_field_name ~env:obj_env + (SharedTypes.Completion.create full_obj_field_name + ~synthetic:true ~insert_text:full_obj_field_name ~env:obj_env ~kind:(SharedTypes.Completion.ObjLabel typ) ?additional_text_edits: (match pos_of_dot with diff --git a/analysis/src/DumpAst.ml b/analysis/src/DumpAst.ml index 3cb09c737f..8178d890bd 100644 --- a/analysis/src/DumpAst.ml +++ b/analysis/src/DumpAst.ml @@ -79,7 +79,9 @@ let rec print_pattern pattern ~pos ~indentation = ^ ",\n" ^ add_indentation (indentation + 1) ^ print_pattern pat2 ~pos ~indentation:(indentation + 2) - ^ "\n" ^ add_indentation indentation ^ ")" + ^ "\n" + ^ add_indentation indentation + ^ ")" | Ppat_extension (({txt} as loc), _) -> "Ppat_extension(%" ^ (loc |> print_loc_denominator_loc ~pos) ^ txt ^ ")" | Ppat_var ({txt} as loc) -> @@ -110,7 +112,9 @@ let rec print_pattern pattern ~pos ~indentation = ^ ": " ^ print_pattern pat ~pos ~indentation:(indentation + 2)) |> String.concat "\n") - ^ "\n" ^ add_indentation indentation ^ ")" + ^ "\n" + ^ add_indentation indentation + ^ ")" | Ppat_tuple patterns -> "Ppat_tuple(\n" ^ (patterns @@ -118,7 +122,9 @@ let rec print_pattern pattern ~pos ~indentation = add_indentation (indentation + 2) ^ (pattern |> print_pattern ~pos ~indentation:(indentation + 2))) |> String.concat ",\n") - ^ "\n" ^ add_indentation indentation ^ ")" + ^ "\n" + ^ add_indentation indentation + ^ ")" | Ppat_any -> "Ppat_any" | Ppat_constraint (pattern, typ) -> "Ppat_constraint(\n" @@ -126,7 +132,9 @@ let rec print_pattern pattern ~pos ~indentation = ^ print_core_type typ ~pos ^ ",\n" ^ add_indentation (indentation + 1) ^ (pattern |> print_pattern ~pos ~indentation:(indentation + 1)) - ^ "\n" ^ add_indentation indentation ^ ")" + ^ "\n" + ^ add_indentation indentation + ^ ")" | v -> Printf.sprintf "" (Utils.identify_ppat v) and print_case case ~pos ~indentation ~case_num = @@ -158,7 +166,9 @@ and print_expr_item expr ~pos ~indentation = |> List.map (fun expr -> expr |> print_expr_item ~pos ~indentation:(indentation + 1)) |> String.concat ("\n" ^ add_indentation (indentation + 1))) - ^ "\n" ^ add_indentation indentation ^ ")" + ^ "\n" + ^ add_indentation indentation + ^ ")" | Pexp_match (match_expr, cases) -> "Pexp_match(" ^ print_expr_item match_expr ~pos ~indentation:0 @@ -198,7 +208,9 @@ and print_expr_item expr ~pos ~indentation = ^ add_indentation (indentation + 3) ^ print_expr_item arg.exp ~pos ~indentation:(indentation + 3)) |> String.concat ",\n") - ^ "\n" ^ add_indentation indentation ^ ")" + ^ "\n" + ^ add_indentation indentation + ^ ")" | Pexp_constant constant -> "Pexp_constant(" ^ print_constant constant ^ ")" | Pexp_construct (({txt} as loc), maybe_expr) -> "Pexp_construct(" @@ -231,7 +243,9 @@ and print_expr_item expr ~pos ~indentation = ^ "next expr:\n" ^ add_indentation (indentation + 2) ^ print_expr_item next_expr ~pos ~indentation:(indentation + 2) - ^ "\n" ^ add_indentation indentation ^ ")" + ^ "\n" + ^ add_indentation indentation + ^ ")" | Pexp_extension (({txt} as loc), _) -> "Pexp_extension(%" ^ (loc |> print_loc_denominator_loc ~pos) ^ txt ^ ")" | Pexp_assert expr -> @@ -252,7 +266,9 @@ and print_expr_item expr ~pos ~indentation = ^ ": " ^ print_expr_item expr ~pos ~indentation:(indentation + 2)) |> String.concat "\n") - ^ "\n" ^ add_indentation indentation ^ ")" + ^ "\n" + ^ add_indentation indentation + ^ ")" | Pexp_tuple exprs -> "Pexp_tuple(\n" ^ (exprs @@ -260,7 +276,9 @@ and print_expr_item expr ~pos ~indentation = add_indentation (indentation + 2) ^ (expr |> print_expr_item ~pos ~indentation:(indentation + 2))) |> String.concat ",\n") - ^ "\n" ^ add_indentation indentation ^ ")" + ^ "\n" + ^ add_indentation indentation + ^ ")" | v -> Printf.sprintf "" (Utils.identify_pexp v) let print_value_binding value ~pos ~indentation = @@ -268,7 +286,9 @@ let print_value_binding value ~pos ~indentation = ^ "value" ^ ":\n" ^ add_indentation (indentation + 1) ^ (value.pvb_pat |> print_pattern ~pos ~indentation:(indentation + 1)) - ^ "\n" ^ add_indentation indentation ^ "expr:\n" + ^ "\n" + ^ add_indentation indentation + ^ "expr:\n" ^ add_indentation (indentation + 1) ^ print_expr_item value.pvb_expr ~pos ~indentation:(indentation + 1) @@ -276,7 +296,9 @@ let print_struct_item struct_item ~pos ~source = match struct_item.Parsetree.pstr_loc |> CursorPosition.classify_loc ~pos with | HasCursor -> ( let start_offset = - match Pos.position_to_offset source (struct_item.pstr_loc |> Loc.start) with + match + Pos.position_to_offset source (struct_item.pstr_loc |> Loc.start) + with | None -> 0 | Some offset -> offset in diff --git a/analysis/src/FindFiles.ml b/analysis/src/FindFiles.ml index 423afb37b2..97f5f82424 100644 --- a/analysis/src/FindFiles.ml +++ b/analysis/src/FindFiles.ml @@ -128,7 +128,9 @@ let get_public config = 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 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 -> @@ -137,7 +139,8 @@ let collect_files directory = let res_opt = Utils.find (fun name -> - if get_name name = mod_name then Some (directory /+ name) else None) + if get_name name = mod_name then Some (directory /+ name) + else None) sources in match res_opt with @@ -186,15 +189,18 @@ let find_project_files ~public ~namespace ~path ~source_directories ~lib_bs = in dirs |> if_debug true "Source directories" (fun s -> - s |> StringSet.elements |> List.map Utils.dump_path |> String.concat " "); + s |> StringSet.elements |> List.map Utils.dump_path + |> String.concat " "); files |> if_debug true "Source files" (fun s -> - s |> StringSet.elements |> List.map Utils.dump_path |> String.concat " "); + s |> StringSet.elements |> List.map Utils.dump_path + |> String.concat " "); let interfaces = Hashtbl.create 100 in files |> StringSet.iter (fun path -> - if is_interface path then Hashtbl.replace interfaces (get_name path) path); + if is_interface path then + Hashtbl.replace interfaces (get_name path) path); let normals = files |> StringSet.elements @@ -203,7 +209,9 @@ let find_project_files ~public ~namespace ~path ~source_directories ~lib_bs = 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 + let base = + compiled_base_name ~namespace (Files.relpath path file) + in match resi with | Some resi -> let cmti = (lib_bs /+ base) ^ ".cmti" in @@ -217,11 +225,13 @@ let find_project_files ~public ~namespace ~path ~source_directories ~lib_bs = else None else ( (* Log.log("Just intf " ++ cmti) *) - Log.log ("Bad source file (no cmt/cmti/cmi) " ^ (lib_bs /+ base)); + 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}) + 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)) @@ -308,8 +318,8 @@ let find_dependency_files base config = | Some _ -> lib_bs :: compiled_directories in let project_files = - find_project_files ~public:(get_public inner) ~namespace - ~path ~source_directories ~lib_bs + find_project_files ~public:(get_public inner) + ~namespace ~path ~source_directories ~lib_bs in Some (compiled_directories, project_files)) | None -> None diff --git a/analysis/src/Hint.ml b/analysis/src/Hint.ml index 49278fed75..9117f39724 100644 --- a/analysis/src/Hint.ml +++ b/analysis/src/Hint.ml @@ -100,8 +100,8 @@ let inlay ~source ~kind_file ~pos ~max_length ~full ~debug = let kind = inlay_kind_to_lsp_inlay_hint hint_kind in let label = ": " ^ label in let result = - Lsp.Types.InlayHint.create ~position ~kind ~padding_left:true - ~padding_right:false ~label:(`String label) () + Lsp.Types.InlayHint.create ~position ~kind ~paddingLeft:true + ~paddingRight:false ~label:(`String label) () in match maxlen with | Some value -> diff --git a/analysis/src/Hover.ml b/analysis/src/Hover.ml index 1193de78ec..970b8906f3 100644 --- a/analysis/src/Hover.ml +++ b/analysis/src/Hover.ml @@ -2,7 +2,8 @@ open SharedTypes module StringSet = Set.Make (String) -let show_module_top_level ~docstring ~is_type ~name (top_level : Module.item list) = +let show_module_top_level ~docstring ~is_type ~name + (top_level : Module.item list) = let contents = top_level |> List.map (fun item -> @@ -52,7 +53,8 @@ let rec show_module ~docstring ~(file : File.t) ~package ~name | 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) + | Some (_, declared) -> show_module ~docstring ~file ~name ~package declared + ) type extracted_type = { name: string; @@ -76,7 +78,8 @@ let find_relevant_types_from_type ~file ~package typ = | None -> (env, [typ]) | Some (env1, {item = {decl}}) -> ( match decl.type_kind with - | Type_record (lds, _) -> (env1, typ :: (lds |> label_declarations_types)) + | Type_record (lds, _) -> + (env1, typ :: (lds |> label_declarations_types)) | Type_variant cds -> ( env1, cds @@ -122,7 +125,8 @@ let expand_types ~file ~package ~supports_markdown_links typ = | all -> let types_seen = ref StringSet.empty in let type_id ~(env : QueryEnv.t) ~name = - env.file.module_name :: List.rev (name :: env.path_rev) |> String.concat "." + env.file.module_name :: List.rev (name :: env.path_rev) + |> String.concat "." in ( all (* Don't produce duplicate type definitions for recursive types *) @@ -140,7 +144,8 @@ let expand_types ~file ~package ~supports_markdown_links typ = (Res_parsetree_viewer .has_inline_record_definition_attribute decl.type_attributes) - then Markdown.go_to_definition_text ~env ~pos:loc.Warnings.loc_start + then + Markdown.go_to_definition_text ~env ~pos:loc.Warnings.loc_start else "" in Markdown.divider @@ -199,8 +204,8 @@ let get_hover_via_completions ~debug ~source ~kind_file ~pos ~for_hover | {kind = Field _; env; docstring} :: _ -> ( let opens = CompletionBackEnd.get_opens ~debug ~raw_opens ~package ~env in match - CompletionBackEnd.completions_get_type_env2 ~debug ~full ~raw_opens ~opens - ~pos completions + CompletionBackEnd.completions_get_type_env2 ~debug ~full ~raw_opens + ~opens ~pos completions with | Some (typ, _env) -> let type_string = @@ -212,8 +217,8 @@ let get_hover_via_completions ~debug ~source ~kind_file ~pos ~for_hover | {env} :: _ -> ( let opens = CompletionBackEnd.get_opens ~debug ~raw_opens ~package ~env in match - CompletionBackEnd.completions_get_type_env2 ~debug ~full ~raw_opens ~opens - ~pos completions + CompletionBackEnd.completions_get_type_env2 ~debug ~full ~raw_opens + ~opens ~pos completions with | Some (typ, _env) -> let type_string = @@ -275,8 +280,8 @@ let new_hover ~full:{file; package} ~supports_markdown_links loc_item = match ProcessCmt.file_for_module ~package name with | None -> None | Some file -> - show_module ~docstring:file.structure.docstring ~name:file.module_name ~file - ~package None) + show_module ~docstring:file.structure.docstring ~name:file.module_name + ~file ~package None) | Typed (_, _, Definition (_, (Field _ | Constructor _))) -> None | Constant t -> Some @@ -291,20 +296,22 @@ let new_hover ~full:{file; package} ~supports_markdown_links loc_item = | 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 + 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 = QueryEnv.from_file file in - match ResolvePath.resolve_module_from_compiler_path ~env ~package path with + match + ResolvePath.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) + show_module ~docstring:declared.docstring ~name + ~file:env_for_module.file ~package (Some declared) | Some (_, None) -> Some (from_type t)) | _ -> Some diff --git a/analysis/src/Packages.ml b/analysis/src/Packages.ml index 36ef44d06f..f6f77fbc68 100644 --- a/analysis/src/Packages.ml +++ b/analysis/src/Packages.ml @@ -1,7 +1,8 @@ open SharedTypes (* 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 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) -> @@ -99,8 +100,8 @@ let new_bs_package ~root_path = dependencies_files_and_paths in let source_directories = - FindFiles.get_source_directories ~include_dev:true ~base_dir:root_path - config + FindFiles.get_source_directories ~include_dev:true + ~base_dir:root_path config in let project_files_and_paths = FindFiles.find_project_files @@ -208,7 +209,9 @@ let find_root ~uri packages_by_root = let get_package ~uri = let open SharedTypes in if Hashtbl.mem state.root_for_uri uri then - Some (Hashtbl.find state.packages_by_root (Hashtbl.find state.root_for_uri uri)) + 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 -> @@ -217,7 +220,8 @@ let get_package ~uri = | 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)) + (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 diff --git a/analysis/src/PipeCompletionUtils.ml b/analysis/src/PipeCompletionUtils.ml index 142fa707f3..09918bee4f 100644 --- a/analysis/src/PipeCompletionUtils.ml +++ b/analysis/src/PipeCompletionUtils.ml @@ -1,5 +1,5 @@ -let add_jsx_completion_items ~main_type_id ~env ~prefix ~(full : SharedTypes.full) - ~raw_opens typ = +let add_jsx_completion_items ~main_type_id ~env ~prefix + ~(full : SharedTypes.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 diff --git a/analysis/src/PrintType.ml b/analysis/src/PrintType.ml index 9c8f122f05..5d3ddf9503 100644 --- a/analysis/src/PrintType.ml +++ b/analysis/src/PrintType.ml @@ -7,5 +7,5 @@ let print_expr ?(line_width = 60) typ = 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:print_name_as_is + (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/ProcessAttributes.ml index dc93a87de0..fad7665eb3 100644 --- a/analysis/src/ProcessAttributes.ml +++ b/analysis/src/ProcessAttributes.ml @@ -44,7 +44,8 @@ let rec find_deprecated_attribute attributes = | ({Asttypes.txt = "deprecated"}, _) :: _ -> Some "" | _ :: rest -> find_deprecated_attribute rest -let new_declared ~item ~extent ~name ~stamp ~module_path is_exported attributes = +let new_declared ~item ~extent ~name ~stamp ~module_path is_exported attributes + = { Declared.name; stamp; diff --git a/analysis/src/ProcessCmt.ml b/analysis/src/ProcessCmt.ml index 17463aba24..0f1299190e 100644 --- a/analysis/src/ProcessCmt.ml +++ b/analysis/src/ProcessCmt.ml @@ -35,8 +35,8 @@ let map_record_field {Types.ld_id; ld_type; ld_attributes; ld_optional} = deprecated = ProcessAttributes.find_deprecated_attribute ld_attributes; } -let rec for_type_signature_item ~(env : SharedTypes.Env.t) ~(exported : Exported.t) - (item : Types.signature_item) = +let rec for_type_signature_item ~(env : SharedTypes.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 @@ -110,7 +110,8 @@ let rec for_type_signature_item ~(env : SharedTypes.Env.t) ~(exported : Exported (args |> List.map (fun t -> (t, Location.none))) | Cstr_record fields -> - InlineRecord (fields |> List.map map_record_field)); + InlineRecord + (fields |> List.map map_record_field)); res = cd_res; type_decl = (name, decl); docstring = attrs_to_docstring cd_attributes; @@ -156,7 +157,8 @@ let rec for_type_signature_item ~(env : SharedTypes.Env.t) ~(exported : Exported [ { Module.kind = - Module {type_ = declared.item; is_module_type = is_module_type declared}; + Module + {type_ = declared.item; is_module_type = is_module_type declared}; name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; @@ -178,7 +180,8 @@ 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 (for_type_signature ~name ~env signature) + | Mty_signature signature -> + Structure (for_type_signature ~name ~env signature) | Mty_functor (_argIdent, _argType, result_type) -> for_type_module ~name ~env result_type @@ -263,7 +266,8 @@ let for_type_declaration ~env ~(exported : Exported.t) docstring = (match ProcessAttributes - .find_doc_attribute f.ld_attributes + .find_doc_attribute + f.ld_attributes with | None -> [] | Some docstring -> [docstring]); @@ -370,7 +374,8 @@ let rec for_signature_item ~env ~(exported : Exported.t) [ { Module.kind = - Module {type_ = declared.item; is_module_type = is_module_type declared}; + Module + {type_ = declared.item; is_module_type = is_module_type declared}; name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; @@ -540,7 +545,8 @@ let rec for_structure_item ~(env : SharedTypes.Env.t) ~(exported : Exported.t) [ { Module.kind = - Module {type_ = declared.item; is_module_type = is_module_type declared}; + Module + {type_ = declared.item; is_module_type = is_module_type declared}; name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; @@ -573,7 +579,8 @@ let rec for_structure_item ~(env : SharedTypes.Env.t) ~(exported : Exported.t) [ { Module.kind = - Module {type_ = declared.item; is_module_type = is_module_type declared}; + Module + {type_ = declared.item; is_module_type = is_module_type declared}; name = declared.name.txt; docstring = declared.docstring; deprecated = declared.deprecated; @@ -595,7 +602,8 @@ let rec for_structure_item ~(env : SharedTypes.Env.t) ~(exported : Exported.t) top_level | Tstr_primitive vd when JsxHacks.primitive_is_fragment vd = false -> let declared = - add_declared ~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) @@ -672,7 +680,9 @@ and scan_let_modules ~env (e : Typedtree.expression) = Stamps.add_module env.stamps stamp declared; scan_let_modules ~env body | Texp_let (_rf, bindings, body) -> - List.iter (fun {Typedtree.vb_expr} -> scan_let_modules ~env vb_expr) bindings; + List.iter + (fun {Typedtree.vb_expr} -> scan_let_modules ~env vb_expr) + bindings; scan_let_modules ~env body | Texp_apply {funct; args; _} -> scan_let_modules ~env funct; diff --git a/analysis/src/ProcessExtra.ml b/analysis/src/ProcessExtra.ml index 8b79084bb8..66bf36603c 100644 --- a/analysis/src/ProcessExtra.ml +++ b/analysis/src/ProcessExtra.ml @@ -128,7 +128,8 @@ let extra_for_cmt ~(iterator : Tast_iterator.iterator) in extra_for_structure_items ~iterator items; extra_for_parts parts - | Interface signature -> extra_for_signature_items ~iterator signature.sig_items + | Interface signature -> + extra_for_signature_items ~iterator signature.sig_items | Partial_interface parts -> let items = parts |> Array.to_list @@ -250,7 +251,8 @@ let add_for_record ~env ~extra ~record_type items = LocalReference (stamp, Field name) | None -> NotFound) | `Global (module_name, path) -> - add_external_reference ~extra module_name path (Field name) name_loc; + add_external_reference ~extra module_name path (Field name) + name_loc; GlobalReference (module_name, path, Field name) | _ -> NotFound in @@ -276,15 +278,16 @@ let add_for_constructor ~env ~extra constructor_type {Asttypes.txt; loc} LocalReference (stamp, Constructor name) | None -> NotFound) | `Global (module_name, path) -> - add_external_reference ~extra module_name path (Constructor name) name_loc; + add_external_reference ~extra module_name path (Constructor name) + name_loc; GlobalReference (module_name, path, Constructor name) | _ -> NotFound in add_loc_item extra name_loc (Typed (name, constructor_type, loc_type)) | _ -> () -let rec add_for_longident ~env ~extra top (path : Path.t) (txt : Longident.t) loc - = +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 @@ -400,8 +403,9 @@ let pat ~(file : File.t) ~env ~extra (iter : Tast_iterator.iterator) match unpacked_module_path_opt () with | Some path -> let declared = - ProcessAttributes.new_declared ~item:(Module.Ident path) ~extent:name.loc - ~name ~stamp ~module_path:NotVisible false pattern.pat_attributes + ProcessAttributes.new_declared ~item:(Module.Ident path) + ~extent:name.loc ~name ~stamp ~module_path:NotVisible false + pattern.pat_attributes in Stamps.add_module file.stamps stamp declared | None -> add_for_pattern stamp name) @@ -411,8 +415,9 @@ let pat ~(file : File.t) ~env ~extra (iter : Tast_iterator.iterator) match unpacked_module_path_opt () with | Some path -> let declared = - ProcessAttributes.new_declared ~item:(Module.Ident path) ~extent:name.loc - ~name ~stamp ~module_path:NotVisible false pattern.pat_attributes + ProcessAttributes.new_declared ~item:(Module.Ident path) + ~extent:name.loc ~name ~stamp ~module_path:NotVisible false + pattern.pat_attributes in Stamps.add_module file.stamps stamp declared | None -> add_for_pattern stamp name) @@ -422,8 +427,11 @@ let pat ~(file : File.t) ~env ~extra (iter : Tast_iterator.iterator) 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.path_is_fragment path) -> - add_for_longident ~env ~extra (Some (expression.exp_type, Value)) path txt loc + | Texp_ident (path, {txt; loc}, _) when not (JsxHacks.path_is_fragment path) + -> + add_for_longident ~env ~extra + (Some (expression.exp_type, Value)) + path txt loc | Texp_record {fields} -> add_for_record ~env ~extra ~record_type:expression.exp_type (fields |> Array.to_list diff --git a/analysis/src/References.ml b/analysis/src/References.ml index 79da7726cb..5cb0ddc62e 100644 --- a/analysis/src/References.ml +++ b/analysis/src/References.ml @@ -36,7 +36,8 @@ let get_loc_item ~full ~pos ~debug = 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); + Printf.printf "n1:%s n2:%s n3:%s\n" (name_of li1) (name_of li2) + (name_of li3); Some li4 | [ {loc_type = Constant _}; @@ -65,8 +66,9 @@ let get_loc_item ~full ~pos ~debug = Some li2 | [ ({loc_type = Typed (_, _, LocalReference _)} as li1); - ({loc_type = Typed (_, _, GlobalReference ("Js_OO", ["unsafe_downgrade"], _))} - as li2); + ({ + loc_type = Typed (_, _, GlobalReference ("Js_OO", ["unsafe_downgrade"], _)); + } as li2); li3; ] (* For older compiler 9.0 or earlier *) @@ -276,7 +278,8 @@ let rec resolve_module_reference ?(paths_seen = []) ~file ~package | 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 + resolve_module_reference ~file ~package ~paths_seen:(path :: paths_seen) + md | Some md -> Some (file, Some md)) | GlobalMod name -> ( match ProcessCmt.file_for_module ~package name with @@ -325,7 +328,8 @@ let definition ~file ~package stamp (tip : Tip.t) = | 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 -> + | Some (file_impl, _extra, declared_impl) when Uri.is_interface file.uri + -> (file_impl, declared_impl) | _ -> (file, declared) in @@ -475,8 +479,8 @@ let for_local_stamp ~full:{file; extra; package} stamp (tip : Tip.t) = | None -> [] | Some locs -> locs - |> List.map (fun loc -> {uri = file.uri; loc_opt = Some loc}) - )) + |> 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 diff --git a/analysis/src/ResolvePath.ml b/analysis/src/ResolvePath.ml index a7740b6ea0..fd6a8b7bbf 100644 --- a/analysis/src/ResolvePath.ml +++ b/analysis/src/ResolvePath.ml @@ -30,7 +30,8 @@ let rec make_path ~(env : QueryEnv.t) module_path = match res with | None -> NotFound | Some (`Local (env, name)) -> Exported (env, name) - | Some (`Global (module_name, full_path)) -> Global (module_name, full_path))) + | Some (`Global (module_name, full_path)) -> + Global (module_name, full_path))) and resolve_path_inner ~(env : QueryEnv.t) ~path = match path with diff --git a/analysis/src/Scope.ml b/analysis/src/Scope.ml index a905ea685c..84d46be6c6 100644 --- a/analysis/src/Scope.ml +++ b/analysis/src/Scope.ml @@ -21,7 +21,8 @@ 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_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 diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index 4224dee0c3..10532f81ee 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -71,7 +71,13 @@ module Token = struct e.last_char <- char; if delta_line >= 0 && delta_char >= 0 && length >= 0 then Some - [|delta_line; delta_char; length; token_type_to_int type_; token_modifiers|] + [| + delta_line; + delta_char; + length; + token_type_to_int type_; + token_modifiers; + |] else None let emit e = @@ -80,7 +86,9 @@ module Token = struct |> List.sort (fun (l1, c1, _, _) (l2, c2, _, _) -> if l1 = l2 then compare c1 c2 else compare l1 l2) in - let arrays = sorted_tokens |> List.filter_map (fun t -> e |> emit_token t) in + let arrays = + sorted_tokens |> List.filter_map (fun t -> e |> emit_token t) + in Array.concat arrays let array_to_json_string arr = @@ -127,7 +135,8 @@ let emit_longident ?(backwards = false) ?(jsx = false) let type_ = match last_token with | Some type_ -> type_ - | None -> if is_uppercase_id id then upper_case_token else lower_case_token + | None -> + if is_uppercase_id id then upper_case_token else lower_case_token in let pos_after = (fst pos, snd pos + String.length id) in let pos_end, len_mismatch = @@ -143,7 +152,9 @@ let emit_longident ?(backwards = false) ?(jsx = false) (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 + 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.to_string pos) (Token.token_type_debug type_); @@ -177,12 +188,14 @@ let emit_jsx_tag ~debug ~name ~pos emitter = let emit_type ~lid ~debug ~(loc : Location.t) emitter = if not loc.loc_ghost then emitter - |> emit_longident ~lower_case_token:Token.Type ~pos:(Loc.start loc) ~lid ~debug + |> emit_longident ~lower_case_token:Token.Type ~pos:(Loc.start loc) ~lid + ~debug let emit_record_label ~(label : Longident.t Location.loc) ~debug emitter = if not label.loc.loc_ghost then emitter - |> emit_longident ~lower_case_token:Token.Property ~pos:(Loc.start 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 @@ -194,7 +207,8 @@ let emit_variant ~(name : Longident.t Location.loc) ~debug emitter = 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) + if debug then + Printf.printf "TypeArg: %s\n" (Loc.to_string core_type.ptyp_loc) in let typ (iterator : Ast_iterator.iterator) (core_type : Parsetree.core_type) = match core_type.ptyp_desc with @@ -285,7 +299,8 @@ let command ~debug ~emitter ~source ~kind_file = (Jsx_container_element { jsx_container_element_tag_name_start = lident; - jsx_container_element_opening_tag_end = pos_of_greatherthan_after_props; + jsx_container_element_opening_tag_end = + pos_of_greatherthan_after_props; jsx_container_element_children = children; jsx_container_element_closing_tag = closing_tag_opt; }) -> diff --git a/analysis/src/SharedTypes.ml b/analysis/src/SharedTypes.ml index ad7bcfa20a..332a693f88 100644 --- a/analysis/src/SharedTypes.ml +++ b/analysis/src/SharedTypes.ml @@ -20,7 +20,8 @@ module ModulePath = struct match module_path with | File _ -> current | IncludedModule (_, inner) -> loop inner current - | ExportedModule {name; module_path = inner} -> loop inner (name :: current) + | ExportedModule {name; module_path = inner} -> + loop inner (name :: current) | NotVisible -> current in loop module_path [tip_name] @@ -30,7 +31,8 @@ module ModulePath = struct match module_path with | File _ -> current | IncludedModule (_, inner) -> loop inner current - | ExportedModule {name; module_path = inner} -> loop inner (name :: current) + | ExportedModule {name; module_path = inner} -> + loop inner (name :: current) | NotVisible -> current in prefix :: loop module_path [] @@ -310,7 +312,12 @@ module QueryEnv : sig val to_string : t -> string end = struct - type t = {file: File.t; exported: Exported.t; path_rev: path; parent: t option} + 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 "." @@ -352,7 +359,9 @@ type poly_variant_constructor = { } (* TODO(env-stuff) All envs for bool string etc can be removed. *) -type inner_type = TypeExpr of Types.type_expr | ExtractedType of completion_type +type inner_type = + | TypeExpr of Types.type_expr + | ExtractedType of completion_type and completion_type = | Tuple of QueryEnv.t * Types.type_expr list * Types.type_expr | Texn of QueryEnv.t @@ -400,7 +409,8 @@ module Env = struct let add_exported_module ~name ~is_type env = { env with - module_path = ExportedModule {name; module_path = env.module_path; is_type}; + 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 @@ -568,7 +578,8 @@ 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) + pos2.character + (loc_type_to_string loc_type) (* needed for debugging *) let _ = loc_item_to_string @@ -604,7 +615,8 @@ module Completable = struct | NFollowRecordField {field_name} -> "recordField(" ^ field_name ^ ")" | NRecordBody _ -> "recordBody" | NVariantPayload {constructor_name; item_num} -> - "variantPayload::" ^ constructor_name ^ "($" ^ string_of_int item_num ^ ")" + "variantPayload::" ^ constructor_name ^ "($" ^ string_of_int item_num + ^ ")" | NPolyvariantPayload {constructor_name; item_num} -> "polyvariantPayload::" ^ constructor_name ^ "($" ^ string_of_int item_num ^ ")" @@ -711,7 +723,8 @@ module Completable = struct | Optional {txt} -> "?" ^ txt) |> String.concat ", ") ^ ")" - | CPArray (Some ctx_path) -> "array<" ^ context_path_to_string ctx_path ^ ">" + | 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 @@ -731,7 +744,8 @@ module Completable = struct ^ context_path_to_string function_context_path ^ "(" ^ (match argument_label with - | Unlabelled {argument_position} -> "$" ^ string_of_int argument_position + | Unlabelled {argument_position} -> + "$" ^ string_of_int argument_position | Labelled name -> "~" ^ name | Optional name -> "~" ^ name ^ "=?") ^ ")" @@ -847,8 +861,8 @@ module Completion = struct } 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 = + ?(includes_snippets = false) ?insert_text ~kind ~env ?sort_text + ?deprecated ?filter_text ?detail ?(docstring = []) name = { name; env; diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/SignatureHelp.ml index cf5f51c2e6..a50d729582 100644 --- a/analysis/src/SignatureHelp.ml +++ b/analysis/src/SignatureHelp.ml @@ -86,8 +86,8 @@ let find_function_type ~debug ~source ~kind_file ~pos ~full = | Some (completable, scope) -> Some ( completable - |> CompletionBackEnd.process_completable ~debug ~full ~pos ~scope - ~env ~for_hover:true, + |> CompletionBackEnd.process_completable ~debug ~full ~pos + ~scope ~env ~for_hover:true, env, package, file )) @@ -237,8 +237,8 @@ let find_constructor_args ~full ~env ~constructor_name loc = | _ -> None) | _ -> None -let signature_help ~debug ~source ~kind_file ~pos ~allow_for_constructor_payloads - ~full = +let signature_help ~debug ~source ~kind_file ~pos + ~allow_for_constructor_payloads ~full = match source with | "" -> None | text -> ( @@ -281,13 +281,15 @@ let signature_help ~debug ~source ~kind_file ~pos ~allow_for_constructor_payload Printf.printf "[sig_help_result] Setting because loc of %s > then existing \ of %s\n" - (print_thing thing) (print_thing current_thing) + (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" - (print_thing thing) (print_thing current_thing)) + (print_thing thing) + (print_thing current_thing)) in let search_for_arg_with_cursor ~is_pipe_expr ~args = let extracted_args = extract_exp_apply_args ~args in @@ -317,7 +319,8 @@ let signature_help ~debug ~source ~kind_file ~pos ~allow_for_constructor_payload | Some {name; pos_start; pos_end} -> ( (* Check for the label identifier itself having the cursor *) match - pos |> CursorPosition.classify_positions ~pos_start ~pos_end + pos + |> CursorPosition.classify_positions ~pos_start ~pos_end with | HasCursor -> Some (Labelled name) | NoCursor | EmptyLoc -> ( @@ -328,7 +331,8 @@ let signature_help ~debug ~source ~kind_file ~pos ~allow_for_constructor_payload match ( arg.exp.pexp_desc, arg.exp.pexp_loc - |> CursorPosition.classify_loc ~pos:pos_before_cursor ) + |> CursorPosition.classify_loc ~pos:pos_before_cursor + ) with | Pexp_extension ({txt = "rescript.exprhole"}, _), _ | _, HasCursor -> @@ -483,8 +487,8 @@ let signature_help ~debug ~source ~kind_file ~pos ~allow_for_constructor_payload | Labelled {txt = l1}, Labelled {txt = l2} when l1 = l2 -> true - | Nolabel, Nolabel when param_arg_count = arg_count - -> + | Nolabel, Nolabel + when param_arg_count = arg_count -> true | _ -> false) with @@ -495,8 +499,8 @@ let signature_help ~debug ~source ~kind_file ~pos ~allow_for_constructor_payload Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown ~value: - (docs_for_label ~supports_markdown_links ~file ~package - label_typ_expr) + (docs_for_label ~supports_markdown_links ~file + ~package label_typ_expr) in Lsp.Types.ParameterInformation.create ~label:(`Offset (start, end_)) @@ -513,7 +517,7 @@ let signature_help ~debug ~source ~kind_file ~pos ~allow_for_constructor_payload (`MarkupContent (Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown ~value:docs))) - ~active_parameter: + ~activeParameter: (match active_parameter with | None -> Some (-1) | active_parameter -> active_parameter) @@ -521,11 +525,11 @@ let signature_help ~debug ~source ~kind_file ~pos ~allow_for_constructor_payload in let signature = Lsp.Types.SignatureHelp.create ~signatures:[signatures] - ~active_parameter: + ~activeParameter: (match active_parameter with | None -> Some (-1) | active_parameter -> active_parameter) - ~active_signature:0 () + ~activeSignature:0 () in Some signature | _ -> None) @@ -594,8 +598,9 @@ let signature_help ~debug ~source ~kind_file ~pos ~allow_for_constructor_payload in offset := end_offset + String.length ", "; ( arg_text, - docs_for_label ~file:full.file ~package:full.package - ~supports_markdown_links typ, + docs_for_label ~file:full.file + ~package:full.package ~supports_markdown_links + typ, (start_offset, end_offset) )))) in let label = @@ -658,7 +663,8 @@ let signature_help ~debug ~source ~kind_file ~pos ~allow_for_constructor_payload else ()); !field_index | _ -> -1) - | `ConstructorExpr (_, expr) when loc_has_cursor 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 tuple_item_with_cursor = @@ -767,11 +773,11 @@ let signature_help ~debug ~source ~kind_file ~pos ~allow_for_constructor_payload (`MarkupContent (Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown ~value:docs))) - ~active_parameter:(Some active_parameter) () + ~activeParameter:(Some active_parameter) () in let signature = Lsp.Types.SignatureHelp.create ~signatures:[signatures] - ~active_parameter:(Some active_parameter) ~active_signature:0 () + ~activeParameter:(Some active_parameter) ~activeSignature:0 () in Some signature)) | _ -> None)) diff --git a/analysis/src/TypeUtils.ml b/analysis/src/TypeUtils.ml index f980310adf..0d9933b74e 100644 --- a/analysis/src/TypeUtils.ml +++ b/analysis/src/TypeUtils.ml @@ -50,7 +50,9 @@ let rec has_tvar (ty : Types.type_expr) : bool = | 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 + 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 @@ -73,10 +75,13 @@ let print_record_from_fields ?name (fields : field list) = |> String.concat ", ") ^ "}" -let rec extracted_type_to_string ?(name_only = false) ?(inner = false) = function +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 |> SharedTypes.path_ident_to_string + try + typ |> path_from_type_expr |> Option.get + |> SharedTypes.path_ident_to_string with _ -> "" else Shared.type_to_string typ | Trecord {definition; fields} -> @@ -84,7 +89,8 @@ let rec extracted_type_to_string ?(name_only = false) ?(inner = false) = functio match definition with | `TypeExpr typ -> ( try - typ |> path_from_type_expr |> Option.get |> SharedTypes.path_ident_to_string + typ |> path_from_type_expr |> Option.get + |> SharedTypes.path_ident_to_string with _ -> "") | `NameOnly name -> name in @@ -99,12 +105,15 @@ let rec extracted_type_to_string ?(name_only = false) ?(inner = false) = functio | Toption (_, TypeExpr inner_typ) -> "option<" ^ Shared.type_to_string inner_typ ^ ">" | Tresult {ok_type; error_type} -> - "result<" ^ Shared.type_to_string ok_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 ^ ">" + | 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 @@ -225,7 +234,8 @@ let instantiate_type2 ?(type_arg_context : type_arg_context option) 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 + | 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)) -> @@ -239,10 +249,7 @@ let rec extract_record_type ~env ~package (t : Types.type_expr) = {field with typ = field_typ}) in Some (env, fields, typ) - | Some - ( env, - {item = {decl = {type_manifest = Some t1; type_params = type_params}}} - ) -> + | 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) @@ -250,14 +257,12 @@ let rec extract_record_type ~env ~package (t : Types.type_expr) = 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 + | 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 = type_params}}} - ) -> + | 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) @@ -270,11 +275,7 @@ let extract_function_type ~env ~package ?(dig_into = true) typ = | 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 = type_params}}; - } ) -> + | 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)) @@ -289,11 +290,7 @@ let extract_function_type_with_env ~env ~package typ = | 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 = type_params}}; - } ) -> + | 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) @@ -302,10 +299,11 @@ let extract_function_type_with_env ~env ~package typ = in loop ~env [] typ -let maybe_set_type_arg_ctx ?type_arg_context_from_type_manifest ~type_params ~type_args env - = +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 + | 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} @@ -323,17 +321,16 @@ let maybe_set_type_arg_ctx ?type_arg_context_from_type_manifest ~type_params ~ty 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 + | 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 = type_params}}; - } ) -> - let type_arg_context = maybe_set_type_arg_ctx ~type_params ~type_args env in + | 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) @@ -342,14 +339,17 @@ let extract_function_type2 ?type_arg_context ~env ~package 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 + ?(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) + (Shared.type_to_string t) + (Debug.debug_print_env env) (Option.is_some type_arg_context); (match type_arg_context with | None -> () @@ -378,12 +378,14 @@ let rec extract_type ?(print_opening_debug = true) | 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) + 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); + (Path.name path) + (Debug.debug_print_env env); match References.dig_constructor ~env ~package path with | Some ( env_from_declaration, @@ -395,12 +397,13 @@ let rec extract_type ?(print_opening_debug = true) 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_params ~type_args env + 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}}) + | 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 = @@ -424,9 +427,10 @@ let rec extract_type ?(print_opening_debug = true) Some ( Trecord {env = env_from_declaration; fields; definition = `TypeExpr t}, type_arg_context ) - | Some (env_from_declaration, {item = {name = "t"; decl = {type_params}}}) -> + | Some (env_from_declaration, {item = {name = "t"; decl = {type_params}}}) + -> let type_arg_context = - maybe_set_type_arg_ctx ~type_params:type_params ~type_args env + maybe_set_type_arg_ctx ~type_params ~type_args env in Some (TtypeT {env = env_from_declaration; path}, type_arg_context) | None -> @@ -444,7 +448,8 @@ let rec extract_type ?(print_opening_debug = true) |> List.map (fun (label, field) -> { name = label; - display_name = Utils.print_maybe_exotic_ident ~allow_uident:true 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 @@ -539,7 +544,8 @@ let rec resolve_type_for_pipe_completion ~env ~package ~lhs_loc ~full 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 + 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 @@ -568,7 +574,8 @@ let extract_type_from_resolved_type (typ : Type.t) ~env ~full = | Abstract _ | Open -> ( match typ.decl.type_manifest with | None -> None - | Some t -> t |> extract_type ~env ~package:full.package |> get_extracted_type) + | 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 *) @@ -585,7 +592,8 @@ let rec resolve_nested ?type_arg_context ~env ~full ~nested ?ctx | None -> () | Some type_arg_context -> if Debug.verbose () then - Printf.printf "[nested]--> %s" (debug_log_type_arg_context type_arg_context)); + Printf.printf "[nested]--> %s" + (debug_log_type_arg_context type_arg_context)); match nested with | [] -> if Debug.verbose () then @@ -632,7 +640,8 @@ let rec resolve_nested ?type_arg_context ~env ~full ~nested ?ctx 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); + (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) -> @@ -674,7 +683,8 @@ let rec resolve_nested ?type_arg_context ~env ~full ~nested ?ctx |> 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} -> + | 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 @@ -755,14 +765,16 @@ let rec resolve_nested ?type_arg_context ~env ~full ~nested ?ctx let find_type_of_record_field fields ~field_name = match - fields |> List.find_opt (fun (field : field) -> field.fname.txt = field_name) + 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 = +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) @@ -811,11 +823,12 @@ let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~nested = 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} - -> ( + | ( NVariantPayload {constructor_name; item_num}, + Tvariant {env; constructors} ) -> ( match constructors - |> find_type_of_constructor_arg ~constructor_name ~payload_num:item_num ~env + |> find_type_of_constructor_arg ~constructor_name + ~payload_num:item_num ~env with | Some typ -> Some (typ, env) | None -> None) @@ -823,7 +836,8 @@ let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~nested = Tpolyvariant {env; constructors} ) -> ( match constructors - |> find_type_of_polyvariant_arg ~constructor_name ~payload_num:item_num + |> find_type_of_polyvariant_arg ~constructor_name + ~payload_num:item_num with | Some typ -> Some (TypeExpr typ, env) | None -> None) @@ -864,11 +878,12 @@ let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~nested = |> Utils.Option.flat_map (fun typ -> ExtractedType typ |> resolve_nested_pattern_path ~env ~full ~nested)) - | NVariantPayload {constructor_name; item_num}, Tvariant {env; constructors} - -> ( + | ( NVariantPayload {constructor_name; item_num}, + Tvariant {env; constructors} ) -> ( match constructors - |> find_type_of_constructor_arg ~constructor_name ~payload_num:item_num ~env + |> 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) @@ -876,7 +891,8 @@ let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~nested = Tpolyvariant {env; constructors} ) -> ( match constructors - |> find_type_of_polyvariant_arg ~constructor_name ~payload_num:item_num + |> find_type_of_polyvariant_arg ~constructor_name + ~payload_num:item_num with | Some typ -> TypeExpr typ |> resolve_nested_pattern_path ~env ~full ~nested @@ -895,8 +911,8 @@ let rec resolve_nested_pattern_path (typ : inner_type) ~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 - = + 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 @@ -904,7 +920,8 @@ let get_args ~env (t : Types.type_expr) ~full = (SharedTypes.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 + (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 @@ -912,11 +929,7 @@ let get_args ~env (t : Types.type_expr) ~full = 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 = type_params}}; - } ) -> + | 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 | _ -> []) @@ -1004,7 +1017,9 @@ module Codegen = struct match extracted_type with | None -> [] | Some extracted_type -> ( - match extracted_type_to_exhaustive_patterns ~env ~full extracted_type with + match + extracted_type_to_exhaustive_patterns ~env ~full extracted_type + with | None -> [] | Some patterns -> patterns) in @@ -1021,13 +1036,17 @@ module Codegen = struct 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 + 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 + match + extracted_type_to_exhaustive_patterns ~env ~full extracted_type + with | None -> [] | Some patterns -> patterns) in @@ -1035,7 +1054,9 @@ module Codegen = struct match extracted_error_type with | None -> [] | Some extracted_type -> ( - match extracted_type_to_exhaustive_patterns ~env ~full extracted_type with + match + extracted_type_to_exhaustive_patterns ~env ~full extracted_type + with | None -> [] | Some patterns -> patterns) in @@ -1050,7 +1071,9 @@ module Codegen = struct | _ -> None let extracted_type_to_exhaustive_cases ~env ~full extracted_type = - let patterns = extracted_type_to_exhaustive_patterns ~env ~full extracted_type in + let patterns = + extracted_type_to_exhaustive_patterns ~env ~full extracted_type + in match patterns with | None -> None @@ -1061,7 +1084,8 @@ module Codegen = struct Ast_helper.Exp.case pat (mk_fail_with_exp ()))) end -let get_module_path_relative_to_env ~debug ~(env : QueryEnv.t) ~env_from_item path = +let get_module_path_relative_to_env ~debug ~(env : QueryEnv.t) ~env_from_item + path = match path with | _ :: path_rev -> (* type path is relative to the completion environment @@ -1113,7 +1137,8 @@ let path_to_element_props package = module StringSet = Set.Make (String) -let get_extra_modules_to_complete_from_for_type ~env ~full (t : Types.type_expr) = +let get_extra_modules_to_complete_from_for_type ~env ~full (t : Types.type_expr) + = let found_module_paths = ref StringSet.empty in let add_to_module_paths attributes = ProcessAttributes.find_editor_complete_from_attribute attributes @@ -1152,19 +1177,20 @@ let get_first_fn_unlabelled_arg_type ~env ~full t = 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) + 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 ~new_text:"" + 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 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 @@ -1181,7 +1207,8 @@ let transform_completion_to_pipe_completion ?(synthetic = false) ~env ?pos_of_do 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)); + | 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 @@ -1248,14 +1275,16 @@ let filter_pipeable_functions ~env ~full ?synthetic ?target_type_id ?pos_of_dot match pos_of_dot with | None -> Some completion | Some pos_of_dot -> - transform_completion_to_pipe_completion ?synthetic ~env ~pos_of_dot - completion) + 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 = +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.QueryEnv.file.module_name + && List.hd completion_path + = env_completion_is_made_from.QueryEnv.file.module_name then List.tl completion_path else completion_path @@ -1286,7 +1315,8 @@ let completion_path_from_maybe_builtin path = | Some ("char", _) -> Some ["Stdlib"; "Char"] | _ -> ( match path |> Utils.expand_path |> List.rev with - | [main_module; "t"] when String.starts_with ~prefix:"Stdlib_" main_module -> + | [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"] diff --git a/analysis/src/Utils.ml b/analysis/src/Utils.ml index 3beab0f74f..18a26e3241 100644 --- a/analysis/src/Utils.ml +++ b/analysis/src/Utils.ml @@ -152,7 +152,8 @@ let has_braces attributes = let rec unwrap_if_option (t : Types.type_expr) = match t.desc with | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> unwrap_if_option t1 - | Tconstr (Path.Pident {name = "option"}, [unwrapped_type], _) -> unwrapped_type + | Tconstr (Path.Pident {name = "option"}, [unwrapped_type], _) -> + unwrapped_type | _ -> t let is_jsx_component (vb : Parsetree.value_binding) = diff --git a/analysis/src/Xform.ml b/analysis/src/Xform.ml index bffbf57ee3..00ef5a94c0 100644 --- a/analysis/src/Xform.ml +++ b/analysis/src/Xform.ml @@ -5,7 +5,8 @@ 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 - |> CompletionFrontEnd.find_type_of_expression_at_loc ~debug ~source ~kind_file + |> CompletionFrontEnd.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) -> ( @@ -22,8 +23,8 @@ let extract_type_from_expr expr ~debug ~source ~kind_file ~full ~pos = CompletionBackEnd.get_opens ~debug ~raw_opens ~package:full.package ~env in match - CompletionBackEnd.completions_get_completion_type2 ~debug ~full ~raw_opens - ~opens ~pos completions + CompletionBackEnd.completions_get_completion_type2 ~debug ~full + ~raw_opens ~opens ~pos completions with | Some (typ, _env) -> let extracted_type = @@ -172,7 +173,7 @@ module ModuleToFile = struct (Lsp.Types.CreateFile.create ~uri ~options: (Lsp.Types.CreateFileOptions.create ~overwrite:false - ~ignore_if_exists:true ()) + ~ignoreIfExists:true ()) ()); `TextDocumentEdit (Lsp.Types.TextDocumentEdit.create @@ -180,9 +181,9 @@ module ModuleToFile = struct [ `TextEdit (Lsp.Types.TextEdit.create ~range - ~new_text:text_for_extracted_file); + ~newText:text_for_extracted_file); ] - ~text_document: + ~textDocument: (Lsp.Types.OptionalVersionedTextDocumentIdentifier.create ~uri ())); `TextDocumentEdit @@ -191,9 +192,9 @@ module ModuleToFile = struct [ `TextEdit (Lsp.Types.TextEdit.create ~range - ~new_text:new_text_in_current_file); + ~newText:new_text_in_current_file); ] - ~text_document: + ~textDocument: (Lsp.Types.OptionalVersionedTextDocumentIdentifier.create ~uri:(Uri.from_string path) ())); ] @@ -214,7 +215,9 @@ module ModuleToFile = struct 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 + let iterator = + mk_iterator ~pos ~path ~changed ~print_standalone_structure + in iterator.structure iterator structure; match !changed with | None -> () @@ -261,7 +264,8 @@ module AddBracesToFn = struct 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; + body_expr.pexp_attributes <- + braces_attribute :: body_expr.pexp_attributes; changed := !current_structure_item | _ -> ()); Ast_iterator.default_iterator.expr iterator e @@ -291,7 +295,8 @@ module AddTypeAnnotation = struct type annotation = Plain | WithParens let mk_iterator ~pos ~result = - let process_pattern ?(is_unlabeled_only_arg = false) (pat : Parsetree.pattern) = + 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) @@ -342,7 +347,8 @@ module AddTypeAnnotation = struct let range, new_text = match annotation with | Plain -> - ( Loc.range_of_loc {loc_item.loc with loc_start = loc_item.loc.loc_end}, + ( 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, @@ -378,7 +384,8 @@ module ExpandCatchAllForVariants = struct in {Ast_iterator.default_iterator with expr} - let xform ~source ~kind_file ~path ~pos ~full ~structure ~code_actions ~debug = + 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; @@ -388,8 +395,9 @@ module ExpandCatchAllForVariants = struct 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) = + 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 -> @@ -492,7 +500,8 @@ module ExpandCatchAllForVariants = struct | Tvariant {constructors} -> constructors |> List.filter_map (fun (c : SharedTypes.Constructor.t) -> - if current_constructor_names |> List.mem c.cname.txt = false + if + current_constructor_names |> List.mem c.cname.txt = false then Some ( c.cname.txt, @@ -504,7 +513,8 @@ module ExpandCatchAllForVariants = struct constructors |> List.filter_map (fun (c : SharedTypes.poly_variant_constructor) -> - if current_constructor_names |> List.mem c.name = false then + if current_constructor_names |> List.mem c.name = false + then Some ( Res_printer.polyvar_ident_to_string c.name, match c.args with @@ -692,8 +702,8 @@ module AddDocTemplate = struct result := Some (r, item.psig_loc) | Psig_type (_, hd :: _) as r when Loc.has_pos ~pos hd.ptype_loc - && ProcessAttributes.find_doc_attribute hd.ptype_attributes = None - -> + && ProcessAttributes.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) @@ -733,7 +743,8 @@ module AddDocTemplate = struct let new_signature_item = match signature_item with | Psig_value value_desc -> - Some (process_sig_value value_desc value_desc.pval_loc) (* Some loc *) + 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 @@ -776,8 +787,8 @@ module AddDocTemplate = struct else Ast_iterator.default_iterator.structure_item iterator si | Pstr_type (_, hd :: _) as r when Loc.has_pos ~pos hd.ptype_loc - && ProcessAttributes.find_doc_attribute hd.ptype_attributes = None - -> + && ProcessAttributes.find_doc_attribute hd.ptype_attributes + = None -> result := Some (r, si.pstr_loc) | _ -> Ast_iterator.default_iterator.structure_item iterator si in @@ -786,7 +797,10 @@ module AddDocTemplate = struct 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} + { + value_binding with + pvb_attributes = attr :: value_binding.pvb_attributes; + } in new_value_binding @@ -902,7 +916,8 @@ let extract_code_actions ~path ~start_pos ~end_pos ~source ~kind_file ~debug = let code_actions = ref [] in match kind_file with | Files.Res -> - let structure, print_expr, print_structure_item, print_standalone_structure = + let structure, print_expr, print_structure_item, print_standalone_structure + = parse_implementation ~source in IfThenElse.xform ~pos ~code_actions ~print_expr ~path structure; diff --git a/tools/bin/main.ml b/tools/bin/main.ml index d1f92181d5..b3cec197c6 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -160,8 +160,8 @@ let main () = Clflags.color := Some Misc.Color.Never; (* TODO: Add result/JSON mode *) - Tools.ExtractCodeblocks.extract_codeblocks_from_file ~transform_assert_equal - ~entry_point_file:path + Tools.ExtractCodeblocks.extract_codeblocks_from_file + ~transform_assert_equal ~entry_point_file:path |> log_and_exit | _ -> log_and_exit (Error extract_codeblocks_help)) | "reanalyze" :: _ -> diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 73ffa3324a..0385474c10 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -157,7 +157,8 @@ let stringify_detail (detail : doc_item_detail) = ("kind", `String "signature"); ( "details", `Assoc - [("parameters", ps); ("returnType", stringify_type_doc return_type)] ); + [("parameters", ps); ("returnType", stringify_type_doc return_type)] + ); ] let stringify_source source = @@ -260,8 +261,8 @@ and stringify_docs_for_module ~original_env (d : docs_for_module) = ("source", stringify_source d.source); ( "items", `List - (d.items |> List.map (fun item -> stringify_doc_item ~original_env item)) - ); + (d.items + |> List.map (fun item -> stringify_doc_item ~original_env item)) ); ] @ match d.deprecated with @@ -299,7 +300,10 @@ let type_detail typ ~env ~full = | InlineRecord fields -> Some (InlineRecord - {field_docs = fields |> List.map field_to_field_doc}) + { + field_docs = + fields |> List.map field_to_field_doc; + }) | _ -> None); }); }) @@ -541,8 +545,8 @@ let extract_docs ~entry_point_file ~debug = | Module {type_ = Constraint (Structure m, Ident p)} -> (* module M: T = { }. Print M *) let docs = - extract_docs_for_module ~module_path:(m.name :: module_path) - m + extract_docs_for_module + ~module_path:(m.name :: module_path) m in let ident_module_path = p |> Path.head |> Ident.name in @@ -627,8 +631,8 @@ let extract_embedded ~extension_points ~filename = ("extensionName", `String extension_name); ("contents", `String contents); ( "loc", - Analysis.Utils.cmt_loc_to_range loc |> Lsp.Types.Range.yojson_of_t - ); + Analysis.Utils.cmt_loc_to_range loc + |> Lsp.Types.Range.yojson_of_t ); ]) |> List.rev in @@ -744,8 +748,8 @@ module FormatCodeblocks = struct mapper.structure mapper ast end - let format_rescript_code_blocks content ~transform_assert_equal ~display_filename - ~add_error ~markdown_block_start_line = + let format_rescript_code_blocks content ~transform_assert_equal + ~display_filename ~add_error ~markdown_block_start_line = (* Detect ReScript code blocks. *) let had_code_blocks = ref false in let block _m = function @@ -782,7 +786,7 @@ module FormatCodeblocks = struct 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:display_filename ~source:code_with_offset + ~display_filename ~source:code_with_offset in if invalid then ( report_parse_error diagnostics; @@ -793,7 +797,7 @@ module FormatCodeblocks = struct else let {Res_driver.parsetree; comments; invalid; diagnostics} = Res_driver.parse_implementation_from_source ~for_printer:true - ~display_filename:display_filename ~source:code_with_offset + ~display_filename ~source:code_with_offset in if invalid then ( report_parse_error diagnostics; @@ -812,7 +816,8 @@ module FormatCodeblocks = struct let mapped_code_block = Cmarkit.Block.Code_block.make ~layout ~info_string formatted_code in - Cmarkit.Mapper.ret (Cmarkit.Block.Code_block (mapped_code_block, meta)) + Cmarkit.Mapper.ret + (Cmarkit.Block.Code_block (mapped_code_block, meta)) | _ -> Cmarkit.Mapper.default) | _ -> Cmarkit.Mapper.default in @@ -825,7 +830,8 @@ module FormatCodeblocks = struct in (new_content, !had_code_blocks) - let format_code_blocks_in_file ~output_mode ~transform_assert_equal ~entry_point_file = + let format_code_blocks_in_file ~output_mode ~transform_assert_equal + ~entry_point_file = let path = match Filename.is_relative entry_point_file with | true -> Unix.realpath entry_point_file @@ -846,7 +852,8 @@ module FormatCodeblocks = struct 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 + ~markdown_block_start_line:pexp_loc.loc_start.pos_lnum + contents in if had_code_blocks && formatted_contents <> contents then ( name, @@ -1098,8 +1105,8 @@ module ExtractCodeblocks = struct result - let extract_rescript_code_blocks content ~transform_assert_equal ~display_filename - ~add_error ~markdown_block_start_line = + let extract_rescript_code_blocks content ~transform_assert_equal + ~display_filename ~add_error ~markdown_block_start_line = (* Detect ReScript code blocks. *) let code_blocks = ref [] in let add_code_block code_block = code_blocks := code_block :: !code_blocks in @@ -1133,7 +1140,7 @@ module ExtractCodeblocks = struct 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:display_filename ~source:code_with_offset + ~display_filename ~source:code_with_offset in if invalid then ( report_parse_error diagnostics; @@ -1143,7 +1150,7 @@ module ExtractCodeblocks = struct else let {Res_driver.parsetree; comments; invalid; diagnostics} = Res_driver.parse_implementation_from_source ~for_printer:true - ~display_filename:display_filename ~source:code_with_offset + ~display_filename ~source:code_with_offset in if invalid then ( report_parse_error diagnostics; @@ -1206,8 +1213,8 @@ module ExtractCodeblocks = struct ~process_docstrings:(fun ~id ~name code -> let code_blocks = code - |> extract_rescript_code_blocks ~transform_assert_equal ~add_error - ~display_filename ~markdown_block_start_line:1 + |> extract_rescript_code_blocks ~transform_assert_equal + ~add_error ~display_filename ~markdown_block_start_line:1 in if List.length code_blocks > 1 then code_blocks |> List.rev diff --git a/tools/src/transforms.ml b/tools/src/transforms.ml index 3c7dfff646..e4b549c5e9 100644 --- a/tools/src/transforms.ml +++ b/tools/src/transforms.ml @@ -1,5 +1,5 @@ -let labelled_to_unlabelled_arguments_in_fn_definition (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 drop_labels (e : Parsetree.expression) : Parsetree.expression = match e.pexp_desc with @@ -23,7 +23,8 @@ let labelled_to_unlabelled_arguments_in_fn_definition (e : Parsetree.expression) { e with pexp_desc = - Pexp_fun {arg_label; default; lhs; rhs = drop_labels rhs; arity; async}; + Pexp_fun + {arg_label; default; lhs; rhs = drop_labels rhs; arity; async}; } | _ -> e in @@ -44,7 +45,8 @@ let converted_literal_to_pure_literal (e : Parsetree.expression) : (* `Float.fromInt(1)` to `1.`, *) e -let drop_unit_arguments_in_apply (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 From ae42afddbe57c41e2ee4cc1d79385360f1461f9f Mon Sep 17 00:00:00 2001 From: Pedro Castro Date: Sun, 31 May 2026 13:09:32 -0300 Subject: [PATCH 3/5] Rename files --- analysis/bin/main.ml | 9 +- analysis/reactive/src/dune | 2 +- .../reactive/src/{Reactive.ml => reactive.ml} | 13 +- .../src/{Reactive.mli => reactive.mli} | 0 ...lection.ml => reactive_file_collection.ml} | 0 ...ction.mli => reactive_file_collection.mli} | 0 ...activeFixpoint.ml => reactive_fixpoint.ml} | 0 ...tiveFixpoint.mli => reactive_fixpoint.mli} | 0 analysis/reactive/test/ReactiveTest.ml | 13 - .../test/{BatchTest.ml => batch_test.ml} | 2 +- analysis/reactive/test/dune | 22 +- ...intBasicTest.ml => fixpoint_basic_test.ml} | 0 ...alTest.ml => fixpoint_incremental_test.ml} | 2 +- .../test/{FlatMapTest.ml => flat_map_test.ml} | 20 +- ...{GlitchFreeTest.ml => glitch_free_test.ml} | 0 ...IntegrationTest.ml => integration_test.ml} | 10 +- .../test/{JoinTest.ml => join_test.ml} | 0 analysis/reactive/test/reactive_test.ml | 13 + .../test/{TestHelpers.ml => test_helpers.ml} | 4 +- .../test/{UnionTest.ml => union_test.ml} | 26 +- analysis/reanalyze/src/AnnotationStore.ml | 34 --- analysis/reanalyze/src/OptionalArgs.ml | 45 --- analysis/reanalyze/src/OptionalArgsState.ml | 10 - .../{AnalysisResult.ml => analysis_result.ml} | 0 ...AnalysisResult.mli => analysis_result.mli} | 0 .../src/{Annotation.ml => annotation.ml} | 0 analysis/reanalyze/src/annotation_store.ml | 34 +++ ...notationStore.mli => annotation_store.mli} | 4 +- .../reanalyze/src/{Arnold.ml => arnold.ml} | 215 +++++++------- analysis/reanalyze/src/{Cli.ml => cli.ml} | 0 ...tAnnotations.ml => collect_annotations.ml} | 32 +- ...nnotations.mli => collect_annotations.mli} | 8 +- ...{CrossFileItems.ml => cross_file_items.ml} | 4 +- ...rossFileItems.mli => cross_file_items.mli} | 10 +- ...temsStore.ml => cross_file_items_store.ml} | 32 +- ...msStore.mli => cross_file_items_store.mli} | 14 +- .../src/{DceConfig.ml => dce_config.ml} | 4 +- ...leProcessing.ml => dce_file_processing.ml} | 30 +- ...Processing.mli => dce_file_processing.mli} | 8 +- .../reanalyze/src/{DcePath.ml => dce_path.ml} | 0 .../src/{DeadCode.ml => dead_code.ml} | 2 +- .../src/{DeadCommon.ml => dead_common.ml} | 160 +++++----- .../{DeadException.ml => dead_exception.ml} | 18 +- .../{DeadException.mli => dead_exception.mli} | 17 +- .../src/{DeadModules.ml => dead_modules.ml} | 8 +- ...dOptionalArgs.ml => dead_optional_args.ml} | 28 +- .../src/{DeadType.ml => dead_type.ml} | 38 +-- .../src/{DeadValue.ml => dead_value.ml} | 87 +++--- analysis/reanalyze/src/{Decl.ml => decl.ml} | 6 +- ...clarationStore.ml => declaration_store.ml} | 0 ...arationStore.mli => declaration_store.mli} | 0 .../src/{Declarations.ml => declarations.ml} | 30 +- .../{Declarations.mli => declarations.mli} | 2 +- .../src/{EmitJson.ml => emit_json.ml} | 0 .../src/{Exception.ml => exception.ml} | 75 ++--- .../src/{Exceptions.ml => exceptions.ml} | 26 +- analysis/reanalyze/src/{Exn.ml => exn.ml} | 0 analysis/reanalyze/src/{Exn.mli => exn.mli} | 0 .../reanalyze/src/{ExnLib.ml => exn_lib.ml} | 4 +- ...FileAnnotations.ml => file_annotations.ml} | 32 +- ...leAnnotations.mli => file_annotations.mli} | 2 +- .../src/{FileDeps.ml => file_deps.ml} | 76 ++--- .../src/{FileDeps.mli => file_deps.mli} | 14 +- .../src/{FileHash.ml => file_hash.ml} | 0 .../reanalyze/src/{FileSet.ml => file_set.ml} | 0 ...{FindSourceFile.ml => find_source_file.ml} | 0 analysis/reanalyze/src/{Issue.ml => issue.ml} | 8 +- .../reanalyze/src/{Issues.ml => issues.ml} | 0 .../src/{Liveness.ml => liveness.ml} | 106 +++---- .../src/{Liveness.mli => liveness.mli} | 10 +- .../reanalyze/src/{LocSet.ml => loc_set.ml} | 0 analysis/reanalyze/src/{Log_.ml => log_.ml} | 12 +- .../src/{ModulePath.ml => module_path.ml} | 16 +- analysis/reanalyze/src/{Name.ml => name.ml} | 0 analysis/reanalyze/src/{Name.mli => name.mli} | 0 analysis/reanalyze/src/optional_args.ml | 46 +++ analysis/reanalyze/src/optional_args_state.ml | 10 + analysis/reanalyze/src/{Paths.ml => paths.ml} | 16 +- analysis/reanalyze/src/{Pos.ml => pos.ml} | 0 .../reanalyze/src/{PosHash.ml => pos_hash.ml} | 0 .../reanalyze/src/{PosSet.ml => pos_set.ml} | 0 ...activeAnalysis.ml => reactive_analysis.ml} | 45 +-- ...ctiveDeclRefs.ml => reactive_decl_refs.ml} | 24 +- ...iveDeclRefs.mli => reactive_decl_refs.mli} | 6 +- ...tionRefs.ml => reactive_exception_refs.ml} | 26 +- ...onRefs.mli => reactive_exception_refs.mli} | 10 +- ...activeLiveness.ml => reactive_liveness.ml} | 22 +- ...tiveLiveness.mli => reactive_liveness.mli} | 2 +- .../{ReactiveMerge.ml => reactive_merge.ml} | 117 ++++---- .../{ReactiveMerge.mli => reactive_merge.mli} | 22 +- .../{ReactiveSolver.ml => reactive_solver.ml} | 42 +-- ...ReactiveSolver.mli => reactive_solver.mli} | 8 +- ...ctiveTypeDeps.ml => reactive_type_deps.ml} | 60 ++-- ...iveTypeDeps.mli => reactive_type_deps.mli} | 16 +- .../src/{Reanalyze.ml => reanalyze.ml} | 204 ++++++------- ...ReanalyzeServer.ml => reanalyze_server.ml} | 96 +++--- .../{ReferenceStore.ml => reference_store.ml} | 12 +- ...ReferenceStore.mli => reference_store.mli} | 8 +- .../src/{References.ml => references.ml} | 33 +- .../src/{References.mli => references.mli} | 12 +- .../src/{RunConfig.ml => run_config.ml} | 0 .../src/{SideEffects.ml => side_effects.ml} | 2 +- .../src/{StringSet.ml => string_set.ml} | 0 .../src/{Suppress.ml => suppress.ml} | 2 +- .../reanalyze/src/{Timing.ml => timing.ml} | 0 .../reanalyze/src/{Version.ml => version.ml} | 0 .../src/{BuildSystem.ml => build_system.ml} | 2 +- analysis/src/{Cache.ml => cache.ml} | 8 +- analysis/src/{Cfg.ml => cfg.ml} | 0 analysis/src/{Cli.ml => cli.ml} | 20 +- analysis/src/{Cmt.ml => cmt.ml} | 10 +- analysis/src/{CmtViewer.ml => cmt_viewer.ml} | 9 +- .../src/{CodeActions.ml => code_actions.ml} | 0 analysis/src/{Codemod.ml => codemod.ml} | 2 +- analysis/src/{Commands.ml => commands.ml} | 20 +- ...etionBackEnd.ml => completion_back_end.ml} | 258 ++++++++-------- ...Decorators.ml => completion_decorators.ml} | 0 ...pressions.ml => completion_expressions.ml} | 12 +- ...ionFrontEnd.ml => completion_front_end.ml} | 61 ++-- .../{CompletionJsx.ml => completion_jsx.ml} | 8 +- ...tionPatterns.ml => completion_patterns.ml} | 4 +- .../src/{Completions.ml => completions.ml} | 12 +- ...CreateInterface.ml => create_interface.ml} | 18 +- .../src/{DceCommand.ml => dce_command.ml} | 4 +- analysis/src/{Debug.ml => debug.ml} | 2 +- .../src/{Diagnostics.ml => diagnostics.ml} | 0 .../{DocumentSymbol.ml => document_symbol.ml} | 0 ...letionUtils.ml => dot_completion_utils.ml} | 18 +- analysis/src/{DumpAst.ml => dump_ast.ml} | 16 +- analysis/src/{Files.ml => files.ml} | 0 analysis/src/{FindFiles.ml => find_files.ml} | 68 ++--- analysis/src/{Hint.ml => hint.ml} | 2 +- analysis/src/{Hover.ml => hover.ml} | 44 +-- analysis/src/{JsxHacks.ml => jsx_hacks.ml} | 0 analysis/src/{Loc.ml => loc.ml} | 0 .../src/{LocalTables.ml => local_tables.ml} | 14 +- analysis/src/{Log.ml => log.ml} | 0 analysis/src/{Markdown.ml => markdown.ml} | 2 +- ...duleResolution.ml => module_resolution.ml} | 0 analysis/src/{Packages.ml => packages.ml} | 52 ++-- ...etionUtils.ml => pipe_completion_utils.ml} | 6 +- analysis/src/{Pos.ml => pos.ml} | 0 analysis/src/{PrintType.ml => print_type.ml} | 0 ...essAttributes.ml => process_attributes.ml} | 2 +- .../src/{ProcessCmt.ml => process_cmt.ml} | 40 +-- .../src/{ProcessExtra.ml => process_extra.ml} | 24 +- analysis/src/{Range.ml => range.ml} | 0 analysis/src/{References.ml => references.ml} | 54 ++-- .../src/{ResolvePath.ml => resolve_path.ml} | 32 +- analysis/src/{Scope.ml => scope.ml} | 6 +- .../{SemanticTokens.ml => semantic_tokens.ml} | 0 analysis/src/{Shared.ml => shared.ml} | 4 +- .../src/{SharedTypes.ml => shared_types.ml} | 60 ++-- .../{SignatureHelp.ml => signature_help.ml} | 36 +-- .../{StructureUtils.ml => structure_utils.ml} | 2 +- analysis/src/{TypeUtils.ml => type_utils.ml} | 38 +-- analysis/src/{Uri.ml => uri.ml} | 0 analysis/src/{Uri.mli => uri.mli} | 0 analysis/src/{Utils.ml => utils.ml} | 0 analysis/src/{Xform.ml => xform.ml} | 101 ++++--- .../{YojsonHelpers.ml => yojson_helpers.ml} | 0 compiler/bsc/rescript_compiler_main.ml | 24 +- compiler/core/js_exp_make.ml | 6 +- compiler/core/js_exp_make.mli | 2 +- compiler/core/js_implementation.ml | 2 +- compiler/core/js_pass_external_shadow.ml | 8 +- compiler/core/lam_compile.ml | 6 +- compiler/core/lam_compile_context.ml | 12 +- compiler/depends/ast_extract.ml | 6 +- compiler/depends/ast_extract.mli | 2 +- compiler/ext/misc.ml | 4 +- compiler/ext/misc.mli | 4 +- .../gentype/{Annotation.ml => annotation.ml} | 8 +- .../gentype/{CodeItem.ml => code_item.ml} | 14 +- .../gentype/{Converter.ml => converter.ml} | 16 +- compiler/gentype/{Debug.ml => debug.ml} | 0 .../{Dependencies.ml => dependencies.ml} | 26 +- compiler/gentype/{EmitJs.ml => emit_js.ml} | 231 +++++++------- .../gentype/{EmitText.ml => emit_text.ml} | 0 .../gentype/{EmitType.ml => emit_type.ml} | 40 +-- compiler/gentype/{Emitters.ml => emitters.ml} | 0 .../gentype/{Emitters.mli => emitters.mli} | 0 .../{ExportModule.ml => export_module.ml} | 19 +- ...{FindSourceFile.ml => find_source_file.ml} | 0 ...indSourceFile.mli => find_source_file.mli} | 0 .../gentype/{GenIdent.ml => gen_ident.ml} | 10 +- .../{GenTypeCommon.ml => gen_type_common.ml} | 26 +- .../{GenTypeConfig.ml => gen_type_config.ml} | 17 +- .../{GenTypeMain.ml => gen_type_main.ml} | 32 +- .../{GeneratedFiles.ml => generated_files.ml} | 0 .../gentype/{ImportPath.ml => import_path.ml} | 8 +- .../{ImportPath.mli => import_path.mli} | 4 +- compiler/gentype/{Indent.ml => indent.ml} | 0 compiler/gentype/{Log_.ml => log_.ml} | 0 ...ModuleExtension.ml => module_extension.ml} | 2 +- .../gentype/{ModuleName.ml => module_name.ml} | 0 .../{ModuleName.mli => module_name.mli} | 0 .../{ModuleResolver.ml => module_resolver.ml} | 45 +-- .../gentype/{NamedArgs.ml => named_args.ml} | 2 +- compiler/gentype/{Paths.ml => paths.ml} | 6 +- .../{ResolvedName.ml => resolved_name.ml} | 8 +- .../{ResolvedName.mli => resolved_name.mli} | 0 compiler/gentype/{Runtime.ml => runtime.ml} | 2 +- compiler/gentype/{Runtime.mli => runtime.mli} | 2 +- ...lateCoreType.ml => translate_core_type.ml} | 14 +- ...ateSignature.ml => translate_signature.ml} | 14 +- ...s.ml => translate_signature_from_types.ml} | 20 +- ...ateStructure.ml => translate_structure.ml} | 52 ++-- ...ions.ml => translate_type_declarations.ml} | 64 ++-- ...s.ml => translate_type_expr_from_types.ml} | 40 +-- .../{Translation.ml => translation.ml} | 49 +-- compiler/gentype/{TypeEnv.ml => type_env.ml} | 44 +-- .../gentype/{TypeEnv.mli => type_env.mli} | 6 +- .../gentype/{TypeVars.ml => type_vars.ml} | 32 +- compiler/jsoo/jsoo_playground_main.ml | 54 ++-- compiler/ml/ast_mapper.ml | 39 +-- compiler/ml/ast_untagged_variants.ml | 24 +- compiler/ml/btype.ml | 8 +- compiler/ml/btype.mli | 8 +- compiler/ml/ctype.ml | 168 ++++++----- compiler/ml/datarepr.ml | 10 +- compiler/ml/depend.ml | 60 ++-- compiler/ml/depend.mli | 12 +- compiler/ml/env.ml | 169 +++++------ compiler/ml/env.mli | 4 +- compiler/ml/experimental_features.ml | 10 +- compiler/ml/lambda.ml | 22 +- compiler/ml/lambda.mli | 4 +- compiler/ml/matching.ml | 32 +- compiler/ml/mtype.ml | 42 +-- compiler/ml/parmatch.ml | 56 ++-- compiler/ml/printtyp.ml | 29 +- compiler/ml/record_type_spread.ml | 11 +- compiler/ml/subst.ml | 24 +- compiler/ml/switch.ml | 14 +- compiler/ml/transl_recmodule.ml | 2 +- compiler/ml/translmod.ml | 6 +- compiler/ml/typecore.ml | 6 +- compiler/ml/typedecl.ml | 70 ++--- .../{typedtreeIter.ml => typedtree_iter.ml} | 4 +- .../{typedtreeIter.mli => typedtree_iter.mli} | 4 +- compiler/ml/typemod.ml | 8 +- compiler/ml/types.ml | 8 +- compiler/ml/types.mli | 2 +- compiler/syntax/cli/res_cli.ml | 18 +- compiler/syntax/src/res_ast_debugger.ml | 30 +- compiler/syntax/src/res_comments_table.ml | 16 +- compiler/syntax/src/res_core.ml | 135 ++++----- compiler/syntax/src/res_doc.ml | 21 +- compiler/syntax/src/res_parens.ml | 106 +++---- compiler/syntax/src/res_printer.ml | 281 +++++++++--------- tests/ounit_tests/ounit_scc_tests.ml | 6 +- .../{Benchmark.ml => benchmark.ml} | 12 +- tests/syntax_tests/res_test.ml | 8 +- tools/bin/main.ml | 12 +- tools/src/migrate.ml | 117 ++++---- tools/src/tools.ml | 46 +-- 257 files changed, 3014 insertions(+), 2942 deletions(-) rename analysis/reactive/src/{Reactive.ml => reactive.ml} (98%) rename analysis/reactive/src/{Reactive.mli => reactive.mli} (100%) rename analysis/reactive/src/{ReactiveFileCollection.ml => reactive_file_collection.ml} (100%) rename analysis/reactive/src/{ReactiveFileCollection.mli => reactive_file_collection.mli} (100%) rename analysis/reactive/src/{ReactiveFixpoint.ml => reactive_fixpoint.ml} (100%) rename analysis/reactive/src/{ReactiveFixpoint.mli => reactive_fixpoint.mli} (100%) delete mode 100644 analysis/reactive/test/ReactiveTest.ml rename analysis/reactive/test/{BatchTest.ml => batch_test.ml} (99%) rename analysis/reactive/test/{FixpointBasicTest.ml => fixpoint_basic_test.ml} (100%) rename analysis/reactive/test/{FixpointIncrementalTest.ml => fixpoint_incremental_test.ml} (99%) rename analysis/reactive/test/{FlatMapTest.ml => flat_map_test.ml} (89%) rename analysis/reactive/test/{GlitchFreeTest.ml => glitch_free_test.ml} (100%) rename analysis/reactive/test/{IntegrationTest.ml => integration_test.ml} (89%) rename analysis/reactive/test/{JoinTest.ml => join_test.ml} (100%) create mode 100644 analysis/reactive/test/reactive_test.ml rename analysis/reactive/test/{TestHelpers.ml => test_helpers.ml} (95%) rename analysis/reactive/test/{UnionTest.ml => union_test.ml} (82%) delete mode 100644 analysis/reanalyze/src/AnnotationStore.ml delete mode 100644 analysis/reanalyze/src/OptionalArgs.ml delete mode 100644 analysis/reanalyze/src/OptionalArgsState.ml rename analysis/reanalyze/src/{AnalysisResult.ml => analysis_result.ml} (100%) rename analysis/reanalyze/src/{AnalysisResult.mli => analysis_result.mli} (100%) rename analysis/reanalyze/src/{Annotation.ml => annotation.ml} (100%) create mode 100644 analysis/reanalyze/src/annotation_store.ml rename analysis/reanalyze/src/{AnnotationStore.mli => annotation_store.mli} (84%) rename analysis/reanalyze/src/{Arnold.ml => arnold.ml} (88%) rename analysis/reanalyze/src/{Cli.ml => cli.ml} (100%) rename analysis/reanalyze/src/{CollectAnnotations.ml => collect_annotations.ml} (86%) rename analysis/reanalyze/src/{CollectAnnotations.mli => collect_annotations.mli} (76%) rename analysis/reanalyze/src/{CrossFileItems.ml => cross_file_items.ml} (94%) rename analysis/reanalyze/src/{CrossFileItems.mli => cross_file_items.mli} (89%) rename analysis/reanalyze/src/{CrossFileItemsStore.ml => cross_file_items_store.ml} (61%) rename analysis/reanalyze/src/{CrossFileItemsStore.mli => cross_file_items_store.mli} (68%) rename analysis/reanalyze/src/{DceConfig.ml => dce_config.ml} (89%) rename analysis/reanalyze/src/{DceFileProcessing.ml => dce_file_processing.ml} (74%) rename analysis/reanalyze/src/{DceFileProcessing.mli => dce_file_processing.mli} (85%) rename analysis/reanalyze/src/{DcePath.ml => dce_path.ml} (100%) rename analysis/reanalyze/src/{DeadCode.ml => dead_code.ml} (65%) rename analysis/reanalyze/src/{DeadCommon.ml => dead_common.ml} (82%) rename analysis/reanalyze/src/{DeadException.ml => dead_exception.ml} (76%) rename analysis/reanalyze/src/{DeadException.mli => dead_exception.mli} (50%) rename analysis/reanalyze/src/{DeadModules.ml => dead_modules.ml} (83%) rename analysis/reanalyze/src/{DeadOptionalArgs.ml => dead_optional_args.ml} (83%) rename analysis/reanalyze/src/{DeadType.ml => dead_type.ml} (90%) rename analysis/reanalyze/src/{DeadValue.ml => dead_value.ml} (86%) rename analysis/reanalyze/src/{Decl.ml => decl.ml} (95%) rename analysis/reanalyze/src/{DeclarationStore.ml => declaration_store.ml} (100%) rename analysis/reanalyze/src/{DeclarationStore.mli => declaration_store.mli} (100%) rename analysis/reanalyze/src/{Declarations.ml => declarations.ml} (50%) rename analysis/reanalyze/src/{Declarations.mli => declarations.mli} (96%) rename analysis/reanalyze/src/{EmitJson.ml => emit_json.ml} (100%) rename analysis/reanalyze/src/{Exception.ml => exception.ml} (89%) rename analysis/reanalyze/src/{Exceptions.ml => exceptions.ml} (66%) rename analysis/reanalyze/src/{Exn.ml => exn.ml} (100%) rename analysis/reanalyze/src/{Exn.mli => exn.mli} (100%) rename analysis/reanalyze/src/{ExnLib.ml => exn_lib.ml} (98%) rename analysis/reanalyze/src/{FileAnnotations.ml => file_annotations.ml} (59%) rename analysis/reanalyze/src/{FileAnnotations.mli => file_annotations.mli} (96%) rename analysis/reanalyze/src/{FileDeps.ml => file_deps.ml} (63%) rename analysis/reanalyze/src/{FileDeps.mli => file_deps.mli} (84%) rename analysis/reanalyze/src/{FileHash.ml => file_hash.ml} (100%) rename analysis/reanalyze/src/{FileSet.ml => file_set.ml} (100%) rename analysis/reanalyze/src/{FindSourceFile.ml => find_source_file.ml} (100%) rename analysis/reanalyze/src/{Issue.ml => issue.ml} (88%) rename analysis/reanalyze/src/{Issues.ml => issues.ml} (100%) rename analysis/reanalyze/src/{Liveness.ml => liveness.ml} (73%) rename analysis/reanalyze/src/{Liveness.mli => liveness.mli} (81%) rename analysis/reanalyze/src/{LocSet.ml => loc_set.ml} (100%) rename analysis/reanalyze/src/{Log_.ml => log_.ml} (96%) rename analysis/reanalyze/src/{ModulePath.ml => module_path.ml} (64%) rename analysis/reanalyze/src/{Name.ml => name.ml} (100%) rename analysis/reanalyze/src/{Name.mli => name.mli} (100%) create mode 100644 analysis/reanalyze/src/optional_args.ml create mode 100644 analysis/reanalyze/src/optional_args_state.ml rename analysis/reanalyze/src/{Paths.ml => paths.ml} (93%) rename analysis/reanalyze/src/{Pos.ml => pos.ml} (100%) rename analysis/reanalyze/src/{PosHash.ml => pos_hash.ml} (100%) rename analysis/reanalyze/src/{PosSet.ml => pos_set.ml} (100%) rename analysis/reanalyze/src/{ReactiveAnalysis.ml => reactive_analysis.ml} (79%) rename analysis/reanalyze/src/{ReactiveDeclRefs.ml => reactive_decl_refs.ml} (81%) rename analysis/reanalyze/src/{ReactiveDeclRefs.mli => reactive_decl_refs.mli} (77%) rename analysis/reanalyze/src/{ReactiveExceptionRefs.ml => reactive_exception_refs.ml} (80%) rename analysis/reanalyze/src/{ReactiveExceptionRefs.mli => reactive_exception_refs.mli} (83%) rename analysis/reanalyze/src/{ReactiveLiveness.ml => reactive_liveness.ml} (86%) rename analysis/reanalyze/src/{ReactiveLiveness.mli => reactive_liveness.mli} (94%) rename analysis/reanalyze/src/{ReactiveMerge.ml => reactive_merge.ml} (67%) rename analysis/reanalyze/src/{ReactiveMerge.mli => reactive_merge.mli} (72%) rename analysis/reanalyze/src/{ReactiveSolver.ml => reactive_solver.ml} (91%) rename analysis/reanalyze/src/{ReactiveSolver.mli => reactive_solver.mli} (77%) rename analysis/reanalyze/src/{ReactiveTypeDeps.ml => reactive_type_deps.ml} (83%) rename analysis/reanalyze/src/{ReactiveTypeDeps.mli => reactive_type_deps.mli} (80%) rename analysis/reanalyze/src/{Reanalyze.ml => reanalyze.ml} (82%) rename analysis/reanalyze/src/{ReanalyzeServer.ml => reanalyze_server.ml} (85%) rename analysis/reanalyze/src/{ReferenceStore.ml => reference_store.ml} (67%) rename analysis/reanalyze/src/{ReferenceStore.mli => reference_store.mli} (75%) rename analysis/reanalyze/src/{References.ml => references.ml} (71%) rename analysis/reanalyze/src/{References.mli => references.mli} (86%) rename analysis/reanalyze/src/{RunConfig.ml => run_config.ml} (100%) rename analysis/reanalyze/src/{SideEffects.ml => side_effects.ml} (98%) rename analysis/reanalyze/src/{StringSet.ml => string_set.ml} (100%) rename analysis/reanalyze/src/{Suppress.ml => suppress.ml} (98%) rename analysis/reanalyze/src/{Timing.ml => timing.ml} (100%) rename analysis/reanalyze/src/{Version.ml => version.ml} (100%) rename analysis/src/{BuildSystem.ml => build_system.ml} (95%) rename analysis/src/{Cache.ml => cache.ml} (88%) rename analysis/src/{Cfg.ml => cfg.ml} (100%) rename analysis/src/{Cli.ml => cli.ml} (96%) rename analysis/src/{Cmt.ml => cmt.ml} (86%) rename analysis/src/{CmtViewer.ml => cmt_viewer.ml} (95%) rename analysis/src/{CodeActions.ml => code_actions.ml} (100%) rename analysis/src/{Codemod.ml => codemod.ml} (95%) rename analysis/src/{Commands.ml => commands.ml} (94%) rename analysis/src/{CompletionBackEnd.ml => completion_back_end.ml} (91%) rename analysis/src/{CompletionDecorators.ml => completion_decorators.ml} (100%) rename analysis/src/{CompletionExpressions.ml => completion_expressions.ml} (97%) rename analysis/src/{CompletionFrontEnd.ml => completion_front_end.ml} (97%) rename analysis/src/{CompletionJsx.ml => completion_jsx.ml} (98%) rename analysis/src/{CompletionPatterns.ml => completion_patterns.ml} (99%) rename analysis/src/{Completions.ml => completions.ml} (63%) rename analysis/src/{CreateInterface.ml => create_interface.ml} (95%) rename analysis/src/{DceCommand.ml => dce_command.ml} (77%) rename analysis/src/{Debug.ml => debug.ml} (83%) rename analysis/src/{Diagnostics.ml => diagnostics.ml} (100%) rename analysis/src/{DocumentSymbol.ml => document_symbol.ml} (100%) rename analysis/src/{DotCompletionUtils.ml => dot_completion_utils.ml} (68%) rename analysis/src/{DumpAst.ml => dump_ast.ml} (96%) rename analysis/src/{Files.ml => files.ml} (100%) rename analysis/src/{FindFiles.ml => find_files.ml} (86%) rename analysis/src/{Hint.ml => hint.ml} (99%) rename analysis/src/{Hover.ml => hover.ml} (90%) rename analysis/src/{JsxHacks.ml => jsx_hacks.ml} (100%) rename analysis/src/{Loc.ml => loc.ml} (100%) rename analysis/src/{LocalTables.ml => local_tables.ml} (90%) rename analysis/src/{Log.ml => log.ml} (100%) rename analysis/src/{Markdown.ml => markdown.ml} (91%) rename analysis/src/{ModuleResolution.ml => module_resolution.ml} (100%) rename analysis/src/{Packages.ml => packages.ml} (83%) rename analysis/src/{PipeCompletionUtils.ml => pipe_completion_utils.ml} (82%) rename analysis/src/{Pos.ml => pos.ml} (100%) rename analysis/src/{PrintType.ml => print_type.ml} (100%) rename analysis/src/{ProcessAttributes.ml => process_attributes.ml} (99%) rename analysis/src/{ProcessCmt.ml => process_cmt.ml} (95%) rename analysis/src/{ProcessExtra.ml => process_extra.ml} (96%) rename analysis/src/{Range.ml => range.ml} (100%) rename analysis/src/{References.ml => references.ml} (93%) rename analysis/src/{ResolvePath.ml => resolve_path.ml} (83%) rename analysis/src/{Scope.ml => scope.ml} (96%) rename analysis/src/{SemanticTokens.ml => semantic_tokens.ml} (100%) rename analysis/src/{Shared.ml => shared.ml} (94%) rename analysis/src/{SharedTypes.ml => shared_types.ml} (96%) rename analysis/src/{SignatureHelp.ml => signature_help.ml} (96%) rename analysis/src/{StructureUtils.ml => structure_utils.ml} (94%) rename analysis/src/{TypeUtils.ml => type_utils.ml} (97%) rename analysis/src/{Uri.ml => uri.ml} (100%) rename analysis/src/{Uri.mli => uri.mli} (100%) rename analysis/src/{Utils.ml => utils.ml} (100%) rename analysis/src/{Xform.ml => xform.ml} (91%) rename analysis/src/{YojsonHelpers.ml => yojson_helpers.ml} (100%) rename compiler/gentype/{Annotation.ml => annotation.ml} (97%) rename compiler/gentype/{CodeItem.ml => code_item.ml} (80%) rename compiler/gentype/{Converter.ml => converter.ml} (86%) rename compiler/gentype/{Debug.ml => debug.ml} (100%) rename compiler/gentype/{Dependencies.ml => dependencies.ml} (70%) rename compiler/gentype/{EmitJs.ml => emit_js.ml} (74%) rename compiler/gentype/{EmitText.ml => emit_text.ml} (100%) rename compiler/gentype/{EmitType.ml => emit_type.ml} (93%) rename compiler/gentype/{Emitters.ml => emitters.ml} (100%) rename compiler/gentype/{Emitters.mli => emitters.mli} (100%) rename compiler/gentype/{ExportModule.ml => export_module.ml} (90%) rename compiler/gentype/{FindSourceFile.ml => find_source_file.ml} (100%) rename compiler/gentype/{FindSourceFile.mli => find_source_file.mli} (100%) rename compiler/gentype/{GenIdent.ml => gen_ident.ml} (65%) rename compiler/gentype/{GenTypeCommon.ml => gen_type_common.ml} (91%) rename compiler/gentype/{GenTypeConfig.ml => gen_type_config.ml} (91%) rename compiler/gentype/{GenTypeMain.ml => gen_type_main.ml} (84%) rename compiler/gentype/{GeneratedFiles.ml => generated_files.ml} (100%) rename compiler/gentype/{ImportPath.ml => import_path.ml} (81%) rename compiler/gentype/{ImportPath.mli => import_path.mli} (89%) rename compiler/gentype/{Indent.ml => indent.ml} (100%) rename compiler/gentype/{Log_.ml => log_.ml} (100%) rename compiler/gentype/{ModuleExtension.ml => module_extension.ml} (97%) rename compiler/gentype/{ModuleName.ml => module_name.ml} (100%) rename compiler/gentype/{ModuleName.mli => module_name.mli} (100%) rename compiler/gentype/{ModuleResolver.ml => module_resolver.ml} (82%) rename compiler/gentype/{NamedArgs.ml => named_args.ml} (95%) rename compiler/gentype/{Paths.ml => paths.ml} (94%) rename compiler/gentype/{ResolvedName.ml => resolved_name.ml} (86%) rename compiler/gentype/{ResolvedName.mli => resolved_name.mli} (100%) rename compiler/gentype/{Runtime.ml => runtime.ml} (95%) rename compiler/gentype/{Runtime.mli => runtime.mli} (96%) rename compiler/gentype/{TranslateCoreType.ml => translate_core_type.ml} (96%) rename compiler/gentype/{TranslateSignature.ml => translate_signature.ml} (93%) rename compiler/gentype/{TranslateSignatureFromTypes.ml => translate_signature_from_types.ml} (86%) rename compiler/gentype/{TranslateStructure.ml => translate_structure.ml} (88%) rename compiler/gentype/{TranslateTypeDeclarations.ml => translate_type_declarations.ml} (86%) rename compiler/gentype/{TranslateTypeExprFromTypes.ml => translate_type_expr_from_types.ml} (95%) rename compiler/gentype/{Translation.ml => translation.ml} (79%) rename compiler/gentype/{TypeEnv.ml => type_env.ml} (82%) rename compiler/gentype/{TypeEnv.mli => type_env.mli} (85%) rename compiler/gentype/{TypeVars.ml => type_vars.ml} (80%) rename compiler/ml/{typedtreeIter.ml => typedtree_iter.ml} (99%) rename compiler/ml/{typedtreeIter.mli => typedtree_iter.mli} (96%) rename tests/syntax_benchmarks/{Benchmark.ml => benchmark.ml} (95%) diff --git a/analysis/bin/main.ml b/analysis/bin/main.ml index 0c70fd7fc7..cbb0db068e 100644 --- a/analysis/bin/main.ml +++ b/analysis/bin/main.ml @@ -126,7 +126,7 @@ let main () = let uri = Uri.from_path root_path in match Packages.find_root ~uri (Hashtbl.create 0) with | Some (`Bs root_path) -> ( - match BuildSystem.get_lib_bs root_path with + match Build_system.get_lib_bs root_path with | None -> print_endline "\"ERR\"" | Some lib_bs -> Cache.delete_cache (Cache.target_file_from_lib_bs lib_bs); @@ -145,7 +145,7 @@ let main () = Cli.type_definition ~path ~pos:(int_of_string line, int_of_string col) ~debug - | [_; "documentSymbol"; path] -> DocumentSymbol.command ~path + | [_; "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) @@ -207,12 +207,13 @@ let main () = | [_; "semanticTokens"; current_file] -> Cli.semantic_tokens ~path:current_file | [_; "createInterface"; path; cmi_file] -> - `String (CreateInterface.command ~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 cc8d382ccd..94a1d26f67 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 903156d9a8..9a12f90fd9 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/reactive.ml @@ -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 100% rename from analysis/reactive/src/Reactive.mli rename to analysis/reactive/src/reactive.mli 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 e94162f2b1..0000000000 --- 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 99% rename from analysis/reactive/test/BatchTest.ml rename to analysis/reactive/test/batch_test.ml index 54ca68d5c4..ad49c5dfeb 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 (); diff --git a/analysis/reactive/test/dune b/analysis/reactive/test/dune index cd8fe3ad9c..34904fcfa3 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 e0c2d0b6cb..3f0e8d803d 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 89% rename from analysis/reactive/test/FlatMapTest.ml rename to analysis/reactive/test/flat_map_test.ml index d09261880c..6a347e3486 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 (); @@ -58,29 +58,29 @@ let test_flatmap_with_merge () = let derived = 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" diff --git a/analysis/reactive/test/GlitchFreeTest.ml b/analysis/reactive/test/glitch_free_test.ml similarity index 100% rename from analysis/reactive/test/GlitchFreeTest.ml rename to analysis/reactive/test/glitch_free_test.ml diff --git a/analysis/reactive/test/IntegrationTest.ml b/analysis/reactive/test/integration_test.ml similarity index 89% rename from analysis/reactive/test/IntegrationTest.ml rename to analysis/reactive/test/integration_test.ml index 8b37317c6c..da65cf92c4 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 (); @@ -16,7 +16,7 @@ let test_file_collection () = (* First flatMap: aggregate word counts across files with merge *) let word_counts = flat_map ~name:"word_counts" files - ~f:(fun _path counts -> StringMap.bindings counts) + ~f:(fun _path counts -> String_map.bindings counts) (* Each file contributes its word counts *) ~merge:( + ) (* Sum counts from multiple files *) () @@ -31,10 +31,10 @@ let test_file_collection () = (* 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 0000000000..49bda079d4 --- /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 54067172fe..9f5cfab59c 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 c532180389..29813b2d9b 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 b34dbce8e7..0000000000 --- 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/OptionalArgs.ml b/analysis/reanalyze/src/OptionalArgs.ml deleted file mode 100644 index b651d991c8..0000000000 --- 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; always_used: StringSet.t} - -let empty = {unused = StringSet.empty; always_used = StringSet.empty; count = 0} - -let from_list l = - {unused = StringSet.of_list l; always_used = StringSet.empty; count = 0} - -let is_empty x = StringSet.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 |> StringSet.of_list in - let name_set_maybe = arg_names_maybe |> StringSet.of_list in - let name_set_always = StringSet.diff name_set name_set_maybe in - let always_used = - if x.count = 0 then name_set_always - else StringSet.inter name_set_always x.always_used - in - let unused = - arg_names - |> List.fold_left (fun acc name -> StringSet.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 = StringSet.inter x.unused y.unused in - let always_used = StringSet.inter x.always_used y.always_used in - ({x with unused; always_used}, {y with unused; always_used}) - -let iter_unused f x = StringSet.iter f x.unused -let iter_always_used f x = StringSet.iter (fun s -> f s x.count) x.always_used - -let fold_unused f x init = StringSet.fold f x.unused init - -let fold_always_used f x init = - StringSet.fold (fun s acc -> f s x.count acc) x.always_used init diff --git a/analysis/reanalyze/src/OptionalArgsState.ml b/analysis/reanalyze/src/OptionalArgsState.ml deleted file mode 100644 index 66a0d0cee6..0000000000 --- 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/AnalysisResult.ml b/analysis/reanalyze/src/analysis_result.ml similarity index 100% rename from analysis/reanalyze/src/AnalysisResult.ml rename to analysis/reanalyze/src/analysis_result.ml diff --git a/analysis/reanalyze/src/AnalysisResult.mli b/analysis/reanalyze/src/analysis_result.mli similarity index 100% rename from analysis/reanalyze/src/AnalysisResult.mli rename to analysis/reanalyze/src/analysis_result.mli diff --git a/analysis/reanalyze/src/Annotation.ml b/analysis/reanalyze/src/annotation.ml similarity index 100% rename from analysis/reanalyze/src/Annotation.ml rename to analysis/reanalyze/src/annotation.ml diff --git a/analysis/reanalyze/src/annotation_store.ml b/analysis/reanalyze/src/annotation_store.ml new file mode 100644 index 0000000000..30036f09f6 --- /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 0c8e099fd8..26142b936b 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 similarity index 88% rename from analysis/reanalyze/src/Arnold.ml rename to analysis/reanalyze/src/arnold.ml index c23a122914..bdc2fab0af 100644 --- a/analysis/reanalyze/src/Arnold.ml +++ b/analysis/reanalyze/src/arnold.ml @@ -5,15 +5,15 @@ let print_pos ppf (pos : Lexing.position) = (file |> Filename.basename) line -module StringSet = Set.Make (String) +module String_set = Set.Make (String) (** Type Definitions *) -module FunctionName = struct +module Function_name = struct type t = string end -module FunctionArgs = struct - type arg = {label: string; function_name: FunctionName.t} +module Function_args = struct + type arg = {label: string; function_name: Function_name.t} type t = arg list let empty = [] @@ -44,22 +44,22 @@ module FunctionArgs = struct if n <> 0 then n else compare l1 l2 end -module FunctionCall = struct - type t = {function_name: FunctionName.t; function_args: FunctionArgs.t} +module Function_call = struct + type t = {function_name: Function_name.t; function_args: Function_args.t} let substitute_name ~sub name = - match sub |> FunctionArgs.find ~label:name with + match sub |> Function_args.find ~label:name with | Some function_name -> function_name | None -> name - let apply_substitution ~(sub : FunctionArgs.t) (t : t) = + 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 : FunctionArgs.arg) -> + |> List.map (fun (arg : Function_args.arg) -> { arg with function_name = arg.function_name |> substitute_name ~sub; @@ -69,14 +69,15 @@ module FunctionCall = struct let no_args function_name = {function_name; function_args = []} let to_string {function_name; function_args} = - function_name ^ FunctionArgs.to_string 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 FunctionArgs.compare x1.function_args x2.function_args + if n <> 0 then n + else Function_args.compare x1.function_args x2.function_args end -module FunctionCallSet = Set.Make (FunctionCall) +module Function_call_set = Set.Make (Function_call) module Stats = struct let n_cache_checks = ref 0 @@ -110,7 +111,7 @@ module Stats = struct let log_cache ~config ~function_call ~hit ~loc = incr n_cache_checks; if hit then incr n_cache_hits; - if config.DceConfig.cli.debug then + if config.Dce_config.cli.debug then Log_.warning ~for_stats:false ~loc (Termination { @@ -120,18 +121,18 @@ module Stats = struct (match hit with | true -> "hit" | false -> "miss") - (FunctionCall.to_string function_call); + (Function_call.to_string function_call); }) let log_result ~config ~function_call ~loc ~res_string = - if config.DceConfig.cli.debug then + if config.Dce_config.cli.debug then Log_.warning ~for_stats:false ~loc (Termination { termination = TerminationAnalysisInternal; message = Format.asprintf "@{%s@} returns %s" - (FunctionCall.to_string function_call) + (Function_call.to_string function_call) res_string; }) @@ -206,13 +207,13 @@ module Call = struct type progress_function = Path.t type t = - | FunctionCall of FunctionCall.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 -> FunctionCall.to_string function_call + | FunctionCall function_call -> Function_call.to_string function_call end module Trace = struct @@ -253,7 +254,7 @@ module Trace = struct | Tcall (ProgressFunction progress_function, progress) -> Path.name progress_function ^ ":" ^ Progress.to_string progress | Tcall (FunctionCall function_call, progress) -> - FunctionCall.to_string function_call ^ ":" ^ Progress.to_string 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 @@ -388,7 +389,7 @@ module Command = struct | Nothing | Sequence of t list | SwitchOption of { - function_call: FunctionCall.t; + function_call: Function_call.t; loc: Location.t; some: t; none: t; @@ -405,7 +406,7 @@ module Command = struct | Sequence commands -> commands |> List.map to_string |> String.concat "; " | SwitchOption {function_call; some = c_some; none = c_none} -> "switch " - ^ FunctionCall.to_string function_call + ^ 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 ", ") ^ "}" @@ -470,13 +471,13 @@ module Kind = struct else kind end -module FunctionTable = struct +module Function_table = struct type function_definition = { mutable body: Command.t option; mutable kind: Kind.t; } - type t = (FunctionName.t, function_definition) Hashtbl.t + type t = (Function_name.t, function_definition) Hashtbl.t let create () : t = Hashtbl.create 1 @@ -529,14 +530,14 @@ module FunctionTable = struct | exception Not_found -> None end -module FindFunctionsCalled = struct +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 |> StringSet.add function_name + callees := !callees |> String_set.add function_name | _ -> ()); super.expr self e in @@ -548,13 +549,13 @@ module FindFunctionsCalled = struct | Texp_function {arity = None} -> true | _ -> false in - let callees = ref StringSet.empty 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 ExtendFunctionTable = struct +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) @@ -603,16 +604,17 @@ module ExtendFunctionTable = struct | Some (id_pos, _, callees) -> if not - (StringSet.is_empty - (StringSet.inter (Lazy.force callees) progress_functions)) + (String_set.is_empty + (String_set.inter (Lazy.force callees) progress_functions)) then let function_name = Path.name callee in if not - (callee |> FunctionTable.is_in_function_in_table ~function_table) + (callee + |> Function_table.is_in_function_in_table ~function_table) then ( - function_table |> FunctionTable.add_function ~function_name; - if config.DceConfig.cli.debug then + function_table |> Function_table.add_function ~function_name; + if config.Dce_config.cli.debug then Log_.warning ~for_stats:false ~loc (Termination { @@ -624,18 +626,18 @@ module ExtendFunctionTable = struct function_name print_pos id_pos; }))) | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)}; args} - when callee |> FunctionTable.is_in_function_in_table ~function_table -> + 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 - |> FunctionTable.is_in_function_in_table ~function_table + |> Function_table.is_in_function_in_table ~function_table -> function_table - |> FunctionTable.add_label_to_kind ~function_name ~label; - if config.DceConfig.cli.debug then + |> Function_table.add_label_to_kind ~function_name ~label; + if config.Dce_config.cli.debug then Log_.warning ~for_stats:false ~loc (Termination { @@ -661,11 +663,11 @@ module ExtendFunctionTable = struct expression |> traverse_expr.expr traverse_expr |> ignore end -module CheckExpressionWellFormed = struct +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 |> FunctionTable.is_in_function_in_table ~function_table then + 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) = @@ -679,14 +681,14 @@ module CheckExpressionWellFormed = struct args |> List.iter (fun ((arg_label : Asttypes.arg_label), arg_opt) -> match - arg_opt |> ExtendFunctionTable.extract_labelled_argument + arg_opt |> Extend_function_table.extract_labelled_argument with | Some (path, loc) -> ( match arg_label with | Labelled {txt = label} -> ( if function_table - |> FunctionTable.function_get_kind_of_label ~function_name + |> Function_table.function_get_kind_of_label ~function_name ~label <> None then () @@ -696,19 +698,19 @@ module CheckExpressionWellFormed = struct with | Some (_pos, (body : Typedtree.expression), _) when path - |> FunctionTable.is_in_function_in_table + |> Function_table.is_in_function_in_table ~function_table -> let in_table = function_path - |> FunctionTable.is_in_function_in_table + |> Function_table.is_in_function_in_table ~function_table in if not in_table then function_table - |> FunctionTable.add_function ~function_name; + |> Function_table.add_function ~function_name; function_table - |> FunctionTable.add_label_to_kind ~function_name ~label; - if config.DceConfig.cli.debug then + |> 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 { @@ -737,10 +739,10 @@ end module Compile = struct type ctx = { - config: DceConfig.t; - current_function_name: FunctionName.t; - function_table: FunctionTable.t; - inner_recursive_functions: (FunctionName.t, FunctionName.t) Hashtbl.t; + 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; } @@ -770,7 +772,7 @@ module Compile = struct | Some inner_function_name -> let inner_function_definition = function_table - |> FunctionTable.get_function_definition + |> Function_table.get_function_definition ~function_name:inner_function_name in let args_from_kind = @@ -789,10 +791,11 @@ module Compile = struct args_from_kind @ args_to_extend ) | None -> (callee_to_rename, args_to_extend) in - if callee |> FunctionTable.is_in_function_in_table ~function_table then + if callee |> Function_table.is_in_function_in_table ~function_table then let function_name = Path.name callee in let function_definition = - function_table |> FunctionTable.get_function_definition ~function_name + function_table + |> Function_table.get_function_definition ~function_name in let exception ArgError in let get_function_arg {Kind.label} = @@ -811,27 +814,27 @@ module Compile = struct let function_arg () = match arg_opt - |> ExtendFunctionTable.extract_labelled_argument + |> 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 |> FunctionTable.is_in_function_in_table ~function_table - -> + when path + |> Function_table.is_in_function_in_table ~function_table -> let function_name = Path.name path in - {FunctionArgs.label; function_name} + {Function_args.label; function_name} | Some (path, _pos) when function_table - |> FunctionTable.function_get_kind_of_label + |> 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 - {FunctionArgs.label; function_name} + {Function_args.label; function_name} | _ -> Stats.log_hygiene_named_arg_value ~label ~loc; raise ArgError @@ -854,12 +857,12 @@ module Compile = struct else match function_table - |> FunctionTable.function_get_kind_of_label + |> 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 |> FunctionCall.no_args), loc) + (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 @@ -875,15 +878,15 @@ module Compile = struct let old_function_name = Ident.name id in let new_function_name = current_function_name ^ "$" ^ old_function_name in function_table - |> FunctionTable.add_function ~function_name:new_function_name; + |> Function_table.add_function ~function_name:new_function_name; let new_function_definition = function_table - |> FunctionTable.get_function_definition + |> Function_table.get_function_definition ~function_name:new_function_name in let current_function_definition = function_table - |> FunctionTable.get_function_definition + |> Function_table.get_function_definition ~function_name:current_function_name in new_function_definition.kind <- current_function_definition.kind; @@ -891,7 +894,7 @@ module Compile = struct 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.DceConfig.cli.debug then + if config.Dce_config.cli.debug then Log_.warning ~for_stats:false ~loc:pat_loc (Termination { @@ -1046,16 +1049,16 @@ module Compile = struct expression ~ctx e +++ expression ~ctx c_rhs end -module CallStack = struct +module Call_stack = struct type frame = {frame_number: int; pos: Lexing.position} - type t = {tbl: (FunctionCall.t, frame) Hashtbl.t; mutable size: int} + 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 -> FunctionCallSet.add frame set) - tbl FunctionCallSet.empty + (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 @@ -1077,15 +1080,15 @@ module CallStack = struct |> List.sort (fun (_, i1, _) (_, i2, _) -> i2 - i1) in frames - |> List.iter (fun ((function_call : FunctionCall.t), i, pos) -> + |> List.iter (fun ((function_call : Function_call.t), i, pos) -> Format.fprintf ppf "\n @{%d@} %s (%a)" i - (FunctionCall.to_string function_call) + (Function_call.to_string function_call) print_pos pos) end module Eval = struct type progress = Progress.t - type cache = (FunctionCall.t, State.t) Hashtbl.t + type cache = (Function_call.t, State.t) Hashtbl.t let create_cache () : cache = Hashtbl.create 1 @@ -1100,7 +1103,7 @@ module Eval = struct let has_infinite_loop ~call_stack ~function_call_to_instantiate ~function_call ~loc ~state = - if call_stack |> CallStack.has_function_call ~function_call then ( + if call_stack |> Call_stack.has_function_call ~function_call then ( if state.State.progress = NoProgress then ( Log_.error ~loc (Termination @@ -1113,12 +1116,14 @@ module Eval = struct (match function_call_to_instantiate = function_call with | true -> Format.fprintf ppf "@{%s@}" - (function_call_to_instantiate |> FunctionCall.to_string) + (function_call_to_instantiate + |> Function_call.to_string) | false -> Format.fprintf ppf "@{%s@} which is @{%s@}" - (function_call_to_instantiate |> FunctionCall.to_string) - (function_call |> FunctionCall.to_string)); - Format.fprintf ppf "@,%a" CallStack.print call_stack) + (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 ()); @@ -1131,7 +1136,7 @@ module Eval = struct let pos = loc.Location.loc_start in let function_call = function_call_to_instantiate - |> FunctionCall.apply_substitution ~sub:function_args + |> Function_call.apply_substitution ~sub:function_args in let function_name = function_call.function_name in let call = Call.FunctionCall function_call in @@ -1144,7 +1149,7 @@ module Eval = struct trace = Trace.Tcall (call, state_after_call.progress); } | None -> - if FunctionCallSet.mem function_call made_progress_on then + 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 @@ -1154,9 +1159,9 @@ module Eval = struct Stats.log_cache ~config ~function_call ~hit:false ~loc; let function_definition = function_table - |> FunctionTable.get_function_definition ~function_name + |> Function_table.get_function_definition ~function_name in - call_stack |> CallStack.add_function_call ~function_call ~pos; + call_stack |> Call_stack.add_function_call ~function_call ~pos; let body = match function_definition.body with | Some body -> body @@ -1171,7 +1176,7 @@ module Eval = struct cache |> update_cache ~config ~function_call ~loc ~state:state_after_call; (* Invariant: run should restore the callStack *) - call_stack |> CallStack.remove_function_call ~function_call; + 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 @@ -1215,9 +1220,9 @@ module Eval = struct match state1.progress with | Progress -> (* look for infinite loops in the rest of the sequence, remembering what has made progress *) - ( FunctionCallSet.union made_progress_on - (call_stack |> CallStack.to_set), - CallStack.create () ) + ( 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 @@ -1271,16 +1276,16 @@ module Eval = struct State.seq state_after_call (State.nondet [state_some; state_none])) let analyze_function ~config ~cache ~function_table ~loc function_name = - if config.DceConfig.cli.debug then + 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 = CallStack.create () in - let function_args = FunctionArgs.empty in - let function_call = FunctionCall.no_args function_name in - call_stack |> CallStack.add_function_call ~function_call ~pos; + 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 |> FunctionTable.get_function_definition ~function_name + function_table |> Function_table.get_function_definition ~function_name in if function_definition.kind <> Kind.empty then Stats.log_hygiene_parametric ~function_name ~loc @@ -1293,7 +1298,7 @@ module Eval = struct let state = body |> run ~config ~cache ~call_stack ~function_args ~function_table - ~made_progress_on:FunctionCallSet.empty ~state:(State.init ()) + ~made_progress_on:Function_call_set.empty ~state:(State.init ()) in cache |> update_cache ~config ~function_call ~loc ~state end @@ -1322,12 +1327,14 @@ let traverse_ast ~config ~value_bindings_table = |> 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.find_callees vb.vb_expr) in + 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 (StringSet.empty, []) + if rec_flag = Asttypes.Nonrecursive then (String_set.empty, []) else let progress_functions0, functions_to_analyze0 = value_bindings @@ -1340,22 +1347,22 @@ let traverse_ast ~config ~value_bindings_table = with | None -> (progress_functions, functions_to_analyze) | Some new_progress_functions -> - ( StringSet.union - (StringSet.of_list 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 )) - (StringSet.empty, []) + (String_set.empty, []) in (progress_functions0, functions_to_analyze0 |> List.rev) in if functions_to_analyze <> [] then ( - let function_table = FunctionTable.create () in + let function_table = Function_table.create () in let is_progress_function path = - StringSet.mem (Path.name path) progress_functions + String_set.mem (Path.name path) progress_functions in let recursive_functions = List.fold_left @@ -1378,29 +1385,29 @@ let traverse_ast ~config ~value_bindings_table = in recursive_definitions |> List.iter (fun (function_name, _body) -> - function_table |> FunctionTable.add_function ~function_name); + function_table |> Function_table.add_function ~function_name); recursive_definitions |> List.iter (fun (_, body) -> body - |> ExtendFunctionTable.run ~config ~function_table + |> Extend_function_table.run ~config ~function_table ~progress_functions ~value_bindings_table); recursive_definitions |> List.iter (fun (_, body) -> body - |> CheckExpressionWellFormed.run ~config ~function_table + |> Check_expression_well_formed.run ~config ~function_table ~value_bindings_table); function_table |> Hashtbl.iter (fun function_name - (function_definition : FunctionTable.function_definition) + (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 - |> FunctionTable.add_body + |> Function_table.add_body ~body: (Some (body @@ -1414,7 +1421,7 @@ let traverse_ast ~config ~value_bindings_table = is_progress_function; })) ~function_name); - if config.DceConfig.cli.debug then FunctionTable.dump function_table; + 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) -> diff --git a/analysis/reanalyze/src/Cli.ml b/analysis/reanalyze/src/cli.ml similarity index 100% rename from analysis/reanalyze/src/Cli.ml rename to analysis/reanalyze/src/cli.ml diff --git a/analysis/reanalyze/src/CollectAnnotations.ml b/analysis/reanalyze/src/collect_annotations.ml similarity index 86% rename from analysis/reanalyze/src/CollectAnnotations.ml rename to analysis/reanalyze/src/collect_annotations.ml index 318348edf0..e7c4e0a17f 100644 --- a/analysis/reanalyze/src/CollectAnnotations.ml +++ b/analysis/reanalyze/src/collect_annotations.ml @@ -3,16 +3,16 @@ This module traverses the typed AST to find attribute annotations and records them in a FileAnnotations.builder. *) -open DeadCommon +open Dead_common -type scope_default = FileAnnotations.annotated_as option +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 FileAnnotations.Live -> FileAnnotations.annotate_live state pos - | Some FileAnnotations.Dead -> FileAnnotations.annotate_dead state pos - | Some FileAnnotations.GenType -> FileAnnotations.annotate_gentype state pos + | 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) = @@ -21,10 +21,10 @@ let process_attributes ~(scope_default : scope_default) ~state ~config if do_gen_type && get_payload_fun Annotation.tag_is_one_of_the_gen_type_annotations <> None - then FileAnnotations.annotate_gentype state pos; - if get_payload "dead" <> None then FileAnnotations.annotate_dead state pos; + 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.DceConfig.cli.live_names |> List.mem name + config.Dce_config.cli.live_names |> List.mem name || let fname = match Filename.is_relative pos.pos_fname with @@ -32,7 +32,7 @@ let process_attributes ~(scope_default : scope_default) ~state ~config | false -> Filename.concat (Sys.getcwd ()) pos.pos_fname in let fname_len = String.length fname in - config.DceConfig.cli.live_paths + config.Dce_config.cli.live_paths |> List.exists (fun prefix -> String.length prefix <= fname_len && @@ -40,9 +40,9 @@ let process_attributes ~(scope_default : scope_default) ~state ~config with Invalid_argument _ -> false) in if get_payload live_annotation <> None || name_is_in_live_names_or_paths () - then FileAnnotations.annotate_live state pos; + then File_annotations.annotate_live state pos; if attributes |> Annotation.is_ocaml_suppress_dead_warning then - FileAnnotations.annotate_live state pos + File_annotations.annotate_live state pos let collect_export_locations ~state ~config ~do_gen_type = let super = Tast_mapper.default in @@ -55,9 +55,9 @@ let collect_export_locations ~state ~config ~do_gen_type = let get_payload (x : string) = attrs |> Annotation.get_attribute_payload (( = ) x) in - if get_payload "dead" <> None then Some FileAnnotations.Dead - else if get_payload "live" <> None then Some FileAnnotations.Live - else if get_payload "genType" <> None then Some FileAnnotations.GenType + 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 @@ -67,7 +67,7 @@ let collect_export_locations ~state ~config ~do_gen_type = | Tpat_var (id, {loc = {loc_start = pos}}) | Tpat_alias ({pat_desc = Tpat_any}, id, {loc = {loc_start = pos}}) -> if !currently_disable_warnings then - FileAnnotations.annotate_live state pos; + 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 @@ -118,7 +118,7 @@ let collect_export_locations ~state ~config ~do_gen_type = ({val_attributes; val_id; val_val = {val_loc = {loc_start = pos}}} as value_description : Typedtree.value_description) = - if !currently_disable_warnings then FileAnnotations.annotate_live state pos; + 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; diff --git a/analysis/reanalyze/src/CollectAnnotations.mli b/analysis/reanalyze/src/collect_annotations.mli similarity index 76% rename from analysis/reanalyze/src/CollectAnnotations.mli rename to analysis/reanalyze/src/collect_annotations.mli index a08a91ae56..eee9f4c173 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 -> + 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 94% rename from analysis/reanalyze/src/CrossFileItems.ml rename to analysis/reanalyze/src/cross_file_items.ml index fde8a22e2b..81ccc95111 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,5 +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.add_value_reference ~config ~refs ~file_deps + 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 93141b1004..1fb9b92cbf 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 61% rename from analysis/reanalyze/src/CrossFileItemsStore.ml rename to analysis/reanalyze/src/cross_file_items_store.ml index 2648fa886e..3a07beb11d 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,53 +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.decl_kind = Value {optional_args}} -> optional_args - | _ -> OptionalArgs.empty) + | _ -> 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 ~arg_names ~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.is_empty 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 98eda6d3d7..f8da5db43c 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 89% rename from analysis/reanalyze/src/DceConfig.ml rename to analysis/reanalyze/src/dce_config.ml index 396185a1bb..0b7f3bf9ca 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. @@ -29,4 +29,4 @@ let current () = exclude_paths = !Cli.exclude_paths; } in - {run = RunConfig.run_config; 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 74% rename from analysis/reanalyze/src/DceFileProcessing.ml rename to analysis/reanalyze/src/dce_file_processing.ml index c0c9a59318..626a5c845b 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 ===== *) @@ -21,7 +21,7 @@ let module_name_tagged (file : file_context) = 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 process_signature ~config ~decls ~(file : file_context) ~do_values ~do_types in signature |> List.iter (fun sig_item -> - DeadValue.process_signature_item ~config ~decls ~file:dead_common_file + Dead_value.process_signature_item ~config ~decls ~file:dead_common_file ~do_values ~do_types ~module_loc:Location.none - ~module_path:ModulePath.initial + ~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) ~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,28 +57,28 @@ let process_cmt_file ~config ~(file : file_context) ~cmt_file_path } 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; + Collect_annotations.signature ~state:annotations ~config signature; process_signature ~config ~decls ~file ~do_values:true ~do_types:true signature.sig_type | Implementation structure -> let cmti_exists = Sys.file_exists ((cmt_file_path |> Filename.remove_extension) ^ ".cmti") in - CollectAnnotations.structure ~state:annotations ~config + 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 do_externals = false in - DeadValue.process_structure ~config ~decls ~refs ~file_deps ~cross_file + 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 | _ -> ()); diff --git a/analysis/reanalyze/src/DceFileProcessing.mli b/analysis/reanalyze/src/dce_file_processing.mli similarity index 85% rename from analysis/reanalyze/src/DceFileProcessing.mli rename to analysis/reanalyze/src/dce_file_processing.mli index ce2a63fa35..f3485a1daf 100644 --- a/analysis/reanalyze/src/DceFileProcessing.mli +++ b/analysis/reanalyze/src/dce_file_processing.mli @@ -12,16 +12,16 @@ 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 -> cmt_file_path:string -> Cmt_format.cmt_infos -> diff --git a/analysis/reanalyze/src/DcePath.ml b/analysis/reanalyze/src/dce_path.ml similarity index 100% rename from analysis/reanalyze/src/DcePath.ml rename to analysis/reanalyze/src/dce_path.ml 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 3119f86365..e97abaa18b 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 process_cmt = 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 82% rename from analysis/reanalyze/src/DeadCommon.ml rename to analysis/reanalyze/src/dead_common.ml index 5c36c8b6db..a843d68606 100644 --- a/analysis/reanalyze/src/DeadCommon.ml +++ b/analysis/reanalyze/src/dead_common.ml @@ -1,4 +1,4 @@ -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 *) @@ -30,7 +30,7 @@ let file_is_implementation_of s1 s2 = 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 @@ -68,7 +68,7 @@ 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.DceConfig.cli.debug then + if config.Dce_config.cli.debug then Log_.item "addValueReference %s --> %s@." (effective_from.loc_start |> Pos.to_string) (loc_to.loc_start |> Pos.to_string); @@ -79,10 +79,10 @@ let add_value_reference ~config ~refs ~file_deps ~(binding : Location.t) && (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:effective_from.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) ?pos_end ?pos_start +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 @@ -102,11 +102,11 @@ let addDeclaration_ ~config ~decls ~(file : FileContext.t) ?pos_end ?pos_start 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@." (decl_kind |> Decl.Kind.to_string) (name |> Name.to_string) (pos |> Pos.to_string) - (path |> DcePath.to_string); + (path |> Dce_path.to_string); let decl = { Decl.decl_kind; @@ -124,7 +124,7 @@ let addDeclaration_ ~config ~decls ~(file : FileContext.t) ?pos_end ?pos_start Declarations.add decls pos decl) let add_value_declaration ~config ~decls ~file ?(is_toplevel = true) - ~(loc : Location.t) ~module_loc ?(optional_args = OptionalArgs.empty) ~path + ~(loc : Location.t) ~module_loc ?(optional_args = Optional_args.empty) ~path ~side_effects name = name |> addDeclaration_ ~config ~decls ~file @@ -134,12 +134,12 @@ let add_value_declaration ~config ~decls ~file ?(is_toplevel = true) (** Create a dead code issue. Pure - no side effects. *) let make_dead_issue ~decl ~message dead_warning : Issue.t = let loc = decl |> decl_get_loc in - AnalysisResult.make_dead_issue ~loc ~dead_warning - ~path:(DcePath.without_head decl.path) + Analysis_result.make_dead_issue ~loc ~dead_warning + ~path:(Dce_path.without_head decl.path) ~message -let is_inside_reported_value (ctx : ReportingContext.t) decl = - let max_end = ReportingContext.get_max_end ctx in +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) @@ -148,7 +148,7 @@ let is_inside_reported_value (ctx : ReportingContext.t) decl = 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 - ReportingContext.set_max_end ctx decl.pos_end; + Reporting_context.set_max_end ctx decl.pos_end; inside_reported_value (** Check if a reference position is "below" the declaration. @@ -169,7 +169,7 @@ let make_hasRefBelow ~transitive ~iter_value_refs_from = else fun decl -> let found = ref false in iter_value_refs_from (fun pos_from pos_to_set -> - if (not !found) && PosSet.mem decl.Decl.pos pos_to_set then + if (not !found) && Pos_set.mem decl.Decl.pos pos_to_set then if ref_is_below decl pos_from then found := true); !found @@ -179,7 +179,7 @@ let make_hasRefBelow ~transitive ~iter_value_refs_from = [?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 report_declaration ~config ~has_ref_below ?check_module_dead ?should_report - (ctx : ReportingContext.t) decl : Issue.t list = + (ctx : Reporting_context.t) decl : Issue.t list = let inside_reported_value = decl |> is_inside_reported_value ctx in let should_report = match should_report with @@ -232,18 +232,18 @@ let report_declaration ~config ~has_ref_below ?check_module_dead ?should_report && (match decl.path with | name :: _ when name |> Name.is_underscore -> Config.report_underscore | _ -> true) - && (config.DceConfig.run.transitive || not (has_ref_below decl)) + && (config.Dce_config.run.transitive || not (has_ref_below decl)) in if should_emit_warning then let module_name = decl.path - |> DcePath.to_module_name ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + |> Dce_path.to_module_name ~is_type:(decl.decl_kind |> Decl.Kind.is_type) in let dead_module_issue = match check_module_dead with | Some f -> f ~file_name:decl.pos.pos_fname module_name | None -> - DeadModules.check_module_dead ~config ~file_name:decl.pos.pos_fname + Dead_modules.check_module_dead ~config ~file_name:decl.pos.pos_fname module_name in let dead_value_issue = make_dead_issue ~decl ~message dead_warning in @@ -254,21 +254,21 @@ let report_declaration ~config ~has_ref_below ?check_module_dead ?should_report else [] let do_report_dead ~ann_store pos = - not (AnnotationStore.is_annotated_gentype_or_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 solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state ~check_optional_arg: (check_optional_arg_fn : - optional_args_state:OptionalArgsState.t -> - ann_store:AnnotationStore.t -> - config:DceConfig.t -> + 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 @@ -276,24 +276,24 @@ let solve_dead_forward ~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 @@ -316,7 +316,7 @@ let solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state (* 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 [] |> List.fast_sort Decl.compare_for_reporting in @@ -339,17 +339,17 @@ let solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state in Log_.item "%s %s %s@." status (decl.decl_kind |> Decl.Kind.to_string) - (decl.path |> DcePath.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 @@ -357,14 +357,14 @@ let solve_dead_forward ~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) @@ -377,41 +377,41 @@ let solve_dead_forward ~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.to_string) + (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.to_string); + (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) @@ -427,7 +427,7 @@ let solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state if is_dead then ( decl.path - |> DeadModules.mark_dead ~config + |> 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; @@ -437,19 +437,19 @@ let solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state check_optional_arg_fn ~optional_args_state ~ann_store ~config decl |> List.iter (fun issue -> inline_issues := issue :: !inline_issues); decl.path - |> DeadModules.mark_live ~config + |> Dead_modules.mark_live ~config ~is_type:(decl.decl_kind |> Decl.Kind.is_type) ~loc:decl.module_loc; - if AnnotationStore.is_annotated_dead ann_store decl.pos then ( + if Annotation_store.is_annotated_dead ann_store decl.pos then ( (* Collect incorrect @dead annotation issue *) let issue = make_dead_issue ~decl ~message:" is annotated @dead but is live" IncorrectDeadAnnotation in decl.path - |> DcePath.to_module_name + |> Dce_path.to_module_name ~is_type:(decl.decl_kind |> Decl.Kind.is_type) - |> DeadModules.check_module_dead ~config + |> Dead_modules.check_module_dead ~config ~file_name:decl.pos.pos_fname |> Option.iter (fun mod_issue -> inline_issues := mod_issue :: !inline_issues); @@ -460,14 +460,14 @@ let solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state in (* Collect issues from dead declarations *) - let reporting_ctx = ReportingContext.create () in + let reporting_ctx = Reporting_context.create () in let dead_issues = sorted_dead_declarations |> List.concat_map (fun 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. @@ -477,14 +477,14 @@ let solve_dead_reactive ~ann_store ~config ~decl_store ~value_refs_from ~(roots : (Lexing.position, unit) Reactive.t) ~optional_args_state ~check_optional_arg: (check_optional_arg_fn : - optional_args_state:OptionalArgsState.t -> - ann_store:AnnotationStore.t -> - config:DceConfig.t -> + 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 *) @@ -503,7 +503,7 @@ let solve_dead_reactive ~ann_store ~config ~decl_store ~value_refs_from 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.compare_for_reporting in @@ -527,7 +527,7 @@ let solve_dead_reactive ~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 @@ -540,14 +540,14 @@ let solve_dead_reactive ~ann_store ~config ~decl_store ~value_refs_from in Log_.item "%s %s %s@." status (decl.decl_kind |> Decl.Kind.to_string) - (decl.path |> DcePath.to_string)); + (decl.path |> Dce_path.to_string)); decl.resolved_dead <- Some is_dead; if is_dead then ( incr num_dead; decl.path - |> DeadModules.mark_dead ~config + |> 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; @@ -558,19 +558,19 @@ let solve_dead_reactive ~ann_store ~config ~decl_store ~value_refs_from check_optional_arg_fn ~optional_args_state ~ann_store ~config decl |> List.iter (fun issue -> inline_issues := issue :: !inline_issues); decl.path - |> DeadModules.mark_live ~config + |> Dead_modules.mark_live ~config ~is_type:(decl.decl_kind |> Decl.Kind.is_type) ~loc:decl.module_loc; - if AnnotationStore.is_annotated_dead ann_store decl.pos then ( + if Annotation_store.is_annotated_dead ann_store decl.pos then ( (* Collect incorrect @dead annotation issue *) let issue = make_dead_issue ~decl ~message:" is annotated @dead but is live" IncorrectDeadAnnotation in decl.path - |> DcePath.to_module_name + |> Dce_path.to_module_name ~is_type:(decl.decl_kind |> Decl.Kind.is_type) - |> DeadModules.check_module_dead ~config + |> Dead_modules.check_module_dead ~config ~file_name:decl.pos.pos_fname |> Option.iter (fun mod_issue -> inline_issues := mod_issue :: !inline_issues); @@ -583,7 +583,7 @@ let solve_dead_reactive ~ann_store ~config ~decl_store ~value_refs_from 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 = sorted_dead_declarations |> List.concat_map (fun decl -> @@ -615,12 +615,12 @@ let solve_dead_reactive ~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 solve_dead ~ann_store ~config ~decl_store ~ref_store ~optional_args_state - ~check_optional_arg : AnalysisResult.t = - match ReferenceStore.get_refs_opt ref_store with + ~check_optional_arg : Analysis_result.t = + match Reference_store.get_refs_opt ref_store with | Some refs -> solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state ~check_optional_arg diff --git a/analysis/reanalyze/src/DeadException.ml b/analysis/reanalyze/src/dead_exception.ml similarity index 76% rename from analysis/reanalyze/src/DeadException.ml rename to analysis/reanalyze/src/dead_exception.ml index ccd03c9a62..fd7ebca806 100644 --- a/analysis/reanalyze/src/DeadException.ml +++ b/analysis/reanalyze/src/dead_exception.ml @@ -1,13 +1,13 @@ -open DeadCommon +open Dead_common -module PathMap = Map.Make (struct - type t = DcePath.t +module Path_map = Map.Make (struct + type t = Dce_path.t let compare = Stdlib.compare end) let find_exception_from_decls (decls : Declarations.t) : - DcePath.t -> Location.t option = + Dce_path.t -> Location.t option = let index = Declarations.fold (fun _pos (decl : Decl.t) acc -> @@ -21,11 +21,11 @@ let find_exception_from_decls (decls : Declarations.t) : loc_ghost = false; } in - PathMap.add decl.path loc acc + Path_map.add decl.path loc acc | _ -> acc) - decls PathMap.empty + decls Path_map.empty in - fun path -> PathMap.find_opt path index + fun path -> Path_map.find_opt path index let add ~config ~decls ~file ~path ~loc ~(str_loc : Location.t) ~(module_loc : Location.t) name = @@ -39,9 +39,9 @@ let mark_as_used ~config ~refs ~file_deps ~cross_file ~(binding : Location.t) if loc_to.loc_ghost then (* Probably defined in another file, delay processing and check at the end *) let exception_path = - path_ |> DcePath.from_path_t |> DcePath.module_to_implementation + path_ |> Dce_path.from_path_t |> Dce_path.module_to_implementation in - CrossFileItems.add_exception_ref cross_file ~exception_path ~loc_from + 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/DeadException.mli b/analysis/reanalyze/src/dead_exception.mli similarity index 50% rename from analysis/reanalyze/src/DeadException.mli rename to analysis/reanalyze/src/dead_exception.mli index 9cd4f2cd6d..41a6f5d98c 100644 --- a/analysis/reanalyze/src/DeadException.mli +++ b/analysis/reanalyze/src/dead_exception.mli @@ -1,12 +1,13 @@ -open DeadCommon +open Dead_common -val find_exception_from_decls : Declarations.t -> DcePath.t -> Location.t option +val find_exception_from_decls : + Declarations.t -> Dce_path.t -> Location.t option val add : - config:DceConfig.t -> + config:Dce_config.t -> decls:Declarations.builder -> - file:FileContext.t -> - path:DcePath.t -> + file:File_context.t -> + path:Dce_path.t -> loc:Location.t -> str_loc:Location.t -> module_loc:Location.t -> @@ -14,10 +15,10 @@ val add : Name.t val mark_as_used : - config:DceConfig.t -> + config:Dce_config.t -> refs:References.builder -> - file_deps:FileDeps.builder -> - cross_file:CrossFileItems.builder -> + file_deps:File_deps.builder -> + cross_file:Cross_file_items.builder -> binding:Location.t -> loc_from:Location.t -> loc_to:Location.t -> diff --git a/analysis/reanalyze/src/DeadModules.ml b/analysis/reanalyze/src/dead_modules.ml similarity index 83% rename from analysis/reanalyze/src/DeadModules.ml rename to analysis/reanalyze/src/dead_modules.ml index 2c3fec7663..26a1fbe44d 100644 --- a/analysis/reanalyze/src/DeadModules.ml +++ b/analysis/reanalyze/src/dead_modules.ml @@ -1,19 +1,19 @@ let active ~config = (* When transitive reporting is off, the only dead modules would be empty modules *) - config.DceConfig.run.transitive + 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 |> DcePath.to_module_name ~is_type in + 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 |> DcePath.to_module_name ~is_type in + 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) @@ -36,5 +36,5 @@ let check_module_dead ~config ~file_name:pos_fname module_name : Issue.t option {Location.loc_start = pos; loc_end = pos; loc_ghost = false} else loc in - Some (AnalysisResult.make_dead_module_issue ~loc ~module_name) + Some (Analysis_result.make_dead_module_issue ~loc ~module_name) | _ -> None diff --git a/analysis/reanalyze/src/DeadOptionalArgs.ml b/analysis/reanalyze/src/dead_optional_args.ml similarity index 83% rename from analysis/reanalyze/src/DeadOptionalArgs.ml rename to analysis/reanalyze/src/dead_optional_args.ml index 6083869454..2131181539 100644 --- a/analysis/reanalyze/src/DeadOptionalArgs.ml +++ b/analysis/reanalyze/src/dead_optional_args.ml @@ -1,4 +1,4 @@ -open DeadCommon +open Dead_common let active () = true @@ -11,15 +11,15 @@ let add_function_reference ~config ~decls ~cross_file ~(loc_from : Location.t) let should_add = match Declarations.find_opt_builder decls pos_to with | Some {decl_kind = Value {optional_args}} -> - not (OptionalArgs.is_empty optional_args) + not (Optional_args.is_empty optional_args) | _ -> false in if should_add then ( - if config.DceConfig.cli.debug then + if config.Dce_config.cli.debug then Log_.item "OptionalArgs.addFunctionReference %s %s@." (pos_from |> Pos.to_string) (pos_to |> Pos.to_string); - CrossFileItems.add_function_reference cross_file ~pos_from ~pos_to) + 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 @@ -45,14 +45,14 @@ let add_references ~config ~cross_file ~(loc_from : Location.t) if active () then ( let pos_to = loc_to.loc_start in let pos_from = binding.loc_start in - CrossFileItems.add_optional_arg_call cross_file ~pos_from ~pos_to ~arg_names - ~arg_names_maybe; - if config.DceConfig.cli.debug then + 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 |> DcePath.from_path_t |> DcePath.to_string) + (path |> Dce_path.from_path_t |> Dce_path.to_string) (arg_names |> String.concat ", ") (arg_names_maybe |> String.concat ", ") (call_pos |> Pos.to_string)) @@ -64,17 +64,17 @@ let check ~optional_args_state ~ann_store ~config:_ decl : Issue.t list = | {Decl.decl_kind = Value {optional_args}} when active () && not - (AnnotationStore.is_annotated_gentype_or_live ann_store decl.pos) + (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 OptionalArgsState.find_opt optional_args_state decl.pos with + 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 = - OptionalArgs.fold_unused + Optional_args.fold_unused (fun s acc -> let issue : Issue.t = { @@ -90,7 +90,7 @@ let check ~optional_args_state ~ann_store ~config:_ decl : Issue.t list = "optional argument @{%s@} of function \ @{%s@} is never used" s - (decl.path |> DcePath.without_head); + (decl.path |> Dce_path.without_head); }; } in @@ -98,7 +98,7 @@ let check ~optional_args_state ~ann_store ~config:_ decl : Issue.t list = state [] in let redundant_issues = - OptionalArgs.fold_always_used + Optional_args.fold_always_used (fun s n_calls acc -> let issue : Issue.t = { @@ -114,7 +114,7 @@ let check ~optional_args_state ~ann_store ~config:_ decl : Issue.t list = "optional argument @{%s@} of function \ @{%s@} is always supplied (%d calls)" s - (decl.path |> DcePath.without_head) + (decl.path |> Dce_path.without_head) n_calls; }; } diff --git a/analysis/reanalyze/src/DeadType.ml b/analysis/reanalyze/src/dead_type.ml similarity index 90% rename from analysis/reanalyze/src/DeadType.ml rename to analysis/reanalyze/src/dead_type.ml index c3dd09df04..1bfad3e33a 100644 --- a/analysis/reanalyze/src/DeadType.ml +++ b/analysis/reanalyze/src/dead_type.ml @@ -1,9 +1,9 @@ (* Adapted from https://github.com/LexiFi/dead_code_analyzer *) -open DeadCommon +open Dead_common let add_type_reference ~config ~refs ~pos_from ~pos_to = - if config.DceConfig.cli.debug then + if config.Dce_config.cli.debug then Log_.item "addTypeReference %s --> %s@." (pos_from |> Pos.to_string) (pos_to |> Pos.to_string); @@ -14,16 +14,16 @@ let extend_type_dependencies ~config ~refs (loc1 : 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.DceConfig.cli.debug 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 : ModulePath.t) +let add_declaration ~config ~decls ~file ~(module_path : Module_path.t) ~(type_id : Ident.t) ~(type_kind : Types.type_kind) - ~(manifest_type_path : DcePath.t option) = + ~(manifest_type_path : Dce_path.t option) = let module_context = - module_path.path @ [FileContext.module_name_tagged file] + 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 @@ -68,8 +68,8 @@ let add_declaration ~config ~decls ~file ~(module_path : ModulePath.t) decls | _ -> () -module PathMap = Map.Make (struct - type t = DcePath.t +module Path_map = Map.Make (struct + type t = Dce_path.t let compare = Stdlib.compare end) @@ -91,16 +91,16 @@ let process_type_label_dependencies ~config ~decls ~refs = let loc = decl |> decl_raw_loc in let path = decl.path in let existing = - PathMap.find_opt path acc |> Option.value ~default:[] + Path_map.find_opt path acc |> Option.value ~default:[] in - PathMap.add path (loc :: existing) acc + Path_map.add path (loc :: existing) acc | _ -> acc) - decls PathMap.empty + 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 - |> PathMap.iter (fun _key locs -> + |> Path_map.iter (fun _key locs -> match locs with | [] | [_] -> () | loc0 :: rest -> @@ -116,12 +116,12 @@ let process_type_label_dependencies ~config ~decls ~refs = | x :: _ -> Some x in let find_one path = - match PathMap.find_opt path index with + match Path_map.find_opt path index with | None -> None | Some locs -> hd_opt locs in - let is_interface_of_pathToType (path_to_type : DcePath.t) = + 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] <> '+' @@ -139,8 +139,8 @@ let process_type_label_dependencies ~config ~decls ~refs = 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 |> DcePath.module_to_interface in - let path_2 = path_1 |> DcePath.type_to_interface 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 path1 = type_label_name :: path_1 in let path2 = type_label_name :: path_2 in match find_one path1 with @@ -156,7 +156,7 @@ let process_type_label_dependencies ~config ~decls ~refs = extend_type_dependencies ~config ~refs loc2 loc | None -> ()) else - let path_1 = path_to_type |> DcePath.module_to_implementation in + 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 -> () @@ -179,9 +179,9 @@ let process_type_label_dependencies ~config ~decls ~refs = in (* currentTypePath -> (rep_pos, manifestTypePath, (pos, fieldName, currentLoc) list) *) let groups : - ( DcePath.t, + ( Dce_path.t, Lexing.position - * DcePath.t + * Dce_path.t * (Lexing.position * Name.t * Location.t) list ) Hashtbl.t = Hashtbl.create 32 diff --git a/analysis/reanalyze/src/DeadValue.ml b/analysis/reanalyze/src/dead_value.ml similarity index 86% rename from analysis/reanalyze/src/DeadValue.ml rename to analysis/reanalyze/src/dead_value.ml index 898aef49f3..aa82de7f77 100644 --- a/analysis/reanalyze/src/DeadValue.ml +++ b/analysis/reanalyze/src/dead_value.ml @@ -1,22 +1,22 @@ (* Adapted from https://github.com/LexiFi/dead_code_analyzer *) -open DeadCommon +open Dead_common let check_any_value_binding_with_no_side_effects ~config ~decls ~file - ~(module_path : ModulePath.t) + ~(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 (SideEffects.check_expr expr)) && not loc.loc_ghost -> + | 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 @ [FileContext.module_name_tagged file] 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 : ModulePath.t) (vb : Typedtree.value_binding) = + ~(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; @@ -28,8 +28,8 @@ let collect_value_binding ~config ~decls ~file ~(current_binding : Location.t) 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 |> DeadOptionalArgs.from_type_expr - |> OptionalArgs.from_list + 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 @@ -38,7 +38,7 @@ let collect_value_binding ~config ~decls ~file ~(current_binding : Location.t) true | _ -> false in - let path = module_path.path @ [FileContext.module_name_tagged file] 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 @@ -47,7 +47,7 @@ let collect_value_binding ~config ~decls ~file ~(current_binding : Location.t) (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 = SideEffects.check_expr vb.vb_expr 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); @@ -60,7 +60,7 @@ let collect_value_binding ~config ~decls ~file ~(current_binding : Location.t) match decl.decl_kind with | Value vk -> Decl.Kind.Value - {vk with side_effects = SideEffects.check_expr vb.vb_expr} + {vk with side_effects = Side_effects.check_expr vb.vb_expr} | dk -> dk in Declarations.replace_builder decls loc_start @@ -77,7 +77,7 @@ let collect_value_binding ~config ~decls ~file ~(current_binding : Location.t) let process_optional_args ~config ~cross_file ~exp_type ~(loc_from : Location.t) ~(binding : Location.t) ~loc_to ~path args = - if exp_type |> DeadOptionalArgs.has_optional_args then ( + if exp_type |> Dead_optional_args.has_optional_args then ( let supplied = ref [] in let supplied_maybe = ref [] in args @@ -106,7 +106,7 @@ let process_optional_args ~config ~cross_file ~exp_type ~(loc_from : Location.t) supplied_maybe := s :: !supplied_maybe | _ -> ()); (!supplied, !supplied_maybe) - |> DeadOptionalArgs.add_references ~config ~cross_file ~loc_from ~loc_to + |> Dead_optional_args.add_references ~config ~cross_file ~loc_from ~loc_to ~binding ~path) let rec collect_expr ~config ~refs ~file_deps ~cross_file @@ -119,7 +119,7 @@ let rec collect_expr ~config ~refs ~file_deps ~cross_file 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.DceConfig.cli.debug then + 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); @@ -187,7 +187,7 @@ let rec collect_expr ~config ~refs ~file_deps ~cross_file | Texp_field (_, _, {lbl_loc = {Location.loc_start = pos_to; loc_ghost = false}; _}) -> if !Config.analyze_types then - DeadType.add_type_reference ~config ~refs ~pos_to + Dead_type.add_type_reference ~config ~refs ~pos_to ~pos_from:loc_from.loc_start | Texp_construct ( _, @@ -199,11 +199,11 @@ let rec collect_expr ~config ~refs ~file_deps ~cross_file (match cstr_tag with | Cstr_extension path -> path - |> DeadException.mark_as_used ~config ~refs ~file_deps ~cross_file + |> Dead_exception.mark_as_used ~config ~refs ~file_deps ~cross_file ~binding ~loc_from ~loc_to | _ -> ()); if !Config.analyze_types && not loc_ghost then - DeadType.add_type_reference ~config ~refs ~pos_to + Dead_type.add_type_reference ~config ~refs ~pos_to ~pos_from:loc_from.loc_start | Texp_record {fields} -> fields @@ -239,7 +239,7 @@ let collect_pattern ~config ~refs : cases |> List.iter (fun (_loc, {Types.lbl_loc = {loc_start = pos_to}}, _pat, _) -> if !Config.analyze_types then - DeadType.add_type_reference ~config ~refs ~pos_from ~pos_to) + Dead_type.add_type_reference ~config ~refs ~pos_from ~pos_to) | _ -> ()); super.Tast_mapper.pat self pat @@ -250,7 +250,7 @@ let rec get_signature (module_type : Types.module_type) = | _ -> [] let rec process_signature_item ~config ~decls ~file ~do_types ~do_values - ~module_loc ~(module_path : ModulePath.t) ~path (si : Types.signature_item) + ~module_loc ~(module_path : Module_path.t) ~path (si : Types.signature_item) = match si with | Sig_type (id, t, _) when do_types -> @@ -260,21 +260,21 @@ let rec process_signature_item ~config ~decls ~file ~do_types ~do_values let manifest_type_path = match t.type_manifest with | Some {desc = Tconstr (path, _, _)} -> ( - let p = path |> DcePath.from_path_t in + let p = path |> Dce_path.from_path_t in match p with | [type_name] -> let module_context = - module_path.path @ [FileContext.module_name_tagged file] + module_path.path @ [File_context.module_name_tagged file] in Some (type_name :: module_context) | _ -> Some - (if FileContext.is_interface file then - DcePath.module_to_interface p - else DcePath.module_to_implementation p)) + (if File_context.is_interface file then + Dce_path.module_to_interface p + else Dce_path.module_to_implementation p)) | _ -> None in - DeadType.add_declaration ~config ~decls ~file ~module_path ~type_id:id + 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 -> @@ -286,7 +286,8 @@ let rec process_signature_item ~config ~decls ~file ~do_types ~do_values in if (not is_primitive) || !Config.analyze_externals then let optional_args = - val_type |> DeadOptionalArgs.from_type_expr |> OptionalArgs.from_list + val_type |> Dead_optional_args.from_type_expr + |> Optional_args.from_list in (* if Ident.name id = "someValue" then @@ -299,7 +300,7 @@ let rec process_signature_item ~config ~decls ~file ~do_types ~do_values | Sig_modtype (id, {Types.mtd_type = Some module_type; mtd_loc = module_loc}) -> let modulePath' = - ModulePath.enter_module module_path + Module_path.enter_module module_path ~name:(id |> Ident.name |> Name.create) ~loc:module_loc in @@ -319,8 +320,8 @@ let rec process_signature_item ~config ~decls ~file ~do_types ~do_values (* 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 : ModulePath.t) - = + let rec create_mapper (last_binding : Location.t) + (module_path : Module_path.t) = let super = Tast_mapper.default in let rec mapper = { @@ -342,7 +343,7 @@ let traverse_structure ~config ~decls ~refs ~file_deps ~cross_file ~file | _ -> false in let modulePath' = - ModulePath.enter_module module_path + Module_path.enter_module module_path ~name:(mb_id |> Ident.name |> Name.create) ~loc:mb_loc in @@ -356,14 +357,14 @@ let traverse_structure ~config ~decls ~refs ~file_deps ~cross_file ~file ~module_path:modulePath' ~path: (modulePath'.path - @ [FileContext.module_name_tagged file])) + @ [File_context.module_name_tagged file])) | _ -> () else (); Some modulePath' | Tstr_primitive vd when do_externals && !Config.analyze_externals -> let path = - module_path.path @ [FileContext.module_name_tagged file] + module_path.path @ [File_context.module_name_tagged file] in let exists = match @@ -393,22 +394,22 @@ let traverse_structure ~config ~decls ~refs ~file_deps ~cross_file ~file let manifest_type_path = match type_declaration.typ_manifest with | Some {ctyp_desc = Ttyp_constr (path, _, _)} -> ( - let p = path |> DcePath.from_path_t in + let p = path |> Dce_path.from_path_t in match p with | [type_name] -> let module_context = module_path.path - @ [FileContext.module_name_tagged file] + @ [File_context.module_name_tagged file] in Some (type_name :: module_context) | _ -> Some - (if FileContext.is_interface file then - DcePath.module_to_interface p - else DcePath.module_to_implementation p)) + (if File_context.is_interface file then + Dce_path.module_to_interface p + else Dce_path.module_to_implementation p)) | _ -> None in - DeadType.add_declaration ~config ~decls ~file + 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); @@ -417,7 +418,7 @@ let traverse_structure ~config ~decls ~refs ~file_deps ~cross_file ~file (match incl_mod.mod_desc with | Tmod_ident (_path, _lid) -> let current_path = - module_path.path @ [FileContext.module_name_tagged file] + module_path.path @ [File_context.module_name_tagged file] in incl_type |> List.iter @@ -429,11 +430,11 @@ let traverse_structure ~config ~decls ~refs ~file_deps ~cross_file ~file None | Tstr_exception {ext_id = id; ext_loc = loc} -> let path = - module_path.path @ [FileContext.module_name_tagged file] + module_path.path @ [File_context.module_name_tagged file] in let name = id |> Ident.name |> Name.create in ignore - (DeadException.add ~config ~decls ~file ~path ~loc + (Dead_exception.add ~config ~decls ~file ~path ~loc ~str_loc:structure_item.str_loc ~module_loc:module_path.loc name); None @@ -459,7 +460,7 @@ let traverse_structure ~config ~decls ~refs ~file_deps ~cross_file ~file in mapper in - let mapper = create_mapper Location.none ModulePath.initial 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 *) @@ -480,8 +481,8 @@ let process_value_dependency ~config ~decls ~refs ~file_deps ~cross_file 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; - DeadOptionalArgs.add_function_reference ~config ~decls ~cross_file ~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 diff --git a/analysis/reanalyze/src/Decl.ml b/analysis/reanalyze/src/decl.ml similarity index 95% rename from analysis/reanalyze/src/Decl.ml rename to analysis/reanalyze/src/decl.ml index e98a33d553..aa457b3f5b 100644 --- a/analysis/reanalyze/src/Decl.ml +++ b/analysis/reanalyze/src/decl.ml @@ -7,7 +7,7 @@ module Kind = struct | VariantCase | Value of { is_toplevel: bool; - mutable optional_args: OptionalArgs.t; + mutable optional_args: Optional_args.t; side_effects: bool; } @@ -30,12 +30,12 @@ type t = { decl_kind: Kind.t; module_loc: Location.t; pos_adjustment: pos_adjustment; - path: DcePath.t; + 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. *) - manifest_type_path: DcePath.t option; + manifest_type_path: Dce_path.t option; pos: Lexing.position; pos_end: Lexing.position; pos_start: Lexing.position; 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 6b8dfedc7d..bcdee966ab 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 e6362ee2e9..4020a4f122 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/EmitJson.ml b/analysis/reanalyze/src/emit_json.ml similarity index 100% rename from analysis/reanalyze/src/EmitJson.ml rename to analysis/reanalyze/src/emit_json.ml diff --git a/analysis/reanalyze/src/Exception.ml b/analysis/reanalyze/src/exception.ml similarity index 89% rename from analysis/reanalyze/src/Exception.ml rename to analysis/reanalyze/src/exception.ml index 90792d018d..271a27bd7a 100644 --- a/analysis/reanalyze/src/Exception.ml +++ b/analysis/reanalyze/src/exception.ml @@ -1,4 +1,4 @@ -open DeadCommon +open Dead_common type values_builder = (Name.t, Exceptions.t) Hashtbl.t (** Per-file mutable builder for exception values during AST processing *) @@ -10,8 +10,8 @@ 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.ModulePath.path in - Hashtbl.replace builder (path |> DcePath.to_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) : @@ -24,8 +24,8 @@ let merge_values_builders (builders : (string * values_builder) list) : module Values = struct let get_from_module (table : values_table) ~module_name ~module_path - (path_ : DcePath.t) = - let name = path_ @ module_path |> DcePath.to_name in + (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 -> ( @@ -69,7 +69,7 @@ end module Event = struct type kind = | Catches of t list (* with | E => ... *) - | Call of {callee: DcePath.t; module_path: DcePath.t} (* foo() *) + | 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 *) @@ -81,8 +81,8 @@ module Event = struct | {kind = Call {callee; module_path}; exceptions; loc} -> Format.fprintf ppf "%s Call(%s, modulePath:%s) %a@." (loc.loc_start |> Pos.to_string) - (callee |> DcePath.to_string) - (module_path |> DcePath.to_string) + (callee |> Dce_path.to_string) + (module_path |> Dce_path.to_string) (Exceptions.pp ~exn_table:None) exceptions | {kind = DoesNotThrow nested_events; loc} -> @@ -106,48 +106,48 @@ module Event = struct () let combine ~(values_table : values_table) ~config ~module_name events = - if config.DceConfig.cli.debug then ( + 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 (LocSet.add loc loc_set) - | None -> Hashtbl.replace exn_table exn (LocSet.add loc LocSet.empty) + | 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 (LocSet.remove loc 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.DceConfig.cli.debug then Log_.item "%a@." print ev; + 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.DceConfig.cli.debug then Log_.item "%a@." print ev; + 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 ExnLib.find callee with + 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.DceConfig.cli.debug then Log_.item "%a@." print ev; + 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 |> DcePath.to_name + | {kind = Call {callee}} :: _ -> callee |> Dce_path.to_name | _ -> "expression" |> Name.create in Log_.warning ~loc @@ -161,7 +161,7 @@ module Event = struct })); loop exn_set rest | ({kind = Catches nested_events; exceptions} as ev) :: rest -> - if config.DceConfig.cli.debug then Log_.item "%a@." print ev; + 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 @@ -243,7 +243,7 @@ let traverse_ast ~file ~values_builder ~checks_builder () = 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 |> DcePath.to_name in + 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 = @@ -299,7 +299,7 @@ let traverse_ast ~file ~values_builder ~checks_builder () = | _ -> false) <> None in - let expr ~(module_path : ModulePath.t) (self : Tast_mapper.mapper) + 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 @@ -308,9 +308,9 @@ let traverse_ast ~file ~values_builder ~checks_builder () = (match expr.exp_desc with | Texp_ident (callee_, _, _) -> let callee = - callee_ |> DcePath.from_path_t |> ModulePath.resolve_alias module_path + callee_ |> Dce_path.from_path_t |> Module_path.resolve_alias module_path in - let callee_name = callee |> DcePath.to_name in + let callee_name = callee |> Dce_path.to_name in if callee_name |> Name.to_string |> is_throw then Log_.warning ~loc (Issue.ExceptionAnalysis @@ -427,7 +427,7 @@ let traverse_ast ~file ~values_builder ~checks_builder () = let name = "Toplevel expression" in current_id := name; current_events := []; - let module_name = file.FileContext.module_name in + 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) @@ -435,7 +435,7 @@ let traverse_ast ~file ~values_builder ~checks_builder () = current_id := old_id; current_events := old_events in - let value_binding ~(module_path : ModulePath.t) (self : Tast_mapper.mapper) + 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 @@ -454,7 +454,7 @@ let traverse_ast ~file ~values_builder ~checks_builder () = values_builder_add values_builder ~module_path ~name exceptions_from_annotations; let res = super.value_binding self vb in - let module_name = file.FileContext.module_name 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 @@ -480,7 +480,7 @@ let traverse_ast ~file ~values_builder ~checks_builder () = process_binding (id |> Ident.name) | _ -> super.value_binding self vb in - let make_mapper (module_path : ModulePath.t) : Tast_mapper.mapper = + let make_mapper (module_path : Module_path.t) : Tast_mapper.mapper = let open Tast_mapper in { super with @@ -488,7 +488,7 @@ let traverse_ast ~file ~values_builder ~checks_builder () = value_binding = value_binding ~module_path; } in - let rec process_module_expr (module_path : ModulePath.t) + 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 @@ -500,9 +500,9 @@ let traverse_ast ~file ~values_builder ~checks_builder () = | _ -> let mapper = make_mapper module_path in super.module_expr mapper me |> ignore - and process_structure (module_path : ModulePath.t) + and process_structure (module_path : Module_path.t) (structure : Typedtree.structure) = - let rec loop (mp : ModulePath.t) (items : Typedtree.structure_item list) = + let rec loop (mp : Module_path.t) (items : Typedtree.structure_item list) = match items with | [] -> () | structure_item :: rest -> @@ -514,23 +514,26 @@ let traverse_ast ~file ~values_builder ~checks_builder () = mp | Tstr_module {mb_id; mb_loc; mb_expr} -> ( let name = mb_id |> Ident.name |> Name.create in - let mp_inside = ModulePath.enter_module mp ~name ~loc:mb_loc 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) -> - ModulePath.add_alias mp ~name ~path:(path_ |> DcePath.from_path_t) + 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 = ModulePath.enter_module acc ~name ~loc:mb_loc 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) -> - ModulePath.add_alias acc ~name - ~path:(path_ |> DcePath.from_path_t) + Module_path.add_alias acc ~name + ~path:(path_ |> Dce_path.from_path_t) | _ -> acc) mp mbs | _ -> @@ -542,7 +545,7 @@ let traverse_ast ~file ~values_builder ~checks_builder () = loop module_path structure.str_items in fun (structure : Typedtree.structure) -> - process_structure ModulePath.initial structure + process_structure Module_path.initial structure type file_result = { module_name: string; @@ -565,7 +568,7 @@ let process_cmt ~file (cmt_infos : Cmt_format.cmt_infos) : file_result option = structure |> process_structure ~file ~values_builder ~checks_builder; Some { - module_name = file.FileContext.module_name; + module_name = file.File_context.module_name; values_builder; checks = checks_builder_to_list checks_builder; } diff --git a/analysis/reanalyze/src/Exceptions.ml b/analysis/reanalyze/src/exceptions.ml similarity index 66% rename from analysis/reanalyze/src/Exceptions.ml rename to analysis/reanalyze/src/exceptions.ml index 910c9a0db1..a5903143ad 100644 --- a/analysis/reanalyze/src/Exceptions.ml +++ b/analysis/reanalyze/src/exceptions.ml @@ -1,15 +1,15 @@ -module ExnSet = Set.Make (Exn) +module Exn_set = Set.Make (Exn) -type t = ExnSet.t +type t = Exn_set.t -let add = ExnSet.add -let diff = ExnSet.diff -let empty = ExnSet.empty -let from_list = ExnSet.of_list -let to_list = ExnSet.elements -let is_empty = ExnSet.is_empty -let iter = ExnSet.iter -let union = ExnSet.union +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 @@ -22,7 +22,7 @@ let pp ~exn_table ppf exceptions = match Hashtbl.find_opt exn_table exn with | Some loc_set -> let positions = - loc_set |> LocSet.elements + loc_set |> Loc_set.elements |> List.map (fun loc -> loc.Location.loc_start) in Format.fprintf ppf "%s@{%s@} (@{%s@})" separator name @@ -30,7 +30,7 @@ let pp ~exn_table ppf exceptions = | None -> Format.fprintf ppf "%s@{%s@}" separator name) | None -> Format.fprintf ppf "%s@{%s@}" separator name in - let is_list = exceptions |> ExnSet.cardinal > 1 in + let is_list = exceptions |> Exn_set.cardinal > 1 in if is_list then Format.fprintf ppf "["; - exceptions |> ExnSet.iter pp_exn; + 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 similarity index 100% rename from analysis/reanalyze/src/Exn.ml rename to analysis/reanalyze/src/exn.ml diff --git a/analysis/reanalyze/src/Exn.mli b/analysis/reanalyze/src/exn.mli similarity index 100% rename from analysis/reanalyze/src/Exn.mli rename to analysis/reanalyze/src/exn.mli diff --git a/analysis/reanalyze/src/ExnLib.ml b/analysis/reanalyze/src/exn_lib.ml similarity index 98% rename from analysis/reanalyze/src/ExnLib.ml rename to analysis/reanalyze/src/exn_lib.ml index 8f5601fac5..f6ce02723f 100644 --- a/analysis/reanalyze/src/ExnLib.ml +++ b/analysis/reanalyze/src/exn_lib.ml @@ -242,5 +242,5 @@ let raises_lib_table : (Name.t, Exceptions.t) Hashtbl.t = (e |> Exceptions.from_list))); table -let find (path : DcePath.t) = - Hashtbl.find_opt raises_lib_table (path |> DcePath.to_name) +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 60e78a0bb9..83cded0371 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 292b5b5c12..3ca50fcacd 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/FileDeps.ml b/analysis/reanalyze/src/file_deps.ml similarity index 63% rename from analysis/reanalyze/src/FileDeps.ml rename to analysis/reanalyze/src/file_deps.ml index b84fd04642..d02a040a77 100644 --- a/analysis/reanalyze/src/FileDeps.ml +++ b/analysis/reanalyze/src/file_deps.ml @@ -3,7 +3,7 @@ Tracks which files reference which other files. *) (* File-keyed hashtable *) -module FileHash = Hashtbl.Make (struct +module File_hash = Hashtbl.Make (struct type t = string let hash (x : t) = Hashtbl.hash x @@ -13,43 +13,43 @@ end) (** {2 Types} *) type t = { - files: FileSet.t; - deps: FileSet.t FileHash.t; (* from_file -> set of to_files *) + files: File_set.t; + deps: File_set.t File_hash.t; (* from_file -> set of to_files *) } -type builder = {mutable files: FileSet.t; deps: FileSet.t FileHash.t} +type builder = {mutable files: File_set.t; deps: File_set.t File_hash.t} (** {2 Builder API} *) let create_builder () : builder = - {files = FileSet.empty; deps = FileHash.create 256} + {files = File_set.empty; deps = File_hash.create 256} let add_file (b : builder) file = - b.files <- FileSet.add file b.files; + b.files <- File_set.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 + 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 FileHash.find_opt b.deps from_file with + match File_hash.find_opt b.deps from_file with | Some s -> s - | None -> FileSet.empty + | None -> File_set.empty in - FileHash.replace b.deps from_file (FileSet.add to_file set) + 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 <- FileSet.union into.files from.files; - FileHash.iter + into.files <- File_set.union into.files from.files; + File_hash.iter (fun from_file to_files -> let existing = - match FileHash.find_opt into.deps from_file with + match File_hash.find_opt into.deps from_file with | Some s -> s - | None -> FileSet.empty + | None -> File_set.empty in - FileHash.replace into.deps from_file (FileSet.union existing to_files)) + File_hash.replace into.deps from_file (File_set.union existing to_files)) from.deps let freeze_builder (b : builder) : t = @@ -66,10 +66,10 @@ let merge_all (builders : builder list) : t = (** {2 Builder extraction for reactive merge} *) -let builder_files (builder : builder) : FileSet.t = builder.files +let builder_files (builder : builder) : File_set.t = builder.files -let builder_deps_to_list (builder : builder) : (string * FileSet.t) list = - FileHash.fold +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 [] @@ -80,17 +80,17 @@ let create ~files ~deps : t = {files; deps} let get_files (t : t) = t.files let get_deps (t : t) file = - match FileHash.find_opt t.deps file with + match File_hash.find_opt t.deps file with | Some s -> s - | None -> FileSet.empty + | None -> File_set.empty -let iter_deps (t : t) f = FileHash.iter f t.deps +let iter_deps (t : t) f = File_hash.iter f t.deps -let file_exists (t : t) file = FileHash.mem t.deps file +let file_exists (t : t) file = File_hash.mem t.deps file -let files_count (t : t) = FileSet.cardinal t.files +let files_count (t : t) = File_set.cardinal t.files -let deps_count (t : t) = FileHash.length t.deps +let deps_count (t : t) = File_hash.length t.deps (** {2 Topological ordering} *) @@ -99,21 +99,21 @@ let iter_files_from_roots_to_leaves (t : t) iter_fun = 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, FileSet.t) Hashtbl.t) + (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 -> FileSet.empty + 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 = FileSet.remove file_name old_set_at_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 = FileSet.add file_name old_set_at_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 @@ -122,9 +122,9 @@ let iter_files_from_roots_to_leaves (t : t) iter_fun = 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 = FileSet.remove file_name old_set_at_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 = FileSet.add file_name old_set_at_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 @@ -138,20 +138,20 @@ let iter_files_from_roots_to_leaves (t : t) iter_fun = iter_deps t (fun from_file set -> if get_num from_file = 0 then Hashtbl.replace references_by_number 0 - (FileSet.add from_file (get_set 0)); - set |> FileSet.iter (fun to_file -> add_edge from_file to_file)); - while get_set 0 <> FileSet.empty do + (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 - |> FileSet.iter (fun file_name -> + |> File_set.iter (fun file_name -> iter_fun file_name; let references = get_deps t file_name in references - |> FileSet.iter (fun to_file -> remove_edge file_name to_file)) + |> 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 FileSet.is_empty set then () - else set |> FileSet.iter (fun file_name -> iter_fun file_name)) + 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 1536d66451..3e43a806e3 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 88% rename from analysis/reanalyze/src/Issue.ml rename to analysis/reanalyze/src/issue.ml index 1cf66aa29a..4aa9bb76a6 100644 --- a/analysis/reanalyze/src/Issue.ml +++ b/analysis/reanalyze/src/issue.ml @@ -2,14 +2,14 @@ These types represent the various issues that can be reported. *) -module ExnSet = Set.Make (Exn) +module Exn_set = Set.Make (Exn) type missing_throw_info = { exn_name: string; - exn_table: (Exn.t, LocSet.t) Hashtbl.t; + exn_table: (Exn.t, Loc_set.t) Hashtbl.t; loc_full: Location.t; - missing_annotations: ExnSet.t; - throw_set: ExnSet.t; + missing_annotations: Exn_set.t; + throw_set: Exn_set.t; } type severity = Warning | Error diff --git a/analysis/reanalyze/src/Issues.ml b/analysis/reanalyze/src/issues.ml similarity index 100% rename from analysis/reanalyze/src/Issues.ml rename to analysis/reanalyze/src/issues.ml diff --git a/analysis/reanalyze/src/Liveness.ml b/analysis/reanalyze/src/liveness.ml similarity index 73% rename from analysis/reanalyze/src/Liveness.ml rename to analysis/reanalyze/src/liveness.ml index 196860a911..c40f4b3426 100644 --- a/analysis/reanalyze/src/Liveness.ml +++ b/analysis/reanalyze/src/liveness.ml @@ -32,50 +32,50 @@ let pos_in_decl (pos : Lexing.position) (decl : Decl.t) : bool = (** 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 pos_from = - DeclarationStore.find_opt decl_store pos_from <> None + Declaration_store.find_opt decl_store pos_from <> None in (* Check value refs *) References.iter_value_refs_from refs (fun pos_from pos_to_set -> if not (is_decl_pos pos_from) then - PosSet.iter - (fun pos_to -> PosHash.replace externally_referenced pos_to true) + 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 pos_from pos_to_set -> if not (is_decl_pos pos_from) then - PosSet.iter - (fun pos_to -> PosHash.replace externally_referenced pos_to true) + 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,15 +87,15 @@ 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 *) @@ -120,11 +120,11 @@ let build_decl_refs_index ~(decl_store : DeclarationStore.t) (** 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.decl_kind |> Decl.Kind.to_string) - (decl.path |> DcePath.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.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.to_string) - (target_decl.path |> DcePath.to_string) + (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 + 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.to_string) - (target_decl.path |> DcePath.to_string) + (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 09a4819b69..c2a3c2b3e7 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 96% rename from analysis/reanalyze/src/Log_.ml rename to analysis/reanalyze/src/log_.ml index df7112505a..f365b1f1c6 100644 --- a/analysis/reanalyze/src/Log_.ml +++ b/analysis/reanalyze/src/log_.ml @@ -100,8 +100,8 @@ let missing_raise_info_to_text {Issue.missing_annotations; loc_full} = Format.asprintf "%a" (Exceptions.pp ~exn_table:None) missing_annotations in if !Cli.json then - EmitJson.emit_annotate ~action:"Add @throws annotation" - ~pos:(EmitJson.loc_to_pos loc_full) + 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 "" @@ -163,7 +163,7 @@ let description_to_name (description : Issue.description) = 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 start_line = loc.loc_start.pos_lnum - 1 in let start_character = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in @@ -172,7 +172,7 @@ let log_issue ~config ~(issue : Issue.t) = let message = description_to_message issue.description in Format.asprintf "%a%s%s" (fun ppf () -> - EmitJson.emit_item ~ppf ~name:issue.name + Emit_json.emit_item ~ppf ~name:issue.name ~kind: (match issue.severity with | Warning -> "warning" @@ -182,7 +182,7 @@ let log_issue ~config ~(issue : Issue.t) = ~message) () (log_additional_info ~description:issue.description) - (if config.DceConfig.cli.json then EmitJson.emit_close () else "") + (if config.Dce_config.cli.json then Emit_json.emit_close () else "") else let color = match issue.severity with @@ -224,7 +224,7 @@ module Stats = struct !issues |> List.rev |> List.iter (fun issue -> log_issue ~config ~issue |> print_string); let sorted_issues, n_issues = get_sorted_issues () in - if not config.DceConfig.cli.json then ( + 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 diff --git a/analysis/reanalyze/src/ModulePath.ml b/analysis/reanalyze/src/module_path.ml similarity index 64% rename from analysis/reanalyze/src/ModulePath.ml rename to analysis/reanalyze/src/module_path.ml index 6d41467bf0..451873db38 100644 --- a/analysis/reanalyze/src/ModulePath.ml +++ b/analysis/reanalyze/src/module_path.ml @@ -1,21 +1,21 @@ -module NameMap = Map.Make (Name) +module Name_map = 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} +type t = {aliases: Dce_path.t Name_map.t; loc: Location.t; path: Dce_path.t} -let initial = ({aliases = NameMap.empty; loc = Location.none; 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 |> NameMap.find_opt name with + 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 |> DcePath.to_string) - (new_path |> DcePath.to_string); + (path |> Dce_path.to_string) + (new_path |> Dce_path.to_string); new_path) | _ -> path @@ -24,8 +24,8 @@ let add_alias (t : t) ~name ~path : t = let path_normalized = path |> normalize_path ~aliases in if !Cli.debug then Log_.item "Module Alias: %s = %s@." (name |> Name.to_string) - (DcePath.to_string path_normalized); - {t with aliases = NameMap.add name path_normalized aliases} + (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 diff --git a/analysis/reanalyze/src/Name.ml b/analysis/reanalyze/src/name.ml similarity index 100% rename from analysis/reanalyze/src/Name.ml rename to analysis/reanalyze/src/name.ml diff --git a/analysis/reanalyze/src/Name.mli b/analysis/reanalyze/src/name.mli similarity index 100% rename from analysis/reanalyze/src/Name.mli rename to analysis/reanalyze/src/name.mli diff --git a/analysis/reanalyze/src/optional_args.ml b/analysis/reanalyze/src/optional_args.ml new file mode 100644 index 0000000000..6974f1580e --- /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 0000000000..3a53ab3de3 --- /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 93% rename from analysis/reanalyze/src/Paths.ml rename to analysis/reanalyze/src/paths.ml index 1a826d4820..cff4937ddd 100644 --- a/analysis/reanalyze/src/Paths.ml +++ b/analysis/reanalyze/src/paths.ml @@ -26,7 +26,7 @@ let rec find_project_root ~dir = assert false) else find_project_root ~dir:parent -let run_config = RunConfig.run_config +let run_config = Run_config.run_config let set_project_root_from_cwd () = run_config.project_root <- find_project_root ~dir:(Sys.getcwd ()); @@ -70,18 +70,18 @@ module Config = struct 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 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 *) @@ -100,7 +100,7 @@ module Config = struct read_transitive conf | None -> (* if no "analysis" specified, default to dce *) - RunConfig.dce ()) + Run_config.dce ()) | _ -> () in diff --git a/analysis/reanalyze/src/Pos.ml b/analysis/reanalyze/src/pos.ml similarity index 100% rename from analysis/reanalyze/src/Pos.ml rename to analysis/reanalyze/src/pos.ml 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 79% rename from analysis/reanalyze/src/ReactiveAnalysis.ml rename to analysis/reanalyze/src/reactive_analysis.ml index 55ea80050d..be53574228 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 = { @@ -30,7 +31,7 @@ type processing_stats = { let process_cmt_infos ~config ~cmt_file_path cmt_infos : cmt_file_result option = let exclude_path source_file = - config.DceConfig.cli.exclude_paths + config.Dce_config.cli.exclude_paths |> List.exists (fun prefix_ -> let prefix = match Filename.is_relative source_file with @@ -42,7 +43,7 @@ let process_cmt_infos ~config ~cmt_file_path cmt_infos : cmt_file_result option 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 + 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 @@ -50,34 +51,34 @@ let process_cmt_infos ~config ~cmt_file_path cmt_infos : cmt_file_result option | _ -> Filename.check_suffix source_file "i" in let module_name = source_file |> Paths.get_module_name in - let dce_file_context : DceFileProcessing.file_context = + 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. + 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 + |> 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 + if config.Dce_config.run.exception_ then cmt_infos |> Exception.process_cmt ~file:file_context else None in - if config.DceConfig.run.termination then + 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 ~cmt_file_path:path cmt_infos) @@ -91,13 +92,13 @@ let process_files ~(collection : t) ~config:_ cmt_file_paths : let total_files = List.length cmt_file_paths in let cached_before = cmt_file_paths - |> List.filter (fun p -> ReactiveFileCollection.mem collection p) + |> 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 cmt_file_paths + 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 @@ -111,7 +112,7 @@ let process_files ~(collection : t) ~config:_ cmt_file_paths : 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} -> ( @@ -131,14 +132,14 @@ let process_files ~(collection : t) ~config:_ cmt_file_paths : 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 = + (string, Dce_file_processing.file_data option) Reactive.t = Reactive.flat_map ~name:"file_data_collection" - (ReactiveFileCollection.to_collection collection) + (Reactive_file_collection.to_collection collection) ~f:(fun path result_opt -> match result_opt with | Some {dce_data = Some data; _} -> [(path, Some data)] @@ -146,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 @@ -158,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 81% rename from analysis/reanalyze/src/ReactiveDeclRefs.ml rename to analysis/reanalyze/src/reactive_decl_refs.ml index 6797b8ed4e..dfa3e212a8 100644 --- a/analysis/reanalyze/src/ReactiveDeclRefs.ml +++ b/analysis/reanalyze/src/reactive_decl_refs.ml @@ -9,9 +9,9 @@ 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.flat_map ~name:"decl_refs.decls_by_file" decls @@ -27,7 +27,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) 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 pos_from _targets -> pos_from.Lexing.pos_fname) @@ -39,10 +39,10 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) |> List.filter_map (fun (decl_pos, decl) -> 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 pos_from _targets -> pos_from.Lexing.pos_fname) ~f:(fun pos_from targets decls_opt -> @@ -53,24 +53,24 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) |> List.filter_map (fun (decl_pos, decl) -> 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 e11f6510b6..e2aa750c8b 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 80% rename from analysis/reanalyze/src/ReactiveExceptionRefs.ml rename to analysis/reanalyze/src/reactive_exception_refs.ml index 7dd1822da2..bafd2673f0 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,7 +23,7 @@ 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.flat_map ~name:"exc_refs.exception_decls" decls @@ -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.flat_map ~name:"exc_refs.resolved_refs_from" resolved_refs ~f:(fun pos_to pos_from_set -> - PosSet.elements pos_from_set - |> List.map (fun pos_from -> (pos_from, PosSet.singleton pos_to))) - ~merge:PosSet.union () + 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} @@ -75,20 +75,20 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let add_to_refs_builder (t : t) ~(refs : References.builder) : unit = Reactive.iter (fun pos_to pos_from_set -> - PosSet.iter + 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 pos_to pos_from_set -> - PosSet.iter + 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) + 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 8f918d7cfe..c418057c59 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 86% rename from analysis/reanalyze/src/ReactiveLiveness.ml rename to analysis/reanalyze/src/reactive_liveness.ml index 6433faa4cd..0adb775737 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.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 @@ -64,7 +64,7 @@ let create ~(merged : ReactiveMerge.t) : t = [] | None -> (* posFrom is NOT a decl position, targets are externally referenced *) - PosSet.elements targets |> List.map (fun pos_to -> (pos_to, ()))) + Pos_set.elements targets |> List.map (fun pos_to -> (pos_to, ()))) ~merge:(fun () () -> ()) () in @@ -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 pos_to -> (pos_to, ()))) + 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 e0b5fcf53a..69524af420 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 67% rename from analysis/reanalyze/src/ReactiveMerge.ml rename to analysis/reanalyze/src/reactive_merge.ml index 9f309d6eee..6c376e0efa 100644 --- a/analysis/reanalyze/src/ReactiveMerge.ml +++ b/analysis/reanalyze/src/reactive_merge.ml @@ -7,22 +7,22 @@ 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.flat_map ~name:"decls" source @@ -30,7 +30,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : 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 @@ -41,8 +41,8 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : 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 @@ -54,8 +54,8 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : | 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 *) @@ -66,8 +66,8 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : | 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 *) @@ -78,11 +78,12 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : | 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; @@ -98,8 +99,8 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : 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 *) @@ -111,9 +112,9 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : | 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 @@ -121,22 +122,22 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : let exception_refs_collection = 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.report_types_dead_only_in_interface + 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,36 +157,36 @@ 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 pos_from pos_to = let existing = - match PosHash.find_opt tbl pos_from with + match Pos_hash.find_opt tbl pos_from with | Some s -> s - | None -> PosSet.empty + | None -> Pos_set.empty in - PosHash.replace tbl pos_from (PosSet.add pos_to existing) + Pos_hash.replace tbl pos_from (Pos_set.add pos_to existing) in (* Merge per-file value refs_from *) Reactive.iter (fun pos_from pos_to_set -> - PosSet.iter + Pos_set.iter (fun pos_to -> add_to_from value_refs_from pos_from pos_to) pos_to_set) t.value_refs_from; @@ -193,7 +194,7 @@ let freeze_refs (t : t) : References.t = (* Merge per-file type refs_from *) Reactive.iter (fun pos_from pos_to_set -> - PosSet.iter + Pos_set.iter (fun pos_to -> add_to_from type_refs_from pos_from pos_to) pos_to_set) t.type_refs_from; @@ -202,7 +203,7 @@ let freeze_refs (t : t) : References.t = let add_type_refs_from reactive = Reactive.iter (fun pos_from pos_to_set -> - PosSet.iter + Pos_set.iter (fun pos_to -> add_to_from type_refs_from pos_from pos_to) pos_to_set) reactive @@ -212,7 +213,7 @@ let freeze_refs (t : t) : References.t = (* Add exception refs (to value refs_from) *) Reactive.iter (fun pos_from pos_to_set -> - PosSet.iter + 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; @@ -220,51 +221,51 @@ let freeze_refs (t : t) : References.t = 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 pos_from pos_to_set -> - PosSet.iter + 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)) + 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 181c37a695..d170b39840 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 91% rename from analysis/reanalyze/src/ReactiveSolver.ml rename to analysis/reanalyze/src/reactive_solver.ml index dd303f1c37..e0b7456b55 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,19 +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.to_module_name ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + |> 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 @@ -78,7 +78,7 @@ 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.flat_map ~name:"solver.dead_modules_empty" dead_decls ~f:(fun _ _ -> []) @@ -120,7 +120,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) () 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, @@ -132,9 +132,9 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* shouldReport checks annotations reactively *) 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 *) @@ -150,16 +150,16 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) | 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.compare_for_reporting in - let reporting_ctx = DeadCommon.ReportingContext.create () in + let reporting_ctx = Dead_common.Reporting_context.create () in let file_issues = sorted |> List.concat_map (fun decl -> - DeadCommon.report_declaration ~config ~has_ref_below + Dead_common.report_declaration ~config ~has_ref_below ~check_module_dead ~should_report reporting_ctx decl) in let modules_list = @@ -194,7 +194,7 @@ 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 @@ -230,7 +230,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) in [ ( module_name, - AnalysisResult.make_dead_module_issue ~loc ~module_name ); + Analysis_result.make_dead_module_issue ~loc ~module_name ); ] | None -> []) () @@ -271,14 +271,14 @@ let check_module_dead ~(dead_modules : (Name.t, Location.t * string) Reactive.t) {Location.loc_start = pos; loc_end = pos; loc_ghost = false} else loc in - Some (AnalysisResult.make_dead_module_issue ~loc ~module_name) + 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 @@ -290,7 +290,7 @@ let collect_issues ~(t : t) ~(config : DceConfig.t) Reactive.iter (fun _pos (decl : Decl.t) -> let issue = - DeadCommon.make_dead_issue ~decl + Dead_common.make_dead_issue ~decl ~message:" is annotated @dead but is live" Issue.IncorrectDeadAnnotation in 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 0c5e5e1d0f..7666b29fc1 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 83% rename from analysis/reanalyze/src/ReactiveTypeDeps.ml rename to analysis/reanalyze/src/reactive_type_deps.ml index fdb538a67f..233f37e67b 100644 --- a/analysis/reanalyze/src/ReactiveTypeDeps.ml +++ b/analysis/reanalyze/src/reactive_type_deps.ml @@ -12,7 +12,7 @@ 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 *) @@ -33,15 +33,15 @@ let decl_to_info (decl : Decl.t) : decl_info option = (** {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 *) @@ -71,12 +71,12 @@ 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 *) @@ -90,8 +90,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) | [] -> [] | type_label_name :: path_to_type -> (* Try two intf paths *) - let path_1 = path_to_type |> DcePath.module_to_interface in - let path_2 = path_1 |> DcePath.type_to_interface 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))]) @@ -109,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 *) @@ -137,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. @@ -158,7 +158,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) | [] -> [] | type_label_name :: path_to_type -> let impl_path = - type_label_name :: DcePath.module_to_implementation path_to_type + type_label_name :: Dce_path.module_to_implementation path_to_type in [(info.pos, (info, impl_path))]) | _ -> []) @@ -185,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: @@ -209,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.flat_map ~name:"type_deps.all_type_refs_from" combined_refs_to ~f:(fun pos_to pos_from_set -> - PosSet.elements pos_from_set - |> List.map (fun pos_from -> (pos_from, PosSet.singleton pos_to))) - ~merge:PosSet.union () + Pos_set.elements pos_from_set + |> List.map (fun pos_from -> (pos_from, Pos_set.singleton pos_to))) + ~merge:Pos_set.union () in { @@ -242,7 +242,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let add_to_refs_builder (t : t) ~(refs : References.builder) : unit = Reactive.iter (fun pos_to pos_from_set -> - PosSet.iter + 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 ac6c9ff2aa..c563ec1971 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 82% rename from analysis/reanalyze/src/Reanalyze.ml rename to analysis/reanalyze/src/reanalyze.ml index 2fde62c28e..fb6ac5cade 100644 --- a/analysis/reanalyze/src/Reanalyze.ml +++ b/analysis/reanalyze/src/reanalyze.ml @@ -1,7 +1,7 @@ -let run_config = RunConfig.run_config +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 *) @@ -11,7 +11,7 @@ type cmt_file_result = { 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.DceConfig.cli.exclude_paths + config.Dce_config.cli.exclude_paths |> List.exists (fun prefix_ -> let prefix = match Filename.is_relative source_file with @@ -23,7 +23,7 @@ let load_cmt_file ~config cmt_file_path : cmt_file_result option = try String.sub source_file 0 (String.length prefix) = prefix with Invalid_argument _ -> false) in - match cmt_infos.cmt_annots |> FindSourceFile.cmt with + 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 @@ -32,12 +32,12 @@ let load_cmt_file ~config cmt_file_path : cmt_file_result option = 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 = + 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. + Dead_common.File_context. {source_path = source_file; module_name; is_interface = is_interface_} in if config.cli.debug then @@ -50,26 +50,26 @@ let load_cmt_file ~config cmt_file_path : cmt_file_result option = | 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 + |> 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 + if config.Dce_config.run.exception_ then cmt_infos |> Exception.process_cmt ~file:file_context else None in - if config.DceConfig.run.termination then + 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 *) @@ -158,7 +158,7 @@ let process_files_sequential ~config (cmt_file_paths : string list) : Conceptually: map process_cmt_file over all files. If file_stats is provided, it will be updated with processing statistics. *) let process_cmt_files ~config ~cmt_root ~reactive_collection ~skip_file - ?(file_stats : ReactiveAnalysis.processing_stats option) () : + ?(file_stats : Reactive_analysis.processing_stats option) () : all_files_result = let cmt_file_paths = let all = collect_cmt_file_paths ~cmt_root in @@ -170,7 +170,7 @@ let process_cmt_files ~config ~cmt_root ~reactive_collection ~skip_file match reactive_collection with | Some collection -> let result, stats = - ReactiveAnalysis.process_files ~collection ~config cmt_file_paths + Reactive_analysis.process_files ~collection ~config cmt_file_paths in (match file_stats with | Some fs -> @@ -206,21 +206,21 @@ let run_analysis ~dce_config ~cmt_root ~reactive_collection ~reactive_merge (* 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.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 () -> @@ -229,28 +229,28 @@ let run_analysis ~dce_config ~cmt_root ~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!). @@ -259,7 +259,7 @@ let run_analysis ~dce_config ~cmt_root ~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 @@ -269,50 +269,50 @@ let run_analysis ~dce_config ~cmt_root ~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 @@ -323,7 +323,7 @@ let run_analysis ~dce_config ~cmt_root ~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 @@ -333,25 +333,25 @@ let run_analysis ~dce_config ~cmt_root ~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); @@ -360,7 +360,7 @@ let run_analysis ~dce_config ~cmt_root ~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, \ @@ -369,19 +369,19 @@ let run_analysis ~dce_config ~cmt_root ~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.solve_dead ~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 ~check_optional_arg:(fun @@ -389,22 +389,23 @@ let run_analysis ~dce_config ~cmt_root ~reactive_collection ~reactive_merge in (* Compute liveness-aware optional args state *) let is_live pos = - match DeclarationStore.find_opt decl_store pos with + 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.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 @@ -413,7 +414,7 @@ let run_analysis ~dce_config ~cmt_root ~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 @@ -421,13 +422,14 @@ let run_analysis ~dce_config ~cmt_root ~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 + if dce_config.Dce_config.run.exception_ then Exception.run_checks ~config:dce_config exception_results; - if dce_config.DceConfig.run.termination && dce_config.DceConfig.cli.debug + if + dce_config.Dce_config.run.termination && dce_config.Dce_config.cli.debug then Arnold.report_stats ~config:dce_config) let run_analysis_and_report ~cmt_root = @@ -436,12 +438,12 @@ let run_analysis_and_report ~cmt_root = (* 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 + 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. @@ -450,16 +452,16 @@ let run_analysis_and_report ~cmt_root = 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: @@ -470,13 +472,13 @@ let run_analysis_and_report ~cmt_root = | 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 @@ -514,10 +516,10 @@ let run_analysis_and_report ~cmt_root = 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 @@ -527,10 +529,10 @@ let run_analysis_and_report ~cmt_root = 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 *) @@ -542,10 +544,10 @@ let run_analysis_and_report ~cmt_root = 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 @@ -554,10 +556,10 @@ let run_analysis_and_report ~cmt_root = 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 *) @@ -615,7 +617,7 @@ let run_analysis_and_report ~cmt_root = 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 analysis_kind_set = ref false in @@ -629,22 +631,22 @@ let parse_argv (argv : string array) : string option = [@@raises exit] in let rec set_all cmt_root = - RunConfig.all (); + 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 = - RunConfig.dce (); + Run_config.dce (); cmt_root_ref := cmt_root; analysis_kind_set := true and set_exception cmt_root = - RunConfig.exception_ (); + Run_config.exception_ (); cmt_root_ref := cmt_root; analysis_kind_set := true and set_termination cmt_root = - RunConfig.termination (); + Run_config.termination (); cmt_root_ref := cmt_root; analysis_kind_set := true and speclist = @@ -688,7 +690,7 @@ let parse_argv (argv : string array) : string option = Set Cli.experimental, "Turn on experimental analyses (this option is currently unused)" ); ( "-externals", - Set DeadCommon.Config.analyze_externals, + Set Dead_common.Config.analyze_externals, "Report on externals in dead code analysis" ); ("-json", Set Cli.json, "Print reports in json format"); ( "-live-names", @@ -755,7 +757,7 @@ let parse_argv (argv : string array) : string option = if !analysis_kind_set = false then set_config (); (match !transitive_override with | None -> () - | Some b -> RunConfig.transitive b); + | Some b -> Run_config.transitive b); !cmt_root_ref (** Default socket location invariant: @@ -772,8 +774,8 @@ let cli () = (* 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_ diff --git a/analysis/reanalyze/src/ReanalyzeServer.ml b/analysis/reanalyze/src/reanalyze_server.ml similarity index 85% rename from analysis/reanalyze/src/ReanalyzeServer.ml rename to analysis/reanalyze/src/reanalyze_server.ml index 66cd16789a..5e17554ca6 100644 --- a/analysis/reanalyze/src/ReanalyzeServer.ml +++ b/analysis/reanalyze/src/reanalyze_server.ml @@ -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 -> + dce_config:Dce_config.t -> cmt_root:string option -> - reactive_collection:ReactiveAnalysis.t option -> - reactive_merge:ReactiveMerge.t option -> - reactive_liveness:ReactiveLiveness.t option -> - reactive_solver:ReactiveSolver.t 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; 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,14 +294,14 @@ Examples: let init_state ~(parse_argv : string array -> string option) ~(run_analysis : - dce_config:DceConfig.t -> + dce_config:Dce_config.t -> cmt_root:string option -> - reactive_collection:ReactiveAnalysis.t option -> - reactive_merge:ReactiveMerge.t option -> - reactive_liveness:ReactiveLiveness.t option -> - reactive_solver:ReactiveSolver.t 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; @@ -331,7 +331,7 @@ Examples: 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 (); + Run_config.reset (); Paths.Config.process_config (); - let new_snapshot = RunConfig.snapshot () in + 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,7 +375,7 @@ 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 ~cmt_root:state.cmt_root @@ -385,12 +385,12 @@ Examples: ~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 @@ -453,14 +453,14 @@ Examples: let cli ~(parse_argv : string array -> string option) ~(run_analysis : - dce_config:DceConfig.t -> + dce_config:Dce_config.t -> cmt_root:string option -> - reactive_collection:ReactiveAnalysis.t option -> - reactive_merge:ReactiveMerge.t option -> - reactive_liveness:ReactiveLiveness.t option -> - reactive_solver:ReactiveSolver.t 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 @@ -479,14 +479,14 @@ end let server_cli ~(parse_argv : string array -> string option) ~(run_analysis : - dce_config:DceConfig.t -> + dce_config:Dce_config.t -> cmt_root:string option -> - reactive_collection:ReactiveAnalysis.t option -> - reactive_merge:ReactiveMerge.t option -> - reactive_liveness:ReactiveLiveness.t option -> - reactive_solver:ReactiveSolver.t 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 86b6d4afff..f8a185c8bd 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 cfc266fad3..c102e6fc6f 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 71% rename from analysis/reanalyze/src/References.ml rename to analysis/reanalyze/src/references.ml index 1d9dd90ae5..8b917dce9e 100644 --- a/analysis/reanalyze/src/References.ml +++ b/analysis/reanalyze/src/references.ml @@ -11,11 +11,11 @@ (* Helper to add to a set in a hashtable *) let add_set 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 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,7 +24,7 @@ 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) ~pos_to ~pos_from = add_set builder.value_refs_from pos_from pos_to @@ -33,14 +33,15 @@ 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 to_pos -> add_set into.value_refs_from pos to_pos)) + |> 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 to_pos -> add_set into.type_refs_from pos to_pos)) + 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 = @@ -62,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 [] @@ -78,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 86% rename from analysis/reanalyze/src/References.mli rename to analysis/reanalyze/src/references.mli index b71aa0635f..d4b9ef9b76 100644 --- a/analysis/reanalyze/src/References.mli +++ b/analysis/reanalyze/src/references.mli @@ -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/RunConfig.ml b/analysis/reanalyze/src/run_config.ml similarity index 100% rename from analysis/reanalyze/src/RunConfig.ml rename to analysis/reanalyze/src/run_config.ml diff --git a/analysis/reanalyze/src/SideEffects.ml b/analysis/reanalyze/src/side_effects.ml similarity index 98% rename from analysis/reanalyze/src/SideEffects.ml rename to analysis/reanalyze/src/side_effects.ml index 0d1a9c5d54..421efa0773 100644 --- a/analysis/reanalyze/src/SideEffects.ml +++ b/analysis/reanalyze/src/side_effects.ml @@ -18,7 +18,7 @@ let white_table_side_effects = let path_is_whitelisted_for_side_effects path = path - |> DcePath.on_ok_path ~when_contains_apply:false ~f:(fun s -> + |> 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) = 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 98% rename from analysis/reanalyze/src/Suppress.ml rename to analysis/reanalyze/src/suppress.ml index 19f65eea55..d9a8c16168 100644 --- a/analysis/reanalyze/src/Suppress.ml +++ b/analysis/reanalyze/src/suppress.ml @@ -1,4 +1,4 @@ -let run_config = RunConfig.run_config +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 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/src/BuildSystem.ml b/analysis/src/build_system.ml similarity index 95% rename from analysis/src/BuildSystem.ml rename to analysis/src/build_system.ml index fe640f2cb8..50c0d2a7d6 100644 --- a/analysis/src/BuildSystem.ml +++ b/analysis/src/build_system.ml @@ -21,7 +21,7 @@ let get_runtime_dir root_path = Some env_path | None -> ( let result = - ModuleResolution.resolve_node_module_path ~start_path:root_path + Module_resolution.resolve_node_module_path ~start_path:root_path "@rescript/runtime" in match result with diff --git a/analysis/src/Cache.ml b/analysis/src/cache.ml similarity index 88% rename from analysis/src/Cache.ml rename to analysis/src/cache.ml index f2c704a156..a70f46c502 100644 --- a/analysis/src/Cache.ml +++ b/analysis/src/cache.ml @@ -1,8 +1,8 @@ -open SharedTypes +open Shared_types type cached = { - project_files: FileSet.t; - dependencies_files: FileSet.t; + project_files: File_set.t; + dependencies_files: File_set.t; paths_for_module: (file, paths) Hashtbl.t; } @@ -34,7 +34,7 @@ let cache_project (package : package) = paths_for_module = package.paths_for_module; } in - match BuildSystem.get_lib_bs package.root_path with + 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 diff --git a/analysis/src/Cfg.ml b/analysis/src/cfg.ml similarity index 100% rename from analysis/src/Cfg.ml rename to analysis/src/cfg.ml diff --git a/analysis/src/Cli.ml b/analysis/src/cli.ml similarity index 96% rename from analysis/src/Cli.ml rename to analysis/src/cli.ml index 2e4e9bc7fd..4277934fc7 100644 --- a/analysis/src/Cli.ml +++ b/analysis/src/cli.ml @@ -64,7 +64,7 @@ let signature_help ~path ~pos ~current_file ~debug | None -> print_null () | Some source -> ( match - SignatureHelp.signature_help ~source ~kind_file ~pos + Signature_help.signature_help ~source ~kind_file ~pos ~allow_for_constructor_payloads ~full ~debug with | None -> print_null () @@ -156,7 +156,7 @@ let semantic_tokens ~path = | None -> print_null () | Some source -> let kind_file = Files.classify_source_file path in - let tokens = SemanticTokens.semantic_tokens ~source ~kind_file in + let tokens = Semantic_tokens.semantic_tokens ~source ~kind_file in Lsp.Types.SemanticTokens.yojson_of_t tokens |> print_string let test ~path = @@ -239,20 +239,20 @@ let test ~path = completion_resolve ~path ~module_path | "dce" -> print_endline ("DCE " ^ path); - Reanalyze.RunConfig.run_config.suppress <- ["src"]; - Reanalyze.RunConfig.run_config.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.read_file path |> Option.get in let kind_file = Files.classify_source_file path in - SemanticTokens.command ~debug:true - ~emitter:(SemanticTokens.Token.create_emitter ()) + Semantic_tokens.command ~debug:true + ~emitter:(Semantic_tokens.Token.create_emitter ()) ~source ~kind_file | "hov" -> print_endline @@ -279,7 +279,7 @@ let test ~path = let dir = dirname path in dir ++ parent_dir_name ++ "lib" ++ "bs" ++ "src" ++ name in - Printf.printf "%s" (CreateInterface.command ~path ~cmi_file) + Printf.printf "%s" (Create_interface.command ~path ~cmi_file) | "ref" -> print_endline ("References " ^ path ^ " " ^ string_of_int line ^ ":" @@ -412,7 +412,7 @@ let test ~path = ("Dump AST " ^ path ^ " " ^ string_of_int line ^ ":" ^ string_of_int col); let current_file = create_current_file () in - DumpAst.dump ~pos:(line, col) ~current_file; + Dump_ast.dump ~pos:(line, col) ~current_file; Sys.remove current_file | "sem" -> semantic_tokens ~path | _ -> ()); diff --git a/analysis/src/Cmt.ml b/analysis/src/cmt.ml similarity index 86% rename from analysis/src/Cmt.ml rename to analysis/src/cmt.ml index 013c6fa3e0..7c0f8343f9 100644 --- a/analysis/src/Cmt.ml +++ b/analysis/src/cmt.ml @@ -1,11 +1,11 @@ -open SharedTypes +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 = ProcessCmt.file_for_cmt_infos ~module_name ~uri infos in - let extra = ProcessExtra.get_extra ~file ~infos in + 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 = @@ -14,7 +14,7 @@ let full_from_uri ~uri = | None -> None | Some package -> ( let module_name = - BuildSystem.namespaced_name package.namespace (FindFiles.get_name path) + Build_system.namespaced_name package.namespace (Find_files.get_name path) in let incremental = if !Cfg.in_incremental_typechecking_mode then @@ -58,7 +58,7 @@ let load_cmt_infos_from_path ~path = | None -> None | Some package -> ( let module_name = - BuildSystem.namespaced_name package.namespace (FindFiles.get_name path) + 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 -> diff --git a/analysis/src/CmtViewer.ml b/analysis/src/cmt_viewer.ml similarity index 95% rename from analysis/src/CmtViewer.ml rename to analysis/src/cmt_viewer.ml index 3f32d395fd..39bf9f544f 100644 --- a/analysis/src/CmtViewer.ml +++ b/analysis/src/cmt_viewer.ml @@ -23,13 +23,14 @@ let dump ?filter rescript_json cmt_path = Packages.get_package ~uri |> Option.get in let module_name = - BuildSystem.namespaced_name package.namespace (FindFiles.get_name cmt_path) + Build_system.namespaced_name package.namespace + (Find_files.get_name cmt_path) in 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 open Shared_types in + let open Shared_types.Stamps in let apply_filter = match filter with | None -> fun _ -> true @@ -125,5 +126,5 @@ let dump ?filter rescript_json cmt_path = | c -> c) |> List.iter (fun {loc; loc_type} -> let loc_str = Warnings.loc_to_string loc in - let kind_str = SharedTypes.loc_type_to_string loc_type 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/CodeActions.ml b/analysis/src/code_actions.ml similarity index 100% rename from analysis/src/CodeActions.ml rename to analysis/src/code_actions.ml diff --git a/analysis/src/Codemod.ml b/analysis/src/codemod.ml similarity index 95% rename from analysis/src/Codemod.ml rename to analysis/src/codemod.ml index ab9712eb49..9b0812dd9a 100644 --- a/analysis/src/Codemod.ml +++ b/analysis/src/codemod.ml @@ -19,7 +19,7 @@ let transform ~source ~pos ~debug ~typ ~hint = let cases = collect_patterns pattern |> List.map (fun (p : Parsetree.pattern) -> - Ast_helper.Exp.case p (TypeUtils.Codegen.mk_fail_with_exp ())) + Ast_helper.Exp.case p (Type_utils.Codegen.mk_fail_with_exp ())) in let result = ref None in let mk_iterator ~pos ~result = diff --git a/analysis/src/Commands.ml b/analysis/src/commands.ml similarity index 94% rename from analysis/src/Commands.ml rename to analysis/src/commands.ml index 92acdcfb81..be6c0a83c4 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/commands.ml @@ -5,9 +5,9 @@ let completion ~debug ~source ~kind_file ~pos ~full = with | None -> [] | Some (completions, full, _) -> - completions |> List.map (CompletionBackEnd.completion_to_item ~full) + completions |> List.map (Completion_back_end.completion_to_item ~full) -let completion_resolve ~(full : SharedTypes.full option) ~module_path = +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 @@ -25,7 +25,7 @@ let completion_resolve ~(full : SharedTypes.full option) ~module_path = Printf.printf "[completion_resolve] Could not load cmt\n"; None | Some full -> ( - match ProcessCmt.file_for_module ~package:full.package module_name with + 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" @@ -92,7 +92,7 @@ let hover ~source ~kind_file ~pos ~supports_markdown_links ~full ~debug = let signature_help ~source ~kind_file ~pos ~allow_for_constructor_payloads ~full ~debug = - SignatureHelp.signature_help ~debug ~source ~kind_file ~pos + Signature_help.signature_help ~debug ~source ~kind_file ~pos ~allow_for_constructor_payloads ~full let definition ~full ~pos ~debug = @@ -219,7 +219,7 @@ let rename ~full ~pos ~new_name ~debug = ())) in let text_document_edits = - let module StringMap = Misc.StringMap in + 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)) @@ -230,13 +230,13 @@ let rename ~full ~pos ~new_name ~debug = (Lsp.Types.TextEdit.create ~newText:new_name ~range:(Utils.cmt_loc_to_range loc)) in - match StringMap.find_opt uri acc with - | None -> StringMap.add uri [text_edit] acc + match String_map.find_opt uri acc with + | None -> String_map.add uri [text_edit] acc | Some prev_edits -> - StringMap.add uri (text_edit :: prev_edits) acc) - StringMap.empty + String_map.add uri (text_edit :: prev_edits) acc) + String_map.empty in - StringMap.fold + String_map.fold (fun uri edits acc -> let text_document = Lsp.Types.OptionalVersionedTextDocumentIdentifier.create diff --git a/analysis/src/CompletionBackEnd.ml b/analysis/src/completion_back_end.ml similarity index 91% rename from analysis/src/CompletionBackEnd.ml rename to analysis/src/completion_back_end.ml index 75d5edebf3..6652470567 100644 --- a/analysis/src/CompletionBackEnd.ml +++ b/analysis/src/completion_back_end.ml @@ -1,4 +1,4 @@ -open SharedTypes +open Shared_types let show_constructor {Constructor.cname = {txt}; args; res} = txt @@ -37,26 +37,26 @@ let resolve_opens ~env opens ~package = match path with | [] | [_] -> previous | name :: path -> ( - match ProcessCmt.file_for_module ~package name with + match Process_cmt.file_for_module ~package name with | None -> Log.log ("Could not get module " ^ name); previous (* TODO: warn? *) | Some file -> ( match - ResolvePath.resolve_path ~env:(QueryEnv.from_file file) ~package - ~path + 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 ResolvePath.resolve_path ~env ~package ~path with + 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 ResolvePath.resolve_path ~env ~package ~path with + match Resolve_path.resolve_path ~env ~package ~path with | None -> Log.log "Not local"; loop previous @@ -89,23 +89,24 @@ let completion_for_exporteds iter_exported get_declared ~prefix ~exact ~env !res let completion_for_exported_modules ~env ~prefix ~exact ~names_used = - completion_for_exporteds (Exported.iter env.QueryEnv.exported Exported.Module) + 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.QueryEnv.exported Exported.Value) + 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.QueryEnv.exported Exported.Type) + 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 : QueryEnv.t) ~prefix ~exact +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 -> @@ -130,7 +131,7 @@ let completions_for_exported_constructors ~(env : QueryEnv.t) ~prefix ~exact | _ -> ()); !res -let completion_for_exported_fields ~(env : QueryEnv.t) ~prefix ~exact +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 -> @@ -156,7 +157,7 @@ let completion_for_exported_fields ~(env : QueryEnv.t) ~prefix ~exact let find_module_in_scope ~env ~module_name ~scope = let modules_table = Hashtbl.create 10 in - env.QueryEnv.file.stamps + env.Query_env.file.stamps |> Stamps.iter_modules (fun _ declared -> Hashtbl.replace modules_table (declared.name.txt, declared.extent_loc |> Loc.start) @@ -175,29 +176,29 @@ let find_module_in_scope ~env ~module_name ~scope = scope |> Scope.iter_modules_after_first_open process_module; !result -let rec module_item_to_structure_env ~(env : QueryEnv.t) ~package +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 ResolvePath.resolve_module_from_compiler_path ~env ~package p with + 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 : QueryEnv.t) ~package +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 (QueryEnv.enter_structure env s, s) + | Some (env, s) -> Some (Query_env.enter_structure env s, s) | None -> None -let completions_from_structure_items ~(env : QueryEnv.t) +let completions_from_structure_items ~(env : Query_env.t) (structure : Module.structure) = - StructureUtils.unique_items structure + Structure_utils.unique_items structure |> List.filter_map (fun (it : Module.item) -> match it.kind with | Module.Value typ -> @@ -215,7 +216,7 @@ let completions_from_structure_items ~(env : QueryEnv.t) (Completion.create ~env ~docstring:it.docstring ~kind:(Completion.Type t) it.name)) -let resolve_path_from_stamps ~(env : QueryEnv.t) ~package ~scope ~module_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 @@ -227,27 +228,27 @@ let resolve_path_from_stamps ~(env : QueryEnv.t) ~package ~scope ~module_name | [""] -> ( match module_item_to_structure_env ~env ~package declared.item with | Some (env, structure) -> - Some (QueryEnv.enter_structure env structure, "") + Some (Query_env.enter_structure env structure, "") | None -> None) | _ -> ( - match ResolvePath.find_in_module ~env declared.item path with + 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 ProcessCmt.file_for_module ~package module_name with + match Process_cmt.file_for_module ~package module_name with | None -> None | Some file -> - ResolvePath.resolve_path ~env:(QueryEnv.from_file 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 : QueryEnv.t) :: rest -> ( + | (env : Query_env.t) :: rest -> ( Log.log ("Looking for env in " ^ Uri.to_string env.file.uri); - match ResolvePath.resolve_path ~env ~package ~path:[module_name; ""] with + match Resolve_path.resolve_path ~env ~package ~path:[module_name; ""] with | Some (env, _) -> Some env | None -> loop rest) | [] -> None @@ -256,15 +257,15 @@ let resolve_module_with_opens ~opens ~package ~module_name = let resolve_file_module ~module_name ~package = Log.log ("Getting module " ^ module_name); - match ProcessCmt.file_for_module ~package module_name with + match Process_cmt.file_for_module ~package module_name with | None -> None | Some file -> Log.log "got it"; - let env = QueryEnv.from_file file in + let env = Query_env.from_file file in Some env -let get_env_with_opens ~scope ~(env : QueryEnv.t) ~package - ~(opens : QueryEnv.t list) ~module_name (path : string list) = +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 @@ -279,7 +280,7 @@ let get_env_with_opens ~scope ~(env : QueryEnv.t) ~package | Some env -> ( match path with | [""] -> Some (env, "") - | _ -> ResolvePath.resolve_path ~env ~package ~path)) + | _ -> Resolve_path.resolve_path ~env ~package ~path)) let rec expand_type_expr ~env ~package type_expr = match type_expr |> Shared.dig_constructor with @@ -342,7 +343,7 @@ let kind_to_documentation ~env ~full ~current_docstring name Markdown.code_block s; ] | ExtractedType (extracted_type, _) -> - [Markdown.code_block (TypeUtils.extracted_type_to_string extracted_type)] + [Markdown.code_block (Type_utils.extracted_type_to_string extracted_type)] in current_docstring @ docs_from_kind |> List.filter (fun s -> s <> "") @@ -378,7 +379,7 @@ let kind_to_detail name (kind : Completion.kind) = | Snippet s -> s | FollowContextPath _ -> "" | ExtractedType (extracted_type, _) -> - TypeUtils.extracted_type_to_string ~name_only:true 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 @@ -386,7 +387,7 @@ let kind_to_data file_path (kind : Completion.kind) = Some (`Assoc [("modulePath", `String f); ("filePath", `String file_path)]) | _ -> Some `Null -let find_all_completions ~(env : QueryEnv.t) ~prefix ~exact ~names_used +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 @@ -407,7 +408,7 @@ let find_all_completions ~(env : QueryEnv.t) ~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 : LocalTables.t) = + ~(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 -> @@ -438,7 +439,7 @@ let process_local_value name loc context_path scope ~prefix ~exact ~env :: local_tables.result_rev let process_local_constructor name loc ~prefix ~exact ~env - ~(local_tables : LocalTables.t) = + ~(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) @@ -465,7 +466,7 @@ let process_local_constructor name loc ~prefix ~exact ~env (Loc.to_string loc)) let process_local_type name loc ~prefix ~exact ~env - ~(local_tables : LocalTables.t) = + ~(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 -> @@ -485,7 +486,7 @@ let process_local_type name loc ~prefix ~exact ~env (Loc.to_string loc)) let process_local_module name loc ~prefix ~exact ~env - ~(local_tables : LocalTables.t) = + ~(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 -> @@ -507,8 +508,8 @@ let process_local_module name loc ~prefix ~exact ~env (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 : QueryEnv.t) - ~(local_tables : LocalTables.t) = +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 @@ -538,17 +539,18 @@ let get_items_from_opens ~opens ~local_tables ~prefix ~exact ~completion_context (fun results env -> let completions_from_this_open = find_all_completions ~env ~prefix ~exact - ~names_used:local_tables.LocalTables.names_used ~completion_context + ~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 : LocalTables.t) ~env ~prefix ~exact ~opens ~scope = - local_tables |> LocalTables.populate_values ~env; - local_tables |> LocalTables.populate_included_values ~env; - local_tables |> LocalTables.populate_constructors ~env; - local_tables |> LocalTables.populate_modules ~env; + ~(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 @@ -581,11 +583,11 @@ let find_local_completions_for_values_and_constructors List.rev_append local_tables.result_rev values_from_opens -let find_local_completions_for_values ~(local_tables : LocalTables.t) ~env +let find_local_completions_for_values ~(local_tables : Local_tables.t) ~env ~prefix ~exact ~opens ~scope = - local_tables |> LocalTables.populate_values ~env; - local_tables |> LocalTables.populate_included_values ~env; - local_tables |> LocalTables.populate_modules ~env; + 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); @@ -611,10 +613,10 @@ let find_local_completions_for_values ~(local_tables : LocalTables.t) ~env List.rev_append local_tables.result_rev values_from_opens -let find_local_completions_for_types ~(local_tables : LocalTables.t) ~env +let find_local_completions_for_types ~(local_tables : Local_tables.t) ~env ~prefix ~exact ~opens ~scope = - local_tables |> LocalTables.populate_types ~env; - local_tables |> LocalTables.populate_modules ~env; + 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); @@ -635,9 +637,9 @@ let find_local_completions_for_types ~(local_tables : LocalTables.t) ~env (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 : LocalTables.t) ~env +let find_local_completions_for_modules ~(local_tables : Local_tables.t) ~env ~prefix ~exact ~opens ~scope = - local_tables |> LocalTables.populate_modules ~env; + local_tables |> Local_tables.populate_modules ~env; scope |> Scope.iter_modules_before_first_open (process_local_module ~prefix ~exact ~env ~local_tables); @@ -652,13 +654,13 @@ let find_local_completions_for_modules ~(local_tables : LocalTables.t) ~env (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 : QueryEnv.t) ~prefix ~exact +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 = LocalTables.create () in + let local_tables = Local_tables.create () in match completion_context with | Value | ValueOrField -> find_local_completions_for_values_and_constructors ~local_tables ~env @@ -677,12 +679,12 @@ 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 = LocalTables.create () in + 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 |> FileSet.elements + all_files |> File_set.elements |> Utils.filter_map (fun name -> if Utils.check_name name ~prefix ~exact @@ -709,7 +711,7 @@ let get_completions_for_path ~debug ~opens ~full ~pos ~exact ~scope ~completion_context in let file_modules = - all_files |> FileSet.elements + all_files |> File_set.elements |> Utils.filter_map (fun name -> if Utils.check_name name ~prefix ~exact @@ -772,12 +774,12 @@ let get_completions_for_path ~debug ~opens ~full ~pos ~exact ~scope 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 = - TypeUtils.remove_current_module_if_needed ~env_completion_is_made_from + Type_utils.remove_current_module_if_needed ~env_completion_is_made_from completion_path in let completion_path_minus_opens = - TypeUtils.remove_opens_from_completion_path ~raw_opens ~package:full.package - completion_path_without_current_module + Type_utils.remove_opens_from_completion_path ~raw_opens + ~package:full.package completion_path_without_current_module |> String.concat "." in let completion_name name = @@ -908,10 +910,10 @@ let completions_get_completion_type ~full completions = | Some {Completion.kind = ObjLabel typ; env} | Some {Completion.kind = Field ({typ}, _); env} -> typ - |> TypeUtils.extract_type ~env ~package:full.package + |> Type_utils.extract_type ~env ~package:full.package |> Option.map (fun (typ, _) -> (typ, env)) | Some {Completion.kind = Type typ; env} -> ( - match TypeUtils.extract_type_from_resolved_type typ ~env ~full with + 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) @@ -934,7 +936,7 @@ let rec completions_get_completion_type2 ~debug ~full ~opens ~raw_opens ~pos ~raw_opens ~pos ~scope |> completions_get_completion_type2 ~debug ~full ~opens ~raw_opens ~pos | Some {Completion.kind = Type typ; env} -> ( - match TypeUtils.extract_type_from_resolved_type typ ~env ~full with + 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} -> @@ -1060,13 +1062,13 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env let has_tvars = if use_tvar_lookup then match by_path with - | [{kind = Value typ}] when TypeUtils.has_tvar typ -> true + | [{kind = Value typ}] when Type_utils.has_tvar typ -> true | _ -> false else false in let result = if has_tvars then - let by_loc = TypeUtils.find_type_via_loc loc ~full ~debug in + 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 @@ -1115,7 +1117,7 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env in match - TypeUtils.extract_function_type ~env ~package ~dig_into:false typ + Type_utils.extract_function_type ~env ~package ~dig_into:false typ with | args, t_ret when args <> [] -> let args = process_apply args labels in @@ -1149,7 +1151,7 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env [] | Some (typ, env) -> let field_completions = - DotCompletionUtils.field_completions_for_dot_completion typ ~env + 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. *) @@ -1160,7 +1162,7 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env context_path = (match cp with | CPApply (c, args) -> CPApply (c, args @ [Asttypes.Nolabel]) - | CPId _ when TypeUtils.is_function_type ~env ~package typ -> + | CPId _ when Type_utils.is_function_type ~env ~package typ -> CPApply (cp, [Asttypes.Nolabel]) | _ -> cp); id = field_name; @@ -1173,8 +1175,8 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env |> get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env:env_completion_is_made_from ~exact ~scope |> List.filter_map (fun c -> - TypeUtils.transform_completion_to_pipe_completion ~synthetic:true - ~env ?pos_of_dot c) + Type_utils.transform_completion_to_pipe_completion + ~synthetic:true ~env ?pos_of_dot c) in field_completions @ pipe_completions) | CPObj (cp, label) -> ( @@ -1187,9 +1189,9 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env |> completions_get_type_env2 ~debug ~full ~opens ~raw_opens ~pos with | Some (typ, env) -> ( - match typ |> TypeUtils.extract_object_type ~env ~package with + match typ |> Type_utils.extract_object_type ~env ~package with | Some (env, t_obj) -> - t_obj |> TypeUtils.get_obj_fields + t_obj |> Type_utils.get_obj_fields |> Utils.filter_map (fun (field, typ) -> if Utils.check_name field ~prefix:label ~exact then Some @@ -1214,11 +1216,11 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env | Some (typ, env) -> ( let env, typ = typ - |> TypeUtils.resolve_type_for_pipe_completion ~env ~package:full.package - ~full ~lhs_loc + |> Type_utils.resolve_type_for_pipe_completion ~env + ~package:full.package ~full ~lhs_loc in - let main_type_id = TypeUtils.find_root_type_id ~full ~env typ in - let type_path = TypeUtils.path_from_type_expr typ 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 @@ -1243,7 +1245,7 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env *) let complete_as_builtin = match type_path with - | Some t -> TypeUtils.completion_path_from_maybe_builtin t + | Some t -> Type_utils.completion_path_from_maybe_builtin t | None -> None in let completion_path = @@ -1256,7 +1258,7 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env 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.get_module_path_relative_to_env ~debug + Type_utils.get_module_path_relative_to_env ~debug ~env:env_completion_is_made_from ~env_from_item:env (Utils.expand_path p) with @@ -1270,7 +1272,7 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env completions_for_pipe_from_completion_path ~env_completion_is_made_from ~opens ~pos ~scope ~debug ~prefix ~env ~raw_opens ~full completion_path - |> TypeUtils.filter_pipeable_functions ~env ~full ~synthetic + |> 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. @@ -1279,7 +1281,7 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env match c.kind with | Value _ -> scope - |> List.find_opt (fun (item : ScopeTypes.item) -> + |> List.find_opt (fun (item : Scope_types.item) -> match item with | Value (scope_item_name, _, _, _) -> scope_item_name = c.name @@ -1291,7 +1293,7 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env let globally_configured_completions_for_type = match - package.autocomplete |> Misc.StringMap.find_opt main_type_id + package.autocomplete |> Misc.String_map.find_opt main_type_id with | None -> [] | Some completion_paths -> @@ -1305,26 +1307,26 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env ~env_completion_is_made_from ~opens ~pos ~scope ~debug ~prefix ~env ~raw_opens ~full completion_path) |> List.flatten - |> TypeUtils.filter_pipeable_functions ~synthetic:true ~env ~full + |> 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 = - TypeUtils.get_extra_modules_to_complete_from_for_type ~env ~full typ + 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 - |> TypeUtils.filter_pipeable_functions ~synthetic:true ~env ~full + |> 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 - PipeCompletionUtils.add_jsx_completion_items ~env ~main_type_id + Pipe_completion_utils.add_jsx_completion_items ~env ~main_type_id ~prefix ~full ~raw_opens typ else [] in @@ -1332,7 +1334,7 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env let current_module_completions = get_completions_for_path ~debug ~completion_context:Value ~exact:false ~opens:[] ~full ~pos ~env:env_at_cursor ~scope [prefix] - |> TypeUtils.filter_pipeable_functions ~synthetic:true ~env ~full + |> Type_utils.filter_pipeable_functions ~synthetic:true ~env ~full ~target_type_id:main_type_id in jsx_completions @ pipe_completions @ extra_completions @@ -1389,9 +1391,9 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env fields |> List.map (fun f -> (f.fname.txt, f.typ, env)) | _ -> [] in - TypeUtils.path_to_element_props package |> dig_to_type_for_completion + Type_utils.path_to_element_props package |> dig_to_type_for_completion else - CompletionJsx.get_jsx_labels ~component_path:path_to_component + 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, @@ -1444,7 +1446,7 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env with | Some ((TypeExpr typ | ExtractedType (Tfunction {typ})), env) -> if Debug.verbose () then print_endline "--> found function type"; - (typ |> TypeUtils.get_args ~full ~env, env) + (typ |> Type_utils.get_args ~full ~env, env) | _ -> if Debug.verbose () then print_endline "--> could not find function type"; @@ -1490,14 +1492,16 @@ and get_completions_for_context_path ~debug ~full ~opens ~raw_opens ~pos ~env |> completions_get_completion_type2 ~debug ~full ~opens ~raw_opens ~pos with | Some (typ, env) -> ( - match typ |> TypeUtils.resolve_nested_pattern_path ~env ~full ~nested with + 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 TypeUtils.find_type_via_loc loc ~full ~debug with + match Type_utils.find_type_via_loc loc ~full ~debug with | None -> [] | Some typ_expr -> [Completion.create "dummy" ~env ~kind:(Value typ_expr)]) @@ -1524,7 +1528,7 @@ let get_opens ~debug ~raw_opens ~package ~env = ^ " " ^ String.concat " " (resolved_opens - |> List.map (fun (e : QueryEnv.t) -> e.file.module_name))); + |> List.map (fun (e : Query_env.t) -> e.file.module_name))); (* Last open takes priority *) List.rev resolved_opens @@ -1559,7 +1563,7 @@ let print_constructor_args ~mode ~as_snippet args_len = let rec complete_typed_value ?(type_arg_context : type_arg_context option) ~raw_opens ~full ~prefix ~completion_context ~mode - (t : SharedTypes.completion_type) = + (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 @@ -1584,13 +1588,13 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) ] ~kind: (Field - (field, TypeUtils.extracted_type_to_string extracted_type)) + (field, Type_utils.extracted_type_to_string extracted_type)) ~env | _ -> create field.fname.txt ?deprecated:field.deprecated ~kind: (Field - (field, TypeUtils.extracted_type_to_string extracted_type)) + (field, Type_utils.extracted_type_to_string extracted_type)) ~env) |> filter_items ~prefix | _ -> @@ -1622,7 +1626,7 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) match t.Types.desc with | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> fn_returns_type_t t1 | Tarrow _ -> ( - match TypeUtils.extract_function_type ~env ~package:full.package t with + 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 @@ -1635,15 +1639,15 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) in let get_completion_name exported_value_name = let fn_nname = - TypeUtils.get_module_path_relative_to_env ~debug:false - ~env:(QueryEnv.from_file full.file) + 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 = - TypeUtils.remove_opens_from_completion_path ~raw_opens + Type_utils.remove_opens_from_completion_path ~raw_opens ~package:full.package base in Some ((base |> String.concat ".") ^ "." ^ exported_value_name) @@ -1762,7 +1766,7 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) let inner_type = match t with | ExtractedType t -> Some (t, None) - | TypeExpr t -> t |> TypeUtils.extract_type ~env ~package:full.package + | TypeExpr t -> t |> Type_utils.extract_type ~env ~package:full.package in let expanded_completions = match inner_type with @@ -1807,10 +1811,10 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) | Tresult {env; ok_type; error_type} -> if Debug.verbose () then print_endline "[complete_typed_value]--> Tresult"; let ok_inner_type = - ok_type |> TypeUtils.extract_type ~env ~package:full.package + ok_type |> Type_utils.extract_type ~env ~package:full.package in let error_inner_type = - error_type |> TypeUtils.extract_type ~env ~package:full.package + error_type |> Type_utils.extract_type ~env ~package:full.package in let expanded_ok_completions = match ok_inner_type with @@ -1919,10 +1923,10 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) print_endline "[complete_typed_value]--> Tfunction #1"; let mk_fn_args ~as_snippet = match args with - | [(Nolabel, arg_typ)] when TypeUtils.type_is_unit arg_typ -> "()" + | [(Nolabel, arg_typ)] when Type_utils.type_is_unit arg_typ -> "()" | [(Nolabel, arg_typ)] -> let var_name = - CompletionExpressions.pretty_print_fn_template_arg_name ~env ~full + Completion_expressions.pretty_print_fn_template_arg_name ~env ~full arg_typ in if as_snippet then "${1:" ^ var_name ^ "}" else var_name @@ -1935,12 +1939,12 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) | Optional {txt = name} -> "~" ^ name ^ "=?" | Labelled {txt = name} -> "~" ^ name | Nolabel -> - if TypeUtils.type_is_unit typ then "()" + 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 = - CompletionExpressions.pretty_print_fn_template_arg_name + Completion_expressions.pretty_print_fn_template_arg_name ~current_index:num ~env ~full typ in if as_snippet then @@ -1951,7 +1955,7 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) "(" ^ args_text ^ ")" in let is_async = - match TypeUtils.extract_type ~env ~package:full.package return_type with + match Type_utils.extract_type ~env ~package:full.package return_type with | Some (Tpromise _, _) -> true | _ -> false in @@ -1960,7 +1964,7 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) match args with | [(Nolabel, arg_typ)] -> let var_name = - CompletionExpressions.pretty_print_fn_template_arg_name ~env ~full + Completion_expressions.pretty_print_fn_template_arg_name ~env ~full arg_typ in ( (" => " ^ if var_name = "()" then "{}" else var_name), @@ -1999,7 +2003,7 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) if Debug.verbose () then print_endline "[complete_typed_value]--> Tpromise"; [] -module StringSet = Set.Make (String) +module String_set = Set.Make (String) let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable = @@ -2030,7 +2034,7 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable if Utils.starts_with "key" prefix then [mk_label ("key", "string")] else [] in - let path_to_element_props = TypeUtils.path_to_element_props package 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" @@ -2066,7 +2070,7 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable key_labels) | Cjsx (component_path, prefix, idents_seen) -> let labels = - CompletionJsx.get_jsx_labels ~component_path ~find_type_of_value ~package + 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 @@ -2110,7 +2114,7 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable ]; } in - match typ |> TypeUtils.resolve_nested ~env ~full ~nested with + match typ |> Type_utils.resolve_nested ~env ~full ~nested with | None -> [] | Some (typ, _env, completion_context, type_arg_context) -> typ @@ -2153,7 +2157,7 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable (rest, import_attributes_config) | _ -> (nested, root_config) in - match typ |> TypeUtils.resolve_nested ~env ~full ~nested with + match typ |> Type_utils.resolve_nested ~env ~full ~nested with | None -> [] | Some (typ, _env, completion_context, type_arg_context) -> typ @@ -2177,7 +2181,7 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable if debug then print_endline "Could not read package.json"; [] | Some s -> ( - match YojsonHelpers.from_string_opt s with + match Yojson_helpers.from_string_opt s with | Some (`Assoc items) -> items |> List.filter_map (fun (key, t) -> @@ -2204,7 +2208,7 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable in (* Filter out generated build artifacts from in-source builds. *) let res_files = - StringSet.of_list + String_set.of_list (files |> List.filter_map (fun f -> if Filename.extension f = ".res" then @@ -2222,7 +2226,7 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable in if String.ends_with file_name ~suffix:package.suffix - && res_files |> StringSet.mem without_extension + && res_files |> String_set.mem without_extension then None else match Filename.extension file_name with @@ -2257,8 +2261,8 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable else prefix in let decorators = - if is_top_level then CompletionDecorators.toplevel - else CompletionDecorators.local + if is_top_level then Completion_decorators.toplevel + else Completion_decorators.local in decorators |> List.filter (fun (decorator, _, _) -> Utils.starts_with decorator prefix) @@ -2286,10 +2290,10 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable (typ |> Shared.type_to_string); typ - |> TypeUtils.get_args ~full ~env + |> Type_utils.get_args ~full ~env |> List.filter_map (fun arg -> match arg with - | SharedTypes.Completable.Labelled name, a -> Some (name, a) + | Shared_types.Completable.Labelled name, a -> Some (name, a) | Optional name, a -> Some (name, a) | _ -> None) | None -> [] @@ -2319,10 +2323,10 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable | Some (typ, env) -> ( match typ - |> TypeUtils.extract_type ~env ~package:full.package + |> Type_utils.extract_type ~env ~package:full.package |> Utils.Option.flat_map (fun (typ, type_arg_context) -> typ - |> TypeUtils.resolve_nested ?type_arg_context ~env ~full ~nested) + |> Type_utils.resolve_nested ?type_arg_context ~env ~full ~nested) with | None -> fallback_or_empty () | Some (typ, _env, completion_context, type_arg_context) -> @@ -2373,7 +2377,7 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable "[process_completable]--> could not get completions for context path"; regular_completions | Some (typ, env) -> ( - match typ |> TypeUtils.resolve_nested ~env ~full ~nested with + match typ |> Type_utils.resolve_nested ~env ~full ~nested with | None -> if Debug.verbose () then print_endline @@ -2471,7 +2475,7 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable |> List.map (fun (c : Completion.t) -> match c.kind with | Value typ_expr -> ( - match typ_expr |> TypeUtils.extract_type ~env:c.env ~package with + match typ_expr |> Type_utils.extract_type ~env:c.env ~package with | Some (Tvariant v, _) -> with_exhaustive_item c ~cases: @@ -2503,7 +2507,7 @@ let rec process_completable ~debug ~full ~scope ~env ~pos ~for_hover completable | _ -> [c]) |> List.flatten | ChtmlElement {prefix} -> - CompletionJsx.html_elements + 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 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/CompletionExpressions.ml b/analysis/src/completion_expressions.ml similarity index 97% rename from analysis/src/CompletionExpressions.ml rename to analysis/src/completion_expressions.ml index f807675e3e..79c86e54da 100644 --- a/analysis/src/CompletionExpressions.ml +++ b/analysis/src/completion_expressions.ml @@ -1,4 +1,4 @@ -open SharedTypes +open Shared_types let is_expr_hole exp = match exp.Parsetree.pexp_desc with @@ -12,7 +12,7 @@ let is_expr_tuple expr = let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos ~first_char_before_cursor_no_white = - let loc_has_cursor loc = loc |> CursorPosition.loc_has_cursor ~pos in + 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 @@ -67,7 +67,7 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos Ext_list.iter fields (fun {lid = fname; x = exp} -> match ( fname.Location.txt, - exp.Parsetree.pexp_loc |> CursorPosition.classify_loc ~pos ) + exp.Parsetree.pexp_loc |> Cursor_position.classify_loc ~pos ) with | Longident.Lident fname, HasCursor -> field_with_cursor := Some (fname, exp) @@ -248,10 +248,10 @@ let pretty_print_fn_template_arg_name ?current_index ~env ~full in let default_var_name = "v" ^ index_text in let arg_typ, suffix, _env = - TypeUtils.dig_to_relevant_template_name_type ~env ~package:full.package + Type_utils.dig_to_relevant_template_name_type ~env ~package:full.package arg_typ in - match arg_typ |> TypeUtils.path_from_type_expr with + match arg_typ |> Type_utils.path_from_type_expr with | None -> default_var_name | Some p -> ( let trailing_elements_of_path = @@ -272,7 +272,7 @@ let pretty_print_fn_template_arg_name ?current_index ~env ~full | some_name when String.length some_name < 30 -> if some_name = "synthetic" then Printf.printf "synthetic! %s\n" - (trailing_elements_of_path |> SharedTypes.ident); + (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 diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/completion_front_end.ml similarity index 97% rename from analysis/src/CompletionFrontEnd.ml rename to analysis/src/completion_front_end.ml index 66024cba69..481c7a0d3f 100644 --- a/analysis/src/CompletionFrontEnd.ml +++ b/analysis/src/completion_front_end.ml @@ -1,4 +1,4 @@ -open SharedTypes +open Shared_types let find_arg_completables ~(args : arg list) ~end_pos ~pos_before_cursor ~(context_path : Completable.context_path) ~pos_after_fun_expr @@ -32,7 +32,7 @@ let find_arg_completables ~(args : arg list) ~end_pos ~pos_before_cursor "[findArgCompletables] Completing in the assignment of labelled \ argument"; match - CompletionExpressions.traverse_expr exp ~expr_path:[] + Completion_expressions.traverse_expr exp ~expr_path:[] ~pos:pos_before_cursor ~first_char_before_cursor_no_white with | None -> None @@ -52,7 +52,7 @@ let find_arg_completables ~(args : arg list) ~end_pos ~pos_before_cursor prefix; nested = List.rev nested; })) - else if CompletionExpressions.is_expr_hole exp then ( + else if Completion_expressions.is_expr_hole exp then ( if Debug.verbose () then print_endline "[findArgCompletables] found exprhole"; Some @@ -71,10 +71,10 @@ let find_arg_completables ~(args : arg list) ~end_pos ~pos_before_cursor | {label = None; exp} :: rest -> if Debug.verbose () then Printf.printf "[findArgCompletable] unlabelled arg expr is: %s \n" - (DumpAst.print_expr_item ~pos:pos_before_cursor ~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.loc_is_empty exp.pexp_loc ~pos:pos_before_cursor then + 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 @@ -83,7 +83,7 @@ let find_arg_completables ~(args : arg list) ~end_pos ~pos_before_cursor print_endline "[findArgCompletables] Completing in an unlabelled argument"; match - CompletionExpressions.traverse_expr exp ~pos:pos_before_cursor + Completion_expressions.traverse_expr exp ~pos:pos_before_cursor ~first_char_before_cursor_no_white ~expr_path:[] with | None -> @@ -108,7 +108,7 @@ let find_arg_completables ~(args : arg list) ~end_pos ~pos_before_cursor prefix; nested = List.rev nested; })) - else if CompletionExpressions.is_expr_hole exp then ( + else if Completion_expressions.is_expr_hole exp then ( if Debug.verbose () then print_endline "[findArgCompletables] found an exprhole #2"; Some @@ -534,7 +534,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file | Ppat_or (p1, _) -> scope_pattern ~pattern_path ?context_path p1 | Ppat_constraint (p, core_type) -> scope_pattern ~pattern_path - ?context_path:(TypeUtils.context_path_from_core_type core_type) + ?context_path:(Type_utils.context_path_from_core_type core_type) p | Ppat_type _ -> () | Ppat_unpack {txt; loc} -> @@ -543,12 +543,12 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file | Ppat_extension _ -> () | Ppat_open (_, p) -> scope_pattern ~pattern_path ?context_path p in - let loc_has_cursor = CursorPosition.loc_has_cursor ~pos:pos_before_cursor in - let loc_is_empty = CursorPosition.loc_is_empty ~pos:pos_before_cursor in + 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.traverse_pattern ~pattern_path:[] ~loc_has_cursor + |> Completion_patterns.traverse_pattern ~pattern_path:[] ~loc_has_cursor ~first_char_before_cursor_no_white ~pos_before_cursor, context_path ) with @@ -609,7 +609,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file (* Identifies expressions where we can do typed pattern or expr completion. *) let typed_completion_expr (exp : Parsetree.expression) = let debug_typed_completion_expr = false in - if exp.pexp_loc |> CursorPosition.loc_has_cursor ~pos:pos_before_cursor then ( + 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 @@ -634,8 +635,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file () | Pexp_match (expr, [{pc_lhs; pc_rhs}]) when loc_has_cursor expr.pexp_loc - && CompletionExpressions.is_expr_hole pc_rhs - && CompletionPatterns.is_pattern_hole pc_lhs -> + && 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 () && debug_typed_completion_expr then print_endline @@ -764,9 +765,9 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file (* Expression with derivable type annotation. E.g: let x: someRecord = {} *) match - ( TypeUtils.context_path_from_core_type core_type, + ( Type_utils.context_path_from_core_type core_type, pvb_expr - |> CompletionExpressions.traverse_expr ~expr_path:[] + |> Completion_expressions.traverse_expr ~expr_path:[] ~pos:pos_before_cursor ~first_char_before_cursor_no_white ) with | Some ctx_path, Some (prefix, nested) -> @@ -783,7 +784,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file E.g: let x = {name: "name", }, when `x` has compiled. *) match pvb_expr - |> CompletionExpressions.traverse_expr ~expr_path:[] + |> Completion_expressions.traverse_expr ~expr_path:[] ~pos:pos_before_cursor ~first_char_before_cursor_no_white with | Some (prefix, nested) -> @@ -802,10 +803,10 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file when loc_has_cursor value_binding.pvb_loc && loc_has_cursor ppat_loc = false && loc_has_cursor pvb_expr.pexp_loc = false - && CompletionExpressions.is_expr_hole pvb_expr -> ( + && 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.context_path_from_core_type core_type with + match Type_utils.context_path_from_core_type core_type with | Some ctx_path -> set_result (Completable.Cexpression @@ -816,7 +817,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file E.g: let {} = someVar *) match ( pvb_pat - |> CompletionPatterns.traverse_pattern ~pattern_path:[] + |> 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 ) @@ -941,7 +942,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ] when loc_has_cursor from_expr.pexp_loc || loc_is_empty from_expr.pexp_loc - && CompletionExpressions.is_expr_hole from_expr -> ( + && Completion_expressions.is_expr_hole from_expr -> ( if Debug.verbose () then print_endline "[decoratorCompletion] Found @module with import attributes and \ @@ -949,7 +950,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file match ( loc_has_cursor from_expr.pexp_loc, loc_is_empty from_expr.pexp_loc, - CompletionExpressions.is_expr_hole from_expr, + Completion_expressions.is_expr_hole from_expr, from_expr ) with | true, _, _, {pexp_desc = Pexp_constant (Pconst_string (s, _))} -> @@ -968,7 +969,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file print_endline "[decoratorCompletion] Found @module with non-string payload"; match - CompletionExpressions.traverse_expr expr ~expr_path:[] + Completion_expressions.traverse_expr expr ~expr_path:[] ~pos:pos_before_cursor ~first_char_before_cursor_no_white with | None -> () @@ -986,7 +987,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file if Debug.verbose () then print_endline "[decoratorCompletion] Found @jsxConfig"; match - CompletionExpressions.traverse_expr expr ~expr_path:[] + Completion_expressions.traverse_expr expr ~expr_path:[] ~pos:pos_before_cursor ~first_char_before_cursor_no_white with | None -> () @@ -1052,9 +1053,9 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file expr iterator arg.exp; reset_current_ctx_path previous_ctx_path)) | Some arg_completable -> set_result arg_completable - and iterate_jsx_props ~iterator (props : CompletionJsx.jsx_props) = + and iterate_jsx_props ~iterator (props : Completion_jsx.jsx_props) = props.props - |> List.iter (fun (prop : CompletionJsx.prop) -> + |> List.iter (fun (prop : Completion_jsx.prop) -> let previous_ctx_path = !current_ctx_path in set_current_ctx_path (CJsxPropValue @@ -1267,7 +1268,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file match e_opt with | Some e when loc_has_cursor e.pexp_loc -> ( match - CompletionExpressions.complete_constructor_payload + Completion_expressions.complete_constructor_payload ~pos_before_cursor ~first_char_before_cursor_no_white lid e with | Some result -> @@ -1368,7 +1369,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file let jsx_props_opt = if is_valid_tag_for_props then Some - (CompletionJsx.extract_jsx_props + (Completion_jsx.extract_jsx_props ~comp_name:(Location.mkloc compName_lid compName_loc) ~props ~children) else None @@ -1386,7 +1387,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file (jsx_props.props |> List.map (fun - ({name; pos_start; pos_end; exp} : CompletionJsx.prop) + ({name; pos_start; pos_end; exp} : Completion_jsx.prop) -> Printf.sprintf "%s[%s->%s]=...%s" name (Pos.to_string pos_start) (Pos.to_string pos_end) @@ -1423,7 +1424,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file }) ) -> None | Some jsx_props, _ -> - CompletionJsx.find_jsx_props_completable ~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 diff --git a/analysis/src/CompletionJsx.ml b/analysis/src/completion_jsx.ml similarity index 98% rename from analysis/src/CompletionJsx.ml rename to analysis/src/completion_jsx.ml index 0abd4fbc3a..e60fcda21f 100644 --- a/analysis/src/CompletionJsx.ml +++ b/analysis/src/completion_jsx.ml @@ -1,4 +1,4 @@ -open SharedTypes +open Shared_types (* List and explanations taken from https://www.tutorialrepublic.com/html-reference/html5-tags.php. *) @@ -226,7 +226,7 @@ let get_jsx_labels ~component_path ~find_type_of_value ~package = let name = Ident.name ld.ld_id in let t = ld.ld_type - |> TypeUtils.instantiate_type ~type_params ~type_args + |> Type_utils.instantiate_type ~type_params ~type_args in (name, t, env)) | _ -> [] @@ -370,7 +370,7 @@ let find_jsx_props_completable ~jsx_props ~end_pos ~pos_before_cursor if Debug.verbose () then print_endline "[jsx_props_completable]--> Cursor on expr assigned"; match - CompletionExpressions.traverse_expr prop.exp ~expr_path:[] + Completion_expressions.traverse_expr prop.exp ~expr_path:[] ~pos:pos_before_cursor ~first_char_before_cursor_no_white with | Some (prefix, nested) -> @@ -394,7 +394,7 @@ let find_jsx_props_completable ~jsx_props ~end_pos ~pos_before_cursor if Debug.verbose () then print_endline "[jsx_props_completable]--> Loc is broken"; if - CompletionExpressions.is_expr_hole prop.exp + Completion_expressions.is_expr_hole prop.exp || is_regexp_jsx_heuristic_expr prop.exp then ( if Debug.verbose () then diff --git a/analysis/src/CompletionPatterns.ml b/analysis/src/completion_patterns.ml similarity index 99% rename from analysis/src/CompletionPatterns.ml rename to analysis/src/completion_patterns.ml index 14aa970631..cc1a270cab 100644 --- a/analysis/src/CompletionPatterns.ml +++ b/analysis/src/completion_patterns.ml @@ -1,4 +1,4 @@ -open SharedTypes +open Shared_types let is_pattern_hole pat = match pat.Parsetree.ppat_desc with @@ -118,7 +118,7 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor match ( fname.Location.txt, f.Parsetree.ppat_loc - |> CursorPosition.classify_loc ~pos:pos_before_cursor ) + |> Cursor_position.classify_loc ~pos:pos_before_cursor ) with | Longident.Lident fname, HasCursor -> field_with_cursor := Some (fname, f) diff --git a/analysis/src/Completions.ml b/analysis/src/completions.ml similarity index 63% rename from analysis/src/Completions.ml rename to analysis/src/completions.ml index 45ba813929..37c8be8eef 100644 --- a/analysis/src/Completions.ml +++ b/analysis/src/completions.ml @@ -1,10 +1,10 @@ let get_completions ~debug ~source ~kind_file ~pos ~for_hover - ~(full : SharedTypes.full option) = + ~(full : Shared_types.full option) = match source with | "" -> None | source -> ( match - CompletionFrontEnd.completion_with_parser ~debug ~source ~kind_file + Completion_front_end.completion_with_parser ~debug ~source ~kind_file ~pos_cursor:pos with | None -> None @@ -14,17 +14,17 @@ let get_completions ~debug ~source ~kind_file ~pos ~for_hover 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.from_file full.file in + let env = Shared_types.Query_env.from_file full.file in let completables = completable - |> CompletionBackEnd.process_completable ~debug ~full ~pos ~scope ~env - ~for_hover + |> Completion_back_end.process_completable ~debug ~full ~pos ~scope + ~env ~for_hover in Some (completables, full, scope))) diff --git a/analysis/src/CreateInterface.ml b/analysis/src/create_interface.ml similarity index 95% rename from analysis/src/CreateInterface.ml rename to analysis/src/create_interface.ml index 14eb9cb7c7..f74f2e151e 100644 --- a/analysis/src/CreateInterface.ml +++ b/analysis/src/create_interface.ml @@ -1,4 +1,4 @@ -module SourceFileExtractor = struct +module Source_file_extractor = struct let create ~path = match Files.read_file path with | None -> [||] @@ -32,7 +32,7 @@ module SourceFileExtractor = struct !res) end -module AttributesUtils : sig +module Attributes_utils : sig type t val make : string list -> t @@ -115,7 +115,7 @@ let print_signature ~extractor ~signature = (Printtyp.tree_of_value_description id {vd with val_kind = Val_reg}) in - (attributes |> AttributesUtils.to_string) ^ divider ^ sig_str ^ "\n" + (attributes |> Attributes_utils.to_string) ^ divider ^ sig_str ^ "\n" in let buf = Buffer.create 10 in @@ -170,7 +170,7 @@ let print_signature ~extractor ~signature = | [] -> ret_type | label_decl :: rest -> let prop_type = - TypeUtils.instantiate_type ~type_params ~type_args + Type_utils.instantiate_type ~type_params ~type_args label_decl.ld_type in let lbl_name = label_decl.ld_id |> Ident.name in @@ -234,11 +234,11 @@ let print_signature ~extractor ~signature = (* Rescript primitive name, e.g. @val external ... *) let lines = let pos_start, pos_end = Loc.range val_loc in - extractor |> SourceFileExtractor.extract ~pos_start ~pos_end + extractor |> Source_file_extractor.extract ~pos_start ~pos_end in - let attributes = AttributesUtils.make lines in + let attributes = Attributes_utils.make lines in - if AttributesUtils.contains "@inline" attributes then + 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) @@ -256,7 +256,7 @@ let print_signature ~extractor ~signature = | Sig_type (_id, type_decl, _recStatus) :: items -> let lines = let pos_start, pos_end = Loc.range type_decl.type_loc in - extractor |> SourceFileExtractor.extract ~pos_start ~pos_end + 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"); @@ -324,6 +324,6 @@ let command ~path ~cmi_file = | Some cmi_info -> (* For reading the config *) let _ = Cmt.load_full_cmt_from_path ~path in - let extractor = SourceFileExtractor.create ~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 77% rename from analysis/src/DceCommand.ml rename to analysis/src/dce_command.ml index 0e340c453c..820482b920 100644 --- a/analysis/src/DceCommand.ml +++ b/analysis/src/dce_command.ml @@ -1,6 +1,6 @@ let command () = - Reanalyze.RunConfig.dce (); - let dce_config = Reanalyze.DceConfig.current () in + 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 (); diff --git a/analysis/src/Debug.ml b/analysis/src/debug.ml similarity index 83% rename from analysis/src/Debug.ml rename to analysis/src/debug.ml index 58bc945b72..a7002fa56c 100644 --- a/analysis/src/Debug.ml +++ b/analysis/src/debug.ml @@ -7,7 +7,7 @@ let log s = | Regular | Verbose -> print_endline s | Off -> () -let debug_print_env (env : SharedTypes.QueryEnv.t) = +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 100% rename from analysis/src/Diagnostics.ml rename to analysis/src/diagnostics.ml diff --git a/analysis/src/DocumentSymbol.ml b/analysis/src/document_symbol.ml similarity index 100% rename from analysis/src/DocumentSymbol.ml rename to analysis/src/document_symbol.ml diff --git a/analysis/src/DotCompletionUtils.ml b/analysis/src/dot_completion_utils.ml similarity index 68% rename from analysis/src/DotCompletionUtils.ml rename to analysis/src/dot_completion_utils.ml index 52d7daf309..5bc0407df1 100644 --- a/analysis/src/DotCompletionUtils.ml +++ b/analysis/src/dot_completion_utils.ml @@ -1,39 +1,39 @@ let filter_record_fields ~env ~record_as_string ~prefix ~exact fields = fields - |> Utils.filter_map (fun (field : SharedTypes.field) -> + |> Utils.filter_map (fun (field : Shared_types.field) -> if Utils.check_name field.fname.txt ~prefix ~exact then Some - (SharedTypes.Completion.create field.fname.txt ~env + (Shared_types.Completion.create field.fname.txt ~env ?deprecated:field.deprecated ~docstring:field.docstring - ~kind:(SharedTypes.Completion.Field (field, record_as_string))) + ~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 |> TypeUtils.extract_object_type ~env ~package in + 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 |> TypeUtils.get_obj_fields + 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 - (SharedTypes.Completion.create full_obj_field_name + (Shared_types.Completion.create full_obj_field_name ~synthetic:true ~insert_text:full_obj_field_name ~env:obj_env - ~kind:(SharedTypes.Completion.ObjLabel typ) + ~kind:(Shared_types.Completion.ObjLabel typ) ?additional_text_edits: (match pos_of_dot with | None -> None | Some pos_of_dot -> Some - (TypeUtils.make_additional_text_edits_for_removing_dot + (Type_utils.make_additional_text_edits_for_removing_dot pos_of_dot))) else None) | None -> ( - match typ |> TypeUtils.extract_record_type ~env ~package with + match typ |> Type_utils.extract_record_type ~env ~package with | Some (env, fields, typ_decl) -> fields |> filter_record_fields ~env ~prefix ~exact diff --git a/analysis/src/DumpAst.ml b/analysis/src/dump_ast.ml similarity index 96% rename from analysis/src/DumpAst.ml rename to analysis/src/dump_ast.ml index 8178d890bd..0ebb44c0d5 100644 --- a/analysis/src/DumpAst.ml +++ b/analysis/src/dump_ast.ml @@ -1,4 +1,4 @@ -open SharedTypes +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 = "" @@ -6,20 +6,20 @@ let has_cursor_denom = "<*>" let no_cursor_denom = "" let print_loc_denominator loc ~pos = - match loc |> CursorPosition.classify_loc ~pos with + 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 |> CursorPosition.classify_location_loc ~pos with - | CursorPosition.EmptyLoc -> empty_loc_denom + 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 CursorPosition.classify_positions pos ~pos_start ~pos_end with - | CursorPosition.EmptyLoc -> empty_loc_denom + 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 @@ -179,7 +179,7 @@ and print_expr_item expr ~pos ~indentation = ~indentation:(indentation + 1)) |> String.concat "\n") | Pexp_ident {txt} -> - "Pexp_ident:" ^ (Utils.flatten_long_ident txt |> SharedTypes.ident) + "Pexp_ident:" ^ (Utils.flatten_long_ident txt |> Shared_types.ident) | Pexp_break -> "Pexp_break" | Pexp_continue -> "Pexp_continue" | Pexp_apply {funct = expr; args} -> @@ -293,7 +293,7 @@ let print_value_binding value ~pos ~indentation = ^ print_expr_item value.pvb_expr ~pos ~indentation:(indentation + 1) let print_struct_item struct_item ~pos ~source = - match struct_item.Parsetree.pstr_loc |> CursorPosition.classify_loc ~pos with + match struct_item.Parsetree.pstr_loc |> Cursor_position.classify_loc ~pos with | HasCursor -> ( let start_offset = match diff --git a/analysis/src/Files.ml b/analysis/src/files.ml similarity index 100% rename from analysis/src/Files.ml rename to analysis/src/files.ml diff --git a/analysis/src/FindFiles.ml b/analysis/src/find_files.ml similarity index 86% rename from analysis/src/FindFiles.ml rename to analysis/src/find_files.ml index 97f5f82424..16d0c3a183 100644 --- a/analysis/src/FindFiles.ml +++ b/analysis/src/find_files.ml @@ -10,21 +10,21 @@ let get_source_directories ~include_dev ~base_dir config = | `String text -> [current /+ text] | `Assoc _ -> ( let dir = - item |> YojsonHelpers.get "dir" + item |> Yojson_helpers.get "dir" |> bind Yojson.Safe.Util.to_string_option |> Option.value ~default:"Must specify directory" in let typ = if include_dev then "lib" else - item |> YojsonHelpers.get "type" + item |> Yojson_helpers.get "type" |> bind Yojson.Safe.Util.to_string_option |> Option.value ~default:"lib" in if typ = "dev" then [] else - match item |> YojsonHelpers.get "subdirs" with + match item |> Yojson_helpers.get "subdirs" with | None | Some (`Bool false) -> [current /+ dir] | Some (`Bool true) -> Files.collect_dirs (base_dir /+ current /+ dir) @@ -33,7 +33,7 @@ let get_source_directories ~include_dev ~base_dir config = | Some item -> (current /+ dir) :: handle_item (current /+ dir) item) | _ -> failwith "Invalid subdirs entry" in - match config |> YojsonHelpers.get "sources" with + match config |> Yojson_helpers.get "sources" with | None -> [] | Some item -> handle_item "" item @@ -95,7 +95,7 @@ let name_space_to_name n = |> String.concat "" let get_namespace config = - let ns = config |> YojsonHelpers.get "namespace" in + let ns = config |> Yojson_helpers.get "namespace" in let from_string = ns |> bind Yojson.Safe.Util.to_string_option in let is_namespaced = ns @@ -105,26 +105,26 @@ let get_namespace config = let either x y = if x = None then y else x in if is_namespaced then let from_name = - config |> YojsonHelpers.get "name" + config |> Yojson_helpers.get "name" |> bind Yojson.Safe.Util.to_string_option in either from_string from_name |> Option.map name_space_to_name else None -module StringSet = Set.Make (String) +module String_set = Set.Make (String) let get_public config = - let public = config |> YojsonHelpers.get "public" in + let public = config |> Yojson_helpers.get "public" in match public with | None -> None | Some public -> ( - match public |> YojsonHelpers.to_list_opt with + match public |> Yojson_helpers.to_list_opt with | None -> None | Some public -> Some (public |> List.filter_map Yojson.Safe.Util.to_string_option - |> StringSet.of_list)) + |> String_set.of_list)) let collect_files directory = let all_files = Files.read_directory directory in @@ -145,7 +145,7 @@ let collect_files directory = in match res_opt with | None -> None - | Some res -> Some (mod_name, SharedTypes.Impl {cmt; res})) + | 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 @@ -161,11 +161,11 @@ let read_sourcedirs_package_roots base = match Files.read_file source_dirs_file with | None -> [] | Some text -> ( - match YojsonHelpers.from_string_opt text with + match Yojson_helpers.from_string_opt text with | None -> [] | Some json -> ( match - json |> YojsonHelpers.get "pkgs" |> bind YojsonHelpers.to_list_opt + json |> Yojson_helpers.get "pkgs" |> bind Yojson_helpers.to_list_opt with | None -> [] | Some packages -> packages |> List.filter_map read_package_entry)) @@ -173,37 +173,37 @@ let read_sourcedirs_package_roots base = 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 - | _ -> ModuleResolution.resolve_node_module_path ~start_path:base name + | _ -> 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) |> StringSet.of_list + 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 |> StringSet.elements + dirs |> String_set.elements |> List.map (fun name -> Files.collect ~max_depth:2 name is_source_file) - |> List.concat |> StringSet.of_list + |> List.concat |> String_set.of_list in dirs |> if_debug true "Source directories" (fun s -> - s |> StringSet.elements |> List.map Utils.dump_path + s |> String_set.elements |> List.map Utils.dump_path |> String.concat " "); files |> if_debug true "Source files" (fun s -> - s |> StringSet.elements |> List.map Utils.dump_path + s |> String_set.elements |> List.map Utils.dump_path |> String.concat " "); let interfaces = Hashtbl.create 100 in files - |> StringSet.iter (fun path -> + |> String_set.iter (fun path -> if is_interface path then Hashtbl.replace interfaces (get_name path) path); let normals = - files |> StringSet.elements + files |> String_set.elements |> Utils.filter_map (fun file -> if is_implementation file then ( let module_name = get_name file in @@ -221,7 +221,7 @@ let find_project_files ~public ~namespace ~path ~source_directories ~lib_bs = (* Log.log("Intf and impl " ++ cmti ++ " " ++ cmt) *) Some ( module_name, - SharedTypes.IntfAndImpl {cmti; resi; cmt; res = file} ) + Shared_types.IntfAndImpl {cmti; resi; cmt; res = file} ) else None else ( (* Log.log("Just intf " ++ cmti) *) @@ -248,7 +248,7 @@ let find_project_files ~public ~namespace ~path ~source_directories ~lib_bs = in match public with | Some public -> - if public |> StringSet.mem original_name then Some (name, paths) + if public |> String_set.mem original_name then Some (name, paths) else None | None -> Some (name, paths)) in @@ -264,11 +264,11 @@ let find_dependency_files base config = let deps = match ( config - |> YojsonHelpers.get "dependencies" - |> bind YojsonHelpers.to_list_opt, + |> Yojson_helpers.get "dependencies" + |> bind Yojson_helpers.to_list_opt, config - |> YojsonHelpers.get "bs-dependencies" - |> bind YojsonHelpers.to_list_opt ) + |> Yojson_helpers.get "bs-dependencies" + |> bind Yojson_helpers.to_list_opt ) with | None, None -> [] | Some deps, None | _, Some deps -> @@ -277,11 +277,11 @@ let find_dependency_files base config = let dev_deps = match ( config - |> YojsonHelpers.get "dev-dependencies" - |> bind YojsonHelpers.to_list_opt, + |> Yojson_helpers.get "dev-dependencies" + |> bind Yojson_helpers.to_list_opt, config - |> YojsonHelpers.get "bs-dev-dependencies" - |> bind YojsonHelpers.to_list_opt ) + |> Yojson_helpers.get "bs-dev-dependencies" + |> bind Yojson_helpers.to_list_opt ) with | None, None -> [] | Some dev_deps, None | _, Some dev_deps -> @@ -299,14 +299,14 @@ let find_dependency_files base config = let rescript_json_path = path /+ "rescript.json" in let parse_text text = - match YojsonHelpers.from_string_opt text with + 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 BuildSystem.get_lib_bs path with + match Build_system.get_lib_bs path with | None -> None | Some lib_bs -> let compiled_directories = @@ -337,7 +337,7 @@ let find_dependency_files base config = Log.log ("Skipping nonexistent dependency: " ^ name); ([], [])) in - match BuildSystem.get_stdlib base with + match Build_system.get_stdlib base with | None -> None | Some stdlib_directory -> let compiled_directories, project_files = diff --git a/analysis/src/Hint.ml b/analysis/src/hint.ml similarity index 99% rename from analysis/src/Hint.ml rename to analysis/src/hint.ml index 9117f39724..cad294f840 100644 --- a/analysis/src/Hint.ml +++ b/analysis/src/hint.ml @@ -1,4 +1,4 @@ -open SharedTypes +open Shared_types type inlay_hint_kind = Type let inlay_kind_to_lsp_inlay_hint = function diff --git a/analysis/src/Hover.ml b/analysis/src/hover.ml similarity index 90% rename from analysis/src/Hover.ml rename to analysis/src/hover.ml index 970b8906f3..f87029695a 100644 --- a/analysis/src/Hover.ml +++ b/analysis/src/hover.ml @@ -1,6 +1,6 @@ -open SharedTypes +open Shared_types -module StringSet = Set.Make (String) +module String_set = Set.Make (String) let show_module_top_level ~docstring ~is_type ~name (top_level : Module.item list) = @@ -60,14 +60,14 @@ type extracted_type = { name: string; path: Path.t; decl: Types.type_declaration; - env: SharedTypes.QueryEnv.t; + 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 = QueryEnv.from_file file in + let env = Query_env.from_file file in let env_to_search, types_to_search = match typ |> Shared.dig_constructor with | Some path -> ( @@ -119,12 +119,12 @@ let expand_types ~file ~package ~supports_markdown_links typ = Markdown.code_block (decl |> Shared.decl_to_string ~print_name_as_is:true - (SharedTypes.path_ident_to_string path)); + (Shared_types.path_ident_to_string path)); ], `InlineType ) | all -> - let types_seen = ref StringSet.empty in - let type_id ~(env : QueryEnv.t) ~name = + 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 @@ -132,9 +132,9 @@ let expand_types ~file ~package ~supports_markdown_links typ = (* Don't produce duplicate type definitions for recursive types *) |> List.filter (fun {env; name} -> let type_id = type_id ~env ~name in - if StringSet.mem type_id !types_seen then false + if String_set.mem type_id !types_seen then false else ( - types_seen := StringSet.add type_id !types_seen; + types_seen := String_set.add type_id !types_seen; true)) |> List.map (fun {decl; env; loc; path} -> let link_to_type_definition_str = @@ -153,7 +153,7 @@ let expand_types ~file ~package ~supports_markdown_links typ = ^ Markdown.code_block (decl |> Shared.decl_to_string ~print_name_as_is:true - (SharedTypes.path_ident_to_string path)) + (Shared_types.path_ident_to_string path)) ^ link_to_type_definition_str ^ "\n"), `Default ) @@ -169,7 +169,7 @@ let hover_with_expanded_types ~file ~package ~supports_markdown_links ?docstring let type_string = match constructor with | Some constructor -> - type_string ^ "\n" ^ CompletionBackEnd.show_constructor constructor + type_string ^ "\n" ^ Completion_back_end.show_constructor constructor | None -> type_string in let type_string = @@ -202,9 +202,11 @@ let get_hover_via_completions ~debug ~source ~kind_file ~pos ~for_hover Some (String.concat "\n\n" parts) | {kind = Field _; env; docstring} :: _ -> ( - let opens = CompletionBackEnd.get_opens ~debug ~raw_opens ~package ~env in + let opens = + Completion_back_end.get_opens ~debug ~raw_opens ~package ~env + in match - CompletionBackEnd.completions_get_type_env2 ~debug ~full ~raw_opens + Completion_back_end.completions_get_type_env2 ~debug ~full ~raw_opens ~opens ~pos completions with | Some (typ, _env) -> @@ -215,9 +217,11 @@ let get_hover_via_completions ~debug ~source ~kind_file ~pos ~for_hover Some type_string | None -> None) | {env} :: _ -> ( - let opens = CompletionBackEnd.get_opens ~debug ~raw_opens ~package ~env in + let opens = + Completion_back_end.get_opens ~debug ~raw_opens ~package ~env + in match - CompletionBackEnd.completions_get_type_env2 ~debug ~full ~raw_opens + Completion_back_end.completions_get_type_env2 ~debug ~full ~raw_opens ~opens ~pos completions with | Some (typ, _env) -> @@ -256,10 +260,10 @@ let new_hover ~full:{file; package} ~supports_markdown_links loc_item = in show_module ~docstring ~name ~file declared ~package)) | LModule (GlobalReference (module_name, path, tip)) -> ( - match ProcessCmt.file_for_module ~package module_name with + match Process_cmt.file_for_module ~package module_name with | None -> None | Some file -> ( - let env = QueryEnv.from_file file in + let env = Query_env.from_file file in match References.exported_for_tip ~env ~path ~package ~tip with | None -> None | Some (_env, _name, stamp) -> ( @@ -277,7 +281,7 @@ let new_hover ~full:{file; package} ~supports_markdown_links loc_item = show_module ~docstring ~name ~file ~package declared)))) | LModule NotFound -> None | TopLevelModule name -> ( - match ProcessCmt.file_for_module ~package name with + match Process_cmt.file_for_module ~package name with | None -> None | Some file -> show_module ~docstring:file.structure.docstring ~name:file.module_name @@ -303,9 +307,9 @@ let new_hover ~full:{file; package} ~supports_markdown_links loc_item = let t = Shared.dig t in match t.desc with | Tpackage (path, _lids, _tys) -> ( - let env = QueryEnv.from_file file in + let env = Query_env.from_file file in match - ResolvePath.resolve_module_from_compiler_path ~env ~package path + Resolve_path.resolve_module_from_compiler_path ~env ~package path with | None -> Some (from_type t) | Some (env_for_module, Some declared) -> diff --git a/analysis/src/JsxHacks.ml b/analysis/src/jsx_hacks.ml similarity index 100% rename from analysis/src/JsxHacks.ml rename to analysis/src/jsx_hacks.ml diff --git a/analysis/src/Loc.ml b/analysis/src/loc.ml similarity index 100% rename from analysis/src/Loc.ml rename to analysis/src/loc.ml diff --git a/analysis/src/LocalTables.ml b/analysis/src/local_tables.ml similarity index 90% rename from analysis/src/LocalTables.ml rename to analysis/src/local_tables.ml index 35995f0775..a4676d80eb 100644 --- a/analysis/src/LocalTables.ml +++ b/analysis/src/local_tables.ml @@ -1,4 +1,4 @@ -open SharedTypes +open Shared_types type 'a table = (string * (int * int), 'a Declared.t) Hashtbl.t type names_used = (string, unit) Hashtbl.t @@ -25,17 +25,17 @@ let create () = } let populate_values ~env local_tables = - env.QueryEnv.file.stamps + 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.QueryEnv.file.stamps + env.Query_env.file.stamps |> Stamps.iter_values (fun _ declared -> match declared.module_path with - | ModulePath.IncludedModule (source, _) -> + | 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 @@ -44,21 +44,21 @@ let populate_included_values ~env local_tables = | _ -> ()) let populate_constructors ~env local_tables = - env.QueryEnv.file.stamps + 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.QueryEnv.file.stamps + 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.QueryEnv.file.stamps + env.Query_env.file.stamps |> Stamps.iter_modules (fun _ declared -> Hashtbl.replace local_tables.modules_table (declared.name.txt, declared.extent_loc |> Loc.start) 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 similarity index 91% rename from analysis/src/Markdown.ml rename to analysis/src/markdown.ml index ca1dc08336..ea92d1c5b2 100644 --- a/analysis/src/Markdown.ml +++ b/analysis/src/markdown.ml @@ -18,6 +18,6 @@ let go_to_definition_text ~env ~pos = ^ make_goto_command { label = "Type definition"; - file = Uri.to_string env.SharedTypes.QueryEnv.file.uri; + 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 100% rename from analysis/src/ModuleResolution.ml rename to analysis/src/module_resolution.ml diff --git a/analysis/src/Packages.ml b/analysis/src/packages.ml similarity index 83% rename from analysis/src/Packages.ml rename to analysis/src/packages.ml index f6f77fbc68..0007375e05 100644 --- a/analysis/src/Packages.ml +++ b/analysis/src/packages.ml @@ -1,4 +1,4 @@ -open SharedTypes +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 @@ -39,31 +39,31 @@ let new_bs_package ~root_path = let parse_raw raw = let lib_bs = match !Cfg.is_doc_gen_from_compiler with - | true -> BuildSystem.get_stdlib root_path - | false -> BuildSystem.get_lib_bs root_path + | true -> Build_system.get_stdlib root_path + | false -> Build_system.get_lib_bs root_path in - match YojsonHelpers.from_string_opt raw with + match Yojson_helpers.from_string_opt raw with | Some config -> ( - let namespace = FindFiles.get_namespace config in + let namespace = Find_files.get_namespace config in let rescript_version = get_re_script_version () in let suffix = - match config |> YojsonHelpers.get "suffix" with + match config |> Yojson_helpers.get "suffix" with | Some (`String suffix) -> suffix | _ -> ".js" in let generic_jsx_module = - let jsx_config = config |> YojsonHelpers.get "jsx" in + let jsx_config = config |> Yojson_helpers.get "jsx" in match jsx_config with | Some jsx_config -> ( - match jsx_config |> YojsonHelpers.get "module" with + 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 |> YojsonHelpers.get "editor" with + match config |> Yojson_helpers.get "editor" with | Some editor_config -> ( - match editor_config |> YojsonHelpers.get "autocomplete" with + match editor_config |> Yojson_helpers.get "autocomplete" with | Some (`Assoc map) -> map |> List.fold_left @@ -76,11 +76,11 @@ let new_bs_package ~root_path = | `String s -> Some s | _ -> None) in - Misc.StringMap.add key values acc + Misc.String_map.add key values acc | _ -> acc) - Misc.StringMap.empty - | _ -> Misc.StringMap.empty) - | None -> Misc.StringMap.empty + Misc.String_map.empty + | _ -> Misc.String_map.empty) + | None -> Misc.String_map.empty in match lib_bs with | None -> None @@ -94,18 +94,18 @@ let new_bs_package ~root_path = cached.paths_for_module ) | None -> let dependencies_files_and_paths = - match FindFiles.find_dependency_files root_path config with + 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 = - FindFiles.get_source_directories ~include_dev:true + Find_files.get_source_directories ~include_dev:true ~base_dir:root_path config in let project_files_and_paths = - FindFiles.find_project_files - ~public:(FindFiles.get_public config) + Find_files.find_project_files + ~public:(Find_files.get_public config) ~namespace ~path:root_path ~source_directories ~lib_bs in let paths_for_module = @@ -113,10 +113,10 @@ let new_bs_package ~root_path = ~dependencies_files_and_paths in let project_files = - project_files_and_paths |> List.map fst |> FileSet.of_list + project_files_and_paths |> List.map fst |> File_set.of_list in let dependencies_files = - dependencies_files_and_paths |> List.map fst |> FileSet.of_list + dependencies_files_and_paths |> List.map fst |> File_set.of_list in (project_files, dependencies_files, paths_for_module) in @@ -127,16 +127,16 @@ let new_bs_package ~root_path = | Some namespace -> let cmt = Filename.concat lib_bs namespace ^ ".cmt" in Hashtbl.replace paths_for_module namespace (Namespace {cmt}); - let path = [FindFiles.name_space_to_name namespace] in + 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 - ( YojsonHelpers.get "compiler-flags" config - |> bind YojsonHelpers.to_list_opt, - YojsonHelpers.get "bsc-flags" config - |> bind YojsonHelpers.to_list_opt ) + ( 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 @@ -207,7 +207,7 @@ let find_root ~uri packages_by_root = loop (if Sys.is_directory path then path else Filename.dirname path) let get_package ~uri = - let open SharedTypes in + let open Shared_types in if Hashtbl.mem state.root_for_uri uri then Some (Hashtbl.find state.packages_by_root diff --git a/analysis/src/PipeCompletionUtils.ml b/analysis/src/pipe_completion_utils.ml similarity index 82% rename from analysis/src/PipeCompletionUtils.ml rename to analysis/src/pipe_completion_utils.ml index 09918bee4f..385da524da 100644 --- a/analysis/src/PipeCompletionUtils.ml +++ b/analysis/src/pipe_completion_utils.ml @@ -1,5 +1,5 @@ let add_jsx_completion_items ~main_type_id ~env ~prefix - ~(full : SharedTypes.full) ~raw_opens typ = + ~(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 @@ -9,12 +9,12 @@ let add_jsx_completion_items ~main_type_id ~env ~prefix | Some g -> g ^ "." ^ builtin_name_to_complete |> String.split_on_char '.' - |> TypeUtils.remove_opens_from_completion_path ~raw_opens + |> Type_utils.remove_opens_from_completion_path ~raw_opens ~package:full.package |> String.concat "." in [ - SharedTypes.Completion.create name ~synthetic:true + Shared_types.Completion.create name ~synthetic:true ~includes_snippets:true ~kind:(Value typ) ~env ~sort_text:"A" ~docstring: [ diff --git a/analysis/src/Pos.ml b/analysis/src/pos.ml similarity index 100% rename from analysis/src/Pos.ml rename to analysis/src/pos.ml diff --git a/analysis/src/PrintType.ml b/analysis/src/print_type.ml similarity index 100% rename from analysis/src/PrintType.ml rename to analysis/src/print_type.ml diff --git a/analysis/src/ProcessAttributes.ml b/analysis/src/process_attributes.ml similarity index 99% rename from analysis/src/ProcessAttributes.ml rename to analysis/src/process_attributes.ml index fad7665eb3..62df3ca3ea 100644 --- a/analysis/src/ProcessAttributes.ml +++ b/analysis/src/process_attributes.ml @@ -1,4 +1,4 @@ -open SharedTypes +open Shared_types (* TODO should I hang on to location? *) let rec find_doc_attribute attributes = diff --git a/analysis/src/ProcessCmt.ml b/analysis/src/process_cmt.ml similarity index 95% rename from analysis/src/ProcessCmt.ml rename to analysis/src/process_cmt.ml index 0f1299190e..24066d80ce 100644 --- a/analysis/src/ProcessCmt.ml +++ b/analysis/src/process_cmt.ml @@ -1,4 +1,4 @@ -open SharedTypes +open Shared_types let is_module_type (declared : Module.t Declared.t) = match declared.module_path with @@ -9,14 +9,14 @@ 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.new_declared ~item ~extent ~name ~stamp + Process_attributes.new_declared ~item ~extent ~name ~stamp ~module_path:env.module_path is_exported attributes in add_stamp env.stamps stamp declared; declared let attrs_to_docstring attrs = - match ProcessAttributes.find_doc_attribute attrs with + match Process_attributes.find_doc_attribute attrs with | None -> [] | Some docstring -> [docstring] @@ -29,13 +29,13 @@ let map_record_field {Types.ld_id; ld_type; ld_attributes; ld_optional} = typ = ld_type; optional = ld_optional; docstring = - (match ProcessAttributes.find_doc_attribute ld_attributes with + (match Process_attributes.find_doc_attribute ld_attributes with | None -> [] | Some docstring -> [docstring]); - deprecated = ProcessAttributes.find_deprecated_attribute ld_attributes; + deprecated = Process_attributes.find_deprecated_attribute ld_attributes; } -let rec for_type_signature_item ~(env : SharedTypes.Env.t) +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}) -> @@ -116,12 +116,12 @@ let rec for_type_signature_item ~(env : SharedTypes.Env.t) type_decl = (name, decl); docstring = attrs_to_docstring cd_attributes; deprecated = - ProcessAttributes.find_deprecated_attribute + Process_attributes.find_deprecated_attribute cd_attributes; } in let declared = - ProcessAttributes.new_declared ~item ~extent:cd_loc + Process_attributes.new_declared ~item ~extent:cd_loc ~name:(Location.mknoloc name) ~stamp (* TODO maybe this needs another child *) ~module_path:env.module_path true cd_attributes @@ -240,7 +240,7 @@ let for_type_declaration ~env ~(exported : Exported.t) Constructor.stamp; cname; deprecated = - ProcessAttributes.find_deprecated_attribute + Process_attributes.find_deprecated_attribute cd_attributes; args = (match cd_args with @@ -265,14 +265,14 @@ let for_type_declaration ~env ~(exported : Exported.t) optional = f.ld_optional; docstring = (match - ProcessAttributes + Process_attributes .find_doc_attribute f.ld_attributes with | None -> [] | Some docstring -> [docstring]); deprecated = - ProcessAttributes + Process_attributes .find_deprecated_attribute f.ld_attributes; }))); @@ -285,7 +285,7 @@ let for_type_declaration ~env ~(exported : Exported.t) } in let declared = - ProcessAttributes.new_declared ~item ~extent:cd_loc + Process_attributes.new_declared ~item ~extent:cd_loc ~name:cname ~stamp ~module_path:env.module_path true cd_attributes in @@ -312,7 +312,7 @@ let for_type_declaration ~env ~(exported : Exported.t) optional = ld_optional; docstring = attrs_to_docstring ld_attributes; deprecated = - ProcessAttributes.find_deprecated_attribute + Process_attributes.find_deprecated_attribute ld_attributes; }))); } @@ -415,7 +415,7 @@ let for_signature ~name ~env sig_items = | _ -> [] in let docstring = attrs_to_docstring attributes in - let deprecated = ProcessAttributes.find_deprecated_attribute attributes in + let deprecated = Process_attributes.find_deprecated_attribute attributes in {Module.name; docstring; exported; items; deprecated} let for_tree_module_type ~name ~env {Typedtree.mty_desc} = @@ -436,7 +436,7 @@ let rec get_module_path mod_desc = | Tmod_constraint (expr, _typ, _constraint, _coercion) -> get_module_path expr.mod_desc -let rec for_structure_item ~(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) -> @@ -460,7 +460,7 @@ let rec for_structure_item ~(env : SharedTypes.Env.t) ~(exported : Exported.t) match (Shared.dig pat.pat_type).desc with | Tpackage (path, _, _) -> let declared = - ProcessAttributes.new_declared ~item:(Module.Ident path) + Process_attributes.new_declared ~item:(Module.Ident path) ~extent:(Option.get unpack_loc_opt) ~name ~stamp:(Ident.binding_time ident) ~module_path:NotVisible false attributes @@ -600,7 +600,7 @@ let rec for_structure_item ~(env : SharedTypes.Env.t) ~(exported : Exported.t) incl_type [] in top_level - | Tstr_primitive vd when JsxHacks.primitive_is_fragment vd = false -> + | Tstr_primitive vd when Jsx_hacks.primitive_is_fragment vd = false -> let declared = add_declared ~extent:vd.val_loc ~item:vd.val_val.val_type ~name:vd.val_name @@ -644,7 +644,7 @@ and for_module ~env mod_desc module_name = let kind = for_type_module ~name:arg_name.txt ~env t.mty_type in let stamp = Ident.binding_time ident in let declared = - ProcessAttributes.new_declared ~item:kind ~name:arg_name + Process_attributes.new_declared ~item:kind ~name:arg_name ~extent:arg_name.loc ~stamp ~module_path:NotVisible false [] in Stamps.add_module env.stamps stamp declared); @@ -674,7 +674,7 @@ and scan_let_modules ~env (e : Typedtree.expression) = let stamp = Ident.binding_time id in let item = for_module ~env mexpr.mod_desc name.txt in let declared = - ProcessAttributes.new_declared ~item ~extent:name.loc ~name ~stamp + Process_attributes.new_declared ~item ~extent:name.loc ~name ~stamp ~module_path:NotVisible false [] in Stamps.add_module env.stamps stamp declared; @@ -741,7 +741,7 @@ and for_structure ~name ~env str_items = | _ -> None) in let docstring = attrs_to_docstring attributes in - let deprecated = ProcessAttributes.find_deprecated_attribute attributes in + let deprecated = Process_attributes.find_deprecated_attribute attributes in {Module.name; docstring; exported; items; deprecated} let file_for_cmt_infos ~module_name ~uri diff --git a/analysis/src/ProcessExtra.ml b/analysis/src/process_extra.ml similarity index 96% rename from analysis/src/ProcessExtra.ml rename to analysis/src/process_extra.ml index 66bf36603c..0c44d934f3 100644 --- a/analysis/src/ProcessExtra.ml +++ b/analysis/src/process_extra.ml @@ -1,4 +1,4 @@ -open SharedTypes +open Shared_types let add_loc_item extra loc loc_type = if not loc.Warnings.loc_ghost then @@ -72,8 +72,8 @@ let add_external_reference ~extra module_name path tip 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 -> LocationSet.add loc old_locs - | None -> LocationSet.singleton loc + | Some old_locs -> Location_set.add loc old_locs + | None -> Location_set.singleton loc in Hashtbl.replace extra.file_references module_name new_locs @@ -148,7 +148,7 @@ 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 ResolvePath.from_compiler_path ~env path with + match Resolve_path.from_compiler_path ~env path with | Stamp stamp -> add_reference ~extra stamp ident_loc; LocalReference (stamp, tip) @@ -172,7 +172,7 @@ let add_for_path ~env ~extra path lident loc typ tip = let add_for_path_parent ~env ~extra path loc = let loc_type = - match ResolvePath.from_compiler_path ~env path with + match Resolve_path.from_compiler_path ~env path with | GlobalMod module_name -> add_file_reference ~extra module_name loc; TopLevelModule module_name @@ -193,7 +193,7 @@ let add_for_path_parent ~env ~extra path loc = add_loc_item extra loc loc_type let get_type_at_path ~env path = - match ResolvePath.from_compiler_path ~env path with + match Resolve_path.from_compiler_path ~env path with | GlobalMod _ -> `Not_found | Global (module_name, path) -> `Global (module_name, path) | NotFound -> `Not_found @@ -341,7 +341,7 @@ let signature_item ~(file : File.t) ~extra (iter : Tast_iterator.iterator) item let stamp = Ident.binding_time val_id in if Stamps.find_value file.stamps stamp = None then ( let declared = - ProcessAttributes.new_declared ~name ~stamp ~extent:val_loc + Process_attributes.new_declared ~name ~stamp ~extent:val_loc ~module_path:NotVisible ~item:val_desc.ctyp_type false val_attributes in Stamps.add_value file.stamps stamp declared; @@ -383,7 +383,7 @@ let pat ~(file : File.t) ~env ~extra (iter : Tast_iterator.iterator) let add_for_pattern stamp name = if Stamps.find_value file.stamps stamp = None then ( let declared = - ProcessAttributes.new_declared ~name ~stamp ~module_path:NotVisible + Process_attributes.new_declared ~name ~stamp ~module_path:NotVisible ~extent:pattern.pat_loc ~item:pattern.pat_type false pattern.pat_attributes in @@ -403,7 +403,7 @@ let pat ~(file : File.t) ~env ~extra (iter : Tast_iterator.iterator) match unpacked_module_path_opt () with | Some path -> let declared = - ProcessAttributes.new_declared ~item:(Module.Ident path) + Process_attributes.new_declared ~item:(Module.Ident path) ~extent:name.loc ~name ~stamp ~module_path:NotVisible false pattern.pat_attributes in @@ -415,7 +415,7 @@ let pat ~(file : File.t) ~env ~extra (iter : Tast_iterator.iterator) match unpacked_module_path_opt () with | Some path -> let declared = - ProcessAttributes.new_declared ~item:(Module.Ident path) + Process_attributes.new_declared ~item:(Module.Ident path) ~extent:name.loc ~name ~stamp ~module_path:NotVisible false pattern.pat_attributes in @@ -427,7 +427,7 @@ let pat ~(file : File.t) ~env ~extra (iter : Tast_iterator.iterator) 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.path_is_fragment path) + | Texp_ident (path, {txt; loc}, _) when not (Jsx_hacks.path_is_fragment path) -> add_for_longident ~env ~extra (Some (expression.exp_type, Value)) @@ -455,7 +455,7 @@ let expr ~env ~(extra : extra) (iter : Tast_iterator.iterator) let get_extra ~file ~infos = let extra = extra_for_file ~file in - let env = QueryEnv.from_file file in + let env = Query_env.from_file file in let iterator = { Tast_iterator.default_iterator with diff --git a/analysis/src/Range.ml b/analysis/src/range.ml similarity index 100% rename from analysis/src/Range.ml rename to analysis/src/range.ml diff --git a/analysis/src/References.ml b/analysis/src/references.ml similarity index 93% rename from analysis/src/References.ml rename to analysis/src/references.ml index 5cb0ddc62e..2eb2074626 100644 --- a/analysis/src/References.ml +++ b/analysis/src/references.ml @@ -1,4 +1,4 @@ -open SharedTypes +open Shared_types let debug_references = ref true let maybe_log m = if !debug_references then Log.log ("[ref] " ^ m) @@ -148,7 +148,7 @@ let get_constructor (file : File.t) stamp name = | _ -> None) let exported_for_tip ~env ~path ~package ~(tip : Tip.t) = - match ResolvePath.resolve_path ~env ~path ~package with + match Resolve_path.resolve_path ~env ~path ~package with | None -> Log.log ("Cannot resolve path " ^ path_to_string path); None @@ -193,12 +193,12 @@ let defined_for_loc ~file ~package loc_kind = inner ~file stamp tip | GlobalReference (module_name, path, tip) -> ( maybe_log ("Getting global " ^ module_name); - match ProcessCmt.file_for_module ~package module_name with + match Process_cmt.file_for_module ~package module_name with | None -> Log.log ("Cannot get module " ^ module_name); None | Some file -> ( - let env = QueryEnv.from_file file in + let env = Query_env.from_file file in match exported_for_tip ~env ~path ~package ~tip with | None -> None | Some (env, name, stamp) -> ( @@ -224,8 +224,8 @@ let alternate_declared ~(file : File.t) ~package (declared : _ Declared.t) tip = match Cmt.full_from_uri ~uri:(Uri.from_path alternate_uri) with | None -> None | Some {file; extra} -> ( - let env = QueryEnv.from_file file in - let path = ModulePath.to_path declared.module_path declared.name.txt in + 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 @@ -249,8 +249,8 @@ let rec resolve_module_reference ?(paths_seen = []) ~file ~package resolve_module_reference ~paths_seen ~file ~package {declared with item = module_type_item} | Ident path -> ( - let env = QueryEnv.from_file file in - match ResolvePath.from_compiler_path ~env path with + 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 @@ -260,11 +260,11 @@ let rec resolve_module_reference ?(paths_seen = []) ~file ~package | None -> None | Some md -> Some (env.file, Some md))) | Global (module_name, path) -> ( - match ProcessCmt.file_for_module ~package module_name with + match Process_cmt.file_for_module ~package module_name with | None -> None | Some file -> ( - let env = QueryEnv.from_file file in - match ResolvePath.resolve_path ~env ~package ~path with + 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 @@ -282,7 +282,7 @@ let rec resolve_module_reference ?(paths_seen = []) ~file ~package md | Some md -> Some (file, Some md)) | GlobalMod name -> ( - match ProcessCmt.file_for_module ~package name with + match Process_cmt.file_for_module ~package name with | None -> None | Some file -> Some (file, None))) @@ -334,9 +334,9 @@ let definition ~file ~package stamp (tip : Tip.t) = | _ -> (file, declared) in let loc = validate_loc declared_impl.name.loc declared_impl.extent_loc in - let env = QueryEnv.from_file file_impl in + let env = Query_env.from_file file_impl in let uri = - ResolvePath.get_source_uri ~env ~package declared_impl.module_path + Resolve_path.get_source_uri ~env ~package declared_impl.module_path in maybe_log ("Inner uri " ^ Uri.to_string uri); Some (uri, loc)) @@ -380,10 +380,10 @@ let definition_for_loc_item ~full:{file; package} loc_item = maybe_log ("Typed GlobalReference moduleName:" ^ module_name ^ " path:" ^ path_to_string path ^ " tip:" ^ Tip.to_string tip); - match ProcessCmt.file_for_module ~package module_name with + match Process_cmt.file_for_module ~package module_name with | None -> None | Some file -> ( - let env = QueryEnv.from_file file in + let env = Query_env.from_file file in match exported_for_tip ~env ~path ~package ~tip with | None -> None | Some (env, _name, stamp) -> @@ -392,7 +392,7 @@ let definition_for_loc_item ~full:{file; package} loc_item = definition ~file:env.file ~package stamp tip)) let dig_constructor ~env ~package path = - match ResolvePath.resolve_from_compiler_path ~env ~package path with + match Resolve_path.resolve_from_compiler_path ~env ~package path with | NotFound -> None | Stamp stamp -> ( match Stamps.find_type env.file.stamps stamp with @@ -412,7 +412,7 @@ let type_definition_for_loc_item ~full:{file; package} loc_item = | Constant _ | TopLevelModule _ | LModule _ -> None | TypeDefinition _ -> Some (file.uri, loc_item.loc) | Typed (_, typ, _) -> ( - let env = QueryEnv.from_file file in + let env = Query_env.from_file file in match Shared.dig_constructor typ with | None -> None | Some path -> ( @@ -423,7 +423,7 @@ let type_definition_for_loc_item ~full:{file; package} loc_item = let is_visible (declared : _ Declared.t) = declared.is_exported && - let rec loop (v : ModulePath.t) = + let rec loop (v : Module_path.t) = match v with | File _ -> true | NotVisible -> false @@ -438,7 +438,7 @@ type references = { } let for_local_stamp ~full:{file; extra; package} stamp (tip : Tip.t) = - let env = QueryEnv.from_file file in + let env = Query_env.from_file file in match match tip with | Constructor name -> @@ -485,12 +485,12 @@ let for_local_stamp ~full:{file; extra; package} stamp (tip : Tip.t) = also find the references in that file *) in let path = - ModulePath.to_path declared.module_path declared.name.txt + 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 |> FileSet.elements + 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 @@ -525,16 +525,16 @@ 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 |> FileSet.elements + package.project_files |> File_set.elements |> Utils.filter_map (fun name -> - match ProcessCmt.file_for_module ~package name with + 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 |> LocationSet.elements + locs |> Location_set.elements |> List.map (fun loc -> { uri = Uri.from_path loc.Location.loc_start.pos_fname; @@ -560,10 +560,10 @@ let all_references_for_loc_item ~full:({file; package} as full) loc_item = for_local_stamp ~full stamp tip | LModule (GlobalReference (module_name, path, tip)) | Typed (_, _, GlobalReference (module_name, path, tip)) -> ( - match ProcessCmt.file_for_module ~package module_name with + match Process_cmt.file_for_module ~package module_name with | None -> [] | Some file -> ( - let env = QueryEnv.from_file file in + let env = Query_env.from_file file in match exported_for_tip ~env ~path ~package ~tip with | None -> [] | Some (env, _name, stamp) -> ( diff --git a/analysis/src/ResolvePath.ml b/analysis/src/resolve_path.ml similarity index 83% rename from analysis/src/ResolvePath.ml rename to analysis/src/resolve_path.ml index fd6a8b7bbf..9393269359 100644 --- a/analysis/src/ResolvePath.ml +++ b/analysis/src/resolve_path.ml @@ -1,7 +1,7 @@ -open SharedTypes +open Shared_types type resolution = - | Exported of QueryEnv.t * file_path + | Exported of Query_env.t * file_path | Global of file_path * file_path list | GlobalMod of file_path | NotFound @@ -13,7 +13,7 @@ let rec join_paths module_path path = | Papply (fn_path, _argPath) -> join_paths fn_path path | Pdot (inner, name, _) -> join_paths inner (name :: path) -let rec make_path ~(env : QueryEnv.t) module_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 @@ -33,7 +33,7 @@ let rec make_path ~(env : QueryEnv.t) module_path = | Some (`Global (module_name, full_path)) -> Global (module_name, full_path))) -and resolve_path_inner ~(env : QueryEnv.t) ~path = +and resolve_path_inner ~(env : Query_env.t) ~path = match path with | [] -> None | [name] -> Some (`Local (env, name)) @@ -45,10 +45,10 @@ and resolve_path_inner ~(env : QueryEnv.t) ~path = | None -> None | Some {item} -> find_in_module ~env item sub_path)) -and find_in_module ~(env : QueryEnv.t) module_ path = +and find_in_module ~(env : Query_env.t) module_ path = match module_ with | Structure structure -> - resolve_path_inner ~env:(QueryEnv.enter_structure env structure) ~path + 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 @@ -69,12 +69,12 @@ let rec resolve_path ~env ~path ~package = Log.log ("resolvePath Global path:" ^ path_to_string full_path ^ " module:" ^ module_name); - match ProcessCmt.file_for_module ~package module_name with + match Process_cmt.file_for_module ~package module_name with | None -> None | Some file -> - resolve_path ~env:(QueryEnv.from_file file) ~path:full_path ~package)) + resolve_path ~env:(Query_env.from_file file) ~path:full_path ~package)) -let from_compiler_path ~(env : QueryEnv.t) path : resolution = +let from_compiler_path ~(env : Query_env.t) path : resolution = match make_path ~env path with | Stamp stamp -> Stamp stamp | GlobalMod name -> GlobalMod name @@ -85,10 +85,10 @@ let from_compiler_path ~(env : QueryEnv.t) path : resolution = let resolve_module_from_compiler_path ~env ~package path = match from_compiler_path ~env path with | Global (module_name, path) -> ( - match ProcessCmt.file_for_module ~package module_name with + match Process_cmt.file_for_module ~package module_name with | None -> None | Some file -> ( - let env = QueryEnv.from_file file in + let env = Query_env.from_file file in match resolve_path ~env ~package ~path with | None -> None | Some (env, name) -> ( @@ -103,10 +103,10 @@ let resolve_module_from_compiler_path ~env ~package path = | None -> None | Some declared -> Some (env, Some declared)) | GlobalMod module_name -> ( - match ProcessCmt.file_for_module ~package module_name with + match Process_cmt.file_for_module ~package module_name with | None -> None | Some file -> - let env = QueryEnv.from_file file in + let env = Query_env.from_file file in Some (env, None)) | NotFound -> None | Exported (env, name) -> ( @@ -121,10 +121,10 @@ let resolve_from_compiler_path ~env ~package path = match from_compiler_path ~env path with | Global (module_name, path) -> ( let res = - match ProcessCmt.file_for_module ~package module_name with + match Process_cmt.file_for_module ~package module_name with | None -> None | Some file -> - let env = QueryEnv.from_file file in + let env = Query_env.from_file file in resolve_path ~env ~package ~path in match res with @@ -135,7 +135,7 @@ let resolve_from_compiler_path ~env ~package path = | NotFound -> NotFound | Exported (env, name) -> Exported (env, name) -let rec get_source_uri ~(env : QueryEnv.t) ~package (path : ModulePath.t) = +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 diff --git a/analysis/src/Scope.ml b/analysis/src/scope.ml similarity index 96% rename from analysis/src/Scope.ml rename to analysis/src/scope.ml index 84d46be6c6..115cdcca8a 100644 --- a/analysis/src/Scope.ml +++ b/analysis/src/scope.ml @@ -1,8 +1,8 @@ -type item = SharedTypes.ScopeTypes.item +type item = Shared_types.Scope_types.item type t = item list -open SharedTypes.ScopeTypes +open Shared_types.Scope_types let item_to_string item = let str s = if s = "" then "\"\"" else s in @@ -31,7 +31,7 @@ let add_value ~name ~loc ?context_path x = | Some context_path -> if show_debug then Printf.printf "adding value '%s' with ctxPath: %s\n" name - (SharedTypes.Completable.context_path_to_string context_path)); + (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 diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/semantic_tokens.ml similarity index 100% rename from analysis/src/SemanticTokens.ml rename to analysis/src/semantic_tokens.ml diff --git a/analysis/src/Shared.ml b/analysis/src/shared.ml similarity index 94% rename from analysis/src/Shared.ml rename to analysis/src/shared.ml index 858b12b4ee..d5467fc228 100644 --- a/analysis/src/Shared.ml +++ b/analysis/src/shared.ml @@ -60,7 +60,7 @@ let find_type_constructors (tel : Types.type_expr list) = !paths |> List.rev let decl_to_string ?print_name_as_is ?(rec_status = Types.Trec_not) name t = - PrintType.print_decl ?print_name_as_is ~rec_status name t + Print_type.print_decl ?print_name_as_is ~rec_status name t let cache_type_to_string = ref false let type_tbl = Hashtbl.create 1 @@ -70,7 +70,7 @@ let type_to_string ?line_width (t : Types.type_expr) = if !cache_type_to_string then Hashtbl.find_opt type_tbl (t.id, t) else None with | None -> - let s = PrintType.print_expr ?line_width t in + 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/SharedTypes.ml b/analysis/src/shared_types.ml similarity index 96% rename from analysis/src/SharedTypes.ml rename to analysis/src/shared_types.ml index 332a693f88..7685e8cd5b 100644 --- a/analysis/src/SharedTypes.ml +++ b/analysis/src/shared_types.ml @@ -8,7 +8,7 @@ type typed_fn_arg = Asttypes.arg_label * Types.type_expr let path_to_string (path : path) = path |> String.concat "." -module ModulePath = struct +module Module_path = struct type t = | File of Uri.t * string | NotVisible @@ -158,7 +158,7 @@ module Declared = struct name: string Location.loc; extent_loc: Location.t; stamp: int; - module_path: ModulePath.t; + module_path: Module_path.t; is_exported: bool; deprecated: string option; docstring: string list; @@ -294,7 +294,7 @@ module File = struct } end -module QueryEnv : sig +module Query_env : sig type t = private { file: File.t; exported: Exported.t; @@ -347,7 +347,7 @@ end = struct end type type_arg_context = { - env: QueryEnv.t; + env: Query_env.t; type_args: Types.type_expr list; type_params: Types.type_expr list; } @@ -363,32 +363,32 @@ type inner_type = | TypeExpr of Types.type_expr | ExtractedType of completion_type and completion_type = - | 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 * inner_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: QueryEnv.t; + env: Query_env.t; ok_type: Types.type_expr; error_type: Types.type_expr; } - | Tbool of QueryEnv.t - | Tarray of QueryEnv.t * inner_type - | Tstring of QueryEnv.t - | TtypeT of {env: QueryEnv.t; path: Path.t} + | 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: QueryEnv.t; + env: Query_env.t; constructors: Constructor.t list; variant_decl: Types.type_declaration; variant_name: string; } | Tpolyvariant of { - env: QueryEnv.t; + env: Query_env.t; constructors: poly_variant_constructor list; type_expr: Types.type_expr; } | Trecord of { - env: QueryEnv.t; + env: Query_env.t; fields: field list; definition: [ `NameOnly of string @@ -396,16 +396,16 @@ and completion_type = | `TypeExpr of Types.type_expr (** When we have the full type expr from the compiler. *) ]; } - | TinlineRecord of {env: QueryEnv.t; fields: field list} + | TinlineRecord of {env: Query_env.t; fields: field list} | Tfunction of { - env: QueryEnv.t; + 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: ModulePath.t} + type t = {stamps: Stamps.t; module_path: Module_path.t} let add_exported_module ~name ~is_type env = { env with @@ -499,7 +499,7 @@ type loc_type = type loc_item = {loc: Location.t; loc_type: loc_type} -module LocationSet = Set.Make (struct +module Location_set = Set.Make (struct include Location let compare loc1 loc2 = compare loc2 loc1 @@ -511,29 +511,29 @@ 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, LocationSet.t) Hashtbl.t; + file_references: (string, Location_set.t) Hashtbl.t; mutable loc_items: loc_item list; } type file = string -module FileSet = Set.Make (String) +module File_set = Set.Make (String) type package = { generic_jsx_module: string option; suffix: string; root_path: file_path; - project_files: FileSet.t; - dependencies_files: FileSet.t; + 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.StringMap.t; + autocomplete: file list Misc.String_map.t; } let all_files_in_package package = - FileSet.union package.project_files package.dependencies_files + File_set.union package.project_files package.dependencies_files type full = {extra: extra; file: File.t; package: package} @@ -804,7 +804,7 @@ module Completable = struct | ChtmlElement {prefix} -> "ChtmlElement <" ^ prefix end -module ScopeTypes = struct +module Scope_types = struct type item = | Constructor of string * Location.t | Field of string * Location.t @@ -840,7 +840,7 @@ module Completion = struct | FileModule of string | Snippet of string | ExtractedType of completion_type * [`Value | `Type] - | FollowContextPath of Completable.context_path * ScopeTypes.item list + | FollowContextPath of Completable.context_path * Scope_types.item list type t = { name: string; @@ -848,7 +848,7 @@ module Completion = struct insert_text: string option; filter_text: string option; insert_text_format: Lsp.Types.InsertTextFormat.t option; - env: QueryEnv.t; + env: Query_env.t; deprecated: string option; docstring: string list; kind: kind; @@ -904,7 +904,7 @@ let kind_from_inner_type (t : inner_type) = Completion.ExtractedType (extracted_type, `Value) | TypeExpr typ -> Value typ -module CursorPosition = struct +module Cursor_position = struct type t = NoCursor | HasCursor | EmptyLoc let classify_loc loc ~pos = diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/signature_help.ml similarity index 96% rename from analysis/src/SignatureHelp.ml rename to analysis/src/signature_help.ml index a50d729582..75ca8897df 100644 --- a/analysis/src/SignatureHelp.ml +++ b/analysis/src/signature_help.ml @@ -1,4 +1,4 @@ -open SharedTypes +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. *) @@ -24,7 +24,7 @@ let docs_for_label type_expr ~file ~package ~supports_markdown_links = in let type_name = if multiple_types_have_this_name then - path |> SharedTypes.path_ident_to_string + path |> Shared_types.path_ident_to_string else name in Markdown.code_block @@ -39,7 +39,7 @@ let find_function_type ~debug ~source ~kind_file ~pos ~full = | None -> None | Some full -> ( let {file; package} = full in - let env = QueryEnv.from_file file in + 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)} -> ( @@ -52,7 +52,7 @@ let find_function_type ~debug ~source ~kind_file ~pos ~full = Printf.printf "[sig_help_fn] Found loc item: %s.\n" (Shared.type_to_string type_expr); match - TypeUtils.extract_function_type2 ~env ~package:full.package type_expr + Type_utils.extract_function_type2 ~env ~package:full.package type_expr with | args, _tRet, _ when args <> [] -> Some (args, docstring, type_expr, package, env, file) @@ -79,14 +79,14 @@ let find_function_type ~debug ~source ~kind_file ~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.completion_with_parser ~debug ~source ~kind_file - ~pos_cursor:pos + Completion_front_end.completion_with_parser ~debug ~source + ~kind_file ~pos_cursor:pos with | None -> None | Some (completable, scope) -> Some ( completable - |> CompletionBackEnd.process_completable ~debug ~full ~pos + |> Completion_back_end.process_completable ~debug ~full ~pos ~scope ~env ~for_hover:true, env, package, @@ -95,7 +95,7 @@ let find_function_type ~debug ~source ~kind_file ~pos ~full = match completables with | Some ({kind = Value type_expr; docstring} :: _, env, package, file) -> let args, _, _ = - TypeUtils.extract_function_type2 type_expr ~env ~package + Type_utils.extract_function_type2 type_expr ~env ~package in Some (args, docstring, type_expr, package, env, file) | _ -> None)) @@ -188,7 +188,7 @@ let find_constructor_args ~full ~env ~constructor_name loc = with | None -> None | Some {loc_type = Typed (_, typ_expr, _)} -> ( - match TypeUtils.extract_type ~env ~package:full.package typ_expr with + match Type_utils.extract_type ~env ~package:full.package typ_expr with | Some ((Toption (_, TypeExpr t) as extracted_type), _) -> ( match constructor_name with | "Some" -> @@ -198,7 +198,7 @@ let find_constructor_args ~full ~env ~constructor_name loc = docstring = [ Markdown.code_block - (TypeUtils.extracted_type_to_string extracted_type); + (Type_utils.extracted_type_to_string extracted_type); ]; args = Args [(t, Location.none)]; } @@ -212,7 +212,7 @@ let find_constructor_args ~full ~env ~constructor_name loc = docstring = [ Markdown.code_block - (TypeUtils.extracted_type_to_string extracted_type); + (Type_utils.extracted_type_to_string extracted_type); ]; args = Args [(ok_type, Location.none)]; } @@ -223,7 +223,7 @@ let find_constructor_args ~full ~env ~constructor_name loc = docstring = [ Markdown.code_block - (TypeUtils.extracted_type_to_string extracted_type); + (Type_utils.extracted_type_to_string extracted_type); ]; args = Args [(error_type, Location.none)]; } @@ -253,7 +253,7 @@ let signature_help ~debug ~source ~kind_file ~pos else None in let loc_has_cursor loc = - loc |> CursorPosition.loc_has_cursor ~pos:pos_before_cursor + loc |> Cursor_position.loc_has_cursor ~pos:pos_before_cursor in let supports_markdown_links = true in let result = ref None in @@ -320,7 +320,7 @@ let signature_help ~debug ~source ~kind_file ~pos (* Check for the label identifier itself having the cursor *) match pos - |> CursorPosition.classify_positions ~pos_start ~pos_end + |> Cursor_position.classify_positions ~pos_start ~pos_end with | HasCursor -> Some (Labelled name) | NoCursor | EmptyLoc -> ( @@ -331,8 +331,8 @@ let signature_help ~debug ~source ~kind_file ~pos match ( arg.exp.pexp_desc, arg.exp.pexp_loc - |> CursorPosition.classify_loc ~pos:pos_before_cursor - ) + |> Cursor_position.classify_loc + ~pos:pos_before_cursor ) with | Pexp_extension ({txt = "rescript.exprhole"}, _), _ | _, HasCursor -> @@ -401,7 +401,7 @@ let signature_help ~debug ~source ~kind_file ~pos (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 - || CompletionExpressions.is_expr_hole payload_exp + || Completion_expressions.is_expr_hole payload_exp && loc_has_cursor pexp_loc -> (* Constructor payloads *) set_result (lid.loc, `ConstructorExpr (lid, payload_exp)) @@ -544,7 +544,7 @@ let signature_help ~debug ~source ~kind_file ~pos None | Some full -> ( let {file} = full in - let env = QueryEnv.from_file file in + let env = Query_env.from_file file in let constructor_name = Longident.last lid.txt in match find_constructor_args ~full ~env ~constructor_name diff --git a/analysis/src/StructureUtils.ml b/analysis/src/structure_utils.ml similarity index 94% rename from analysis/src/StructureUtils.ml rename to analysis/src/structure_utils.ml index 97c1d17b2d..895dab2d50 100644 --- a/analysis/src/StructureUtils.ml +++ b/analysis/src/structure_utils.ml @@ -1,4 +1,4 @@ -open SharedTypes +open Shared_types let unique_items (structure : Module.structure) : Module.item list = let names_used = Hashtbl.create 10 in diff --git a/analysis/src/TypeUtils.ml b/analysis/src/type_utils.ml similarity index 97% rename from analysis/src/TypeUtils.ml rename to analysis/src/type_utils.ml index 0d9933b74e..826276bad0 100644 --- a/analysis/src/TypeUtils.ml +++ b/analysis/src/type_utils.ml @@ -1,7 +1,7 @@ -open SharedTypes +open Shared_types let module_path_from_env env = - let module_name = env.QueryEnv.file.module_name in + 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) *) @@ -17,7 +17,7 @@ let module_path_from_env env = transformed_module_name :: List.rev env.path_rev let full_type_id_from_decl ~env ~name ~module_path = - env.QueryEnv.file.module_name :: ModulePath.to_path module_path name + 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} = @@ -81,7 +81,7 @@ let rec extracted_type_to_string ?(name_only = false) ?(inner = false) = if inner then try typ |> path_from_type_expr |> Option.get - |> SharedTypes.path_ident_to_string + |> Shared_types.path_ident_to_string with _ -> "" else Shared.type_to_string typ | Trecord {definition; fields} -> @@ -90,7 +90,7 @@ let rec extracted_type_to_string ?(name_only = false) ?(inner = false) = | `TypeExpr typ -> ( try typ |> path_from_type_expr |> Option.get - |> SharedTypes.path_ident_to_string + |> Shared_types.path_ident_to_string with _ -> "") | `NameOnly name -> name in @@ -505,7 +505,7 @@ let is_function_type ~env ~package t = | Some (Tfunction _, _) -> true | _ -> false -let find_return_type_of_function_at_loc loc ~(env : QueryEnv.t) ~full ~debug = +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 @@ -917,7 +917,7 @@ let get_args ~env (t : Types.type_expr) ~full = | 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, _, _) -> - (SharedTypes.Completable.Labelled l, t_arg) + (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) @@ -964,7 +964,7 @@ let rec context_path_from_core_type (core_type : Parsetree.core_type) = }) | _ -> None -let unwrap_completion_type_if_option (t : SharedTypes.completion_type) = +let unwrap_completion_type_if_option (t : Shared_types.completion_type) = match t with | Toption (_, ExtractedType unwrapped) -> unwrapped | _ -> t @@ -989,7 +989,7 @@ module Codegen = struct | Tvariant v -> Some (v.constructors - |> List.map (fun (c : SharedTypes.Constructor.t) -> + |> List.map (fun (c : Shared_types.Constructor.t) -> mk_construct_pat ?payload: (match c.args with @@ -999,7 +999,7 @@ module Codegen = struct | Tpolyvariant v -> Some (v.constructors - |> List.map (fun (c : SharedTypes.poly_variant_constructor) -> + |> List.map (fun (c : Shared_types.poly_variant_constructor) -> mk_tag_pat ?payload: (match c.args with @@ -1084,14 +1084,14 @@ module Codegen = struct Ast_helper.Exp.case pat (mk_fail_with_exp ()))) end -let get_module_path_relative_to_env ~debug ~(env : QueryEnv.t) ~env_from_item +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 = - QueryEnv.path_from_env env_from_item (List.rev path_rev) + Query_env.path_from_env env_from_item (List.rev path_rev) in if debug then Printf.printf "CPPipe pathFromEnv:%s found:%b\n" @@ -1135,16 +1135,16 @@ let path_to_element_props package = | None -> ["ReactDOM"; "domProps"] | Some g -> (g |> String.split_on_char '.') @ ["Elements"; "props"] -module StringSet = Set.Make (String) +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 StringSet.empty in + let found_module_paths = ref String_set.empty in let add_to_module_paths attributes = - ProcessAttributes.find_editor_complete_from_attribute attributes + Process_attributes.find_editor_complete_from_attribute attributes |> List.iter (fun e -> found_module_paths := - StringSet.add (e |> String.concat ".") !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 @@ -1158,7 +1158,7 @@ let get_extra_modules_to_complete_from_for_type ~env ~full (t : Types.type_expr) | None -> () in inner ~env ~full t; - !found_module_paths |> StringSet.elements + !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 = @@ -1235,7 +1235,7 @@ let rec find_root_type_id ~full ~env (t : Types.type_expr) = Printf.printf "[findRootTypeId] dug up named type at module path %s, from item: %s \n" (module_path_from_env env |> String.concat ".") - (ModulePath.to_path module_path name |> 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.*) @@ -1284,7 +1284,7 @@ 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.QueryEnv.file.module_name + = env_completion_is_made_from.Query_env.file.module_name then List.tl completion_path else completion_path diff --git a/analysis/src/Uri.ml b/analysis/src/uri.ml similarity index 100% rename from analysis/src/Uri.ml rename to analysis/src/uri.ml diff --git a/analysis/src/Uri.mli b/analysis/src/uri.mli similarity index 100% rename from analysis/src/Uri.mli rename to analysis/src/uri.mli diff --git a/analysis/src/Utils.ml b/analysis/src/utils.ml similarity index 100% rename from analysis/src/Utils.ml rename to analysis/src/utils.ml diff --git a/analysis/src/Xform.ml b/analysis/src/xform.ml similarity index 91% rename from analysis/src/Xform.ml rename to analysis/src/xform.ml index 00ef5a94c0..8b78dee94b 100644 --- a/analysis/src/Xform.ml +++ b/analysis/src/xform.ml @@ -5,25 +5,26 @@ 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 - |> CompletionFrontEnd.find_type_of_expression_at_loc ~debug ~source + |> 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 = SharedTypes.QueryEnv.from_file full.SharedTypes.file in + let env = Shared_types.Query_env.from_file full.Shared_types.file in let completions = completable - |> CompletionBackEnd.process_completable ~debug ~full ~pos ~scope ~env + |> 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 = - CompletionBackEnd.get_opens ~debug ~raw_opens ~package:full.package ~env + Completion_back_end.get_opens ~debug ~raw_opens ~package:full.package + ~env in match - CompletionBackEnd.completions_get_completion_type2 ~debug ~full + Completion_back_end.completions_get_completion_type2 ~debug ~full ~raw_opens ~opens ~pos completions with | Some (typ, _env) -> @@ -31,15 +32,15 @@ let extract_type_from_expr expr ~debug ~source ~kind_file ~full ~pos = match typ with | ExtractedType t -> Some t | TypeExpr t -> - TypeUtils.extract_type t ~env ~package:full.package - |> TypeUtils.get_extracted_type + Type_utils.extract_type t ~env ~package:full.package + |> Type_utils.get_extracted_type in extracted_type | None -> None) | _ -> None) | _ -> None -module IfThenElse = struct +module If_then_else = struct (* Convert if-then-else to switch *) let rec list_to_pat ~item_to_pat = function @@ -143,13 +144,13 @@ module IfThenElse = struct let range = Loc.range_of_loc new_expr.pexp_loc in let new_text = print_expr ~range new_expr in let code_action = - CodeActions.make ~title:"Replace with switch" ~kind:RefactorRewrite + Code_actions.make ~title:"Replace with switch" ~kind:RefactorRewrite ~uri:path ~new_text ~range in code_actions := code_action :: !code_actions end -module ModuleToFile = struct +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) = @@ -201,7 +202,7 @@ module ModuleToFile = struct in changed := Some - (CodeActions.make_with_document_changes + (Code_actions.make_with_document_changes ~title: (Printf.sprintf "Extract local module \"%s\" to file \"%s\"" module_name (module_name ^ ".res")) @@ -224,7 +225,7 @@ module ModuleToFile = struct | Some code_action -> code_actions := code_action :: !code_actions end -module AddBracesToFn = struct +module Add_braces_to_fn = struct (* Add braces to fn without braces *) let mk_iterator ~pos ~changed = @@ -283,13 +284,13 @@ module AddBracesToFn = struct 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 = - CodeActions.make ~title:"Add braces to function" ~kind:RefactorRewrite + Code_actions.make ~title:"Add braces to function" ~kind:RefactorRewrite ~uri:path ~new_text ~range in code_actions := code_action :: !code_actions end -module AddTypeAnnotation = struct +module Add_type_annotation = struct (* Add type annotation to value declaration *) type annotation = Plain | WithParens @@ -355,14 +356,14 @@ module AddTypeAnnotation = struct "(" ^ name ^ ": " ^ (typ |> Shared.type_to_string) ^ ")" ) in let code_action = - CodeActions.make ~title:"Add type annotation" ~kind:RefactorRewrite + Code_actions.make ~title:"Add type annotation" ~kind:RefactorRewrite ~uri:path ~new_text ~range in code_actions := code_action :: !code_actions | _ -> ())) end -module ExpandCatchAllForVariants = struct +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 @@ -426,13 +427,13 @@ module ExpandCatchAllForVariants = struct | Some (Tvariant {constructors}) -> let missing_constructors = constructors - |> List.filter (fun (c : SharedTypes.Constructor.t) -> + |> 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 : SharedTypes.Constructor.t) -> + |> List.map (fun (c : Shared_types.Constructor.t) -> c.cname.txt ^ match c.args with @@ -442,7 +443,7 @@ module ExpandCatchAllForVariants = struct in let range = Loc.range_of_loc catch_all_case.pc_lhs.ppat_loc in let code_action = - CodeActions.make ~title:"Expand catch-all" ~kind:RefactorRewrite + Code_actions.make ~title:"Expand catch-all" ~kind:RefactorRewrite ~uri:path ~new_text ~range in code_actions := code_action :: !code_actions @@ -450,13 +451,13 @@ module ExpandCatchAllForVariants = struct | Some (Tpolyvariant {constructors}) -> let missing_constructors = constructors - |> List.filter (fun (c : SharedTypes.poly_variant_constructor) -> + |> 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 : SharedTypes.poly_variant_constructor) -> + |> List.map (fun (c : Shared_types.poly_variant_constructor) -> Res_printer.polyvar_ident_to_string c.name ^ match c.args with @@ -466,7 +467,7 @@ module ExpandCatchAllForVariants = struct in let range = Loc.range_of_loc catch_all_case.pc_lhs.ppat_loc in let code_action = - CodeActions.make ~title:"Expand catch-all" ~kind:RefactorRewrite + Code_actions.make ~title:"Expand catch-all" ~kind:RefactorRewrite ~uri:path ~new_text ~range in code_actions := code_action :: !code_actions @@ -479,7 +480,7 @@ module ExpandCatchAllForVariants = struct match inner_type with | ExtractedType t -> Some t | TypeExpr t -> ( - match TypeUtils.extract_type ~env ~package:full.package t with + match Type_utils.extract_type ~env ~package:full.package t with | None -> None | Some (t, _) -> Some t) in @@ -499,7 +500,7 @@ module ExpandCatchAllForVariants = struct match variant with | Tvariant {constructors} -> constructors - |> List.filter_map (fun (c : SharedTypes.Constructor.t) -> + |> List.filter_map (fun (c : Shared_types.Constructor.t) -> if current_constructor_names |> List.mem c.cname.txt = false then @@ -512,7 +513,7 @@ module ExpandCatchAllForVariants = struct | Tpolyvariant {constructors} -> constructors |> List.filter_map - (fun (c : SharedTypes.poly_variant_constructor) -> + (fun (c : Shared_types.poly_variant_constructor) -> if current_constructor_names |> List.mem c.name = false then Some @@ -537,7 +538,7 @@ module ExpandCatchAllForVariants = struct in let range = Loc.range_of_loc catch_all_case.pc_lhs.ppat_loc in let code_action = - CodeActions.make ~title:"Expand catch-all" ~kind:RefactorRewrite + Code_actions.make ~title:"Expand catch-all" ~kind:RefactorRewrite ~uri:path ~new_text ~range in code_actions := code_action :: !code_actions @@ -546,7 +547,7 @@ module ExpandCatchAllForVariants = struct | _ -> ()) end -module ExhaustiveSwitch = struct +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 @@ -621,10 +622,10 @@ module ExhaustiveSwitch = struct with | None -> () | Some extracted_type -> ( - let open TypeUtils.Codegen in + let open Type_utils.Codegen in let exhaustive_switch = extracted_type_to_exhaustive_cases - ~env:(SharedTypes.QueryEnv.from_file full.file) + ~env:(Shared_types.Query_env.from_file full.file) ~full extracted_type in match exhaustive_switch with @@ -635,7 +636,7 @@ module ExhaustiveSwitch = struct print_expr ~range {expr with pexp_desc = Pexp_match (expr, cases)} in let code_action = - CodeActions.make ~title:"Exhaustive switch" ~kind:RefactorRewrite + Code_actions.make ~title:"Exhaustive switch" ~kind:RefactorRewrite ~uri:path ~new_text ~range in code_actions := code_action :: !code_actions)) @@ -646,10 +647,10 @@ module ExhaustiveSwitch = struct with | None -> () | Some extracted_type -> ( - let open TypeUtils.Codegen in + let open Type_utils.Codegen in let exhaustive_switch = extracted_type_to_exhaustive_cases - ~env:(SharedTypes.QueryEnv.from_file full.file) + ~env:(Shared_types.Query_env.from_file full.file) ~full extracted_type in match exhaustive_switch with @@ -661,13 +662,13 @@ module ExhaustiveSwitch = struct {switch_expr with pexp_desc = Pexp_match (completion_expr, cases)} in let code_action = - CodeActions.make ~title:"Exhaustive switch" ~kind:RefactorRewrite + Code_actions.make ~title:"Exhaustive switch" ~kind:RefactorRewrite ~uri:path ~new_text ~range in code_actions := code_action :: !code_actions)) end -module AddDocTemplate = struct +module Add_doc_template = struct let create_template () = let doc_content = ["\n"; "\n"] in let expression = @@ -696,13 +697,13 @@ module AddDocTemplate = struct match item.psig_desc with | Psig_value value_description as r when Loc.has_pos ~pos value_description.pval_loc - && ProcessAttributes.find_doc_attribute + && 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 - && ProcessAttributes.find_doc_attribute hd.ptype_attributes + && Process_attributes.find_doc_attribute hd.ptype_attributes = None -> result := Some (r, item.psig_loc) | Psig_module {pmd_name = {loc}} as r -> @@ -759,7 +760,7 @@ module AddDocTemplate = struct let range = Loc.range_of_loc signature_item.psig_loc in let new_text = print_signature_item ~range signature_item in let code_action = - CodeActions.make ~title:"Add Documentation template" + Code_actions.make ~title:"Add Documentation template" ~kind:RefactorRewrite ~uri:path ~new_text ~range in code_actions := code_action :: !code_actions @@ -774,11 +775,11 @@ module AddDocTemplate = struct match si.pstr_desc with | Pstr_value (_, {pvb_pat = {ppat_loc}; pvb_attributes} :: _) as r when Loc.has_pos ~pos ppat_loc - && ProcessAttributes.find_doc_attribute pvb_attributes = None -> + && 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 - && ProcessAttributes.find_doc_attribute + && Process_attributes.find_doc_attribute value_description.pval_attributes = None -> result := Some (r, si.pstr_loc) @@ -787,7 +788,7 @@ module AddDocTemplate = struct else Ast_iterator.default_iterator.structure_item iterator si | Pstr_type (_, hd :: _) as r when Loc.has_pos ~pos hd.ptype_loc - && ProcessAttributes.find_doc_attribute hd.ptype_attributes + && Process_attributes.find_doc_attribute hd.ptype_attributes = None -> result := Some (r, si.pstr_loc) | _ -> Ast_iterator.default_iterator.structure_item iterator si @@ -847,7 +848,7 @@ module AddDocTemplate = struct let range = Loc.range_of_loc structure_item.pstr_loc in let new_text = print_structure_item ~range structure_item in let code_action = - CodeActions.make ~title:"Add Documentation template" + Code_actions.make ~title:"Add Documentation template" ~kind:RefactorRewrite ~uri:path ~new_text ~range in code_actions := code_action :: !code_actions @@ -920,21 +921,23 @@ let extract_code_actions ~path ~start_pos ~end_pos ~source ~kind_file ~debug = = parse_implementation ~source in - IfThenElse.xform ~pos ~code_actions ~print_expr ~path structure; - ModuleToFile.xform ~pos ~code_actions ~path ~print_standalone_structure + If_then_else.xform ~pos ~code_actions ~print_expr ~path structure; + Module_to_file.xform ~pos ~code_actions ~path ~print_standalone_structure structure; - AddBracesToFn.xform ~pos ~code_actions ~path ~print_structure_item structure; - AddDocTemplate.Implementation.xform ~pos ~code_actions ~path + 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 -> - AddTypeAnnotation.xform ~path ~pos ~full ~structure ~code_actions ~debug; - ExpandCatchAllForVariants.xform ~path ~source ~kind_file ~pos ~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; - ExhaustiveSwitch.xform ~print_expr ~path ~source ~kind_file + 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)) @@ -945,7 +948,7 @@ let extract_code_actions ~path ~start_pos ~end_pos ~source ~kind_file ~debug = !code_actions | Resi -> let signature, print_signature_item = parse_interface ~source in - AddDocTemplate.Interface.xform ~pos ~code_actions ~path ~signature + Add_doc_template.Interface.xform ~pos ~code_actions ~path ~signature ~print_signature_item; !code_actions | Other -> [] diff --git a/analysis/src/YojsonHelpers.ml b/analysis/src/yojson_helpers.ml similarity index 100% rename from analysis/src/YojsonHelpers.ml rename to analysis/src/yojson_helpers.ml diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index 67fbc0043d..419bdd4c5f 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_exp_make.ml b/compiler/core/js_exp_make.ml index 210c0a58dd..530765477e 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 ec208532a5..d37d55ea9a 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 5f4e4e6c76..ec7ef0c2e6 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 1415a14c52..1fe994506c 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 9897f0c01e..97f6bec84e 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 c6341e743d..636f0a254b 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 0516fb1beb..036ff98e38 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 9e53b4cbd4..a3342d52f2 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 d63856aa07..46f99d25d3 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 8e4a1cb283..6dc9294833 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 9c66678b38..06aa96fcd4 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 7913263c67..187b608fbd 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 11a70fa3ae..3679ebac1f 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 e4049c6c00..17f5e7b9fd 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 7a72efa2e1..1d5f232e3f 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 54e5777b8b..d391dd276b 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 eb3ce62954..ec193bfb00 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 5cdf1fdb7a..e2c09c0565 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 9923927fda..57138b2cde 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 a4eafea44e..dd0d8361af 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 ed5d41654a..4457545bca 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 dcc8d94983..fb7d51858c 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 f44a63cc5b..ae4c2a3e1d 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 0a1604f36f..8181124e10 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 c52efa3dd7..b85639b6f9 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 4d34a0fa28..59dc0ed448 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 94% rename from compiler/gentype/Paths.ml rename to compiler/gentype/paths.ml index f058e238ec..20371e2b4e 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,7 +43,7 @@ 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 relative_path = @@ -56,7 +56,7 @@ let get_output_file ~(config : Config.t) source_path = 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 79e737d35e..0f58b11580 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 e8b14e21e9..8fe4729a8e 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 d220a0a7b5..36f73ddb29 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 882aa87ba6..2c6d39b407 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 9271f41a90..d7a8ec4c9b 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 8672a95c39..be847c6f52 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 f0f89f943a..1b3ad813f8 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 9d12689871..01fe26c658 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 3bf09ca0fa..b4a4825321 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 c80b413350..eb82b72ee7 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 adbdaa6c48..821d412a09 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 724bfbc5f9..c881e088b1 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 98508da4f6..ef695a9f08 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 0a750bdda6..a78cf8c3eb 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 0970b4b3ee..7953771b4c 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 06673db5ed..d63fb29632 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 2af606a084..dc72b0578f 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 ef099af22b..02a04a7e06 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 ccc2129d88..b11b67c367 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -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, _, _) @@ -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/datarepr.ml b/compiler/ml/datarepr.ml index df16f61971..44e2ba9afa 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 43a625160b..3b00ff9e5a 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 b4fb4c884e..aa41f121e5 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 970634be03..0626ba5552 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 48eaba1c10..66b8e3192b 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 662157b1ef..b30faa2e0b 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 a111bc388f..33078a59fd 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 b55caf8c36..0440d20c7f 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 b84339aed9..916646ea08 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 449d89ae5a..4ed00e0054 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 b86364445f..4ae23724fb 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 40105e0258..da6a3b25b1 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 diff --git a/compiler/ml/record_type_spread.ml b/compiler/ml/record_type_spread.ml index bf7b286dd2..0156db4b99 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 b30d32c611..6956e90d49 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 9626f060c5..80bb69e7c5 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 6b89d29bb7..77617eda5d 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 87471ac26b..eded92c102 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 4f0b3be38e..1073ffcf89 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 0f44d4595f..4c73d9a3ca 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 72c24352b9..6f48bcd620 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 17adaa67f5..df070ca05b 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 0932c62f34..ac1ae9f30c 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 eeca29aa83..9f443f3c5f 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 cb9bf06664..598030ff12 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 201a3ac31e..1723492707 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/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index 8f8ebdb0bb..ff5b1a42c1 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 bd2e73ba56..9741d3ece6 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 @@ -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 4c79ff0f8f..b075b9ffa0 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 @@ -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}, @@ -3104,7 +3104,7 @@ and parse_jsx_children p : Parsetree.jsx_children = match p.Parser.token with | DotDotDot -> 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 @@ -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 301c0520bd..b56c2bee20 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 09bfa4196c..49e6c29862 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 020aff850b..1e9a3f5a73 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/tests/ounit_tests/ounit_scc_tests.ml b/tests/ounit_tests/ounit_scc_tests.ml index e0bb9f33a0..281c6491bc 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/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 1a7d2ffffa..53370e4a13 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 505637dd04..699dd5fbca 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 b3cec197c6..bf4df8cecd 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -92,13 +92,13 @@ let main () = root_path)) | Some package -> let module_names = - Analysis.SharedTypes.FileSet.elements package.project_files + Analysis.Shared_types.File_set.elements package.project_files in let files = module_names |> List.filter_map (fun mod_name -> Hashtbl.find_opt package.paths_for_module mod_name - |> Option.map Analysis.SharedTypes.get_src) + |> Option.map Analysis.Shared_types.get_src) |> List.concat |> List.filter (fun path -> Filename.check_suffix path ".res" @@ -144,7 +144,7 @@ let main () = let output_mode = if is_stdout then `Stdout else `File in Clflags.color := Some Misc.Color.Never; match - ( Tools.FormatCodeblocks.format_code_blocks_in_file ~output_mode + ( Tools.Format_codeblocks.format_code_blocks_in_file ~output_mode ~transform_assert_equal ~entry_point_file:path, output_mode ) with @@ -160,7 +160,7 @@ let main () = Clflags.color := Some Misc.Color.Never; (* TODO: Add result/JSON mode *) - Tools.ExtractCodeblocks.extract_codeblocks_from_file + Tools.Extract_codeblocks.extract_codeblocks_from_file ~transform_assert_equal ~entry_point_file:path |> log_and_exit | _ -> log_and_exit (Error extract_codeblocks_help)) @@ -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,7 +213,7 @@ let main () = Sys.argv.(i) <- Sys.argv.(i + 1) done; Sys.argv.(len - 1) <- ""; - Reanalyze.ReanalyzeServer.server_cli ~parse_argv:Reanalyze.parse_argv + Reanalyze.Reanalyze_server.server_cli ~parse_argv:Reanalyze.parse_argv ~run_analysis:Reanalyze.run_analysis () | "extract-embedded" :: ext_point_names :: filename :: _ -> log_and_exit diff --git a/tools/src/migrate.ml b/tools/src/migrate.ml index 185f9629d7..30bba2094f 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 @@ -583,7 +585,7 @@ let make_mapper (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 make_mapper (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 make_mapper (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,10 +729,10 @@ let make_mapper (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); } @@ -762,7 +765,7 @@ let migrate ~entry_point_file ~output_mode = 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 diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 0385474c10..521d3f833f 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -1,6 +1,6 @@ open Analysis -module StringSet = Set.Make (String) +module String_set = Set.Make (String) type field_doc = { field_name: string; @@ -269,7 +269,7 @@ and stringify_docs_for_module ~original_env (d : docs_for_module) = | Some d -> [("deprecated", `String d)] | None -> []) -let field_to_field_doc (field : SharedTypes.field) : field_doc = +let field_to_field_doc (field : Shared_types.field) : field_doc = { field_name = field.fname.txt; docstrings = field.docstring; @@ -279,8 +279,8 @@ let field_to_field_doc (field : SharedTypes.field) : field_doc = } let type_detail typ ~env ~full = - let open SharedTypes in - match TypeUtils.extract_type_from_resolved_type ~env ~full typ with + let open Shared_types in + match Type_utils.extract_type_from_resolved_type ~env ~full typ with | Some (Trecord {fields}) -> Some (Record {field_docs = fields |> List.map field_to_field_doc}) | Some (Tvariant {constructors}) -> @@ -293,7 +293,7 @@ let type_detail typ ~env ~full = { constructor_name = c.cname.txt; docstrings = c.docstring; - signature = CompletionBackEnd.show_constructor c; + signature = Completion_back_end.show_constructor c; deprecated = c.deprecated; items = (match c.args with @@ -362,7 +362,7 @@ let value_detail (typ : Types.type_expr) = Some (Signature {parameters; return_type}) let make_id module_path ~identifier = - identifier :: module_path |> List.rev |> SharedTypes.ident + identifier :: module_path |> List.rev |> Shared_types.ident let get_source ~root_path ({loc_start} : Location.t) = let line, col = Pos.of_lexing loc_start in @@ -382,12 +382,12 @@ let extract_docs ~entry_point_file ~debug = if debug then Printf.printf "extracting docs for %s\n" path; let result = match - FindFiles.is_implementation path = false - && FindFiles.is_interface path = false + Find_files.is_implementation path = false + && Find_files.is_interface path = false with | false -> ( let path = - if FindFiles.is_implementation path then + if Find_files.is_implementation path then let path_as_resi = (path |> Filename.dirname) ^ "/" ^ (path |> Filename.basename |> Filename.chop_extension) @@ -411,11 +411,11 @@ let extract_docs ~entry_point_file ~debug = let file = full.file in let structure = file.structure in let root_path = full.package.root_path in - let open SharedTypes in - let env = QueryEnv.from_file file 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 values_seen = ref StringSet.empty in + let values_seen = ref String_set.empty in { id = module_path |> List.rev |> ident; docstring = structure.docstring |> List.map String.trim; @@ -480,7 +480,7 @@ let extract_docs ~entry_point_file ~debug = in let items, internal_docstrings = match - ProcessCmt.file_for_module ~package:full.package + Process_cmt.file_for_module ~package:full.package alias_to_module with | None -> ([], []) @@ -552,7 +552,7 @@ let extract_docs ~entry_point_file ~debug = let module_type_id_path = match - ProcessCmt.file_for_module ~package:full.package + Process_cmt.file_for_module ~package:full.package ident_module_path |> Option.is_none with @@ -575,9 +575,9 @@ let extract_docs ~entry_point_file ~debug = |> List.filter_map (fun (doc_item : doc_item) -> match doc_item with | Value {id} -> - if StringSet.mem id !values_seen then None + if String_set.mem id !values_seen then None else ( - values_seen := StringSet.add id !values_seen; + values_seen := String_set.add id !values_seen; Some doc_item) | _ -> Some doc_item) |> List.rev; @@ -655,7 +655,7 @@ let is_res_lang 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 *) @@ -929,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 @@ -1010,12 +1010,12 @@ module ExtractCodeblocks = struct in let result = match - FindFiles.is_implementation path = false - && FindFiles.is_interface path = false + Find_files.is_implementation path = false + && Find_files.is_interface path = false with | false -> ( let path = - if FindFiles.is_implementation path then + if Find_files.is_implementation path then let path_as_resi = (path |> Filename.dirname) ^ "/" ^ (path |> Filename.basename |> Filename.chop_extension) @@ -1033,8 +1033,8 @@ module ExtractCodeblocks = struct | Some full -> let file = full.file in let structure = file.structure in - let open SharedTypes in - let env = QueryEnv.from_file file in + 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) = From 4d84626297b837a3b7af037f2855fb260754c7b8 Mon Sep 17 00:00:00 2001 From: Pedro Castro Date: Sun, 31 May 2026 13:30:18 -0300 Subject: [PATCH 4/5] Fix conlifct from #8454 --- analysis/reanalyze/src/paths.ml | 6 +- analysis/reanalyze/src/reanalyze.ml | 2 +- .../{YojsonHelpers.ml => yojson_helpers.ml} | 0 analysis/src/FindFiles.ml | 342 ------------------ analysis/src/Packages.ml | 227 ------------ analysis/src/find_files.ml | 43 ++- analysis/src/packages.ml | 2 +- analysis/src/yojson_helpers.ml | 2 +- .../ounit_analysis_config_tests.ml | 19 +- 9 files changed, 40 insertions(+), 603 deletions(-) rename analysis/reanalyze/src/{YojsonHelpers.ml => yojson_helpers.ml} (100%) delete mode 100644 analysis/src/FindFiles.ml delete mode 100644 analysis/src/Packages.ml diff --git a/analysis/reanalyze/src/paths.ml b/analysis/reanalyze/src/paths.ml index 87dbfbf68b..b25b29e401 100644 --- a/analysis/reanalyze/src/paths.ml +++ b/analysis/reanalyze/src/paths.ml @@ -154,14 +154,14 @@ let read_cmt_scan () = 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 diff --git a/analysis/reanalyze/src/reanalyze.ml b/analysis/reanalyze/src/reanalyze.ml index 04cc62c9b3..652716f0fb 100644 --- a/analysis/reanalyze/src/reanalyze.ml +++ b/analysis/reanalyze/src/reanalyze.ml @@ -779,4 +779,4 @@ module Reanalyze_server = Reanalyze_server 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/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/FindFiles.ml b/analysis/src/FindFiles.ml deleted file mode 100644 index 07a5a35eda..0000000000 --- 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/Packages.ml b/analysis/src/Packages.ml deleted file mode 100644 index d07bfa1785..0000000000 --- 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/find_files.ml b/analysis/src/find_files.ml index 16d0c3a183..9bc0711126 100644 --- a/analysis/src/find_files.ml +++ b/analysis/src/find_files.ml @@ -11,14 +11,14 @@ let get_source_directories ~include_dev ~base_dir config = | `Assoc _ -> ( let dir = item |> Yojson_helpers.get "dir" - |> bind Yojson.Safe.Util.to_string_option + |> 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.Safe.Util.to_string_option + |> bind Yojson_helpers.string_opt |> Option.value ~default:"lib" in @@ -94,22 +94,27 @@ let name_space_to_name n = |> 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 = - let ns = config |> Yojson_helpers.get "namespace" in - let from_string = ns |> bind Yojson.Safe.Util.to_string_option in - let is_namespaced = - ns - |> bind Yojson.Safe.Util.to_bool_option - |> Option.value ~default:(from_string |> Option.is_some) - in - let either x y = if x = None then y else x in - if is_namespaced then - let from_name = - config |> Yojson_helpers.get "name" - |> bind Yojson.Safe.Util.to_string_option + 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 - either from_string from_name |> Option.map name_space_to_name - else None + fromName |> Option.map name_space_to_name module String_set = Set.Make (String) @@ -123,7 +128,7 @@ let get_public config = | Some public -> Some (public - |> List.filter_map Yojson.Safe.Util.to_string_option + |> List.filter_map Yojson_helpers.string_opt |> String_set.of_list)) let collect_files directory = @@ -272,7 +277,7 @@ let find_dependency_files base config = with | None, None -> [] | Some deps, None | _, Some deps -> - deps |> List.filter_map Yojson.Safe.Util.to_string_option + deps |> List.filter_map Yojson_helpers.string_opt in let dev_deps = match @@ -285,7 +290,7 @@ let find_dependency_files base config = with | None, None -> [] | Some dev_deps, None | _, Some dev_deps -> - dev_deps |> List.filter_map (fun x -> Some (Yojson.Safe.Util.to_string x)) + dev_deps |> List.filter_map Yojson_helpers.string_opt in let deps = deps @ dev_deps in Log.log ("Dependencies: " ^ String.concat " " deps); diff --git a/analysis/src/packages.ml b/analysis/src/packages.ml index 0007375e05..3a5068f177 100644 --- a/analysis/src/packages.ml +++ b/analysis/src/packages.ml @@ -152,7 +152,7 @@ let new_bs_package ~root_path = let opens_from_compiler_flags = List.fold_left (fun opens item -> - match item |> Yojson.Safe.Util.to_string_option with + match item |> Yojson_helpers.string_opt with | None -> opens | Some s -> ( let parts = String.split_on_char ' ' s in diff --git a/analysis/src/yojson_helpers.ml b/analysis/src/yojson_helpers.ml index bca4f707eb..b45b7331e6 100644 --- a/analysis/src/yojson_helpers.ml +++ b/analysis/src/yojson_helpers.ml @@ -1 +1 @@ -include Reanalyze.YojsonHelpers +include Reanalyze.Yojson_helpers diff --git a/tests/ounit_tests/ounit_analysis_config_tests.ml b/tests/ounit_tests/ounit_analysis_config_tests.ml index 57cc3dbdd2..9cf524f452 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 _ -> From 5b839a3f76db9b0ef3babe01ac06ffa95b873146 Mon Sep 17 00:00:00 2001 From: Pedro Castro Date: Sun, 31 May 2026 14:10:05 -0300 Subject: [PATCH 5/5] Update CHANGELOG.md --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index b9f45bdab8..7419ec7935 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