Analysis refactor for #8425

CHANGELOG.md

@@ -69,6 +69,7 @@
 - Refactor analysis CLI helpers to use source input. https://github.com/rescript-lang/rescript/pull/8466
 - Include syntax, gentype, analysis, tools, and reanalyze tests in coverage reports. https://github.com/rescript-lang/rescript/pull/8467
 - Remove the unreachable `Longident.Lapply` constructor (OCaml's applicative-functor path syntax `F(X).t`, which ReScript's grammar cannot produce). https://github.com/rescript-lang/rescript/pull/8469
+- Refactor analysis for server side use. https://github.com/rescript-lang/rescript/pull/8478
 
 # 13.0.0-alpha.4
 

analysis/bin/main.ml

@@ -221,7 +221,7 @@ let main () =
   | [_; "format"; path] -> Cli.format ~path
   | [_; "test"; path] -> Cli.test ~state ~path
   | [_; "cmt"; rescript_json; cmt_path] ->
-    Cmt_viewer.dump ~state rescript_json cmt_path
+    Cli.dump_cmt ~state ~rescript_json ~cmt_path
   | args when List.mem "-h" args || List.mem "--help" args -> prerr_endline help
   | _ ->
     prerr_endline help;

analysis/src/cli.ml

@@ -182,6 +182,25 @@ let create_interface ~path ~cmi_file =
   in
   Printf.printf "%s" result
 
+let dump_cmt ~state ~rescript_json ~cmt_path =
+  let uri = Uri.from_path (Filename.remove_extension cmt_path ^ ".res") in
+  let package =
+    let uri = Uri.from_path rescript_json in
+    Packages.get_package ~state ~uri
+  in
+  match package with
+  | None -> print_null ()
+  | Some package -> (
+    let module_name =
+      Build_system.namespaced_name package.namespace
+        (Find_files.get_name cmt_path)
+    in
+    match Cmt.full_for_cmt ~module_name ~package ~uri cmt_path with
+    | None -> print_null ()
+    | Some full ->
+      let content = Cmt_viewer.dump ~full ~filter_for_position:None in
+      Printf.printf "%s" content)
+
 let test ~state ~path =
   Uri.strip_path := true;
   match Files.read_file path with

analysis/src/cmt_viewer.ml

@@ -14,117 +14,99 @@ let filter_by_cursor cursor (loc : Warnings.loc) : bool =
     in
     line_in && col_in
 
-type filter = Cursor of (int * int) | Loc of Loc.t
-
-let dump ~state ?filter rescript_json cmt_path =
-  let uri = Uri.from_path (Filename.remove_extension cmt_path ^ ".res") in
-  let package =
-    let uri = Uri.from_path rescript_json in
-    Packages.get_package ~state ~uri |> Option.get
-  in
-  let module_name =
-    Build_system.namespaced_name package.namespace
-      (Find_files.get_name cmt_path)
+let dump ~(filter_for_position : (int * int) option) ~full =
+  let open Shared_types in
+  let open Shared_types.Stamps in
+  let buffer = Buffer.create 4096 in
+  let printf fmt = Printf.bprintf buffer fmt in
+  let apply_filter =
+    match filter_for_position with
+    | None -> fun _ -> true
+    | Some cursor -> Loc.has_pos ~pos:cursor
   in
-  match Cmt.full_for_cmt ~module_name ~package ~uri cmt_path with
-  | None -> failwith (Format.sprintf "Could not load cmt for %s" cmt_path)
-  | Some full ->
-    let open Shared_types in
-    let open Shared_types.Stamps in
-    let apply_filter =
-      match filter with
-      | None -> fun _ -> true
-      | Some (Cursor cursor) -> Loc.has_pos ~pos:cursor
-      | Some (Loc loc) -> Loc.is_inside loc
-    in
-    (match filter with
-    | None -> ()
-    | Some (Cursor (line, col)) ->
-      Printf.printf "Filtering by cursor %d,%d\n" line col
-    | Some (Loc loc) ->
-      Printf.printf "Filtering by loc %s\n" (Loc.to_string loc));
+  (match filter_for_position with
+  | None -> ()
+  | Some (line, col) -> printf "Filtering by cursor %d,%d\n" line col);
 
-    Printf.printf "file moduleName: %s\n\n" full.file.module_name;
+  printf "file moduleName: %s\n\n" full.file.module_name;
 
-    let stamps =
-      full.file.stamps |> get_entries
-      |> List.filter (fun (_, stamp) -> apply_filter (loc_of_kind stamp))
-    in
+  let stamps =
+    full.file.stamps |> get_entries
+    |> List.filter (fun (_, stamp) -> apply_filter (loc_of_kind stamp))
+  in
 
