From 8acea619f4e5249043242c153595a35fab772e6d Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 28 Aug 2026 08:10:30 +0200 Subject: [PATCH] Upgrade OCamlformat to 0.29 Signed-off-by: Christoph Knittel --- .ocamlformat | 2 +- analysis/reactive/src/reactive.ml | 22 +- .../reactive/src/reactive_file_collection.ml | 8 +- analysis/reactive/test/batch_test.ml | 6 +- .../test/fixpoint_incremental_test.ml | 24 +- analysis/reanalyze/src/arnold.ml | 222 +++--- analysis/reanalyze/src/collect_annotations.ml | 8 +- analysis/reanalyze/src/cross_file_items.ml | 10 +- analysis/reanalyze/src/dce_file_processing.ml | 10 +- analysis/reanalyze/src/dead_common.ml | 374 +++++------ analysis/reanalyze/src/dead_optional_args.ml | 12 +- analysis/reanalyze/src/dead_type.ml | 38 +- analysis/reanalyze/src/dead_value.ml | 85 ++- analysis/reanalyze/src/declarations.ml | 4 +- analysis/reanalyze/src/exception.ml | 28 +- analysis/reanalyze/src/exn_lib.ml | 10 +- analysis/reanalyze/src/file_annotations.ml | 4 +- analysis/reanalyze/src/file_deps.ml | 12 +- analysis/reanalyze/src/log_.ml | 18 +- analysis/reanalyze/src/name.ml | 4 +- analysis/reanalyze/src/paths.ml | 24 +- analysis/reanalyze/src/reactive_analysis.ml | 18 +- analysis/reanalyze/src/reactive_decl_refs.ml | 8 +- analysis/reanalyze/src/reactive_merge.ml | 2 +- analysis/reanalyze/src/reactive_solver.ml | 6 +- analysis/reanalyze/src/reactive_type_deps.ml | 12 +- analysis/reanalyze/src/reanalyze.ml | 76 +-- analysis/reanalyze/src/side_effects.ml | 4 +- analysis/src/cli.ml | 124 ++-- analysis/src/cmt.ml | 2 +- analysis/src/cmt_viewer.ml | 52 +- analysis/src/codemod.ml | 2 +- analysis/src/commands.ml | 38 +- analysis/src/completion_back_end.ml | 634 +++++++++--------- analysis/src/completion_expressions.ml | 16 +- analysis/src/completion_front_end.ml | 178 ++--- analysis/src/completion_jsx.ml | 57 +- analysis/src/completion_patterns.ml | 28 +- analysis/src/create_interface.ml | 81 ++- analysis/src/diagnostics.ml | 35 +- analysis/src/document_symbol.ml | 4 +- analysis/src/dot_completion_utils.ml | 40 +- analysis/src/dump_ast.ml | 26 +- analysis/src/files.ml | 10 +- analysis/src/find_files.ml | 212 +++--- analysis/src/hint.ml | 80 +-- analysis/src/hover.ml | 78 ++- analysis/src/local_tables.ml | 40 +- analysis/src/packages.ml | 14 +- analysis/src/process_attributes.ml | 18 +- analysis/src/process_cmt.ml | 76 +-- analysis/src/process_extra.ml | 152 ++--- analysis/src/references.ml | 57 +- analysis/src/scope.ml | 4 +- analysis/src/semantic_tokens.ml | 2 +- analysis/src/shared_types.ml | 8 +- analysis/src/signature_help.ml | 321 +++++---- analysis/src/structure_utils.ml | 8 +- analysis/src/type_utils.ml | 172 +++-- analysis/src/utils.ml | 4 +- analysis/src/xform.ml | 63 +- compiler/core/ir_diagnostics.ml | 4 +- compiler/core/js_analyzer.ml | 4 +- compiler/core/js_dump.ml | 18 +- compiler/core/js_dump_import_export.ml | 12 +- compiler/core/js_dump_program.ml | 4 +- compiler/core/js_exp_make.ml | 14 +- .../core/js_pass_flatten_and_mark_dead.ml | 8 +- compiler/core/js_pass_scope.ml | 4 +- compiler/core/js_source_map.ml | 32 +- compiler/core/lam_compile.ml | 45 +- compiler/core/lam_compile_primitive.ml | 8 +- compiler/core/lam_pass_remove_alias.ml | 12 +- compiler/core/polyvar_pattern_match.ml | 15 +- compiler/ext/ext_modulename.ml | 4 +- compiler/ext/ext_string.ml | 4 +- compiler/ext/ident.ml | 8 +- compiler/ext/warnings.ml | 16 +- compiler/frontend/ast_config.ml | 12 +- compiler/gentype/converter.ml | 2 +- compiler/gentype/emit_js.ml | 66 +- compiler/gentype/emit_type.ml | 128 ++-- compiler/gentype/gentype_common.ml | 20 +- compiler/gentype/gentype_main.ml | 16 +- compiler/gentype/module_name.ml | 4 +- compiler/gentype/module_resolver.ml | 52 +- compiler/gentype/translate_core_type.ml | 68 +- compiler/gentype/translate_structure.ml | 16 +- .../gentype/translate_type_declarations.ml | 98 +-- .../gentype/translate_type_expr_from_types.ml | 148 ++-- compiler/gentype/translation.ml | 63 +- compiler/gentype/type_env.ml | 8 +- compiler/gentype/type_vars.ml | 6 +- compiler/jsoo/jsoo_playground_main.ml | 99 ++- compiler/ml/ast_mapper_from0.ml | 8 +- compiler/ml/ast_mapper_to0.ml | 41 +- compiler/ml/builtin_attributes.ml | 36 +- compiler/ml/code_frame.ml | 165 +++-- compiler/ml/ctype.ml | 17 +- compiler/ml/dict_type_helpers.ml | 2 +- compiler/ml/env.ml | 12 +- compiler/ml/includecore.ml | 16 +- compiler/ml/parmatch.ml | 4 +- compiler/ml/printtyp.ml | 16 +- compiler/ml/record_type_spread.ml | 14 +- compiler/ml/translcore.ml | 25 +- compiler/ml/typecore.ml | 44 +- compiler/ml/typedecl.ml | 35 +- compiler/ml/variant_coercion.ml | 38 +- compiler/ml/variant_type_spread.ml | 153 +++-- compiler/syntax/src/jsx_v4.ml | 133 ++-- compiler/syntax/src/res_comments_table.ml | 18 +- compiler/syntax/src/res_core.ml | 60 +- compiler/syntax/src/res_outcome_printer.ml | 12 +- compiler/syntax/src/res_parsetree_viewer.ml | 4 +- compiler/syntax/src/res_printer.ml | 28 +- dune-project | 2 +- rescript.opam | 2 +- tests/ounit_tests/ounit_hash_stubs_test.ml | 2 +- tests/ounit_tests/ounit_scc_tests.ml | 18 +- tests/syntax_benchmarks/benchmark.ml | 40 +- tools/bin/main.ml | 8 +- tools/src/migrate.ml | 96 +-- tools/src/tools.ml | 492 +++++++------- 124 files changed, 3077 insertions(+), 3169 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index 19fa7d86b8f..42b1afdaecf 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,5 +1,5 @@ profile = default -version = 0.27.0 +version = 0.29.0 field-space = tight-decl break-cases = toplevel diff --git a/analysis/reactive/src/reactive.ml b/analysis/reactive/src/reactive.ml index 9a12f90fd96..f8f4a9a2c95 100644 --- a/analysis/reactive/src/reactive.ml +++ b/analysis/reactive/src/reactive.ml @@ -360,9 +360,9 @@ module Scheduler = struct let nodes_with_levels = dirty |> List.filter_map (fun name -> - match Hashtbl.find_opt Registry.nodes name with - | Some info -> Some (info.Registry.level, name, info) - | None -> None) + match Hashtbl.find_opt Registry.nodes name with + | Some info -> Some (info.Registry.level, name, info) + | None -> None) in let sorted = @@ -875,10 +875,10 @@ let join ~name (left : ('k1, 'v1) t) (right : ('k2, 'v2) t) ~key_of ~f ?merge () let output_entries = !all_affected |> List.filter_map (fun k3 -> - if Hashtbl.mem seen k3 then None - else ( - Hashtbl.replace seen k3 (); - recompute_target k3)) + if Hashtbl.mem seen k3 then None + else ( + Hashtbl.replace seen k3 (); + recompute_target k3)) in if output_entries <> [] then ( @@ -1010,10 +1010,10 @@ let union ~name (left : ('k, 'v) t) (right : ('k, 'v) t) ?merge () : ('k, 'v) t let output_entries = !all_affected |> List.filter_map (fun k -> - if Hashtbl.mem seen k then None - else ( - Hashtbl.replace seen k (); - recompute_target k)) + if Hashtbl.mem seen k then None + else ( + Hashtbl.replace seen k (); + recompute_target k)) in if output_entries <> [] then ( diff --git a/analysis/reactive/src/reactive_file_collection.ml b/analysis/reactive/src/reactive_file_collection.ml index bcae68a0b79..5ac4ab1ae2e 100644 --- a/analysis/reactive/src/reactive_file_collection.ml +++ b/analysis/reactive/src/reactive_file_collection.ml @@ -87,10 +87,10 @@ let remove_batch t paths = let entries = paths |> List.filter_map (fun path -> - if Hashtbl.mem t.internal.cache path then ( - Hashtbl.remove t.internal.cache path; - Some (path, None)) - else None) + if Hashtbl.mem t.internal.cache path then ( + Hashtbl.remove t.internal.cache path; + Some (path, None)) + else None) in if entries <> [] then emit t (Reactive.Batch entries); List.length entries diff --git a/analysis/reactive/test/batch_test.ml b/analysis/reactive/test/batch_test.ml index ad49c5dfeb7..45ab2a96ebb 100644 --- a/analysis/reactive/test/batch_test.ml +++ b/analysis/reactive/test/batch_test.ml @@ -55,9 +55,9 @@ let test_batch_fixpoint () = incr batch_count; entries |> List.iter (fun (_, v_opt) -> - match v_opt with - | Some () -> incr total_added - | None -> ()) + match v_opt with + | Some () -> incr total_added + | None -> ()) | Set (_, ()) -> incr total_added | Remove _ -> ()) fp; diff --git a/analysis/reactive/test/fixpoint_incremental_test.ml b/analysis/reactive/test/fixpoint_incremental_test.ml index 3f0e8d803d1..7166065c657 100644 --- a/analysis/reactive/test/fixpoint_incremental_test.ml +++ b/analysis/reactive/test/fixpoint_incremental_test.ml @@ -31,9 +31,9 @@ let test_fixpoint_add_base () = | Batch entries -> entries |> List.iter (fun (k, v_opt) -> - match v_opt with - | Some () -> added := k :: !added - | None -> removed := k :: !removed)) + match v_opt with + | Some () -> added := k :: !added + | None -> removed := k :: !removed)) fp; emit_init (Set ("c", ())); @@ -299,9 +299,9 @@ let test_fixpoint_remove_spurious_root () = | Batch entries -> entries |> List.iter (fun (k, v_opt) -> - match v_opt with - | Some () -> added := k :: !added - | None -> removed := k :: !removed)) + match v_opt with + | Some () -> added := k :: !added + | None -> removed := k :: !removed)) fp; (* Step 1: "b" is spuriously marked as a root *) @@ -429,9 +429,9 @@ let test_fixpoint_remove_edge_rederivation () = | Batch entries -> entries |> List.iter (fun (k, v_opt) -> - match v_opt with - | Some () -> added := k :: !added - | None -> removed := k :: !removed)) + match v_opt with + | Some () -> added := k :: !added + | None -> removed := k :: !removed)) fp; (* Add root *) @@ -542,9 +542,9 @@ let test_fixpoint_remove_edge_entry_higher_rank_support () = | Batch entries -> entries |> List.iter (fun (k, v_opt) -> - match v_opt with - | Some () -> added := k :: !added - | None -> removed := k :: !removed)) + match v_opt with + | Some () -> added := k :: !added + | None -> removed := k :: !removed)) fp; (* Add root *) diff --git a/analysis/reanalyze/src/arnold.ml b/analysis/reanalyze/src/arnold.ml index 1116f1223c9..9c3591febb1 100644 --- a/analysis/reanalyze/src/arnold.ml +++ b/analysis/reanalyze/src/arnold.ml @@ -60,10 +60,10 @@ module Function_call = struct function_args = t.function_args |> List.map (fun (arg : Function_args.arg) -> - { - arg with - function_name = arg.function_name |> substitute_name ~sub; - }); + { + arg with + function_name = arg.function_name |> substitute_name ~sub; + }); } let no_args function_name = {function_name; function_args = []} @@ -283,8 +283,8 @@ end = struct let to_string x = ((match x.some with - | None -> [] - | Some p -> ["some: " ^ Progress.to_string p]) + | None -> [] + | Some p -> ["some: " ^ Progress.to_string p]) @ match x.none with | None -> [] @@ -492,11 +492,11 @@ module Function_table = struct in definitions |> List.iteri (fun i (function_name, kind, body) -> - Format.fprintf ppf "@,@{%d@} @{%s%s@}: %s" (i + 1) - function_name (Kind.to_string kind) - (match body with - | Some command -> Command.to_string command - | None -> "None")); + Format.fprintf ppf "@,@{%d@} @{%s%s@}: %s" (i + 1) + function_name (Kind.to_string kind) + (match body with + | Some command -> Command.to_string command + | None -> "None")); Format.fprintf ppf "@]" let dump tbl = Format.fprintf Format.std_formatter "%a@." print tbl @@ -630,25 +630,24 @@ module Extend_function_table = struct let function_name = Path.name callee in args |> List.iter (fun ((arg_label : Asttypes.arg_label), arg_opt) -> - match (arg_label, arg_opt |> extract_labelled_argument) with - | Labelled {txt = label}, Some (path, loc) - when path - |> Function_table.is_in_function_in_table ~function_table - -> - function_table - |> Function_table.add_label_to_kind ~function_name ~label; - if config.Dce_config.cli.debug then - Log_.warning ~for_stats:false ~loc - (Termination - { - termination = TerminationAnalysisInternal; - message = - Format.asprintf - "@{%s@} is parametric \ - ~@{%s@}=@{%s@}" - function_name label (Path.name path); - }) - | _ -> ()) + match (arg_label, arg_opt |> extract_labelled_argument) with + | Labelled {txt = label}, Some (path, loc) + when path + |> Function_table.is_in_function_in_table ~function_table -> + function_table + |> Function_table.add_label_to_kind ~function_name ~label; + if config.Dce_config.cli.debug then + Log_.warning ~for_stats:false ~loc + (Termination + { + termination = TerminationAnalysisInternal; + message = + Format.asprintf + "@{%s@} is parametric \ + ~@{%s@}=@{%s@}" + function_name label (Path.name path); + }) + | _ -> ()) | _ -> ()); super.expr self e in @@ -680,50 +679,47 @@ module Check_expression_well_formed = struct let function_name = Path.name function_path in args |> List.iter (fun ((arg_label : Asttypes.arg_label), arg_opt) -> - match - arg_opt |> Extend_function_table.extract_labelled_argument - with - | Some (path, loc) -> ( - match arg_label with - | Labelled {txt = label} -> ( - if - function_table - |> Function_table.function_get_kind_of_label ~function_name - ~label - <> None - then () - else - match - Hashtbl.find_opt value_bindings_table function_name - with - | Some (_pos, (body : Typedtree.expression), _) - when path - |> Function_table.is_in_function_in_table - ~function_table -> - let in_table = - function_path + match + arg_opt |> Extend_function_table.extract_labelled_argument + with + | Some (path, loc) -> ( + match arg_label with + | Labelled {txt = label} -> ( + if + function_table + |> Function_table.function_get_kind_of_label ~function_name + ~label + <> None + then () + else + match Hashtbl.find_opt value_bindings_table function_name with + | Some (_pos, (body : Typedtree.expression), _) + when path |> Function_table.is_in_function_in_table - ~function_table - in - if not in_table then - function_table - |> Function_table.add_function ~function_name; - function_table - |> Function_table.add_label_to_kind ~function_name ~label; - if config.Dce_config.cli.debug then - Log_.warning ~for_stats:false ~loc:body.exp_loc - (Termination - { - termination = TerminationAnalysisInternal; - message = - Format.asprintf - "Extend Function Table with @{%s@} \ - as parametric ~@{%s@}=@{%s@}" - function_name label (Path.name path); - }) - | _ -> check_ident ~path ~loc) - | Optional _ | Nolabel -> check_ident ~path ~loc) - | _ -> ()); + ~function_table -> + let in_table = + function_path + |> Function_table.is_in_function_in_table ~function_table + in + if not in_table then + function_table + |> Function_table.add_function ~function_name; + function_table + |> Function_table.add_label_to_kind ~function_name ~label; + if config.Dce_config.cli.debug then + Log_.warning ~for_stats:false ~loc:body.exp_loc + (Termination + { + termination = TerminationAnalysisInternal; + message = + Format.asprintf + "Extend Function Table with @{%s@} as \ + parametric ~@{%s@}=@{%s@}" + function_name label (Path.name path); + }) + | _ -> check_ident ~path ~loc) + | Optional _ | Nolabel -> check_ident ~path ~loc) + | _ -> ()); e | _ -> super.expr self e in @@ -778,14 +774,14 @@ module Compile = struct let args_from_kind = inner_function_definition.kind |> List.map (fun (entry : Kind.entry) -> - ( Asttypes.Labelled {txt = entry.label; loc = Location.none}, - Some - { - expr with - exp_desc = - Texp_ident - (Path.Pident (Ident.create entry.label), l, vd); - } )) + ( Asttypes.Labelled {txt = entry.label; loc = Location.none}, + Some + { + expr with + exp_desc = + Texp_ident + (Path.Pident (Ident.create entry.label), l, vd); + } )) in ( Path.Pident (Ident.create inner_function_name), args_from_kind @ args_to_extend ) @@ -802,9 +798,9 @@ module Compile = struct let arg_opt = args |> List.find_opt (fun arg -> - match arg with - | Asttypes.Labelled {txt = s}, Some _ -> s = label - | _ -> false) + match arg with + | Asttypes.Labelled {txt = s}, Some _ -> s = label + | _ -> false) in let arg_opt = match arg_opt with @@ -909,7 +905,7 @@ module Compile = struct let commands = (value_bindings |> List.map (fun (vb : Typedtree.value_binding) -> - vb.vb_expr |> expression ~ctx)) + vb.vb_expr |> expression ~ctx)) @ [in_expr |> expression ~ctx] in Command.sequence commands @@ -1081,9 +1077,9 @@ module Call_stack = struct in frames |> List.iter (fun ((function_call : Function_call.t), i, pos) -> - Format.fprintf ppf "\n @{%d@} %s (%a)" i - (Function_call.to_string function_call) - print_pos pos) + Format.fprintf ppf "\n @{%d@} %s (%a)" i + (Function_call.to_string function_call) + print_pos pos) end module Eval = struct @@ -1235,9 +1231,9 @@ module Eval = struct let states = commands |> List.map (fun c -> - c - |> run ~config ~cache ~call_stack ~function_args ~function_table - ~made_progress_on ~state:state_no_trace) + c + |> run ~config ~cache ~call_stack ~function_args ~function_table + ~made_progress_on ~state:state_no_trace) in State.seq state (states |> State.unordered_sequence) | Nondet commands -> @@ -1246,9 +1242,9 @@ module Eval = struct let states = commands |> List.map (fun c -> - c - |> run ~config ~cache ~call_stack ~function_args ~function_table - ~made_progress_on ~state:state_no_trace) + c + |> run ~config ~cache ~call_stack ~function_args ~function_table + ~made_progress_on ~state:state_no_trace) in State.seq state (states |> State.nondet) | SwitchOption {function_call; loc; some; none} -> ( @@ -1314,8 +1310,8 @@ let progress_functions_from_attributes attributes = | Some (TuplePayload l) -> l |> List.filter_map (function - | Annotation.IdentPayload lid -> Some (lid_to_string lid) - | _ -> None) + | Annotation.IdentPayload lid -> Some (lid_to_string lid) + | _ -> None) | _ -> []) else None @@ -1325,14 +1321,12 @@ let traverse_ast ~config ~value_bindings_table = (* Update the table of value bindings for variables *) value_bindings |> List.iter (fun (vb : Typedtree.value_binding) -> - match vb.vb_pat.pat_desc with - | Tpat_var (id, {loc = {loc_start = pos}}) -> - let callees = - lazy (Find_functions_called.find_callees vb.vb_expr) - in - Hashtbl.replace value_bindings_table (Ident.name id) - (pos, vb.vb_expr, callees) - | _ -> ()); + match vb.vb_pat.pat_desc with + | Tpat_var (id, {loc = {loc_start = pos}}) -> + let callees = lazy (Find_functions_called.find_callees vb.vb_expr) in + Hashtbl.replace value_bindings_table (Ident.name id) + (pos, vb.vb_expr, callees) + | _ -> ()); let progress_functions, functions_to_analyze = if rec_flag = Asttypes.Nonrecursive then (String_set.empty, []) else @@ -1385,17 +1379,17 @@ let traverse_ast ~config ~value_bindings_table = in recursive_definitions |> List.iter (fun (function_name, _body) -> - function_table |> Function_table.add_function ~function_name); + function_table |> Function_table.add_function ~function_name); recursive_definitions |> List.iter (fun (_, body) -> - body - |> Extend_function_table.run ~config ~function_table - ~progress_functions ~value_bindings_table); + body + |> Extend_function_table.run ~config ~function_table + ~progress_functions ~value_bindings_table); recursive_definitions |> List.iter (fun (_, body) -> - body - |> Check_expression_well_formed.run ~config ~function_table - ~value_bindings_table); + body + |> Check_expression_well_formed.run ~config ~function_table + ~value_bindings_table); function_table |> Hashtbl.iter (fun @@ -1425,13 +1419,13 @@ let traverse_ast ~config ~value_bindings_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); + 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); + super.value_binding self value_binding |> ignore); (rec_flag, value_bindings) in {super with Tast_mapper.value_bindings} diff --git a/analysis/reanalyze/src/collect_annotations.ml b/analysis/reanalyze/src/collect_annotations.ml index 1e05fcfef08..14619462f21 100644 --- a/analysis/reanalyze/src/collect_annotations.ml +++ b/analysis/reanalyze/src/collect_annotations.ml @@ -34,10 +34,10 @@ let process_attributes ~(scope_default : scope_default) ~state ~config let fname_len = String.length fname in config.Dce_config.cli.live_paths |> List.exists (fun prefix -> - String.length prefix <= fname_len - && - try String.sub fname 0 (String.length prefix) = prefix - with Invalid_argument _ -> false) + String.length prefix <= fname_len + && + try String.sub fname 0 (String.length prefix) = prefix + with Invalid_argument _ -> false) in if get_payload live_annotation <> None || name_is_in_live_names_or_paths () then File_annotations.annotate_live state pos; diff --git a/analysis/reanalyze/src/cross_file_items.ml b/analysis/reanalyze/src/cross_file_items.ml index 6d0554a12dc..9af6393c6b6 100644 --- a/analysis/reanalyze/src/cross_file_items.ml +++ b/analysis/reanalyze/src/cross_file_items.ml @@ -97,8 +97,8 @@ let builder_to_t (builder : builder) : t = let process_exception_refs (t : t) ~refs ~file_deps ~find_exception ~config = t.exception_refs |> List.iter (fun {exception_path; loc_from} -> - match find_exception exception_path with - | None -> () - | Some loc_to -> - Dead_common.add_value_reference ~config ~refs ~file_deps - ~binding:Location.none ~add_file_reference:true ~loc_from ~loc_to) + match find_exception exception_path with + | None -> () + | Some loc_to -> + Dead_common.add_value_reference ~config ~refs ~file_deps + ~binding:Location.none ~add_file_reference:true ~loc_from ~loc_to) diff --git a/analysis/reanalyze/src/dce_file_processing.ml b/analysis/reanalyze/src/dce_file_processing.ml index b305a33d0ed..64478b12399 100644 --- a/analysis/reanalyze/src/dce_file_processing.ml +++ b/analysis/reanalyze/src/dce_file_processing.ml @@ -30,11 +30,11 @@ let process_signature ~config ~decls ~(file : file_context) ~do_values ~do_types in signature |> List.iter (fun sig_item -> - Dead_value.process_signature_item ~config ~decls ~file:dead_common_file - ~do_values ~do_types ~module_loc:Location.none - ~module_path:Module_path.initial - ~path:[module_name_tagged file] - sig_item) + Dead_value.process_signature_item ~config ~decls ~file:dead_common_file + ~do_values ~do_types ~module_loc:Location.none + ~module_path:Module_path.initial + ~path:[module_name_tagged file] + sig_item) (* ===== Main entry point ===== *) diff --git a/analysis/reanalyze/src/dead_common.ml b/analysis/reanalyze/src/dead_common.ml index a3f39096f8e..5161e14b6d2 100644 --- a/analysis/reanalyze/src/dead_common.ml +++ b/analysis/reanalyze/src/dead_common.ml @@ -232,8 +232,8 @@ let report_declaration ~config ~has_ref_below ?check_module_dead ?should_report let should_emit_warning = (not inside_reported_value) && (match decl.path with - | name :: _ when name |> Name.is_underscore -> Config.report_underscore - | _ -> true) + | name :: _ when name |> Name.is_underscore -> Config.report_underscore + | _ -> true) && (config.Dce_config.run.transitive || not (has_ref_below decl)) in if should_emit_warning then @@ -324,138 +324,134 @@ let solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state all_decls |> List.iter (fun (decl : Decl.t) -> - let pos = decl.pos in - let live_reason = Liveness.get_live_reason ~live pos in - let is_live = Option.is_some live_reason in - let is_dead = not is_live in + let pos = decl.pos in + let live_reason = Liveness.get_live_reason ~live pos in + let is_live = Option.is_some live_reason in + let is_dead = not is_live in - (* Debug output (forward model): + (* Debug output (forward model): show reachability + why (root/propagated), and a compact dependency summary (incoming/outgoing declaration edges). *) - if debug then ( - let status = - match live_reason with - | None -> "Dead" - | Some reason -> - Printf.sprintf "Live (%s)" (Liveness.reason_to_string reason) - in - Log_.item "%s %s %s@." status - (decl.decl_kind |> Decl.Kind.to_string) - (decl.path |> Dce_path.to_string); - (* Print dependency context to help understand why a decl is (not) live. + if debug then ( + let status = + match live_reason with + | None -> "Dead" + | Some reason -> + Printf.sprintf "Live (%s)" (Liveness.reason_to_string reason) + in + Log_.item "%s %s %s@." status + (decl.decl_kind |> Decl.Kind.to_string) + (decl.path |> Dce_path.to_string); + (* Print dependency context to help understand why a decl is (not) live. This is declaration-to-declaration deps only, derived from refs_from. *) - let outgoing_to_decls = - match Pos_hash.find_opt decl_refs_index pos with - | None -> 0 - | Some (value_targets, type_targets) -> - let count_targets targets = - Pos_set.fold - (fun target acc -> - match Declaration_store.find_opt decl_store target with - | Some _ -> acc + 1 - | None -> acc) - targets 0 - in - count_targets value_targets + count_targets type_targets - in - let incoming_from_decls, incoming_from_live_decls = - match Pos_hash.find_opt incoming_decl_deps pos with - | None -> (0, 0) - | Some sources -> - let total = Pos_set.cardinal sources in - let live_src = - Pos_set.fold - (fun src acc -> - if Pos_hash.mem live src then acc + 1 else acc) - sources 0 - in - (total, live_src) - in - if incoming_from_decls > 0 || outgoing_to_decls > 0 then - Log_.item " deps: in=%d (live=%d dead=%d) out=%d@." - incoming_from_decls incoming_from_live_decls - (incoming_from_decls - incoming_from_live_decls) - outgoing_to_decls; - (* For debugging, print a small sample of incoming/outgoing decl deps. + let outgoing_to_decls = + match Pos_hash.find_opt decl_refs_index pos with + | None -> 0 + | Some (value_targets, type_targets) -> + let count_targets targets = + Pos_set.fold + (fun target acc -> + match Declaration_store.find_opt decl_store target with + | Some _ -> acc + 1 + | None -> acc) + targets 0 + in + count_targets value_targets + count_targets type_targets + in + let incoming_from_decls, incoming_from_live_decls = + match Pos_hash.find_opt incoming_decl_deps pos with + | None -> (0, 0) + | Some sources -> + let total = Pos_set.cardinal sources in + let live_src = + Pos_set.fold + (fun src acc -> if Pos_hash.mem live src then acc + 1 else acc) + sources 0 + in + (total, live_src) + in + if incoming_from_decls > 0 || outgoing_to_decls > 0 then + Log_.item " deps: in=%d (live=%d dead=%d) out=%d@." + incoming_from_decls incoming_from_live_decls + (incoming_from_decls - incoming_from_live_decls) + outgoing_to_decls; + (* 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 Pos_hash.find_opt incoming_decl_deps pos with - | None -> () - | Some sources -> - let shown = ref 0 in - Pos_set.iter - (fun src_pos -> - if !shown < max_show then ( - incr shown; - match Declaration_store.find_opt decl_store src_pos with - | Some src_decl -> - let src_status = - if Pos_hash.mem live src_pos then "live" else "dead" - in - Log_.item " <- %s (%s)@." - (src_decl.path |> Dce_path.to_string) - src_status - | None -> ())) - sources; - if Pos_set.cardinal sources > max_show then - Log_.item " <- ... (%d more)@." - (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 Declaration_store.find_opt decl_store target with - | None -> false - | Some target_decl -> - Log_.item " -> %s@." - (target_decl.path |> Dce_path.to_string); - true - in - let shown = ref 0 in - let try_show targets = - Pos_set.iter - (fun target -> - if !shown < max_show then - if show_target target then incr shown) - targets - in - try_show value_targets; - try_show type_targets; - if outgoing_to_decls > max_show then - Log_.item " -> ... (%d more)@." - (outgoing_to_decls - max_show)); - - decl.resolved_dead <- Some is_dead; - - if is_dead then ( - decl.path - |> Dead_modules.mark_dead ~config - ~is_type:(decl.decl_kind |> Decl.Kind.is_type) - ~loc:decl.module_loc; - if not (do_report_dead ~ann_store decl.pos) then decl.report <- false; - dead_declarations := decl :: !dead_declarations) - else ( - (* Collect optional args issues for live declarations *) - check_optional_arg_fn ~optional_args_state ~ann_store ~config decl - |> List.iter (fun issue -> inline_issues := issue :: !inline_issues); - decl.path - |> Dead_modules.mark_live ~config - ~is_type:(decl.decl_kind |> Decl.Kind.is_type) - ~loc:decl.module_loc; - if Annotation_store.is_annotated_dead ann_store decl.pos then ( - (* Collect incorrect @dead annotation issue *) - let issue = - make_dead_issue ~decl ~message:" is annotated @dead but is live" - IncorrectDeadAnnotation - in - decl.path - |> Dce_path.to_module_name - ~is_type:(decl.decl_kind |> Decl.Kind.is_type) - |> Dead_modules.check_module_dead ~config - ~file_name:decl.pos.pos_fname - |> Option.iter (fun mod_issue -> - inline_issues := mod_issue :: !inline_issues); - inline_issues := issue :: !inline_issues))); + let max_show = 3 in + (match Pos_hash.find_opt incoming_decl_deps pos with + | None -> () + | Some sources -> + let shown = ref 0 in + Pos_set.iter + (fun src_pos -> + if !shown < max_show then ( + incr shown; + match Declaration_store.find_opt decl_store src_pos with + | Some src_decl -> + let src_status = + if Pos_hash.mem live src_pos then "live" else "dead" + in + Log_.item " <- %s (%s)@." + (src_decl.path |> Dce_path.to_string) + src_status + | None -> ())) + sources; + if Pos_set.cardinal sources > max_show then + Log_.item " <- ... (%d more)@." + (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 Declaration_store.find_opt decl_store target with + | None -> false + | Some target_decl -> + Log_.item " -> %s@." (target_decl.path |> Dce_path.to_string); + true + in + let shown = ref 0 in + let try_show targets = + Pos_set.iter + (fun target -> + if !shown < max_show then if show_target target then incr shown) + targets + in + try_show value_targets; + try_show type_targets; + if outgoing_to_decls > max_show then + Log_.item " -> ... (%d more)@." (outgoing_to_decls - max_show)); + + decl.resolved_dead <- Some is_dead; + + if is_dead then ( + decl.path + |> Dead_modules.mark_dead ~config + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + ~loc:decl.module_loc; + if not (do_report_dead ~ann_store decl.pos) then decl.report <- false; + dead_declarations := decl :: !dead_declarations) + else ( + (* Collect optional args issues for live declarations *) + check_optional_arg_fn ~optional_args_state ~ann_store ~config decl + |> List.iter (fun issue -> inline_issues := issue :: !inline_issues); + decl.path + |> Dead_modules.mark_live ~config + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + ~loc:decl.module_loc; + if Annotation_store.is_annotated_dead ann_store decl.pos then ( + (* Collect incorrect @dead annotation issue *) + let issue = + make_dead_issue ~decl ~message:" is annotated @dead but is live" + IncorrectDeadAnnotation + in + decl.path + |> Dce_path.to_module_name + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + |> Dead_modules.check_module_dead ~config + ~file_name:decl.pos.pos_fname + |> Option.iter (fun mod_issue -> + inline_issues := mod_issue :: !inline_issues); + inline_issues := issue :: !inline_issues))); let sorted_dead_declarations = !dead_declarations |> List.fast_sort Decl.compare_for_reporting @@ -466,7 +462,7 @@ let solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state let dead_issues = sorted_dead_declarations |> List.concat_map (fun decl -> - report_declaration ~config ~has_ref_below reporting_ctx decl) + report_declaration ~config ~has_ref_below reporting_ctx decl) in let all_issues = List.rev !inline_issues @ dead_issues in Analysis_result.add_issues Analysis_result.empty all_issues @@ -519,64 +515,64 @@ let solve_dead_reactive ~ann_store ~config ~decl_store ~value_refs_from all_decls |> List.iter (fun (decl : Decl.t) -> - let pos = decl.pos in - incr num_live_checks; - let is_live = is_live pos in - let is_dead = not is_live in - - (* Debug output (forward model): derive root/propagated from [roots]. *) - (if debug then - let live_reason : Liveness.live_reason option = - if not is_live then None - else if Reactive.get roots pos <> None then - if Annotation_store.is_annotated_gentype_or_live ann_store pos - then Some Liveness.Annotated - else Some Liveness.ExternalRef - else Some Liveness.Propagated - in - let status = - match live_reason with - | None -> "Dead" - | Some reason -> - Printf.sprintf "Live (%s)" (Liveness.reason_to_string reason) - in - Log_.item "%s %s %s@." status - (decl.decl_kind |> Decl.Kind.to_string) - (decl.path |> Dce_path.to_string)); - - decl.resolved_dead <- Some is_dead; - - if is_dead then ( - incr num_dead; - decl.path - |> Dead_modules.mark_dead ~config - ~is_type:(decl.decl_kind |> Decl.Kind.is_type) - ~loc:decl.module_loc; - if not (do_report_dead ~ann_store decl.pos) then decl.report <- false; - dead_declarations := decl :: !dead_declarations) - else ( - incr num_live; - (* Collect optional args issues for live declarations *) - check_optional_arg_fn ~optional_args_state ~ann_store ~config decl - |> List.iter (fun issue -> inline_issues := issue :: !inline_issues); - decl.path - |> Dead_modules.mark_live ~config - ~is_type:(decl.decl_kind |> Decl.Kind.is_type) - ~loc:decl.module_loc; - if Annotation_store.is_annotated_dead ann_store decl.pos then ( - (* Collect incorrect @dead annotation issue *) - let issue = - make_dead_issue ~decl ~message:" is annotated @dead but is live" - IncorrectDeadAnnotation - in - decl.path - |> Dce_path.to_module_name - ~is_type:(decl.decl_kind |> Decl.Kind.is_type) - |> Dead_modules.check_module_dead ~config - ~file_name:decl.pos.pos_fname - |> Option.iter (fun mod_issue -> - inline_issues := mod_issue :: !inline_issues); - inline_issues := issue :: !inline_issues))); + let pos = decl.pos in + incr num_live_checks; + let is_live = is_live pos in + let is_dead = not is_live in + + (* Debug output (forward model): derive root/propagated from [roots]. *) + (if debug then + let live_reason : Liveness.live_reason option = + if not is_live then None + else if Reactive.get roots pos <> None then + if Annotation_store.is_annotated_gentype_or_live ann_store pos then + Some Liveness.Annotated + else Some Liveness.ExternalRef + else Some Liveness.Propagated + in + let status = + match live_reason with + | None -> "Dead" + | Some reason -> + Printf.sprintf "Live (%s)" (Liveness.reason_to_string reason) + in + Log_.item "%s %s %s@." status + (decl.decl_kind |> Decl.Kind.to_string) + (decl.path |> Dce_path.to_string)); + + decl.resolved_dead <- Some is_dead; + + if is_dead then ( + incr num_dead; + decl.path + |> Dead_modules.mark_dead ~config + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + ~loc:decl.module_loc; + if not (do_report_dead ~ann_store decl.pos) then decl.report <- false; + dead_declarations := decl :: !dead_declarations) + else ( + incr num_live; + (* Collect optional args issues for live declarations *) + check_optional_arg_fn ~optional_args_state ~ann_store ~config decl + |> List.iter (fun issue -> inline_issues := issue :: !inline_issues); + decl.path + |> Dead_modules.mark_live ~config + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + ~loc:decl.module_loc; + if Annotation_store.is_annotated_dead ann_store decl.pos then ( + (* Collect incorrect @dead annotation issue *) + let issue = + make_dead_issue ~decl ~message:" is annotated @dead but is live" + IncorrectDeadAnnotation + in + decl.path + |> Dce_path.to_module_name + ~is_type:(decl.decl_kind |> Decl.Kind.is_type) + |> Dead_modules.check_module_dead ~config + ~file_name:decl.pos.pos_fname + |> Option.iter (fun mod_issue -> + inline_issues := mod_issue :: !inline_issues); + inline_issues := issue :: !inline_issues))); let t4 = Unix.gettimeofday () in let sorted_dead_declarations = @@ -589,7 +585,7 @@ let solve_dead_reactive ~ann_store ~config ~decl_store ~value_refs_from let dead_issues = sorted_dead_declarations |> List.concat_map (fun decl -> - report_declaration ~config ~has_ref_below 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 diff --git a/analysis/reanalyze/src/dead_optional_args.ml b/analysis/reanalyze/src/dead_optional_args.ml index 3b4880e77c6..03cc4af173a 100644 --- a/analysis/reanalyze/src/dead_optional_args.ml +++ b/analysis/reanalyze/src/dead_optional_args.ml @@ -8,9 +8,9 @@ let rec has_optional_args (texpr : Types.type_expr) = | Tarrow (params, _) -> params |> List.exists (fun ({lbl} : Types.arg) -> - match lbl with - | Optional _ -> true - | _ -> false) + match lbl with + | Optional _ -> true + | _ -> false) | Tlink t -> has_optional_args t | Tsubst t -> has_optional_args t | _ -> false @@ -37,9 +37,9 @@ let rec from_type_expr (texpr : Types.type_expr) = | Tarrow (params, _) -> params |> List.filter_map (fun ({lbl} : Types.arg) -> - match lbl with - | Optional {txt = s} -> Some s - | _ -> None) + match lbl with + | Optional {txt = s} -> Some s + | _ -> None) | Tlink t -> from_type_expr t | Tsubst t -> from_type_expr t | _ -> [] diff --git a/analysis/reanalyze/src/dead_type.ml b/analysis/reanalyze/src/dead_type.ml index d0eeb449d03..1edc5ab7055 100644 --- a/analysis/reanalyze/src/dead_type.ml +++ b/analysis/reanalyze/src/dead_type.ml @@ -101,14 +101,14 @@ let process_type_label_dependencies ~config ~decls ~refs = connect them together. *) index |> Path_map.iter (fun _key locs -> - match locs with - | [] | [_] -> () - | loc0 :: rest -> - rest - |> List.iter (fun loc -> - extend_type_dependencies ~config ~refs loc loc0; - if not Config.report_types_dead_only_in_interface then - extend_type_dependencies ~config ~refs loc0 loc)); + match locs with + | [] | [_] -> () + | loc0 :: rest -> + rest + |> List.iter (fun loc -> + extend_type_dependencies ~config ~refs loc loc0; + if not Config.report_types_dead_only_in_interface then + extend_type_dependencies ~config ~refs loc0 loc)); (* Cross-file impl<->intf linking, modeled after the previous lookup logic. *) let hd_opt = function @@ -209,18 +209,16 @@ let process_type_label_dependencies ~config ~decls ~refs = groups |> Hashtbl.to_seq |> List.of_seq |> List.map (fun (current_type_path, (rep_pos, manifest_type_path, items)) -> - (rep_pos, current_type_path, manifest_type_path, items)) + (rep_pos, current_type_path, manifest_type_path, items)) (* Later (lower) types first *) |> List.fast_sort (fun (p1, _, _, _) (p2, _, _, _) -> compare_pos p2 p1) |> List.iter (fun (_rep_pos, _currentTypePath, manifest_type_path, items) -> - items - |> List.fast_sort (fun (p1, _, _) (p2, _, _) -> compare_pos p1 p2) - |> List.iter (fun (_pos, field_name, current_loc) -> - let manifest_field_path = field_name :: manifest_type_path in - match find_one manifest_field_path with - | None -> () - | Some manifest_loc -> - extend_type_dependencies ~config ~refs current_loc - manifest_loc; - extend_type_dependencies ~config ~refs manifest_loc - current_loc)) + items + |> List.fast_sort (fun (p1, _, _) (p2, _, _) -> compare_pos p1 p2) + |> List.iter (fun (_pos, field_name, current_loc) -> + let manifest_field_path = field_name :: manifest_type_path in + match find_one manifest_field_path with + | None -> () + | Some manifest_loc -> + extend_type_dependencies ~config ~refs current_loc manifest_loc; + extend_type_dependencies ~config ~refs manifest_loc current_loc)) diff --git a/analysis/reanalyze/src/dead_value.ml b/analysis/reanalyze/src/dead_value.ml index 35f775fee7e..f6da7f9d095 100644 --- a/analysis/reanalyze/src/dead_value.ml +++ b/analysis/reanalyze/src/dead_value.ml @@ -106,29 +106,24 @@ let process_optional_args ~config ~cross_file ~exp_type ~(loc_from : Location.t) let supplied_maybe = ref [] in args |> List.iter (fun (lbl, arg) -> - let arg_is_supplied = - match arg with - | Some - { - Typedtree.exp_desc = - Texp_construct (_, {cstr_name = "Some"}, _); - } -> - Some true - | Some - { - Typedtree.exp_desc = - Texp_construct (_, {cstr_name = "None"}, _); - } -> - Some false - | Some _ -> None - | None -> Some false - in - match lbl with - | Asttypes.Optional {txt = s} when not loc_from.loc_ghost -> - if arg_is_supplied <> Some false then supplied := s :: !supplied; - if arg_is_supplied = None then - supplied_maybe := s :: !supplied_maybe - | _ -> ()); + let arg_is_supplied = + match arg with + | Some + {Typedtree.exp_desc = Texp_construct (_, {cstr_name = "Some"}, _)} + -> + Some true + | Some + {Typedtree.exp_desc = Texp_construct (_, {cstr_name = "None"}, _)} + -> + Some false + | Some _ -> None + | None -> Some false + in + match lbl with + | Asttypes.Optional {txt = s} when not loc_from.loc_ghost -> + if arg_is_supplied <> Some false then supplied := s :: !supplied; + if arg_is_supplied = None then supplied_maybe := s :: !supplied_maybe + | _ -> ()); (!supplied, !supplied_maybe) |> Dead_optional_args.add_references ~config ~cross_file ~loc_from ~loc_to ~binding ~path) @@ -183,7 +178,7 @@ let rec collect_expr ~config ~refs ~file_deps ~cross_file ~direct_callees Expression_table.replace direct_callees direct_callee (); args |> process_optional_args ~config ~cross_file ~exp_type - ~loc_from:(loc_from : Location.t) + ~(loc_from : Location.t) ~binding:last_binding ~loc_to ~path | Texp_let ( (* generated for functions with optional args *) @@ -219,7 +214,7 @@ let rec collect_expr ~config ~refs ~file_deps ~cross_file ~direct_callees Expression_table.replace direct_callees direct_callee (); args |> process_optional_args ~config ~cross_file ~exp_type - ~loc_from:(loc_from : Location.t) + ~(loc_from : Location.t) ~binding:last_binding ~loc_to ~path | Texp_field (_, _, {lbl_loc = {Location.loc_start = pos_to; loc_ghost = false}; _}) -> @@ -245,15 +240,14 @@ let rec collect_expr ~config ~refs ~file_deps ~cross_file ~direct_callees | Texp_record {fields} -> fields |> Array.iter (fun (_, record_label_definition, _) -> - match record_label_definition with - | Typedtree.Overridden (_, ({exp_loc} as e)) when exp_loc.loc_ghost - -> - (* Punned field in OCaml projects has ghost location in expression *) - let e = {e with exp_loc = {exp_loc with loc_ghost = false}} in - collect_expr ~config ~refs ~file_deps ~cross_file ~direct_callees - ~last_binding super self e - |> ignore - | _ -> ()) + match record_label_definition with + | Typedtree.Overridden (_, ({exp_loc} as e)) when exp_loc.loc_ghost -> + (* Punned field in OCaml projects has ghost location in expression *) + let e = {e with exp_loc = {exp_loc with loc_ghost = false}} in + collect_expr ~config ~refs ~file_deps ~cross_file ~direct_callees + ~last_binding super self e + |> ignore + | _ -> ()) | _ -> ()); super.Tast_mapper.expr self e @@ -290,8 +284,8 @@ let type_path_candidates ~file ~(module_path : Module_path.t) path = let add_record_label_type_references ~config ~refs ~pos_from labels = labels |> List.iter (fun {Types.ld_loc = {loc_start = pos_to; loc_ghost}; _} -> - if not loc_ghost then - Dead_type.add_type_reference ~config ~refs ~pos_from ~pos_to) + if not loc_ghost then + Dead_type.add_type_reference ~config ~refs ~pos_from ~pos_to) let add_record_rest_type_references_from_path ~config ~decls ~refs ~file ~module_path ~pos_from rest = @@ -301,14 +295,13 @@ let add_record_rest_type_references_from_path ~config ~decls ~refs ~file let type_paths = type_path_candidates ~file ~module_path path in decls |> Declarations.builder_to_list |> List.iter (fun (_, decl) -> - match (decl.Decl.decl_kind, decl.path) with - | RecordLabel, _label :: type_path - when List.exists - (fun candidate -> candidate = type_path) - type_paths -> - Dead_type.add_type_reference ~config ~refs ~pos_from - ~pos_to:decl.pos - | _ -> ()) + match (decl.Decl.decl_kind, decl.path) with + | RecordLabel, _label :: type_path + when List.exists (fun candidate -> candidate = type_path) type_paths + -> + Dead_type.add_type_reference ~config ~refs ~pos_from + ~pos_to:decl.pos + | _ -> ()) | _ -> () let add_record_rest_type_references ~config ~decls ~refs ~file ~module_path @@ -332,8 +325,8 @@ let collect_pattern ~config ~decls ~refs ~file ~module_path : | Typedtree.Tpat_record (cases, _clodsedFlag, rest) -> ( cases |> List.iter (fun (_loc, {Types.lbl_loc = {loc_start = pos_to}}, _pat, _) -> - if !Config.analyze_types then - Dead_type.add_type_reference ~config ~refs ~pos_from ~pos_to); + if !Config.analyze_types then + Dead_type.add_type_reference ~config ~refs ~pos_from ~pos_to); match rest with | None -> () | Some rest -> diff --git a/analysis/reanalyze/src/declarations.ml b/analysis/reanalyze/src/declarations.ml index bcdee966ab7..00931d02061 100644 --- a/analysis/reanalyze/src/declarations.ml +++ b/analysis/reanalyze/src/declarations.ml @@ -25,9 +25,7 @@ let merge_all (builders : builder list) : t = let result = Pos_hash.create 256 in builders |> List.iter (fun builder -> - Pos_hash.iter - (fun pos decl -> Pos_hash.replace result pos decl) - builder); + Pos_hash.iter (fun pos decl -> Pos_hash.replace result pos decl) builder); result (* ===== Builder extraction for reactive merge ===== *) diff --git a/analysis/reanalyze/src/exception.ml b/analysis/reanalyze/src/exception.ml index 271a27bd7a4..9e206e8e0b1 100644 --- a/analysis/reanalyze/src/exception.ml +++ b/analysis/reanalyze/src/exception.ml @@ -19,7 +19,7 @@ let merge_values_builders (builders : (string * values_builder) list) : let table = Hashtbl.create 15 in builders |> List.iter (fun (module_name, builder) -> - Hashtbl.replace table module_name builder); + Hashtbl.replace table module_name builder); table module Values = struct @@ -168,8 +168,8 @@ module Event = struct let new_throws = Exceptions.diff nested_exceptions exceptions in exceptions |> Exceptions.iter (fun exn -> - nested_events - |> List.iter (fun event -> shrink_exn_table exn event.loc)); + nested_events + |> List.iter (fun event -> shrink_exn_table exn event.loc)); loop (Exceptions.union exn_set new_throws) rest | [] -> exn_set in @@ -275,9 +275,9 @@ let traverse_ast ~file ~values_builder ~checks_builder () = let iter_cases self cases = cases |> List.iter (fun case -> - case.Typedtree.c_lhs |> iter_pat self; - case.c_guard |> iter_expr_opt self; - case.c_rhs |> iter_expr self) + case.Typedtree.c_lhs |> iter_pat self; + case.c_guard |> iter_expr_opt self; + case.c_rhs |> iter_expr self) in let is_throw s = s = "Pervasives.raise" || s = "Pervasives.throw" in let throw_args args = @@ -291,12 +291,12 @@ let traverse_ast ~file ~values_builder ~checks_builder () = let does_not_throw attributes = attributes |> Annotation.get_attribute_payload (function - | "doesNotRaise" | "doesnotraise" | "DoesNoRaise" | "doesNotraise" - | "doNotRaise" | "donotraise" | "DoNoRaise" | "doNotraise" - | "doesNotThrow" | "doesnotthrow" | "DoesNoThrow" | "doesNotthrow" - | "doNotThrow" | "donotthrow" | "DoNoThrow" | "doNotthrow" -> - true - | _ -> false) + | "doesNotRaise" | "doesnotraise" | "DoesNoRaise" | "doesNotraise" + | "doNotRaise" | "donotraise" | "DoNoRaise" | "doNotraise" + | "doesNotThrow" | "doesnotthrow" | "DoesNoThrow" | "doesNotthrow" + | "doNotThrow" | "donotthrow" | "DoNoThrow" | "doNotthrow" -> + true + | _ -> false) <> None in let expr ~(module_path : Module_path.t) (self : Tast_mapper.mapper) @@ -398,7 +398,7 @@ let traverse_ast ~file ~values_builder ~checks_builder () = let throws_annotation_payload = attributes |> Annotation.get_attribute_payload (fun s -> - s = "throws" || s = "throw" || s = "raises" || s = "raise") + s = "throws" || s = "throw" || s = "raises" || s = "raise") in let rec get_exceptions payload = match payload with @@ -412,7 +412,7 @@ let traverse_ast ~file ~values_builder ~checks_builder () = | Annotation.TuplePayload tuple -> tuple |> List.map (fun payload -> - payload |> get_exceptions |> Exceptions.to_list) + payload |> get_exceptions |> Exceptions.to_list) |> List.concat |> Exceptions.from_list | _ -> Exceptions.empty in diff --git a/analysis/reanalyze/src/exn_lib.ml b/analysis/reanalyze/src/exn_lib.ml index ce39c97dc97..6c53ce850f6 100644 --- a/analysis/reanalyze/src/exn_lib.ml +++ b/analysis/reanalyze/src/exn_lib.ml @@ -234,11 +234,11 @@ let raises_lib_table : (Name.t, Exceptions.t) Hashtbl.t = ("Yojson.Basic.Util", yojson_basic_util); ] |> List.iter (fun (name, group) -> - group - |> List.iter (fun (s, e) -> - Hashtbl.add table - (name ^ "." ^ s |> Name.create) - (e |> Exceptions.from_list))); + group + |> List.iter (fun (s, e) -> + Hashtbl.add table + (name ^ "." ^ s |> Name.create) + (e |> Exceptions.from_list))); table let find (path : Dce_path.t) = diff --git a/analysis/reanalyze/src/file_annotations.ml b/analysis/reanalyze/src/file_annotations.ml index 83cded03713..3701dcc85fc 100644 --- a/analysis/reanalyze/src/file_annotations.ml +++ b/analysis/reanalyze/src/file_annotations.ml @@ -27,9 +27,7 @@ let merge_all (builders : builder list) : t = let result = Pos_hash.create 1 in builders |> List.iter (fun builder -> - Pos_hash.iter - (fun pos value -> Pos_hash.replace result pos value) - builder); + Pos_hash.iter (fun pos value -> Pos_hash.replace result pos value) builder); result (* ===== Builder extraction for reactive merge ===== *) diff --git a/analysis/reanalyze/src/file_deps.ml b/analysis/reanalyze/src/file_deps.ml index d02a040a77b..a976e1cd486 100644 --- a/analysis/reanalyze/src/file_deps.ml +++ b/analysis/reanalyze/src/file_deps.ml @@ -145,13 +145,13 @@ let iter_files_from_roots_to_leaves (t : t) iter_fun = Hashtbl.remove references_by_number 0; files_with_no_incoming_references |> File_set.iter (fun file_name -> - iter_fun file_name; - let references = get_deps t file_name in - references - |> File_set.iter (fun to_file -> remove_edge file_name to_file)) + iter_fun file_name; + let references = get_deps t file_name in + references + |> File_set.iter (fun to_file -> remove_edge file_name to_file)) done; (* Process any remaining items in case of circular references *) references_by_number |> Hashtbl.iter (fun _num set -> - if File_set.is_empty set then () - else set |> File_set.iter (fun file_name -> iter_fun file_name)) + 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/log_.ml b/analysis/reanalyze/src/log_.ml index f365b1f1c6c..214cb1e5c8e 100644 --- a/analysis/reanalyze/src/log_.ml +++ b/analysis/reanalyze/src/log_.ml @@ -203,15 +203,15 @@ module Stats = struct let counters2 = Hashtbl.create 1 in !issues |> List.iter (fun (issue : Issue.t) -> - let counter = - match Hashtbl.find_opt counters2 issue.name with - | Some counter -> counter - | None -> - let counter = ref 0 in - Hashtbl.add counters2 issue.name counter; - counter - in - incr counter); + let counter = + match Hashtbl.find_opt counters2 issue.name with + | Some counter -> counter + | None -> + let counter = ref 0 in + Hashtbl.add counters2 issue.name counter; + counter + in + incr counter); let issues, n_issues = Hashtbl.fold (fun name cnt (issues, n_issues) -> diff --git a/analysis/reanalyze/src/name.ml b/analysis/reanalyze/src/name.ml index 2ca477e8665..af273f9e5b1 100644 --- a/analysis/reanalyze/src/name.ml +++ b/analysis/reanalyze/src/name.ml @@ -13,8 +13,8 @@ let is_underscore s = s = "_" || s = "+_" let starts_with_underscore s = s |> String.length >= 2 && - try s.[0] = '_' || (s.[0] = '+' && s.[1] = '_') - with Invalid_argument _ -> false + try s.[0] = '_' || (s.[0] = '+' && s.[1] = '_') + with Invalid_argument _ -> false let to_interface s = match is_interface s with diff --git a/analysis/reanalyze/src/paths.ml b/analysis/reanalyze/src/paths.ml index 2b0d524ea1a..03b9dc61a3d 100644 --- a/analysis/reanalyze/src/paths.ml +++ b/analysis/reanalyze/src/paths.ml @@ -44,9 +44,9 @@ module Config = struct let names = elements |> List.filter_map (fun (x : Yojson.Safe.t) -> - match x with - | `String s -> Some s - | _ -> None) + match x with + | `String s -> Some s + | _ -> None) in run_config.suppress <- names @ run_config.suppress | _ -> () @@ -57,9 +57,9 @@ module Config = struct let names = elements |> List.filter_map (fun (x : Yojson.Safe.t) -> - match x with - | `String s -> Some s - | _ -> None) + match x with + | `String s -> Some s + | _ -> None) in run_config.unsuppress <- names @ run_config.unsuppress | _ -> () @@ -69,12 +69,12 @@ module Config = struct | Some (`List elements) -> elements |> List.iter (fun (x : Yojson.Safe.t) -> - match x with - | `String "all" -> Run_config.all () - | `String "dce" -> Run_config.dce () - | `String "exception" -> Run_config.exception_ () - | `String "termination" -> Run_config.termination () - | _ -> ()) + match x with + | `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 *) Run_config.dce () diff --git a/analysis/reanalyze/src/reactive_analysis.ml b/analysis/reanalyze/src/reactive_analysis.ml index be535742286..f4f005abd5d 100644 --- a/analysis/reanalyze/src/reactive_analysis.ml +++ b/analysis/reanalyze/src/reactive_analysis.ml @@ -33,15 +33,15 @@ let process_cmt_infos ~config ~cmt_file_path cmt_infos : cmt_file_result option let exclude_path source_file = config.Dce_config.cli.exclude_paths |> List.exists (fun prefix_ -> - let prefix = - match Filename.is_relative source_file with - | true -> prefix_ - | false -> Filename.concat (Sys.getcwd ()) prefix_ - in - String.length prefix <= String.length source_file - && - try String.sub source_file 0 (String.length prefix) = prefix - with Invalid_argument _ -> false) + let prefix = + match Filename.is_relative source_file with + | true -> prefix_ + | false -> Filename.concat (Sys.getcwd ()) prefix_ + in + String.length prefix <= String.length source_file + && + try String.sub source_file 0 (String.length prefix) = prefix + with Invalid_argument _ -> false) in match cmt_infos.Cmt_format.cmt_annots |> Find_source_file.cmt with | Some source_file when not (exclude_path source_file) -> diff --git a/analysis/reanalyze/src/reactive_decl_refs.ml b/analysis/reanalyze/src/reactive_decl_refs.ml index dfa3e212a81..d0c21fed365 100644 --- a/analysis/reanalyze/src/reactive_decl_refs.ml +++ b/analysis/reanalyze/src/reactive_decl_refs.ml @@ -37,8 +37,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) | Some decls_in_file -> decls_in_file |> List.filter_map (fun (decl_pos, decl) -> - if pos_in_decl pos_from decl then Some (decl_pos, targets) - else None)) + if pos_in_decl pos_from decl then Some (decl_pos, targets) + else None)) ~merge:Pos_set.union () in @@ -51,8 +51,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) | Some decls_in_file -> decls_in_file |> List.filter_map (fun (decl_pos, decl) -> - if pos_in_decl pos_from decl then Some (decl_pos, targets) - else None)) + if pos_in_decl pos_from decl then Some (decl_pos, targets) + else None)) ~merge:Pos_set.union () in diff --git a/analysis/reanalyze/src/reactive_merge.ml b/analysis/reanalyze/src/reactive_merge.ml index 14dc222d719..db3ecfc84d2 100644 --- a/analysis/reanalyze/src/reactive_merge.ml +++ b/analysis/reanalyze/src/reactive_merge.ml @@ -126,7 +126,7 @@ let create (source : (string, Dce_file_processing.file_data option) Reactive.t) ~f:(fun _path items -> items.Cross_file_items.exception_refs |> List.map (fun (r : Cross_file_items.exception_ref) -> - (r.exception_path, r.loc_from))) + (r.exception_path, r.loc_from))) () in diff --git a/analysis/reanalyze/src/reactive_solver.ml b/analysis/reanalyze/src/reactive_solver.ml index e0b7456b555..321005ad895 100644 --- a/analysis/reanalyze/src/reactive_solver.ml +++ b/analysis/reanalyze/src/reactive_solver.ml @@ -159,8 +159,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let file_issues = sorted |> List.concat_map (fun decl -> - Dead_common.report_declaration ~config ~has_ref_below - ~check_module_dead ~should_report reporting_ctx decl) + Dead_common.report_declaration ~config ~has_ref_below + ~check_module_dead ~should_report reporting_ctx decl) in let modules_list = Hashtbl.fold (fun m () acc -> m :: acc) modules_with_values [] @@ -298,7 +298,7 @@ let collect_issues ~(t : t) ~(config : Dce_config.t) check_module_dead ~dead_modules:t.dead_modules ~reported_modules ~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 := mod_issue :: !incorrect_dead_issues); incorrect_dead_issues := issue :: !incorrect_dead_issues) t.incorrect_dead_decls; let t1 = Unix.gettimeofday () in diff --git a/analysis/reanalyze/src/reactive_type_deps.ml b/analysis/reanalyze/src/reactive_type_deps.ml index 233f37e67b6..543c3cd0380 100644 --- a/analysis/reanalyze/src/reactive_type_deps.ml +++ b/analysis/reanalyze/src/reactive_type_deps.ml @@ -70,12 +70,12 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) So: posTo=other, posFrom=first *) rest |> List.concat_map (fun other -> - (* Always add: other -> first (posTo=other, posFrom=first) *) - 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, Pos_set.singleton other.pos) :: refs)) + (* Always add: other -> first (posTo=other, posFrom=first) *) + 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, Pos_set.singleton other.pos) :: refs)) ~merge:Pos_set.union () in diff --git a/analysis/reanalyze/src/reanalyze.ml b/analysis/reanalyze/src/reanalyze.ml index b96ad7a7938..c04166d6113 100644 --- a/analysis/reanalyze/src/reanalyze.ml +++ b/analysis/reanalyze/src/reanalyze.ml @@ -13,15 +13,15 @@ let load_cmt_file ~config cmt_file_path : cmt_file_result option = let exclude_path source_file = config.Dce_config.cli.exclude_paths |> List.exists (fun prefix_ -> - let prefix = - match Filename.is_relative source_file with - | true -> prefix_ - | false -> Filename.concat (Sys.getcwd ()) prefix_ - in - String.length prefix <= String.length source_file - && - try String.sub source_file 0 (String.length prefix) = prefix - with Invalid_argument _ -> false) + let prefix = + match Filename.is_relative source_file with + | true -> prefix_ + | false -> Filename.concat (Sys.getcwd ()) prefix_ + in + String.length prefix <= String.length source_file + && + try String.sub source_file 0 (String.length prefix) = prefix + with Invalid_argument _ -> false) in match cmt_infos.cmt_annots |> Find_source_file.cmt with | Some source_file when not (exclude_path source_file) -> @@ -115,24 +115,24 @@ let collect_cmt_file_paths ~cmt_root : string list = in files |> List.filter (fun x -> - Filename.check_suffix x ".cmt" || Filename.check_suffix x ".cmti") + Filename.check_suffix x ".cmt" || Filename.check_suffix x ".cmti") |> List.sort String.compare |> List.iter (fun f -> - let p = Filename.concat abs_dir f in - if not (Hashtbl.mem seen p) then ( - Hashtbl.add seen p (); - paths := p :: !paths)) + let p = Filename.concat abs_dir f in + if not (Hashtbl.mem seen p) then ( + Hashtbl.add seen p (); + paths := p :: !paths)) in scan_plan |> List.iter (fun (entry : Paths.cmt_scan_entry) -> - let build_root_abs = - Filename.concat run_config.project_root entry.build_root - in - (* Scan configured subdirs. *) - entry.scan_dirs - |> List.iter (fun d -> add_dir (Filename.concat build_root_abs d)); - (* Optionally scan build root itself for namespace/mlmap `.cmt`s. *) - if entry.also_scan_build_root then add_dir build_root_abs)); + let build_root_abs = + Filename.concat run_config.project_root entry.build_root + in + (* Scan configured subdirs. *) + entry.scan_dirs + |> List.iter (fun d -> add_dir (Filename.concat build_root_abs d)); + (* Optionally scan build root itself for namespace/mlmap `.cmt`s. *) + if entry.also_scan_build_root then add_dir build_root_abs)); !paths |> List.rev (** Process files sequentially *) @@ -143,15 +143,15 @@ let process_files_sequential ~config (cmt_file_paths : string list) : let exception_results = ref [] in 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 - | None -> ()); - match exception_data with - | Some data -> exception_results := data :: !exception_results - | None -> ()) - | None -> ()); + 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 + | None -> ()); + match exception_data with + | Some data -> exception_results := data :: !exception_results + | None -> ()) + | None -> ()); {dce_data_list = !dce_data_list; exception_results = !exception_results}) (** Process all cmt files and return results for DCE and Exception analysis. @@ -244,7 +244,7 @@ let run_analysis ~dce_config ~cmt_root ~reactive_collection ~reactive_merge (File_annotations.merge_all (dce_data_list |> List.map (fun fd -> - fd.Dce_file_processing.annotations))), + fd.Dce_file_processing.annotations))), Declaration_store.of_frozen decls, Cross_file_items_store.of_frozen (Cross_file_items.merge_all @@ -295,11 +295,11 @@ let run_analysis ~dce_config ~cmt_root ~reactive_collection ~reactive_merge | None -> dce_data_list |> List.iter (fun fd -> - References.merge_into_builder - ~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)); + References.merge_into_builder + ~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 *) Dead_type.process_type_label_dependencies ~config:dce_config ~decls ~refs:refs_builder; @@ -434,7 +434,7 @@ let run_analysis ~dce_config ~cmt_root ~reactive_collection ~reactive_merge | Some result -> Analysis_result.get_issues result |> List.iter (fun (issue : Issue.t) -> - Log_.warning ~loc:issue.loc issue.description) + Log_.warning ~loc:issue.loc issue.description) | None -> ()); if dce_config.Dce_config.run.exception_ then Exception.run_checks ~config:dce_config exception_results; diff --git a/analysis/reanalyze/src/side_effects.ml b/analysis/reanalyze/src/side_effects.ml index 421efa07737..8e8ef833d80 100644 --- a/analysis/reanalyze/src/side_effects.ml +++ b/analysis/reanalyze/src/side_effects.ml @@ -19,7 +19,7 @@ let white_table_side_effects = let path_is_whitelisted_for_side_effects path = path |> Dce_path.on_ok_path ~when_contains_apply:false ~f:(fun s -> - Hashtbl.mem (Lazy.force white_table_side_effects) s) + Hashtbl.mem (Lazy.force white_table_side_effects) s) let rec expr_no_side_effects (expr : Typedtree.expression) = match expr.exp_desc with @@ -38,7 +38,7 @@ let rec expr_no_side_effects (expr : Typedtree.expression) = | Texp_let (_, vbs, e) -> vbs |> List.for_all (fun (vb : Typedtree.value_binding) -> - vb.vb_expr |> expr_no_side_effects) + vb.vb_expr |> expr_no_side_effects) && e |> expr_no_side_effects | Texp_record {fields; extended_expression} -> fields |> Array.for_all field_no_side_effects diff --git a/analysis/src/cli.ml b/analysis/src/cli.ml index b3f4b04a194..75a2b06661b 100644 --- a/analysis/src/cli.ml +++ b/analysis/src/cli.ml @@ -112,11 +112,11 @@ let rename ~state ~path ~pos ~new_name ~debug = | Some {documentChanges = Some document_changes} -> document_changes |> List.map (fun c -> - match c with - | `RenameFile r -> Lsp.Types.RenameFile.yojson_of_t r - | `TextDocumentEdit te -> Lsp.Types.TextDocumentEdit.yojson_of_t te - | `DeleteFile df -> Lsp.Types.DeleteFile.yojson_of_t df - | `CreateFile cf -> Lsp.Types.CreateFile.yojson_of_t cf) + match c with + | `RenameFile r -> Lsp.Types.RenameFile.yojson_of_t r + | `TextDocumentEdit te -> Lsp.Types.TextDocumentEdit.yojson_of_t te + | `DeleteFile df -> Lsp.Types.DeleteFile.yojson_of_t df + | `CreateFile cf -> Lsp.Types.CreateFile.yojson_of_t cf) |> print_list | _ -> print_null () @@ -227,10 +227,10 @@ let test ~state ~path = in lines |> List.iteri (fun j l -> - let line_to_output = - if j == i - 1 then remove_line_comment l else l - in - Printf.fprintf cout "%s\n" line_to_output); + let line_to_output = + if j == i - 1 then remove_line_comment l else l + in + Printf.fprintf cout "%s\n" line_to_output); close_out cout; current_file in @@ -372,60 +372,60 @@ let test ~state ~path = 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 - |> List.iter - (fun - (dc : - [ `CreateFile of Lsp.Types.CreateFile.t - | `DeleteFile of Lsp.Types.DeleteFile.t - | `RenameFile of Lsp.Types.RenameFile.t - | `TextDocumentEdit of - Lsp.Types.TextDocumentEdit.t ]) - -> - match dc with - | `TextDocumentEdit tde -> - let filename = - tde.textDocument.uri |> Uri.to_path - |> Filename.basename - in - Printf.printf "\nTextDocumentEdit: %s\n" filename; + Printf.printf "Hit: %s\n" title; + match edit with + | Some {documentChanges} -> + documentChanges |> Option.get + |> List.iter + (fun + (dc : + [ `CreateFile of Lsp.Types.CreateFile.t + | `DeleteFile of Lsp.Types.DeleteFile.t + | `RenameFile of Lsp.Types.RenameFile.t + | `TextDocumentEdit of Lsp.Types.TextDocumentEdit.t + ]) + -> + match dc with + | `TextDocumentEdit tde -> + let filename = + tde.textDocument.uri |> Uri.to_path + |> Filename.basename + in + Printf.printf "\nTextDocumentEdit: %s\n" filename; - tde.edits - |> List.iter - (fun - (edit : - [ `AnnotatedTextEdit of - Lsp.Types.AnnotatedTextEdit.t - | `TextEdit of Lsp.Types.TextEdit.t ]) - -> - let start_char, new_text, range = - match edit with - | `TextEdit te -> - ( te.range.start.character, - te.newText, - te.range ) - | `AnnotatedTextEdit te -> - ( te.range.start.character, - te.newText, - te.range ) - in - let indent = String.make start_char ' ' in - Printf.printf - "%s\nnewText:\n%s<--here\n%s%s\n" - (Lsp.Types.Range.yojson_of_t range - |> Yojson.Safe.pretty_to_string) - indent indent new_text) - | `CreateFile cf -> - let filename = - cf.uri |> Uri.to_path |> Filename.basename - in - Printf.printf "\nCreateFile: %s\n" filename - | _ -> - failwith "not implemented text document edit test") - | None -> ()) + tde.edits + |> List.iter + (fun + (edit : + [ `AnnotatedTextEdit of + Lsp.Types.AnnotatedTextEdit.t + | `TextEdit of Lsp.Types.TextEdit.t ]) + -> + let start_char, new_text, range = + match edit with + | `TextEdit te -> + ( te.range.start.character, + te.newText, + te.range ) + | `AnnotatedTextEdit te -> + ( te.range.start.character, + te.newText, + te.range ) + in + let indent = String.make start_char ' ' in + Printf.printf + "%s\nnewText:\n%s<--here\n%s%s\n" + (Lsp.Types.Range.yojson_of_t range + |> Yojson.Safe.pretty_to_string) + indent indent new_text) + | `CreateFile cf -> + let filename = + cf.uri |> Uri.to_path |> Filename.basename + in + Printf.printf "\nCreateFile: %s\n" filename + | _ -> + failwith "not implemented text document edit test") + | None -> ()) | "c-a" -> let hint = String.sub rest 3 (String.length rest - 3) in print_endline diff --git a/analysis/src/cmt.ml b/analysis/src/cmt.ml index a2c5e92eed9..e2936c3707a 100644 --- a/analysis/src/cmt.ml +++ b/analysis/src/cmt.ml @@ -67,7 +67,7 @@ let fulls_from_module ~package ~module_name = let uris = get_uris paths in uris |> List.filter_map (fun uri -> - full_from_module_uri ~package ~module_name ~uri ~paths) + full_from_module_uri ~package ~module_name ~uri ~paths) let load_full_cmt_from_path ~state ~path = let uri = Uri.from_path path in diff --git a/analysis/src/cmt_viewer.ml b/analysis/src/cmt_viewer.ml index a26ab067340..76a7b7b136c 100644 --- a/analysis/src/cmt_viewer.ml +++ b/analysis/src/cmt_viewer.ml @@ -41,25 +41,25 @@ let dump ~(filter_for_position : (int * int) option) ~full = stamps |> List.sort (fun (_, a) (_, b) -> - 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) + 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 "%d ktype %s\n" stamp - (Warnings.loc_to_string t.extent_loc) - | KValue t -> - printf "%d kvalue %s\n" stamp - (Warnings.loc_to_string t.extent_loc) - | KModule t -> - printf "%d kmodule %s\n" stamp - (Warnings.loc_to_string t.extent_loc) - | KConstructor t -> - printf "%d kconstructor %s\n" stamp - (Warnings.loc_to_string t.extent_loc)); + match kind with + | KType t -> + printf "%d ktype %s\n" stamp + (Warnings.loc_to_string t.extent_loc) + | KValue t -> + printf "%d kvalue %s\n" stamp + (Warnings.loc_to_string t.extent_loc) + | KModule t -> + printf "%d kmodule %s\n" stamp + (Warnings.loc_to_string t.extent_loc) + | KConstructor t -> + printf "%d kconstructor %s\n" stamp + (Warnings.loc_to_string t.extent_loc)); (* dump the structure *) let rec dump_structure indent (structure : Module.structure) = @@ -100,13 +100,13 @@ let dump ~(filter_for_position : (int * int) option) ~full = loc_items |> List.sort (fun a b -> - 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) + 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; loc_type} -> - let loc_str = Warnings.loc_to_string loc in - let kind_str = Shared_types.loc_type_to_string loc_type in - printf "%s %s\n" loc_str kind_str); + let loc_str = Warnings.loc_to_string loc in + let kind_str = Shared_types.loc_type_to_string loc_type in + printf "%s %s\n" loc_str kind_str); Buffer.contents buffer diff --git a/analysis/src/codemod.ml b/analysis/src/codemod.ml index ce16e2f2592..235948bdd1f 100644 --- a/analysis/src/codemod.ml +++ b/analysis/src/codemod.ml @@ -21,7 +21,7 @@ let transform_opt ~source ~pos ~debug ~typ ~hint = let cases = collect_patterns pattern |> List.map (fun (p : Parsetree.pattern) -> - Ast_helper.Exp.case p (Type_utils.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 index fb0651ce9ca..391661b216d 100644 --- a/analysis/src/commands.ml +++ b/analysis/src/commands.ml @@ -195,33 +195,33 @@ let rename ~state ~full ~pos ~new_name ~debug = 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) + if loc_opt = None then Some uri2 else None) in let references_to_items = all_references |> Utils.filter_map (function - | {References.uri = uri2; loc_opt = Some loc} -> Some (uri2, loc) - | {loc_opt = None} -> None) + | {References.uri = uri2; loc_opt = Some loc} -> Some (uri2, loc) + | {loc_opt = None} -> None) in let file_renames = references_to_toplevel_modules |> List.map (fun uri -> - let path = Uri.to_path uri in - let dir = - match Filename.dirname path with - | "." -> "" - | other -> other - in - let new_path = - Filename.concat dir (new_name ^ Filename.extension path) - in - `RenameFile - (Lsp.Types.RenameFile.create - ~newUri: - (new_path |> Uri.from_path |> Uri.to_string - |> Uri.from_path) - ~oldUri:(uri |> Uri.to_string |> Uri.from_string) - ())) + let path = Uri.to_path uri in + let dir = + match Filename.dirname path with + | "." -> "" + | other -> other + in + let new_path = + Filename.concat dir (new_name ^ Filename.extension path) + in + `RenameFile + (Lsp.Types.RenameFile.create + ~newUri: + (new_path |> Uri.from_path |> Uri.to_string + |> Uri.from_path) + ~oldUri:(uri |> Uri.to_string |> Uri.from_string) + ())) in let text_document_edits = let module String_map = Misc.String_map in diff --git a/analysis/src/completion_back_end.ml b/analysis/src/completion_back_end.ml index a1aa3f68928..f689ea2acbb 100644 --- a/analysis/src/completion_back_end.ml +++ b/analysis/src/completion_back_end.ml @@ -8,11 +8,11 @@ let show_constructor {Constructor.cname = {txt}; args; res} = "({" ^ (fields |> List.map (fun (field : field) -> - Printf.sprintf "%s%s: %s" field.fname.txt - (if field.optional then "?" else "") - (Shared.type_to_string - (if field.optional then Utils.unwrap_if_option field.typ - else field.typ))) + Printf.sprintf "%s%s: %s" field.fname.txt + (if field.optional then "?" else "") + (Shared.type_to_string + (if field.optional then Utils.unwrap_if_option field.typ + else field.typ))) |> String.concat ", ") ^ "})" | Args args -> @@ -115,18 +115,18 @@ let completions_for_exported_constructors ~(env : Query_env.t) ~prefix ~exact res := (constructors |> List.filter (fun c -> - Utils.check_name c.Constructor.cname.txt ~prefix ~exact) + Utils.check_name c.Constructor.cname.txt ~prefix ~exact) |> Utils.filter_map (fun c -> - let name = c.Constructor.cname.txt in - if not (Hashtbl.mem names_used name) then - let () = Hashtbl.add names_used name () in - Some - (Completion.create name ~env ~docstring:c.docstring - ?deprecated:c.deprecated - ~kind: - (Completion.Constructor - (c, t.item.decl |> Shared.decl_to_string t.name.txt))) - else None)) + let name = c.Constructor.cname.txt in + if not (Hashtbl.mem names_used name) then + let () = Hashtbl.add names_used name () in + Some + (Completion.create name ~env ~docstring:c.docstring + ?deprecated:c.deprecated + ~kind: + (Completion.Constructor + (c, t.item.decl |> Shared.decl_to_string t.name.txt))) + else None)) @ !res | _ -> ()); !res @@ -141,16 +141,16 @@ let completion_for_exported_fields ~(env : Query_env.t) ~prefix ~exact (fields |> List.filter (fun f -> Utils.check_name f.fname.txt ~prefix ~exact) |> Utils.filter_map (fun f -> - let name = f.fname.txt in - if not (Hashtbl.mem names_used name) then - let () = Hashtbl.add names_used name () in - Some - (Completion.create name ~env ~docstring:f.docstring - ?deprecated:f.deprecated - ~kind: - (Completion.Field - (f, t.item.decl |> Shared.decl_to_string t.name.txt))) - else None)) + let name = f.fname.txt in + if not (Hashtbl.mem names_used name) then + let () = Hashtbl.add names_used name () in + Some + (Completion.create name ~env ~docstring:f.docstring + ?deprecated:f.deprecated + ~kind: + (Completion.Field + (f, t.item.decl |> Shared.decl_to_string t.name.txt))) + else None)) @ !res | _ -> ()); !res @@ -159,9 +159,9 @@ let find_module_in_scope ~env ~module_name ~scope = let modules_table = Hashtbl.create 10 in env.Query_env.file.stamps |> Stamps.iter_modules (fun _ declared -> - Hashtbl.replace modules_table - (declared.name.txt, declared.extent_loc |> Loc.start) - declared); + Hashtbl.replace modules_table + (declared.name.txt, declared.extent_loc |> Loc.start) + declared); let result = ref None in let process_module name loc = if name = module_name && !result = None then @@ -202,21 +202,20 @@ let completions_from_structure_items ~(env : Query_env.t) (structure : Module.structure) = Structure_utils.unique_items structure |> List.filter_map (fun (it : Module.item) -> - match it.kind with - | Module.Value typ -> - Some - (Completion.create ~env ~docstring:it.docstring - ~kind:(Completion.Value typ) it.name) - | Module.Module {type_ = m} -> - Some - (Completion.create ~env ~docstring:it.docstring - ~kind: - (Completion.Module {docstring = it.docstring; module_ = m}) - it.name) - | Module.Type (t, _recStatus) -> - Some - (Completion.create ~env ~docstring:it.docstring - ~kind:(Completion.Type t) it.name)) + match it.kind with + | Module.Value typ -> + Some + (Completion.create ~env ~docstring:it.docstring + ~kind:(Completion.Value typ) it.name) + | Module.Module {type_ = m} -> + Some + (Completion.create ~env ~docstring:it.docstring + ~kind:(Completion.Module {docstring = it.docstring; module_ = m}) + it.name) + | Module.Type (t, _recStatus) -> + Some + (Completion.create ~env ~docstring:it.docstring + ~kind:(Completion.Type t) it.name)) let resolve_path_from_stamps ~state ~(env : Query_env.t) ~package ~scope ~module_name ~path = @@ -692,16 +691,16 @@ let get_complementary_completions_for_typed_value ~opens ~all_files ~scope ~env let file_modules = all_files |> File_set.elements |> Utils.filter_map (fun name -> - if - Utils.check_name name ~prefix ~exact - && not - (* TODO complete the namespaced name too *) - (Utils.file_name_has_unallowed_chars name) - then - Some - (Completion.create name ~synthetic:true ~env - ~kind:(Completion.FileModule name)) - else None) + if + Utils.check_name name ~prefix ~exact + && not + (* TODO complete the namespaced name too *) + (Utils.file_name_has_unallowed_chars name) + then + Some + (Completion.create name ~synthetic:true ~env + ~kind:(Completion.FileModule name)) + else None) in local_completions_with_opens @ file_modules @@ -719,15 +718,15 @@ let get_completions_for_path ~state ~debug ~opens ~full ~pos ~exact ~scope let file_modules = all_files |> File_set.elements |> Utils.filter_map (fun name -> - if - Utils.check_name name ~prefix ~exact - && not - (* TODO complete the namespaced name too *) - (Utils.file_name_has_unallowed_chars name) - then - Some - (Completion.create name ~env ~kind:(Completion.FileModule name)) - else None) + if + Utils.check_name name ~prefix ~exact + && not + (* TODO complete the namespaced name too *) + (Utils.file_name_has_unallowed_chars name) + then + Some + (Completion.create name ~env ~kind:(Completion.FileModule name)) + else None) in local_completions_with_opens @ file_modules | module_name :: path -> ( @@ -801,7 +800,7 @@ let completions_for_pipe_from_completion_path ~state let completions = completions |> List.map (fun (completion : Completion.t) -> - {completion with name = completion_name completion.name}) + {completion with name = completion_name completion.name}) in completions @@ -827,8 +826,8 @@ let mk_item ?data ?additional_text_edits name ~kind ~detail ~deprecated ~docstring = let doc_content = (match deprecated with - | None -> "" - | Some s -> "Deprecated: " ^ s ^ "\n\n") + | None -> "" + | Some s -> "Deprecated: " ^ s ^ "\n\n") ^ match docstring with | [] -> "" @@ -1202,8 +1201,8 @@ and get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos |> get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos ~env:env_completion_is_made_from ~exact ~scope |> List.filter_map (fun c -> - Type_utils.transform_completion_to_pipe_completion - ~synthetic:true ~env ?pos_of_dot c) + Type_utils.transform_completion_to_pipe_completion ~synthetic:true + ~env ?pos_of_dot c) in field_completions @ pipe_completions) | CPObj (cp, label) -> ( @@ -1220,10 +1219,10 @@ and get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos | Some (env, t_obj) -> t_obj |> Type_utils.get_obj_fields |> Utils.filter_map (fun (field, typ) -> - if Utils.check_name field ~prefix:label ~exact then - Some - (Completion.create field ~env ~kind:(Completion.ObjLabel typ)) - else None) + if Utils.check_name field ~prefix:label ~exact then + Some + (Completion.create field ~env ~kind:(Completion.ObjLabel typ)) + else None) | None -> []) | None -> []) | CPPipe {context_path = cp; id = prefix; lhs_loc; in_jsx; synthetic} -> ( @@ -1302,20 +1301,20 @@ and get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos |> Type_utils.filter_pipeable_functions ~env ~state ~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. + (* If we're completing from the current module then we need to care about scope. This is automatically taken care of in other cases. *) - if is_from_current_module then - match c.kind with - | Value _ -> - scope - |> List.find_opt (fun (item : Scope_types.item) -> - match item with - | Value (scope_item_name, _, _, _) -> - scope_item_name = c.name - | _ -> false) - |> Option.is_some - | _ -> false - else true) + if is_from_current_module then + match c.kind with + | Value _ -> + scope + |> List.find_opt (fun (item : Scope_types.item) -> + match item with + | Value (scope_item_name, _, _, _) -> + scope_item_name = c.name + | _ -> false) + |> Option.is_some + | _ -> false + else true) in let globally_configured_completions_for_type = @@ -1330,9 +1329,9 @@ and get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos let globally_configured_completions = globally_configured_completions_for_type |> List.map (fun completion_path -> - completions_for_pipe_from_completion_path ~state - ~env_completion_is_made_from ~opens ~pos ~scope ~debug - ~prefix ~env ~raw_opens ~full completion_path) + completions_for_pipe_from_completion_path ~state + ~env_completion_is_made_from ~opens ~pos ~scope ~debug ~prefix + ~env ~raw_opens ~full completion_path) |> List.flatten |> Type_utils.filter_pipeable_functions ~synthetic:true ~state ~env ~full ~target_type_id:main_type_id @@ -1344,9 +1343,9 @@ and get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos Type_utils.get_extra_modules_to_complete_from_for_type ~state ~env ~full typ |> List.map (fun completion_path -> - completions_for_pipe_from_completion_path ~state - ~env_completion_is_made_from ~opens ~pos ~scope ~debug - ~prefix ~env ~raw_opens ~full completion_path) + completions_for_pipe_from_completion_path ~state + ~env_completion_is_made_from ~opens ~pos ~scope ~debug ~prefix + ~env ~raw_opens ~full completion_path) |> List.flatten |> Type_utils.filter_pipeable_functions ~synthetic:true ~state ~env ~full ~target_type_id:main_type_id @@ -1373,13 +1372,13 @@ and get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos let type_exrps = ctx_paths |> List.map (fun context_path -> - context_path - |> get_completions_for_context_path ~state ~debug ~full ~opens - ~raw_opens ~pos ~env ~exact:true ~scope) + context_path + |> get_completions_for_context_path ~state ~debug ~full ~opens + ~raw_opens ~pos ~env ~exact:true ~scope) |> List.filter_map (fun completion_items -> - match completion_items with - | {Completion.kind = Value typ} :: _ -> Some typ - | _ -> None) + match completion_items with + | {Completion.kind = Value typ} :: _ -> Some typ + | _ -> None) in if List.length ctx_paths = List.length type_exrps then [ @@ -1484,14 +1483,14 @@ and get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos let target_label = labels |> List.find_opt (fun (label, _) -> - match (argument_label, label) with - | ( Unlabelled {argument_position = pos1}, - Completable.Unlabelled {argument_position = pos2} ) -> - pos1 = pos2 - | ( (Labelled name1 | Optional name1), - (Labelled name2 | Optional name2) ) -> - name1 = name2 - | _ -> false) + match (argument_label, label) with + | ( Unlabelled {argument_position = pos1}, + Completable.Unlabelled {argument_position = pos2} ) -> + pos1 = pos2 + | (Labelled name1 | Optional name1), (Labelled name2 | Optional name2) + -> + name1 = name2 + | _ -> false) in let expand_option = match target_label with @@ -1567,7 +1566,7 @@ let filter_items items ~prefix = else items |> List.filter (fun (item : Completion.t) -> - Utils.starts_with item.name prefix) + Utils.starts_with item.name prefix) type completion_mode = Pattern of Completable.pattern_mode | Expression @@ -1605,27 +1604,27 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) | Some (Completable.RecordField {seen_fields}) -> fields |> List.filter (fun (field : field) -> - List.mem field.fname.txt seen_fields = false) + List.mem field.fname.txt seen_fields = false) |> List.map (fun (field : field) -> - match (field.optional, mode) with - | true, Pattern Destructuring -> - create ("?" ^ field.fname.txt) ?deprecated:field.deprecated - ~docstring: - [ - field.fname.txt - ^ " is an optional field, and needs to be destructured \ - using '?'."; - ] - ~kind: - (Field - (field, Type_utils.extracted_type_to_string extracted_type)) - ~env - | _ -> - create field.fname.txt ?deprecated:field.deprecated - ~kind: - (Field - (field, Type_utils.extracted_type_to_string extracted_type)) - ~env) + match (field.optional, mode) with + | true, Pattern Destructuring -> + create ("?" ^ field.fname.txt) ?deprecated:field.deprecated + ~docstring: + [ + field.fname.txt + ^ " is an optional field, and needs to be destructured using \ + '?'."; + ] + ~kind: + (Field + (field, Type_utils.extracted_type_to_string extracted_type)) + ~env + | _ -> + create field.fname.txt ?deprecated:field.deprecated + ~kind: + (Field + (field, Type_utils.extracted_type_to_string extracted_type)) + ~env) |> filter_items ~prefix | _ -> if prefix = "" then @@ -1690,15 +1689,15 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) if value_with_type_t type_expr then get_completion_name name |> Option.map (fun name -> - create name ~includes_snippets:true ~insert_text:name - ~kind:(Value type_expr) ~env) + create name ~includes_snippets:true ~insert_text:name + ~kind:(Value type_expr) ~env) else if fn_returns_type_t type_expr then get_completion_name name |> Option.map (fun name -> - create - (Printf.sprintf "%s()" name) - ~includes_snippets:true ~insert_text:(name ^ "($0)") - ~kind:(Value type_expr) ~env) + create + (Printf.sprintf "%s()" name) + ~includes_snippets:true ~insert_text:(name ^ "($0)") + ~kind:(Value type_expr) ~env) else None in let completion_items = @@ -1753,44 +1752,43 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) if Debug.verbose () then print_endline "[complete_typed_value]--> Tvariant"; constructors |> List.map (fun (constructor : Constructor.t) -> - let num_args = - match constructor.args with - | InlineRecord _ -> 1 - | Args args -> List.length args - in - create ?deprecated:constructor.deprecated ~includes_snippets:true - (constructor.cname.txt - ^ print_constructor_args num_args ~as_snippet:false) - ~insert_text: - (constructor.cname.txt - ^ print_constructor_args num_args ~as_snippet:true) - ~kind: - (Constructor - ( constructor, - variant_decl |> Shared.decl_to_string variant_name )) - ~env) + let num_args = + match constructor.args with + | InlineRecord _ -> 1 + | Args args -> List.length args + in + create ?deprecated:constructor.deprecated ~includes_snippets:true + (constructor.cname.txt + ^ print_constructor_args num_args ~as_snippet:false) + ~insert_text: + (constructor.cname.txt + ^ print_constructor_args num_args ~as_snippet:true) + ~kind: + (Constructor + (constructor, variant_decl |> Shared.decl_to_string variant_name)) + ~env) |> filter_items ~prefix | Tpolyvariant {env; constructors; type_expr} -> if Debug.verbose () then print_endline "[complete_typed_value]--> Tpolyvariant"; constructors |> List.map (fun (constructor : poly_variant_constructor) -> - create - ("#" ^ constructor.display_name - ^ print_constructor_args - (List.length constructor.args) - ~as_snippet:false) - ~includes_snippets:true - ~insert_text: - ((if Utils.starts_with prefix "#" then "" else "#") - ^ constructor.display_name - ^ print_constructor_args - (List.length constructor.args) - ~as_snippet:true) - ~kind: - (PolyvariantConstructor - (constructor, type_expr |> Shared.type_to_string)) - ~env) + create + ("#" ^ constructor.display_name + ^ print_constructor_args + (List.length constructor.args) + ~as_snippet:false) + ~includes_snippets:true + ~insert_text: + ((if Utils.starts_with prefix "#" then "" else "#") + ^ constructor.display_name + ^ print_constructor_args + (List.length constructor.args) + ~as_snippet:true) + ~kind: + (PolyvariantConstructor + (constructor, type_expr |> Shared.type_to_string)) + ~env) |> filter_items ~prefix:(if Utils.starts_with prefix "#" then prefix else "#" ^ prefix) | Toption (env, t) -> @@ -1809,15 +1807,15 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) |> complete_typed_value ~raw_opens ~full ~state ~prefix ~completion_context ~mode |> List.map (fun (c : Completion.t) -> - { - c with - name = "Some(" ^ c.name ^ ")"; - sort_text = None; - insert_text = - (match c.insert_text with - | None -> None - | Some insert_text -> Some ("Some(" ^ insert_text ^ ")")); - }) + { + c with + name = "Some(" ^ c.name ^ ")"; + sort_text = None; + insert_text = + (match c.insert_text with + | None -> None + | Some insert_text -> Some ("Some(" ^ insert_text ^ ")")); + }) in let none_case = Completion.create "None" ~kind:(kind_from_inner_type t) ~env @@ -1857,15 +1855,15 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) |> complete_typed_value ~raw_opens ~full ~prefix ~completion_context ~mode ~state |> List.map (fun (c : Completion.t) -> - { - c with - name = "Ok(" ^ c.name ^ ")"; - sort_text = None; - insert_text = - (match c.insert_text with - | None -> None - | Some insert_text -> Some ("Ok(" ^ insert_text ^ ")")); - }) + { + c with + name = "Ok(" ^ c.name ^ ")"; + sort_text = None; + insert_text = + (match c.insert_text with + | None -> None + | Some insert_text -> Some ("Ok(" ^ insert_text ^ ")")); + }) in let expanded_error_completions = match error_inner_type with @@ -1875,15 +1873,15 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) |> complete_typed_value ~raw_opens ~full ~prefix ~completion_context ~mode ~state |> List.map (fun (c : Completion.t) -> - { - c with - name = "Error(" ^ c.name ^ ")"; - sort_text = None; - insert_text = - (match c.insert_text with - | None -> None - | Some insert_text -> Some ("Error(" ^ insert_text ^ ")")); - }) + { + c with + name = "Error(" ^ c.name ^ ")"; + sort_text = None; + insert_text = + (match c.insert_text with + | None -> None + | Some insert_text -> Some ("Error(" ^ insert_text ^ ")")); + }) in let ok_any_case = create "Ok(_)" ~includes_snippets:true ~kind:(Value ok_type) ~env @@ -1968,21 +1966,21 @@ let rec complete_typed_value ?(type_arg_context : type_arg_context option) let args_text = args |> List.map (fun ((label, typ) : typed_fn_arg) -> - match label with - | Optional {txt = name} -> "~" ^ name ^ "=?" - | Labelled {txt = name} -> "~" ^ name - | Nolabel -> - if Type_utils.type_is_unit typ then "()" - else ( - current_unlabelled_index := !current_unlabelled_index + 1; - let num = !current_unlabelled_index in - let var_name = - Completion_expressions.pretty_print_fn_template_arg_name - ~current_index:num ~env ~full ~state typ - in - if as_snippet then - "${" ^ string_of_int num ^ ":" ^ var_name ^ "}" - else var_name)) + match label with + | Optional {txt = name} -> "~" ^ name ^ "=?" + | Labelled {txt = name} -> "~" ^ name + | Nolabel -> + if Type_utils.type_is_unit typ then "()" + else ( + current_unlabelled_index := !current_unlabelled_index + 1; + let num = !current_unlabelled_index in + let var_name = + Completion_expressions.pretty_print_fn_template_arg_name + ~current_index:num ~env ~full ~state typ + in + if as_snippet then + "${" ^ string_of_int num ^ ":" ^ var_name ^ "}" + else var_name)) |> String.concat ", " in "(" ^ args_text ^ ")" @@ -2085,14 +2083,14 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover Some (fields |> List.filter_map (fun (f : field) -> - if - Utils.starts_with f.fname.txt prefix - && (for_hover || not (List.mem f.fname.txt idents_seen)) - then - Some - ( f.fname.txt, - Shared.type_to_string (Utils.unwrap_if_option f.typ) ) - else None) + if + Utils.starts_with f.fname.txt prefix + && (for_hover || not (List.mem f.fname.txt idents_seen)) + then + Some + ( f.fname.txt, + Shared.type_to_string (Utils.unwrap_if_option f.typ) ) + else None) |> List.map mk_label) in match from_element_props with @@ -2121,9 +2119,9 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover else (labels |> List.filter (fun (name, _t, _env) -> - Utils.starts_with name prefix - && name <> "key" - && (for_hover || not (List.mem name idents_seen))) + Utils.starts_with name prefix + && name <> "key" + && (for_hover || not (List.mem name idents_seen))) |> List.map mk_label) @ key_labels | CdecoratorPayload (JsxConfig {prefix; nested}) -> ( @@ -2221,15 +2219,15 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover | Some (`Assoc items) -> items |> List.filter_map (fun (key, t) -> - match (key, t) with - | ("dependencies" | "devDependencies"), `Assoc o -> - Some - (o - |> List.filter_map (fun (pkg_name, _) -> - match pkg_name with - | "rescript" -> None - | pkg_name -> Some pkg_name)) - | _ -> None) + match (key, t) with + | ("dependencies" | "devDependencies"), `Assoc o -> + Some + (o + |> List.filter_map (fun (pkg_name, _) -> + match pkg_name with + | "rescript" -> None + | pkg_name -> Some pkg_name)) + | _ -> None) |> List.flatten | _ -> if debug then print_endline "Could not parse package.json"; @@ -2247,9 +2245,9 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover String_set.of_list (files |> List.filter_map (fun f -> - if Filename.extension f = ".res" then - Some (try Filename.chop_extension f with _ -> f) - else None)) + if Filename.extension f = ".res" then + Some (try Filename.chop_extension f with _ -> f) + else None)) in let is_internal_artifact_extension = function | ".ast" | ".cmi" | ".cmj" | ".cmt" | ".cmti" | ".iast" -> true @@ -2257,18 +2255,18 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover in files |> List.filter_map (fun file_name -> - let without_extension = - try Filename.chop_extension file_name with _ -> file_name - in - if - String.ends_with file_name ~suffix:package.suffix - && res_files |> String_set.mem without_extension - then None - else - match Filename.extension file_name with - | ".res" | ".resi" | "" -> None - | ext when is_internal_artifact_extension ext -> None - | _ -> Some ("./" ^ file_name)) + let without_extension = + try Filename.chop_extension file_name with _ -> file_name + in + if + String.ends_with file_name ~suffix:package.suffix + && res_files |> String_set.mem without_extension + then None + else + match Filename.extension file_name with + | ".res" | ".resi" | "" -> None + | ext when is_internal_artifact_extension ext -> None + | _ -> Some ("./" ^ file_name)) |> List.sort String.compare with _ -> if debug then print_endline "Could not read relative directory"; @@ -2278,10 +2276,10 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover items |> List.filter (fun name -> Utils.starts_with name prefix) |> List.map (fun name -> - let is_local = Utils.starts_with name "./" in - Completion.create name - ~kind:(Label (if is_local then "Local file" else "Package")) - ~env) + let is_local = Utils.starts_with name "./" in + Completion.create name + ~kind:(Label (if is_local then "Local file" else "Package")) + ~env) | Cdecorator prefix -> let mk_decorator (name, docstring, maybe_insert_text) = { @@ -2303,14 +2301,14 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover decorators |> List.filter (fun (decorator, _, _) -> Utils.starts_with decorator prefix) |> List.map (fun (decorator, maybe_insert_text, doc) -> - let parts = String.split_on_char '.' prefix in - let len = String.length prefix in - let dec2 = - if List.length parts > 1 then - String.sub decorator len (String.length decorator - len) - else decorator - in - (dec2, doc, maybe_insert_text)) + let parts = String.split_on_char '.' prefix in + let len = String.length prefix in + let dec2 = + if List.length parts > 1 then + String.sub decorator len (String.length decorator - len) + else decorator + in + (dec2, doc, maybe_insert_text)) |> List.map mk_decorator | CnamedArg (cp, prefix, idents_seen) -> let labels = @@ -2328,10 +2326,10 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover typ |> Type_utils.get_args ~full ~env ~state |> List.filter_map (fun arg -> - match arg with - | Shared_types.Completable.Labelled name, a -> Some (name, a) - | Optional name, a -> Some (name, a) - | _ -> None) + match arg with + | Shared_types.Completable.Labelled name, a -> Some (name, a) + | Optional name, a -> Some (name, a) + | _ -> None) | None -> [] in let mk_label (name, typ) = @@ -2339,8 +2337,8 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover in labels |> List.filter (fun (name, _t) -> - Utils.starts_with name prefix - && (for_hover || not (List.mem name idents_seen))) + 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 () = @@ -2362,9 +2360,9 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover typ |> Type_utils.extract_type ~env ~package:full.package ~state |> Utils.Option.flat_map (fun (typ, type_arg_context) -> - typ - |> Type_utils.resolve_nested ?type_arg_context ~env ~full ~nested - ~state) + typ + |> Type_utils.resolve_nested ?type_arg_context ~env ~full ~nested + ~state) with | None -> fallback_or_empty () | Some (typ, _env, completion_context, type_arg_context) -> @@ -2452,15 +2450,15 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover |> complete_typed_value ?type_arg_context ~raw_opens ~mode:Expression ~full ~prefix ~completion_context ~state |> List.map (fun (c : Completion.t) -> - if wrap_insert_text_in_braces then - { - c with - insert_text = - (match c.insert_text with - | None -> None - | Some text -> Some ("{" ^ text ^ "}")); - } - else c) + if wrap_insert_text_in_braces then + { + c with + insert_text = + (match c.insert_text with + | None -> None + | Some text -> Some ("{" ^ text ^ "}")); + } + else c) in match (prefix, completion_context) with | "", _ -> items @@ -2472,7 +2470,7 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover guaranteed to end up on top. *) items |> List.map (fun (c : Completion.t) -> - {c with sort_text = Some ("A" ^ " " ^ c.name)}) + {c with sort_text = Some ("A" ^ " " ^ c.name)}) else items in items @ regular_completions @@ -2487,8 +2485,8 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover c.name ^ " {\n" ^ (cases |> List.mapi (fun index case_text -> - "| " ^ case_text ^ " => " - ^ print_failwith_str (start_index + index + 1)) + "| " ^ case_text ^ " => " + ^ print_failwith_str (start_index + index + 1)) |> String.concat "\n") ^ "\n}" |> Utils.indent range.start.character @@ -2512,55 +2510,53 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover in completions_for_context_path |> List.map (fun (c : Completion.t) -> - match c.kind with - | Value typ_expr -> ( - match - typ_expr |> Type_utils.extract_type ~env:c.env ~package ~state - with - | Some (Tvariant v, _) -> - with_exhaustive_item c - ~cases: - (v.constructors - |> List.map (fun (constructor : Constructor.t) -> - constructor.cname.txt - ^ - match constructor.args with - | Args [] -> "" - | _ -> "(_)")) - | Some (Tpolyvariant v, _) -> - with_exhaustive_item c - ~cases: - (v.constructors - |> List.map (fun (constructor : poly_variant_constructor) -> - "#" ^ constructor.display_name - ^ - match constructor.args with - | [] -> "" - | _ -> "(_)")) - | Some (Toption (_env, _typ), _) -> - with_exhaustive_item c ~cases:["Some($1)"; "None"] ~start_index:1 - | Some (Tresult _, _) -> - with_exhaustive_item c ~cases:["Ok($1)"; "Error($1)"] - ~start_index:1 - | Some (Tbool _, _) -> - with_exhaustive_item c ~cases:["true"; "false"] - | _ -> [c]) - | _ -> [c]) + match c.kind with + | Value typ_expr -> ( + match + typ_expr |> Type_utils.extract_type ~env:c.env ~package ~state + with + | Some (Tvariant v, _) -> + with_exhaustive_item c + ~cases: + (v.constructors + |> List.map (fun (constructor : Constructor.t) -> + constructor.cname.txt + ^ + match constructor.args with + | Args [] -> "" + | _ -> "(_)")) + | Some (Tpolyvariant v, _) -> + with_exhaustive_item c + ~cases: + (v.constructors + |> List.map (fun (constructor : poly_variant_constructor) -> + "#" ^ constructor.display_name + ^ + match constructor.args with + | [] -> "" + | _ -> "(_)")) + | Some (Toption (_env, _typ), _) -> + with_exhaustive_item c ~cases:["Some($1)"; "None"] ~start_index:1 + | Some (Tresult _, _) -> + with_exhaustive_item c ~cases:["Ok($1)"; "Error($1)"] ~start_index:1 + | Some (Tbool _, _) -> with_exhaustive_item c ~cases:["true"; "false"] + | _ -> [c]) + | _ -> [c]) |> List.flatten | ChtmlElement {prefix} -> Completion_jsx.html_elements |> List.filter_map (fun (element_name, description, deprecated) -> - if Utils.starts_with element_name prefix then - let name = "<" ^ element_name ^ ">" in - Some - (Completion.create name ~synthetic:true ~kind:(Label name) - ~detail:description ~env ~docstring:[description] - ~insert_text:element_name - ?deprecated: - (match deprecated with - | true -> Some "true" - | false -> None)) - else None) + if Utils.starts_with element_name prefix then + let name = "<" ^ element_name ^ ">" in + Some + (Completion.create name ~synthetic:true ~kind:(Label name) + ~detail:description ~env ~docstring:[description] + ~insert_text:element_name + ?deprecated: + (match deprecated with + | true -> Some "true" + | false -> None)) + else None) | CextensionNode prefix -> if Utils.starts_with "todo" prefix then let detail = diff --git a/analysis/src/completion_expressions.ml b/analysis/src/completion_expressions.ml index 55612e8aa1a..5c01dd6d1b5 100644 --- a/analysis/src/completion_expressions.ml +++ b/analysis/src/completion_expressions.ml @@ -36,9 +36,9 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos let array_item_with_cursor = array_patterns |> List.find_map (fun e -> - e - |> traverse_expr ~expr_path:next_expr_path - ~first_char_before_cursor_no_white ~pos) + e + |> traverse_expr ~expr_path:next_expr_path + ~first_char_before_cursor_no_white ~pos) in match (array_item_with_cursor, loc_has_cursor exp.pexp_loc) with @@ -222,10 +222,10 @@ and traverse_expr_tuple_items tuple_items ~next_expr_path let item_with_cursor = tuple_items |> List.find_map (fun e -> - item_num := !item_num + 1; - e - |> traverse_expr ~expr_path:(next_expr_path !item_num) - ~first_char_before_cursor_no_white ~pos) + item_num := !item_num + 1; + e + |> traverse_expr ~expr_path:(next_expr_path !item_num) + ~first_char_before_cursor_no_white ~pos) in match (item_with_cursor, first_char_before_cursor_no_white) with | None, Some ',' -> @@ -234,7 +234,7 @@ and traverse_expr_tuple_items tuple_items ~next_expr_path let pos_num = ref (-1) in tuple_items |> List.iteri (fun index e -> - if pos >= Loc.start e.Parsetree.pexp_loc then pos_num := index); + if pos >= 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 diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index 42115a593b5..a0ea27e0ac0 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -479,22 +479,22 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file | Ppat_tuple pl -> pl |> List.iteri (fun index p -> - scope_pattern p - ~pattern_path:(NTupleItem {item_num = index} :: pattern_path) - ?context_path) + 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 -> - scope_pattern p - ~pattern_path: - (NVariantPayload - { - item_num = index; - constructor_name = Utils.get_unqualified_name txt; - } - :: pattern_path) - ?context_path) + scope_pattern p + ~pattern_path: + (NVariantPayload + { + item_num = index; + constructor_name = Utils.get_unqualified_name txt; + } + :: pattern_path) + ?context_path) | Ppat_construct ({txt}, Some p) -> scope_pattern ~pattern_path: @@ -506,11 +506,11 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file | Ppat_variant (txt, Some {ppat_desc = Ppat_tuple pl}) -> pl |> List.iteri (fun index p -> - scope_pattern p - ~pattern_path: - (NPolyvariantPayload {item_num = index; constructor_name = txt} - :: pattern_path) - ?context_path) + scope_pattern p + ~pattern_path: + (NPolyvariantPayload {item_num = index; constructor_name = txt} + :: pattern_path) + ?context_path) | Ppat_variant (txt, Some p) -> scope_pattern ~pattern_path: @@ -591,14 +591,14 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file | Ptype_variant constr_decls -> constr_decls |> List.iter (fun (cd : Parsetree.constructor_declaration) -> - scope := - !scope - |> Scope.add_constructor ~name:cd.pcd_name.txt ~loc:cd.pcd_loc) + scope := + !scope + |> 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.add_field ~name:ld.pld_name.txt ~loc:ld.pld_loc) + scope := + !scope |> Scope.add_field ~name:ld.pld_name.txt ~loc:ld.pld_loc) | _ -> () in let scope_type_declaration (td : Parsetree.type_declaration) = @@ -690,13 +690,13 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file let has_case_with_cursor = cases |> List.find_opt (fun case -> - loc_has_cursor case.Parsetree.pc_lhs.ppat_loc) + loc_has_cursor case.Parsetree.pc_lhs.ppat_loc) |> Option.is_some in let has_case_with_empty_loc = cases |> List.find_opt (fun case -> - loc_is_empty case.Parsetree.pc_lhs.ppat_loc) + loc_is_empty case.Parsetree.pc_lhs.ppat_loc) |> Option.is_some in if Debug.verbose () && debug_typed_completion_expr then @@ -1051,37 +1051,37 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file let current_unlabelled_count = ref (if is_pipe then 1 else 0) in args |> List.iter (fun (arg : arg) -> - let previous_ctx_path = !current_ctx_path in - set_current_ctx_path - (CArgument - { - function_context_path; - argument_label = - (match arg with - | {label = None} -> - 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; - reset_current_ctx_path previous_ctx_path)) + let previous_ctx_path = !current_ctx_path in + set_current_ctx_path + (CArgument + { + function_context_path; + argument_label = + (match arg with + | {label = None} -> + 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; + reset_current_ctx_path previous_ctx_path)) | Some arg_completable -> set_result arg_completable and iterate_jsx_props ~iterator (props : Completion_jsx.jsx_props) = props.props |> List.iter (fun (prop : Completion_jsx.prop) -> - let previous_ctx_path = !current_ctx_path in - set_current_ctx_path - (CJsxPropValue - { - 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; - reset_current_ctx_path previous_ctx_path) + let previous_ctx_path = !current_ctx_path in + set_current_ctx_path + (CJsxPropValue + { + 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; + reset_current_ctx_path previous_ctx_path) and expr (iterator : Ast_iterator.iterator) (expr : Parsetree.expression) = let old_in_jsx_context = !in_jsx_context in let processed = ref false in @@ -1143,14 +1143,14 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file let old_ctx_path = !current_ctx_path in cases |> List.iter (fun (case : Parsetree.case) -> - let old_scope = !scope in - if - 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 := old_scope); + let old_scope = !scope in + if + 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 := old_scope); reset_current_ctx_path old_ctx_path | Pexp_apply { @@ -1184,17 +1184,17 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file 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 -> - set_result - (Cpath - (CPField - { - context_path = cpath; - field_name = ""; - pos_of_dot; - expr_loc = expr.pexp_loc; - in_jsx = !in_jsx_context; - })); - set_found ()) + set_result + (Cpath + (CPField + { + context_path = cpath; + field_name = ""; + pos_of_dot; + expr_loc = expr.pexp_loc; + in_jsx = !in_jsx_context; + })); + set_found ()) (* A dot completion for a tagged templated application with an ident. Example: @@ -1215,17 +1215,17 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file && 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 -> - set_result - (Cpath - (CPField - { - context_path = cpath; - field_name; - pos_of_dot; - expr_loc = expr.pexp_loc; - in_jsx = !in_jsx_context; - })); - set_found ()) + set_result + (Cpath + (CPField + { + context_path = cpath; + field_name; + pos_of_dot; + expr_loc = expr.pexp_loc; + in_jsx = !in_jsx_context; + })); + set_found ()) | _ -> ( if expr.pexp_loc |> Loc.has_pos ~pos:pos_no_white && !result = None then ( set_found (); @@ -1546,14 +1546,14 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file (Loc.to_string fun_expr.pexp_loc) (args |> List.map (fun {label; exp} -> - Printf.sprintf "%s...%s" - (match label with - | None -> "" - | Some {name; opt; pos_start; pos_end} -> - "~" ^ name ^ Pos.to_string pos_start ^ "->" - ^ Pos.to_string pos_end ^ "=" - ^ if opt then "?" else "") - (Loc.to_string exp.pexp_loc)) + Printf.sprintf "%s...%s" + (match label with + | None -> "" + | Some {name; opt; pos_start; pos_end} -> + "~" ^ name ^ Pos.to_string pos_start ^ "->" + ^ Pos.to_string pos_end ^ "=" + ^ if opt then "?" else "") + (Loc.to_string exp.pexp_loc)) |> String.concat ", "); let fun_ctx_path = diff --git a/analysis/src/completion_jsx.ml b/analysis/src/completion_jsx.ml index eaa3c9ccaa0..41e0fadf1d9 100644 --- a/analysis/src/completion_jsx.ml +++ b/analysis/src/completion_jsx.ml @@ -223,12 +223,11 @@ let get_jsx_labels ~component_path ~find_type_of_value ~package ~state = } ) -> label_decls |> List.map (fun (ld : Types.label_declaration) -> - let name = Ident.name ld.ld_id in - let t = - ld.ld_type - |> Type_utils.instantiate_type ~type_params ~type_args - in - (name, t, env)) + let name = Ident.name ld.ld_id in + let t = + ld.ld_type |> Type_utils.instantiate_type ~type_params ~type_args + in + (name, t, env)) | _ -> [] in let rec get_labels (t : Types.type_expr) = @@ -470,28 +469,28 @@ let extract_jsx_props ~(comp_name : Longident.t Location.loc) ~props ~children = let props = props |> List.map (function - | JSXPropPunning (_, name) -> - { - name = name.txt; - 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}; - } - | JSXPropValue (name, _, value) -> - { - name = name.txt; - pos_start = Loc.start name.loc; - pos_end = Loc.end_ name.loc; - exp = value; - } - | JSXPropSpreading (loc, expr) -> - { - name = "_spreadProps"; - pos_start = Loc.start loc; - pos_end = Loc.end_ loc; - exp = expr; - }) + | JSXPropPunning (_, name) -> + { + name = name.txt; + 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}; + } + | JSXPropValue (name, _, value) -> + { + name = name.txt; + pos_start = Loc.start name.loc; + pos_end = Loc.end_ name.loc; + exp = value; + } + | JSXPropSpreading (loc, expr) -> + { + name = "_spreadProps"; + pos_start = Loc.start loc; + pos_end = Loc.end_ loc; + exp = expr; + }) in {comp_name; props; children_start} diff --git a/analysis/src/completion_patterns.ml b/analysis/src/completion_patterns.ml index fdbd30aeaec..706b4d924b3 100644 --- a/analysis/src/completion_patterns.ml +++ b/analysis/src/completion_patterns.ml @@ -17,12 +17,12 @@ let rec traverse_tuple_items tuple_items ~next_pattern_path 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) + item_num := !item_num + 1; + pat + |> traverse_pattern + ~pattern_path:(next_pattern_path !item_num) + ~loc_has_cursor ~first_char_before_cursor_no_white + ~pos_before_cursor) in match (item_with_cursor, first_char_before_cursor_no_white) with | None, Some ',' -> @@ -31,8 +31,8 @@ let rec traverse_tuple_items tuple_items ~next_pattern_path let pos_num = ref (-1) in tuple_items |> List.iteri (fun index pat -> - if pos_before_cursor >= Loc.start pat.Parsetree.ppat_loc then - pos_num := index); + if pos_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 @@ -68,9 +68,9 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor let or_pat_with_item = [p1; p2] |> List.find_map (fun p -> - p - |> traverse_pattern ~pattern_path ~loc_has_cursor - ~first_char_before_cursor_no_white ~pos_before_cursor) + p + |> traverse_pattern ~pattern_path ~loc_has_cursor + ~first_char_before_cursor_no_white ~pos_before_cursor) in match or_pat_with_item with | None when is_pattern_hole p1 || is_pattern_hole p2 -> @@ -102,9 +102,9 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor else array_patterns |> List.find_map (fun pat -> - pat - |> traverse_pattern ~pattern_path:next_pattern_path ~loc_has_cursor - ~first_char_before_cursor_no_white ~pos_before_cursor) + pat + |> traverse_pattern ~pattern_path:next_pattern_path ~loc_has_cursor + ~first_char_before_cursor_no_white ~pos_before_cursor) | Ppat_tuple tuple_items when loc_has_cursor pat.ppat_loc -> tuple_items |> traverse_tuple_items ~first_char_before_cursor_no_white diff --git a/analysis/src/create_interface.ml b/analysis/src/create_interface.ml index c3d02853a7e..9a6e3495377 100644 --- a/analysis/src/create_interface.ml +++ b/analysis/src/create_interface.ml @@ -52,22 +52,22 @@ end = struct let res = ref [] in lines |> List.iteri (fun line_idx line -> - let state = ref Search in - for i = 0 to String.length line - 1 do - let ch = line.[i] in - match (!state, ch) with - | Search, '@' -> state := Collect i - | Collect attr_offset, ' ' -> - res := make_attr line_idx attr_offset i line :: !res; - state := Search - | Search, _ | Collect _, _ -> () - done; + let state = ref Search in + for i = 0 to String.length line - 1 do + let ch = line.[i] in + match (!state, ch) with + | Search, '@' -> state := Collect i + | Collect attr_offset, ' ' -> + res := make_attr line_idx attr_offset i line :: !res; + state := Search + | Search, _ | Collect _, _ -> () + done; - match !state with - | Collect attr_offset -> - res := - make_attr line_idx attr_offset (String.length line) line :: !res - | _ -> ()); + match !state with + | Collect attr_offset -> + res := + make_attr line_idx attr_offset (String.length line) line :: !res + | _ -> ()); !res |> List.rev let contains attribute_for_search t = @@ -82,15 +82,15 @@ end = struct let res = ref [] in t |> List.iter (fun attr -> - let {line; offset; name} = attr in + let {line; offset; name} = attr in - if line <> !prev_line then ( - res := !buffer :: !res; - buffer := ""; - prev_line := line); + if line <> !prev_line then ( + res := !buffer :: !res; + buffer := ""; + prev_line := line); - let indent = String.make (offset - String.length !buffer) ' ' in - buffer := !buffer ^ indent ^ name); + let indent = String.make (offset - String.length !buffer) ' ' in + buffer := !buffer ^ indent ^ name); res := !buffer :: !res; !res |> List.rev |> String.concat "\n" end @@ -162,18 +162,17 @@ let print_signature ~extractor ~signature = let params = label_decls |> List.map (fun (label_decl : Types.label_declaration) -> - let prop_type = - Type_utils.instantiate_type ~type_params ~type_args - label_decl.ld_type - in - let lbl_name = label_decl.ld_id |> Ident.name in - let lbl = - if label_decl.ld_optional then - Asttypes.Optional {txt = lbl_name; loc = Location.none} - else - Asttypes.Labelled {txt = lbl_name; loc = Location.none} - in - {Types.lbl; typ = prop_type}) + let prop_type = + Type_utils.instantiate_type ~type_params ~type_args + label_decl.ld_type + in + let lbl_name = label_decl.ld_id |> Ident.name in + let lbl = + if label_decl.ld_optional then + Asttypes.Optional {txt = lbl_name; loc = Location.none} + else Asttypes.Labelled {txt = lbl_name; loc = Location.none} + in + {Types.lbl; typ = prop_type}) in {ret_type with desc = Tarrow (params, ret_type)} in @@ -282,13 +281,13 @@ let print_signature ~extractor ~signature = Buffer.add_string buf "("; args |> List.iter (fun (id, mto) -> - Buffer.add_string buf ("\n" ^ indent ^ " "); - (match mto with - | None -> Buffer.add_string buf (Ident.name id) - | Some mt -> - Buffer.add_string buf (Ident.name id ^ ": "); - process_module_type ~indent:(indent ^ " ") mt); - Buffer.add_string buf ","); + Buffer.add_string buf ("\n" ^ indent ^ " "); + (match mto with + | None -> Buffer.add_string buf (Ident.name id) + | Some mt -> + Buffer.add_string buf (Ident.name id ^ ": "); + process_module_type ~indent:(indent ^ " ") mt); + Buffer.add_string buf ","); if args <> [] then Buffer.add_string buf ("\n" ^ indent); Buffer.add_string buf (") =>\n" ^ indent); process_module_type ~indent ret_mt diff --git a/analysis/src/diagnostics.ml b/analysis/src/diagnostics.ml index bcc537b9667..2b73f9b7d9a 100644 --- a/analysis/src/diagnostics.ml +++ b/analysis/src/diagnostics.ml @@ -2,24 +2,23 @@ let document_syntax ~source ~kind_file = let get_diagnostics diagnostics = diagnostics |> List.map (fun diagnostic -> - let _, startline, startcol = - Location.get_pos_info (Res_diagnostics.get_start_pos diagnostic) - in - let _, endline, endcol = - Location.get_pos_info (Res_diagnostics.get_end_pos diagnostic) - in - let range = - Lsp.Types.Range.create - ~start: - (Lsp.Types.Position.create ~line:(startline - 1) - ~character:startcol) - ~end_: - (Lsp.Types.Position.create ~line:(endline - 1) - ~character:endcol) - in - Lsp.Types.Diagnostic.create ~range - ~message:(`String (Res_diagnostics.explain diagnostic)) - ~severity:Lsp.Types.DiagnosticSeverity.Error ()) + let _, startline, startcol = + Location.get_pos_info (Res_diagnostics.get_start_pos diagnostic) + in + let _, endline, endcol = + Location.get_pos_info (Res_diagnostics.get_end_pos diagnostic) + in + let range = + Lsp.Types.Range.create + ~start: + (Lsp.Types.Position.create ~line:(startline - 1) + ~character:startcol) + ~end_: + (Lsp.Types.Position.create ~line:(endline - 1) ~character:endcol) + in + Lsp.Types.Diagnostic.create ~range + ~message:(`String (Res_diagnostics.explain diagnostic)) + ~severity:Lsp.Types.DiagnosticSeverity.Error ()) in if kind_file = Files.Res then let parse_implementation = diff --git a/analysis/src/document_symbol.ml b/analysis/src/document_symbol.ml index 8a70389eb9b..8aa54586d96 100644 --- a/analysis/src/document_symbol.ml +++ b/analysis/src/document_symbol.ml @@ -30,11 +30,11 @@ let get_symbols ~source ~kind_file = | Ptype_variant constr_decls -> constr_decls |> List.iter (fun (cd : Parsetree.constructor_declaration) -> - add_symbol cd.pcd_name.txt cd.pcd_loc EnumMember) + add_symbol cd.pcd_name.txt cd.pcd_loc EnumMember) | Ptype_record label_decls -> label_decls |> List.iter (fun (ld : Parsetree.label_declaration) -> - add_symbol ld.pld_name.txt ld.pld_loc Property) + add_symbol ld.pld_name.txt ld.pld_loc Property) | _ -> () in let process_type_declaration (td : Parsetree.type_declaration) = diff --git a/analysis/src/dot_completion_utils.ml b/analysis/src/dot_completion_utils.ml index a4421b3697b..6cd0f4e7123 100644 --- a/analysis/src/dot_completion_utils.ml +++ b/analysis/src/dot_completion_utils.ml @@ -1,12 +1,12 @@ let filter_record_fields ~env ~record_as_string ~prefix ~exact fields = fields |> Utils.filter_map (fun (field : Shared_types.field) -> - if Utils.check_name field.fname.txt ~prefix ~exact then - Some - (Shared_types.Completion.create field.fname.txt ~env - ?deprecated:field.deprecated ~docstring:field.docstring - ~kind:(Shared_types.Completion.Field (field, record_as_string))) - else None) + if Utils.check_name field.fname.txt ~prefix ~exact then + Some + (Shared_types.Completion.create field.fname.txt ~env + ?deprecated:field.deprecated ~docstring:field.docstring + ~kind:(Shared_types.Completion.Field (field, record_as_string))) + else None) let field_completions_for_dot_completion ?pos_of_dot typ ~env ~state ~package ~prefix ~exact = @@ -18,20 +18,20 @@ let field_completions_for_dot_completion ?pos_of_dot typ ~env ~state ~package Printf.printf "[dot_completion]--> Obj type found:\n"; obj |> Type_utils.get_obj_fields |> Utils.filter_map (fun (field, _typ) -> - if Utils.check_name field ~prefix ~exact then - let full_obj_field_name = Printf.sprintf "[\"%s\"]" field in - Some - (Shared_types.Completion.create full_obj_field_name - ~synthetic:true ~insert_text:full_obj_field_name ~env:obj_env - ~kind:(Shared_types.Completion.ObjLabel typ) - ?additional_text_edits: - (match pos_of_dot with - | None -> None - | Some pos_of_dot -> - Some - (Type_utils.make_additional_text_edits_for_removing_dot - pos_of_dot))) - else None) + if Utils.check_name field ~prefix ~exact then + let full_obj_field_name = Printf.sprintf "[\"%s\"]" field in + Some + (Shared_types.Completion.create full_obj_field_name ~synthetic:true + ~insert_text:full_obj_field_name ~env:obj_env + ~kind:(Shared_types.Completion.ObjLabel typ) + ?additional_text_edits: + (match pos_of_dot with + | None -> None + | Some pos_of_dot -> + Some + (Type_utils.make_additional_text_edits_for_removing_dot + pos_of_dot))) + else None) | None -> ( match typ |> Type_utils.extract_record_type ~env ~state ~package with | Some (env, fields, typ_decl) -> diff --git a/analysis/src/dump_ast.ml b/analysis/src/dump_ast.ml index 6c8fd4ed377..ae75f6dca6c 100644 --- a/analysis/src/dump_ast.ml +++ b/analysis/src/dump_ast.ml @@ -135,8 +135,8 @@ let rec print_pattern pattern ~pos ~indentation = "Ppat_tuple(\n" ^ (patterns |> List.map (fun pattern -> - add_indentation (indentation + 2) - ^ (pattern |> print_pattern ~pos ~indentation:(indentation + 2))) + add_indentation (indentation + 2) + ^ (pattern |> print_pattern ~pos ~indentation:(indentation + 2))) |> String.concat ",\n") ^ "\n" ^ add_indentation indentation @@ -180,7 +180,7 @@ and print_expr_item expr ~pos ~indentation = ^ add_indentation (indentation + 1) ^ (exprs |> List.map (fun expr -> - expr |> print_expr_item ~pos ~indentation:(indentation + 1)) + expr |> print_expr_item ~pos ~indentation:(indentation + 1)) |> String.concat ("\n" ^ add_indentation (indentation + 1))) ^ "\n" ^ add_indentation indentation @@ -191,8 +191,8 @@ and print_expr_item expr ~pos ~indentation = ^ ")\n" ^ (cases |> List.mapi (fun case_num case -> - print_case case ~pos ~case_num:(case_num + 1) - ~indentation:(indentation + 1)) + print_case case ~pos ~case_num:(case_num + 1) + ~indentation:(indentation + 1)) |> String.concat "\n") | Pexp_ident {txt} -> "Pexp_ident:" ^ (Utils.flatten_long_ident txt |> Shared_types.ident) @@ -219,10 +219,10 @@ and print_expr_item expr ~pos ~indentation = ^ "args:\n" ^ (args |> List.map (fun arg -> - add_indentation (indentation + 2) - ^ print_label arg.label ~pos ^ "=\n" - ^ add_indentation (indentation + 3) - ^ print_expr_item arg.exp ~pos ~indentation:(indentation + 3)) + add_indentation (indentation + 2) + ^ print_label arg.label ~pos ^ "=\n" + ^ add_indentation (indentation + 3) + ^ print_expr_item arg.exp ~pos ~indentation:(indentation + 3)) |> String.concat ",\n") ^ "\n" ^ add_indentation indentation @@ -289,8 +289,8 @@ and print_expr_item expr ~pos ~indentation = "Pexp_tuple(\n" ^ (exprs |> List.map (fun expr -> - add_indentation (indentation + 2) - ^ (expr |> print_expr_item ~pos ~indentation:(indentation + 2))) + add_indentation (indentation + 2) + ^ (expr |> print_expr_item ~pos ~indentation:(indentation + 2))) |> String.concat ",\n") ^ "\n" ^ add_indentation indentation @@ -307,7 +307,7 @@ let print_value_binding value ~pos ~indentation = ^ "constraint: type " ^ (pvc_newtypes |> List.map (fun ({Location.txt} as name) -> - (name |> print_loc_denominator_loc ~pos) ^ txt) + (name |> print_loc_denominator_loc ~pos) ^ txt) |> String.concat " ") ^ ". " ^ print_core_type pvc_type ~pos @@ -357,7 +357,7 @@ let print_struct_item struct_item ~pos ~source = | Nonrecursive -> "") ^ (values |> List.map (fun value -> - add_indentation 1 ^ print_value_binding value ~pos ~indentation:1) + add_indentation 1 ^ print_value_binding value ~pos ~indentation:1) |> String.concat ",\n") ^ "\n)" | _ -> "") diff --git a/analysis/src/files.ml b/analysis/src/files.ml index 2c71d6a736a..9cdf77bb581 100644 --- a/analysis/src/files.ml +++ b/analysis/src/files.ml @@ -35,8 +35,8 @@ let relpath base path = in String.concat Filename.dir_sep ((match base with - | [] -> ["."] - | _ -> List.map (fun _ -> "..") base) + | [] -> ["."] + | _ -> List.map (fun _ -> "..") base) @ path) |> remove_extra_dots @@ -92,16 +92,14 @@ let rec collect ?(check_dir = fun _ -> true) ?max_depth path test = if check_dir path then read_directory path |> List.map (fun name -> - collect ~check_dir (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 check_dir path then read_directory path |> List.map (fun name -> - collect ~check_dir ~max_depth:(n - 1) - (Filename.concat path name) - test) + collect ~check_dir ~max_depth:(n - 1) (Filename.concat path name) test) |> List.concat else [] | _ -> if test path then [path] else [] diff --git a/analysis/src/find_files.ml b/analysis/src/find_files.ml index de9c066446f..0891e210825 100644 --- a/analysis/src/find_files.ml +++ b/analysis/src/find_files.ml @@ -75,18 +75,18 @@ let filter_duplicates cmts = let intfs = Hashtbl.create 100 in cmts |> List.iter (fun path -> - if - Filename.check_suffix path ".rei" - || Filename.check_suffix path ".mli" - || Filename.check_suffix path ".cmti" - then Hashtbl.add intfs (get_name path) true); + if + Filename.check_suffix path ".rei" + || Filename.check_suffix path ".mli" + || Filename.check_suffix path ".cmti" + then Hashtbl.add intfs (get_name path) true); cmts |> List.filter (fun path -> - not - ((Filename.check_suffix path ".re" - || Filename.check_suffix path ".ml" - || Filename.check_suffix path ".cmt") - && Hashtbl.mem intfs (get_name path))) + not + ((Filename.check_suffix path ".re" + || Filename.check_suffix path ".ml" + || Filename.check_suffix path ".cmt") + && Hashtbl.mem intfs (get_name path))) let name_space_to_name n = n @@ -139,18 +139,17 @@ let collect_files directory = let sources = all_files |> List.filter is_source_file |> filter_duplicates in compileds |> Utils.filter_map (fun path -> - let mod_name = get_name path in - let cmt = directory /+ path in - let res_opt = - Utils.find - (fun name -> - if get_name name = mod_name then Some (directory /+ name) - else None) - sources - in - match res_opt with - | None -> None - | Some res -> Some (mod_name, Shared_types.Impl {cmt; res})) + let mod_name = get_name path in + let cmt = directory /+ path in + let res_opt = + Utils.find + (fun name -> + if get_name name = mod_name then Some (directory /+ name) else None) + sources + in + match res_opt with + | None -> None + | Some res -> Some (mod_name, Shared_types.Impl {cmt; res})) (* Dependency resolution uses the package graph recorded by the build system in .sourcedirs.json when available. If a package is not listed there, analysis @@ -194,68 +193,61 @@ let find_project_files ~public ~namespace ~path ~source_directories ~lib_bs = in dirs |> if_debug true "Source directories" (fun s -> - s |> String_set.elements |> List.map Utils.dump_path - |> String.concat " "); + s |> String_set.elements |> List.map Utils.dump_path |> String.concat " "); files |> if_debug true "Source files" (fun s -> - s |> String_set.elements |> List.map Utils.dump_path - |> String.concat " "); + s |> String_set.elements |> List.map Utils.dump_path |> String.concat " "); let interfaces = Hashtbl.create 100 in files |> String_set.iter (fun path -> - if is_interface path then - Hashtbl.replace interfaces (get_name path) path); + if is_interface path then Hashtbl.replace interfaces (get_name path) path); let normals = files |> String_set.elements |> Utils.filter_map (fun file -> - if is_implementation file then ( - let module_name = get_name file in - let resi = Hashtbl.find_opt interfaces module_name in - Hashtbl.remove interfaces module_name; - let base = - compiled_base_name ~namespace (Files.relpath path file) - in - match resi with - | Some resi -> - let cmti = (lib_bs /+ base) ^ ".cmti" in - let cmt = (lib_bs /+ base) ^ ".cmt" in - if Files.exists cmti then - if Files.exists cmt then - (* Log.log("Intf and impl " ++ cmti ++ " " ++ cmt) *) - Some - ( module_name, - Shared_types.IntfAndImpl {cmti; resi; cmt; res = file} ) - else None - else ( - (* Log.log("Just intf " ++ cmti) *) - Log.log - ("Bad source file (no cmt/cmti/cmi) " ^ (lib_bs /+ base)); - None) - | None -> - let cmt = (lib_bs /+ base) ^ ".cmt" in - if Files.exists cmt then - Some (module_name, Impl {cmt; res = file}) - else ( - Log.log ("Bad source file (no cmt/cmi) " ^ (lib_bs /+ base)); - None)) - else None) + if is_implementation file then ( + let module_name = get_name file in + let resi = Hashtbl.find_opt interfaces module_name in + Hashtbl.remove interfaces module_name; + let base = compiled_base_name ~namespace (Files.relpath path file) in + match resi with + | Some resi -> + let cmti = (lib_bs /+ base) ^ ".cmti" in + let cmt = (lib_bs /+ base) ^ ".cmt" in + if Files.exists cmti then + if Files.exists cmt then + (* Log.log("Intf and impl " ++ cmti ++ " " ++ cmt) *) + Some + ( module_name, + Shared_types.IntfAndImpl {cmti; resi; cmt; res = file} ) + else None + else ( + (* Log.log("Just intf " ++ cmti) *) + Log.log ("Bad source file (no cmt/cmti/cmi) " ^ (lib_bs /+ base)); + None) + | None -> + let cmt = (lib_bs /+ base) ^ ".cmt" in + if Files.exists cmt then Some (module_name, Impl {cmt; res = file}) + else ( + Log.log ("Bad source file (no cmt/cmi) " ^ (lib_bs /+ base)); + None)) + else None) in let result = normals |> List.filter_map (fun (name, paths) -> - let original_name = name in - let name = - match namespace with - | None -> name - | Some namespace -> name ^ "-" ^ namespace - in - match public with - | Some public -> - if public |> String_set.mem original_name then Some (name, paths) - else None - | None -> Some (name, paths)) + let original_name = name in + let name = + match namespace with + | None -> name + | Some namespace -> name ^ "-" ^ namespace + in + match public with + | Some public -> + if public |> String_set.mem original_name then Some (name, paths) + else None + | None -> Some (name, paths)) in match namespace with | None -> result @@ -298,49 +290,49 @@ let find_dependency_files base config = let dep_files = deps |> List.map (fun name -> - let result = - bind - (fun path -> - let rescript_json_path = path /+ "rescript.json" in + let result = + bind + (fun path -> + let rescript_json_path = path /+ "rescript.json" in - let parse_text text = - match Yojson_helpers.from_string_opt text with - | Some inner -> ( - let namespace = get_namespace inner in - let source_directories = - get_source_directories ~include_dev:false ~base_dir:path - inner - in - match Build_system.get_lib_bs path with - | None -> None - | Some lib_bs -> - let compiled_directories = - source_directories |> List.map (Filename.concat lib_bs) - in - let compiled_directories = - match namespace with - | None -> compiled_directories - | Some _ -> lib_bs :: compiled_directories - in - let project_files = - find_project_files ~public:(get_public inner) - ~namespace ~path ~source_directories ~lib_bs - in - Some (compiled_directories, project_files)) - | None -> None - in + let parse_text text = + match Yojson_helpers.from_string_opt text with + | Some inner -> ( + let namespace = get_namespace inner in + let source_directories = + get_source_directories ~include_dev:false ~base_dir:path + inner + in + match Build_system.get_lib_bs path with + | None -> None + | Some lib_bs -> + let compiled_directories = + source_directories |> List.map (Filename.concat lib_bs) + in + let compiled_directories = + match namespace with + | None -> compiled_directories + | Some _ -> lib_bs :: compiled_directories + in + let project_files = + find_project_files ~public:(get_public inner) ~namespace + ~path ~source_directories ~lib_bs + in + Some (compiled_directories, project_files)) + | None -> None + in - match Files.read_file rescript_json_path with - | Some text -> parse_text text - | None -> None) - (find_package_root ~base ~sourcedirs_package_roots name) - in + match Files.read_file rescript_json_path with + | Some text -> parse_text text + | None -> None) + (find_package_root ~base ~sourcedirs_package_roots name) + in - match result with - | Some (files, directories) -> (files, directories) - | None -> - Log.log ("Skipping nonexistent dependency: " ^ name); - ([], [])) + match result with + | Some (files, directories) -> (files, directories) + | None -> + Log.log ("Skipping nonexistent dependency: " ^ name); + ([], [])) in match Build_system.get_stdlib base with | None -> None diff --git a/analysis/src/hint.ml b/analysis/src/hint.ml index 6f0b87a34b6..0d28b7f2b3b 100644 --- a/analysis/src/hint.ml +++ b/analysis/src/hint.ml @@ -86,30 +86,30 @@ let inlay ~source ~kind_file ~pos ~max_length ~full ~state ~debug = let result = !hints |> List.filter_map (fun ((range : Lsp.Types.Range.t), hint_kind) -> - match - References.get_loc_item ~full - ~pos:(range.start.line, range.start.character + 1) - ~debug - with - | None -> None - | Some loc_item -> ( - let position = - Lsp.Types.Position.create ~line:range.start.line - ~character:range.end_.character - in - match loc_item_to_type_hint loc_item ~state ~full with - | Some label -> ( - 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) () - in - match max_length with - | Some value -> - if String.length label > value then None else Some result - | None -> Some result) - | None -> None)) + match + References.get_loc_item ~full + ~pos:(range.start.line, range.start.character + 1) + ~debug + with + | None -> None + | Some loc_item -> ( + let position = + Lsp.Types.Position.create ~line:range.start.line + ~character:range.end_.character + in + match loc_item_to_type_hint loc_item ~state ~full with + | Some label -> ( + 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) () + in + match max_length with + | Some value -> + if String.length label > value then None else Some result + | None -> Some result) + | None -> None)) in Some result @@ -149,23 +149,23 @@ let code_lens ~source ~kind_file ~full ~debug = let result = !lenses |> List.filter_map (fun (range : Lsp.Types.Range.t) -> - match - References.get_loc_item ~full - ~pos:(range.start.line, range.start.character + 1) - ~debug - with - | Some {loc_type = Typed (_, type_expr, _)} -> - (* Code lenses can run commands. An empty command string means we just want the editor + match + References.get_loc_item ~full + ~pos:(range.start.line, range.start.character + 1) + ~debug + with + | 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 = - Lsp.Types.Command.create - ~command:"" - (* Print the type with a huge line width, because the code lens always prints on a + let command = + Lsp.Types.Command.create + ~command:"" + (* Print the type with a huge line width, because the code lens always prints on a single line in the editor. *) - ~title:(type_expr |> Shared.type_to_string ~line_width:400) - () - in - Some (Lsp.Types.CodeLens.create ~range ~command ()) - | _ -> None) + ~title:(type_expr |> Shared.type_to_string ~line_width:400) + () + in + Some (Lsp.Types.CodeLens.create ~range ~command ()) + | _ -> None) in Some result diff --git a/analysis/src/hover.ml b/analysis/src/hover.ml index e59ca1da0dd..c4f5a629e8d 100644 --- a/analysis/src/hover.ml +++ b/analysis/src/hover.ml @@ -7,13 +7,13 @@ let show_module_top_level ~docstring ~is_type ~name let contents = top_level |> List.map (fun item -> - match item.Module.kind with - (* TODO pretty print module contents *) - | Type ({decl}, rec_status) -> - " " ^ (decl |> Shared.decl_to_string ~rec_status item.name) - | Module _ -> " module " ^ item.name - | Value typ -> - " let " ^ item.name ^ ": " ^ (typ |> Shared.type_to_string)) + match item.Module.kind with + (* TODO pretty print module contents *) + | Type ({decl}, rec_status) -> + " " ^ (decl |> Shared.decl_to_string ~rec_status item.name) + | Module _ -> " module " ^ item.name + | Value typ -> + " let " ^ item.name ^ ": " ^ (typ |> Shared.type_to_string)) (* TODO indent *) |> String.concat "\n" in @@ -86,16 +86,16 @@ let find_relevant_types_from_type ~state ~file ~package typ = ( env1, cds |> List.map (fun (cd : Types.constructor_declaration) -> - let from_args = - match cd.cd_args with - | Cstr_tuple ts -> ts - | Cstr_record lds -> lds |> label_declarations_types - in - typ - :: - (match cd.cd_res with - | None -> from_args - | Some t -> t :: from_args)) + let from_args = + match cd.cd_args with + | Cstr_tuple ts -> ts + | Cstr_record lds -> lds |> label_declarations_types + in + typ + :: + (match cd.cd_res with + | None -> from_args + | Some t -> t :: from_args)) |> List.flatten ) | _ -> (env, [typ]))) | None -> (env, [typ]) @@ -133,30 +133,28 @@ let expand_types ~state ~file ~package ~supports_markdown_links typ = ( all (* Don't produce duplicate type definitions for recursive types *) |> List.filter (fun {env; name} -> - let type_id = type_id ~env ~name in - if String_set.mem type_id !types_seen then false - else ( - types_seen := String_set.add type_id !types_seen; - true)) + let type_id = type_id ~env ~name in + if String_set.mem type_id !types_seen then false + else ( + types_seen := String_set.add type_id !types_seen; + true)) |> List.map (fun {decl; env; loc; path} -> - let link_to_type_definition_str = - if - supports_markdown_links - && not - (Res_parsetree_viewer - .has_inline_record_definition_attribute - decl.type_attributes) - then - Markdown.go_to_definition_text ~env ~pos:loc.Warnings.loc_start - else "" - in - Markdown.divider - ^ (if supports_markdown_links then Markdown.spacing else "") - ^ Markdown.code_block - (decl - |> Shared.decl_to_string ~print_name_as_is:true - (Shared_types.path_ident_to_string path)) - ^ link_to_type_definition_str ^ "\n"), + let link_to_type_definition_str = + if + supports_markdown_links + && not + (Res_parsetree_viewer.has_inline_record_definition_attribute + decl.type_attributes) + then Markdown.go_to_definition_text ~env ~pos:loc.Warnings.loc_start + else "" + in + Markdown.divider + ^ (if supports_markdown_links then Markdown.spacing else "") + ^ Markdown.code_block + (decl + |> Shared.decl_to_string ~print_name_as_is:true + (Shared_types.path_ident_to_string path)) + ^ link_to_type_definition_str ^ "\n"), `Default ) (* Produces a hover with relevant types expanded in the main type being hovered. *) diff --git a/analysis/src/local_tables.ml b/analysis/src/local_tables.ml index a4676d80eb0..69e9c84d073 100644 --- a/analysis/src/local_tables.ml +++ b/analysis/src/local_tables.ml @@ -27,39 +27,39 @@ let create () = let populate_values ~env local_tables = env.Query_env.file.stamps |> Stamps.iter_values (fun _ declared -> - Hashtbl.replace local_tables.value_table - (declared.name.txt, declared.name.loc |> Loc.start) - declared) + Hashtbl.replace local_tables.value_table + (declared.name.txt, declared.name.loc |> Loc.start) + declared) let populate_included_values ~env local_tables = env.Query_env.file.stamps |> Stamps.iter_values (fun _ declared -> - match declared.module_path with - | Module_path.IncludedModule (source, _) -> - let path = Path.name source in - let declared = {declared with item = (path, declared.item)} in - Hashtbl.replace local_tables.included_value_table - (declared.name.txt, declared.name.loc |> Loc.start) - declared - | _ -> ()) + match declared.module_path with + | Module_path.IncludedModule (source, _) -> + let path = Path.name source in + let declared = {declared with item = (path, declared.item)} in + Hashtbl.replace local_tables.included_value_table + (declared.name.txt, declared.name.loc |> Loc.start) + declared + | _ -> ()) let populate_constructors ~env local_tables = env.Query_env.file.stamps |> Stamps.iter_constructors (fun _ declared -> - Hashtbl.replace local_tables.constructor_table - (declared.name.txt, declared.extent_loc |> Loc.start) - declared) + Hashtbl.replace local_tables.constructor_table + (declared.name.txt, declared.extent_loc |> Loc.start) + declared) let populate_types ~env local_tables = env.Query_env.file.stamps |> Stamps.iter_types (fun _ declared -> - Hashtbl.replace local_tables.types_table - (declared.name.txt, declared.name.loc |> Loc.start) - declared) + Hashtbl.replace local_tables.types_table + (declared.name.txt, declared.name.loc |> Loc.start) + declared) let populate_modules ~env local_tables = env.Query_env.file.stamps |> Stamps.iter_modules (fun _ declared -> - Hashtbl.replace local_tables.modules_table - (declared.name.txt, declared.extent_loc |> Loc.start) - declared) + Hashtbl.replace local_tables.modules_table + (declared.name.txt, declared.extent_loc |> Loc.start) + declared) diff --git a/analysis/src/packages.ml b/analysis/src/packages.ml index ed90107de7a..1f12bf097d0 100644 --- a/analysis/src/packages.ml +++ b/analysis/src/packages.ml @@ -6,10 +6,10 @@ 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); + 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); + Hashtbl.replace paths_for_module mod_name paths); paths_for_module let override_rescript_version = ref None @@ -73,8 +73,8 @@ let new_bs_package ~root_path = let values = items |> List.filter_map (function - | `String s -> Some s - | _ -> None) + | `String s -> Some s + | _ -> None) in Misc.String_map.add key values acc | _ -> acc) @@ -145,9 +145,9 @@ let new_bs_package ~root_path = let no_pervasives = compiler_flags |> List.exists (fun s -> - match s with - | `String s -> s = "-nopervasives" - | _ -> false) + match s with + | `String s -> s = "-nopervasives" + | _ -> false) in let opens_from_compiler_flags = List.fold_left diff --git a/analysis/src/process_attributes.ml b/analysis/src/process_attributes.ml index 62df3ca3ea6..bd5b1567a94 100644 --- a/analysis/src/process_attributes.ml +++ b/analysis/src/process_attributes.ml @@ -33,11 +33,11 @@ let rec find_deprecated_attribute attributes = fields |> List.iter (fun {lid = {txt}; x} -> - match (txt, x) with - | ( Lident "reason", - {pexp_desc = Pexp_constant (Pconst_string (msg, _))} ) -> - reason := msg - | _ -> ()); + match (txt, x) with + | ( Lident "reason", + {pexp_desc = Pexp_constant (Pconst_string (msg, _))} ) -> + reason := msg + | _ -> ()); Some !reason | _ -> None) @@ -75,10 +75,10 @@ let rec find_editor_complete_from_attribute ?(module_paths = []) attributes = let module_paths_from_array = items |> List.filter_map (fun item -> - match item.Parsetree.pexp_desc with - | Pexp_construct ({txt = path}, None) -> - Some (Utils.flatten_long_ident path) - | _ -> None) + match item.Parsetree.pexp_desc with + | Pexp_construct ({txt = path}, None) -> + Some (Utils.flatten_long_ident path) + | _ -> None) in find_editor_complete_from_attribute ~module_paths:(module_paths_from_array @ module_paths) diff --git a/analysis/src/process_cmt.ml b/analysis/src/process_cmt.ml index 0ec4a4fd7b2..3cd5acbb5a5 100644 --- a/analysis/src/process_cmt.ml +++ b/analysis/src/process_cmt.ml @@ -248,7 +248,7 @@ let for_type_declaration ~env ~(exported : Exported.t) Args (args |> List.map (fun t -> - (t.Typedtree.ctyp_type, t.ctyp_loc))) + (t.Typedtree.ctyp_type, t.ctyp_loc))) | Cstr_record fields -> InlineRecord (fields @@ -351,13 +351,13 @@ let rec for_signature_item ~env ~(exported : Exported.t) | Tsig_type (rec_flag, decls) -> decls |> List.mapi (fun i decl -> - 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 |> for_type_declaration ~env ~exported ~rec_status) + 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 |> for_type_declaration ~env ~exported ~rec_status) | Tsig_module {md_id; md_attributes; md_loc; md_name = name; md_type = {mty_type}} -> let item = @@ -385,8 +385,8 @@ let rec for_signature_item ~env ~(exported : Exported.t) | Tsig_recmodule mod_decls -> mod_decls |> List.map (fun mod_decl -> - for_signature_item ~env ~exported - {item with sig_desc = Tsig_module 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 = @@ -450,8 +450,8 @@ let rec for_structure_item ~(env : Shared_types.Env.t) ~(exported : Exported.t) match pat.pat_extra |> Utils.filter_map (function - | Typedtree.Tpat_unpack, loc, _ -> Some loc - | _ -> None) + | Typedtree.Tpat_unpack, loc, _ -> Some loc + | _ -> None) with | loc :: _ -> Some loc | [] -> None @@ -575,8 +575,8 @@ let rec for_structure_item ~(env : Shared_types.Env.t) ~(exported : Exported.t) | Tstr_recmodule mod_decls -> mod_decls |> List.map (fun mod_decl -> - for_structure_item ~env ~exported - {item with str_desc = Tstr_module mod_decl}) + for_structure_item ~env ~exported + {item with str_desc = Tstr_module mod_decl}) |> List.flatten | Tstr_modtype { @@ -640,13 +640,13 @@ let rec for_structure_item ~(env : Shared_types.Env.t) ~(exported : Exported.t) | Tstr_type (rec_flag, decls) -> decls |> List.mapi (fun i decl -> - 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 |> for_type_declaration ~env ~exported ~rec_status) + 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 |> for_type_declaration ~env ~exported ~rec_status) | _ -> [] and for_module ~env mod_desc module_name = @@ -707,8 +707,8 @@ and scan_let_modules ~env (e : Typedtree.expression) = scan_let_modules ~env funct; args |> List.iter (function - | _, Some e -> scan_let_modules ~env e - | _, None -> ()) + | _, Some e -> scan_let_modules ~env e + | _, None -> ()) | Texp_tuple exprs -> List.iter (scan_let_modules ~env) exprs | Texp_sequence (e1, e2) -> scan_let_modules ~env e1; @@ -728,10 +728,10 @@ and scan_let_modules ~env (e : Typedtree.expression) = scan_let_modules ~env e; cases |> List.iter (fun {Typedtree.c_lhs = _; c_guard; c_rhs} -> - (match c_guard with - | Some g -> scan_let_modules ~env g - | None -> ()); - scan_let_modules ~env c_rhs) + (match c_guard with + | Some g -> scan_let_modules ~env g + | None -> ()); + scan_let_modules ~env c_rhs) | Texp_ifthenelse (e1, e2, e3_opt) -> ( scan_let_modules ~env e1; scan_let_modules ~env e2; @@ -750,9 +750,9 @@ and for_structure ~name ~env str_items = let attributes = str_items |> List.filter_map (fun (struc : Typedtree.structure_item) -> - match struc with - | {str_desc = Tstr_attribute attr} -> Some attr - | _ -> None) + match struc with + | {str_desc = Tstr_attribute attr} -> Some attr + | _ -> None) in let docstring = attrs_to_docstring attributes in let deprecated = Process_attributes.find_deprecated_attribute attributes in @@ -768,10 +768,10 @@ let file_for_cmt_infos ~module_name ~uri let items = parts |> Array.to_list |> 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) + 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 = for_structure ~name:module_name ~env items in @@ -780,10 +780,10 @@ let file_for_cmt_infos ~module_name ~uri let items = parts |> Array.to_list |> 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) + match p with + | Partial_signature str -> Some str.sig_items + | Partial_signature_item str -> Some [str] + | _ -> None) |> List.concat in let structure = for_signature ~name:module_name ~env items in diff --git a/analysis/src/process_extra.ml b/analysis/src/process_extra.ml index 2cd5782b578..b70cd87e75b 100644 --- a/analysis/src/process_extra.ml +++ b/analysis/src/process_extra.ml @@ -16,48 +16,43 @@ let extra_for_file ~(file : File.t) = let extra = init_extra () in file.stamps |> 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); + add_loc_item extra d.name.loc (LModule (Definition (stamp, Module))); + add_reference ~extra stamp d.name.loc); file.stamps |> 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))); - add_reference ~extra stamp d.name.loc); + add_loc_item extra d.name.loc + (Typed (d.name.txt, d.item, Definition (stamp, Value))); + add_reference ~extra stamp d.name.loc); file.stamps |> 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)); - add_reference ~extra stamp d.name.loc; - match d.item.Type.kind with - | Record labels -> - labels - |> List.iter (fun {stamp; fname; typ} -> - 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} -> - add_reference ~extra stamp cname.loc; - let t = - { - Types.id = 0; - level = 0; - desc = - Tconstr - ( Path.Pident - {Ident.stamp; name = d.name.txt; flags = 0}, - [], - ref Types.Mnil ); - } - in - add_loc_item extra cname.loc - (Typed - ( d.name.txt, - t, - Definition (d.stamp, Constructor cname.txt) ))) - | _ -> ()); + add_loc_item extra d.name.loc + (TypeDefinition (d.name.txt, d.item.Type.decl, stamp)); + add_reference ~extra stamp d.name.loc; + match d.item.Type.kind with + | Record labels -> + labels + |> List.iter (fun {stamp; fname; typ} -> + 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} -> + add_reference ~extra stamp cname.loc; + let t = + { + Types.id = 0; + level = 0; + desc = + Tconstr + ( Path.Pident {Ident.stamp; name = d.name.txt; flags = 0}, + [], + ref Types.Mnil ); + } + in + add_loc_item extra cname.loc + (Typed (d.name.txt, t, Definition (d.stamp, Constructor cname.txt)))) + | _ -> ()); extra let add_external_reference ~extra module_name path tip loc = @@ -100,15 +95,15 @@ let extra_for_cmt ~(iterator : Tast_iterator.iterator) let extra_for_parts parts = parts |> Array.iter (fun part -> - match part with - | Cmt_format.Partial_signature str -> iterator.signature iterator str - | Partial_signature_item str -> iterator.signature_item iterator str - | Partial_expression expression -> iterator.expr iterator expression - | Partial_pattern pattern -> iterator.pat iterator pattern - | Partial_class_expr _ -> () - | Partial_module_type module_type -> - iterator.module_type iterator module_type - | Partial_structure _ | Partial_structure_item _ -> ()) + match part with + | Cmt_format.Partial_signature str -> iterator.signature iterator str + | Partial_signature_item str -> iterator.signature_item iterator str + | Partial_expression expression -> iterator.expr iterator expression + | Partial_pattern pattern -> iterator.pat iterator pattern + | Partial_class_expr _ -> () + | Partial_module_type module_type -> + iterator.module_type iterator module_type + | Partial_structure _ | Partial_structure_item _ -> ()) in match cmt_annots with | Implementation structure -> @@ -117,11 +112,11 @@ let extra_for_cmt ~(iterator : Tast_iterator.iterator) let items = parts |> Array.to_list |> 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] - (* | Partial_expression(exp) => Some([ str]) *) - | _ -> None) + match p with + | Partial_structure str -> Some str.str_items + | Partial_structure_item str -> Some [str] + (* | Partial_expression(exp) => Some([ str]) *) + | _ -> None) |> List.concat in extra_for_structure_items ~iterator items; @@ -132,10 +127,10 @@ let extra_for_cmt ~(iterator : Tast_iterator.iterator) let items = parts |> Array.to_list |> 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) + match p with + | Partial_signature s -> Some s.sig_items + | Partial_signature_item str -> Some [str] + | _ -> None) |> List.concat in extra_for_signature_items ~iterator items; @@ -237,24 +232,23 @@ let add_for_record ~env ~extra ~record_type items = let t = get_type_at_path ~env path in items |> List.iter (fun ({Asttypes.txt; loc}, _, _, _) -> - (* let name = Longident.last(txt); *) - 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} -> - add_reference ~extra astamp name_loc; - LocalReference (stamp, Field name) - | None -> NotFound) - | `Global (module_name, path) -> - add_external_reference ~extra module_name path (Field name) - name_loc; - GlobalReference (module_name, path, Field name) - | _ -> NotFound - in - add_loc_item extra name_loc (Typed (name, record_type, loc_type))) + (* let name = Longident.last(txt); *) + 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} -> + add_reference ~extra astamp name_loc; + LocalReference (stamp, Field name) + | None -> NotFound) + | `Global (module_name, path) -> + add_external_reference ~extra module_name path (Field name) name_loc; + GlobalReference (module_name, path, Field name) + | _ -> NotFound + in + add_loc_item extra name_loc (Typed (name, record_type, loc_type))) | _ -> () let add_for_constructor ~env ~extra constructor_type {Asttypes.txt; loc} @@ -366,8 +360,8 @@ let pat ~(file : File.t) ~env ~extra (iter : Tast_iterator.iterator) match pattern.pat_extra |> List.filter_map (function - | Typedtree.Tpat_unpack, _, _ -> Some () - | _ -> None) + | Typedtree.Tpat_unpack, _, _ -> Some () + | _ -> None) with | _ :: _ -> true | [] -> false @@ -444,9 +438,9 @@ let expr ~env ~(extra : extra) (iter : Tast_iterator.iterator) add_for_record ~env ~extra ~record_type:expression.exp_type (fields |> Array.to_list |> Utils.filter_map (fun (desc, item, opt) -> - match item with - | Typedtree.Overridden (loc, _) -> Some (loc, desc, (), opt) - | _ -> None)) + match item with + | Typedtree.Overridden (loc, _) -> Some (loc, desc, (), opt) + | _ -> None)) | Texp_constant constant -> add_loc_item extra expression.exp_loc (Constant constant) (* Skip unit and list literals *) diff --git a/analysis/src/references.ml b/analysis/src/references.ml index d8ac611b46b..2f3946bddc5 100644 --- a/analysis/src/references.ml +++ b/analysis/src/references.ml @@ -496,7 +496,7 @@ let for_local_stamp ~state ~full:{file; extra; package} stamp (tip : Tip.t) = | Some locs -> locs |> List.map (fun loc -> - {uri = file.uri; loc_opt = Some 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 @@ -513,24 +513,23 @@ let for_local_stamp ~state ~full:{file; extra; package} stamp (tip : Tip.t) = package.project_files |> File_set.elements |> List.filter (fun name -> name <> file.module_name) |> List.map (fun module_name -> - Cmt.fulls_from_module ~package ~module_name - |> List.map (fun {file; extra} -> - match - Hashtbl.find_opt extra.external_references - normalized_module_name - with - | None -> [] - | Some refs -> - let locs = - refs - |> Utils.filter_map (fun (p, t, locs) -> - if p = normalized_path && t = tip then - Some locs - else None) - in - locs - |> List.map (fun loc -> - {uri = file.uri; loc_opt = Some loc}))) + Cmt.fulls_from_module ~package ~module_name + |> List.map (fun {file; extra} -> + match + Hashtbl.find_opt extra.external_references + normalized_module_name + with + | None -> [] + | Some refs -> + let locs = + refs + |> Utils.filter_map (fun (p, t, locs) -> + if p = normalized_path && t = tip then Some locs + else None) + in + locs + |> List.map (fun loc -> + {uri = file.uri; loc_opt = Some loc}))) |> List.concat |> List.concat in alternative_references @ externals) @@ -549,17 +548,17 @@ let all_references_for_loc_item ~state ~full:({file; package} as full) loc_item let other_modules_references = package.project_files |> File_set.elements |> Utils.filter_map (fun module_name -> - Cmt.full_from_module ~package ~module_name) + Cmt.full_from_module ~package ~module_name) |> List.map (fun full -> - match Hashtbl.find_opt full.extra.file_references module_name with - | None -> [] - | Some locs -> - locs |> Location_set.elements - |> List.map (fun loc -> - { - uri = Uri.from_path loc.Location.loc_start.pos_fname; - loc_opt = Some loc; - })) + match Hashtbl.find_opt full.extra.file_references module_name with + | None -> [] + | Some locs -> + locs |> Location_set.elements + |> List.map (fun loc -> + { + uri = Uri.from_path loc.Location.loc_start.pos_fname; + loc_opt = Some loc; + })) |> List.flatten in let target_module_references = diff --git a/analysis/src/scope.ml b/analysis/src/scope.ml index 115cdcca8ab..1804b445165 100644 --- a/analysis/src/scope.ml +++ b/analysis/src/scope.ml @@ -146,5 +146,5 @@ let iter_includes f x = let get_raw_opens x = x |> Utils.filter_map (function - | Open path -> Some path - | _ -> None) + | Open path -> Some path + | _ -> None) diff --git a/analysis/src/semantic_tokens.ml b/analysis/src/semantic_tokens.ml index 3e69d89a978..279212ee32d 100644 --- a/analysis/src/semantic_tokens.ml +++ b/analysis/src/semantic_tokens.ml @@ -84,7 +84,7 @@ module Token = struct let sorted_tokens = e.tokens |> List.sort (fun (l1, c1, _, _) (l2, c2, _, _) -> - if l1 = l2 then compare c1 c2 else compare l1 l2) + 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) diff --git a/analysis/src/shared_types.ml b/analysis/src/shared_types.ml index 533baf09a88..b2b9819d6e8 100644 --- a/analysis/src/shared_types.ml +++ b/analysis/src/shared_types.ml @@ -718,9 +718,9 @@ module Completable = struct context_path_to_string cp ^ "(" ^ (labels |> List.map (function - | Asttypes.Nolabel -> "Nolabel" - | Labelled {txt} -> "~" ^ txt - | Optional {txt} -> "?" ^ txt) + | Asttypes.Nolabel -> "Nolabel" + | Labelled {txt} -> "~" ^ txt + | Optional {txt} -> "?" ^ txt) |> String.concat ", ") ^ ")" | CPArray (Some ctx_path) -> @@ -1006,7 +1006,7 @@ let state_to_yojson (state : state) = let autocomplete_to_yojson autocomplete = autocomplete |> Misc.String_map.bindings |> List.map (fun (name, files) -> - (name, `List (List.map (fun file -> `String file) files))) + (name, `List (List.map (fun file -> `String file) files))) |> fun fields -> `Assoc fields in diff --git a/analysis/src/signature_help.ml b/analysis/src/signature_help.ml index 344b771febb..d84fe61030c 100644 --- a/analysis/src/signature_help.ml +++ b/analysis/src/signature_help.ml @@ -10,28 +10,28 @@ let docs_for_label type_expr ~file ~state ~package ~supports_markdown_links = let type_definitions = types |> List.map (fun {Hover.decl; name; env; loc; path} -> - 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 + 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 multiple_types_have_this_name = - type_names - |> List.filter (fun type_name -> type_name = name) - |> List.length > 1 - in - let type_name = - if multiple_types_have_this_name then - path |> Shared_types.path_ident_to_string - else name - in - Markdown.code_block - (Shared.decl_to_string ~print_name_as_is:true type_name decl) - ^ link_to_type_definition_str) + let multiple_types_have_this_name = + type_names + |> List.filter (fun type_name -> type_name = name) + |> List.length > 1 + in + let type_name = + if multiple_types_have_this_name then + path |> Shared_types.path_ident_to_string + else name + in + Markdown.code_block + (Shared.decl_to_string ~print_name_as_is:true type_name decl) + ^ link_to_type_definition_str) in type_definitions |> String.concat "\n" @@ -157,23 +157,23 @@ let find_active_parameter ~arg_at_cursor ~args = let index = ref 0 in args |> List.find_map (fun (label, _) -> - match label with - | Asttypes.Nolabel when !index = unlabelled_argument_index -> - Some !index - | _ -> - index := !index + 1; - None) + match label with + | Asttypes.Nolabel when !index = unlabelled_argument_index -> + Some !index + | _ -> + index := !index + 1; + None) | Some (Labelled name) -> let index = ref 0 in args |> List.find_map (fun (label, _) -> - match label with - | (Asttypes.Labelled {txt = label_name} | Optional {txt = label_name}) - when label_name = name -> - Some !index - | _ -> - index := !index + 1; - None) + match label with + | (Asttypes.Labelled {txt = label_name} | Optional {txt = label_name}) + when label_name = name -> + Some !index + | _ -> + index := !index + 1; + None) type constructor_info = { docstring: string list; @@ -233,9 +233,9 @@ let find_constructor_args ~full ~env ~state ~constructor_name loc = | Some (Tvariant {constructors}, _) -> constructors |> List.find_opt (fun (c : Constructor.t) -> - c.cname.txt = constructor_name) + c.cname.txt = constructor_name) |> Option.map (fun (c : Constructor.t) -> - {docstring = c.docstring; name = c.cname.txt; args = c.args}) + {docstring = c.docstring; name = c.cname.txt; args = c.args}) | _ -> None) | _ -> None @@ -302,44 +302,43 @@ let signature_help ~debug ~source ~kind_file ~pos let argAtCursor_ = extracted_args |> List.find_map (fun arg -> - match arg.label with - | None -> - 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 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 + match arg.label with + | None -> + 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 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 pos_before_cursor >= (arg.exp.pexp_loc |> Loc.start) - then - last_unlabelled_arg_before_cursor := - current_unlabelled_arg_count; - None) - | Some {name; pos_start; pos_end} -> ( - (* Check for the label identifier itself having the cursor *) - match - pos - |> Cursor_position.classify_positions ~pos_start ~pos_end - with - | HasCursor -> Some (Labelled name) - | NoCursor | EmptyLoc -> ( - (* If we're not in the label, check the exp. Either the exp + if pos_before_cursor >= (arg.exp.pexp_loc |> Loc.start) then + last_unlabelled_arg_before_cursor := + current_unlabelled_arg_count; + None) + | Some {name; pos_start; pos_end} -> ( + (* Check for the label identifier itself having the cursor *) + match + pos + |> Cursor_position.classify_positions ~pos_start ~pos_end + with + | HasCursor -> Some (Labelled name) + | NoCursor | EmptyLoc -> ( + (* If we're not in the label, check the exp. Either the exp exists and has the cursor. Or the exp is a parser recovery node, in which case we assume that the parser recovery indicates that the cursor was here. *) - match - ( arg.exp.pexp_desc, - arg.exp.pexp_loc - |> Cursor_position.classify_loc - ~pos:pos_before_cursor ) - with - | Pexp_extension ({txt = "rescript.exprhole"}, _), _ - | _, HasCursor -> - Some (Labelled name) - | _ -> None))) + match + ( arg.exp.pexp_desc, + arg.exp.pexp_loc + |> Cursor_position.classify_loc ~pos:pos_before_cursor + ) + with + | Pexp_extension ({txt = "rescript.exprhole"}, _), _ + | _, HasCursor -> + Some (Labelled name) + | _ -> None))) in match argAtCursor_ with @@ -464,7 +463,7 @@ let signature_help ~debug ~source ~kind_file ~pos Printf.printf "extracted params: \n%s\n" (parameters |> List.map (fun (_, start, end_) -> - String.sub fn_type_str start (end_ - start)) + String.sub fn_type_str start (end_ - start)) |> list); (* Figure out the active parameter *) @@ -474,41 +473,40 @@ let signature_help ~debug ~source ~kind_file ~pos let parameters_information = parameters |> 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 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 -> - true - | Labelled {txt = l1}, Labelled {txt = l2} - when l1 = l2 -> - true - | Nolabel, Nolabel - when param_arg_count = arg_count -> - true - | _ -> false) - with - | None -> - Lsp.Types.MarkupContent.create - ~kind:Lsp.Types.MarkupKind.Markdown ~value:"" - | Some (_, label_typ_expr) -> - Lsp.Types.MarkupContent.create - ~kind:Lsp.Types.MarkupKind.Markdown - ~value: - (docs_for_label ~supports_markdown_links ~file ~state - ~package label_typ_expr) - in - Lsp.Types.ParameterInformation.create - ~label:(`Offset (start, end_)) - ~documentation:(`MarkupContent documentation) ()) + 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 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 -> + true + | Labelled {txt = l1}, Labelled {txt = l2} when l1 = l2 + -> + true + | Nolabel, Nolabel when param_arg_count = arg_count -> + true + | _ -> false) + with + | None -> + Lsp.Types.MarkupContent.create + ~kind:Lsp.Types.MarkupKind.Markdown ~value:"" + | Some (_, label_typ_expr) -> + Lsp.Types.MarkupContent.create + ~kind:Lsp.Types.MarkupKind.Markdown + ~value: + (docs_for_label ~supports_markdown_links ~file ~state + ~package label_typ_expr) + in + Lsp.Types.ParameterInformation.create + ~label:(`Offset (start, end_)) + ~documentation:(`MarkupContent documentation) ()) in let signatures = Lsp.Types.SignatureInformation.create ~label:fn_type_str @@ -569,20 +567,20 @@ let signature_help ~debug ~source ~kind_file ~pos (`InlineRecord (fields |> List.map (fun (field : field) -> - let start_offset = !offset in - let arg_text = - Printf.sprintf "%s%s: %s" field.fname.txt - (if field.optional then "?" else "") - (Shared.type_to_string - (if field.optional then - Utils.unwrap_if_option field.typ - else field.typ)) - in - let end_offset = - start_offset + String.length arg_text - in - offset := end_offset + String.length ", "; - (arg_text, field, (start_offset, end_offset))))) + let start_offset = !offset in + let arg_text = + Printf.sprintf "%s%s: %s" field.fname.txt + (if field.optional then "?" else "") + (Shared.type_to_string + (if field.optional then + Utils.unwrap_if_option field.typ + else field.typ)) + in + let end_offset = + start_offset + String.length arg_text + in + offset := end_offset + String.length ", "; + (arg_text, field, (start_offset, end_offset))))) | Args [(typ, _)] -> Some (`SingleArg @@ -595,17 +593,16 @@ let signature_help ~debug ~source ~kind_file ~pos (`TupleArg (args |> List.map (fun (typ, _) -> - 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 := end_offset + String.length ", "; - ( arg_text, - docs_for_label ~file:full.file - ~package:full.package ~supports_markdown_links - ~state typ, - (start_offset, end_offset) )))) + 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 := end_offset + String.length ", "; + ( arg_text, + docs_for_label ~file:full.file ~package:full.package + ~supports_markdown_links ~state typ, + (start_offset, end_offset) )))) in let label = constructor.name ^ "(" @@ -631,10 +628,10 @@ let signature_help ~debug ~source ~kind_file ~pos let tuple_item_with_cursor = items |> List.find_map (fun (item : Parsetree.expression) -> - let current_index = !idx in - idx := current_index + 1; - if loc_has_cursor item.pexp_loc then Some current_index - else None) + let current_index = !idx in + idx := current_index + 1; + if loc_has_cursor item.pexp_loc then Some current_index + else None) in match tuple_item_with_cursor with | None -> -1 @@ -660,11 +657,11 @@ let signature_help ~debug ~source ~kind_file ~pos let field_index = ref (-1) in fields |> List.iter (fun (_, field, _) -> - idx := !idx + 1; - let current_index = !idx in - if field_name = field.fname.txt then - field_index := current_index - else ()); + idx := !idx + 1; + let current_index = !idx in + if field_name = field.fname.txt then + field_index := current_index + else ()); !field_index | _ -> -1) | `ConstructorExpr (_, expr) when loc_has_cursor expr.pexp_loc -> @@ -674,10 +671,10 @@ let signature_help ~debug ~source ~kind_file ~pos let tuple_item_with_cursor = items |> List.find_map (fun (item : Parsetree.pattern) -> - let current_index = !idx in - idx := current_index + 1; - if loc_has_cursor item.ppat_loc then Some current_index - else None) + let current_index = !idx in + idx := current_index + 1; + if loc_has_cursor item.ppat_loc then Some current_index + else None) in match tuple_item_with_cursor with | None -> -1 @@ -704,11 +701,11 @@ let signature_help ~debug ~source ~kind_file ~pos let field_index = ref (-1) in fields |> List.iter (fun (_, field, _) -> - idx := !idx + 1; - let current_index = !idx in - if field_name = field.fname.txt then - field_index := current_index - else ()); + idx := !idx + 1; + let current_index = !idx in + if field_name = field.fname.txt then + field_index := current_index + else ()); !field_index | _ -> -1) | `ConstructorPat (_, pat) when loc_has_cursor pat.ppat_loc -> 0 @@ -743,21 +740,6 @@ let signature_help ~debug ~source ~kind_file ~pos () :: (fields |> List.map (fun (_, (field : field), (start, end_)) -> - Lsp.Types.ParameterInformation.create - ~label: - (`Offset (base_offset + start, base_offset + end_)) - ~documentation: - (`MarkupContent - (Lsp.Types.MarkupContent.create - ~kind:Lsp.Types.MarkupKind.Markdown - ~value: - (field.docstring |> String.concat "\n"))) - ())) - | Some (`TupleArg items) -> - (* Account for leading '(' *) - let base_offset = constructor_name_length + 1 in - items - |> List.map (fun (_, docstring, (start, end_)) -> Lsp.Types.ParameterInformation.create ~label: (`Offset (base_offset + start, base_offset + end_)) @@ -765,8 +747,21 @@ let signature_help ~debug ~source ~kind_file ~pos (`MarkupContent (Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown - ~value:docstring)) - ()) + ~value:(field.docstring |> String.concat "\n"))) + ())) + | Some (`TupleArg items) -> + (* Account for leading '(' *) + let base_offset = constructor_name_length + 1 in + items + |> List.map (fun (_, docstring, (start, end_)) -> + Lsp.Types.ParameterInformation.create + ~label:(`Offset (base_offset + start, base_offset + end_)) + ~documentation: + (`MarkupContent + (Lsp.Types.MarkupContent.create + ~kind:Lsp.Types.MarkupKind.Markdown + ~value:docstring)) + ()) in let signatures = Lsp.Types.SignatureInformation.create ~label ~parameters:params diff --git a/analysis/src/structure_utils.ml b/analysis/src/structure_utils.ml index 895dab2d507..aa97c5f9512 100644 --- a/analysis/src/structure_utils.ml +++ b/analysis/src/structure_utils.ml @@ -4,7 +4,7 @@ let unique_items (structure : Module.structure) : Module.item list = let names_used = Hashtbl.create 10 in structure.items |> List.filter (fun (it : Module.item) -> - if Hashtbl.mem names_used it.name then false - else ( - Hashtbl.add names_used it.name (); - true)) + if Hashtbl.mem names_used it.name then false + else ( + Hashtbl.add names_used it.name (); + true)) diff --git a/analysis/src/type_utils.ml b/analysis/src/type_utils.ml index 6e12fb61746..a9133f4293b 100644 --- a/analysis/src/type_utils.ml +++ b/analysis/src/type_utils.ml @@ -68,8 +68,8 @@ let path_from_type_expr (t : Types.type_expr) = let print_record_from_fields ?name (fields : field list) = (match name with - | None -> "" - | Some name -> "type " ^ name ^ " = ") + | None -> "" + | Some name -> "type " ^ name ^ " = ") ^ "{" ^ (fields |> List.map (fun f -> f.fname.txt ^ ": " ^ Shared.type_to_string f.typ) @@ -254,10 +254,10 @@ let rec extract_record_type ~state ~env ~package (t : Types.type_expr) = let fields = fields |> List.map (fun field -> - let field_typ = - field.typ |> instantiate_type ~type_params ~type_args - in - {field with typ = field_typ}) + let field_typ = + field.typ |> instantiate_type ~type_params ~type_args + in + {field with typ = field_typ}) in Some (env, fields, typ) | Some (env, {item = {decl = {type_manifest = Some t1; type_params}}}) -> @@ -465,19 +465,19 @@ let rec extract_type ?(print_opening_debug = true) let constructors = row_fields |> List.map (fun (label, field) -> - { - name = label; - display_name = - Utils.print_maybe_exotic_ident ~allow_uident:true label; - args = - (* Multiple arguments are represented as a Ttuple, while a single argument is just the type expression itself. *) - (match field with - | Types.Rpresent (Some type_expr) -> ( - match type_expr.desc with - | Ttuple args -> args - | _ -> [type_expr]) - | _ -> []); - }) + { + name = label; + display_name = + Utils.print_maybe_exotic_ident ~allow_uident:true label; + args = + (* Multiple arguments are represented as a Ttuple, while a single argument is just the type expression itself. *) + (match field with + | Types.Rpresent (Some type_expr) -> ( + match type_expr.desc with + | Ttuple args -> args + | _ -> [type_expr]) + | _ -> []); + }) in Some (Tpolyvariant {env; constructors; type_expr = t}, type_arg_context) | Tvar (Some var_name) -> ( @@ -641,8 +641,7 @@ let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx typ |> extract_type ~state ~env ~package:full.package |> Utils.Option.flat_map (fun (typ, type_arg_context) -> - typ |> resolve_nested ?type_arg_context ~env ~state ~full ~nested) - ) + typ |> resolve_nested ?type_arg_context ~env ~state ~full ~nested)) | ( NFollowRecordField {field_name}, (TinlineRecord {env; fields} | Trecord {env; fields}) ) -> ( if Debug.verbose () then @@ -667,18 +666,18 @@ let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx typ |> extract_type ~env ~state ~package:full.package |> Utils.Option.flat_map (fun (typ, type_arg_context) -> - typ - |> resolve_nested ?type_arg_context ~ctx:(Rfield field_name) ~env - ~state ~full ~nested)) + typ + |> resolve_nested ?type_arg_context ~ctx:(Rfield field_name) ~env + ~state ~full ~nested)) | NRecordBody {seen_fields}, Trecord {env; definition = `TypeExpr type_expr} -> type_expr |> extract_type ~env ~state ~package:full.package |> Option.map (fun (typ, type_arg_context) -> - ( typ, - env, - Some (Completable.RecordField {seen_fields}), - type_arg_context )) + ( typ, + env, + Some (Completable.RecordField {seen_fields}), + type_arg_context )) | ( NRecordBody {seen_fields}, (Trecord {env; definition = `NameOnly _} as extracted_type) ) -> Some @@ -704,14 +703,14 @@ let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx typ |> extract_type ~env ~state ~package:full.package |> Utils.Option.flat_map (fun (t, type_arg_context) -> - t |> resolve_nested ?type_arg_context ~env ~state ~full ~nested) + t |> resolve_nested ?type_arg_context ~env ~state ~full ~nested) | NVariantPayload {constructor_name = "Ok"; item_num = 0}, Tresult {ok_type} -> if Debug.verbose () then print_endline "[nested]--> moving into result Ok"; ok_type |> extract_type ~env ~state ~package:full.package |> Utils.Option.flat_map (fun (t, type_arg_context) -> - t |> resolve_nested ?type_arg_context ~env ~state ~full ~nested) + t |> resolve_nested ?type_arg_context ~env ~state ~full ~nested) | ( NVariantPayload {constructor_name = "Error"; item_num = 0}, Tresult {error_type} ) -> if Debug.verbose () then @@ -719,7 +718,7 @@ let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx error_type |> extract_type ~env ~state ~package:full.package |> Utils.Option.flat_map (fun (t, type_arg_context) -> - t |> resolve_nested ?type_arg_context ~env ~state ~full ~nested) + t |> resolve_nested ?type_arg_context ~env ~state ~full ~nested) | NVariantPayload {constructor_name; item_num}, Tvariant {env; constructors} -> ( if Debug.verbose () then @@ -730,7 +729,7 @@ let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx match constructors |> List.find_opt (fun (c : Constructor.t) -> - c.cname.txt = constructor_name) + c.cname.txt = constructor_name) with | Some {args = Args args} -> ( if Debug.verbose () then @@ -748,13 +747,13 @@ let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx typ |> extract_type ~env ~state ~package:full.package |> Utils.Option.flat_map (fun (typ, type_arg_context) -> - if Debug.verbose () then - Printf.printf - "[nested]--> extracted %s, continuing descent of %i items\n" - (extracted_type_to_string typ) - (List.length nested); - typ - |> resolve_nested ?type_arg_context ~env ~state ~full ~nested)) + if Debug.verbose () then + Printf.printf + "[nested]--> extracted %s, continuing descent of %i items\n" + (extracted_type_to_string typ) + (List.length nested); + typ |> resolve_nested ?type_arg_context ~env ~state ~full ~nested) + ) | Some {args = InlineRecord fields} when item_num = 0 -> if Debug.verbose () then print_endline "[nested]--> found constructor (inline record)"; @@ -766,7 +765,7 @@ let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx match constructors |> List.find_opt (fun (c : poly_variant_constructor) -> - c.name = constructor_name) + c.name = constructor_name) with | None -> None | Some constructor -> ( @@ -776,16 +775,15 @@ let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx typ |> extract_type ~env ~state ~package:full.package |> Utils.Option.flat_map (fun (typ, type_arg_context) -> - typ - |> resolve_nested ?type_arg_context ~env ~state ~full ~nested)) - ) + typ |> resolve_nested ?type_arg_context ~env ~state ~full ~nested) + )) | NArray, Tarray (env, ExtractedType typ) -> typ |> resolve_nested ?type_arg_context ~env ~state ~full ~nested | NArray, Tarray (env, TypeExpr typ) -> typ |> extract_type ~env ~state ~package:full.package |> Utils.Option.flat_map (fun (typ, type_arg_context) -> - typ |> resolve_nested ?type_arg_context ~env ~state ~full ~nested) + typ |> resolve_nested ?type_arg_context ~env ~state ~full ~nested) | _ -> None) let find_type_of_record_field fields ~field_name = @@ -816,7 +814,7 @@ let find_type_of_polyvariant_arg constructors ~constructor_name ~payload_num = match constructors |> List.find_opt (fun (c : poly_variant_constructor) -> - c.name = constructor_name) + c.name = constructor_name) with | Some {args} -> ( match List.nth_opt args payload_num with @@ -892,8 +890,8 @@ let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~state ~nested |> extract_type ~env ~state ~package:full.package |> get_extracted_type |> Utils.Option.flat_map (fun typ -> - ExtractedType typ - |> resolve_nested_pattern_path ~env ~state ~full ~nested)) + ExtractedType typ + |> resolve_nested_pattern_path ~env ~state ~full ~nested)) | NTupleItem {item_num}, Tuple (env, tuple_items, _) -> ( match List.nth_opt tuple_items item_num with | None -> None @@ -902,8 +900,8 @@ let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~state ~nested |> extract_type ~env ~state ~package:full.package |> get_extracted_type |> Utils.Option.flat_map (fun typ -> - ExtractedType typ - |> resolve_nested_pattern_path ~env ~state ~full ~nested)) + ExtractedType typ + |> resolve_nested_pattern_path ~env ~state ~full ~nested)) | ( NVariantPayload {constructor_name; item_num}, Tvariant {env; constructors} ) -> ( match @@ -1027,22 +1025,22 @@ module Codegen = struct Some (v.constructors |> List.map (fun (c : Shared_types.Constructor.t) -> - mk_construct_pat - ?payload: - (match c.args with - | Args [] -> None - | _ -> Some (any ())) - c.cname.txt)) + mk_construct_pat + ?payload: + (match c.args with + | Args [] -> None + | _ -> Some (any ())) + c.cname.txt)) | Tpolyvariant v -> Some (v.constructors |> List.map (fun (c : Shared_types.poly_variant_constructor) -> - mk_tag_pat - ?payload: - (match c.args with - | [] -> None - | _ -> Some (any ())) - c.display_name)) + mk_tag_pat + ?payload: + (match c.args with + | [] -> None + | _ -> Some (any ())) + c.display_name)) | Toption (_, inner_type) -> let extracted_type = match inner_type with @@ -1068,7 +1066,7 @@ module Codegen = struct ] @ (expanded_branches |> List.map (fun (pat : Parsetree.pattern) -> - mk_construct_pat ~payload:pat "Some"))) + mk_construct_pat ~payload:pat "Some"))) | Tresult {ok_type; error_type} -> let extracted_ok_type = ok_type @@ -1105,10 +1103,10 @@ module Codegen = struct Some ((expanded_ok_branches |> List.map (fun (pat : Parsetree.pattern) -> - mk_construct_pat ~payload:pat "Ok")) + mk_construct_pat ~payload:pat "Ok")) @ (expanded_error_branches |> List.map (fun (pat : Parsetree.pattern) -> - mk_construct_pat ~payload:pat "Error"))) + mk_construct_pat ~payload:pat "Error"))) | Tbool _ -> Some [mk_construct_pat "true"; mk_construct_pat "false"] | _ -> None @@ -1123,7 +1121,7 @@ module Codegen = struct Some (patterns |> List.map (fun (pat : Parsetree.pattern) -> - Ast_helper.Exp.case pat (mk_fail_with_exp ()))) + Ast_helper.Exp.case pat (mk_fail_with_exp ()))) end let get_module_path_relative_to_env ~debug ~(env : Query_env.t) ~env_from_item @@ -1185,8 +1183,8 @@ let get_extra_modules_to_complete_from_for_type ~env ~state ~full let add_to_module_paths attributes = Process_attributes.find_editor_complete_from_attribute attributes |> List.iter (fun e -> - found_module_paths := - String_set.add (e |> String.concat ".") !found_module_paths) + 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 @@ -1304,26 +1302,26 @@ let filter_pipeable_functions ~env ~state ~full ?synthetic ?target_type_id | Some target_type_id -> completions |> List.filter_map (fun (completion : Completion.t) -> - let this_completion_item_type_id = - match completion.kind with - | Value t -> ( - match - get_first_fn_unlabelled_arg_type ~full ~env:completion.env - ~state t - with - | None -> None - | Some (t, env_from_labelled_arg) -> - find_root_type_id ~full ~env:env_from_labelled_arg ~state t) - | _ -> None - in - match this_completion_item_type_id with - | Some main_type_id when main_type_id = target_type_id -> ( - match pos_of_dot with - | None -> Some completion - | Some pos_of_dot -> - transform_completion_to_pipe_completion ?synthetic ~env - ~pos_of_dot completion) - | _ -> None) + let this_completion_item_type_id = + match completion.kind with + | Value t -> ( + match + get_first_fn_unlabelled_arg_type ~full ~env:completion.env ~state + t + with + | None -> None + | Some (t, env_from_labelled_arg) -> + find_root_type_id ~full ~env:env_from_labelled_arg ~state t) + | _ -> None + in + match this_completion_item_type_id with + | Some main_type_id when main_type_id = target_type_id -> ( + match pos_of_dot with + | None -> Some completion + | Some pos_of_dot -> + transform_completion_to_pipe_completion ?synthetic ~env ~pos_of_dot + completion) + | _ -> None) let remove_current_module_if_needed ~env_completion_is_made_from completion_path = diff --git a/analysis/src/utils.ml b/analysis/src/utils.ml index afaa4ae04fa..31444f880e4 100644 --- a/analysis/src/utils.ml +++ b/analysis/src/utils.ml @@ -157,8 +157,8 @@ let rec unwrap_if_option (t : Types.type_expr) = let is_jsx_component (vb : Parsetree.value_binding) = vb.pvb_attributes |> List.exists (function - | {Location.txt = "react.component" | "jsx.component"}, _payload -> true - | _ -> false) + | {Location.txt = "react.component" | "jsx.component"}, _payload -> true + | _ -> false) let check_name name ~prefix ~exact = if exact then name = prefix else starts_with name prefix diff --git a/analysis/src/xform.ml b/analysis/src/xform.ml index 3a7e4d0d483..720ef7254e0 100644 --- a/analysis/src/xform.ml +++ b/analysis/src/xform.ml @@ -313,8 +313,8 @@ module Add_type_annotation = struct in params |> List.iter (fun ({p_lbl; p_pat} : Parsetree.fun_param) -> - let is_unlabeled_only_arg = single_param && p_lbl = Nolabel in - process_pattern ~is_unlabeled_only_arg p_pat) + let is_unlabeled_only_arg = single_param && p_lbl = Nolabel in + process_pattern ~is_unlabeled_only_arg p_pat) | _ -> () in let structure_item (iterator : Ast_iterator.iterator) @@ -375,9 +375,9 @@ module Expand_catch_all_for_variants = struct let catch_all_case = cases |> List.find_opt (fun (c : Parsetree.case) -> - match c with - | {pc_lhs = {ppat_desc = Ppat_any}} -> true - | _ -> false) + match c with + | {pc_lhs = {ppat_desc = Ppat_any}} -> true + | _ -> false) in match catch_all_case with | None -> () @@ -417,8 +417,8 @@ module Expand_catch_all_for_variants = struct let get_current_constructor_names ?mode cases = cases |> List.map (fun (c : Parsetree.case) -> - if Option.is_some c.pc_guard then [] - else find_all_constructor_names ?mode c.pc_lhs) + if Option.is_some c.pc_guard then [] + else find_all_constructor_names ?mode c.pc_lhs) |> List.flatten in let current_constructor_names = get_current_constructor_names cases in @@ -431,17 +431,17 @@ module Expand_catch_all_for_variants = struct let missing_constructors = constructors |> List.filter (fun (c : Shared_types.Constructor.t) -> - current_constructor_names |> List.mem c.cname.txt = false) + current_constructor_names |> List.mem c.cname.txt = false) in if List.length missing_constructors > 0 then let new_text = missing_constructors |> List.map (fun (c : Shared_types.Constructor.t) -> - c.cname.txt - ^ - match c.args with - | Args [] -> "" - | Args _ | InlineRecord _ -> "(_)") + c.cname.txt + ^ + match c.args with + | Args [] -> "" + | Args _ | InlineRecord _ -> "(_)") |> String.concat " | " in let range = Loc.range_of_loc catch_all_case.pc_lhs.ppat_loc in @@ -455,17 +455,17 @@ module Expand_catch_all_for_variants = struct let missing_constructors = constructors |> List.filter (fun (c : Shared_types.poly_variant_constructor) -> - current_constructor_names |> List.mem c.name = false) + current_constructor_names |> List.mem c.name = false) in if List.length missing_constructors > 0 then let new_text = missing_constructors |> List.map (fun (c : Shared_types.poly_variant_constructor) -> - Res_printer.polyvar_ident_to_string c.name - ^ - match c.args with - | [] -> "" - | _ -> "(_)") + Res_printer.polyvar_ident_to_string c.name + ^ + match c.args with + | [] -> "" + | _ -> "(_)") |> String.concat " | " in let range = Loc.range_of_loc catch_all_case.pc_lhs.ppat_loc in @@ -497,24 +497,23 @@ module Expand_catch_all_for_variants = struct 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) + match c.pc_lhs.ppat_desc with + | Ppat_construct ({txt = Lident "None"}, _) -> true + | _ -> false) in let missing_constructors = match variant with | Tvariant {constructors} -> constructors |> List.filter_map (fun (c : Shared_types.Constructor.t) -> - if - current_constructor_names |> List.mem c.cname.txt = false - then - Some - ( c.cname.txt, - match c.args with - | Args [] -> false - | _ -> true ) - else None) + if current_constructor_names |> List.mem c.cname.txt = false + then + Some + ( c.cname.txt, + match c.args with + | Args [] -> false + | _ -> true ) + else None) | Tpolyvariant {constructors} -> constructors |> List.filter_map @@ -534,7 +533,7 @@ module Expand_catch_all_for_variants = struct "Some(" ^ (missing_constructors |> List.map (fun (name, has_args) -> - name ^ if has_args then "(_)" else "") + name ^ if has_args then "(_)" else "") |> String.concat " | ") ^ ")" in diff --git a/compiler/core/ir_diagnostics.ml b/compiler/core/ir_diagnostics.ml index a6184b6bfda..d6fbe8a766e 100644 --- a/compiler/core/ir_diagnostics.ml +++ b/compiler/core/ir_diagnostics.ml @@ -8,8 +8,8 @@ let is_artifact filename = let remove_stale_artifacts directory = Sys.readdir directory |> Array.iter (fun filename -> - if is_artifact filename then - Misc.remove_file (Filename.concat directory filename)) + if is_artifact filename then + Misc.remove_file (Filename.concat directory filename)) let create ~output_prefix = let directory = output_prefix ^ ".debug-ir" in diff --git a/compiler/core/js_analyzer.ml b/compiler/core/js_analyzer.ml index b7693f34e12..83622bc4222 100644 --- a/compiler/core/js_analyzer.ml +++ b/compiler/core/js_analyzer.ml @@ -115,8 +115,8 @@ let rec no_side_effect_expression_desc (x : J.expression_desc) = | Optional_block (x, _) -> no_side_effect x | Object (dup, kvs) -> (match dup with - | Some e -> no_side_effect e - | None -> true) + | Some e -> no_side_effect e + | None -> true) && Ext_list.for_all_snd kvs no_side_effect | String_append (a, b) | Seq (a, b) -> no_side_effect a && no_side_effect b | Length e | Caml_block_tag (e, _) | Typeof e -> no_side_effect e diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 1f181ba3e82..0dc721a9f4f 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -523,13 +523,11 @@ and expression_desc cxt ~(level : int) f x : cxt = P.string f "(({"; fields |> List.iteri (fun i ({record_rest_label; _} : J.record_rest_field) -> - if i > 0 then comma_sp f; - let key = - Js_dump_property.property_key (Lit record_rest_label) - in - P.string f key; - P.string f L.colon_space; - P.string f ("__unused" ^ string_of_int i)); + if i > 0 then comma_sp f; + let key = Js_dump_property.property_key (Lit record_rest_label) in + P.string f key; + P.string f L.colon_space; + P.string f ("__unused" ^ string_of_int i)); (match fields with | [] -> () | _ -> comma_sp f); @@ -891,7 +889,7 @@ and expression_desc cxt ~(level : int) f x : cxt = {expression_desc = Bin (EqEqEq, e1, {expression_desc = Undefined _})}, {expression_desc = Bin (EqEqEq, e2, {expression_desc = Null})} ) when e1 = e2 -> - expression_desc cxt ~level:(level : int) f (Is_null_or_undefined e1) + expression_desc cxt ~(level : int) f (Is_null_or_undefined e1) | Bin (op, e1, e2) -> let out, lft, rght = Js_op_util.op_prec op in let need_paren = @@ -1214,8 +1212,8 @@ and print_jsx cxt ?(spread_props : J.expression option) in let printable_props = (match key with - | None -> [] - | Some k -> [print_key k]) + | None -> [] + | Some k -> [print_key k]) @ (match spread_props with | None -> [] | Some spread -> [print_spread_props spread]) diff --git a/compiler/core/js_dump_import_export.ml b/compiler/core/js_dump_import_export.ml index d96fbfe1c17..1038b8be63c 100644 --- a/compiler/core/js_dump_import_export.ml +++ b/compiler/core/js_dump_import_export.ml @@ -140,12 +140,12 @@ let dump_import_attributes f P.brace_group f 0 (fun _ -> import_attributes |> List.iteri (fun idx (key, value) -> - Js_dump_string.pp_string f key; - P.string f L.colon_space; - Js_dump_string.pp_string f value; - if idx < total - 1 then ( - P.string f L.comma; - P.space f))) + Js_dump_string.pp_string f key; + P.string f L.colon_space; + Js_dump_string.pp_string f value; + if idx < total - 1 then ( + P.string f L.comma; + P.space f))) (** ES6 module style imports *) let imports cxt f diff --git a/compiler/core/js_dump_program.ml b/compiler/core/js_dump_program.ml index 33675ed5b9b..c861aeb5fac 100644 --- a/compiler/core/js_dump_program.ml +++ b/compiler/core/js_dump_program.ml @@ -112,8 +112,8 @@ let pp_deps_program ~(output_prefix : string) (f : Ext_pp.t) = !Js_config.directives |> List.iter (fun prim -> - P.string f prim; - P.newline f); + P.string f prim; + P.newline f); if not !Js_config.no_version_header then ( P.string f Bs_version.header; P.newline f); diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index 6606e327e61..c11a6c96596 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -1745,13 +1745,13 @@ let bigint_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = let trim = ref false in s |> String.iteri (fun i c -> - match (c, i, !trim) with - | '0', 0, _ -> trim := true - | '0', _, true -> () - | '_', _, _ -> () - | _ -> - trim := false; - Buffer.add_char buf c); + match (c, i, !trim) with + | '0', 0, _ -> trim := true + | '0', _, true -> () + | '_', _, _ -> () + | _ -> + trim := false; + Buffer.add_char buf c); buf |> Buffer.to_bytes |> Bytes.to_string in match (cmp, e0.expression_desc, e1.expression_desc) with diff --git a/compiler/core/js_pass_flatten_and_mark_dead.ml b/compiler/core/js_pass_flatten_and_mark_dead.ml index b108c765513..88d900893d4 100644 --- a/compiler/core/js_pass_flatten_and_mark_dead.ml +++ b/compiler/core/js_pass_flatten_and_mark_dead.ml @@ -93,10 +93,10 @@ let mark_dead_code (js : J.program) : J.program = | Some {expression_desc = Record_rest (fields, _)} -> fields |> List.iter (fun (field : J.record_rest_field) -> - match field.record_rest_ident with - | None -> () - | Some ident -> - add_binding_info ident_use_stats ident_info ident) + match field.record_rest_ident with + | None -> () + | Some ident -> + add_binding_info ident_use_stats ident_info ident) | _ -> ())); } in diff --git a/compiler/core/js_pass_scope.ml b/compiler/core/js_pass_scope.ml index f2bdc4e3506..bbe453f2e27 100644 --- a/compiler/core/js_pass_scope.ml +++ b/compiler/core/js_pass_scope.ml @@ -162,8 +162,8 @@ let record_scope_pass = (* mark which param is used *) params |> List.iteri (fun i v -> - if not (Set_ident.mem used_idents' v) then - Js_fun_env.mark_unused env i); + if not (Set_ident.mem used_idents' v) then + Js_fun_env.mark_unused env i); let closured_idents' = (* pass param_set down *) Set_ident.(diff used_idents' (union defined_idents' param_set)) diff --git a/compiler/core/js_source_map.ml b/compiler/core/js_source_map.ml index 4e2d1f3ac72..487fe2dadef 100644 --- a/compiler/core/js_source_map.ml +++ b/compiler/core/js_source_map.ml @@ -232,22 +232,22 @@ let encode_mappings mappings = let first_segment = ref true in mappings |> List.sort compare_mapping |> List.iter (fun mapping -> - while !current_line < mapping.generated_line do - Buffer.add_char buf ';'; - incr current_line; - previous_generated_column := 0; - first_segment := true - done; - if not !first_segment then Buffer.add_char buf ','; - first_segment := false; - add_vlq buf (mapping.generated_column - !previous_generated_column); - add_vlq buf (mapping.source_index - !previous_source); - add_vlq buf (mapping.original_line - !previous_original_line); - add_vlq buf (mapping.original_column - !previous_original_column); - previous_generated_column := mapping.generated_column; - previous_source := mapping.source_index; - previous_original_line := mapping.original_line; - previous_original_column := mapping.original_column); + while !current_line < mapping.generated_line do + Buffer.add_char buf ';'; + incr current_line; + previous_generated_column := 0; + first_segment := true + done; + if not !first_segment then Buffer.add_char buf ','; + first_segment := false; + add_vlq buf (mapping.generated_column - !previous_generated_column); + add_vlq buf (mapping.source_index - !previous_source); + add_vlq buf (mapping.original_line - !previous_original_line); + add_vlq buf (mapping.original_column - !previous_original_column); + previous_generated_column := mapping.generated_column; + previous_source := mapping.source_index; + previous_original_line := mapping.original_line; + previous_original_column := mapping.original_column); Buffer.contents buf let json builder = diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 164a47bb8f5..aa8d5116d63 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -479,7 +479,7 @@ let compile output_prefix = Ident.same pid id || not @@ Ext_list.exists all_bindings (fun (other, _) -> - Ident.same other pid) + Ident.same other pid) | Lconst _ -> true | _ -> false) -> (* capture cases like for {!Queue} @@ -492,24 +492,24 @@ let compile output_prefix = ( Js_output.make (S.define_variable ~kind:Variable id (E.dummy_obj tag_info) :: Ext_list.mapi ls (fun i x -> - S.exp - (Js_of_lam_block.set_field - (match tag_info with - | Blk_record {fields = xs} -> Fld_record_set (fst xs.(i)) - | Blk_record_inlined xs -> - Fld_record_inline_set (fst xs.fields.(i)) - | Blk_constructor p -> ( - let is_cons = p.name = Literals.cons in - match (is_cons, i) with - | true, 0 -> Fld_record_inline_set Literals.hd - | true, 1 -> Fld_record_inline_set Literals.tl - | _, _ -> Fld_record_inline_set ("_" ^ string_of_int i)) - | _ -> assert false) - (E.var id) (Int32.of_int i) - (match x with - | Lvar lid -> E.var lid - | Lconst x -> Lam_compile_const.translate x - | _ -> assert false)))), + S.exp + (Js_of_lam_block.set_field + (match tag_info with + | Blk_record {fields = xs} -> Fld_record_set (fst xs.(i)) + | Blk_record_inlined xs -> + Fld_record_inline_set (fst xs.fields.(i)) + | Blk_constructor p -> ( + let is_cons = p.name = Literals.cons in + match (is_cons, i) with + | true, 0 -> Fld_record_inline_set Literals.hd + | true, 1 -> Fld_record_inline_set Literals.tl + | _, _ -> Fld_record_inline_set ("_" ^ string_of_int i)) + | _ -> assert false) + (E.var id) (Int32.of_int i) + (match x with + | Lvar lid -> E.var lid + | Lconst x -> Lam_compile_const.translate x + | _ -> assert false)))), [] ) | Lprim {primitive = Pmakeblock (tag_info, _)} -> ( (* Lconst should not appear here if we do [scc] @@ -1082,10 +1082,9 @@ let compile output_prefix = (* Declaration First, body and handler have the same value *) let declares = S.define_variable ~kind:Variable exit_id E.zero_int_literal - :: (* we should always make it zero here, since [zero] is reserved in our mapping*) - Ext_list.flat_map code_table (fun {bindings} -> - Ext_list.map bindings (fun x -> - S.declare_variable ~kind:Variable x)) + (* we should always make it zero here, since [zero] is reserved in our mapping*) + :: Ext_list.flat_map code_table (fun {bindings} -> + Ext_list.map bindings (fun x -> S.declare_variable ~kind:Variable x)) in match lambda_cxt.continuation with (* could be optimized when cases are less than 3 *) diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 8c2945bdfcc..3b986dd4aee 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -605,10 +605,10 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) E.obj (items |> List.filter_map (fun (exp : J.expression) -> - match exp.expression_desc with - | Caml_block ([{expression_desc = Str {txt}}; expr], _, _) -> - Some (Js_op.Lit txt, expr) - | _ -> None)) + match exp.expression_desc with + | Caml_block ([{expression_desc = Str {txt}}; expr], _, _) -> + Some (Js_op.Lit txt, expr) + | _ -> None)) | _ -> assert false) | Pdict_has -> ( match args with diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index 1dc0dc78e10..eb0994beb88 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -147,12 +147,12 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = (* be more cautious when do cross module inlining *) when Ext_list.same_length params args && Ext_list.for_all args (fun arg -> - match arg with - | Lvar p -> ( - match Hash_ident.find_opt meta.ident_tbl p with - | Some v -> v <> Parameter - | None -> true) - | _ -> true) + match arg with + | Lvar p -> ( + match Hash_ident.find_opt meta.ident_tbl p with + | Some v -> v <> Parameter + | None -> true) + | _ -> true) && Lam_analysis.lfunction_can_be_inlined lfunction -> simpl (Lam_beta_reduce.propagate_beta_reduce meta params body args) | _ -> diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index 3d2a4f5b4ab..d325fcacf51 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -45,14 +45,13 @@ let convert (xs : input) : output = let os : value list ref = ref [] in xs |> List.iteri (fun i (hash, (name, act)) -> - match Lambda.make_key act with - | None -> - os := {stamp = i; hash_names_act = ([(hash, name)], act)} :: !os - | Some key -> - Coll.add_or_update coll key - ~update:(fun ({hash_names_act = hash_names, act} as acc) -> - {acc with hash_names_act = ((hash, name) :: hash_names, act)}) - {hash_names_act = ([(hash, name)], act); stamp = i}); + match Lambda.make_key act with + | None -> os := {stamp = i; hash_names_act = ([(hash, name)], act)} :: !os + | Some key -> + Coll.add_or_update coll key + ~update:(fun ({hash_names_act = hash_names, act} as acc) -> + {acc with hash_names_act = ((hash, name) :: hash_names, act)}) + {hash_names_act = ([(hash, name)], act); stamp = i}); let result = Coll.to_list coll (fun _ value -> value) @ !os in Ext_list.sort_via_arrayf result (fun x y -> compare x.stamp y.stamp) diff --git a/compiler/ext/ext_modulename.ml b/compiler/ext/ext_modulename.ml index d2d46930f04..4dc16aafd51 100644 --- a/compiler/ext/ext_modulename.ml +++ b/compiler/ext/ext_modulename.ml @@ -30,8 +30,8 @@ let good_hint_name module_name offset = | _ -> false) (String.unsafe_get module_name offset) && Ext_string.for_all_from module_name (offset + 1) (function - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> true - | _ -> false) + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> true + | _ -> false) let rec collect_start buf s off len = if off >= len then () diff --git a/compiler/ext/ext_string.ml b/compiler/ext/ext_string.ml index 19931456ee1..4c62d2e8bf3 100644 --- a/compiler/ext/ext_string.ml +++ b/compiler/ext/ext_string.ml @@ -427,8 +427,8 @@ let is_valid_hash_number (x : string) = if len > 1 then a > 48 && for_all_from x 1 (function - | '0' .. '9' -> true - | _ -> false) + | '0' .. '9' -> true + | _ -> false) else a >= 48 let hash_number_as_i32_exn (x : string) : int32 = Int32.of_string x diff --git a/compiler/ext/ident.ml b/compiler/ext/ident.ml index a5ca80e840f..b77f4d12ae1 100644 --- a/compiler/ext/ident.ml +++ b/compiler/ext/ident.ml @@ -115,8 +115,8 @@ let balance l d r = match l with | Node (ll, ld, lr, _) when (match ll with - | Empty -> 0 - | Node (_, _, _, h) -> h) + | Empty -> 0 + | Node (_, _, _, h) -> h) >= match lr with | Empty -> 0 @@ -129,8 +129,8 @@ let balance l d r = match r with | Node (rl, rd, rr, _) when (match rr with - | Empty -> 0 - | Node (_, _, _, h) -> h) + | Empty -> 0 + | Node (_, _, _, h) -> h) >= match rl with | Empty -> 0 diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index 7bc8af3714a..9e09285b5be 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -442,12 +442,12 @@ let message = function fields |> List.map (fun field -> "\n- " ^ field) |> String.concat "" in (match fields with - | [_] -> - "The following optional field appears in both the explicit pattern and \ - the rest type:" - | _ -> - "The following optional fields appear in both the explicit pattern and \ - the rest type:") + | [_] -> + "The following optional field appears in both the explicit pattern and \ + the rest type:" + | _ -> + "The following optional fields appear in both the explicit pattern and \ + the rest type:") ^ field_list ^ match fields with @@ -455,8 +455,8 @@ let message = function | _ -> "\n\nThey will always be absent from the rest record.") | Bs_todo maybe_text -> (match maybe_text with - | None -> "Todo found." - | Some todo -> "Todo found: " ^ todo) + | None -> "Todo found." + | Some todo -> "Todo found: " ^ todo) ^ "\n\n\ \ This code is not implemented yet and will crash at runtime. Make sure \ you implement this before running the code." diff --git a/compiler/frontend/ast_config.ml b/compiler/frontend/ast_config.ml index c05625b64ee..bb727f68217 100644 --- a/compiler/frontend/ast_config.ml +++ b/compiler/frontend/ast_config.ml @@ -45,12 +45,12 @@ let process_directives str = (* Reset: multiple calls possible e.g. with bsc from the command-line *) str |> List.iter (fun (item : Parsetree.structure_item) -> - match item.pstr_desc with - | Pstr_attribute ({txt = "directive"}, payload) -> ( - match Ast_payload.is_single_string payload with - | Some (d, _) -> Js_config.directives := !Js_config.directives @ [d] - | None -> Bs_syntaxerr.err item.pstr_loc Expect_string_literal) - | _ -> ()) + match item.pstr_desc with + | Pstr_attribute ({txt = "directive"}, payload) -> ( + match Ast_payload.is_single_string payload with + | Some (d, _) -> Js_config.directives := !Js_config.directives @ [d] + | None -> Bs_syntaxerr.err item.pstr_loc Expect_string_literal) + | _ -> ()) let rec iter_on_config_str (x : Parsetree.structure) = match x with diff --git a/compiler/gentype/converter.ml b/compiler/gentype/converter.ml index d7603483932..e70fd321678 100644 --- a/compiler/gentype/converter.ml +++ b/compiler/gentype/converter.ml @@ -66,7 +66,7 @@ let type_get_inlined ~config ~lookup_id ~type_name_is_interface type0 = let with_payload_converted = variant.payloads |> List.map (fun (payload : payload) -> - {payload with t = payload.t |> visit ~visited}) + {payload with t = payload.t |> visit ~visited}) in let normalized = match with_payload_converted with diff --git a/compiler/gentype/emit_js.ml b/compiler/gentype/emit_js.ml index 0d317c99a2b..81453e2776a 100644 --- a/compiler/gentype/emit_js.ml +++ b/compiler/gentype/emit_js.ml @@ -175,12 +175,12 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name let fields = fields |> List.map (fun (field : field) -> - match - field.name_js = "children" - && field.type_ |> Emit_type.is_type_react_element - with - | true -> {field with type_ = Emit_type.type_react_child} - | false -> field) + match + field.name_js = "children" + && field.type_ |> Emit_type.is_type_react_element + with + | true -> {field with type_ = Emit_type.type_react_child} + | false -> field) in let function_ = { @@ -295,12 +295,12 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name let fields = fields |> List.map (fun (field : field) -> - match - field.name_js = "children" - && field.type_ |> Emit_type.is_type_react_element - with - | true -> {field with type_ = Emit_type.type_react_child} - | false -> field) + match + field.name_js = "children" + && field.type_ |> Emit_type.is_type_react_element + with + | true -> {field with type_ = Emit_type.type_react_child} + | false -> field) in Object (closed_flags, fields) in @@ -470,7 +470,7 @@ let rec read_cmt_files_recursively ~config ~env let new_import_types = type_declarations |> List.map (fun (type_declaration : Code_item.type_declaration) -> - type_declaration.import_types) + type_declaration.import_types) |> List.concat in new_import_types @@ -513,23 +513,23 @@ let emit_import_types ~config ~emitters ~env let get_annotated_typed_declarations ~annotated_set type_declarations = type_declarations |> List.map (fun type_declaration -> - let name_in_annotated_set = - annotated_set - |> String_set.mem - (type_declaration.Code_item.export_from_type_declaration - .export_type - .resolved_type_name |> Resolved_name.to_string) - in - if name_in_annotated_set then - { - type_declaration with - export_from_type_declaration = - { - type_declaration.export_from_type_declaration with - annotation = GenType; - }; - } - else type_declaration) + let name_in_annotated_set = + annotated_set + |> String_set.mem + (type_declaration.Code_item.export_from_type_declaration + .export_type + .resolved_type_name |> Resolved_name.to_string) + in + if name_in_annotated_set then + { + type_declaration with + export_from_type_declaration = + { + type_declaration.export_from_type_declaration with + annotation = GenType; + }; + } + else type_declaration) |> List.filter (fun ({export_from_type_declaration = {annotation}} : @@ -542,7 +542,7 @@ let propagate_annotation_to_sub_types ~code_items let initial_annotated_types = type_map |> String_map.bindings |> List.filter (fun (_, {Code_item.annotation}) -> - annotation = Annotation.GenType) + annotation = Annotation.GenType) |> List.map (fun (_, {Code_item.type_}) -> type_) in let types_of_exported_value (code_item : Code_item.t) = @@ -627,13 +627,13 @@ let emit_translation_as_string ~config ~file_name let import_types_from_type_declarations = annotated_type_declarations |> List.map (fun (type_declaration : Code_item.type_declaration) -> - type_declaration.import_types) + type_declaration.import_types) |> List.concat in let export_from_type_declarations = annotated_type_declarations |> List.map (fun (type_declaration : Code_item.type_declaration) -> - type_declaration.export_from_type_declaration) + type_declaration.export_from_type_declaration) in let type_name_is_interface ~env = type_name_is_interface ~export_type_map diff --git a/compiler/gentype/emit_type.ml b/compiler/gentype/emit_type.ml index 79c1d253fde..922e0896411 100644 --- a/compiler/gentype/emit_type.ml +++ b/compiler/gentype/emit_type.ml @@ -95,13 +95,13 @@ let rec render_type ~(config : Config.t) ?(indent = None) let fields = fields |> List.map (fun field -> - { - field with - type_ = - field.type_ - |> Type_vars.substitute ~f:(fun s -> - if type_vars |> List.mem s then Some type_any else None); - }) + { + field with + type_ = + field.type_ + |> Type_vars.substitute ~f:(fun s -> + if type_vars |> List.mem s then Some type_any else None); + }) in let component_type = type_react_component ~props_type:(Object (closed_flag, fields)) @@ -122,8 +122,8 @@ let rec render_type ~(config : Config.t) ?(indent = None) (not builtin) && config.export_interfaces && name |> type_name_is_interface with - | true -> name |> interface_name ~config - | false -> name) + | true -> name |> interface_name ~config + | false -> name) ^ Emit_text.generics_string ~type_vars: (type_args @@ -172,8 +172,8 @@ let rec render_type ~(config : Config.t) ?(indent = None) let inherits_rendered = inherits |> List.map (fun type_ -> - type_ - |> render_type ~config ~indent ~type_name_is_interface ~in_fun_type) + type_ + |> render_type ~config ~indent ~type_name_is_interface ~in_fun_type) in let no_payloads_rendered = no_payloads |> List.map label_js_to_string in let field ~name value = @@ -192,63 +192,61 @@ let rec render_type ~(config : Config.t) ?(indent = None) let payloads_rendered = payloads |> List.map (fun {case; t = type_} -> - let render t = - t - |> render_type ~config ~indent ~type_name_is_interface - ~in_fun_type - in - let tag_field = - case |> label_js_to_string - |> field ~name:(Runtime.js_variant_tag ~polymorphic:false ~tag) - in - match (unboxed, type_) with - | true, type_ -> - let need_parens = - match type_ with - | Function _ -> true - | _ -> false - in - let t = type_ |> render in - if need_parens then Emit_text.parens [t] else t - | false, type_ when polymorphic -> - (* poly variant *) - [ - case |> label_js_to_string - |> field ~name:(Runtime.js_variant_tag ~polymorphic ~tag); - type_ |> render - |> field ~name:(Runtime.js_variant_value ~polymorphic); - ] - |> fields - | false, Object (Inline, flds) -> - (* inlined record *) - tag_field :: flds |> fields - | false, type_ -> - (* ordinary variant *) - let payloads = - match type_ with - | Tuple ts -> ts - | _ -> [type_] - in - let flds = - tag_field - :: Ext_list.mapi payloads (fun n t -> - t |> render - |> field ~name:(Runtime.js_variant_payload_tag ~n)) - in - flds |> fields) + let render t = + t + |> render_type ~config ~indent ~type_name_is_interface ~in_fun_type + in + let tag_field = + case |> label_js_to_string + |> field ~name:(Runtime.js_variant_tag ~polymorphic:false ~tag) + in + match (unboxed, type_) with + | true, type_ -> + let need_parens = + match type_ with + | Function _ -> true + | _ -> false + in + let t = type_ |> render in + if need_parens then Emit_text.parens [t] else t + | false, type_ when polymorphic -> + (* poly variant *) + [ + case |> label_js_to_string + |> field ~name:(Runtime.js_variant_tag ~polymorphic ~tag); + type_ |> render + |> field ~name:(Runtime.js_variant_value ~polymorphic); + ] + |> fields + | false, Object (Inline, flds) -> + (* inlined record *) + tag_field :: flds |> fields + | false, type_ -> + (* ordinary variant *) + let payloads = + match type_ with + | Tuple ts -> ts + | _ -> [type_] + in + let flds = + tag_field + :: Ext_list.mapi payloads (fun n t -> + t |> render |> field ~name:(Runtime.js_variant_payload_tag ~n)) + in + flds |> fields) in let rendered = inherits_rendered @ no_payloads_rendered @ payloads_rendered in let indent1 = rendered |> Indent.heuristic_variants ~indent in (match indent1 = None with - | true -> "" - | false -> Indent.break ~indent:indent1 ^ " ") + | true -> "" + | false -> Indent.break ~indent:indent1 ^ " ") ^ (rendered |> String.concat ((match indent1 = None with - | true -> " " - | false -> Indent.break ~indent:indent1) + | true -> " " + | false -> Indent.break ~indent:indent1) ^ "| ")) and render_field ~config ~indent ~type_name_is_interface ~in_fun_type @@ -299,8 +297,8 @@ and render_fields ~config ~indent ~in_fun_type ~type_name_is_interface fields = and render_fun_type ~config ~indent ~in_fun_type ~type_name_is_interface ~type_vars arg_types ret_type = (match in_fun_type with - | true -> "(" - | false -> "") + | true -> "(" + | false -> "") ^ Emit_text.generics_string ~type_vars ^ "(" ^ String.concat ", " @@ -308,8 +306,8 @@ and render_fun_type ~config ~indent ~in_fun_type ~type_name_is_interface (fun i {a_name; a_type} -> let parameter_name = (match a_name = "" with - | true -> "_" ^ string_of_int (i + 1) - | false -> a_name) + | true -> "_" ^ string_of_int (i + 1) + | false -> a_name) ^ ":" in parameter_name @@ -333,8 +331,8 @@ let emit_export_const ~early ?(comment = "") ~config ~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") + | true -> comment + | false -> "// " ^ comment ^ "\n") ^ Doc_string.render doc_string ^ "export const " ^ name ^ ": " ^ type_string ^ " = " ^ line ^ " as any;" |> (match early with diff --git a/compiler/gentype/gentype_common.ml b/compiler/gentype/gentype_common.ml index eabddae4325..a1e92e6179e 100644 --- a/compiler/gentype/gentype_common.ml +++ b/compiler/gentype/gentype_common.ml @@ -31,19 +31,19 @@ type case = {label_js: label_js} let is_js_safe_property_name name = name = "" || (match name.[0] [@doesNotRaise] with - | 'A' .. 'z' -> true - | _ -> false) + | 'A' .. 'z' -> true + | _ -> false) && name |> String.for_all (function - | 'A' .. 'z' | '0' .. '9' -> true - | _ -> false) + | 'A' .. 'z' | '0' .. '9' -> true + | _ -> false) let is_number s = let len = String.length s in len > 0 && (match len > 1 with - | true -> (s.[0] [@doesNotRaise]) > '0' - | false -> true) + | true -> (s.[0] [@doesNotRaise]) > '0' + | false -> true) && let res = ref true in for i = 0 to len - 1 do @@ -147,8 +147,8 @@ struct let is_generated_module id ~(config : Config.t) = config.bs_dependencies |> List.exists (fun package_name -> - package_name |> package_name_to_generated_module_name - = Some (id |> Ident.name)) + package_name |> package_name_to_generated_module_name + = Some (id |> Ident.name)) (** (Common, DemoSomelibrary) -> Common-DemoSomelibrary *) let add_generated_module s ~generated_module = @@ -182,8 +182,8 @@ let ident ?(builtin = true) ?(type_args = []) name = let sanitize_type_name name = name |> Ext_ident.unwrap_uppercase_exotic |> String.map (function - | '\'' -> '_' - | c -> c) + | '\'' -> '_' + | c -> c) let unknown = ident "unknown" let bigint_t = ident "bigint" let boolean_t = ident "boolean" diff --git a/compiler/gentype/gentype_main.ml b/compiler/gentype/gentype_main.ml index 12a1b64ca10..45a8e34c3b2 100644 --- a/compiler/gentype/gentype_main.ml +++ b/compiler/gentype/gentype_main.ml @@ -116,14 +116,14 @@ let read_input_cmt is_interface cmt_file = let has_gentype_annotations_impl = input_cmt_impl |> cmt_check_annotations ~check_annotation:(fun ~loc attributes -> - if attributes |> check_annotation ~loc then ( - if not !ignore_interface then ( - Log_.Color.setup (); - Log_.info ~loc ~name:"Warning genType" (fun ppf () -> - Format.fprintf ppf - "Annotation is ignored as there's a .resi file")); - true) - else false) + if attributes |> check_annotation ~loc then ( + if not !ignore_interface then ( + Log_.Color.setup (); + Log_.info ~loc ~name:"Warning genType" (fun ppf () -> + Format.fprintf ppf + "Annotation is ignored as there's a .resi file")); + true) + else false) in ( (match !ignore_interface with | true -> input_cmt_impl diff --git a/compiler/gentype/module_name.ml b/compiler/gentype/module_name.ml index efd0d25370a..41269e3a697 100644 --- a/compiler/gentype/module_name.ml +++ b/compiler/gentype/module_name.ml @@ -9,8 +9,8 @@ let sanitize_id s = then s |> String.map (function - | '.' | '[' | ']' -> '_' - | c -> c) + | '.' | '[' | ']' -> '_' + | c -> c) else s in if s <> "" && (s.[0] [@doesNotRaise]) >= 'A' && (s.[0] [@doesNotRaise]) <= 'z' diff --git a/compiler/gentype/module_resolver.ml b/compiler/gentype/module_resolver.ml index e7ed1a31cae..698cb75d72d 100644 --- a/compiler/gentype/module_resolver.ml +++ b/compiler/gentype/module_resolver.ml @@ -37,35 +37,35 @@ let sourcedirs_to_map ~(config : Config.t) ~extensions ~exclude_file = let add_dir ~dir_on_disk ~dir_emitted ~filter ~map = dir_on_disk |> Sys.readdir |> Array.iter (fun fname -> - if fname |> filter then - map := - !map - |> Module_name_map.add - (fname |> chop_extensions |> Module_name.from_string_unsafe) - dir_emitted) + if fname |> filter then + map := + !map + |> Module_name_map.add + (fname |> chop_extensions |> Module_name.from_string_unsafe) + dir_emitted) in config.sources |> List.iter (fun dir -> - let dir_on_disk = config.project_root +++ dir in - if Sys.file_exists dir_on_disk && Sys.is_directory dir_on_disk then - add_dir ~dir_emitted:dir ~dir_on_disk ~filter:filter_given_extension - ~map:file_map); + let dir_on_disk = config.project_root +++ dir in + if Sys.file_exists dir_on_disk && Sys.is_directory dir_on_disk then + add_dir ~dir_emitted:dir ~dir_on_disk ~filter:filter_given_extension + ~map:file_map); config.bs_dependencies |> List.iter (fun package_name -> - match Hashtbl.find config.dep_paths package_name with - | path -> - let root = ["lib"; "bs"] |> List.fold_left ( +++ ) path in - let filter file_name = - [".cmt"; ".cmti"] - |> List.exists (fun ext -> Filename.check_suffix file_name ext) - in - read_bs_dependencies_dirs ~root - |> List.iter (fun dir -> - let dir_on_disk = root +++ dir in - let dir_emitted = package_name +++ dir in - add_dir ~dir_emitted ~dir_on_disk ~filter - ~map:bs_dependencies_file_map) - | exception Not_found -> ()); + match Hashtbl.find config.dep_paths package_name with + | path -> + let root = ["lib"; "bs"] |> List.fold_left ( +++ ) path in + let filter file_name = + [".cmt"; ".cmti"] + |> List.exists (fun ext -> Filename.check_suffix file_name ext) + in + read_bs_dependencies_dirs ~root + |> List.iter (fun dir -> + let dir_on_disk = root +++ dir in + let dir_emitted = package_name +++ dir in + add_dir ~dir_emitted ~dir_on_disk ~filter + ~map:bs_dependencies_file_map) + | exception Not_found -> ()); (!file_map, !bs_dependencies_file_map) type case = Lowercase | Uppercase @@ -159,8 +159,8 @@ let resolve_module ~(config : Config.t) ~import_extension ~output_file_relative in (* e.g. import "../dst/ModuleName.ext" *) (match case = Uppercase with - | true -> module_name - | false -> module_name |> Module_name.uncapitalize) + | true -> module_name + | false -> module_name |> Module_name.uncapitalize) |> Import_path.from_module ~dir:from_output_dir_to_module_dir ~import_extension diff --git a/compiler/gentype/translate_core_type.ml b/compiler/gentype/translate_core_type.ml index a9029e62ccb..25eabe83237 100644 --- a/compiler/gentype/translate_core_type.ml +++ b/compiler/gentype/translate_core_type.ml @@ -170,46 +170,44 @@ and translateCoreType_ ~config ~type_vars_gen let no_payloads = no_payloads |> List.map (fun (label, attributes) -> - let label_js = - if as_string then - match attributes |> Annotation.get_as_string with - | Some label_renamed -> StringLabel label_renamed - | None -> - if is_number label then IntLabel label - else StringLabel label - else if as_int then ( - match attributes |> Annotation.get_as_int with - | Some n -> - last_bs_int := n; - IntLabel (string_of_int n) - | None -> - last_bs_int := !last_bs_int + 1; - IntLabel (string_of_int !last_bs_int)) - else if is_number label then IntLabel label - else StringLabel label - in - {label_js}) + let label_js = + if as_string then + match attributes |> Annotation.get_as_string with + | Some label_renamed -> StringLabel label_renamed + | None -> + if is_number label then IntLabel label else StringLabel label + else if as_int then ( + match attributes |> Annotation.get_as_int with + | Some n -> + last_bs_int := n; + IntLabel (string_of_int n) + | None -> + last_bs_int := !last_bs_int + 1; + IntLabel (string_of_int !last_bs_int)) + else if is_number label then IntLabel label + else StringLabel label + in + {label_js}) in let payloads_translations = payloads |> List.map (fun (label, attributes, payload) -> - ( label, - attributes, - payload |> translateCoreType_ ~config ~type_vars_gen ~type_env - )) + ( label, + attributes, + payload |> translateCoreType_ ~config ~type_vars_gen ~type_env )) in let payloads = payloads_translations |> List.map (fun (label, _attributes, translation) -> - { - case = - { - label_js = - (if is_number label then IntLabel label - else StringLabel label); - }; - t = translation.type_; - }) + { + case = + { + label_js = + (if is_number label then IntLabel label + else StringLabel label); + }; + t = translation.type_; + }) in let inherits_translations = inherits |> translateCoreTypes_ ~config ~type_vars_gen ~type_env @@ -234,8 +232,8 @@ and translateCoreType_ ~config ~type_vars_gen let type_equations_translation = pack_fields |> List.map (fun (x, t) -> - ( x.Asttypes.txt, - t |> translateCoreType_ ~config ~type_vars_gen ~type_env )) + ( x.Asttypes.txt, + t |> translateCoreType_ ~config ~type_vars_gen ~type_env )) in let type_equations = type_equations_translation @@ -272,5 +270,5 @@ let translate_core_type ~config ~type_env core_type = if !Debug.dependencies then translation.dependencies |> List.iter (fun dep -> - Log_.item "Dependency: %s\n" (dep |> dep_to_string)); + Log_.item "Dependency: %s\n" (dep |> dep_to_string)); translation diff --git a/compiler/gentype/translate_structure.ml b/compiler/gentype/translate_structure.ml index cff62a1a9a2..56b81dac262 100644 --- a/compiler/gentype/translate_structure.ml +++ b/compiler/gentype/translate_structure.ml @@ -35,7 +35,7 @@ and add_annotations_to_types ~config ~(expr : Typedtree.expression) (* Underscore "_" appears as "param", can occur more than once *) arg_types |> List.mapi (fun i {a_name; a_type} -> - {a_name = a_name ^ "_" ^ string_of_int i; a_type}) + {a_name = a_name ^ "_" ^ string_of_int i; a_type}) else arg_types and add_annotations_to_fields ~config (expr : Typedtree.expression) @@ -125,10 +125,10 @@ let rec remove_duplicate_value_bindings let value_bindings_filtered = value_bindings |> List.filter (fun value_binding -> - match value_binding with - | {Typedtree.vb_pat = {pat_desc = Tpat_var (id, _)}} -> - not (bound_in_rest |> String_set.mem (id |> Ident.name)) - | _ -> true) + match value_binding with + | {Typedtree.vb_pat = {pat_desc = Tpat_var (id, _)}} -> + not (bound_in_rest |> String_set.mem (id |> Ident.name)) + | _ -> true) in let bound = value_bindings @@ -353,6 +353,6 @@ and translate_structure ~config ~output_file_relative ~resolver ~type_env if !Debug.translation then Log_.item "Translate Structure\n"; structure.Typedtree.str_items |> remove_value_binding_duplicates |> List.map (fun struct_item -> - struct_item - |> translate_structure_item ~config ~output_file_relative ~resolver - ~type_env) + struct_item + |> translate_structure_item ~config ~output_file_relative ~resolver + ~type_env) diff --git a/compiler/gentype/translate_type_declarations.ml b/compiler/gentype/translate_type_declarations.ml index 561816b0802..f14fd9ac42c 100644 --- a/compiler/gentype/translate_type_declarations.ml +++ b/compiler/gentype/translate_type_declarations.ml @@ -222,8 +222,8 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver (List.combine variant.payloads row_fields_variants.payloads [@doesNotRaise]) |> List.map (fun (payload, (label, attributes, _)) -> - let case = create_polyvariant_case (label, attributes) in - {payload with case}) + let case = create_polyvariant_case (label, attributes) in + {payload with case}) else variant.payloads in create_variant ~inherits:variant.inherits ~no_payloads ~payloads @@ -262,38 +262,38 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver let variants = constructor_declarations |> List.mapi (fun position constructor_declaration -> - let constructor_args = constructor_declaration.Types.cd_args in - let name = constructor_declaration.cd_id |> Ident.name in - let tag = Variant_runtime.constructor_tag layout position in - let args_translation = - match constructor_args with - | Cstr_tuple type_exprs -> - type_exprs - |> Translate_type_expr_from_types - .translate_type_exprs_from_types ~config ~type_env - | Cstr_record label_declarations -> - [ - label_declarations - |> translate_label_declarations ~inline:true - ~unboxed: - (type_representation = Unboxed - || Variant_runtime.constructor_is_untagged layout - position); - ] - in - let arg_types = - args_translation - |> List.map (fun {Translate_type_expr_from_types.type_} -> type_) - in - let import_types = - args_translation - |> List.map (fun {Translate_type_expr_from_types.dependencies} -> - dependencies) - |> List.concat - |> Translation.translate_dependencies ~config - ~output_file_relative ~resolver - in - (name, tag, arg_types, import_types)) + let constructor_args = constructor_declaration.Types.cd_args in + let name = constructor_declaration.cd_id |> Ident.name in + let tag = Variant_runtime.constructor_tag layout position in + let args_translation = + match constructor_args with + | Cstr_tuple type_exprs -> + type_exprs + |> Translate_type_expr_from_types.translate_type_exprs_from_types + ~config ~type_env + | Cstr_record label_declarations -> + [ + label_declarations + |> translate_label_declarations ~inline:true + ~unboxed: + (type_representation = Unboxed + || Variant_runtime.constructor_is_untagged layout + position); + ] + in + let arg_types = + args_translation + |> List.map (fun {Translate_type_expr_from_types.type_} -> type_) + in + let import_types = + args_translation + |> List.map (fun {Translate_type_expr_from_types.dependencies} -> + dependencies) + |> List.concat + |> Translation.translate_dependencies ~config ~output_file_relative + ~resolver + in + (name, tag, arg_types, import_types)) in let variants_no_payload, variants_with_payload = variants |> List.partition (fun (_, _, arg_types, _) -> arg_types = []) @@ -301,17 +301,17 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver let no_payloads = variants_no_payload |> List.map (fun (name, tag, _argTypes, _importTypes) -> - create_variant_case name tag) + create_variant_case name tag) in let payloads = variants_with_payload |> List.map (fun (name, tag, arg_types, _importTypes) -> - let type_ = - match arg_types with - | [type_] -> type_ - | _ -> Tuple arg_types - in - {case = create_variant_case name tag; t = type_}) + let type_ = + match arg_types with + | [type_] -> type_ + | _ -> Tuple arg_types + in + {case = create_variant_case name tag; t = type_}) in let variant_typ = let unboxed = @@ -394,12 +394,12 @@ let translate_type_declarations ~config ~output_file_relative ~recursive |> List.iter (add_type_declaration_id_to_type_env ~type_env); type_declarations |> List.map (fun type_declaration -> - let res = - type_declaration - |> translate_type_declaration ~config ~output_file_relative ~resolver - ~type_env - in - if not recursive then - type_declaration |> add_type_declaration_id_to_type_env ~type_env; - res) + let res = + type_declaration + |> translate_type_declaration ~config ~output_file_relative ~resolver + ~type_env + in + if not recursive then + type_declaration |> add_type_declaration_id_to_type_env ~type_env; + res) |> List.concat diff --git a/compiler/gentype/translate_type_expr_from_types.ml b/compiler/gentype/translate_type_expr_from_types.ml index 96b5ffcfb41..0e918375bfa 100644 --- a/compiler/gentype/translate_type_expr_from_types.ml +++ b/compiler/gentype/translate_type_expr_from_types.ml @@ -40,18 +40,18 @@ let translate_obj_type closed_flag fields_translations = let fields = fields_translations |> check_mutable_field |> List.map (fun (name, t, mutable_) -> - let optional, type_ = - match t with - | Option t -> (Optional, t) - | _ -> (Mandatory, t) - in - { - mutable_; - name_js = name; - optional; - type_; - doc_string = Doc_string.empty; - }) + let optional, type_ = + match t with + | Option t -> (Optional, t) + | _ -> (Mandatory, t) + in + { + mutable_; + name_js = name; + optional; + type_; + doc_string = Doc_string.empty; + }) in let type_ = Object (closed_flag, fields) in {dependencies; type_} @@ -561,11 +561,10 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env let no_payloads = no_payloads |> List.map (fun label -> - { - label_js = - (if is_number label then IntLabel label - else StringLabel label); - }) + { + label_js = + (if is_number label then IntLabel label else StringLabel label); + }) in let type_ = create_variant ~inherits:[] ~no_payloads ~payloads:[] ~polymorphic:true @@ -582,15 +581,14 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env let payload_translations = payloads |> List.map (fun (label, payload) -> - ( label, - payload - |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env - )) + ( label, + payload + |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env )) in let payloads = payload_translations |> List.map (fun (label, translation) -> - {case = {label_js = StringLabel label}; t = translation.type_}) + {case = {label_js = StringLabel label}; t = translation.type_}) in let type_ = create_variant ~inherits:[] ~no_payloads ~payloads ~polymorphic:true @@ -609,10 +607,9 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env let type_equations_translation = (List.combine ids types [@doesNotRaise]) |> List.map (fun (x, t) -> - ( x, - t - |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env - )) + ( x, + t |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env + )) in let type_equations = type_equations_translation @@ -648,53 +645,50 @@ and signature_to_module_runtime_representation ~config ~type_vars_gen ~type_env let dependencies_and_fields = signature |> List.map (fun signature_item -> - match signature_item with - | Types.Sig_value (_id, {val_kind = Val_prim _}) -> ([], []) - | Types.Sig_value (id, {val_type = type_expr; val_attributes}) -> - let {dependencies; type_} = - type_expr - |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env - in - let field = - { - mutable_ = Immutable; - name_js = id |> Ident.name; - optional = Mandatory; - type_; - doc_string = Annotation.doc_string_from_attrs val_attributes; - } - in - (dependencies, [field]) - | Types.Sig_module (id, module_declaration, _recStatus) -> - let type_env1 = - match - type_env |> Type_env.get_module ~name:(id |> Ident.name) - with - | Some type_env1 -> type_env1 - | None -> type_env - in - let dependencies, type_ = - match module_declaration.md_type with - | Mty_signature signature -> - signature - |> signature_to_module_runtime_representation ~config - ~type_vars_gen ~type_env:type_env1 - | Mty_ident _ | Mty_functor _ | Mty_alias _ -> ([], unknown) - in - let field = - { - mutable_ = Immutable; - name_js = id |> Ident.name; - optional = Mandatory; - type_; - doc_string = - Annotation.doc_string_from_attrs - module_declaration.md_attributes; - } - in - (dependencies, [field]) - | Types.Sig_type _ | Types.Sig_typext _ | Types.Sig_modtype _ -> - ([], [])) + match signature_item with + | Types.Sig_value (_id, {val_kind = Val_prim _}) -> ([], []) + | Types.Sig_value (id, {val_type = type_expr; val_attributes}) -> + let {dependencies; type_} = + type_expr + |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env + in + let field = + { + mutable_ = Immutable; + name_js = id |> Ident.name; + optional = Mandatory; + type_; + doc_string = Annotation.doc_string_from_attrs val_attributes; + } + in + (dependencies, [field]) + | Types.Sig_module (id, module_declaration, _recStatus) -> + let type_env1 = + match type_env |> Type_env.get_module ~name:(id |> Ident.name) with + | Some type_env1 -> type_env1 + | None -> type_env + in + let dependencies, type_ = + match module_declaration.md_type with + | Mty_signature signature -> + signature + |> signature_to_module_runtime_representation ~config + ~type_vars_gen ~type_env:type_env1 + | Mty_ident _ | Mty_functor _ | Mty_alias _ -> ([], unknown) + in + let field = + { + mutable_ = Immutable; + name_js = id |> Ident.name; + optional = Mandatory; + type_; + doc_string = + Annotation.doc_string_from_attrs + module_declaration.md_attributes; + } + in + (dependencies, [field]) + | Types.Sig_type _ | Types.Sig_typext _ | Types.Sig_modtype _ -> ([], [])) in let dependencies, fields = let dl, fl = dependencies_and_fields |> List.split in @@ -710,7 +704,7 @@ let translate_type_expr_from_types ~config ~type_env type_expr = if !Debug.dependencies then translation.dependencies |> List.iter (fun dep -> - Log_.item "Dependency: %s\n" (dep |> dep_to_string)); + Log_.item "Dependency: %s\n" (dep |> dep_to_string)); translation let translate_type_exprs_from_types ~config ~type_env type_exprs = @@ -721,7 +715,7 @@ let translate_type_exprs_from_types ~config ~type_env type_exprs = if !Debug.dependencies then translations |> List.iter (fun translation -> - translation.dependencies - |> List.iter (fun dep -> - Log_.item "Dependency: %s\n" (dep |> dep_to_string))); + translation.dependencies + |> List.iter (fun dep -> + Log_.item "Dependency: %s\n" (dep |> dep_to_string))); translations diff --git a/compiler/gentype/translation.ml b/compiler/gentype/translation.ml index e382cdf6e75..10fd6225818 100644 --- a/compiler/gentype/translation.ml +++ b/compiler/gentype/translation.ml @@ -18,7 +18,7 @@ let import_type_compare i1 i2 = let combine (translations : t list) : t = ( translations |> List.map (fun {Code_item.import_types; code_items; type_declarations} -> - ((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) -> @@ -175,38 +175,35 @@ let add_type_declarations_from_module_equations ~type_env (translation : t) = let new_type_declarations = translation.type_declarations |> 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 - |> Resolved_name.apply_equations ~eqs - in - equations - |> List.map (fun (x, y) -> - let new_export_type = - { - export_type with - name_as = None; - type_ = - y |> Resolved_name.to_string - |> ident ~builtin:false - ~type_args: - (export_type.type_vars - |> List.map (fun s -> TypeVar s)); - resolved_type_name = x; - } - in - { - Code_item.export_from_type_declaration = - { - Code_item.export_type = new_export_type; - annotation = - type_declaration.export_from_type_declaration - .annotation; - }; - import_types = []; - })) + let export_type = + type_declaration.export_from_type_declaration.export_type + in + let equations = + export_type.resolved_type_name |> Resolved_name.apply_equations ~eqs + in + equations + |> List.map (fun (x, y) -> + let new_export_type = + { + export_type with + name_as = None; + type_ = + y |> Resolved_name.to_string + |> ident ~builtin:false + ~type_args: + (export_type.type_vars |> List.map (fun s -> TypeVar s)); + resolved_type_name = x; + } + in + { + Code_item.export_from_type_declaration = + { + Code_item.export_type = new_export_type; + annotation = + type_declaration.export_from_type_declaration.annotation; + }; + import_types = []; + })) |> List.concat in match new_type_declarations = [] with diff --git a/compiler/gentype/type_env.ml b/compiler/gentype/type_env.ml index 12a844c5cb2..e1fe6e2b972 100644 --- a/compiler/gentype/type_env.ml +++ b/compiler/gentype/type_env.ml @@ -113,7 +113,7 @@ let apply_type_equations ~config ~path type_env = (type_env |> to_string) (id |> Ident.name) (type_ |> Emit_type.type_to_string ~config ~type_name_is_interface:(fun _ -> - false)); + false)); Some type_ | exception Not_found -> None) | _ -> None @@ -176,9 +176,9 @@ let rec get_module_equations type_env : Resolved_name.eq list = let sub_equations = type_env.map |> String_map.bindings |> List.map (fun (_, entry) -> - match entry with - | Module te -> te |> get_module_equations - | Type _ -> []) + match entry with + | Module te -> te |> get_module_equations + | Type _ -> []) |> List.concat in match (type_env.module_equation, type_env.parent) with diff --git a/compiler/gentype/type_vars.ml b/compiler/gentype/type_vars.ml index 22d626503b0..3d583f6c31f 100644 --- a/compiler/gentype/type_vars.ml +++ b/compiler/gentype/type_vars.ml @@ -38,7 +38,7 @@ let rec substitute ~f type0 = arg_types = function_.arg_types |> List.map (fun {a_name; a_type = t} -> - {a_name; a_type = t |> substitute ~f}); + {a_name; a_type = t |> substitute ~f}); } | Ident {type_args = []} -> type0 | Ident ({type_args} as ident) -> @@ -50,7 +50,7 @@ let rec substitute ~f type0 = ( closed_flag, fields |> List.map (fun field -> - {field with type_ = field.type_ |> substitute ~f}) ) + {field with type_ = field.type_ |> substitute ~f}) ) | Option type_ -> Option (type_ |> substitute ~f) | Promise type_ -> Promise (type_ |> substitute ~f) | Tuple inner_types -> Tuple (inner_types |> List.map (substitute ~f)) @@ -65,7 +65,7 @@ let rec substitute ~f type0 = payloads = variant.payloads |> List.map (fun payload -> - {payload with t = payload.t |> substitute ~f}); + {payload with t = payload.t |> substitute ~f}); } let rec free_ type0 : String_set.t = diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index 2ca3db57251..9abef11ca6f 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -273,18 +273,16 @@ module Res_driver = struct let errors = parse_result.diagnostics |> List.map (fun d -> - let full_msg = - diagnostic_to_string ~src:parse_result.source d - in - let short_msg = Res_diagnostics.explain d in - let loc = - { - Location.loc_start = Res_diagnostics.get_start_pos d; - Location.loc_end = Res_diagnostics.get_end_pos d; - loc_ghost = false; - } - in - {full_msg; short_msg; loc}) + let full_msg = diagnostic_to_string ~src:parse_result.source d in + let short_msg = Res_diagnostics.explain d in + let loc = + { + Location.loc_start = Res_diagnostics.get_start_pos d; + Location.loc_end = Res_diagnostics.get_end_pos d; + loc_ghost = false; + } + in + {full_msg; short_msg; loc}) |> List.rev in raise (RescriptParsingErrors errors) @@ -607,12 +605,12 @@ module Export = struct ( "compile", inject @@ Js.wrap_meth_callback (fun _ code -> - Compile.implementation ~config ~lang (Js.to_string code)) ); + Compile.implementation ~config ~lang (Js.to_string code)) ); ( "compileWithDebug", inject @@ Js.wrap_meth_callback (fun _ code -> - Compile.implementation ~include_debug_outputs:true ~config - ~lang (Js.to_string code)) ); + Compile.implementation ~include_debug_outputs:true ~config ~lang + (Js.to_string code)) ); ("version", inject @@ Js.string Bs_version.version); |] in @@ -622,8 +620,8 @@ module Export = struct ( "format", inject @@ Js.wrap_meth_callback (fun _ code -> - Compile.syntax_format ?filename:config.filename ~from:lang - ~to_:lang (Js.to_string code)) ); + Compile.syntax_format ?filename:config.filename ~from:lang + ~to_:lang (Js.to_string code)) ); |] in obj attrs @@ -688,61 +686,60 @@ module Export = struct ( "convertSyntax", inject @@ Js.wrap_meth_callback (fun _ from_lang to_lang src -> - convert_syntax ~from_lang:(Js.to_string from_lang) - ~to_lang:(Js.to_string to_lang) (Js.to_string src)) ); + convert_syntax ~from_lang:(Js.to_string from_lang) + ~to_lang:(Js.to_string to_lang) (Js.to_string src)) ); ( "setModuleSystem", inject @@ Js.wrap_meth_callback (fun _ value -> - Js.bool (set_module_system (Js.to_string value))) ); + Js.bool (set_module_system (Js.to_string value))) ); ( "setFilename", inject @@ Js.wrap_meth_callback (fun _ value -> - Js.bool (set_filename (Js.to_string value))) ); + Js.bool (set_filename (Js.to_string value))) ); ( "setWarnFlags", inject @@ Js.wrap_meth_callback (fun _ value -> - Js.bool (set_warn_flags (Js.to_string value))) ); + Js.bool (set_warn_flags (Js.to_string value))) ); ( "setOpenModules", inject @@ Js.wrap_meth_callback (fun _ value -> - Js.bool - (set_open_modules - (value |> Js.to_array |> Array.map Js.to_string - |> Array.to_list))) ); + Js.bool + (set_open_modules + (value |> Js.to_array |> Array.map Js.to_string + |> Array.to_list))) ); ( "setExperimentalFeatures", inject @@ Js.wrap_meth_callback (fun _ value -> - Js.bool - (set_experimental_features - (value |> Js.to_array |> Array.map Js.to_string - |> Array.to_list))) ); + Js.bool + (set_experimental_features + (value |> Js.to_array |> Array.map Js.to_string + |> Array.to_list))) ); ( "setJsxPreserveMode", inject @@ Js.wrap_meth_callback (fun _ value -> - Js.bool (set_jsx_preserve_mode (Js.to_bool value))) ); + Js.bool (set_jsx_preserve_mode (Js.to_bool value))) ); ( "getConfig", inject @@ Js.wrap_meth_callback (fun _ -> - Js.Unsafe.( - obj - [| - ( "module_system", - inject - @@ (config.module_system - |> Bundle_config.string_of_module_system - |> Js.string) ); - ("warn_flags", inject @@ Js.string config.warn_flags); - ( "jsx_preserve_mode", - inject @@ (config.jsx_preserve_mode |> Js.bool) ); - ( "experimental_features", - inject - @@ (config.experimental_features |> Array.of_list - |> Js.array) ); - ( "open_modules", - inject - @@ (config.open_modules |> Array.of_list |> Js.array) - ); - |])) ); + Js.Unsafe.( + obj + [| + ( "module_system", + inject + @@ (config.module_system + |> Bundle_config.string_of_module_system |> Js.string + ) ); + ("warn_flags", inject @@ Js.string config.warn_flags); + ( "jsx_preserve_mode", + inject @@ (config.jsx_preserve_mode |> Js.bool) ); + ( "experimental_features", + inject + @@ (config.experimental_features |> Array.of_list + |> Js.array) ); + ( "open_modules", + inject + @@ (config.open_modules |> Array.of_list |> Js.array) ); + |])) ); |]) end diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index cb12e036f0c..3531d9124ab 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -977,10 +977,10 @@ let default_mapper = when List.map (fun {txt} -> txt) newtypes = List.map (fun {txt} -> txt) poly_newtypes && - try - Ast_helper0.Typ.varify_constructors newtypes typ - = poly_type - with Syntaxerr.Error _ -> false -> + try + Ast_helper0.Typ.varify_constructors newtypes typ + = poly_type + with Syntaxerr.Error _ -> false -> Some (pat, expr, newtypes, typ) | _ -> None) | _ -> None diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 21375c4c7b1..733c05f57f4 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -366,27 +366,26 @@ module E = struct let map_jsx_props sub props = props |> List.map (function - | JSXPropPunning (is_optional, name) -> - let ident = - Exp.ident ~loc:name.loc - {txt = Longident.Lident name.txt; loc = name.loc} - in - let label = - if is_optional then Asttypes.Noloc.Optional name.txt - else Asttypes.Noloc.Labelled name.txt - in - (label, ident) - | JSXPropValue (name, is_optional, value) -> - let label = - if is_optional then Asttypes.Noloc.Optional name.txt - else Asttypes.Noloc.Labelled name.txt - in - ( label, - sub.expr sub value |> wrap_with_loc_attr jsx_prop_loc_attr name.loc - ) - | JSXPropSpreading (loc, value) -> - ( Asttypes.Noloc.Labelled "_spreadProps", - sub.expr sub value |> wrap_with_loc_attr jsx_spread_loc_attr loc )) + | JSXPropPunning (is_optional, name) -> + let ident = + Exp.ident ~loc:name.loc + {txt = Longident.Lident name.txt; loc = name.loc} + in + let label = + if is_optional then Asttypes.Noloc.Optional name.txt + else Asttypes.Noloc.Labelled name.txt + in + (label, ident) + | JSXPropValue (name, is_optional, value) -> + let label = + if is_optional then Asttypes.Noloc.Optional name.txt + else Asttypes.Noloc.Labelled name.txt + in + ( label, + sub.expr sub value |> wrap_with_loc_attr jsx_prop_loc_attr name.loc ) + | JSXPropSpreading (loc, value) -> + ( Asttypes.Noloc.Labelled "_spreadProps", + sub.expr sub value |> wrap_with_loc_attr jsx_spread_loc_attr loc )) let map_jsx_children sub loc children = match children with diff --git a/compiler/ml/builtin_attributes.ml b/compiler/ml/builtin_attributes.ml index a4d073104b4..453048b3476 100644 --- a/compiler/ml/builtin_attributes.ml +++ b/compiler/ml/builtin_attributes.ml @@ -88,32 +88,32 @@ let rec deprecated_of_attrs_with_migrate = function let reason = fields |> List.find_map (fun field -> - match field with - | { - lid = {txt = Lident "reason"}; - x = {pexp_desc = Pexp_constant (Pconst_string (reason, _))}; - } -> - Some reason - | _ -> None) + match field with + | { + lid = {txt = Lident "reason"}; + x = {pexp_desc = Pexp_constant (Pconst_string (reason, _))}; + } -> + Some reason + | _ -> None) in let migration_template = fields |> List.find_map (fun field -> - match field with - | {lid = {txt = Lident "migrate"}; x = migration_template} -> - Some migration_template - | _ -> None) + match field with + | {lid = {txt = Lident "migrate"}; x = migration_template} -> + Some migration_template + | _ -> None) in let migration_in_pipe_chain_template = fields |> List.find_map (fun field -> - match field with - | { - lid = {txt = Lident "migrateInPipeChain"}; - x = migration_in_pipe_chain_template; - } -> - Some migration_in_pipe_chain_template - | _ -> None) + match field with + | { + lid = {txt = Lident "migrateInPipeChain"}; + x = migration_in_pipe_chain_template; + } -> + Some migration_in_pipe_chain_template + | _ -> None) in (* TODO: Validate and error if expected shape mismatches *) diff --git a/compiler/ml/code_frame.ml b/compiler/ml/code_frame.ml index b14b7007af9..2054b83c0a5 100644 --- a/compiler/ml/code_frame.ml +++ b/compiler/ml/code_frame.ml @@ -153,16 +153,16 @@ let print ~is_warning ~src ~(start_pos : Lexing.position) (end_line_line_end_offset - start_line_line_offset) |> String.split_on_char '\n' |> filter_mapi (fun i line -> - let line_number = i + first_shown_line in - if more_than_5_highlighted_lines then - if line_number = highlight_line_start_line + 2 then - Some (Elided, line) - else if - line_number > highlight_line_start_line + 2 - && line_number < highlight_line_end_line - 1 - then None - else Some (Number line_number, line) - else Some (Number line_number, line)) + let line_number = i + first_shown_line in + if more_than_5_highlighted_lines then + if line_number = highlight_line_start_line + 2 then + Some (Elided, line) + else if + line_number > highlight_line_start_line + 2 + && line_number < highlight_line_end_line - 1 + then None + else Some (Number line_number, line) + else Some (Number line_number, line)) else [] in let leading_space_to_cut = @@ -180,48 +180,47 @@ let print ~is_warning ~src ~(start_pos : Lexing.position) let stripped_lines = lines |> List.map (fun (gutter, line) -> - let new_content = - if String.length line <= leading_space_to_cut then - [{s = ""; start = 0; end_ = 0}] - else - String.sub line leading_space_to_cut - (String.length line - leading_space_to_cut) - |> break_long_line line_width - |> List.mapi (fun i line -> - match gutter with - | Elided -> {s = line; start = 0; end_ = 0} - | Number line_number -> - let highlight_line_start_offset = - start_pos.pos_cnum - start_pos.pos_bol - in - let highlight_line_end_offset = - end_pos.pos_cnum - end_pos.pos_bol - in - let start = - if i = 0 && line_number = highlight_line_start_line - then - highlight_line_start_offset - leading_space_to_cut - else 0 - in - let end_ = - if line_number < highlight_line_start_line then 0 - else if - line_number = highlight_line_start_line - && line_number = highlight_line_end_line - then highlight_line_end_offset - leading_space_to_cut - else if line_number = highlight_line_start_line then - String.length line - else if - line_number > highlight_line_start_line - && line_number < highlight_line_end_line - then String.length line - else if line_number = highlight_line_end_line then - highlight_line_end_offset - leading_space_to_cut - else 0 - in - {s = line; start; end_}) - in - {gutter; content = new_content}) + let new_content = + if String.length line <= leading_space_to_cut then + [{s = ""; start = 0; end_ = 0}] + else + String.sub line leading_space_to_cut + (String.length line - leading_space_to_cut) + |> break_long_line line_width + |> List.mapi (fun i line -> + match gutter with + | Elided -> {s = line; start = 0; end_ = 0} + | Number line_number -> + let highlight_line_start_offset = + start_pos.pos_cnum - start_pos.pos_bol + in + let highlight_line_end_offset = + end_pos.pos_cnum - end_pos.pos_bol + in + let start = + if i = 0 && line_number = highlight_line_start_line then + highlight_line_start_offset - leading_space_to_cut + else 0 + in + let end_ = + if line_number < highlight_line_start_line then 0 + else if + line_number = highlight_line_start_line + && line_number = highlight_line_end_line + then highlight_line_end_offset - leading_space_to_cut + else if line_number = highlight_line_start_line then + String.length line + else if + line_number > highlight_line_start_line + && line_number < highlight_line_end_line + then String.length line + else if line_number = highlight_line_end_line then + highlight_line_end_offset - leading_space_to_cut + else 0 + in + {s = line; start; end_}) + in + {gutter; content = new_content}) in let buf = Buffer.create 100 in let open Color in @@ -258,36 +257,36 @@ let print ~is_warning ~src ~(start_pos : Lexing.position) in stripped_lines |> List.iter (fun {gutter; content} -> - match gutter with - | Elided -> - draw_gutter Dim "."; - add_ch Dim '.'; - add_ch Dim '.'; - add_ch Dim '.'; - add_ch NoColor '\n' - | Number line_number -> - content - |> List.iteri (fun i line -> - let gutter_content = - if i = 0 then string_of_int line_number else "" - in - let gutter_color = - if - i = 0 - && line_number >= highlight_line_start_line - && line_number <= highlight_line_end_line - then if is_warning then Warn else Err - else NoColor - in - draw_gutter gutter_color gutter_content; + match gutter with + | Elided -> + draw_gutter Dim "."; + add_ch Dim '.'; + add_ch Dim '.'; + add_ch Dim '.'; + add_ch NoColor '\n' + | Number line_number -> + content + |> List.iteri (fun i line -> + let gutter_content = + if i = 0 then string_of_int line_number else "" + in + let gutter_color = + if + i = 0 + && line_number >= highlight_line_start_line + && line_number <= highlight_line_end_line + then if is_warning then Warn else Err + else NoColor + in + draw_gutter gutter_color gutter_content; - line.s - |> String.iteri (fun ii ch -> - let c = - if ii >= line.start && ii < line.end_ then - if is_warning then Warn else Err - else NoColor - in - add_ch c ch); - add_ch NoColor '\n')); + line.s + |> String.iteri (fun ii ch -> + let c = + if ii >= line.start && ii < line.end_ then + if is_warning then Warn else Err + else NoColor + in + add_ch c ch); + add_ch NoColor '\n')); Buffer.contents buf diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 4f5eeb0712d..9d1746f4767 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -247,10 +247,10 @@ let in_current_module = function let in_pervasives p = in_current_module p && - try - ignore (Env.find_type p Env.initial_safe_string); - true - with Not_found -> false + try + ignore (Env.find_type p Env.initial_safe_string); + true + with Not_found -> false let is_datatype decl = match decl.type_kind with @@ -3619,7 +3619,7 @@ let rec subtype_rec env trace t1 t2 cstrs = let incompatible_constructor_names = c1_constructor_names |> List.filter (fun name -> - not (List.mem name c2_constructor_names)) + not (List.mem name c2_constructor_names)) in ( trace, t1, @@ -3639,8 +3639,7 @@ let rec subtype_rec env trace t1 t2 cstrs = let constructor_map = Hashtbl.create c1_len in c2 |> List.iteri (fun position (c : Types.constructor_declaration) -> - Hashtbl.add constructor_map (Ident.name c.cd_id) - (c, position)); + Hashtbl.add constructor_map (Ident.name c.cd_id) (c, position)); let field_subtype_violations = c1 |> List.mapi @@ -3956,8 +3955,8 @@ let cyclic_abbrev env id ty = match ty.desc with | Tconstr (p, _tl, _abbrev) -> ( (match p with - | Path.Pident p -> Ident.same p id - | _ -> false) + | Path.Pident p -> Ident.same p id + | _ -> false) || List.memq ty seen || try check_cycle (ty :: seen) (expand_abbrev_opt env ty) with diff --git a/compiler/ml/dict_type_helpers.ml b/compiler/ml/dict_type_helpers.ml index 0f5a807b3d1..f7fc401860f 100644 --- a/compiler/ml/dict_type_helpers.ml +++ b/compiler/ml/dict_type_helpers.ml @@ -34,7 +34,7 @@ let dict_magic_field_name = "dictValuesType" let has_dict_pattern_attribute attrs = attrs |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) -> - txt = "res.dictPattern") + txt = "res.dictPattern") |> Option.is_some let has_dict_attribute attrs = diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 565b2355e0d..0a85e442781 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -238,10 +238,10 @@ module Tycomp_tbl = struct Ext_list.filter keys2 (fun id -> is_local (find_same id tbl2) && - try - ignore (find_same id tbl1); - false - with Not_found -> true) + try + ignore (find_same id tbl1); + false + with Not_found -> true) end module Id_tbl = struct @@ -1704,8 +1704,8 @@ let components_of_functor_appl f env p1 p2 = let sub = Subst.add_module f.fcomp_param p2 Subst.identity in let mty = Subst.modtype sub f.fcomp_res in let comps = - components_of_module ~deprecated:None ~loc:Location.none (*???*) - env Subst.identity p mty + components_of_module ~deprecated:None ~loc:Location.none (*???*) env + Subst.identity p mty in Hashtbl.add f.fcomp_cache p2 comps; comps diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index a57c54fdd8a..619c30a2bfe 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -91,8 +91,8 @@ let type_manifest env ty1 params1 ty2 params2 priv2 = let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in Ctype.equal env true (ty1 :: params1) (row2.row_more :: params2) && (match row1.row_more with - | {desc = Tvar _ | Tconstr _ | Tnil} -> true - | _ -> false) + | {desc = Tvar _ | Tconstr _ | Tnil} -> true + | _ -> false) && let r1, r2, pairs = Ctype.merge_row_fields row1.row_fields row2.row_fields @@ -132,8 +132,8 @@ let type_manifest env ty1 params1 ty2 params2 priv2 = && let fields1, rest1 = Ctype.flatten_fields fi1 in (match rest1 with - | {desc = Tnil | Tvar _ | Tconstr _} -> true - | _ -> false) + | {desc = Tnil | Tvar _ | Tconstr _} -> true + | _ -> false) && let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in miss2 = [] @@ -147,10 +147,10 @@ let type_manifest env ty1 params1 ty2 params2 priv2 = Ctype.equal env true (ty1 :: params1) (ty2 :: params2) || priv2 = Private && - try - check_super - (Ctype.try_expand_once_opt env (Ctype.expand_head env ty1)) - with Ctype.Cannot_expand -> false + try + check_super + (Ctype.try_expand_once_opt env (Ctype.expand_head env ty1)) + with Ctype.Cannot_expand -> false in check_super ty1 diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 7533e6f6a0d..5abfce99543 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2242,9 +2242,9 @@ let check_unused pred casel = | Upartial ps -> ps |> List.filter (fun p -> - not (Variant_type_spread.is_pat_from_variant_spread_attr p)) + not (Variant_type_spread.is_pat_from_variant_spread_attr p)) |> List.iter (fun p -> - Location.prerr_warning p.pat_loc Warnings.Unused_pat) + Location.prerr_warning p.pat_loc Warnings.Unused_pat) | Used -> () with Empty | Not_found | NoGuard -> assert false); diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index d3be38ccb02..c5a280f1433 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -59,8 +59,8 @@ let non_shadowed_pervasive_or_stdlib = function | Pdot (Pident id, s, _pos) as path -> ( (Ident.same id ident_pervasives || Ident.same id ident_stdlib) && - try Path.same path (Env.lookup_type (Lident s) !printing_env) - with Not_found -> true) + try Path.same path (Env.lookup_type (Lident s) !printing_env) + with Not_found -> true) | _ -> false let rec tree_of_path = function @@ -382,8 +382,8 @@ let best_type_path p = while !printing_cont <> [] && - try fst (path_size (get_path ())) > !printing_depth - with Not_found -> true + try fst (path_size (get_path ())) > !printing_depth + with Not_found -> true do printing_cont := List.map snd (Env.run_iter_cont !printing_cont); incr printing_depth @@ -591,8 +591,8 @@ let find_inlined_type name (printing_context : printing_context option) = | Some {inlined_types} -> inlined_types |> List.find_opt (fun inlined_type -> - match inlined_type with - | Record {type_name} -> type_name = name) + match inlined_type with + | Record {type_name} -> type_name = name) (* Disabled in classic mode when printing an unification error *) @@ -1681,8 +1681,8 @@ let print_variant_configuration_issue ppf constructor_names_to_print |> List.iteri (fun index name -> - if index = 0 then () else fprintf ppf ", "; - fprintf ppf "@{%s@}" name); + if index = 0 then () else fprintf ppf ", "; + fprintf ppf "@{%s@}" name); if not_printed_constructor_count > 0 then fprintf ppf " (+%i more)" not_printed_constructor_count; diff --git a/compiler/ml/record_type_spread.ml b/compiler/ml/record_type_spread.ml index 7999921df54..18f921c9667 100644 --- a/compiler/ml/record_type_spread.ml +++ b/compiler/ml/record_type_spread.ml @@ -73,9 +73,9 @@ let substitute_type_vars (type_vars : (string * Types.type_expr) list) let has_type_spread (lbls : Typedtree.label_declaration list) = lbls |> List.exists (fun (l : Typedtree.label_declaration) -> - match l with - | {ld_name = {txt = "..."}} -> true - | _ -> false) + match l with + | {ld_name = {txt = "..."}} -> true + | _ -> false) let extract_type_vars (type_params : Types.type_expr list) (typ : Types.type_expr) = @@ -91,9 +91,9 @@ let extract_type_vars (type_params : Types.type_expr list) let paired_type_vars = List.combine type_params applied_type_vars in paired_type_vars |> List.filter_map (fun (t, applied_tvar) -> - match t.Types.desc with - | Tvar (Some tname) -> Some (tname, applied_tvar) - | _ -> None) + match t.Types.desc with + | Tvar (Some tname) -> Some (tname, applied_tvar) + | _ -> None) else [] let expand_labels_with_type_spreads (env : Env.t) @@ -134,7 +134,7 @@ let expand_labels_with_type_spreads (env : Env.t) ( fst acc @ Ext_list.map fields (fun l -> mk_lbl l ld_type type_vars), snd acc @ Ext_list.map fields (fun l -> - {l with ld_type = substitute_type_vars type_vars l.ld_type}) + {l with ld_type = substitute_type_vars type_vars l.ld_type}) ) rest rest' | _ -> None diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 2613406123c..c034ec5dc13 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -581,18 +581,18 @@ let external_import_needs_adaptation (arg_types : External_arg_spec.params) (return_wrapper : External_ffi_types.return_wrapper) = decl.variadic || (match return_wrapper with - | Return_null_to_opt | Return_null_undefined_to_opt -> true - | Return_unset | Return_identity -> false) + | Return_null_to_opt | Return_null_undefined_to_opt -> true + | Return_unset | Return_identity -> false) || Ext_list.exists arg_types (fun {arg_type; arg_label} -> - (match arg_type with - | Nothing | Extern_unit -> false - | Poly_var_string _ | Poly_var _ | Int _ | Arg_cst _ | Ignore | Unwrap - -> - true) - || - match arg_label with - | Arg_optional -> true - | Arg_label | Arg_empty -> false) + (match arg_type with + | Nothing | Extern_unit -> false + | Poly_var_string _ | Poly_var _ | Int _ | Arg_cst _ | Ignore | Unwrap + -> + true) + || + match arg_label with + | Arg_optional -> true + | Arg_label | Arg_empty -> false) (* [import(f)] where [f]'s binding needs adaptation lowers to @@ -908,8 +908,7 @@ let try_ids = Hashtbl.create 8 let extract_directive_for_fn exp = exp.exp_attributes |> List.find_map (fun ({txt}, payload) -> - if txt = "directive" then Ast_payload.is_single_string payload - else None) + if txt = "directive" then Ast_payload.is_single_string payload else None) let hoisted_function_attr_name = "res.hoistedFunction" diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 14716c6b852..8c01ed30f1c 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -648,16 +648,16 @@ let build_ppat_or_for_variant_spread pat env expected_ty = let synthetic_or_patterns = constructors |> List.map (fun (c : Types.constructor_declaration) -> - Ast_helper.Pat.mk - ~attrs:[Variant_type_spread.mk_pat_from_variant_spread_attr ()] - ~loc:lident.loc - (Ppat_construct - ( Location.mkloc - (Longident.Lident (Ident.name c.cd_id)) - lident.loc, - match c.cd_args with - | Cstr_tuple [] -> None - | _ -> Some (Ast_helper.Pat.any ()) ))) + Ast_helper.Pat.mk + ~attrs:[Variant_type_spread.mk_pat_from_variant_spread_attr ()] + ~loc:lident.loc + (Ppat_construct + ( Location.mkloc + (Longident.Lident (Ident.name c.cd_id)) + lident.loc, + match c.cd_args with + | Cstr_tuple [] -> None + | _ -> Some (Ast_helper.Pat.any ()) ))) |> List.rev in let pat = @@ -4246,9 +4246,9 @@ and type_application ~context total_app env funct (sargs : sargs) : let targs = List.rev !rev_args |> List.map (fun (l, thunk) -> - match thunk with - | None -> (l, None) - | Some f -> (l, Some (f ()))) + match thunk with + | None -> (l, None) + | Some f -> (l, Some (f ()))) in let provided = List.length !ignored + nargs in let newarity = arity - provided in @@ -5170,16 +5170,16 @@ let report_error env loc ppf error = let required_args = args_from_type |> List.filter_map (fun arg -> - match arg with - | Labelled {txt = n} -> Some n - | Optional _ | Nolabel -> None) + match arg with + | Labelled {txt = n} -> Some n + | Optional _ | Nolabel -> None) in let passed_named_args = sargs |> List.filter_map (fun arg -> - match arg with - | Labelled {txt} | Optional {txt} -> Some txt - | Nolabel -> None) + match arg with + | Labelled {txt} | Optional {txt} -> Some txt + | Nolabel -> None) in let missing_required_args = required_args @@ -5190,9 +5190,9 @@ let report_error env loc ppf error = let named_args_of_fn_type = args_from_type |> List.filter_map (fun arg -> - match arg with - | Labelled {txt = n} | Optional {txt = n} -> Some n - | Nolabel -> None) + match arg with + | Labelled {txt = n} | Optional {txt = n} -> Some n + | Nolabel -> None) in let superfluous_args = passed_named_args diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 623e38f24cf..25c193eaa01 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -493,8 +493,7 @@ let transl_declaration ~type_record_as_object env sdecl id = | _, _, {type_kind = Type_variant (constructors, _)} -> constructors |> List.iter (fun (c : Types.constructor_declaration) -> - Hashtbl.add constructors_from_variant_spreads c.cd_id.name - c) + Hashtbl.add constructors_from_variant_spreads c.cd_id.name c) | _ -> ()) | _ -> ()); None) @@ -518,14 +517,14 @@ let transl_declaration ~type_record_as_object env sdecl id = Cstr_tuple (args |> List.map (fun texpr : Typedtree.core_type -> - { - ctyp_attributes = cstr.cd_attributes; - ctyp_loc = cstr.cd_loc; - ctyp_env = env; - ctyp_type = texpr; - ctyp_desc = Ttyp_any; - (* This is fine because the type checker seems to only look at `ctyp_type` for type checking. *) - })) + { + ctyp_attributes = cstr.cd_attributes; + ctyp_loc = cstr.cd_loc; + ctyp_env = env; + ctyp_type = texpr; + ctyp_desc = Ttyp_any; + (* This is fine because the type checker seems to only look at `ctyp_type` for type checking. *) + })) | Cstr_record lbls -> Cstr_record (lbls @@ -1509,15 +1508,15 @@ let transl_type_decl env rec_flag sdecl_list = let inline_types = tdecls |> List.filter (fun tdecl -> - tdecl.typ_attributes - |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) -> - txt = "res.inlineRecordDefinition") - |> Option.is_some) + tdecl.typ_attributes + |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) -> + txt = "res.inlineRecordDefinition") + |> Option.is_some) |> List.filter_map (fun tdecl -> - match tdecl.typ_type.type_kind with - | Type_record (labels, _) -> - Some (Record {type_name = tdecl.typ_name.txt; labels}) - | _ -> None) + match tdecl.typ_type.type_kind with + | Type_record (labels, _) -> + Some (Record {type_name = tdecl.typ_name.txt; labels}) + | _ -> None) in let decls = List.map diff --git a/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml index 36606934f74..2aa704500aa 100644 --- a/compiler/ml/variant_coercion.ml +++ b/compiler/ml/variant_coercion.ml @@ -256,10 +256,10 @@ let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~layout let polyvariant_runtime_representations = row_fields |> List.filter_map (fun (label, (field : Types.row_field)) -> - (* Check that there's no payload in the polyvariant *) - match field with - | Rpresent None -> Some label - | _ -> None) + (* Check that there's no payload in the polyvariant *) + match field with + | Rpresent None -> Some label + | _ -> None) in if List.length polyvariant_runtime_representations <> List.length row_fields then @@ -270,25 +270,25 @@ let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~layout (fun polyvariant_value -> variant_constructors |> List.mapi (fun position (c : Types.constructor_declaration) -> - let constructor_name = Ident.name c.cd_id in - match Variant_runtime.constructor_tag layout position with - | Some (String as_runtime_string) -> - (* `@as("")`, does the configured string match the polyvariant value? *) - as_runtime_string = polyvariant_value - | Some _ -> - (* Any other `@as` can't match since it's by definition not a string *) - false - | None -> ( - (* No `@as` means the runtime representation will be the constructor + let constructor_name = Ident.name c.cd_id in + match Variant_runtime.constructor_tag layout position with + | Some (String as_runtime_string) -> + (* `@as("")`, does the configured string match the polyvariant value? *) + as_runtime_string = polyvariant_value + | Some _ -> + (* Any other `@as` can't match since it's by definition not a string *) + false + | None -> ( + (* No `@as` means the runtime representation will be the constructor name as a string. However, there's a special case with unboxed types where there's a string catch-all case. In that case, any polyvariant will match, since the catch-all case will match any string. *) - match (unboxed, c.cd_args) with - | true, Cstr_tuple [{desc = Tconstr (p, _, _)}] -> - Path.same p Predef.path_string - | _ -> polyvariant_value = constructor_name)) + match (unboxed, c.cd_args) with + | true, Cstr_tuple [{desc = Tconstr (p, _, _)}] -> + Path.same p Predef.path_string + | _ -> polyvariant_value = constructor_name)) |> List.exists Fun.id) polyvariant_runtime_representations then Ok () @@ -302,5 +302,5 @@ let type_is_variant (typ : (Path.t * Path.t * Types.type_declaration) option) = let has_res_pat_variant_spread_attribute attrs = attrs |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) -> - txt = "res.patVariantSpread") + txt = "res.patVariantSpread") |> Option.is_some diff --git a/compiler/ml/variant_type_spread.ml b/compiler/ml/variant_type_spread.ml index a3ba0f00864..08ed7629ce3 100644 --- a/compiler/ml/variant_type_spread.ml +++ b/compiler/ml/variant_type_spread.ml @@ -7,9 +7,9 @@ let mk_pat_from_variant_spread_attr () : Parsetree.attribute = let is_pat_from_variant_spread_attr pat = pat.Typedtree.pat_attributes |> List.exists (fun (a : Parsetree.attribute) -> - match a with - | {txt = "res.patFromVariantSpread"}, PStr [] -> true - | _ -> false) + match a with + | {txt = "res.patFromVariantSpread"}, PStr [] -> true + | _ -> false) type variant_type_spread_error = | CouldNotFindType @@ -105,32 +105,32 @@ let expand_variant_spreads (env : Env.t) (sdecl_list : Parsetree.type_declaration list) = sdecl_list |> List.map (fun (sdecl : Parsetree.type_declaration) -> - match sdecl with - | {ptype_kind = Ptype_variant constructors} -> - let has_spread = ref false in - let all_constructors = Hashtbl.create (List.length constructors) in - constructors - |> List.iter (fun (c : Parsetree.constructor_declaration) -> - if c.pcd_name.txt = "..." then has_spread := true - else Hashtbl.add all_constructors c.pcd_name.txt ()); - if !has_spread = false then sdecl - else - { - sdecl with - ptype_kind = - Ptype_variant - (constructors - |> List.map (map_constructors ~all_constructors ~sdecl env) - |> List.concat); - } - | _ -> sdecl) + match sdecl with + | {ptype_kind = Ptype_variant constructors} -> + let has_spread = ref false in + let all_constructors = Hashtbl.create (List.length constructors) in + constructors + |> List.iter (fun (c : Parsetree.constructor_declaration) -> + if c.pcd_name.txt = "..." then has_spread := true + else Hashtbl.add all_constructors c.pcd_name.txt ()); + if !has_spread = false then sdecl + else + { + sdecl with + ptype_kind = + Ptype_variant + (constructors + |> List.map (map_constructors ~all_constructors ~sdecl env) + |> List.concat); + } + | _ -> sdecl) let constructor_is_from_spread (attrs : Parsetree.attributes) = attrs |> List.exists (fun (a : Parsetree.attribute) -> - match a with - | {txt = "res.constructor_from_spread"}, PStr [] -> true - | _ -> false) + match a with + | {txt = "res.constructor_from_spread"}, PStr [] -> true + | _ -> false) let remove_is_spread_attribute (attr : Parsetree.attribute) = match attr with @@ -152,58 +152,57 @@ let expand_dummy_constructor_args (sdecl_list : Parsetree.type_declaration list) Ptype_variant (c1 |> List.map (fun (c : Parsetree.constructor_declaration) -> - if constructor_is_from_spread c.pcd_attributes then - match - c2 - |> List.find_opt - (fun (cc : Types.constructor_declaration) -> - Ident.name cc.cd_id = c.pcd_name.txt) - with - | None -> c - | Some constructor -> ( - match constructor with - | {cd_args = Cstr_record lbls} -> - { - c with - pcd_attributes = - c.pcd_attributes - |> List.filter remove_is_spread_attribute; - pcd_args = - Pcstr_record - (lbls - |> List.map - (fun (l : Types.label_declaration) -> - { - Parsetree.pld_name = c.pcd_name; - pld_mutable = l.ld_mutable; - pld_loc = l.ld_loc; - pld_attributes = []; - pld_optional = l.ld_optional; - pld_type = - { - ptyp_desc = Ptyp_any; - ptyp_loc = l.ld_loc; - ptyp_attributes = []; - }; - })); - } - | {cd_args = Cstr_tuple args} -> - { - c with - pcd_attributes = - c.pcd_attributes - |> List.filter remove_is_spread_attribute; - pcd_args = - Pcstr_tuple - (args - |> List.map (fun _t -> - { - Parsetree.ptyp_loc = c.pcd_loc; - ptyp_attributes = []; - ptyp_desc = Ptyp_any; - })); - }) - else c)); + if constructor_is_from_spread c.pcd_attributes then + match + c2 + |> List.find_opt + (fun (cc : Types.constructor_declaration) -> + Ident.name cc.cd_id = c.pcd_name.txt) + with + | None -> c + | Some constructor -> ( + match constructor with + | {cd_args = Cstr_record lbls} -> + { + c with + pcd_attributes = + c.pcd_attributes + |> List.filter remove_is_spread_attribute; + pcd_args = + Pcstr_record + (lbls + |> List.map (fun (l : Types.label_declaration) -> + { + Parsetree.pld_name = c.pcd_name; + pld_mutable = l.ld_mutable; + pld_loc = l.ld_loc; + pld_attributes = []; + pld_optional = l.ld_optional; + pld_type = + { + ptyp_desc = Ptyp_any; + ptyp_loc = l.ld_loc; + ptyp_attributes = []; + }; + })); + } + | {cd_args = Cstr_tuple args} -> + { + c with + pcd_attributes = + c.pcd_attributes + |> List.filter remove_is_spread_attribute; + pcd_args = + Pcstr_tuple + (args + |> List.map (fun _t -> + { + Parsetree.ptyp_loc = c.pcd_loc; + ptyp_attributes = []; + ptyp_desc = Ptyp_any; + })); + }) + else c)); } | _ -> sdecl) sdecl_list decls diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index 8a69cf3651b..db326f667e6 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -104,12 +104,12 @@ let make_module_name file_name nested_modules fn_name = let make_props_type_params_tvar named_type_list = named_type_list |> List.filter_map (fun (_isOptional, label, _, loc, _interiorType) -> - if label = "key" then None - else - Some - (Typ.var ~loc - @@ safe_type_from_value - (Labelled {txt = label; loc = Location.none}))) + if label = "key" then None + else + Some + (Typ.var ~loc + @@ safe_type_from_value (Labelled {txt = label; loc = Location.none}) + )) let strip_option core_type = match core_type with @@ -139,23 +139,23 @@ let make_props_type_params ?(strip_explicit_option = false) ?(strip_explicit_nullable_of_ref = false) named_type_list = named_type_list |> List.filter_map (fun (is_optional, label, _, loc, interior_type) -> - if label = "key" then None - (* TODO: Worth thinking how about "ref_" or "_ref" usages *) - else if label = "ref" then - (* + if label = "key" then + None (* TODO: Worth thinking how about "ref_" or "_ref" usages *) + else if label = "ref" then + (* If ref has a type annotation then use it, else 'ref. For example, if JSX ppx is used for React Native, type would be different. *) - match interior_type with - | {ptyp_desc = Ptyp_any} -> Some (ref_type_var loc) - | _ -> - if strip_explicit_nullable_of_ref then strip_nullable interior_type - else Some interior_type - (* Strip the explicit option type in implementation *) - (* let make = (~x: option=?) => ... *) - else if is_optional && strip_explicit_option then - strip_option interior_type - else Some interior_type) + match interior_type with + | {ptyp_desc = Ptyp_any} -> Some (ref_type_var loc) + | _ -> + if strip_explicit_nullable_of_ref then strip_nullable interior_type + else Some interior_type + (* Strip the explicit option type in implementation *) + (* let make = (~x: option=?) => ... *) + else if is_optional && strip_explicit_option then + strip_option interior_type + else Some interior_type) let make_label_decls named_type_list = let rec check_duplicated_label l = @@ -176,17 +176,16 @@ let make_label_decls named_type_list = named_type_list |> List.map (fun (is_optional, label, attrs, loc, interior_type) -> - if label = "key" then - Type.field ~loc ~attrs ~optional:true {txt = label; loc} - interior_type - else if is_optional then - Type.field ~loc ~attrs ~optional:true {txt = label; loc} - (Typ.var @@ safe_type_from_value - @@ Labelled {txt = label; loc = Location.none}) - else - Type.field ~loc ~attrs {txt = label; loc} - (Typ.var @@ safe_type_from_value - @@ Labelled {txt = label; loc = Location.none})) + if label = "key" then + Type.field ~loc ~attrs ~optional:true {txt = label; loc} interior_type + else if is_optional then + Type.field ~loc ~attrs ~optional:true {txt = label; loc} + (Typ.var @@ safe_type_from_value + @@ Labelled {txt = label; loc = Location.none}) + else + Type.field ~loc ~attrs {txt = label; loc} + (Typ.var @@ safe_type_from_value + @@ Labelled {txt = label; loc = Location.none})) let make_type_decls ~attrs props_name loc named_type_list = let label_decl_list = make_label_decls named_type_list in @@ -362,7 +361,7 @@ let arg_to_type types let has_default_value name_arg_list = name_arg_list |> List.exists (fun (name, default, _, _, _, _) -> - Option.is_some default && is_optional name) + Option.is_some default && is_optional name) let arg_to_concrete_type types (name, attrs, loc, type_) = match name with @@ -764,13 +763,13 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = let nolabel_params = patterns_with_nolabel |> List.rev_map (fun (_, pattern, _opt) -> - let pattern = - match pattern.ppat_desc with - | Ppat_var {txt} when txt = "ref" -> - Pat.constraint_ pattern (ref_type Location.none) - | _ -> pattern - in - Exp.fun_param Nolabel pattern) + let pattern = + match pattern.ppat_desc with + | Ppat_var {txt} when txt = "ref" -> + Pat.constraint_ pattern (ref_type Location.none) + | _ -> pattern + in + Exp.fun_param Nolabel pattern) in (* ({a, b, _}: props<'a, 'b>) *) let record_pattern = @@ -1149,10 +1148,10 @@ let mk_record_from_props mapper (jsx_expr_loc : Location.t) (props : jsx_props) let props = props |> List.filter (function - | JSXPropPunning (_, {txt = "key"}) | JSXPropValue ({txt = "key"}, _, _) - -> - false - | _ -> true) + | JSXPropPunning (_, {txt = "key"}) | JSXPropValue ({txt = "key"}, _, _) + -> + false + | _ -> true) in let props, spread_props = match props with @@ -1164,23 +1163,23 @@ let mk_record_from_props mapper (jsx_expr_loc : Location.t) (props : jsx_props) let record_fields = props |> List.map (function - | JSXPropPunning (is_optional, name) -> - { - lid = {txt = Lident name.txt; loc = name.loc}; - x = Exp.ident ~loc:name.loc {txt = Lident name.txt; loc = name.loc}; - opt = is_optional; - } - | JSXPropValue (name, is_optional, value) -> - { - lid = {txt = Lident name.txt; loc = name.loc}; - x = mapper.expr mapper value; - opt = is_optional; - } - | JSXPropSpreading (loc, _) -> - (* There can only be one spread expression and it is expected to be the first prop *) - Jsx_common.raise_error ~loc - "JSX: use {...p} {x: v} not {x: v} {...p} \n\ - \ multiple spreads {...p} {...p} not allowed.") + | JSXPropPunning (is_optional, name) -> + { + lid = {txt = Lident name.txt; loc = name.loc}; + x = Exp.ident ~loc:name.loc {txt = Lident name.txt; loc = name.loc}; + opt = is_optional; + } + | JSXPropValue (name, is_optional, value) -> + { + lid = {txt = Lident name.txt; loc = name.loc}; + x = mapper.expr mapper value; + opt = is_optional; + } + | JSXPropSpreading (loc, _) -> + (* There can only be one spread expression and it is expected to be the first prop *) + Jsx_common.raise_error ~loc + "JSX: use {...p} {x: v} not {x: v} {...p} \n\ + \ multiple spreads {...p} {...p} not allowed.") in match (record_fields, spread_props) with | [], Some spread_props -> @@ -1195,13 +1194,13 @@ let mk_record_from_props mapper (jsx_expr_loc : Location.t) (props : jsx_props) let try_find_key_prop (props : jsx_props) : (arg_label * expression) option = props |> List.find_map (function - | JSXPropPunning (is_optional, ({txt = "key"} as name)) -> - let arg_label = if is_optional then Optional name else Labelled name in - Some (arg_label, Exp.ident {txt = Lident "key"; loc = name.loc}) - | JSXPropValue (({txt = "key"} as name), is_optional, expr) -> - let arg_label = if is_optional then Optional name else Labelled name in - Some (arg_label, expr) - | _ -> None) + | JSXPropPunning (is_optional, ({txt = "key"} as name)) -> + let arg_label = if is_optional then Optional name else Labelled name in + Some (arg_label, Exp.ident {txt = Lident "key"; loc = name.loc}) + | JSXPropValue (({txt = "key"} as name), is_optional, expr) -> + let arg_label = if is_optional then Optional name else Labelled name in + Some (arg_label, expr) + | _ -> None) let append_children_prop (config : Jsx_common.jsx_config) mapper (component_description : component_description) (props : jsx_props) diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 3d8c0c6e9e4..66f3e5f71f2 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -372,12 +372,12 @@ let fun_expr expr = looks up when printing a "type a b" group. *) newtypes |> List.map (fun ((name : string Location.loc), attrs) -> - (attrs, Asttypes.Nolabel, None, Ast_helper.Pat.var ~loc:name.loc name)) + (attrs, Asttypes.Nolabel, None, Ast_helper.Pat.var ~loc:name.loc name)) in let params_of params = params |> List.map (fun {p_attrs; p_lbl; p_default; p_pat} -> - (p_attrs, p_lbl, p_default, p_pat)) + (p_attrs, p_lbl, p_default, p_pat)) in (* Comments are attached by walking the parameters in source order, so the newtype groups are interleaved back at their original positions. *) @@ -985,13 +985,13 @@ and walk_expression expr t comments = walk_list (arguments |> List.map (fun (lbl, expr) -> - let loc = - match lbl with - | Asttypes.Labelled {loc} | Optional {loc} -> - {loc with loc_end = expr.Parsetree.pexp_loc.loc_end} - | _ -> expr.pexp_loc - in - ExprArgument {expr; loc})) + let loc = + match lbl with + | Asttypes.Labelled {loc} | Optional {loc} -> + {loc with loc_end = expr.Parsetree.pexp_loc.loc_end} + | _ -> expr.pexp_loc + in + ExprArgument {expr; loc})) t rest in match expr.Parsetree.pexp_desc with diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 27cd06ae2cd..e2300349e38 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -42,9 +42,9 @@ let inline_type_name_exists inline_types_context inline_type_name = let inline_type_param_exists params param_name = params |> List.exists (fun (param, _) -> - match param.Parsetree.ptyp_desc with - | Ptyp_var existing_name -> existing_name = param_name - | _ -> false) + match param.Parsetree.ptyp_desc with + | Ptyp_var existing_name -> existing_name = param_name + | _ -> false) let maybe_track_inline_type_param inline_types_context name loc = match inline_types_context with @@ -523,8 +523,8 @@ let recover_keyword_field_name_if_probably_field p ~mk_message : if Token.is_keyword p.Parser.token && Parser.lookahead p (fun st -> - Parser.next st; - st.Parser.token = Colon) + Parser.next st; + st.Parser.token = Colon) then ( emit_keyword_field_error p ~mk_message; let loc = mk_loc p.Parser.start_pos p.Parser.end_pos in @@ -905,7 +905,7 @@ let read_jsx_tag_name (p : Parser.t) : | Some (_, _, `Lower) -> read_local_jsx_name p |> Option.map (fun (name, loc, _) -> - {Location.txt = Parsetree.JsxLowerTag name; loc}) + {Location.txt = Parsetree.JsxLowerTag name; loc}) |> Option.to_result ~none:"" | Some (first_seg, first_loc, `Upper) -> let start_pos = first_loc.Location.loc_start in @@ -2883,11 +2883,11 @@ and parse_jsx_opening_or_self_closing_element (* start of the opening < *) let closing_tag = closing_tag_start |> Option.map (fun closing_tag_start -> - { - Parsetree.jsx_closing_container_tag_start = closing_tag_start; - jsx_closing_container_tag_name = end_tag_name; - jsx_closing_container_tag_end = closing_tag_end; - }) + { + Parsetree.jsx_closing_container_tag_start = closing_tag_start; + jsx_closing_container_tag_name = end_tag_name; + jsx_closing_container_tag_end = closing_tag_end; + }) in Ast_helper.Exp.jsx_container_element ~loc name jsx_props opening_tag_end children closing_tag @@ -2924,11 +2924,11 @@ and parse_jsx_opening_or_self_closing_element (* start of the opening < *) let closing_tag = closing_tag_start |> Option.map (fun closing_tag_start -> - { - Parsetree.jsx_closing_container_tag_start = closing_tag_start; - jsx_closing_container_tag_name = end_tag_name; - jsx_closing_container_tag_end = closing_tag_end; - }) + { + Parsetree.jsx_closing_container_tag_start = closing_tag_start; + jsx_closing_container_tag_name = end_tag_name; + jsx_closing_container_tag_end = closing_tag_end; + }) in Ast_helper.Exp.jsx_container_element ~loc:(mk_loc start_pos p.prev_end_pos) @@ -4641,12 +4641,11 @@ and parse_atomic_typ_expr ?current_type_name_path ?inline_types_context ~attrs p let inline_types = inline_types_context.found_inline_types in args |> List.filter (fun (c : Parsetree.core_type) -> - match c.ptyp_desc with - | Ptyp_constr ({txt = Lident typename}, _) -> - inline_types - |> List.exists (fun inline_type -> - inline_type.name = typename) - | _ -> false) + match c.ptyp_desc with + | Ptyp_constr ({txt = Lident typename}, _) -> + inline_types + |> List.exists (fun inline_type -> inline_type.name = typename) + | _ -> false) |> List.length in if number_of_inline_records_in_args > 1 then @@ -6527,10 +6526,10 @@ and parse_type_definition_or_extension ~attrs p = let inline_types = inline_types_context.found_inline_types |> List.map (fun inline_type -> - Ast_helper.Type.mk ~params:inline_type.params - ~attrs:[(Location.mknoloc "res.inlineRecordDefinition", PStr [])] - ~loc:inline_type.loc ~kind:inline_type.kind - {name with txt = inline_type.name}) + Ast_helper.Type.mk ~params:inline_type.params + ~attrs:[(Location.mknoloc "res.inlineRecordDefinition", PStr [])] + ~loc:inline_type.loc ~kind:inline_type.kind + {name with txt = inline_type.name}) in TypeDef {rec_flag; types = inline_types @ type_defs} @@ -6571,11 +6570,10 @@ and parse_external_def ~attrs ~start_pos p = let inline_types = inline_types_context.found_inline_types |> List.rev_map (fun inline_type -> - Ast_helper.Type.mk ~params:inline_type.params - ~attrs: - [(Location.mknoloc "res.inlineRecordDefinition", PStr [])] - ~loc:inline_type.loc ~kind:inline_type.kind - {name with txt = inline_type.name}) + Ast_helper.Type.mk ~params:inline_type.params + ~attrs:[(Location.mknoloc "res.inlineRecordDefinition", PStr [])] + ~loc:inline_type.loc ~kind:inline_type.kind + {name with txt = inline_type.name}) |> List.rev in (vb, inline_types)) diff --git a/compiler/syntax/src/res_outcome_printer.ml b/compiler/syntax/src/res_outcome_printer.ml index ea217dde67c..a35eac36868 100644 --- a/compiler/syntax/src/res_outcome_printer.ml +++ b/compiler/syntax/src/res_outcome_printer.ml @@ -513,15 +513,15 @@ let print_external_module_doc (emn : External_ffi_types.external_module_name) = let with_fields = import_attributes |> List.map (fun (k, v) -> - (* digestion stores the source key [type_] as [type]; other + (* digestion stores the source key [type_] as [type]; other keys are stored as written, including exotic ones from escaped idents (\"some-identifier"), which must print escaped again to be writable source *) - let key = - if k = "type" then Doc.text "type_" - else Res_printer.print_ident_like k - in - Doc.concat [key; Doc.text ": "; print_string_literal_doc v]) + let key = + if k = "type" then Doc.text "type_" + else Res_printer.print_ident_like k + in + Doc.concat [key; Doc.text ": "; print_string_literal_doc v]) in Doc.concat [ diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 083c8b3a4e2..148a6ce63b9 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -48,13 +48,13 @@ let has_res_pat_variant_spread_attribute attrs = let has_dict_pattern_attribute attrs = attrs |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) -> - txt = "res.dictPattern") + txt = "res.dictPattern") |> Option.is_some let has_dict_spread_attribute attrs = attrs |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) -> - txt = "res.dictSpread") + txt = "res.dictSpread") |> Option.is_some type dict_expr_part = diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 710674d8327..e5b90e4d884 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -43,8 +43,8 @@ let add_async doc = Doc.concat [Doc.text "async "; doc] let has_inline_type_definitions type_declarations = type_declarations |> List.find_opt (fun (td : Parsetree.type_declaration) -> - Res_parsetree_viewer.has_inline_record_definition_attribute - td.ptype_attributes) + Res_parsetree_viewer.has_inline_record_definition_attribute + td.ptype_attributes) |> Option.is_some let get_first_leading_comment tbl loc = @@ -468,8 +468,8 @@ let is_valid_numeric_polyvar_number (x : string) = if len > 1 then a > 48 && for_all_from x 1 (function - | '0' .. '9' -> true - | _ -> false) + | '0' .. '9' -> true + | _ -> false) else a >= 48 (* Exotic identifiers in poly-vars have a "lighter" syntax: #"ease-in" *) @@ -500,7 +500,7 @@ let find_inline_record_definition inline_record_name | Some inline_record_definitions -> inline_record_definitions |> List.find_opt (fun (r : Parsetree.type_declaration) -> - r.ptype_name.txt = inline_record_name) + r.ptype_name.txt = inline_record_name) let pending_inline_record_definitions inline_record_definitions = let external_name_of_type_declaration @@ -1281,8 +1281,8 @@ and print_type_declarations ~state ~rec_flag type_declarations cmt_tbl = let inline_record_definitions, regular_declarations = type_declarations |> List.partition (fun (td : Parsetree.type_declaration) -> - Res_parsetree_viewer.has_inline_record_definition_attribute - td.ptype_attributes) + Res_parsetree_viewer.has_inline_record_definition_attribute + td.ptype_attributes) in match regular_declarations with | [] -> ( @@ -2347,10 +2347,10 @@ and print_value_binding ~state ~rec_flag (vb : Parsetree.value_binding) cmt_tbl let attrs = vb.pvb_attributes |> List.filter_map (function - | {Asttypes.txt = "let.unwrap"}, _ -> - has_unwrap := true; - None - | attr -> Some attr) + | {Asttypes.txt = "let.unwrap"}, _ -> + has_unwrap := true; + None + | attr -> Some attr) in let attrs = print_attributes ~state ~loc:vb.pvb_pat.ppat_loc attrs cmt_tbl in let header = @@ -5009,9 +5009,9 @@ and print_jsx_children ~state (children : Parsetree.jsx_children) cmt_tbl = let braces = expr.pexp_attributes |> List.find_map (fun (attr, _) -> - match attr with - | {Location.txt = "res.braces"; loc} -> Some loc - | _ -> None) + match attr with + | {Location.txt = "res.braces"; loc} -> Some loc + | _ -> None) in match braces with | None -> expr.pexp_loc diff --git a/dune-project b/dune-project index 7f958407683..62d10fe7776 100644 --- a/dune-project +++ b/dune-project @@ -29,7 +29,7 @@ (ppx_gen_rec :build) wtf8 (ocamlformat - (and :with-test (= 0.27.0))) + (and :with-test (= 0.29.0))) (yojson (= 3.0.0)) (ounit2 diff --git a/rescript.opam b/rescript.opam index a800542d7b7..8142f5f25c3 100644 --- a/rescript.opam +++ b/rescript.opam @@ -14,7 +14,7 @@ depends: [ "ppx_deriving" {build} "ppx_gen_rec" {build} "wtf8" - "ocamlformat" {with-test & = "0.27.0"} + "ocamlformat" {with-test & = "0.29.0"} "yojson" {= "3.0.0"} "ounit2" {with-test & = "2.2.7"} "odoc" {with-doc} diff --git a/tests/ounit_tests/ounit_hash_stubs_test.ml b/tests/ounit_tests/ounit_hash_stubs_test.ml index d22062006cf..efa709cc399 100644 --- a/tests/ounit_tests/ounit_hash_stubs_test.ml +++ b/tests/ounit_tests/ounit_hash_stubs_test.ml @@ -20,7 +20,7 @@ let suites = ( __LOC__ >:: fun _ -> Array.init 100 (fun i -> String.make i 'a') |> Array.iter (fun x -> - Ext_platform_primitives.hash_string x =~ Hashtbl.hash x) ); + Ext_platform_primitives.hash_string x =~ Hashtbl.hash x) ); ( __LOC__ >:: fun _ -> (* only string matters here *) hash {stamp = 0; name = "Pervasives"; flags = 0} diff --git a/tests/ounit_tests/ounit_scc_tests.ml b/tests/ounit_tests/ounit_scc_tests.ml index fc1f626db2d..36688cb818a 100644 --- a/tests/ounit_tests/ounit_scc_tests.ml +++ b/tests/ounit_tests/ounit_scc_tests.ml @@ -243,10 +243,10 @@ let test (input : (string * string list) list) = let node_array = Array.init nodes_num (fun _ -> Vec_int.empty ()) in input |> List.iter (fun (x, others) -> - let idx = String_hash.find_exn tbl x in - others - |> List.iter (fun y -> - Vec_int.push node_array.(idx) (String_hash.find_exn tbl y))); + let idx = String_hash.find_exn tbl x in + others + |> List.iter (fun y -> + Vec_int.push node_array.(idx) (String_hash.find_exn tbl y))); Ext_scc.graph_check node_array let test2 (input : (string * string list) list) = @@ -267,14 +267,14 @@ let test2 (input : (string * string list) list) = let node_array = Array.init nodes_num (fun _ -> Vec_int.empty ()) in input |> List.iter (fun (x, others) -> - let idx = String_hash.find_exn tbl x in - others - |> List.iter (fun y -> - Vec_int.push node_array.(idx) (String_hash.find_exn tbl y))); + let idx = String_hash.find_exn tbl x in + others + |> List.iter (fun y -> + Vec_int.push node_array.(idx) (String_hash.find_exn tbl y))); let output = Ext_scc.graph node_array in output |> Int_vec_vec.map_into_array (fun int_vec -> - Vec_int.map_into_array (fun i -> other_mapping.(i)) int_vec) + Vec_int.map_into_array (fun i -> other_mapping.(i)) int_vec) let suites = __FILE__ diff --git a/tests/syntax_benchmarks/benchmark.ml b/tests/syntax_benchmarks/benchmark.ml index 53370e4a138..2c890a8ccb8 100644 --- a/tests/syntax_benchmarks/benchmark.ml +++ b/tests/syntax_benchmarks/benchmark.ml @@ -206,27 +206,27 @@ end = struct let run () = List.to_seq specs |> Seq.flat_map (fun spec -> - let filename, action = spec in - let test_name = string_of_action action ^ " " ^ filename in - let {Benchmark.ms_per_run; allocs_per_run} = benchmark spec in - [ - `Assoc - [ - ("name", `String (Format.sprintf "%s - time/run" test_name)); - ("unit", `String "ms"); - ("value", `Float ms_per_run); - ]; - `Assoc - [ - ("name", `String (Format.sprintf "%s - allocs/run" test_name)); - ("unit", `String "words"); - ("value", `Int allocs_per_run); - ]; - ] - |> List.to_seq) + let filename, action = spec in + let test_name = string_of_action action ^ " " ^ filename in + let {Benchmark.ms_per_run; allocs_per_run} = benchmark spec in + [ + `Assoc + [ + ("name", `String (Format.sprintf "%s - time/run" test_name)); + ("unit", `String "ms"); + ("value", `Float ms_per_run); + ]; + `Assoc + [ + ("name", `String (Format.sprintf "%s - allocs/run" test_name)); + ("unit", `String "words"); + ("value", `Int allocs_per_run); + ]; + ] + |> List.to_seq) |> Seq.iteri (fun i json -> - print_endline (if i == 0 then "[" else ","); - print_string (Yojson.to_string json)); + print_endline (if i == 0 then "[" else ","); + print_string (Yojson.to_string json)); print_newline (); print_endline "]" end diff --git a/tools/bin/main.ml b/tools/bin/main.ml index 0028d802563..763d29e51f6 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -97,12 +97,12 @@ let main () = let files = module_names |> List.filter_map (fun mod_name -> - Hashtbl.find_opt package.paths_for_module mod_name - |> Option.map Analysis.Shared_types.get_src) + Hashtbl.find_opt package.paths_for_module mod_name + |> Option.map Analysis.Shared_types.get_src) |> List.concat |> List.filter (fun path -> - Filename.check_suffix path ".res" - || Filename.check_suffix path ".resi") + Filename.check_suffix path ".res" + || Filename.check_suffix path ".resi") in let total = List.length files in if total = 0 then log_and_exit (Ok "No source files found to migrate") diff --git a/tools/src/migrate.ml b/tools/src/migrate.ml index bfbb9f38783..db6e8f42fc9 100644 --- a/tools/src/migrate.ml +++ b/tools/src/migrate.ml @@ -85,9 +85,9 @@ module Mapper_utils = struct ] -> elems |> List.filter_map (fun (e : Parsetree.expression) -> - match e.pexp_desc with - | Pexp_constant (Pconst_string (s, _)) -> Some s - | _ -> None) + match e.pexp_desc with + | Pexp_constant (Pconst_string (s, _)) -> Some s + | _ -> None) | _ -> [] let apply_names (names : string list) (e : Parsetree.expression) : @@ -151,12 +151,12 @@ module Mapper_utils = struct let idx = ref 0 in source_args |> List.iter (fun (lbl, arg) -> - match lbl with - | Asttypes.Nolabel -> - Hashtbl.replace unlabelled !idx arg; - incr idx - | Asttypes.Labelled {txt} | Optional {txt} -> - Hashtbl.replace labelled txt arg); + match lbl with + | Asttypes.Nolabel -> + Hashtbl.replace unlabelled !idx arg; + incr idx + | Asttypes.Labelled {txt} | Optional {txt} -> + Hashtbl.replace labelled txt arg); (labelled, unlabelled) (* Replace placeholders anywhere inside an expression using the given @@ -190,11 +190,11 @@ module Mapper_utils = struct let build_labelled_args_map (template_args : args) = template_args |> List.filter_map (fun (label, arg) -> - match (label, Insert_ext.placeholder_of_expr arg) with - | ( (Asttypes.Labelled {txt = label} | Optional {txt = label}), - Some (Insert_ext.Labelled arg_name) ) -> - Some (arg_name, label) - | _ -> None) + match (label, Insert_ext.placeholder_of_expr arg) with + | ( (Asttypes.Labelled {txt = label} | Optional {txt = label}), + Some (Insert_ext.Labelled arg_name) ) -> + Some (arg_name, label) + | _ -> None) |> List.fold_left (fun map (k, v) -> String_map.add k v map) String_map.empty @@ -273,16 +273,16 @@ module Mapper_utils = struct let rename_labels (source_args : args) ~labelled_args_map = source_args |> List.map (fun (label, arg) -> - match label with - | Asttypes.Labelled ({loc; txt} as l) -> ( - 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 String_map.find_opt txt labelled_args_map with - | Some mapped -> (Optional {loc; txt = mapped}, arg) - | None -> (Optional l, arg)) - | _ -> (label, arg)) + match label with + | Asttypes.Labelled ({loc; txt} as l) -> ( + 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 String_map.find_opt txt labelled_args_map with + | Some mapped -> (Optional {loc; txt = mapped}, arg) + | None -> (Optional l, arg)) + | _ -> (label, arg)) let apply_migration_template mapper (template_args : args) (source_args : args) = @@ -555,47 +555,47 @@ let make_mapper (deprecated_used : Cmt_utils.deprecated_used list) = let deprecated_function_calls = deprecated_used |> List.filter (fun (d : Cmt_utils.deprecated_used) -> - match d.context with - | Some FunctionCall -> true - | _ -> false) + match d.context with + | Some FunctionCall -> true + | _ -> false) in let loc_to_deprecated_fn_call = Hashtbl.create (List.length deprecated_function_calls) in deprecated_function_calls |> List.iter (fun ({Cmt_utils.source_loc} as d) -> - Hashtbl.replace loc_to_deprecated_fn_call source_loc d); + Hashtbl.replace loc_to_deprecated_fn_call source_loc d); let deprecated_references = deprecated_used |> List.filter (fun (d : Cmt_utils.deprecated_used) -> - match d.context with - | Some Reference -> true - | _ -> false) + match d.context with + | Some Reference -> true + | _ -> false) in let loc_to_deprecated_reference = Hashtbl.create (List.length deprecated_references) in deprecated_references |> List.iter (fun ({Cmt_utils.source_loc} as d) -> - Hashtbl.replace loc_to_deprecated_reference source_loc d); + Hashtbl.replace loc_to_deprecated_reference source_loc d); let deprecated_constructor_constructors = deprecated_used |> List.filter_map (fun (d : Cmt_utils.deprecated_used) -> - match d.migration_template with - | Some template -> ( - match Constructor_replace.of_template template with - | Some target -> Some (d.source_loc, target) - | None -> None) - | None -> None) + match d.migration_template with + | Some template -> ( + match Constructor_replace.of_template template with + | Some target -> Some (d.source_loc, target) + | None -> None) + | None -> None) in let loc_to_deprecated_constructor_constructor = Hashtbl.create (List.length deprecated_constructor_constructors) in deprecated_constructor_constructors |> List.iter (fun (loc, target) -> - Hashtbl.replace loc_to_deprecated_constructor_constructor loc target); + Hashtbl.replace loc_to_deprecated_constructor_constructor loc target); let find_constructor_target ~loc ~lid_loc = match Hashtbl.find_opt loc_to_deprecated_constructor_constructor loc with @@ -616,20 +616,20 @@ let make_mapper (deprecated_used : Cmt_utils.deprecated_used list) = (Cmt_utils.deprecated_used * Parsetree.core_type) list = deprecated_used |> List.filter_map (fun (d : Cmt_utils.deprecated_used) -> - match d.migration_template with - | Some e -> ( - match Type_replace.core_type_of_expr_extension e with - | Some ct -> Some (d, ct) - | None -> None) - | None -> None) + match d.migration_template with + | Some e -> ( + match Type_replace.core_type_of_expr_extension e with + | Some ct -> Some (d, ct) + | None -> None) + | None -> None) in let find_type_replace_template (loc : Location.t) : Parsetree.core_type option = type_replace_deprecations |> List.find_map (fun ((d : Cmt_utils.deprecated_used), ct) -> - if loc_contains loc d.source_loc || loc_contains d.source_loc loc - then Some ct - else None) + if loc_contains loc d.source_loc || loc_contains d.source_loc loc then + Some ct + else None) in let mapper = diff --git a/tools/src/tools.ml b/tools/src/tools.ml index f893f81f986..b585908f6ad 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -144,8 +144,8 @@ let rec stringify_type_doc = function and stringify_signature_parameter {label; optional; typ} = `Assoc ((match label with - | Some label -> [("label", `String label)] - | None -> []) + | Some label -> [("label", `String label)] + | None -> []) @ [("optional", `Bool optional); ("type", stringify_type_doc typ)]) and stringify_value_signature {parameters; return_type} = @@ -170,24 +170,24 @@ let stringify_detail (detail : doc_item_detail) = `List (constructor_docs |> List.map (fun constructor_doc -> - `Assoc - ([ - ("name", `String constructor_doc.constructor_name); - ( "docstrings", - stringify_docstrings constructor_doc.docstrings ); - ("signature", `String constructor_doc.signature); - ] - @ (match constructor_doc.deprecated with - | Some d -> [("deprecated", `String d)] - | None -> []) - @ - match constructor_doc.items with - | Some constructor_payload -> - [ - ( "payload", - stringify_constructor_payload constructor_payload ); - ] - | None -> []))) ); + `Assoc + ([ + ("name", `String constructor_doc.constructor_name); + ( "docstrings", + stringify_docstrings constructor_doc.docstrings ); + ("signature", `String constructor_doc.signature); + ] + @ (match constructor_doc.deprecated with + | Some d -> [("deprecated", `String d)] + | None -> []) + @ + match constructor_doc.items with + | Some constructor_payload -> + [ + ( "payload", + stringify_constructor_payload constructor_payload ); + ] + | None -> []))) ); ] | Signature {parameters; return_type} -> `Assoc @@ -325,22 +325,19 @@ let type_detail typ ~env ~full ~state = constructor_docs = constructors |> List.map (fun (c : Constructor.t) -> - { - constructor_name = c.cname.txt; - docstrings = c.docstring; - signature = Completion_back_end.show_constructor c; - deprecated = c.deprecated; - items = - (match c.args with - | InlineRecord fields -> - Some - (InlineRecord - { - field_docs = - fields |> List.map field_to_field_doc; - }) - | _ -> None); - }); + { + constructor_name = c.cname.txt; + docstrings = c.docstring; + signature = Completion_back_end.show_constructor c; + deprecated = c.deprecated; + items = + (match c.args with + | InlineRecord fields -> + Some + (InlineRecord + {field_docs = fields |> List.map field_to_field_doc}) + | _ -> None); + }); }) | _ -> None @@ -467,149 +464,148 @@ let extract_docs ~entry_point_file ~debug = items = structure.items |> List.filter_map (fun (item : Module.item) -> - let item = - { - item with - name = Ext_ident.unwrap_uppercase_exotic item.name; - } - in - let source = get_source ~root_path item.loc in - match item.kind with - | Value typ -> - Some - (Value - { - id = module_path |> make_id ~identifier:item.name; - docstring = item.docstring |> List.map String.trim; - signature = - "let " ^ item.name ^ ": " - ^ Shared.type_to_string typ; - name = item.name; - deprecated = item.deprecated; - detail = value_detail typ; - source; - }) - | Type (typ, _) -> - Some - (Type - { - id = module_path |> make_id ~identifier:item.name; - docstring = item.docstring |> List.map String.trim; - signature = - typ.decl |> Shared.decl_to_string item.name; - name = item.name; - deprecated = item.deprecated; - detail = type_detail typ ~full ~env ~state; - source; - }) - | Module {type_ = Ident p; is_module_type = false} -> - (* module Whatever = OtherModule *) - let alias_to_module = p |> path_ident_to_string in - let id = - (module_path |> List.rev |> List.hd) ^ "." ^ item.name - in - let items, internal_docstrings = - match - Process_cmt.file_for_module ~package:full.package - ~state alias_to_module - with - | None -> ([], []) - | Some file -> - let docs = - extract_docs_for_module ~module_path:[id] - file.structure - in - (docs.items, docs.docstring) - in - Some - (ModuleAlias - { - id; - name = item.name; - source; - items; - docstring = - item.docstring @ internal_docstrings - |> List.map String.trim; - }) - | Module {type_ = Structure m; is_module_type = false} -> - (* module Whatever = {} in res or module Whatever: {} in resi. *) - let module_path = m.name :: module_path in - let docs = extract_docs_for_module ~module_path m in - Some - (Module - { - id = module_path |> List.rev |> ident; - name = m.name; - moduletypeid = None; - docstring = item.docstring @ m.docstring; - deprecated = item.deprecated; - source; - items = docs.items; - }) - | Module {type_ = Structure m; is_module_type = true} -> - (* module type Whatever = {} *) - let module_path = m.name :: module_path in - let docs = extract_docs_for_module ~module_path m in - Some - (ModuleType - { - id = module_path |> List.rev |> ident; - name = m.name; - docstring = item.docstring @ m.docstring; - deprecated = item.deprecated; - source; - items = docs.items; - }) - | Module + let item = + { + item with + name = Ext_ident.unwrap_uppercase_exotic item.name; + } + in + let source = get_source ~root_path item.loc in + match item.kind with + | Value typ -> + Some + (Value { - type_ = - Constraint (Structure _impl, Structure interface); - } -> - (* module Whatever: { } = { }. Prefer the interface. *) - Some - (Module - (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 = - extract_docs_for_module - ~module_path:(m.name :: module_path) m - in - let ident_module_path = p |> Path.head |> Ident.name in + id = module_path |> make_id ~identifier:item.name; + docstring = item.docstring |> List.map String.trim; + signature = + "let " ^ item.name ^ ": " + ^ Shared.type_to_string typ; + name = item.name; + deprecated = item.deprecated; + detail = value_detail typ; + source; + }) + | Type (typ, _) -> + Some + (Type + { + id = module_path |> make_id ~identifier:item.name; + docstring = item.docstring |> List.map String.trim; + signature = + typ.decl |> Shared.decl_to_string item.name; + name = item.name; + deprecated = item.deprecated; + detail = type_detail typ ~full ~env ~state; + source; + }) + | Module {type_ = Ident p; is_module_type = false} -> + (* module Whatever = OtherModule *) + let alias_to_module = p |> path_ident_to_string in + let id = + (module_path |> List.rev |> List.hd) ^ "." ^ item.name + in + let items, internal_docstrings = + match + Process_cmt.file_for_module ~package:full.package ~state + alias_to_module + with + | None -> ([], []) + | Some file -> + let docs = + extract_docs_for_module ~module_path:[id] + file.structure + in + (docs.items, docs.docstring) + in + Some + (ModuleAlias + { + id; + name = item.name; + source; + items; + docstring = + item.docstring @ internal_docstrings + |> List.map String.trim; + }) + | Module {type_ = Structure m; is_module_type = false} -> + (* module Whatever = {} in res or module Whatever: {} in resi. *) + let module_path = m.name :: module_path in + let docs = extract_docs_for_module ~module_path m in + Some + (Module + { + id = module_path |> List.rev |> ident; + name = m.name; + moduletypeid = None; + docstring = item.docstring @ m.docstring; + deprecated = item.deprecated; + source; + items = docs.items; + }) + | Module {type_ = Structure m; is_module_type = true} -> + (* module type Whatever = {} *) + let module_path = m.name :: module_path in + let docs = extract_docs_for_module ~module_path m in + Some + (ModuleType + { + id = module_path |> List.rev |> ident; + name = m.name; + docstring = item.docstring @ m.docstring; + deprecated = item.deprecated; + source; + items = docs.items; + }) + | Module + { + type_ = Constraint (Structure _impl, Structure interface); + } -> + (* module Whatever: { } = { }. Prefer the interface. *) + Some + (Module + (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 = + extract_docs_for_module + ~module_path:(m.name :: module_path) m + in + let ident_module_path = p |> Path.head |> Ident.name in - let module_type_id_path = - match - Process_cmt.file_for_module ~package:full.package - ~state ident_module_path - |> Option.is_none - with - | false -> [] - | true -> [module_path |> List.rev |> List.hd] - in + let module_type_id_path = + match + Process_cmt.file_for_module ~package:full.package ~state + ident_module_path + |> Option.is_none + with + | false -> [] + | true -> [module_path |> List.rev |> List.hd] + in - Some - (Module - { - docs with - moduletypeid = - Some - (make_id ~identifier:(Path.name p) - module_type_id_path); - }) - | _ -> None) + Some + (Module + { + docs with + moduletypeid = + Some + (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 (doc_item : doc_item) -> - match doc_item with - | Value {id} -> - if String_set.mem id !values_seen then None - else ( - values_seen := String_set.add id !values_seen; - Some doc_item) - | _ -> Some doc_item) + match doc_item with + | Value {id} -> + if String_set.mem id !values_seen then None + else ( + values_seen := String_set.add id !values_seen; + Some doc_item) + | _ -> Some doc_item) |> List.rev; } in @@ -656,14 +652,14 @@ let extract_embedded ~extension_points ~filename = let result = !content |> List.map (fun (loc, extension_name, contents) -> - `Assoc - [ - ("extensionName", `String extension_name); - ("contents", `String contents); - ( "loc", - Analysis.Utils.cmt_loc_to_range loc - |> Lsp.Types.Range.yojson_of_t ); - ]) + `Assoc + [ + ("extensionName", `String extension_name); + ("contents", `String contents); + ( "loc", + Analysis.Utils.cmt_loc_to_range loc |> Lsp.Types.Range.yojson_of_t + ); + ]) |> List.rev in Yojson.Safe.pretty_to_string (`List result) @@ -1075,56 +1071,54 @@ module Extract_codeblocks = struct structure.items |> List.iter (fun (item : Module.item) -> - match item.kind with - | Value _typ -> - let id = module_path |> make_id ~identifier:item.name in - let name = item.name in - process_docstrings ~id ~name (get_docstring item.docstring) - | Type (_typ, _) -> - let id = module_path |> make_id ~identifier:item.name in - let name = item.name in - process_docstrings ~id ~name (get_docstring item.docstring) - | Module {type_ = Ident _p; is_module_type = false} -> - (* module Whatever = OtherModule *) - let id = - (module_path |> List.rev |> List.hd) ^ "." ^ item.name - in - let name = item.name in - 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 module_path = m.name :: module_path in - let id = module_path |> List.rev |> ident in - let name = m.name in - 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 module_path = m.name :: module_path in - let id = module_path |> List.rev |> ident in - let name = m.name in - 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 module_path = interface.name :: module_path in - let id = module_path |> List.rev |> ident in - let name = interface.name in - 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 module_path = m.name :: module_path in - let id = module_path |> List.rev |> ident in - let name = m.name in - process_docstrings ~id ~name (get_docstring m.docstring); - extract_code_blocks_for_module ~module_path m - | Module.Module _ -> ()) + match item.kind with + | Value _typ -> + let id = module_path |> make_id ~identifier:item.name in + let name = item.name in + process_docstrings ~id ~name (get_docstring item.docstring) + | Type (_typ, _) -> + let id = module_path |> make_id ~identifier:item.name in + let name = item.name in + process_docstrings ~id ~name (get_docstring item.docstring) + | Module {type_ = Ident _p; is_module_type = false} -> + (* module Whatever = OtherModule *) + let id = + (module_path |> List.rev |> List.hd) ^ "." ^ item.name + in + let name = item.name in + 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 module_path = m.name :: module_path in + let id = module_path |> List.rev |> ident in + let name = m.name in + 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 module_path = m.name :: module_path in + let id = module_path |> List.rev |> ident in + let name = m.name in + 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 module_path = interface.name :: module_path in + let id = module_path |> List.rev |> ident in + let name = interface.name in + 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 module_path = m.name :: module_path in + let id = module_path |> List.rev |> ident in + let name = m.name in + process_docstrings ~id ~name (get_docstring m.docstring); + extract_code_blocks_for_module ~module_path m + | Module.Module _ -> ()) in extract_code_blocks_for_module structure; Ok ()) @@ -1233,11 +1227,11 @@ module Extract_codeblocks = struct Ok (code_blocks |> List.mapi (fun index code_block -> - { - id = "codeblock-" ^ string_of_int (index + 1); - name = "codeblock-" ^ string_of_int (index + 1); - code = code_block; - })) + { + id = "codeblock-" ^ string_of_int (index + 1); + name = "codeblock-" ^ string_of_int (index + 1); + code = code_block; + })) else let extracted = extract_code_blocks ~entry_point_file @@ -1250,16 +1244,16 @@ module Extract_codeblocks = struct 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 = code_block; - }) + add_code_block + { + id = id ^ "-" ^ string_of_int (index + 1); + name; + code = code_block; + }) else code_blocks |> List.iter (fun code_block -> - add_code_block {id; name; code = code_block})) + add_code_block {id; name; code = code_block})) in match extracted with @@ -1279,12 +1273,12 @@ module Extract_codeblocks = struct (`List (code_blocks |> List.map (fun code_block -> - `Assoc - [ - ("id", `String code_block.id); - ("name", `String code_block.name); - ("code", `String code_block.code); - ])))) + `Assoc + [ + ("id", `String code_block.id); + ("name", `String code_block.name); + ("code", `String code_block.code); + ])))) end module Migrate = Migrate