-    let total_stamps = List.length stamps in
-    Printf.printf "Found %d stamps:\n%s" total_stamps
-      (if total_stamps > 0 then "\n" else "");
+  let total_stamps = List.length stamps in
+  printf "Found %d stamps:\n%s" total_stamps
+    (if total_stamps > 0 then "\n" else "");
 
-    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)
-    |> List.iter (fun (stamp, kind) ->
-           match kind with
-           | KType t ->
-             Printf.printf "%d ktype        %s\n" stamp
-               (Warnings.loc_to_string t.extent_loc)
-           | KValue t ->
-             Printf.printf "%d kvalue       %s\n" stamp
-               (Warnings.loc_to_string t.extent_loc)
-           | KModule t ->
-             Printf.printf "%d kmodule      %s\n" stamp
-               (Warnings.loc_to_string t.extent_loc)
-           | KConstructor t ->
-             Printf.printf "%d kconstructor %s\n" stamp
-               (Warnings.loc_to_string t.extent_loc));
+  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)
+  |> 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));
 
-    (* dump the structure *)
-    let rec dump_structure indent (structure : Module.structure) =
-      if indent > 0 then Printf.printf "%s" (String.make indent ' ');
-      Printf.printf "Structure %s:\n" structure.name;
-      structure.items |> List.iter (dump_structure_item (indent + 2))
-    and dump_structure_item indent item =
-      if indent > 0 then Printf.printf "%s" (String.make indent ' ');
-      let open Module in
-      match item.kind with
-      | Value _typedExpr ->
-        Printf.printf "Value %s %s\n" item.name
-          (Warnings.loc_to_string item.loc)
-      | Type _ ->
-        Printf.printf "Type %s %s\n" item.name (Warnings.loc_to_string item.loc)
-      | Module {type_ = m} ->
-        Printf.printf "Module %s %s\n" item.name
-          (Warnings.loc_to_string item.loc);
-        dump_module indent m
-    and dump_module indent (module_ : Module.t) =
-      match module_ with
-      | Ident path -> Printf.printf "Module (Ident) %s\n" (Path.name path)
-      | Structure structure -> dump_structure indent structure
-      | Constraint (m1, m2) ->
-        dump_module indent m1;
-        dump_module indent m2
-    in
+  (* dump the structure *)
+  let rec dump_structure indent (structure : Module.structure) =
+    if indent > 0 then printf "%s" (String.make indent ' ');
+    printf "Structure %s:\n" structure.name;
+    structure.items |> List.iter (dump_structure_item (indent + 2))
+  and dump_structure_item indent item =
+    if indent > 0 then printf "%s" (String.make indent ' ');
+    let open Module in
+    match item.kind with
+    | Value _typedExpr ->
+      printf "Value %s %s\n" item.name (Warnings.loc_to_string item.loc)
+    | Type _ ->
+      printf "Type %s %s\n" item.name (Warnings.loc_to_string item.loc)
+    | Module {type_ = m} ->
+      printf "Module %s %s\n" item.name (Warnings.loc_to_string item.loc);
+      dump_module indent m
+  and dump_module indent (module_ : Module.t) =
+    match module_ with
+    | Ident path -> printf "Module (Ident) %s\n" (Path.name path)
+    | Structure structure -> dump_structure indent structure
+    | Constraint (m1, m2) ->
+      dump_module indent m1;
+      dump_module indent m2
+  in
 
-    print_newline ();
-    dump_structure 0 full.file.structure;
+  printf "\n";
+  dump_structure 0 full.file.structure;
 
-    (* Dump all locItems (typed nodes) *)
-    let loc_items =
-      match full.extra with
-      | {loc_items} ->
-        loc_items |> List.filter (fun loc_item -> apply_filter loc_item.loc)
-    in
+  (* Dump all locItems (typed nodes) *)
+  let loc_items =
+    match full.extra with
+    | {loc_items} ->
+      loc_items |> List.filter (fun loc_item -> apply_filter loc_item.loc)
+  in
 
-    Printf.printf "\nFound %d locItems (typed nodes):\n\n"
-      (List.length loc_items);
+  printf "\nFound %d locItems (typed nodes):\n\n" (List.length loc_items);
 
-    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)
-    |> List.iter (fun {loc; loc_type} ->
-           let loc_str = Warnings.loc_to_string loc in
-           let kind_str = Shared_types.loc_type_to_string loc_type in
-           Printf.printf "%s %s\n" loc_str kind_str)
+  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)
+  |> 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);
+  Buffer.contents buffer

analysis/src/codemod.ml

@@ -5,43 +5,57 @@ let rec collect_patterns p =
   | Ppat_or (p1, p2) -> collect_patterns p1 @ [p2]
   | _ -> [p]
 
-let transform ~source ~pos ~debug ~typ ~hint =
-  let structure, print_expr, _, _ = Xform.parse_implementation ~source in
-  match typ with
-  | AddMissingCases -> (
-    let source = "let " ^ hint ^ " = ()" in
-    let {Res_driver.parsetree = hint_structure} =
-      Res_driver.parse_implementation_from_source ~for_printer:false
-        ~display_filename:"<none>" ~source
-    in
-    match hint_structure with
-    | [{pstr_desc = Pstr_value (_, [{pvb_pat = pattern}])}] -> (
-      let cases =
-        collect_patterns pattern
-        |> List.map (fun (p : Parsetree.pattern) ->
-               Ast_helper.Exp.case p (Type_utils.Codegen.mk_fail_with_exp ()))
+let transform_opt ~source ~pos ~debug ~typ ~hint =
+  let log message = if debug then print_endline message in
+  try
+    let structure, print_expr, _, _ = Xform.parse_implementation ~source in
+    match typ with
+    | AddMissingCases -> (
+      let source = "let " ^ hint ^ " = ()" in
+      let {Res_driver.parsetree = hint_structure} =
+        Res_driver.parse_implementation_from_source ~for_printer:false
+          ~display_filename:"<none>" ~source
       in
-      let result = ref None in
-      let mk_iterator ~pos ~result =
-        let expr (iterator : Ast_iterator.iterator) (exp : Parsetree.expression)
-            =
-          match exp.pexp_desc with
-          | Pexp_match (e, existing_cases)
-            when Pos.of_lexing exp.pexp_loc.loc_start = pos ->
-            result :=
-              Some {exp with pexp_desc = Pexp_match (e, existing_cases @ cases)}
-          | _ -> Ast_iterator.default_iterator.expr iterator exp
+      match hint_structure with
+      | [{pstr_desc = Pstr_value (_, [{pvb_pat = pattern}])}] -> (
+        let cases =
+          collect_patterns pattern
+          |> List.map (fun (p : Parsetree.pattern) ->
+                 Ast_helper.Exp.case p (Type_utils.Codegen.mk_fail_with_exp ()))
         in
-        {Ast_iterator.default_iterator with expr}
-      in
-      let iterator = mk_iterator ~pos ~result in
-      iterator.structure iterator structure;
-      match !result with
-      | None ->
-        if debug then print_endline "Found no result";
-        exit 1
-      | Some switch_expr ->
-        print_expr ~range:(Loc.range_of_loc switch_expr.pexp_loc) switch_expr)
-    | _ ->
-      if debug then print_endline "Mismatch in expected structure";
-      exit 1)
+        let result = ref None in
+        let mk_iterator ~pos ~result =
+          let expr (iterator : Ast_iterator.iterator)
+              (exp : Parsetree.expression) =
+            match exp.pexp_desc with
+            | Pexp_match (e, existing_cases)
+              when Pos.of_lexing exp.pexp_loc.loc_start = pos ->
+              result :=
+                Some
+                  {exp with pexp_desc = Pexp_match (e, existing_cases @ cases)}
+            | _ -> Ast_iterator.default_iterator.expr iterator exp
+          in
+          {Ast_iterator.default_iterator with expr}
+        in
+        let iterator = mk_iterator ~pos ~result in
+        iterator.structure iterator structure;
+        match !result with
+        | None ->
+          log "Found no result";
+          None
+        | Some switch_expr ->
+          Some
+            (print_expr
+               ~range:(Loc.range_of_loc switch_expr.pexp_loc)
+               switch_expr))
+      | _ ->
+        log "Mismatch in expected structure";
+        None)
+  with exn ->
+    log ("Codemod failed: " ^ Printexc.to_string exn);
+    None
+
+let transform ~source ~pos ~debug ~typ ~hint =
+  match transform_opt ~source ~pos ~debug ~typ ~hint with
+  | Some result -> result
+  | None -> exit 1

analysis/src/document_symbol.ml

@@ -10,8 +10,8 @@ let get_symbols ~source ~kind_file =
     then
       let range = Utils.cmt_loc_to_range loc in
       let symbol =
-        Lsp.Types.DocumentSymbol.create ~name ~range ~selectionRange:range
-          ~children:[] ~kind ()
+        Lsp.Types.DocumentSymbol.create ~name ~range ~selectionRange:range ~kind
+          ()
       in
       symbols := symbol :: !symbols
   in
@@ -165,13 +165,14 @@ let get_symbols ~source ~kind_file =
     | [] -> [symbol]
     | last :: rest ->
       if is_inside symbol last then
-        match last.children with
-        | Some c ->
-          let new_last =
-            {last with children = Some (c |> add_symbol_to_children ~symbol)}
-          in
-          new_last :: rest
-        | _ -> rest
+        let children = last.children |> Option.value ~default:[] in
+        let new_last =
+          {
+            last with
+            children = Some (children |> add_symbol_to_children ~symbol);
+          }
+        in
+        new_last :: rest
       else symbol :: children
   in
   let rec add_sorted_symbols_to_children ~sorted_symbols children =