From 303fbe21908f24c8dc6e6c3fb9d1fecce4a61bef Mon Sep 17 00:00:00 2001 From: mununki Date: Wed, 21 Oct 2026 12:03:39 +0900 Subject: [PATCH 1/4] Support ReScript 12 in dependency and value usage analysis - Decode typed trees with the layout of the compiler that wrote each .cmt file (ReScript 11 vs 12, told apart by the cmt_infos size), fixing the segfault in -vb on ReScript 12 builds - Resolve the .ast file of namespaced modules (app-Ns.cmt -> app.ast) so imports are filtered again, drop the generated namespace module from the graph, and normalize namespaced value paths for -vb - Read .ast headers by their byte length instead of as a module count - Read the ReScript 12 dependencies/dev-dependencies fields of rescript.json - Filter ReScript 12 runtime modules (Stdlib_*, Primitive_*) - Align the vendored ReScript 11 typedtree with the compiler layout - Add ReScript 12 fixture projects (standard and namespaced) with graph and value usage regression tests --- CHANGELOG.md | 8 + CONTRIBUTING.md | 19 +- Makefile | 3 + README.md | 2 +- lib/dependency_graph.ml | 651 ++++++-------------- lib/dune | 2 +- lib/parse_utils.ml | 27 +- lib/parser.ml | 305 +++++---- lib/typed_ast.ml | 230 +++++++ test/dune | 6 +- test/fixtures/rescript12_basic.json | 109 ++++ test/fixtures/rescript12_namespaced.json | 109 ++++ test/rescript12/.gitignore | 3 + test/rescript12/basic/package.json | 14 + test/rescript12/basic/rescript.json | 18 + test/rescript12/basic/src/app.res | 11 + test/rescript12/basic/src/comp0.res | 6 + test/rescript12/basic/src/logger.res | 1 + test/rescript12/basic/src/mathUtil.res | 22 + test/rescript12/basic/src/utils.res | 24 + test/rescript12/namespaced/package.json | 14 + test/rescript12/namespaced/rescript.json | 19 + test/rescript12/namespaced/src/app.res | 11 + test/rescript12/namespaced/src/comp0.res | 6 + test/rescript12/namespaced/src/logger.res | 1 + test/rescript12/namespaced/src/mathUtil.res | 22 + test/rescript12/namespaced/src/utils.res | 24 + test/rescript12/package.json | 10 + test/rescript12/pnpm-lock.yaml | 142 +++++ test/rescript12/pnpm-workspace.yaml | 3 + test/test_ast.ml | 159 ++--- test/test_namespace.ml | 82 ++- test/test_rescriptdep.ml | 27 +- test/test_value_usage.ml | 80 +++ vendor/typedtree.ml | 22 +- vendor/typedtree.mli | 26 +- vendor/typedtree_v12.ml | 149 +++++ 37 files changed, 1577 insertions(+), 790 deletions(-) create mode 100644 lib/typed_ast.ml create mode 100644 test/fixtures/rescript12_basic.json create mode 100644 test/fixtures/rescript12_namespaced.json create mode 100644 test/rescript12/.gitignore create mode 100644 test/rescript12/basic/package.json create mode 100644 test/rescript12/basic/rescript.json create mode 100644 test/rescript12/basic/src/app.res create mode 100644 test/rescript12/basic/src/comp0.res create mode 100644 test/rescript12/basic/src/logger.res create mode 100644 test/rescript12/basic/src/mathUtil.res create mode 100644 test/rescript12/basic/src/utils.res create mode 100644 test/rescript12/namespaced/package.json create mode 100644 test/rescript12/namespaced/rescript.json create mode 100644 test/rescript12/namespaced/src/app.res create mode 100644 test/rescript12/namespaced/src/comp0.res create mode 100644 test/rescript12/namespaced/src/logger.res create mode 100644 test/rescript12/namespaced/src/mathUtil.res create mode 100644 test/rescript12/namespaced/src/utils.res create mode 100644 test/rescript12/package.json create mode 100644 test/rescript12/pnpm-lock.yaml create mode 100644 test/rescript12/pnpm-workspace.yaml create mode 100644 test/test_value_usage.ml create mode 100644 vendor/typedtree_v12.ml diff --git a/CHANGELOG.md b/CHANGELOG.md index 8789018..53ad6b8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added - Added regression coverage for dependency graph dependent-index updates +- Added ReScript 12 support for value usage analysis (`-vb`) by decoding typed trees with the layout of the compiler that wrote each `.cmt` file +- Added ReScript 12 fixture projects (standard and namespaced) with dependency graph and value usage regression tests ### Changed - Improved dependency graph performance by maintaining a reverse dependent index instead of scanning the full graph for each dependent lookup @@ -16,6 +18,12 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed - Prevented stale VS Code inline value usage decorations from appearing after source edits or outdated CLI responses - Improved inline value usage cache invalidation when ReScript build artifacts change +- Fixed a segmentation fault when counting value usage (`-vb`) in projects built with ReScript 12 +- Fixed namespaced projects so imports are filtered by each module's `.ast` file again; ReScript 12 runtime modules (`Stdlib_*`, `Primitive_*`) and unused imports no longer appear as dependencies, and the generated namespace module is no longer shown as a node +- Fixed value usage analysis (`-vb`) in namespaced projects +- Read the ReScript 12 `dependencies` and `dev-dependencies` fields of `rescript.json` when resolving external module paths +- Read `.ast` headers by their byte length so data from the binary AST is never taken as module references +- Aligned the vendored ReScript 11 typedtree with the compiler's constructor layout ## [0.1.2] - 2026-04-22 ### Fixed diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 74f273e..3743ad7 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -20,13 +20,16 @@ dune build --profile static You can run tests using the following methods: ```bash -# Run the CI-equivalent test suite (requires pnpm 8.x) +# Run the CI-equivalent test suite (requires pnpm 10.x) make test # Run specific tests: dune exec test/test_cmt_values.exe # Test value dependency information dune exec test/test_cmt_imports.exe # Test import information +dune exec test/test_ast.exe # Test reading module references from .ast files dune exec test/test_rescriptdep.exe # Test dependency analysis on sample projects +dune exec test/test_value_usage.exe # Test value usage counts (-vb) on sample projects +dune exec test/test_namespace.exe # Test namespace handling (self-contained) ``` ### Test Structure @@ -35,7 +38,10 @@ The test code is located in the `test/` directory and includes: - `test_cmt_imports.ml`: Tests the import information from cmt files - `test_cmt_values.ml`: Tests the value dependency information from cmt files +- `test_ast.ml`: Tests reading module references from compiler-generated .ast files - `test_rescriptdep.ml`: Tests the dependency analysis on sample ReScript projects +- `test_value_usage.ml`: Tests value usage counts on ReScript 11 and 12 projects +- `test_namespace.ml`: Tests namespace handling without compiled fixtures - `benchmark.ml`: Performance benchmark for the parser ### Test Fixtures @@ -46,7 +52,9 @@ The test system uses two types of fixtures: The dependency analysis tests use JSON fixtures to ensure consistent behavior: -- `test/fixtures/rescript.json`: Reference output for the rescript test project +- `test/fixtures/rescript.json`: Reference output for the ReScript 11 test project +- `test/fixtures/rescript12_basic.json`: Reference output for the ReScript 12 test project +- `test/fixtures/rescript12_namespaced.json`: Reference output for the namespaced ReScript 12 test project These fixtures are automatically generated on first run and serve as reference points for future test runs. If the dependency analysis output differs from these fixtures, the test will fail and show a diff of the changes. @@ -54,7 +62,10 @@ These fixtures are automatically generated on first run and serve as reference p The test directory contains sample ReScript projects used for testing the dependency analyzer: -- `test/rescript/`: Sample ReScript project with standard ReScript setup +- `test/rescript/`: Sample ReScript 11 project with standard ReScript setup +- `test/rescript12/`: pnpm workspace with ReScript 12 projects built from the same sources: + `basic/` (standard setup) and `namespaced/` (`"namespace": true`). `math.res` is + named `mathUtil.res` there because ReScript 12 resolves `Math` to `Stdlib.Math`. Each test project contains: - `src/`: Source code files (.res, .resi) @@ -69,7 +80,7 @@ When making changes that affect dependency analysis: 1. Review the test output diff carefully to ensure changes are expected 2. If the changes are intentional: - - Delete the existing fixture file: `rm test/fixtures/rescript.json` + - Delete the existing fixture file, e.g. `rm test/fixtures/rescript.json` - Run the tests again to generate new fixtures: `dune exec test/test_rescriptdep.exe` - Commit both the code changes and the updated fixtures diff --git a/Makefile b/Makefile index 5ce0d7f..2be009d 100644 --- a/Makefile +++ b/Makefile @@ -14,13 +14,16 @@ check-pnpm: install-test-deps: CI=1 pnpm --dir test/rescript install --frozen-lockfile + CI=1 pnpm --dir test/rescript12 install --frozen-lockfile build-test-projects: pnpm --dir test/rescript run res:build + pnpm --dir test/rescript12 run res:build run-ocaml-tests: dune exec ./test/test_cmt_imports.exe dune exec ./test/test_cmt_values.exe dune exec ./test/test_ast.exe dune exec ./test/test_rescriptdep.exe + dune exec ./test/test_value_usage.exe dune exec ./test/test_namespace.exe diff --git a/README.md b/README.md index 5ac1c47..ddf9de0 100644 --- a/README.md +++ b/README.md @@ -53,7 +53,7 @@ For detailed information about building the project, running tests, and contribu # Build the project make build -# Run the CI-equivalent test suite (requires pnpm 8.x) +# Run the CI-equivalent test suite (requires pnpm 10.x) make test ``` diff --git a/lib/dependency_graph.ml b/lib/dependency_graph.ml index 162304e..c2e256e 100644 --- a/lib/dependency_graph.ml +++ b/lib/dependency_graph.ml @@ -5,7 +5,10 @@ module StringMap = Map.Make (String) (* Module metadata type *) -type module_metadata = { path : string option } +type module_metadata = { + path : string option; (* Source file *) + cmt_path : string option; (* CMT file the module was read from *) +} (* Graph representation including module metadata *) type t = { @@ -51,8 +54,8 @@ let make dependencies metadata = { dependencies; dependents = build_dependents dependencies; metadata } (* Add a module and its dependencies to the graph *) -let add graph module_name dependencies path = - let metadata = { path } in +let add ?cmt_path graph module_name dependencies path = + let metadata = { path; cmt_path } in let dependencies = List.sort_uniq String.compare dependencies in let dependents = match StringMap.find_opt module_name graph.dependencies with @@ -79,7 +82,7 @@ let get_metadata_map graph = graph.metadata (* Get module metadata record for a module *) let get_module_metadata graph module_name = try StringMap.find module_name graph.metadata - with Not_found -> { path = None } + with Not_found -> { path = None; cmt_path = None } (* Get module path *) let get_module_path graph module_name = @@ -90,7 +93,8 @@ let get_module_path graph module_name = let build_from_module_infos infos = List.fold_left (fun graph info -> - add graph info.Parser.name info.Parser.dependencies info.Parser.file_path) + add ?cmt_path:info.Parser.cmt_path graph info.Parser.name + info.Parser.dependencies info.Parser.file_path) empty infos (* Get the dependencies of a module *) @@ -344,7 +348,10 @@ let create_focused_graph graph center_module = (* 3. Start building a new graph with just the center module *) (* Preserve metadata - add center module *) let center_metadata = get_module_metadata graph center_module in - let result = add empty center_module center_deps center_metadata.path in + let result = + add ?cmt_path:center_metadata.cmt_path empty center_module center_deps + center_metadata.path + in (* 4. Add dependency modules and their metadata *) let result = @@ -354,7 +361,7 @@ let create_focused_graph graph center_module = (* In a focused graph, we only care about dependencies of the center module, not dependencies of dependencies, so we use empty list for deps *) let dep_metadata = get_module_metadata graph dep in - add acc dep [] dep_metadata.path + add ?cmt_path:dep_metadata.cmt_path acc dep [] dep_metadata.path else acc) result center_deps in @@ -371,7 +378,8 @@ let create_focused_graph graph center_module = then (* Add the dependent with just one dependency - the center module *) let dependent_metadata = get_module_metadata graph dependent in - add acc dependent [ center_module ] dependent_metadata.path + add ?cmt_path:dependent_metadata.cmt_path acc dependent + [ center_module ] dependent_metadata.path else acc) result dependents in @@ -383,476 +391,199 @@ let find_modules_with_no_dependents graph = let modules = get_modules graph in List.filter (fun m -> find_dependents graph m = []) modules -(* Improved function for tracking let binding location/scope and path *) -let find_let_binding_at_line_with_path value_name value_line structure = +(* Find the let binding [value_name] declared at [value_line]. Returns the + module path of the binding inside its file, whether it is a top-level + binding, and for a local binding the top-level expression enclosing it. *) +let find_let_binding_at_line_with_path value_name value_line items = let found = ref None in - let rec search_items items path is_top_level parent_expr = + let is_target (binding : Typed_ast.binding) = + binding.name = Some value_name && binding.line = value_line + in + let rec search_items path items = List.iter - (fun item -> - match item.Typedtree.str_desc with - | Typedtree.Tstr_value (_, vbs) -> + (function + | Typed_ast.Values bindings -> List.iter - (fun vb -> - let loc = vb.Typedtree.vb_pat.pat_loc in - let start_line = loc.loc_start.pos_lnum in - match vb.vb_pat.pat_desc with - | Tpat_var (id, _) -> - if Ident.name id = value_name && start_line = value_line - then - found := - Some (vb, List.rev path, is_top_level, parent_expr); - search_expr vb.Typedtree.vb_expr path false - (Some vb.Typedtree.vb_expr) - | _ -> ()) - vbs - | Typedtree.Tstr_module { mb_id; mb_expr = { mod_desc; _ }; _ } -> ( - let mod_name = Ident.name mb_id in - match mod_desc with - | Typedtree.Tmod_structure s -> - search_items s.str_items (mod_name :: path) true parent_expr - | Typedtree.Tmod_constraint (mexpr, _, _, _) -> ( - match mexpr.mod_desc with - | Typedtree.Tmod_structure s -> - search_items s.str_items (mod_name :: path) true parent_expr - | _ -> ()) - | _ -> ()) - | _ -> ()) + (fun (binding : Typed_ast.binding) -> + if is_target binding then + found := Some (List.rev path, true, None); + search_expr path binding.expr binding.expr) + bindings + | Typed_ast.Module (name, items) -> search_items (name :: path) items + | Typed_ast.Include items -> search_items path items + | Typed_ast.Eval expr -> search_expr path expr expr) items - and search_expr expr path is_top_level parent_expr = - match expr.Typedtree.exp_desc with - | Texp_let (_, vbs, e) -> - List.iter - (fun vb -> - let loc = vb.Typedtree.vb_pat.pat_loc in - let start_line = loc.loc_start.pos_lnum in - match vb.vb_pat.pat_desc with - | Tpat_var (id, _) -> - if Ident.name id = value_name && start_line = value_line then - found := Some (vb, List.rev path, is_top_level, parent_expr); - search_expr vb.Typedtree.vb_expr path false parent_expr - | _ -> ()) - vbs; - search_expr e path is_top_level parent_expr - | Texp_function { cases; _ } -> - List.iter - (fun c -> search_expr c.Typedtree.c_rhs path false parent_expr) - cases - | Texp_apply (e, args) -> - search_expr e path false parent_expr; - List.iter - (function - | _, Some e -> search_expr e path false parent_expr | _ -> ()) - args - | Texp_match (e, cases, cases2, _) -> - search_expr e path false parent_expr; - List.iter - (fun c -> search_expr c.Typedtree.c_rhs path false parent_expr) - (cases @ cases2) - | Texp_tuple elist | Texp_array elist -> - List.iter (fun e -> search_expr e path false parent_expr) elist - | Texp_construct (_, _, elist) -> - List.iter (fun e -> search_expr e path false parent_expr) elist - | Texp_variant (_, eo) -> - Option.iter (fun e -> search_expr e path false parent_expr) eo - | Texp_record { fields; extended_expression; _ } -> - Array.iter - (function - | _, Typedtree.Overridden (_, e) -> - search_expr e path false parent_expr - | _ -> ()) - fields; - Option.iter - (fun e -> search_expr e path false parent_expr) - extended_expression - | Texp_field (e, _, _) -> search_expr e path false parent_expr - | Texp_setfield (e1, _, _, e2) -> - search_expr e1 path false parent_expr; - search_expr e2 path false parent_expr - | Texp_ifthenelse (e1, e2, eo) -> - search_expr e1 path false parent_expr; - search_expr e2 path false parent_expr; - Option.iter (fun e -> search_expr e path false parent_expr) eo - | Texp_sequence (e1, e2) -> - search_expr e1 path false parent_expr; - search_expr e2 path false parent_expr - | Texp_while (e1, e2) -> - search_expr e1 path false parent_expr; - search_expr e2 path false parent_expr - | Texp_for (_, _, e1, e2, _, e3) -> - search_expr e1 path false parent_expr; - search_expr e2 path false parent_expr; - search_expr e3 path false parent_expr - | Texp_send (e, _, eo) -> - search_expr e path false parent_expr; - Option.iter (fun e -> search_expr e path false parent_expr) eo - | Texp_open (_, e) -> search_expr e path false parent_expr - | _ -> () + and search_local_bindings path parent bindings = + List.iter + (fun (binding : Typed_ast.binding) -> + if is_target binding then + found := Some (List.rev path, false, Some parent); + search_expr path parent binding.expr) + bindings + and search_local_items path parent items = + List.iter + (function + | Typed_ast.Values bindings -> + search_local_bindings path parent bindings + | Typed_ast.Module (_, items) | Typed_ast.Include items -> + search_local_items path parent items + | Typed_ast.Eval expr -> search_expr path parent expr) + items + and search_expr path parent = function + | Typed_ast.Ident _ -> () + | Typed_ast.Let (bindings, body) -> + search_local_bindings path parent bindings; + search_expr path parent body + | Typed_ast.Struct items -> search_local_items path parent items + | Typed_ast.Node children -> List.iter (search_expr path parent) children in - search_items structure.Typedtree.str_items [] true None; + search_items [] items; !found -let rec count_in_expression value_name path open_modules current_module - target_module is_top_level expr = - let value_id = value_name in - let value_mod_path = path in - let rec path_to_list path = - match path with - | Path.Pident id -> [ Ident.name id ] - | Path.Pdot (p, id, _) -> path_to_list p @ [ id ] - | _ -> [ Path.name path ] - in - match expr.Typedtree.exp_desc with - | Typedtree.Texp_ident (path_ast, _, _) -> - let used_path = path_to_list path_ast in - let result = - if not is_top_level then - match used_path with [ id ] when id = value_id -> 1 | _ -> 0 - else if current_module = target_module then - match used_path with - | m :: rest - when m = target_module && rest = value_mod_path @ [ value_id ] -> - 1 - | [ id ] when id = value_id -> 1 - | _ -> 0 - else - match used_path with - | m :: rest - when m = target_module && rest = value_mod_path @ [ value_id ] -> - 1 - | _ -> 0 - in - result - | Typedtree.Texp_let (_, vbs, e) -> - List.fold_left - (fun acc vb -> - acc - + count_in_expression value_name path [] current_module target_module - is_top_level vb.Typedtree.vb_expr) - (count_in_expression value_name path [] current_module target_module - is_top_level e) - vbs - | Typedtree.Texp_try (e, cases) -> - count_in_expression value_name path open_modules current_module - target_module is_top_level e - + List.fold_left - (fun acc c -> - acc - + count_in_expression value_name path open_modules current_module - target_module is_top_level c.Typedtree.c_rhs) - 0 cases - | Typedtree.Texp_function { cases; _ } -> - List.fold_left - (fun acc c -> - acc - + count_in_expression value_name path [] current_module target_module - is_top_level c.Typedtree.c_rhs) - 0 cases - | Typedtree.Texp_apply (e, args) -> - List.fold_left - (fun acc (_, eo) -> - acc - + - match eo with - | Some e -> - count_in_expression value_name path [] current_module - target_module is_top_level e - | None -> 0) - (count_in_expression value_name path [] current_module target_module - is_top_level e) - args - | Typedtree.Texp_match (e, cases, cases2, _) -> - count_in_expression value_name path [] current_module target_module - is_top_level e - + List.fold_left - (fun acc c -> - acc - + count_in_expression value_name path [] current_module - target_module is_top_level c.Typedtree.c_rhs) - 0 (cases @ cases2) - | Typedtree.Texp_tuple elist | Typedtree.Texp_array elist -> +let rec count_in_expression matches = function + | Typed_ast.Ident path -> if matches path then 1 else 0 + | Typed_ast.Let (bindings, body) -> List.fold_left - (fun acc e -> - acc - + count_in_expression value_name path [] current_module target_module - is_top_level e) - 0 elist - | Typedtree.Texp_construct (_, _, elist) -> + (fun acc (binding : Typed_ast.binding) -> + acc + count_in_expression matches binding.expr) + (count_in_expression matches body) + bindings + | Typed_ast.Struct items -> count_in_items matches items + | Typed_ast.Node children -> List.fold_left - (fun acc e -> - acc - + count_in_expression value_name path [] current_module target_module - is_top_level e) - 0 elist - | Typedtree.Texp_variant (_, eo) -> ( - match eo with - | Some e -> - count_in_expression value_name path [] current_module target_module - is_top_level e - | None -> 0) - | Typedtree.Texp_record { fields; extended_expression; _ } -> ( - let acc = - Array.fold_left - (fun acc (_, fld) -> - match fld with - | Typedtree.Overridden (_, e) -> - acc - + count_in_expression value_name path [] current_module - target_module is_top_level e - | Typedtree.Kept _ -> acc) - 0 fields - in - match extended_expression with - | Some e -> - acc - + count_in_expression value_name path [] current_module target_module - is_top_level e - | None -> acc) - | Typedtree.Texp_field (e, _, _) -> - count_in_expression value_name path [] current_module target_module - is_top_level e - | Typedtree.Texp_setfield (e1, _, _, e2) -> - count_in_expression value_name path [] current_module target_module - is_top_level e1 - + count_in_expression value_name path [] current_module target_module - is_top_level e2 - | Typedtree.Texp_ifthenelse (e1, e2, eo) -> ( - count_in_expression value_name path [] current_module target_module - is_top_level e1 - + count_in_expression value_name path [] current_module target_module - is_top_level e2 - + - match eo with - | Some e -> - count_in_expression value_name path [] current_module target_module - is_top_level e - | None -> 0) - | Typedtree.Texp_sequence (e1, e2) -> - count_in_expression value_name path [] current_module target_module - is_top_level e1 - + count_in_expression value_name path [] current_module target_module - is_top_level e2 - | Typedtree.Texp_while (e1, e2) -> - count_in_expression value_name path [] current_module target_module - is_top_level e1 - + count_in_expression value_name path [] current_module target_module - is_top_level e2 - | Typedtree.Texp_for (_, _, e1, e2, _, e3) -> - count_in_expression value_name path [] current_module target_module - is_top_level e1 - + count_in_expression value_name path [] current_module target_module - is_top_level e2 - + count_in_expression value_name path [] current_module target_module - is_top_level e3 - | Typedtree.Texp_send (e, _, eo) -> ( - count_in_expression value_name path [] current_module target_module - is_top_level e - + - match eo with - | Some e -> - count_in_expression value_name path [] current_module target_module - is_top_level e - | None -> 0) - | Typedtree.Texp_open (open_decl, e) -> - let open_mod = - match open_decl.open_expr.mod_desc with - | Typedtree.Tmod_ident (path_ast, _) -> Path.name path_ast - | _ -> "" - in - count_in_expression value_name path (open_mod :: open_modules) - current_module target_module is_top_level e - | Typedtree.Texp_letmodule (_, _, _, expr) -> - count_in_expression value_name path open_modules current_module - target_module is_top_level expr - | Typedtree.Texp_object _ -> 0 - | Typedtree.Texp_constant _ -> 0 - | Typedtree.Texp_letexception (_, expr) -> - count_in_expression value_name path open_modules current_module - target_module is_top_level expr - | Typedtree.Texp_letop { let_; ands; body } -> - let acc = - count_in_expression value_name path open_modules current_module - target_module is_top_level let_.bop_exp - + List.fold_left - (fun acc (and_ : Typedtree.binding_op) -> - acc - + count_in_expression value_name path open_modules current_module - target_module is_top_level and_.bop_exp) - 0 ands - in + (fun acc expr -> acc + count_in_expression matches expr) + 0 children + +and count_in_items matches items = + List.fold_left + (fun acc item -> acc - + count_in_expression value_name path open_modules current_module - target_module is_top_level body.c_rhs - | Typedtree.Texp_assert e -> - count_in_expression value_name path open_modules current_module - target_module is_top_level e - | Typedtree.Texp_lazy e -> - count_in_expression value_name path open_modules current_module - target_module is_top_level e - | Typedtree.Texp_override (_, lst) -> - List.fold_left - (fun acc (_, _, e) -> - acc - + count_in_expression value_name path open_modules current_module - target_module is_top_level e) - 0 lst - | Typedtree.Texp_setinstvar (_, _, _, e) -> - count_in_expression value_name path open_modules current_module - target_module is_top_level e - | Typedtree.Texp_pack _ -> 0 - | Typedtree.Texp_unreachable -> 0 - | Typedtree.Texp_extension_constructor (_, _) -> 0 - | Typedtree.Texp_instvar _ -> 0 - | Typedtree.Texp_new _ -> 0 - -and count_in_structure value_name path current_module target_module is_top_level - structure = - let result = - List.fold_left - (fun acc item -> - match item.Typedtree.str_desc with - | Typedtree.Tstr_value (_, vbs) -> - let acc' = - acc - + List.fold_left - (fun acc vb -> - acc - + count_in_expression value_name path [] current_module - target_module is_top_level vb.Typedtree.vb_expr) - 0 vbs - in - acc' - | Typedtree.Tstr_eval (e, _) -> - let acc' = - acc - + count_in_expression value_name path [] current_module - target_module is_top_level e - in - acc' - | Typedtree.Tstr_module { mb_expr = { mod_desc; _ }; _ } -> ( - match mod_desc with - | Typedtree.Tmod_structure s -> - let acc' = - acc - + count_in_structure value_name path current_module - target_module is_top_level s - in - acc' - | Typedtree.Tmod_constraint (mexpr, _, _, _) -> ( - match mexpr.mod_desc with - | Typedtree.Tmod_structure s -> - let acc' = - acc - + count_in_structure value_name path current_module - target_module is_top_level s - in - acc' - | _ -> acc) - | _ -> acc) - | _ -> acc) - 0 structure.Typedtree.str_items + + + match item with + | Typed_ast.Values bindings -> + List.fold_left + (fun acc (binding : Typed_ast.binding) -> + acc + count_in_expression matches binding.expr) + 0 bindings + | Typed_ast.Module (_, items) | Typed_ast.Include items -> + count_in_items matches items + | Typed_ast.Eval expr -> count_in_expression matches expr) + 0 items + +(* The namespace of a compilation unit, e.g. "App-MyNs" -> Some "MyNs" *) +let namespace_of_modname modname = + match String.rindex_opt modname '-' with + | Some idx when idx + 1 < String.length modname -> + Some (String.sub modname (idx + 1) (String.length modname - idx - 1)) + | _ -> None + +(* Namespaced builds name compilation units "Utils-MyNs" and may reach them + through the namespace module "MyNs", so normalize the module part of a path + before comparing it with graph module names. *) +let normalize_value_path ~namespace path = + let path = + match (path, namespace) with + | ns :: (_ :: _ :: _ as rest), Some namespace when ns = namespace -> rest + | _ -> path in - result - -(* Count value usage in dependents of a module *) + match path with + | m :: (_ :: _ as rest) -> Parse_utils.normalize_module_name m :: rest + | _ -> path + +(* Build the predicate that decides whether a resolved value path refers to the + binding being counted. [value_path] is the submodule path of the binding + inside [target_module]. *) +let value_path_matcher ~namespace ~local ~in_target_module ~target_module + ~value_path ~value_name = + let qualified = value_path @ [ value_name ] in + fun path -> + let path = normalize_value_path ~namespace path in + if local then path = [ value_name ] + else + match path with + | m :: rest when m = target_module && rest = qualified -> true + | _ -> in_target_module && (path = [ value_name ] || path = qualified) + +let find_cmt_path metadata = + match metadata.cmt_path with + | Some cmt_path when Sys.file_exists cmt_path -> Some cmt_path + | _ -> ( + match metadata.path with + | Some file_path -> + let cmt_path = + Parser.DependencyExtractor.get_cmt_path_for_source file_path + in + if Sys.file_exists cmt_path then Some cmt_path else None + | None -> None) + +let read_typed_implementation cmt_path = + let cmt_info = Cmt_format.read_cmt cmt_path in + ( Typed_ast.implementation cmt_info, + namespace_of_modname cmt_info.Cmt_format.cmt_modname ) + +(* Count value usage in dependents of a module (and in the module itself). + Negative counts report why a module could not be analyzed: + -2 no implementation, -3 unreadable CMT, -4 no CMT file, -5 no file path. *) let count_value_usage_in_dependents graph ~module_name ~value_name ~value_line = - let open Stdlib in - let open Cmt_format in - (* Also search for usage in the module itself, not just in dependents *) let dependents = List.sort_uniq String.compare (module_name :: find_dependents graph module_name) in - let find_cmt_path file_path = - let cmt_path = - Parser.DependencyExtractor.get_cmt_path_for_source file_path - in - if Sys.file_exists cmt_path then Some cmt_path else None - in - let target_path, is_top_level, _ = + (* Locate the binding in the target module to learn its submodule path and + whether it is a top-level binding *) + let target_binding = match value_line with - | Some line -> - let file_path_opt = get_module_path graph module_name in - let result = - match file_path_opt with - | Some file_path -> ( - let cmt_path_opt = find_cmt_path file_path in - match cmt_path_opt with - | Some cmt_path -> ( - try - let cmt_info = Cmt_format.read_cmt cmt_path in - match cmt_info.cmt_annots with - | Implementation structure -> ( - match - find_let_binding_at_line_with_path value_name line - structure - with - | Some (_, path, is_top, parent_expr) -> - (path, is_top, parent_expr) - | None -> ([], true, None)) - | _ -> ([], true, None) - with _ -> ([], true, None)) - | None -> ([], true, None)) - | None -> ([], true, None) - in - result - | None -> ([], true, None) + | None -> None + | Some line -> ( + match find_cmt_path (get_module_metadata graph module_name) with + | Some cmt_path -> ( + try + match read_typed_implementation cmt_path with + | Some items, _ -> + find_let_binding_at_line_with_path value_name line items + | None, _ -> None + with _ -> None) + | None -> None) in List.map (fun dep -> - let file_path_opt = get_module_path graph dep in - match file_path_opt with - | Some file_path -> ( - let cmt_path_opt = find_cmt_path file_path in - match cmt_path_opt with - | Some cmt_path -> ( - try - let cmt_info = Cmt_format.read_cmt cmt_path in - match cmt_info.cmt_annots with - | Implementation structure -> ( - match value_line with - | Some line -> - if dep = module_name then - let binding_result = - find_let_binding_at_line_with_path value_name line - structure - in - match binding_result with - | Some (_, _, is_top_level, parent_expr) -> - if is_top_level then - let count = - count_in_structure value_name target_path dep - module_name true structure - in - (dep, count) - else - let count = - match parent_expr with - | Some expr -> - count_in_expression value_name target_path - [] dep module_name false expr - | None -> 0 - in - (dep, count) - | None -> (dep, 0) - else if not is_top_level then (dep, 0) - (* If the let binding we're looking for is not at top level, no need to search in dependent modules *) - else - let count = - count_in_structure value_name target_path dep - module_name true structure - in - (dep, count) - | None -> - let count = - count_in_structure value_name [] dep module_name true - structure - in - (dep, count)) - | _ -> (dep, -2) - (* -2: No implementation AST *) - with _ -> (dep, -3) (* -3: CMT read error *)) - | None -> (dep, -4) - (* -4: No .cmt file found *)) - | None -> (dep, -5) - (* -5: No file path found *)) + let metadata = get_module_metadata graph dep in + match find_cmt_path metadata with + | None -> + if metadata.path = None && metadata.cmt_path = None then (dep, -5) + else (dep, -4) + | Some cmt_path -> ( + try + match read_typed_implementation cmt_path with + | None, _ -> (dep, -2) + | Some items, namespace -> + let in_target_module = dep = module_name in + let count_top_level value_path = + count_in_items + (value_path_matcher ~namespace ~local:false + ~in_target_module ~target_module:module_name ~value_path + ~value_name) + items + in + let count = + match (value_line, target_binding) with + | None, _ -> count_top_level [] + | Some _, None -> + if in_target_module then 0 else count_top_level [] + | Some _, Some (value_path, true, _) -> + count_top_level value_path + | Some _, Some (_, false, parent_expr) -> ( + (* A local binding can only be used inside the top-level + expression that encloses it *) + match parent_expr with + | Some expr when in_target_module -> + count_in_expression + (value_path_matcher ~namespace ~local:true + ~in_target_module ~target_module:module_name + ~value_path:[] ~value_name) + expr + | _ -> 0) + in + (dep, count) + with _ -> (dep, -3))) dependents diff --git a/lib/dune b/lib/dune index 9cda4cc..69ebb55 100644 --- a/lib/dune +++ b/lib/dune @@ -1,5 +1,5 @@ (library (name rescriptdep) (public_name rescriptdep) - (modules parse_utils parser formatter dependency_graph) + (modules parse_utils parser typed_ast formatter dependency_graph) (libraries str unix vendor eio eio_main yojson)) diff --git a/lib/parse_utils.ml b/lib/parse_utils.ml index 7616385..e1f7d90 100644 --- a/lib/parse_utils.ml +++ b/lib/parse_utils.ml @@ -197,6 +197,9 @@ let is_stdlib_or_internal_module name = || String.starts_with ~prefix:"Js_" name || String.starts_with ~prefix:"Belt_" name || String.starts_with ~prefix:"Jsx" name + (* ReScript 12 runtime modules *) + || String.starts_with ~prefix:"Stdlib_" name + || String.starts_with ~prefix:"Primitive_" name (* Check if a string is a valid module name *) let is_valid_module_name str = @@ -249,13 +252,23 @@ let find_external_module_path ?(verbose = false) module_name project_root = with _ -> [] in - (* Extract dependencies from different fields *) - let bs_deps = get_string_array json "bs-dependencies" in - let bs_dev_deps = get_string_array json "bs-dev-dependencies" in - let pinned_deps = get_string_array json "pinned-dependencies" in - - (* Combine all dependencies *) - let all_deps = List.concat [ bs_deps; bs_dev_deps; pinned_deps ] in + (* Extract dependencies from different fields. ReScript 12 renamed + "bs-dependencies" and "bs-dev-dependencies" to "dependencies" and + "dev-dependencies". *) + let all_deps = + [ + "dependencies"; + "dev-dependencies"; + "bs-dependencies"; + "bs-dev-dependencies"; + "pinned-dependencies"; + ] + |> List.concat_map (get_string_array json) + |> List.fold_left + (fun acc dep -> if List.mem dep acc then acc else dep :: acc) + [] + |> List.rev + in if verbose then Printf.printf "Found dependencies: %s\n" (String.concat ", " all_deps); diff --git a/lib/parser.ml b/lib/parser.ml index 161d833..378af9b 100644 --- a/lib/parser.ml +++ b/lib/parser.ml @@ -8,6 +8,7 @@ type module_info = { interface_digest : Digest.t option; implementation_digest : Digest.t option; file_path : string option; + cmt_path : string option; } (* Cache management module with Eio synchronization *) @@ -189,6 +190,16 @@ end (* Exceptions *) exception Invalid_cmt_file of string +(* Namespaced builds compile a generated namespace module ("MyNs.cmt" from + "MyNs.mlmap") that aliases every module of the package. It is not a source + module, so it is kept out of the graph. *) +let is_namespace_map_cmt path = + Sys.file_exists (Filename.remove_extension path ^ ".mlmap") + +(* A .cmt file that describes a source module *) +let is_module_cmt path = + Filename.check_suffix path ".cmt" && not (is_namespace_map_cmt path) + (* Recursively scan directories for .cmt files *) let rec scan_directory_recursive dir = try @@ -215,7 +226,7 @@ let rec scan_directory_recursive dir = (* Recursively scan subdirectory *) cmt_files := List.append (scan_directory_recursive path) !cmt_files) - else if Filename.check_suffix file ".cmt" then + else if is_module_cmt path then (* Add cmt file *) cmt_files := path :: !cmt_files) files; @@ -243,81 +254,50 @@ module DependencyExtractor = struct (* For path applications, we'll use the first path *) extract_module_from_path p1 - (* Simplified AST file path resolution - just replace extension with .ast in the same directory *) + (* Resolve the .ast file written next to a .cmt file. Namespaced builds name + the CMT "app-MyNs.cmt" but keep the AST as "app.ast". *) let get_ast_path cmt_path = - let base_path = Filename.remove_extension cmt_path in - base_path ^ ".ast" + let base_name = + Filename.basename cmt_path |> Filename.remove_extension + |> strip_generated_namespace_suffix + in + Filename.concat (Filename.dirname cmt_path) (base_name ^ ".ast") - (* Function to read AST file contents efficiently *) + (* Read the module references recorded in the header of an AST file. + The compiler writes the byte length of the header as a binary int, + followed by "\nModuleA\nModuleB\n...", the source path and the + marshalled AST. Returns [None] when the header cannot be read. *) let read_ast_file ?(verbose = false) ?(skip_cache = false) ast_path = (* Check if AST data is already cached *) match Cache.get_ast_data ~verbose ast_path with | Some data when not skip_cache -> if verbose then Printf.printf "Using cached AST data for %s\n" ast_path; - data + Some data | _ -> ( if verbose then Printf.printf "Reading AST file: %s\n" ast_path; - if not (Sys.file_exists ast_path) then - (* Return empty list if file doesn't exist *) - [] + if not (Sys.file_exists ast_path) then None else try let ic = open_in_bin ast_path in - - (* Efficiently read the entire header section of the AST file *) - let module_count = input_binary_int ic in - - (* Skip the newline after the count *) - let _ = try input_char ic with _ -> '\000' in - - (* Read all module references at once instead of line by line *) - let modules = ref [] in - let rec read_modules remaining max_iterations = - if remaining <= 0 || max_iterations <= 0 then !modules - else - try - let buf = Buffer.create 128 in - let rec read_line max_chars = - if max_chars <= 0 then - (* Line too long, skip the rest of this line *) - try - while input_char ic <> '\n' do - () - done; - read_modules (remaining - 1) (max_iterations - 1) - with End_of_file -> !modules - else - let c = input_char ic in - if c = '\n' then ( - let line = Buffer.contents buf in - if - String.length line > 0 - && line.[0] <> '/' - && (String.length line <= 1 - || not (line.[0] = 'C' && line.[1] = ':')) - then modules := line :: !modules; - read_modules (remaining - 1) (max_iterations - 1)) - else ( - Buffer.add_char buf c; - read_line (max_chars - 1)) + Fun.protect + ~finally:(fun () -> close_in_noerr ic) + (fun () -> + let header_length = input_binary_int ic in + if header_length < 0 || header_length > in_channel_length ic + then None + else + let modules = + really_input_string ic header_length + |> String.split_on_char '\n' + |> List.filter (fun line -> line <> "") in - read_line 10000 (* Limit line length to 10,000 chars *) - with End_of_file -> !modules - in - - let result = read_modules module_count 200000 in - (* Limit iterations to prevent infinite loops *) - close_in ic; - - (* Cache the results *) - Cache.cache_ast_data ~verbose ~skip_cache ast_path result; - - result + Cache.cache_ast_data ~verbose ~skip_cache ast_path modules; + Some modules) with e -> if verbose then Printf.printf "Error reading AST file %s: %s\n" ast_path (Printexc.to_string e); - []) + None) (* Get the CMT file path for a source file based on cmt file patterns *) let get_cmt_path_for_source source_file = @@ -396,17 +376,18 @@ module DependencyExtractor = struct module_name ast_path; (* Get the module list from the AST file *) - let modules = read_ast_file ~verbose ~skip_cache ast_path in - - (* Convert to a set for O(1) lookup *) - let module StringSet = Set.Make (String) in - let modules_set = StringSet.of_list modules in - - (* Efficient set membership check *) - let canonical_module_name = normalize_module_name module_name in let result = - StringSet.mem module_name modules_set - || StringSet.mem canonical_module_name modules_set + match read_ast_file ~verbose ~skip_cache ast_path with + | None -> true (* Unreadable header, conservatively keep it *) + | Some modules -> + (* Convert to a set for O(1) lookup *) + let module StringSet = Set.Make (String) in + let modules_set = StringSet.of_list modules in + + (* Efficient set membership check *) + let canonical_module_name = normalize_module_name module_name in + StringSet.mem module_name modules_set + || StringSet.mem canonical_module_name modules_set in (* Cache the result *) @@ -420,90 +401,95 @@ module DependencyExtractor = struct result) - (* Batch check for module usage to avoid repeated file operations *) + (* Batch check for module usage to avoid repeated file operations. + [ast_path] defaults to the AST file next to the CMT of [source_file]. *) let batch_check_modules_usage ?(verbose = false) ?(skip_cache = false) - source_file modules = - (* Get corresponding CMT file to find AST file in the same location *) - let cmt_path = get_cmt_path_for_source source_file in - let ast_path = get_ast_path cmt_path in + ?ast_path source_file modules = + let ast_path = + match ast_path with + | Some ast_path -> ast_path + | None -> get_ast_path (get_cmt_path_for_source source_file) + in if verbose then Printf.printf "Looking for AST file at: %s\n" ast_path; - if not (Sys.file_exists ast_path) then ( - if verbose then - Printf.printf - "AST file not found at %s, conservatively returning all modules\n" - ast_path; - - (* Cache individual results *) - List.iter - (fun module_name -> - let cache_key = source_file ^ ":" ^ module_name in - Cache.cache_ast_dependency_result ~verbose ~skip_cache cache_key true) - modules; - - modules (* Return all modules if AST file doesn't exist *)) - else ( - if verbose then - Printf.printf "Batch checking %d modules in AST file: %s\n" - (List.length modules) ast_path; - - (* Get the module list from the AST file *) - let ast_modules = read_ast_file ~verbose ~skip_cache ast_path in - - (* Convert ast_modules to a set for O(1) lookups instead of O(n) with List.mem *) - let module StringSet = Set.Make (String) in - let ast_modules_set = StringSet.of_list ast_modules in - - (* Filter modules that are present in the AST file *) - let results = - (* Add a timeout mechanism *) - let start_time = Unix.gettimeofday () in - let timeout = 5.0 in - (* 5 second timeout - longer for full list processing *) - let filtered = ref [] in - let timed_out = ref false in + match read_ast_file ~verbose ~skip_cache ast_path with + | None -> + if verbose then + Printf.printf + "AST file not found or unreadable at %s, conservatively returning \ + all modules\n" + ast_path; + (* Cache individual results *) List.iter (fun module_name -> - (* Check if we've already timed out *) - if not !timed_out then ( - if - (* Check if we've exceeded the timeout *) - Unix.gettimeofday () -. start_time > timeout - then ( - Printf.eprintf - "Warning: Timeout during batch module filtering\n"; - timed_out := true) - else - (* O(1) lookup using set instead of O(n) with List.mem *) - let canonical_module_name = normalize_module_name module_name in - let is_used = - StringSet.mem module_name ast_modules_set - || StringSet.mem canonical_module_name ast_modules_set - in + let cache_key = source_file ^ ":" ^ module_name in + Cache.cache_ast_dependency_result ~verbose ~skip_cache cache_key + true) + modules; - (* Cache individual results *) - let cache_key = source_file ^ ":" ^ module_name in - Cache.cache_ast_dependency_result ~verbose ~skip_cache cache_key - is_used; + modules (* Return all modules if the AST header is unavailable *) + | Some ast_modules -> + if verbose then + Printf.printf "Batch checking %d modules in AST file: %s\n" + (List.length modules) ast_path; + + (* Convert ast_modules to a set for O(1) lookups instead of O(n) with List.mem *) + let module StringSet = Set.Make (String) in + let ast_modules_set = StringSet.of_list ast_modules in + + (* Filter modules that are present in the AST file *) + let results = + (* Add a timeout mechanism *) + let start_time = Unix.gettimeofday () in + let timeout = 5.0 in + (* 5 second timeout - longer for full list processing *) + let filtered = ref [] in + let timed_out = ref false in + + List.iter + (fun module_name -> + (* Check if we've already timed out *) + if not !timed_out then ( + if + (* Check if we've exceeded the timeout *) + Unix.gettimeofday () -. start_time > timeout + then ( + Printf.eprintf + "Warning: Timeout during batch module filtering\n"; + timed_out := true) + else + (* O(1) lookup using set instead of O(n) with List.mem *) + let canonical_module_name = + normalize_module_name module_name + in + let is_used = + StringSet.mem module_name ast_modules_set + || StringSet.mem canonical_module_name ast_modules_set + in - (* Add to filtered results if used *) - if is_used then filtered := module_name :: !filtered)) - modules; + (* Cache individual results *) + let cache_key = source_file ^ ":" ^ module_name in + Cache.cache_ast_dependency_result ~verbose ~skip_cache + cache_key is_used; - (* If we timed out, conservatively return all modules *) - if !timed_out then ( - if verbose then Printf.printf "Timed out, returning all modules\n"; - modules) - else List.rev !filtered - in + (* Add to filtered results if used *) + if is_used then filtered := module_name :: !filtered)) + modules; - if verbose then - Printf.printf "Filtered %d out of %d modules in AST file\n" - (List.length results) (List.length modules); + (* If we timed out, conservatively return all modules *) + if !timed_out then ( + if verbose then Printf.printf "Timed out, returning all modules\n"; + modules) + else List.rev !filtered + in - results) + if verbose then + Printf.printf "Filtered %d out of %d modules in AST file\n" + (List.length results) (List.length modules); + + results (* Legacy source file checking function - kept for backward compatibility *) let is_module_used_in_source ?(verbose = false) source_file module_name = @@ -563,9 +549,10 @@ module DependencyExtractor = struct Printf.printf "Error reading source file %s\n" source_file; true (* In case of file reading failure, conservatively return true *) - (* Extract dependencies from cmt_info structure *) + (* Extract dependencies from cmt_info structure. [cmt_path] is the file the + info was read from; the AST file next to it filters the imports. *) let extract_dependencies_from_cmt_info ?(verbose = false) - ?(skip_cache = false) cmt_info = + ?(skip_cache = false) ?cmt_path cmt_info = let deps = ref [] in (* Check source file path - directly use cmt_sourcefile *) @@ -598,16 +585,19 @@ module DependencyExtractor = struct cmt_info.Cmt_format.cmt_imports with _ -> ()); - (* If we have a valid source file, do batch filtering *) - if source_file <> "" then - let filtered_deps = - batch_check_modules_usage ~verbose ~skip_cache source_file - !potential_deps - in - deps := filtered_deps - else - (* If no source file, include all potential dependencies *) - deps := !potential_deps; + (* Filter the imports by the module references in the AST file *) + (match cmt_path with + | Some cmt_path -> + deps := + batch_check_modules_usage ~verbose ~skip_cache + ~ast_path:(get_ast_path cmt_path) cmt_path !potential_deps + | None when source_file <> "" -> + deps := + batch_check_modules_usage ~verbose ~skip_cache source_file + !potential_deps + | None -> + (* If no source file, include all potential dependencies *) + deps := !potential_deps); (* Return unique dependencies *) List.sort_uniq String.compare !deps @@ -814,7 +804,7 @@ let parse_cmt_file ?(verbose = false) ?(skip_cache = false) path = (* Extract dependencies from cmt_info *) let dependencies = DependencyExtractor.extract_dependencies_from_cmt_info ~verbose - ~skip_cache cmt_info + ~skip_cache ~cmt_path:path cmt_info in (* Filter out self-references and normalize *) @@ -848,6 +838,7 @@ let parse_cmt_file ?(verbose = false) ?(skip_cache = false) path = interface_digest = cmt_info.cmt_interface_digest; implementation_digest = cmt_info.cmt_source_digest; file_path; + cmt_path = Some path; } in @@ -880,7 +871,7 @@ let get_project_modules paths = (fun file -> let path = Filename.concat dir file in if Sys.is_directory path then scan_dir_for_modules path - else if Filename.check_suffix file ".cmt" then + else if is_module_cmt path then let name = Filename.basename file |> Filename.remove_extension |> normalize_module_name @@ -895,7 +886,7 @@ let get_project_modules paths = List.iter (fun path -> if Sys.is_directory path then scan_dir_for_modules path - else if Filename.check_suffix path ".cmt" then + else if is_module_cmt path then let name = Filename.basename path |> Filename.remove_extension |> normalize_module_name @@ -954,7 +945,7 @@ let parse_files_or_dirs ?(verbose = false) ?(skip_cache = false) paths = let dir_cmt_files = scan_directory path in cmt_files := dir_cmt_files @ !cmt_files; collect rest) - else if Filename.check_suffix path ".cmt" then ( + else if is_module_cmt path then ( cmt_files := path :: !cmt_files; collect rest) else collect rest diff --git a/lib/typed_ast.ml b/lib/typed_ast.ml new file mode 100644 index 0000000..a0951b1 --- /dev/null +++ b/lib/typed_ast.ml @@ -0,0 +1,230 @@ +(* typed_ast.ml - Version-neutral view of typed implementations + + CMT files are marshalled without type information. Reading one with the + typedtree definition of another ReScript release misinterprets constructor + tags and can crash the process, so this module decodes the typed + implementation with the layout of the compiler that wrote it and keeps only + what value usage analysis needs. *) + +open Stdlib + +type expr = + | Ident of string list (** Resolved value path, e.g. ["Utils"; "U"; "f"] *) + | Let of binding list * expr + | Struct of item list (** Local or first-class module structure *) + | Node of expr list (** Any other expression, by its sub-expressions *) + +and binding = { + name : string option; (** [None] unless the pattern is a plain variable *) + line : int; + expr : expr; +} + +and item = + | Values of binding list + | Module of string * item list + | Include of item list + | Eval of expr + +type layout = Rescript_11 | Rescript_12 + +exception Unsupported_layout of string + +(* ReScript 12 appended [cmt_extra_info] to [cmt_infos], which tells the two + typedtree layouts apart without trusting anything inside the tree. *) +let detect_layout (cmt_info : Cmt_format.cmt_infos) = + match Obj.size (Obj.repr cmt_info) with + | 13 -> Rescript_11 + | 14 -> Rescript_12 + | fields -> + raise + (Unsupported_layout + (Printf.sprintf "unknown cmt_infos layout with %d fields" fields)) + +let rec path_to_list = function + | Path.Pident id -> [ Ident.name id ] + | Path.Pdot (p, s, _) -> path_to_list p @ [ s ] + | Path.Papply _ as p -> [ Path.name p ] + +let option_to_list f = function Some x -> [ f x ] | None -> [] + +module V11 = struct + open Typedtree + + let rec expr e = + match e.exp_desc with + | Texp_ident (path, _, _) -> Ident (path_to_list path) + | Texp_let (_, vbs, body) -> Let (List.map binding vbs, expr body) + | Texp_function { cases; _ } -> Node (List.concat_map case cases) + | Texp_apply (f, args) -> + Node + (expr f :: List.filter_map (fun (_, arg) -> Option.map expr arg) args) + | Texp_match (e, cases, exn_cases, _) -> + Node (expr e :: List.concat_map case (cases @ exn_cases)) + | Texp_try (e, cases) -> Node (expr e :: List.concat_map case cases) + | Texp_tuple es | Texp_array es | Texp_construct (_, _, es) -> + Node (List.map expr es) + | Texp_variant (_, eo) -> Node (option_to_list expr eo) + | Texp_record { fields; extended_expression; _ } -> + let overridden = + Array.to_list fields + |> List.filter_map (function + | _, Overridden (_, e) -> Some (expr e) + | _, Kept _ -> None) + in + Node (overridden @ option_to_list expr extended_expression) + | Texp_field (e, _, _) + | Texp_assert e + | Texp_lazy e + | Texp_letexception (_, e) -> + Node [ expr e ] + | Texp_setfield (e1, _, _, e2) | Texp_sequence (e1, e2) | Texp_while (e1, e2) + -> + Node [ expr e1; expr e2 ] + | Texp_ifthenelse (e1, e2, eo) -> + Node (expr e1 :: expr e2 :: option_to_list expr eo) + | Texp_for (_, _, e1, e2, _, e3) -> Node [ expr e1; expr e2; expr e3 ] + | Texp_send (e, _, eo) -> Node (expr e :: option_to_list expr eo) + | Texp_letmodule (_, _, m, body) -> Node [ module_expr m; expr body ] + | Texp_pack m -> module_expr m + | Texp_constant _ | Texp_new _ | Texp_instvar _ | Texp_setinstvar _ + | Texp_override _ | Texp_object _ | Texp_unreachable + | Texp_extension_constructor _ -> + Node [] + + and case c = option_to_list expr c.c_guard @ [ expr c.c_rhs ] + + and binding vb = + let name = + match vb.vb_pat.pat_desc with + | Tpat_var (id, _) -> Some (Ident.name id) + | _ -> None + in + { + name; + line = vb.vb_pat.pat_loc.loc_start.pos_lnum; + expr = expr vb.vb_expr; + } + + and module_expr m = + match m.mod_desc with + | Tmod_ident _ -> Node [] + | Tmod_structure s -> Struct (structure s) + | Tmod_functor (_, _, _, body) | Tmod_constraint (body, _, _, _) -> + module_expr body + | Tmod_apply (f, arg, _) -> Node [ module_expr f; module_expr arg ] + | Tmod_unpack (e, _) -> expr e + + and module_items m = + match module_expr m with Struct items -> items | e -> [ Eval e ] + + and structure s = + List.concat_map + (fun item -> + match item.str_desc with + | Tstr_eval (e, _) -> [ Eval (expr e) ] + | Tstr_value (_, vbs) -> [ Values (List.map binding vbs) ] + | Tstr_module mb -> + [ Module (Ident.name mb.mb_id, module_items mb.mb_expr) ] + | Tstr_recmodule mbs -> + List.map + (fun mb -> Module (Ident.name mb.mb_id, module_items mb.mb_expr)) + mbs + | Tstr_include (incl : include_declaration) -> + [ Include (module_items incl.incl_mod) ] + | _ -> []) + s.str_items +end + +module V12 = struct + open Typedtree_v12 + + let rec expr e = + match e.exp_desc with + | Texp_ident (path, _, _) -> Ident (path_to_list path) + | Texp_let (_, vbs, body) -> Let (List.map binding vbs, expr body) + | Texp_function { case = c; _ } -> Node (case c) + | Texp_apply { funct; args; _ } -> + Node + (expr funct + :: List.filter_map (fun (_, arg) -> Option.map expr arg) args) + | Texp_match (e, cases, exn_cases, _) -> + Node (expr e :: List.concat_map case (cases @ exn_cases)) + | Texp_try (e, cases) -> Node (expr e :: List.concat_map case cases) + | Texp_tuple es | Texp_array es | Texp_construct (_, _, es) -> + Node (List.map expr es) + | Texp_variant (_, eo) -> Node (option_to_list expr eo) + | Texp_record { fields; extended_expression; _ } -> + let overridden = + Array.to_list fields + |> List.filter_map (function + | _, Overridden (_, e), _ -> Some (expr e) + | _, Kept _, _ -> None) + in + Node (overridden @ option_to_list expr extended_expression) + | Texp_field (e, _, _) | Texp_assert e | Texp_letexception (_, e) -> + Node [ expr e ] + | Texp_setfield (e1, _, _, e2) | Texp_sequence (e1, e2) | Texp_while (e1, e2) + -> + Node [ expr e1; expr e2 ] + | Texp_ifthenelse (e1, e2, eo) -> + Node (expr e1 :: expr e2 :: option_to_list expr eo) + | Texp_for (_, _, e1, e2, _, e3) -> Node [ expr e1; expr e2; expr e3 ] + | Texp_send (e, _, eo) -> Node (expr e :: option_to_list expr eo) + | Texp_letmodule (_, _, m, body) -> Node [ module_expr m; expr body ] + | Texp_pack m -> module_expr m + | Texp_constant _ | Texp_extension_constructor _ -> Node [] + + and case c = option_to_list expr c.c_guard @ [ expr c.c_rhs ] + + and binding vb = + let name = + match vb.vb_pat.pat_desc with + | Tpat_var (id, _) -> Some (Ident.name id) + | _ -> None + in + { + name; + line = vb.vb_pat.pat_loc.loc_start.pos_lnum; + expr = expr vb.vb_expr; + } + + and module_expr m = + match m.mod_desc with + | Tmod_ident _ -> Node [] + | Tmod_structure s -> Struct (structure s) + | Tmod_functor (_, _, _, body) | Tmod_constraint (body, _, _, _) -> + module_expr body + | Tmod_apply (f, arg, _) -> Node [ module_expr f; module_expr arg ] + | Tmod_unpack (e, _) -> expr e + + and module_items m = + match module_expr m with Struct items -> items | e -> [ Eval e ] + + and structure s = + List.concat_map + (fun item -> + match item.str_desc with + | Tstr_eval (e, _) -> [ Eval (expr e) ] + | Tstr_value (_, vbs) -> [ Values (List.map binding vbs) ] + | Tstr_module mb -> + [ Module (Ident.name mb.mb_id, module_items mb.mb_expr) ] + | Tstr_recmodule mbs -> + List.map + (fun mb -> Module (Ident.name mb.mb_id, module_items mb.mb_expr)) + mbs + | Tstr_include incl -> [ Include (module_items incl.incl_mod) ] + | _ -> []) + s.str_items +end + +(* Decode the typed implementation of a CMT file, or [None] for interfaces and + partial (error-recovery) annotations. *) +let implementation (cmt_info : Cmt_format.cmt_infos) = + match cmt_info.cmt_annots with + | Cmt_format.Implementation structure -> ( + match detect_layout cmt_info with + | Rescript_11 -> Some (V11.structure structure) + | Rescript_12 -> + Some (V12.structure (Obj.magic structure : Typedtree_v12.structure))) + | _ -> None diff --git a/test/dune b/test/dune index 043d521..7d2b343 100644 --- a/test/dune +++ b/test/dune @@ -12,12 +12,14 @@ test_rescriptdep test_cmt_imports test_cmt_values - test_ast) + test_ast + test_value_usage) (modules test_rescriptdep test_cmt_imports test_cmt_values - test_ast) + test_ast + test_value_usage) (libraries rescriptdep str test_support)) (executable diff --git a/test/fixtures/rescript12_basic.json b/test/fixtures/rescript12_basic.json new file mode 100644 index 0000000..b7cfe71 --- /dev/null +++ b/test/fixtures/rescript12_basic.json @@ -0,0 +1,109 @@ +{ + "modules": [ + { + "name": "App", + "path": "test/rescript12/basic/src/app.res", + "dependencies": [ + { + "name": "Comp0", + "path": "test/rescript12/basic/src/comp0.res" + }, + { + "name": "Logger", + "path": "test/rescript12/basic/src/logger.res" + }, + { + "name": "MathUtil", + "path": "test/rescript12/basic/src/mathUtil.res" + }, + { + "name": "React", + "path": "test/rescript12/basic/node_modules/@rescript/react/src" + } + ], + "dependents": [], + "fan_in": 0, + "fan_out": 4, + "in_cycle": false + }, + { + "name": "Comp0", + "path": "test/rescript12/basic/src/comp0.res", + "dependencies": [ + { + "name": "React", + "path": "test/rescript12/basic/node_modules/@rescript/react/src" + }, + { + "name": "ReactDOM", + "path": "test/rescript12/basic/node_modules/@rescript/react/src" + } + ], + "dependents": [ + { + "name": "App", + "path": "test/rescript12/basic/src/app.res" + } + ], + "fan_in": 1, + "fan_out": 2, + "in_cycle": false + }, + { + "name": "Logger", + "path": "test/rescript12/basic/src/logger.res", + "dependencies": [], + "dependents": [ + { + "name": "App", + "path": "test/rescript12/basic/src/app.res" + } + ], + "fan_in": 1, + "fan_out": 0, + "in_cycle": false + }, + { + "name": "MathUtil", + "path": "test/rescript12/basic/src/mathUtil.res", + "dependencies": [ + { + "name": "Utils", + "path": "test/rescript12/basic/src/utils.res" + } + ], + "dependents": [ + { + "name": "App", + "path": "test/rescript12/basic/src/app.res" + } + ], + "fan_in": 1, + "fan_out": 1, + "in_cycle": false + }, + { + "name": "Utils", + "path": "test/rescript12/basic/src/utils.res", + "dependencies": [], + "dependents": [ + { + "name": "MathUtil", + "path": "test/rescript12/basic/src/mathUtil.res" + } + ], + "fan_in": 1, + "fan_out": 0, + "in_cycle": false + } + ], + "cycles": [], + "metrics": { + "total_modules": 5, + "average_fan_in": 0.8, + "average_fan_out": 1.4, + "most_depended_upon": {"module": "Comp0", "count": 1}, + "most_dependencies": {"module": "App", "count": 4}, + "cycles_count": 0 + } +} diff --git a/test/fixtures/rescript12_namespaced.json b/test/fixtures/rescript12_namespaced.json new file mode 100644 index 0000000..2bca24e --- /dev/null +++ b/test/fixtures/rescript12_namespaced.json @@ -0,0 +1,109 @@ +{ + "modules": [ + { + "name": "App", + "path": "test/rescript12/namespaced/src/app.res", + "dependencies": [ + { + "name": "Comp0", + "path": "test/rescript12/namespaced/src/comp0.res" + }, + { + "name": "Logger", + "path": "test/rescript12/namespaced/src/logger.res" + }, + { + "name": "MathUtil", + "path": "test/rescript12/namespaced/src/mathUtil.res" + }, + { + "name": "React", + "path": "test/rescript12/namespaced/node_modules/@rescript/react/src" + } + ], + "dependents": [], + "fan_in": 0, + "fan_out": 4, + "in_cycle": false + }, + { + "name": "Comp0", + "path": "test/rescript12/namespaced/src/comp0.res", + "dependencies": [ + { + "name": "React", + "path": "test/rescript12/namespaced/node_modules/@rescript/react/src" + }, + { + "name": "ReactDOM", + "path": "test/rescript12/namespaced/node_modules/@rescript/react/src" + } + ], + "dependents": [ + { + "name": "App", + "path": "test/rescript12/namespaced/src/app.res" + } + ], + "fan_in": 1, + "fan_out": 2, + "in_cycle": false + }, + { + "name": "Logger", + "path": "test/rescript12/namespaced/src/logger.res", + "dependencies": [], + "dependents": [ + { + "name": "App", + "path": "test/rescript12/namespaced/src/app.res" + } + ], + "fan_in": 1, + "fan_out": 0, + "in_cycle": false + }, + { + "name": "MathUtil", + "path": "test/rescript12/namespaced/src/mathUtil.res", + "dependencies": [ + { + "name": "Utils", + "path": "test/rescript12/namespaced/src/utils.res" + } + ], + "dependents": [ + { + "name": "App", + "path": "test/rescript12/namespaced/src/app.res" + } + ], + "fan_in": 1, + "fan_out": 1, + "in_cycle": false + }, + { + "name": "Utils", + "path": "test/rescript12/namespaced/src/utils.res", + "dependencies": [], + "dependents": [ + { + "name": "MathUtil", + "path": "test/rescript12/namespaced/src/mathUtil.res" + } + ], + "fan_in": 1, + "fan_out": 0, + "in_cycle": false + } + ], + "cycles": [], + "metrics": { + "total_modules": 5, + "average_fan_in": 0.8, + "average_fan_out": 1.4, + "most_depended_upon": {"module": "Comp0", "count": 1}, + "most_dependencies": {"module": "App", "count": 4}, + "cycles_count": 0 + } +} diff --git a/test/rescript12/.gitignore b/test/rescript12/.gitignore new file mode 100644 index 0000000..1c0764b --- /dev/null +++ b/test/rescript12/.gitignore @@ -0,0 +1,3 @@ +lib +node_modules +.DS_Store diff --git a/test/rescript12/basic/package.json b/test/rescript12/basic/package.json new file mode 100644 index 0000000..acfd8d4 --- /dev/null +++ b/test/rescript12/basic/package.json @@ -0,0 +1,14 @@ +{ + "name": "rescript12-basic", + "version": "0.0.0", + "private": true, + "scripts": { + "res:build": "rescript build" + }, + "dependencies": { + "@rescript/react": "0.15.0", + "react": "^19.1.0", + "react-dom": "^19.1.0", + "rescript": "12.3.1" + } +} diff --git a/test/rescript12/basic/rescript.json b/test/rescript12/basic/rescript.json new file mode 100644 index 0000000..216ea8f --- /dev/null +++ b/test/rescript12/basic/rescript.json @@ -0,0 +1,18 @@ +{ + "name": "rescript12-basic", + "sources": [ + { + "dir": "src", + "subdirs": true + } + ], + "package-specs": { + "module": "esmodule", + "in-source": false + }, + "suffix": ".res.mjs", + "dependencies": ["@rescript/react"], + "jsx": { + "version": 4 + } +} diff --git a/test/rescript12/basic/src/app.res b/test/rescript12/basic/src/app.res new file mode 100644 index 0000000..5c1cfa0 --- /dev/null +++ b/test/rescript12/basic/src/app.res @@ -0,0 +1,11 @@ +module M = { + @react.component + let make = (~p as _) => +} + +let run = () => { + let result = MathUtil.square(5) + Logger.log(`Result: ${result->Belt.Int.toString}`) + + +} diff --git a/test/rescript12/basic/src/comp0.res b/test/rescript12/basic/src/comp0.res new file mode 100644 index 0000000..ccee0b7 --- /dev/null +++ b/test/rescript12/basic/src/comp0.res @@ -0,0 +1,6 @@ +@react.component +let make = () => { +
+

{"comp0"->React.string}

+
+} diff --git a/test/rescript12/basic/src/logger.res b/test/rescript12/basic/src/logger.res new file mode 100644 index 0000000..a1f75ec --- /dev/null +++ b/test/rescript12/basic/src/logger.res @@ -0,0 +1 @@ +let log = message => Console.log(message) diff --git a/test/rescript12/basic/src/mathUtil.res b/test/rescript12/basic/src/mathUtil.res new file mode 100644 index 0000000..2ffcc1b --- /dev/null +++ b/test/rescript12/basic/src/mathUtil.res @@ -0,0 +1,22 @@ +open Utils + +let square = x => multiply(x, x) +let double = x => add(x, x) +let quadruple = x => U.quadruple(x) + +module M = { + let triple = x => multiply(x, 3) + let divide = (x, y) => divide(x, y) +} + +let is_whitelisted = module_name => { + try { + Belt.Array.some(whitelist, name => name == module_name) + } catch { + | _ => false + } +} + +external f0: {..} => int = "f0" + +let v0 = f0({"a": U.triple(0)}) diff --git a/test/rescript12/basic/src/utils.res b/test/rescript12/basic/src/utils.res new file mode 100644 index 0000000..ca3c0e6 --- /dev/null +++ b/test/rescript12/basic/src/utils.res @@ -0,0 +1,24 @@ +let add = (a, b) => a + b +let multiply = (a, b) => a * b +let triple = x => multiply(x, 3) +let quadruple = x => multiply(x, 4) + +module U = { + let triple = x => multiply(x, 3) + let quadruple = x => multiply(x, 4) +} + +let divide = (a, b) => { + let divider = (a, b) => a / b + divider(a, b) +} + +let whitelist = ["math"] + +let is_whitelisted = module_name => { + try { + Belt.Array.some(whitelist, name => name == module_name) + } catch { + | _ => false + } +} diff --git a/test/rescript12/namespaced/package.json b/test/rescript12/namespaced/package.json new file mode 100644 index 0000000..7f4fcc6 --- /dev/null +++ b/test/rescript12/namespaced/package.json @@ -0,0 +1,14 @@ +{ + "name": "rescript12-namespaced", + "version": "0.0.0", + "private": true, + "scripts": { + "res:build": "rescript build" + }, + "dependencies": { + "@rescript/react": "0.15.0", + "react": "^19.1.0", + "react-dom": "^19.1.0", + "rescript": "12.3.1" + } +} diff --git a/test/rescript12/namespaced/rescript.json b/test/rescript12/namespaced/rescript.json new file mode 100644 index 0000000..209940e --- /dev/null +++ b/test/rescript12/namespaced/rescript.json @@ -0,0 +1,19 @@ +{ + "name": "rescript12-namespaced", + "namespace": true, + "sources": [ + { + "dir": "src", + "subdirs": true + } + ], + "package-specs": { + "module": "esmodule", + "in-source": false + }, + "suffix": ".res.mjs", + "dependencies": ["@rescript/react"], + "jsx": { + "version": 4 + } +} diff --git a/test/rescript12/namespaced/src/app.res b/test/rescript12/namespaced/src/app.res new file mode 100644 index 0000000..5c1cfa0 --- /dev/null +++ b/test/rescript12/namespaced/src/app.res @@ -0,0 +1,11 @@ +module M = { + @react.component + let make = (~p as _) => +} + +let run = () => { + let result = MathUtil.square(5) + Logger.log(`Result: ${result->Belt.Int.toString}`) + + +} diff --git a/test/rescript12/namespaced/src/comp0.res b/test/rescript12/namespaced/src/comp0.res new file mode 100644 index 0000000..ccee0b7 --- /dev/null +++ b/test/rescript12/namespaced/src/comp0.res @@ -0,0 +1,6 @@ +@react.component +let make = () => { +
+

{"comp0"->React.string}

+
+} diff --git a/test/rescript12/namespaced/src/logger.res b/test/rescript12/namespaced/src/logger.res new file mode 100644 index 0000000..a1f75ec --- /dev/null +++ b/test/rescript12/namespaced/src/logger.res @@ -0,0 +1 @@ +let log = message => Console.log(message) diff --git a/test/rescript12/namespaced/src/mathUtil.res b/test/rescript12/namespaced/src/mathUtil.res new file mode 100644 index 0000000..2ffcc1b --- /dev/null +++ b/test/rescript12/namespaced/src/mathUtil.res @@ -0,0 +1,22 @@ +open Utils + +let square = x => multiply(x, x) +let double = x => add(x, x) +let quadruple = x => U.quadruple(x) + +module M = { + let triple = x => multiply(x, 3) + let divide = (x, y) => divide(x, y) +} + +let is_whitelisted = module_name => { + try { + Belt.Array.some(whitelist, name => name == module_name) + } catch { + | _ => false + } +} + +external f0: {..} => int = "f0" + +let v0 = f0({"a": U.triple(0)}) diff --git a/test/rescript12/namespaced/src/utils.res b/test/rescript12/namespaced/src/utils.res new file mode 100644 index 0000000..ca3c0e6 --- /dev/null +++ b/test/rescript12/namespaced/src/utils.res @@ -0,0 +1,24 @@ +let add = (a, b) => a + b +let multiply = (a, b) => a * b +let triple = x => multiply(x, 3) +let quadruple = x => multiply(x, 4) + +module U = { + let triple = x => multiply(x, 3) + let quadruple = x => multiply(x, 4) +} + +let divide = (a, b) => { + let divider = (a, b) => a / b + divider(a, b) +} + +let whitelist = ["math"] + +let is_whitelisted = module_name => { + try { + Belt.Array.some(whitelist, name => name == module_name) + } catch { + | _ => false + } +} diff --git a/test/rescript12/package.json b/test/rescript12/package.json new file mode 100644 index 0000000..c0c049f --- /dev/null +++ b/test/rescript12/package.json @@ -0,0 +1,10 @@ +{ + "name": "rescript12-fixtures", + "version": "0.0.0", + "private": true, + "description": "ReScript 12 fixture projects for rescriptdep tests", + "scripts": { + "res:build": "pnpm -r res:build" + }, + "packageManager": "pnpm@10.33.0" +} diff --git a/test/rescript12/pnpm-lock.yaml b/test/rescript12/pnpm-lock.yaml new file mode 100644 index 0000000..4e1084d --- /dev/null +++ b/test/rescript12/pnpm-lock.yaml @@ -0,0 +1,142 @@ +lockfileVersion: '9.0' + +settings: + autoInstallPeers: true + excludeLinksFromLockfile: false + +importers: + + .: {} + + basic: + dependencies: + '@rescript/react': + specifier: 0.15.0 + version: 0.15.0(@rescript/runtime@12.3.1)(react-dom@19.3.1(react@19.3.1))(react@19.3.1) + react: + specifier: ^19.1.0 + version: 19.3.1 + react-dom: + specifier: ^19.1.0 + version: 19.3.1(react@19.3.1) + rescript: + specifier: 12.3.1 + version: 12.3.1 + + namespaced: + dependencies: + '@rescript/react': + specifier: 0.15.0 + version: 0.15.0(@rescript/runtime@12.3.1)(react-dom@19.3.1(react@19.3.1))(react@19.3.1) + react: + specifier: ^19.1.0 + version: 19.3.1 + react-dom: + specifier: ^19.1.0 + version: 19.3.1(react@19.3.1) + rescript: + specifier: 12.3.1 + version: 12.3.1 + +packages: + + '@rescript/darwin-arm64@12.3.1': + resolution: {integrity: sha512-pwdnHhuIMH4Y5nuEwBLAMOYvGIcAVgnSZq/DWUNZJWoUr7YZpNkABJp0TFGiyYePT5ld+nvjQ40oI0rKjEWK8w==} + engines: {node: '>=20.11.0'} + cpu: [arm64] + os: [darwin] + + '@rescript/darwin-x64@12.3.1': + resolution: {integrity: sha512-Eu39cHkzoHyC18BCRqnmZnLgP42c7JhR74UBl6XhaFOzuf63tddOssgTyX9mEihzok2xFBGLpETrCvZN8Qqtkg==} + engines: {node: '>=20.11.0'} + cpu: [x64] + os: [darwin] + + '@rescript/linux-arm64@12.3.1': + resolution: {integrity: sha512-Nsk3qfDRrp9b6RI85t0xzrr8LoxwXAI678V7zpQMaRfhltYl+N5fsK66MWx9rSrv6SIWPVSyU8FrJG0MskONwQ==} + engines: {node: '>=20.11.0'} + cpu: [arm64] + os: [linux] + + '@rescript/linux-x64@12.3.1': + resolution: {integrity: sha512-CfAJ3q/y/GSwrSJCLdCdyLWWdb7kTZkl2vjC+mSAw3pMqknEyCbt4ukS64Xn8PrqxVGHIs+kdefEphU7dt77xA==} + engines: {node: '>=20.11.0'} + cpu: [x64] + os: [linux] + + '@rescript/react@0.15.0': + resolution: {integrity: sha512-qDrrgxYzxRL/pjug617u5Q4+aqEfV5g+GQnd+eCWb0XqPrKucaDzN5rirDUZPg8UrqU/AvCP8Ev5cFd+MJx88A==} + peerDependencies: + '@rescript/runtime': '>=12.0.0' + react: '>=19.2.0' + react-dom: '>=19.2.0' + + '@rescript/runtime@12.3.1': + resolution: {integrity: sha512-yTM0iTl6owyA37UEtPAZR0A3G1kFffJWb+UE6+rcG/N2kxYQnuSlNDfVvsry7l8O+o/ME6QE7Zt7efjCDGM3xg==} + + '@rescript/win32-x64@12.3.1': + resolution: {integrity: sha512-1ffFbw9IJnJmGTNshWzRcG6wQ7GkzOeWxLLrarvxI38p2aYPQKTbVovUraXpw1Jfg2bbWkm8hPMMrFIezI/pkA==} + engines: {node: '>=20.11.0'} + cpu: [x64] + os: [win32] + + react-dom@19.3.1: + resolution: {integrity: sha512-Y0bARz53lhEC1NMCASs0/j+faB/zqt3R8hpvg1e8+61ZVJ4UL0UdC4cBbXfZMcIuhrfgeILTLe+ZeBCavQPtKQ==} + peerDependencies: + react: ^19.3.1 + + react@19.3.1: + resolution: {integrity: sha512-QNhWdt7nrgVWWQG58QuGsAR3jv3Hbe4mb4vz7w2csnHavciZJgda1CPNaldF6eVxv90ud3jUXpKlHL69gO38yw==} + engines: {node: '>=0.10.0'} + + rescript@12.3.1: + resolution: {integrity: sha512-Q4y0SQ7EUShiX1ymEG5iOCGzbVSOh7CCLEnQUkq19FX2i64eQ2uEGeMCKFl0AsL7TcK5pS+66QTSP6jf6LSgaA==} + engines: {node: '>=20.11.0'} + hasBin: true + + scheduler@0.28.0: + resolution: {integrity: sha512-juorfCmIkIw8tT+p5BXSm6PJjQF/ycEYmKyzURCIt/RaZIhL+PulbQ9Yu2z1HdOJDdqDTlxA1+xKBmHXJsczAw==} + +snapshots: + + '@rescript/darwin-arm64@12.3.1': + optional: true + + '@rescript/darwin-x64@12.3.1': + optional: true + + '@rescript/linux-arm64@12.3.1': + optional: true + + '@rescript/linux-x64@12.3.1': + optional: true + + '@rescript/react@0.15.0(@rescript/runtime@12.3.1)(react-dom@19.3.1(react@19.3.1))(react@19.3.1)': + dependencies: + '@rescript/runtime': 12.3.1 + react: 19.3.1 + react-dom: 19.3.1(react@19.3.1) + + '@rescript/runtime@12.3.1': {} + + '@rescript/win32-x64@12.3.1': + optional: true + + react-dom@19.3.1(react@19.3.1): + dependencies: + react: 19.3.1 + scheduler: 0.28.0 + + react@19.3.1: {} + + rescript@12.3.1: + dependencies: + '@rescript/runtime': 12.3.1 + optionalDependencies: + '@rescript/darwin-arm64': 12.3.1 + '@rescript/darwin-x64': 12.3.1 + '@rescript/linux-arm64': 12.3.1 + '@rescript/linux-x64': 12.3.1 + '@rescript/win32-x64': 12.3.1 + + scheduler@0.28.0: {} diff --git a/test/rescript12/pnpm-workspace.yaml b/test/rescript12/pnpm-workspace.yaml new file mode 100644 index 0000000..f04ee94 --- /dev/null +++ b/test/rescript12/pnpm-workspace.yaml @@ -0,0 +1,3 @@ +packages: + - basic + - namespaced diff --git a/test/test_ast.ml b/test/test_ast.ml index 6c3b614..483dc6b 100644 --- a/test/test_ast.ml +++ b/test/test_ast.ml @@ -1,126 +1,47 @@ open Stdlib open Printf -(* Function to read a line from binary file *) -let read_line_bin ic = - let buf = Buffer.create 128 in - let rec read_chars () = - let c = input_char ic in - if c = '\n' then Buffer.contents buf - else ( - Buffer.add_char buf c; - read_chars ()) +(* Check that the module references read from the header of compiler-generated + .ast files match the modules each fixture source refers to. *) + +let read_module_refs ast_path = + match + Rescriptdep.Parser.DependencyExtractor.read_ast_file ~skip_cache:true + ast_path + with + | Some modules -> List.sort_uniq String.compare modules + | None -> failwith (sprintf "Could not read the AST header of %s" ast_path) + +let check_ast_fixture ~candidates ~expected = + let ast_path = + Test_support.require_existing_path + ~hint: + "AST fixture not found. Run `make test` to install the ReScript test \ + projects and build their `.ast` output first." + candidates in - try read_chars () with End_of_file -> Buffer.contents buf - -(* Module to collect unique module references *) -module StringSet = Set.Make (String) - -(* Parse module references from AST file *) -let parse_module_refs filename = - let ic = open_in_bin filename in - let modules = ref StringSet.empty in - - try - (* Read the number of modules (first 4 bytes) *) - let modules_count = try input_binary_int ic with _ -> 0 in - printf "Found %d module references in AST file\n" modules_count; - - (* Skip the newline after the count *) - let _ = try input_char ic with _ -> '\000' in - - (* Read all module references efficiently *) - let module_names = ref [] in - - let rec read_modules remaining max_iterations = - if remaining <= 0 || max_iterations <= 0 then !module_names - else - try - let buf = Buffer.create 128 in - let rec read_line max_chars = - if max_chars <= 0 then - (* Line too long, skip the rest of this line *) - try - while input_char ic <> '\n' do - () - done; - read_modules (remaining - 1) (max_iterations - 1) - with End_of_file -> !module_names - else - let c = input_char ic in - if c = '\n' then ( - let line = Buffer.contents buf in - (* Filter out file paths - only add module names *) - if - String.length line > 0 - && line.[0] <> '/' - && (String.length line <= 1 - || not (line.[0] = 'C' && line.[1] = ':')) - && line.[0] >= 'A' - && line.[0] <= 'Z' - then module_names := line :: !module_names; - read_modules (remaining - 1) (max_iterations - 1)) - else ( - Buffer.add_char buf c; - read_line (max_chars - 1)) - in - read_line 10000 (* Limit line length to 10,000 chars *) - with End_of_file -> !module_names - in - - let result = read_modules modules_count 200000 in - (* Limit iterations to prevent infinite loops *) - - (* Try to find source file path after reading modules *) - let source_path = ref "" in - let found_source_path = ref false in + let modules = read_module_refs ast_path in + printf "Module references in %s:\n" ast_path; + List.iter (printf " - %s\n") modules; + if modules <> expected then ( + printf "ERROR: expected %s\n" (String.concat ", " expected); + false) + else true - (try - let line = read_line_bin ic in - if - String.length line > 0 - && (line.[0] = '/' - || (String.length line > 1 && line.[0] = 'C' && line.[1] = ':')) - then ( - found_source_path := true; - source_path := line; - printf "Source file: %s\n" !source_path) - with End_of_file -> - if not !found_source_path then - printf "Note: Could not find source file path\n"); - - (* Add individual module names to the set *) - List.iter (fun name -> modules := StringSet.add name !modules) result; - - close_in ic; - !modules - with e -> - close_in_noerr ic; - printf "Error parsing AST file: %s\n" (Printexc.to_string e); - StringSet.empty - -(* Main function *) let () = - let ast_path = - if Array.length Sys.argv > 1 then Sys.argv.(1) - else - Test_support.require_existing_path - ~hint: - "AST fixture not found. Run `make test` to install the ReScript test \ - project and build its `.ast` output first." - [ "rescript/lib/bs/src/app.ast"; "test/rescript/lib/bs/src/app.ast" ] + if Array.length Sys.argv > 1 then ( + List.iter (printf "%s\n") (read_module_refs Sys.argv.(1)); + exit 0); + + let results = + [ + ( "rescript/lib/bs/src/app.ast", + [ "Belt"; "Comp0"; "Logger"; "Math"; "React" ] ); + ( "rescript12/basic/lib/bs/src/app.ast", + [ "Belt"; "Comp0"; "Logger"; "MathUtil"; "React" ] ); + ("rescript12/namespaced/lib/bs/src/mathUtil.ast", [ "Belt"; "U"; "Utils" ]); + ] + |> List.map (fun (ast_path, expected) -> + check_ast_fixture ~candidates:[ ast_path; "test/" ^ ast_path ] ~expected) in - - printf "Analyzing AST file: %s\n" ast_path; - - if not (Sys.file_exists ast_path) then ( - printf "Error: AST file not found at %s\n" ast_path; - exit 1); - - let modules = parse_module_refs ast_path in - - printf "\nModule references:\n"; - if StringSet.is_empty modules then printf " (No modules found)\n" - else StringSet.iter (printf " - %s\n") modules; - - exit 0 + exit (if List.for_all Fun.id results then 0 else 1) diff --git a/test/test_namespace.ml b/test/test_namespace.ml index 1acff55..a3487d9 100644 --- a/test/test_namespace.ml +++ b/test/test_namespace.ml @@ -3,11 +3,19 @@ open Stdlib let assert_true condition message = if not condition then failwith message +(* Write an AST file the way the compiler does: the byte length of the + header, "\nModuleA\nModuleB\n...", then the source path and the + marshalled AST. *) let write_ast_fixture ast_path modules = + let header = + "\n" ^ String.concat "" (List.map (fun m -> m ^ "\n") modules) + in let oc = open_out_bin ast_path in - output_binary_int oc (List.length modules); - output_char oc '\n'; - List.iter (fun module_name -> output_string oc (module_name ^ "\n")) modules; + output_binary_int oc (String.length header); + output_string oc header; + output_string oc "/project/src/Consumer.res\n"; + (* Binary AST payload that must not be read as module references *) + output_string oc "\132\149\166\190Dep02\nGarbage\n"; close_out oc let test_normalize_module_name () = @@ -113,6 +121,71 @@ let test_dependency_graph_dependents_index_updates () = (Rescriptdep.Dependency_graph.find_dependents graph "Dep02" = [ "Consumer" ]) "Expected dependents index to include updated dependency" +let test_ast_path_for_namespaced_cmt () = + assert_true + (Rescriptdep.Parser.DependencyExtractor.get_ast_path + "/project/lib/bs/src/app-MyNamespace.cmt" + = "/project/lib/bs/src/app.ast") + "Expected namespaced CMT files to resolve to the unsuffixed AST file"; + assert_true + (Rescriptdep.Parser.DependencyExtractor.get_ast_path + "/project/lib/bs/src/app.cmt" + = "/project/lib/bs/src/app.ast") + "Expected plain CMT files to resolve to the AST file next to them" + +let test_read_ast_header_only () = + let ast_path = Filename.temp_file "rescriptdep-header" ".ast" in + Fun.protect + (fun () -> + write_ast_fixture ast_path [ "Dep01"; "NS_alias" ]; + Rescriptdep.Parser.Cache.clear (); + assert_true + (Rescriptdep.Parser.DependencyExtractor.read_ast_file ast_path + = Some [ "Dep01"; "NS_alias" ]) + "Expected only the AST header to be read as module references") + ~finally:(fun () -> try Sys.remove ast_path with _ -> ()) + +let test_dependencies_filtered_by_namespaced_ast () = + let dir = Filename.concat (Filename.get_temp_dir_name ()) "rescriptdep-ns" in + (try Sys.mkdir dir 0o755 with Sys_error _ -> ()); + let cmt_path = Filename.concat dir "consumer-MyNamespace.cmt" in + let ast_path = Filename.concat dir "consumer.ast" in + Fun.protect + (fun () -> + write_ast_fixture ast_path [ "Dep01" ]; + Rescriptdep.Parser.Cache.clear (); + let cmt_info = + { + Cmt_format.cmt_modname = "Consumer-MyNamespace"; + cmt_annots = Implementation (Obj.magic ()); + cmt_value_dependencies = []; + cmt_comments = []; + cmt_args = [||]; + cmt_sourcefile = None; + cmt_builddir = ""; + cmt_loadpath = []; + cmt_source_digest = None; + cmt_initial_env = Env.empty; + cmt_imports = + [ + ("Dep01-MyNamespace", None); + ("Dep02-MyNamespace", None); + ("MyNamespace", None); + ("Stdlib_Array", None); + ]; + cmt_interface_digest = None; + cmt_use_summaries = false; + } + in + let dependencies = + Rescriptdep.Parser.DependencyExtractor.extract_dependencies_from_cmt_info + ~cmt_path cmt_info + in + assert_true + (dependencies = [ "Dep01-MyNamespace" ]) + "Expected namespaced imports to be filtered by the unsuffixed AST file") + ~finally:(fun () -> try Sys.remove ast_path with _ -> ()) + let test_batch_check_matches_canonical_and_qualified_ast_entries () = let source_file = Filename.temp_file "rescriptdep-namespace" ".res" in let ast_path = Filename.remove_extension source_file ^ ".ast" in @@ -157,5 +230,8 @@ let () = test_extract_dependencies_from_namespaced_imports (); test_focus_with_namespaced_input (); test_dependency_graph_dependents_index_updates (); + test_ast_path_for_namespaced_cmt (); + test_read_ast_header_only (); + test_dependencies_filtered_by_namespaced_ast (); test_batch_check_matches_canonical_and_qualified_ast_entries (); print_endline "Namespace handling tests passed" diff --git a/test/test_rescriptdep.ml b/test/test_rescriptdep.ml index f262a2d..216d08e 100644 --- a/test/test_rescriptdep.ml +++ b/test/test_rescriptdep.ml @@ -43,8 +43,10 @@ let compare_files file1 file2 = let cmd = Printf.sprintf "diff -q %s %s >/dev/null" file1 file2 in Sys.command cmd = 0 -(* Test rescriptdep on a specific project *) -let test_project_fixtures project_name = +(* Test rescriptdep on a specific project. [fixture_name] defaults to the + project name and names the reference JSON in test/fixtures. *) +let test_project_fixtures ?fixture_name project_name = + let fixture_name = Option.value fixture_name ~default:project_name in printf "Testing rescriptdep on %s project...\n" project_name; (* Create paths *) @@ -59,9 +61,12 @@ let test_project_fixtures project_name = ] in let reference_output = - Test_support.require_existing_path - ~hint:"Reference JSON fixture directory not found." - [ Printf.sprintf "fixtures/%s.json" project_name; Printf.sprintf "test/fixtures/%s.json" project_name ] + let fixtures_dir = + Test_support.require_existing_path + ~hint:"Reference JSON fixture directory not found." + [ "fixtures"; "test/fixtures" ] + in + Filename.concat fixtures_dir (fixture_name ^ ".json") in (* Ensure fixtures directory exists *) @@ -117,7 +122,17 @@ let test_project_fixtures project_name = let test_rescriptdep () = printf "=== Running rescriptdep dependency tests ===\n"; - test_project_fixtures "rescript" + (* Run every project even when an earlier one fails *) + let results = + [ + ("rescript", "rescript"); + ("rescript12/basic", "rescript12_basic"); + ("rescript12/namespaced", "rescript12_namespaced"); + ] + |> List.map (fun (project_name, fixture_name) -> + test_project_fixtures ~fixture_name project_name) + in + List.for_all Fun.id results (* Main execution code *) let () = diff --git a/test/test_value_usage.ml b/test/test_value_usage.ml new file mode 100644 index 0000000..12063b2 --- /dev/null +++ b/test/test_value_usage.ml @@ -0,0 +1,80 @@ +open Stdlib +open Printf + +(* Value usage counts (-vb) for the same sources compiled by ReScript 11 and + ReScript 12. Reading a CMT file with the wrong typedtree layout used to + crash the process, so every project must give the same counts. *) + +let count_usage bs_dir ~module_name ~value_name ~value_line = + Rescriptdep.Parser.clear_cache (); + let graph = + Rescriptdep.Parser.parse_files_or_dirs ~skip_cache:true [ bs_dir ] + |> Rescriptdep.Dependency_graph.build_from_module_infos + in + let focused_graph = + Rescriptdep.Dependency_graph.create_focused_graph graph module_name + in + Rescriptdep.Dependency_graph.count_value_usage_in_dependents focused_graph + ~module_name ~value_name ~value_line:(Some value_line) + +let format_counts counts = + counts + |> List.map (fun (name, count) -> sprintf "%s=%d" name count) + |> String.concat ", " + +(* [math_module] is the module defined by math.res (v11) / mathUtil.res (v12): + ReScript 12 resolves "Math" to Stdlib.Math. *) +let test_project project ~math_module = + let bs_dir = + Test_support.require_existing_path + ~hint: + "Compiled ReScript fixture project not found. Run `make test` to \ + install the fixture dependencies and build `lib/bs` first." + [ + Printf.sprintf "%s/lib/bs" project; + Printf.sprintf "test/%s/lib/bs" project; + ] + in + printf "=== Value usage in %s ===\n" project; + let cases = + [ + (* Top-level value used in its own module and through [open Utils] *) + ("Utils", "multiply", 2, [ (math_module, 2); ("Utils", 4) ]); + ("Utils", "add", 1, [ (math_module, 1); ("Utils", 0) ]); + (* Value inside a submodule, used as U.triple *) + ("Utils", "triple", 7, [ (math_module, 1); ("Utils", 0) ]); + (* Value used from a JSX component module *) + (math_module, "square", 3, [ ("App", 1); (math_module, 0) ]); + (* Local binding inside a function body *) + ("Utils", "divider", 12, [ (math_module, 0); ("Utils", 1) ]); + ("Utils", "whitelist", 16, [ (math_module, 1); ("Utils", 1) ]); + ] + in + List.for_all + (fun (module_name, value_name, value_line, expected) -> + let actual = + count_usage bs_dir ~module_name ~value_name ~value_line + |> List.sort compare + in + let expected = List.sort compare expected in + if actual = expected then ( + printf " %s.%s@%d: %s\n" module_name value_name value_line + (format_counts actual); + true) + else ( + printf " ERROR %s.%s@%d: expected %s, got %s\n" module_name value_name + value_line (format_counts expected) (format_counts actual); + false)) + cases + +let () = + let results = + [ + ("rescript", "Math"); + ("rescript12/basic", "MathUtil"); + ("rescript12/namespaced", "MathUtil"); + ] + |> List.map (fun (project, math_module) -> + test_project project ~math_module) + in + exit (if List.for_all Fun.id results then 0 else 1) diff --git a/vendor/typedtree.ml b/vendor/typedtree.ml index 39ab39c..6e714e0 100644 --- a/vendor/typedtree.ml +++ b/vendor/typedtree.ml @@ -91,20 +91,20 @@ and expression_desc = | Texp_for of unit * string * expression * expression * direction_flag * expression | Texp_send of expression * meth * expression option - | Texp_new of Path.t * unit * class_declaration - | Texp_instvar of Path.t * Path.t * string - | Texp_setinstvar of Path.t * Path.t * string * expression - | Texp_override of Path.t * (Path.t * string * expression) list + (* ReScript keeps the class constructors only as placeholders, but they + still occupy constructor tags in marshalled CMT files. *) + | Texp_new of unit + | Texp_instvar of unit + | Texp_setinstvar of unit + | Texp_override of unit | Texp_letmodule of unit * string * module_expr * expression | Texp_letexception of extension_constructor * expression | Texp_assert of expression | Texp_lazy of expression - | Texp_object of class_structure * string list + | Texp_object of unit | Texp_pack of module_expr - | Texp_letop of { let_ : binding_op; ands : binding_op list; body : case } | Texp_unreachable | Texp_extension_constructor of Location.t * Path.t - | Texp_open of open_declaration * expression and meth = Tmeth_name of string | Tmeth_val of Ident.t and case = { c_lhs : pattern; c_guard : expression option; c_rhs : expression } @@ -113,14 +113,6 @@ and record_label_definition = | Kept of Types.type_expr | Overridden of Location.t * expression -and binding_op = { - bop_op_path : Path.t; - bop_op_val : value_description; - bop_op_type : Types.type_expr; - bop_exp : expression; - bop_loc : Location.t; -} - and value_binding = { vb_pat : pattern; vb_expr : expression; diff --git a/vendor/typedtree.mli b/vendor/typedtree.mli index f42dc49..e60740c 100644 --- a/vendor/typedtree.mli +++ b/vendor/typedtree.mli @@ -18,6 +18,10 @@ (** By comparison with {!Parsetree}: - Every {!Longindent.t} is accompanied by a resolved {!Path.t}. *) +(* This mirrors the typedtree layout written by ReScript 11 and earlier. CMT + files are read with [input_value], so constructor order and arity must match + the compiler exactly. ReScript 12 uses {!Typedtree_v12}. *) + open Types type pattern = { @@ -94,20 +98,20 @@ and expression_desc = | Texp_for of unit * string * expression * expression * direction_flag * expression | Texp_send of expression * meth * expression option - | Texp_new of Path.t * unit * class_declaration - | Texp_instvar of Path.t * Path.t * string - | Texp_setinstvar of Path.t * Path.t * string * expression - | Texp_override of Path.t * (Path.t * string * expression) list + (* ReScript keeps the class constructors only as placeholders, but they + still occupy constructor tags in marshalled CMT files. *) + | Texp_new of unit + | Texp_instvar of unit + | Texp_setinstvar of unit + | Texp_override of unit | Texp_letmodule of unit * string * module_expr * expression | Texp_letexception of extension_constructor * expression | Texp_assert of expression | Texp_lazy of expression - | Texp_object of class_structure * string list + | Texp_object of unit | Texp_pack of module_expr - | Texp_letop of { let_ : binding_op; ands : binding_op list; body : case } | Texp_unreachable | Texp_extension_constructor of Location.t * Path.t - | Texp_open of open_declaration * expression and meth = Tmeth_name of string | Tmeth_val of Ident.t and case = { c_lhs : pattern; c_guard : expression option; c_rhs : expression } @@ -116,14 +120,6 @@ and record_label_definition = | Kept of Types.type_expr | Overridden of Location.t * expression -and binding_op = { - bop_op_path : Path.t; - bop_op_val : value_description; - bop_op_type : Types.type_expr; - bop_exp : expression; - bop_loc : Location.t; -} - and value_binding = { vb_pat : pattern; vb_expr : expression; diff --git a/vendor/typedtree_v12.ml b/vendor/typedtree_v12.ml new file mode 100644 index 0000000..3451046 --- /dev/null +++ b/vendor/typedtree_v12.ml @@ -0,0 +1,149 @@ +(* Typedtree layout written by ReScript 12 (compiler/ml/typedtree.mli). + + CMT files are read with [input_value], so constructor order and arity must + match the compiler exactly. Only the nodes that value usage analysis walks + are spelled out; everything it never inspects is kept opaque. *) + +type opaque = Obj.t + +type pattern = { + pat_desc : pattern_desc; + pat_loc : Location.t; + pat_extra : opaque; + pat_type : opaque; + mutable pat_env : opaque; + pat_attributes : opaque; +} + +and pattern_desc = + | Tpat_any + | Tpat_var of Ident.t * string Asttypes.loc + | Tpat_alias of pattern * Ident.t * string Asttypes.loc + | Tpat_constant of opaque + | Tpat_tuple of pattern list + | Tpat_construct of opaque * opaque * pattern list + | Tpat_variant of opaque * pattern option * opaque + | Tpat_record of opaque * opaque + | Tpat_array of pattern list + | Tpat_or of pattern * pattern * opaque + +and expression = { + exp_desc : expression_desc; + exp_loc : Location.t; + exp_extra : opaque; + exp_type : opaque; + exp_env : opaque; + exp_attributes : opaque; +} + +and expression_desc = + | Texp_ident of Path.t * opaque * opaque + | Texp_constant of opaque + | Texp_let of opaque * value_binding list * expression + | Texp_function of { + arg_label : opaque; + arity : opaque; + param : Ident.t; + case : case; + partial : opaque; + async : bool; + } + | Texp_apply of { + funct : expression; + args : (opaque * expression option) list; + partial : bool; + transformed_jsx : bool; + } + | Texp_match of expression * case list * case list * opaque + | Texp_try of expression * case list + | Texp_tuple of expression list + | Texp_construct of opaque * opaque * expression list + | Texp_variant of opaque * expression option + | Texp_record of { + fields : (opaque * record_label_definition * bool) array; + representation : opaque; + extended_expression : expression option; + } + | Texp_field of expression * opaque * opaque + | Texp_setfield of expression * opaque * opaque * expression + | Texp_array of expression list + | Texp_ifthenelse of expression * expression * expression option + | Texp_sequence of expression * expression + | Texp_while of expression * expression + | Texp_for of opaque * opaque * expression * expression * opaque * expression + | Texp_send of expression * opaque * expression option + | Texp_letmodule of Ident.t * opaque * module_expr * expression + | Texp_letexception of opaque * expression + | Texp_assert of expression + | Texp_pack of module_expr + | Texp_extension_constructor of opaque * Path.t + +and case = { c_lhs : pattern; c_guard : expression option; c_rhs : expression } + +and record_label_definition = + | Kept of opaque + | Overridden of opaque * expression + +and value_binding = { + vb_pat : pattern; + vb_expr : expression; + vb_attributes : opaque; + vb_loc : Location.t; +} + +and module_expr = { + mod_desc : module_expr_desc; + mod_loc : Location.t; + mod_type : opaque; + mod_env : opaque; + mod_attributes : opaque; +} + +and module_expr_desc = + | Tmod_ident of Path.t * opaque + | Tmod_structure of structure + | Tmod_functor of Ident.t * opaque * opaque * module_expr + | Tmod_apply of module_expr * module_expr * opaque + | Tmod_constraint of module_expr * opaque * opaque * opaque + | Tmod_unpack of expression * opaque + +and structure = { + str_items : structure_item list; + str_type : opaque; + str_final_env : opaque; +} + +and structure_item = { + str_desc : structure_item_desc; + str_loc : Location.t; + str_env : opaque; +} + +and structure_item_desc = + | Tstr_eval of expression * opaque + | Tstr_value of opaque * value_binding list + | Tstr_primitive of opaque + | Tstr_type of opaque * opaque + | Tstr_typext of opaque + | Tstr_exception of opaque + | Tstr_module of module_binding + | Tstr_recmodule of module_binding list + | Tstr_modtype of opaque + | Tstr_open of opaque + | Tstr_include of include_declaration + | Tstr_attribute of opaque + +and module_binding = { + mb_id : Ident.t; + mb_name : opaque; + mb_expr : module_expr; + mb_attributes : opaque; + mb_loc : Location.t; +} + +and include_declaration = { + incl_mod : module_expr; + incl_type : opaque; + incl_loc : Location.t; + incl_attributes : opaque; +} From 9e0d86ead8603383fecc9dd71a0987e2bfca7e17 Mon Sep 17 00:00:00 2001 From: mununki Date: Wed, 21 Oct 2026 12:11:56 +0900 Subject: [PATCH 2/4] Add per-compiler backends and ReScript 13 dependency analysis - Identify the compiler of each .cmt file from its magic number and cmt_infos layout (lib/compilers.ml), and decode typed trees with one backend per release (Compiler_v11, Compiler_v12) - Keep typed trees opaque in the vendored Cmt_format and accept every CMT format version when reading; rename the ReScript 11 typedtree to Typedtree_v11 - Support ReScript 13 (13.0.0-alpha.6) for the dependency graph; value usage analysis reports -6 for compilers it cannot decode yet - Stop with an error on .cmt files from unknown compilers instead of silently producing an empty graph - Skip constructors added by later releases in the decoders instead of matching on unknown tags - Add ReScript 13 fixture projects, self-contained compiler identification tests, and build fixture workspace packages one at a time so they do not corrupt their shared compiled dependencies - Document the supported ReScript versions and how to add a release --- CHANGELOG.md | 5 + CONTRIBUTING.md | 26 +++ Makefile | 3 + README.md | 17 ++ bin/main.ml | 3 +- lib/compiler_v11.ml | 104 ++++++++++ lib/compiler_v12.ml | 98 +++++++++ lib/compilers.ml | 82 ++++++++ lib/dependency_graph.ml | 11 +- lib/dune | 10 +- lib/parser.ml | 4 +- lib/typed_ast.ml | 209 ++------------------ test/dune | 4 +- test/fixtures/rescript13_basic.json | 109 ++++++++++ test/fixtures/rescript13_namespaced.json | 109 ++++++++++ test/rescript12/package.json | 2 +- test/rescript13/.gitignore | 3 + test/rescript13/basic/package.json | 14 ++ test/rescript13/basic/rescript.json | 18 ++ test/rescript13/basic/src/app.res | 11 ++ test/rescript13/basic/src/comp0.res | 6 + test/rescript13/basic/src/logger.res | 1 + test/rescript13/basic/src/mathUtil.res | 22 +++ test/rescript13/basic/src/utils.res | 24 +++ test/rescript13/namespaced/package.json | 14 ++ test/rescript13/namespaced/rescript.json | 19 ++ test/rescript13/namespaced/src/app.res | 11 ++ test/rescript13/namespaced/src/comp0.res | 6 + test/rescript13/namespaced/src/logger.res | 1 + test/rescript13/namespaced/src/mathUtil.res | 22 +++ test/rescript13/namespaced/src/utils.res | 24 +++ test/rescript13/package.json | 10 + test/rescript13/pnpm-lock.yaml | 142 +++++++++++++ test/rescript13/pnpm-workspace.yaml | 3 + test/test_ast.ml | 4 + test/test_compilers.ml | 171 ++++++++++++++++ test/test_rescriptdep.ml | 2 + test/test_value_usage.ml | 47 +++-- vendor/cmt_format.ml | 44 +++-- vendor/cmt_format.mli | 30 ++- vendor/{typedtree.ml => typedtree_v11.ml} | 0 vendor/{typedtree.mli => typedtree_v11.mli} | 7 +- 42 files changed, 1188 insertions(+), 264 deletions(-) create mode 100644 lib/compiler_v11.ml create mode 100644 lib/compiler_v12.ml create mode 100644 lib/compilers.ml create mode 100644 test/fixtures/rescript13_basic.json create mode 100644 test/fixtures/rescript13_namespaced.json create mode 100644 test/rescript13/.gitignore create mode 100644 test/rescript13/basic/package.json create mode 100644 test/rescript13/basic/rescript.json create mode 100644 test/rescript13/basic/src/app.res create mode 100644 test/rescript13/basic/src/comp0.res create mode 100644 test/rescript13/basic/src/logger.res create mode 100644 test/rescript13/basic/src/mathUtil.res create mode 100644 test/rescript13/basic/src/utils.res create mode 100644 test/rescript13/namespaced/package.json create mode 100644 test/rescript13/namespaced/rescript.json create mode 100644 test/rescript13/namespaced/src/app.res create mode 100644 test/rescript13/namespaced/src/comp0.res create mode 100644 test/rescript13/namespaced/src/logger.res create mode 100644 test/rescript13/namespaced/src/mathUtil.res create mode 100644 test/rescript13/namespaced/src/utils.res create mode 100644 test/rescript13/package.json create mode 100644 test/rescript13/pnpm-lock.yaml create mode 100644 test/rescript13/pnpm-workspace.yaml create mode 100644 test/test_compilers.ml rename vendor/{typedtree.ml => typedtree_v11.ml} (100%) rename vendor/{typedtree.mli => typedtree_v11.mli} (98%) diff --git a/CHANGELOG.md b/CHANGELOG.md index 53ad6b8..f6e09f5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,8 +10,13 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Added regression coverage for dependency graph dependent-index updates - Added ReScript 12 support for value usage analysis (`-vb`) by decoding typed trees with the layout of the compiler that wrote each `.cmt` file - Added ReScript 12 fixture projects (standard and namespaced) with dependency graph and value usage regression tests +- Added ReScript 13 (13.0.0-alpha.6) support for dependency analysis; value usage analysis reports `-6` for modules built by compilers it cannot decode yet +- Added ReScript 13 fixture projects and self-contained compiler identification tests +- Added a supported ReScript versions table to the README ### Changed +- Organized typed tree decoding into one backend per compiler release (`Compiler_v11`, `Compiler_v12`) selected by the CMT magic number and `cmt_infos` layout, with decoders skipping constructors added by later releases instead of misreading them +- `.cmt` files written by unknown compilers now stop the analysis with an error instead of silently producing an empty graph - Improved dependency graph performance by maintaining a reverse dependent index instead of scanning the full graph for each dependent lookup - Reduced VS Code inline value usage analysis work with debounced requests, short-lived result caching, and JSON output parsing diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 3743ad7..08026eb 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -42,6 +42,7 @@ The test code is located in the `test/` directory and includes: - `test_rescriptdep.ml`: Tests the dependency analysis on sample ReScript projects - `test_value_usage.ml`: Tests value usage counts on ReScript 11 and 12 projects - `test_namespace.ml`: Tests namespace handling without compiled fixtures +- `test_compilers.ml`: Tests compiler identification and typed tree decoder guards without compiled fixtures - `benchmark.ml`: Performance benchmark for the parser ### Test Fixtures @@ -55,6 +56,7 @@ The dependency analysis tests use JSON fixtures to ensure consistent behavior: - `test/fixtures/rescript.json`: Reference output for the ReScript 11 test project - `test/fixtures/rescript12_basic.json`: Reference output for the ReScript 12 test project - `test/fixtures/rescript12_namespaced.json`: Reference output for the namespaced ReScript 12 test project +- `test/fixtures/rescript13_basic.json`, `test/fixtures/rescript13_namespaced.json`: The same for ReScript 13 These fixtures are automatically generated on first run and serve as reference points for future test runs. If the dependency analysis output differs from these fixtures, the test will fail and show a diff of the changes. @@ -66,6 +68,11 @@ The test directory contains sample ReScript projects used for testing the depend - `test/rescript12/`: pnpm workspace with ReScript 12 projects built from the same sources: `basic/` (standard setup) and `namespaced/` (`"namespace": true`). `math.res` is named `mathUtil.res` there because ReScript 12 resolves `Math` to `Stdlib.Math`. +- `test/rescript13/`: The same workspace for ReScript 13, with `Belt` calls replaced by + `Stdlib` ones since ReScript 13 no longer ships `Belt`. + +The packages of a workspace share their compiled dependencies, so `res:build` builds them +one at a time (`--workspace-concurrency=1`); parallel builds corrupt the shared `.cmi` files. Each test project contains: - `src/`: Source code files (.res, .resi) @@ -84,6 +91,25 @@ When making changes that affect dependency analysis: - Run the tests again to generate new fixtures: `dune exec test/test_rescriptdep.exe` - Commit both the code changes and the updated fixtures +### Supporting a New ReScript Release + +`.cmt` files are marshalled OCaml values without type information, so they must be read with +type definitions whose constructor order and arity match the compiler exactly. Only the typed +tree used by value usage analysis (`-vb`) differs between the supported releases; the fields of +`cmt_infos` used by the dependency graph and the `.ast` header format are shared. + +To add a release: + +1. Add an entry to `all` in `lib/compilers.ml` with the release's CMT magic number (in + `compiler/ext/config.ml` of the ReScript repository) and the number of fields of its + `cmt_infos` record. This is enough for the dependency graph. +2. For value usage analysis, vendor the parts of its `compiler/ml/typedtree.mli` that are + decoded as `vendor/typedtree_vNN.ml`, keeping every constructor in order, and add a + `lib/compiler_vNN.ml` decoder with its constructor counts. `test/test_compilers.ml` checks + that the counts match the vendored definitions. +3. Add a fixture workspace (`test/rescriptNN/`), its reference JSON fixtures, and the project + to `test/test_rescriptdep.ml`, `test/test_value_usage.ml` and the `Makefile`. + ### Running the Benchmark The benchmark requires a ReScript project with compiled .cmt files to analyze: diff --git a/Makefile b/Makefile index 2be009d..b2100be 100644 --- a/Makefile +++ b/Makefile @@ -15,10 +15,12 @@ check-pnpm: install-test-deps: CI=1 pnpm --dir test/rescript install --frozen-lockfile CI=1 pnpm --dir test/rescript12 install --frozen-lockfile + CI=1 pnpm --dir test/rescript13 install --frozen-lockfile build-test-projects: pnpm --dir test/rescript run res:build pnpm --dir test/rescript12 run res:build + pnpm --dir test/rescript13 run res:build run-ocaml-tests: dune exec ./test/test_cmt_imports.exe @@ -27,3 +29,4 @@ run-ocaml-tests: dune exec ./test/test_rescriptdep.exe dune exec ./test/test_value_usage.exe dune exec ./test/test_namespace.exe + dune exec ./test/test_compilers.exe diff --git a/README.md b/README.md index ddf9de0..3a83b09 100644 --- a/README.md +++ b/README.md @@ -43,6 +43,23 @@ rescriptdep [options] files_or_dirs # -vl, --value-line : Line number of the value binding (1-based, for disambiguation when multiple bindings have the same name; use with -vb) ``` +`files_or_dirs` are compiled `.cmt` files or directories that contain them, usually the project's `lib/bs`. + +With `-vb`, each module reports its usage count, or a negative code when it could not be analyzed: +`-2` no implementation, `-3` unreadable `.cmt` file, `-4` no `.cmt` file, `-5` no file path, +`-6` the compiler that built the module is not supported by value usage analysis. + +## Supported ReScript Versions + +| ReScript | Dependency graph | Value usage (`-vb`) | +|---|---|---| +| 11.0.0 - 11.1.4 | Yes | Yes | +| 12.0.0 - 12.3.1 | Yes | Yes | +| 13.0.0-alpha.6 | Yes | Not yet (`-6`) | + +rescriptdep identifies the compiler from each `.cmt` file. Files written by other compilers are +rejected with an error instead of being misread. + ## Development For detailed information about building the project, running tests, and contributing, please see [CONTRIBUTING.md](CONTRIBUTING.md). diff --git a/bin/main.ml b/bin/main.ml index 2e8a89e..9b5ce4e 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -224,7 +224,8 @@ let main () = Printf.eprintf "[BENCH] Total execution time: %.4f seconds\n" total_time; exit 0) with - | Rescriptdep.Parser.Invalid_cmt_file msg -> + | Rescriptdep.Parser.Invalid_cmt_file msg + | Rescriptdep.Compilers.Unsupported msg -> Printf.eprintf "Error: %s\n" msg; exit 1 | Sys_error msg -> diff --git a/lib/compiler_v11.ml b/lib/compiler_v11.ml new file mode 100644 index 0000000..97475f9 --- /dev/null +++ b/lib/compiler_v11.ml @@ -0,0 +1,104 @@ +(* compiler_v11.ml - Typed tree decoder for ReScript 11 *) + +open Stdlib +open Typed_ast +open Typedtree_v11 + +(* Constructor counts (constant, non-constant) of the decoded variants *) +let expression_desc_constructors = (1, 30) +let module_expr_desc_constructors = (0, 6) +let structure_item_desc_constructors = (0, 14) + +let rec expr e = + if not (has_known_constructor expression_desc_constructors e.exp_desc) then + Node [] + else + match e.exp_desc with + | Texp_ident (path, _, _) -> Ident (path_to_list path) + | Texp_let (_, vbs, body) -> Let (List.map binding vbs, expr body) + | Texp_function { cases; _ } -> Node (List.concat_map case cases) + | Texp_apply (f, args) -> + Node + (expr f :: List.filter_map (fun (_, arg) -> Option.map expr arg) args) + | Texp_match (e, cases, exn_cases, _) -> + Node (expr e :: List.concat_map case (cases @ exn_cases)) + | Texp_try (e, cases) -> Node (expr e :: List.concat_map case cases) + | Texp_tuple es | Texp_array es | Texp_construct (_, _, es) -> + Node (List.map expr es) + | Texp_variant (_, eo) -> Node (option_to_list expr eo) + | Texp_record { fields; extended_expression; _ } -> + let overridden = + Array.to_list fields + |> List.filter_map (function + | _, Overridden (_, e) -> Some (expr e) + | _, Kept _ -> None) + in + Node (overridden @ option_to_list expr extended_expression) + | Texp_field (e, _, _) + | Texp_assert e + | Texp_lazy e + | Texp_letexception (_, e) -> + Node [ expr e ] + | Texp_setfield (e1, _, _, e2) | Texp_sequence (e1, e2) | Texp_while (e1, e2) + -> + Node [ expr e1; expr e2 ] + | Texp_ifthenelse (e1, e2, eo) -> + Node (expr e1 :: expr e2 :: option_to_list expr eo) + | Texp_for (_, _, e1, e2, _, e3) -> Node [ expr e1; expr e2; expr e3 ] + | Texp_send (e, _, eo) -> Node (expr e :: option_to_list expr eo) + | Texp_letmodule (_, _, m, body) -> Node [ module_expr m; expr body ] + | Texp_pack m -> module_expr m + | Texp_constant _ | Texp_new _ | Texp_instvar _ | Texp_setinstvar _ + | Texp_override _ | Texp_object _ | Texp_unreachable + | Texp_extension_constructor _ -> + Node [] + +and case c = option_to_list expr c.c_guard @ [ expr c.c_rhs ] + +and binding vb = + let name = + match vb.vb_pat.pat_desc with + | Tpat_var (id, _) -> Some (Ident.name id) + | _ -> None + in + { name; line = vb.vb_pat.pat_loc.loc_start.pos_lnum; expr = expr vb.vb_expr } + +and module_expr m = + if not (has_known_constructor module_expr_desc_constructors m.mod_desc) then + Node [] + else + match m.mod_desc with + | Tmod_ident _ -> Node [] + | Tmod_structure s -> Struct (structure s) + | Tmod_functor (_, _, _, body) | Tmod_constraint (body, _, _, _) -> + module_expr body + | Tmod_apply (f, arg, _) -> Node [ module_expr f; module_expr arg ] + | Tmod_unpack (e, _) -> expr e + +and module_items m = + match module_expr m with Struct items -> items | e -> [ Eval e ] + +and structure s = + List.concat_map + (fun item -> + if + not + (has_known_constructor structure_item_desc_constructors item.str_desc) + then [] + else + match item.str_desc with + | Tstr_eval (e, _) -> [ Eval (expr e) ] + | Tstr_value (_, vbs) -> [ Values (List.map binding vbs) ] + | Tstr_module mb -> + [ Module (Ident.name mb.mb_id, module_items mb.mb_expr) ] + | Tstr_recmodule mbs -> + List.map + (fun mb -> Module (Ident.name mb.mb_id, module_items mb.mb_expr)) + mbs + | Tstr_include (incl : include_declaration) -> + [ Include (module_items incl.incl_mod) ] + | _ -> []) + s.str_items + +(* Decode the [Implementation] annotation of a CMT file *) +let implementation (tree : Obj.t) = structure (Obj.obj tree : structure) diff --git a/lib/compiler_v12.ml b/lib/compiler_v12.ml new file mode 100644 index 0000000..9c15a85 --- /dev/null +++ b/lib/compiler_v12.ml @@ -0,0 +1,98 @@ +(* compiler_v12.ml - Typed tree decoder for ReScript 12 *) + +open Stdlib +open Typed_ast +open Typedtree_v12 + +(* Constructor counts (constant, non-constant) of the decoded variants *) +let expression_desc_constructors = (0, 24) +let module_expr_desc_constructors = (0, 6) +let structure_item_desc_constructors = (0, 12) + +let rec expr e = + if not (has_known_constructor expression_desc_constructors e.exp_desc) then + Node [] + else + match e.exp_desc with + | Texp_ident (path, _, _) -> Ident (path_to_list path) + | Texp_let (_, vbs, body) -> Let (List.map binding vbs, expr body) + | Texp_function { case = c; _ } -> Node (case c) + | Texp_apply { funct; args; _ } -> + Node + (expr funct + :: List.filter_map (fun (_, arg) -> Option.map expr arg) args) + | Texp_match (e, cases, exn_cases, _) -> + Node (expr e :: List.concat_map case (cases @ exn_cases)) + | Texp_try (e, cases) -> Node (expr e :: List.concat_map case cases) + | Texp_tuple es | Texp_array es | Texp_construct (_, _, es) -> + Node (List.map expr es) + | Texp_variant (_, eo) -> Node (option_to_list expr eo) + | Texp_record { fields; extended_expression; _ } -> + let overridden = + Array.to_list fields + |> List.filter_map (function + | _, Overridden (_, e), _ -> Some (expr e) + | _, Kept _, _ -> None) + in + Node (overridden @ option_to_list expr extended_expression) + | Texp_field (e, _, _) | Texp_assert e | Texp_letexception (_, e) -> + Node [ expr e ] + | Texp_setfield (e1, _, _, e2) | Texp_sequence (e1, e2) | Texp_while (e1, e2) + -> + Node [ expr e1; expr e2 ] + | Texp_ifthenelse (e1, e2, eo) -> + Node (expr e1 :: expr e2 :: option_to_list expr eo) + | Texp_for (_, _, e1, e2, _, e3) -> Node [ expr e1; expr e2; expr e3 ] + | Texp_send (e, _, eo) -> Node (expr e :: option_to_list expr eo) + | Texp_letmodule (_, _, m, body) -> Node [ module_expr m; expr body ] + | Texp_pack m -> module_expr m + | Texp_constant _ | Texp_extension_constructor _ -> Node [] + +and case c = option_to_list expr c.c_guard @ [ expr c.c_rhs ] + +and binding vb = + let name = + match vb.vb_pat.pat_desc with + | Tpat_var (id, _) -> Some (Ident.name id) + | _ -> None + in + { name; line = vb.vb_pat.pat_loc.loc_start.pos_lnum; expr = expr vb.vb_expr } + +and module_expr m = + if not (has_known_constructor module_expr_desc_constructors m.mod_desc) then + Node [] + else + match m.mod_desc with + | Tmod_ident _ -> Node [] + | Tmod_structure s -> Struct (structure s) + | Tmod_functor (_, _, _, body) | Tmod_constraint (body, _, _, _) -> + module_expr body + | Tmod_apply (f, arg, _) -> Node [ module_expr f; module_expr arg ] + | Tmod_unpack (e, _) -> expr e + +and module_items m = + match module_expr m with Struct items -> items | e -> [ Eval e ] + +and structure s = + List.concat_map + (fun item -> + if + not + (has_known_constructor structure_item_desc_constructors item.str_desc) + then [] + else + match item.str_desc with + | Tstr_eval (e, _) -> [ Eval (expr e) ] + | Tstr_value (_, vbs) -> [ Values (List.map binding vbs) ] + | Tstr_module mb -> + [ Module (Ident.name mb.mb_id, module_items mb.mb_expr) ] + | Tstr_recmodule mbs -> + List.map + (fun mb -> Module (Ident.name mb.mb_id, module_items mb.mb_expr)) + mbs + | Tstr_include incl -> [ Include (module_items incl.incl_mod) ] + | _ -> []) + s.str_items + +(* Decode the [Implementation] annotation of a CMT file *) +let implementation (tree : Obj.t) = structure (Obj.obj tree : structure) diff --git a/lib/compilers.ml b/lib/compilers.ml new file mode 100644 index 0000000..60efde8 --- /dev/null +++ b/lib/compilers.ml @@ -0,0 +1,82 @@ +(* compilers.ml - ReScript compiler releases whose build artifacts are supported + + The dependency graph only reads fields of cmt_infos that every release below + lays out the same way, plus the .ast header, whose format is shared too. + Only the typed tree used by value usage analysis differs between releases, + so each entry says how to recognize the release from the CMT file itself + and how to decode its typed tree. *) + +open Stdlib + +type t = { + name : string; + cmt_magic : string; (** Magic number of the typed tree section *) + cmt_infos_fields : int; (** Number of fields of the cmt_infos record *) + implementation : (Obj.t -> Typed_ast.item list) option; + (** [None] when value usage analysis does not support the release *) +} + +let all = + [ + { + name = "ReScript 11"; + cmt_magic = "Caml1999T022"; + cmt_infos_fields = 13; + implementation = Some Compiler_v11.implementation; + }; + { + name = "ReScript 12"; + cmt_magic = "Caml1999T022"; + cmt_infos_fields = 14; + implementation = Some Compiler_v12.implementation; + }; + { + (* The typed tree still changes between the 13.0 alpha releases *) + name = "ReScript 13"; + cmt_magic = "Caml1999T037"; + cmt_infos_fields = 14; + implementation = None; + }; + ] + +exception Unsupported of string + +let cmt_infos_fields (cmt_info : Cmt_format.cmt_infos) = + Obj.size (Obj.repr cmt_info) + +let find ~cmt_magic cmt_info = + let fields = cmt_infos_fields cmt_info in + List.find_opt + (fun compiler -> + compiler.cmt_magic = cmt_magic && compiler.cmt_infos_fields = fields) + all + +(* Read a CMT file and identify the compiler that wrote it. Files written by + unknown releases are rejected before any field of their infos is read. *) +let read_cmt path = + let cmt_magic, cmt_info = Cmt_format.read_cmt_with_magic path in + match find ~cmt_magic cmt_info with + | Some compiler -> (compiler, cmt_info) + | None -> + raise + (Unsupported + (Printf.sprintf + "%s was written by an unsupported ReScript compiler (CMT format \ + %s with %d fields). Supported compilers: %s" + path cmt_magic + (cmt_infos_fields cmt_info) + (String.concat ", " (List.map (fun c -> c.name) all)))) + +(* Decode the typed implementation of a CMT file, or [None] for interfaces and + partial (error-recovery) annotations *) +let implementation compiler (cmt_info : Cmt_format.cmt_infos) = + match cmt_info.cmt_annots with + | Cmt_format.Implementation tree -> ( + match compiler.implementation with + | Some decode -> Some (decode tree) + | None -> + raise + (Unsupported + (Printf.sprintf "Value usage analysis does not support %s yet" + compiler.name))) + | _ -> None diff --git a/lib/dependency_graph.ml b/lib/dependency_graph.ml index c2e256e..6ce5b9d 100644 --- a/lib/dependency_graph.ml +++ b/lib/dependency_graph.ml @@ -517,13 +517,14 @@ let find_cmt_path metadata = | None -> None) let read_typed_implementation cmt_path = - let cmt_info = Cmt_format.read_cmt cmt_path in - ( Typed_ast.implementation cmt_info, + let compiler, cmt_info = Compilers.read_cmt cmt_path in + ( Compilers.implementation compiler cmt_info, namespace_of_modname cmt_info.Cmt_format.cmt_modname ) (* Count value usage in dependents of a module (and in the module itself). Negative counts report why a module could not be analyzed: - -2 no implementation, -3 unreadable CMT, -4 no CMT file, -5 no file path. *) + -2 no implementation, -3 unreadable CMT, -4 no CMT file, -5 no file path, + -6 compiler not supported by value usage analysis. *) let count_value_usage_in_dependents graph ~module_name ~value_name ~value_line = let dependents = List.sort_uniq String.compare @@ -585,5 +586,7 @@ let count_value_usage_in_dependents graph ~module_name ~value_name ~value_line = | _ -> 0) in (dep, count) - with _ -> (dep, -3))) + with + | Compilers.Unsupported _ -> (dep, -6) + | _ -> (dep, -3))) dependents diff --git a/lib/dune b/lib/dune index 69ebb55..57235ed 100644 --- a/lib/dune +++ b/lib/dune @@ -1,5 +1,13 @@ (library (name rescriptdep) (public_name rescriptdep) - (modules parse_utils parser typed_ast formatter dependency_graph) + (modules + parse_utils + parser + typed_ast + compiler_v11 + compiler_v12 + compilers + formatter + dependency_graph) (libraries str unix vendor eio eio_main yojson)) diff --git a/lib/parser.ml b/lib/parser.ml index 378af9b..59a81cc 100644 --- a/lib/parser.ml +++ b/lib/parser.ml @@ -762,7 +762,7 @@ let parse_cmt_file ?(verbose = false) ?(skip_cache = false) path = try (* Check if file has a cached version with matching digests *) let cmt_info = - try Cmt_format.read_cmt path + try snd (Compilers.read_cmt path) with Cmt_format.Error msg -> (* Provide more detailed error information *) if verbose then @@ -847,7 +847,7 @@ let parse_cmt_file ?(verbose = false) ?(skip_cache = false) path = module_info with - | Invalid_cmt_file _ as e -> raise e + | (Invalid_cmt_file _ | Compilers.Unsupported _) as e -> raise e | Sys_error msg -> raise (Invalid_cmt_file (Printf.sprintf "System error with %s: %s" path msg)) diff --git a/lib/typed_ast.ml b/lib/typed_ast.ml index a0951b1..638e5ee 100644 --- a/lib/typed_ast.ml +++ b/lib/typed_ast.ml @@ -2,9 +2,9 @@ CMT files are marshalled without type information. Reading one with the typedtree definition of another ReScript release misinterprets constructor - tags and can crash the process, so this module decodes the typed - implementation with the layout of the compiler that wrote it and keeps only - what value usage analysis needs. *) + tags and can crash the process, so each supported compiler has a decoder + (Compiler_v11, Compiler_v12, ...) that turns its typed tree into this view, + which keeps only what value usage analysis needs. *) open Stdlib @@ -26,21 +26,6 @@ and item = | Include of item list | Eval of expr -type layout = Rescript_11 | Rescript_12 - -exception Unsupported_layout of string - -(* ReScript 12 appended [cmt_extra_info] to [cmt_infos], which tells the two - typedtree layouts apart without trusting anything inside the tree. *) -let detect_layout (cmt_info : Cmt_format.cmt_infos) = - match Obj.size (Obj.repr cmt_info) with - | 13 -> Rescript_11 - | 14 -> Rescript_12 - | fields -> - raise - (Unsupported_layout - (Printf.sprintf "unknown cmt_infos layout with %d fields" fields)) - let rec path_to_list = function | Path.Pident id -> [ Ident.name id ] | Path.Pdot (p, s, _) -> path_to_list p @ [ s ] @@ -48,183 +33,11 @@ let rec path_to_list = function let option_to_list f = function Some x -> [ f x ] | None -> [] -module V11 = struct - open Typedtree - - let rec expr e = - match e.exp_desc with - | Texp_ident (path, _, _) -> Ident (path_to_list path) - | Texp_let (_, vbs, body) -> Let (List.map binding vbs, expr body) - | Texp_function { cases; _ } -> Node (List.concat_map case cases) - | Texp_apply (f, args) -> - Node - (expr f :: List.filter_map (fun (_, arg) -> Option.map expr arg) args) - | Texp_match (e, cases, exn_cases, _) -> - Node (expr e :: List.concat_map case (cases @ exn_cases)) - | Texp_try (e, cases) -> Node (expr e :: List.concat_map case cases) - | Texp_tuple es | Texp_array es | Texp_construct (_, _, es) -> - Node (List.map expr es) - | Texp_variant (_, eo) -> Node (option_to_list expr eo) - | Texp_record { fields; extended_expression; _ } -> - let overridden = - Array.to_list fields - |> List.filter_map (function - | _, Overridden (_, e) -> Some (expr e) - | _, Kept _ -> None) - in - Node (overridden @ option_to_list expr extended_expression) - | Texp_field (e, _, _) - | Texp_assert e - | Texp_lazy e - | Texp_letexception (_, e) -> - Node [ expr e ] - | Texp_setfield (e1, _, _, e2) | Texp_sequence (e1, e2) | Texp_while (e1, e2) - -> - Node [ expr e1; expr e2 ] - | Texp_ifthenelse (e1, e2, eo) -> - Node (expr e1 :: expr e2 :: option_to_list expr eo) - | Texp_for (_, _, e1, e2, _, e3) -> Node [ expr e1; expr e2; expr e3 ] - | Texp_send (e, _, eo) -> Node (expr e :: option_to_list expr eo) - | Texp_letmodule (_, _, m, body) -> Node [ module_expr m; expr body ] - | Texp_pack m -> module_expr m - | Texp_constant _ | Texp_new _ | Texp_instvar _ | Texp_setinstvar _ - | Texp_override _ | Texp_object _ | Texp_unreachable - | Texp_extension_constructor _ -> - Node [] - - and case c = option_to_list expr c.c_guard @ [ expr c.c_rhs ] - - and binding vb = - let name = - match vb.vb_pat.pat_desc with - | Tpat_var (id, _) -> Some (Ident.name id) - | _ -> None - in - { - name; - line = vb.vb_pat.pat_loc.loc_start.pos_lnum; - expr = expr vb.vb_expr; - } - - and module_expr m = - match m.mod_desc with - | Tmod_ident _ -> Node [] - | Tmod_structure s -> Struct (structure s) - | Tmod_functor (_, _, _, body) | Tmod_constraint (body, _, _, _) -> - module_expr body - | Tmod_apply (f, arg, _) -> Node [ module_expr f; module_expr arg ] - | Tmod_unpack (e, _) -> expr e - - and module_items m = - match module_expr m with Struct items -> items | e -> [ Eval e ] - - and structure s = - List.concat_map - (fun item -> - match item.str_desc with - | Tstr_eval (e, _) -> [ Eval (expr e) ] - | Tstr_value (_, vbs) -> [ Values (List.map binding vbs) ] - | Tstr_module mb -> - [ Module (Ident.name mb.mb_id, module_items mb.mb_expr) ] - | Tstr_recmodule mbs -> - List.map - (fun mb -> Module (Ident.name mb.mb_id, module_items mb.mb_expr)) - mbs - | Tstr_include (incl : include_declaration) -> - [ Include (module_items incl.incl_mod) ] - | _ -> []) - s.str_items -end - -module V12 = struct - open Typedtree_v12 - - let rec expr e = - match e.exp_desc with - | Texp_ident (path, _, _) -> Ident (path_to_list path) - | Texp_let (_, vbs, body) -> Let (List.map binding vbs, expr body) - | Texp_function { case = c; _ } -> Node (case c) - | Texp_apply { funct; args; _ } -> - Node - (expr funct - :: List.filter_map (fun (_, arg) -> Option.map expr arg) args) - | Texp_match (e, cases, exn_cases, _) -> - Node (expr e :: List.concat_map case (cases @ exn_cases)) - | Texp_try (e, cases) -> Node (expr e :: List.concat_map case cases) - | Texp_tuple es | Texp_array es | Texp_construct (_, _, es) -> - Node (List.map expr es) - | Texp_variant (_, eo) -> Node (option_to_list expr eo) - | Texp_record { fields; extended_expression; _ } -> - let overridden = - Array.to_list fields - |> List.filter_map (function - | _, Overridden (_, e), _ -> Some (expr e) - | _, Kept _, _ -> None) - in - Node (overridden @ option_to_list expr extended_expression) - | Texp_field (e, _, _) | Texp_assert e | Texp_letexception (_, e) -> - Node [ expr e ] - | Texp_setfield (e1, _, _, e2) | Texp_sequence (e1, e2) | Texp_while (e1, e2) - -> - Node [ expr e1; expr e2 ] - | Texp_ifthenelse (e1, e2, eo) -> - Node (expr e1 :: expr e2 :: option_to_list expr eo) - | Texp_for (_, _, e1, e2, _, e3) -> Node [ expr e1; expr e2; expr e3 ] - | Texp_send (e, _, eo) -> Node (expr e :: option_to_list expr eo) - | Texp_letmodule (_, _, m, body) -> Node [ module_expr m; expr body ] - | Texp_pack m -> module_expr m - | Texp_constant _ | Texp_extension_constructor _ -> Node [] - - and case c = option_to_list expr c.c_guard @ [ expr c.c_rhs ] - - and binding vb = - let name = - match vb.vb_pat.pat_desc with - | Tpat_var (id, _) -> Some (Ident.name id) - | _ -> None - in - { - name; - line = vb.vb_pat.pat_loc.loc_start.pos_lnum; - expr = expr vb.vb_expr; - } - - and module_expr m = - match m.mod_desc with - | Tmod_ident _ -> Node [] - | Tmod_structure s -> Struct (structure s) - | Tmod_functor (_, _, _, body) | Tmod_constraint (body, _, _, _) -> - module_expr body - | Tmod_apply (f, arg, _) -> Node [ module_expr f; module_expr arg ] - | Tmod_unpack (e, _) -> expr e - - and module_items m = - match module_expr m with Struct items -> items | e -> [ Eval e ] - - and structure s = - List.concat_map - (fun item -> - match item.str_desc with - | Tstr_eval (e, _) -> [ Eval (expr e) ] - | Tstr_value (_, vbs) -> [ Values (List.map binding vbs) ] - | Tstr_module mb -> - [ Module (Ident.name mb.mb_id, module_items mb.mb_expr) ] - | Tstr_recmodule mbs -> - List.map - (fun mb -> Module (Ident.name mb.mb_id, module_items mb.mb_expr)) - mbs - | Tstr_include incl -> [ Include (module_items incl.incl_mod) ] - | _ -> []) - s.str_items -end - -(* Decode the typed implementation of a CMT file, or [None] for interfaces and - partial (error-recovery) annotations. *) -let implementation (cmt_info : Cmt_format.cmt_infos) = - match cmt_info.cmt_annots with - | Cmt_format.Implementation structure -> ( - match detect_layout cmt_info with - | Rescript_11 -> Some (V11.structure structure) - | Rescript_12 -> - Some (V12.structure (Obj.magic structure : Typedtree_v12.structure))) - | _ -> None +(* A decoder only knows the constructors of its compiler release. Matching on + a constructor added by a later release would jump to an arbitrary branch, + so decoders skip values whose tag is outside [(constants, blocks)], the + numbers of constant and non-constant constructors of the variant. *) +let has_known_constructor (constants, blocks) value = + let repr = Obj.repr value in + if Obj.is_block repr then Obj.tag repr < blocks + else (Obj.obj repr : int) < constants diff --git a/test/dune b/test/dune index 7d2b343..ef2523f 100644 --- a/test/dune +++ b/test/dune @@ -3,8 +3,8 @@ (modules test_support)) (tests - (names test_namespace) - (modules test_namespace) + (names test_namespace test_compilers) + (modules test_namespace test_compilers) (libraries rescriptdep)) (executables diff --git a/test/fixtures/rescript13_basic.json b/test/fixtures/rescript13_basic.json new file mode 100644 index 0000000..a25a8d4 --- /dev/null +++ b/test/fixtures/rescript13_basic.json @@ -0,0 +1,109 @@ +{ + "modules": [ + { + "name": "App", + "path": "test/rescript13/basic/src/app.res", + "dependencies": [ + { + "name": "Comp0", + "path": "test/rescript13/basic/src/comp0.res" + }, + { + "name": "Logger", + "path": "test/rescript13/basic/src/logger.res" + }, + { + "name": "MathUtil", + "path": "test/rescript13/basic/src/mathUtil.res" + }, + { + "name": "React", + "path": "test/rescript13/basic/node_modules/@rescript/react/src" + } + ], + "dependents": [], + "fan_in": 0, + "fan_out": 4, + "in_cycle": false + }, + { + "name": "Comp0", + "path": "test/rescript13/basic/src/comp0.res", + "dependencies": [ + { + "name": "React", + "path": "test/rescript13/basic/node_modules/@rescript/react/src" + }, + { + "name": "ReactDOM", + "path": "test/rescript13/basic/node_modules/@rescript/react/src" + } + ], + "dependents": [ + { + "name": "App", + "path": "test/rescript13/basic/src/app.res" + } + ], + "fan_in": 1, + "fan_out": 2, + "in_cycle": false + }, + { + "name": "Logger", + "path": "test/rescript13/basic/src/logger.res", + "dependencies": [], + "dependents": [ + { + "name": "App", + "path": "test/rescript13/basic/src/app.res" + } + ], + "fan_in": 1, + "fan_out": 0, + "in_cycle": false + }, + { + "name": "MathUtil", + "path": "test/rescript13/basic/src/mathUtil.res", + "dependencies": [ + { + "name": "Utils", + "path": "test/rescript13/basic/src/utils.res" + } + ], + "dependents": [ + { + "name": "App", + "path": "test/rescript13/basic/src/app.res" + } + ], + "fan_in": 1, + "fan_out": 1, + "in_cycle": false + }, + { + "name": "Utils", + "path": "test/rescript13/basic/src/utils.res", + "dependencies": [], + "dependents": [ + { + "name": "MathUtil", + "path": "test/rescript13/basic/src/mathUtil.res" + } + ], + "fan_in": 1, + "fan_out": 0, + "in_cycle": false + } + ], + "cycles": [], + "metrics": { + "total_modules": 5, + "average_fan_in": 0.8, + "average_fan_out": 1.4, + "most_depended_upon": {"module": "Comp0", "count": 1}, + "most_dependencies": {"module": "App", "count": 4}, + "cycles_count": 0 + } +} diff --git a/test/fixtures/rescript13_namespaced.json b/test/fixtures/rescript13_namespaced.json new file mode 100644 index 0000000..f0dab46 --- /dev/null +++ b/test/fixtures/rescript13_namespaced.json @@ -0,0 +1,109 @@ +{ + "modules": [ + { + "name": "App", + "path": "test/rescript13/namespaced/src/app.res", + "dependencies": [ + { + "name": "Comp0", + "path": "test/rescript13/namespaced/src/comp0.res" + }, + { + "name": "Logger", + "path": "test/rescript13/namespaced/src/logger.res" + }, + { + "name": "MathUtil", + "path": "test/rescript13/namespaced/src/mathUtil.res" + }, + { + "name": "React", + "path": "test/rescript13/namespaced/node_modules/@rescript/react/src" + } + ], + "dependents": [], + "fan_in": 0, + "fan_out": 4, + "in_cycle": false + }, + { + "name": "Comp0", + "path": "test/rescript13/namespaced/src/comp0.res", + "dependencies": [ + { + "name": "React", + "path": "test/rescript13/namespaced/node_modules/@rescript/react/src" + }, + { + "name": "ReactDOM", + "path": "test/rescript13/namespaced/node_modules/@rescript/react/src" + } + ], + "dependents": [ + { + "name": "App", + "path": "test/rescript13/namespaced/src/app.res" + } + ], + "fan_in": 1, + "fan_out": 2, + "in_cycle": false + }, + { + "name": "Logger", + "path": "test/rescript13/namespaced/src/logger.res", + "dependencies": [], + "dependents": [ + { + "name": "App", + "path": "test/rescript13/namespaced/src/app.res" + } + ], + "fan_in": 1, + "fan_out": 0, + "in_cycle": false + }, + { + "name": "MathUtil", + "path": "test/rescript13/namespaced/src/mathUtil.res", + "dependencies": [ + { + "name": "Utils", + "path": "test/rescript13/namespaced/src/utils.res" + } + ], + "dependents": [ + { + "name": "App", + "path": "test/rescript13/namespaced/src/app.res" + } + ], + "fan_in": 1, + "fan_out": 1, + "in_cycle": false + }, + { + "name": "Utils", + "path": "test/rescript13/namespaced/src/utils.res", + "dependencies": [], + "dependents": [ + { + "name": "MathUtil", + "path": "test/rescript13/namespaced/src/mathUtil.res" + } + ], + "fan_in": 1, + "fan_out": 0, + "in_cycle": false + } + ], + "cycles": [], + "metrics": { + "total_modules": 5, + "average_fan_in": 0.8, + "average_fan_out": 1.4, + "most_depended_upon": {"module": "Comp0", "count": 1}, + "most_dependencies": {"module": "App", "count": 4}, + "cycles_count": 0 + } +} diff --git a/test/rescript12/package.json b/test/rescript12/package.json index c0c049f..c31bd87 100644 --- a/test/rescript12/package.json +++ b/test/rescript12/package.json @@ -4,7 +4,7 @@ "private": true, "description": "ReScript 12 fixture projects for rescriptdep tests", "scripts": { - "res:build": "pnpm -r res:build" + "res:build": "pnpm -r --workspace-concurrency=1 res:build" }, "packageManager": "pnpm@10.33.0" } diff --git a/test/rescript13/.gitignore b/test/rescript13/.gitignore new file mode 100644 index 0000000..1c0764b --- /dev/null +++ b/test/rescript13/.gitignore @@ -0,0 +1,3 @@ +lib +node_modules +.DS_Store diff --git a/test/rescript13/basic/package.json b/test/rescript13/basic/package.json new file mode 100644 index 0000000..d7d73e5 --- /dev/null +++ b/test/rescript13/basic/package.json @@ -0,0 +1,14 @@ +{ + "name": "rescript13-basic", + "version": "0.0.0", + "private": true, + "scripts": { + "res:build": "rescript build" + }, + "dependencies": { + "@rescript/react": "0.15.0", + "react": "^19.1.0", + "react-dom": "^19.1.0", + "rescript": "13.0.0-alpha.6" + } +} diff --git a/test/rescript13/basic/rescript.json b/test/rescript13/basic/rescript.json new file mode 100644 index 0000000..ae3c5f1 --- /dev/null +++ b/test/rescript13/basic/rescript.json @@ -0,0 +1,18 @@ +{ + "name": "rescript13-basic", + "sources": [ + { + "dir": "src", + "subdirs": true + } + ], + "package-specs": { + "module": "esmodule", + "in-source": false + }, + "suffix": ".res.mjs", + "dependencies": ["@rescript/react"], + "jsx": { + "version": 4 + } +} diff --git a/test/rescript13/basic/src/app.res b/test/rescript13/basic/src/app.res new file mode 100644 index 0000000..7681cc5 --- /dev/null +++ b/test/rescript13/basic/src/app.res @@ -0,0 +1,11 @@ +module M = { + @react.component + let make = (~p as _) => +} + +let run = () => { + let result = MathUtil.square(5) + Logger.log(`Result: ${result->Int.toString}`) + + +} diff --git a/test/rescript13/basic/src/comp0.res b/test/rescript13/basic/src/comp0.res new file mode 100644 index 0000000..ccee0b7 --- /dev/null +++ b/test/rescript13/basic/src/comp0.res @@ -0,0 +1,6 @@ +@react.component +let make = () => { +
+

{"comp0"->React.string}

+
+} diff --git a/test/rescript13/basic/src/logger.res b/test/rescript13/basic/src/logger.res new file mode 100644 index 0000000..a1f75ec --- /dev/null +++ b/test/rescript13/basic/src/logger.res @@ -0,0 +1 @@ +let log = message => Console.log(message) diff --git a/test/rescript13/basic/src/mathUtil.res b/test/rescript13/basic/src/mathUtil.res new file mode 100644 index 0000000..bccff83 --- /dev/null +++ b/test/rescript13/basic/src/mathUtil.res @@ -0,0 +1,22 @@ +open Utils + +let square = x => multiply(x, x) +let double = x => add(x, x) +let quadruple = x => U.quadruple(x) + +module M = { + let triple = x => multiply(x, 3) + let divide = (x, y) => divide(x, y) +} + +let is_whitelisted = module_name => { + try { + Array.some(whitelist, name => name == module_name) + } catch { + | _ => false + } +} + +external f0: {..} => int = "f0" + +let v0 = f0({"a": U.triple(0)}) diff --git a/test/rescript13/basic/src/utils.res b/test/rescript13/basic/src/utils.res new file mode 100644 index 0000000..77705c4 --- /dev/null +++ b/test/rescript13/basic/src/utils.res @@ -0,0 +1,24 @@ +let add = (a, b) => a + b +let multiply = (a, b) => a * b +let triple = x => multiply(x, 3) +let quadruple = x => multiply(x, 4) + +module U = { + let triple = x => multiply(x, 3) + let quadruple = x => multiply(x, 4) +} + +let divide = (a, b) => { + let divider = (a, b) => a / b + divider(a, b) +} + +let whitelist = ["math"] + +let is_whitelisted = module_name => { + try { + Array.some(whitelist, name => name == module_name) + } catch { + | _ => false + } +} diff --git a/test/rescript13/namespaced/package.json b/test/rescript13/namespaced/package.json new file mode 100644 index 0000000..770d970 --- /dev/null +++ b/test/rescript13/namespaced/package.json @@ -0,0 +1,14 @@ +{ + "name": "rescript13-namespaced", + "version": "0.0.0", + "private": true, + "scripts": { + "res:build": "rescript build" + }, + "dependencies": { + "@rescript/react": "0.15.0", + "react": "^19.1.0", + "react-dom": "^19.1.0", + "rescript": "13.0.0-alpha.6" + } +} diff --git a/test/rescript13/namespaced/rescript.json b/test/rescript13/namespaced/rescript.json new file mode 100644 index 0000000..e943428 --- /dev/null +++ b/test/rescript13/namespaced/rescript.json @@ -0,0 +1,19 @@ +{ + "name": "rescript13-namespaced", + "namespace": true, + "sources": [ + { + "dir": "src", + "subdirs": true + } + ], + "package-specs": { + "module": "esmodule", + "in-source": false + }, + "suffix": ".res.mjs", + "dependencies": ["@rescript/react"], + "jsx": { + "version": 4 + } +} diff --git a/test/rescript13/namespaced/src/app.res b/test/rescript13/namespaced/src/app.res new file mode 100644 index 0000000..7681cc5 --- /dev/null +++ b/test/rescript13/namespaced/src/app.res @@ -0,0 +1,11 @@ +module M = { + @react.component + let make = (~p as _) => +} + +let run = () => { + let result = MathUtil.square(5) + Logger.log(`Result: ${result->Int.toString}`) + + +} diff --git a/test/rescript13/namespaced/src/comp0.res b/test/rescript13/namespaced/src/comp0.res new file mode 100644 index 0000000..ccee0b7 --- /dev/null +++ b/test/rescript13/namespaced/src/comp0.res @@ -0,0 +1,6 @@ +@react.component +let make = () => { +
+

{"comp0"->React.string}

+
+} diff --git a/test/rescript13/namespaced/src/logger.res b/test/rescript13/namespaced/src/logger.res new file mode 100644 index 0000000..a1f75ec --- /dev/null +++ b/test/rescript13/namespaced/src/logger.res @@ -0,0 +1 @@ +let log = message => Console.log(message) diff --git a/test/rescript13/namespaced/src/mathUtil.res b/test/rescript13/namespaced/src/mathUtil.res new file mode 100644 index 0000000..bccff83 --- /dev/null +++ b/test/rescript13/namespaced/src/mathUtil.res @@ -0,0 +1,22 @@ +open Utils + +let square = x => multiply(x, x) +let double = x => add(x, x) +let quadruple = x => U.quadruple(x) + +module M = { + let triple = x => multiply(x, 3) + let divide = (x, y) => divide(x, y) +} + +let is_whitelisted = module_name => { + try { + Array.some(whitelist, name => name == module_name) + } catch { + | _ => false + } +} + +external f0: {..} => int = "f0" + +let v0 = f0({"a": U.triple(0)}) diff --git a/test/rescript13/namespaced/src/utils.res b/test/rescript13/namespaced/src/utils.res new file mode 100644 index 0000000..77705c4 --- /dev/null +++ b/test/rescript13/namespaced/src/utils.res @@ -0,0 +1,24 @@ +let add = (a, b) => a + b +let multiply = (a, b) => a * b +let triple = x => multiply(x, 3) +let quadruple = x => multiply(x, 4) + +module U = { + let triple = x => multiply(x, 3) + let quadruple = x => multiply(x, 4) +} + +let divide = (a, b) => { + let divider = (a, b) => a / b + divider(a, b) +} + +let whitelist = ["math"] + +let is_whitelisted = module_name => { + try { + Array.some(whitelist, name => name == module_name) + } catch { + | _ => false + } +} diff --git a/test/rescript13/package.json b/test/rescript13/package.json new file mode 100644 index 0000000..5a8655a --- /dev/null +++ b/test/rescript13/package.json @@ -0,0 +1,10 @@ +{ + "name": "rescript13-fixtures", + "version": "0.0.0", + "private": true, + "description": "ReScript 13 fixture projects for rescriptdep tests", + "scripts": { + "res:build": "pnpm -r --workspace-concurrency=1 res:build" + }, + "packageManager": "pnpm@10.33.0" +} diff --git a/test/rescript13/pnpm-lock.yaml b/test/rescript13/pnpm-lock.yaml new file mode 100644 index 0000000..bde9366 --- /dev/null +++ b/test/rescript13/pnpm-lock.yaml @@ -0,0 +1,142 @@ +lockfileVersion: '9.0' + +settings: + autoInstallPeers: true + excludeLinksFromLockfile: false + +importers: + + .: {} + + basic: + dependencies: + '@rescript/react': + specifier: 0.15.0 + version: 0.15.0(@rescript/runtime@13.0.0-alpha.6)(react-dom@19.3.1(react@19.3.1))(react@19.3.1) + react: + specifier: ^19.1.0 + version: 19.3.1 + react-dom: + specifier: ^19.1.0 + version: 19.3.1(react@19.3.1) + rescript: + specifier: 13.0.0-alpha.6 + version: 13.0.0-alpha.6 + + namespaced: + dependencies: + '@rescript/react': + specifier: 0.15.0 + version: 0.15.0(@rescript/runtime@13.0.0-alpha.6)(react-dom@19.3.1(react@19.3.1))(react@19.3.1) + react: + specifier: ^19.1.0 + version: 19.3.1 + react-dom: + specifier: ^19.1.0 + version: 19.3.1(react@19.3.1) + rescript: + specifier: 13.0.0-alpha.6 + version: 13.0.0-alpha.6 + +packages: + + '@rescript/darwin-arm64@13.0.0-alpha.6': + resolution: {integrity: sha512-wb08dh/miY3OGUTCJL/0m8Q9xgDkd5Klh+vi7dAVl1y94g/JgVzxsU6ElB6Bb3baQeXcZW5A8tu5QnAZwwdxdw==} + engines: {node: '>=20.11.0'} + cpu: [arm64] + os: [darwin] + + '@rescript/darwin-x64@13.0.0-alpha.6': + resolution: {integrity: sha512-N0QJzzhvBC25zt8FVSRQYSVsM6Pv8OATVANbSZUZBX/wv5HCISgUWTaZ1q0RLHpEvRymalT+kXEZGG6fUvcDCg==} + engines: {node: '>=20.11.0'} + cpu: [x64] + os: [darwin] + + '@rescript/linux-arm64@13.0.0-alpha.6': + resolution: {integrity: sha512-/HEgh1Ocsyy//VsQ3e+f0qNIi/9JGqcFCM95bh/Ee0m/8RbswmUtfFjvcs/WLrhSPW9BndkLWBGMRwIYpBkRgQ==} + engines: {node: '>=20.11.0'} + cpu: [arm64] + os: [linux] + + '@rescript/linux-x64@13.0.0-alpha.6': + resolution: {integrity: sha512-kQlCnbUPwyxrC3KGLIR7ASdDKVkDd4hNBD+eD3t/yIIfR6lCs00EeVWbbfHMbs/Rg7TmQvGKkZTgAEQ6IoIhoQ==} + engines: {node: '>=20.11.0'} + cpu: [x64] + os: [linux] + + '@rescript/react@0.15.0': + resolution: {integrity: sha512-qDrrgxYzxRL/pjug617u5Q4+aqEfV5g+GQnd+eCWb0XqPrKucaDzN5rirDUZPg8UrqU/AvCP8Ev5cFd+MJx88A==} + peerDependencies: + '@rescript/runtime': '>=12.0.0' + react: '>=19.2.0' + react-dom: '>=19.2.0' + + '@rescript/runtime@13.0.0-alpha.6': + resolution: {integrity: sha512-PtIAApHWITR8nX//wh7eMQIdQbyl/Ynhr+oMcyUtQN98mXnU/F5UpGDGAK6QXanDpdVSW6korsqHyDcMtIscEg==} + + '@rescript/win32-x64@13.0.0-alpha.6': + resolution: {integrity: sha512-JGHbh8xuRtOPJeE86vzDLqSnL471CeAV3uWacEBCi6K7ZNHZlihCQhEUqWf7ir9gf46xcpnS//8A5L1Baa6Q3w==} + engines: {node: '>=20.11.0'} + cpu: [x64] + os: [win32] + + react-dom@19.3.1: + resolution: {integrity: sha512-Y0bARz53lhEC1NMCASs0/j+faB/zqt3R8hpvg1e8+61ZVJ4UL0UdC4cBbXfZMcIuhrfgeILTLe+ZeBCavQPtKQ==} + peerDependencies: + react: ^19.3.1 + + react@19.3.1: + resolution: {integrity: sha512-QNhWdt7nrgVWWQG58QuGsAR3jv3Hbe4mb4vz7w2csnHavciZJgda1CPNaldF6eVxv90ud3jUXpKlHL69gO38yw==} + engines: {node: '>=0.10.0'} + + rescript@13.0.0-alpha.6: + resolution: {integrity: sha512-8bnerL6UZ11xrbt8VSa2FuFYOW1pyEIx3CGYgVz2tXsG+cVlMPjHaalquLJdZCTdz7ypJJclxAFFuGfH7B+nKg==} + engines: {node: '>=22'} + hasBin: true + + scheduler@0.28.0: + resolution: {integrity: sha512-juorfCmIkIw8tT+p5BXSm6PJjQF/ycEYmKyzURCIt/RaZIhL+PulbQ9Yu2z1HdOJDdqDTlxA1+xKBmHXJsczAw==} + +snapshots: + + '@rescript/darwin-arm64@13.0.0-alpha.6': + optional: true + + '@rescript/darwin-x64@13.0.0-alpha.6': + optional: true + + '@rescript/linux-arm64@13.0.0-alpha.6': + optional: true + + '@rescript/linux-x64@13.0.0-alpha.6': + optional: true + + '@rescript/react@0.15.0(@rescript/runtime@13.0.0-alpha.6)(react-dom@19.3.1(react@19.3.1))(react@19.3.1)': + dependencies: + '@rescript/runtime': 13.0.0-alpha.6 + react: 19.3.1 + react-dom: 19.3.1(react@19.3.1) + + '@rescript/runtime@13.0.0-alpha.6': {} + + '@rescript/win32-x64@13.0.0-alpha.6': + optional: true + + react-dom@19.3.1(react@19.3.1): + dependencies: + react: 19.3.1 + scheduler: 0.28.0 + + react@19.3.1: {} + + rescript@13.0.0-alpha.6: + dependencies: + '@rescript/runtime': 13.0.0-alpha.6 + optionalDependencies: + '@rescript/darwin-arm64': 13.0.0-alpha.6 + '@rescript/darwin-x64': 13.0.0-alpha.6 + '@rescript/linux-arm64': 13.0.0-alpha.6 + '@rescript/linux-x64': 13.0.0-alpha.6 + '@rescript/win32-x64': 13.0.0-alpha.6 + + scheduler@0.28.0: {} diff --git a/test/rescript13/pnpm-workspace.yaml b/test/rescript13/pnpm-workspace.yaml new file mode 100644 index 0000000..f04ee94 --- /dev/null +++ b/test/rescript13/pnpm-workspace.yaml @@ -0,0 +1,3 @@ +packages: + - basic + - namespaced diff --git a/test/test_ast.ml b/test/test_ast.ml index 483dc6b..4c7fa9e 100644 --- a/test/test_ast.ml +++ b/test/test_ast.ml @@ -40,6 +40,10 @@ let () = ( "rescript12/basic/lib/bs/src/app.ast", [ "Belt"; "Comp0"; "Logger"; "MathUtil"; "React" ] ); ("rescript12/namespaced/lib/bs/src/mathUtil.ast", [ "Belt"; "U"; "Utils" ]); + ( "rescript13/basic/lib/bs/src/app.ast", + [ "Comp0"; "Int"; "Logger"; "MathUtil"; "React" ] ); + ( "rescript13/namespaced/lib/bs/src/mathUtil.ast", + [ "Array"; "U"; "Utils" ] ); ] |> List.map (fun (ast_path, expected) -> check_ast_fixture ~candidates:[ ast_path; "test/" ^ ast_path ] ~expected) diff --git a/test/test_compilers.ml b/test/test_compilers.ml new file mode 100644 index 0000000..f292a77 --- /dev/null +++ b/test/test_compilers.ml @@ -0,0 +1,171 @@ +open Stdlib + +(* Compiler identification and typed tree decoder guards. These tests build + synthetic CMT files and typed tree values instead of compiled fixtures, so + they also run under `dune runtest`. *) + +let assert_true condition message = if not condition then failwith message + +(* A cmt_infos record laid out like ReScript 11 writes it *) +let rescript11_cmt_info = + Obj.repr + { + Cmt_format.cmt_modname = "Sample"; + cmt_annots = Implementation (Obj.repr ()); + cmt_value_dependencies = []; + cmt_comments = []; + cmt_args = [||]; + cmt_sourcefile = None; + cmt_builddir = ""; + cmt_loadpath = []; + cmt_source_digest = None; + cmt_initial_env = Env.empty; + cmt_imports = []; + cmt_interface_digest = None; + cmt_use_summaries = false; + } + +(* ReScript 12 and 13 append cmt_extra_info to the record *) +let rescript12_cmt_info = + let size = Obj.size rescript11_cmt_info in + let extended = Obj.new_block 0 (size + 1) in + for i = 0 to size - 1 do + Obj.set_field extended i (Obj.field rescript11_cmt_info i) + done; + Obj.set_field extended size (Obj.repr ()); + extended + +let with_cmt_file ~magic cmt_info f = + let path = Filename.temp_file "rescriptdep-compiler" ".cmt" in + Fun.protect + ~finally:(fun () -> try Sys.remove path with _ -> ()) + (fun () -> + let oc = open_out_bin path in + output_string oc magic; + output_value oc cmt_info; + close_out oc; + f path) + +let identify ~magic cmt_info = + with_cmt_file ~magic cmt_info (fun path -> + match Rescriptdep.Compilers.read_cmt path with + | compiler, _ -> Some compiler.Rescriptdep.Compilers.name + | exception Rescriptdep.Compilers.Unsupported _ -> None) + +let test_identification () = + assert_true + (identify ~magic:"Caml1999T022" rescript11_cmt_info = Some "ReScript 11") + "Expected 13-field T022 CMT files to be read as ReScript 11"; + assert_true + (identify ~magic:"Caml1999T022" rescript12_cmt_info = Some "ReScript 12") + "Expected 14-field T022 CMT files to be read as ReScript 12"; + assert_true + (identify ~magic:"Caml1999T037" rescript12_cmt_info = Some "ReScript 13") + "Expected 14-field T037 CMT files to be read as ReScript 13"; + assert_true + (identify ~magic:"Caml1999T037" rescript11_cmt_info = None) + "Expected unknown magic number and layout combinations to be rejected"; + assert_true + (identify ~magic:"Caml1999T099" rescript12_cmt_info = None) + "Expected unknown CMT format versions to be rejected" + +let test_unsupported_compiler_fails_the_graph () = + with_cmt_file ~magic:"Caml1999T099" rescript12_cmt_info (fun path -> + match + Rescriptdep.Parser.parse_files_or_dirs ~skip_cache:true [ path ] + with + | _ -> + failwith + "Expected CMT files of unknown compilers to fail the analysis \ + instead of producing an empty graph" + | exception Rescriptdep.Compilers.Unsupported _ -> ()) + +let test_value_usage_reports_unsupported_compiler () = + with_cmt_file ~magic:"Caml1999T037" rescript12_cmt_info (fun path -> + let graph = + Rescriptdep.Dependency_graph.add ~cmt_path:path + Rescriptdep.Dependency_graph.empty "Sample" [] None + in + assert_true + (Rescriptdep.Dependency_graph.count_value_usage_in_dependents graph + ~module_name:"Sample" ~value_name:"value" ~value_line:None + = [ ("Sample", -6) ]) + "Expected value usage to report -6 for compilers it cannot decode") + +(* The constructor counts used by the unknown-tag guard must match the + vendored typedtree definitions: the last constructor of each variant has + the last known tag *) +let test_constructor_counts () = + let tag value = Obj.tag (Obj.repr value) in + let last_block (_, blocks) = blocks - 1 in + let opaque = Obj.repr () in + let unknown = Obj.magic () in + assert_true + (tag (Typedtree_v11.Texp_extension_constructor (unknown, unknown)) + = last_block Rescriptdep.Compiler_v11.expression_desc_constructors) + "ReScript 11 expression_desc count is out of date"; + assert_true + ((Obj.obj (Obj.repr Typedtree_v11.Texp_unreachable) : int) + = fst Rescriptdep.Compiler_v11.expression_desc_constructors - 1) + "ReScript 11 expression_desc constant count is out of date"; + assert_true + (tag (Typedtree_v11.Tstr_attribute "") + = last_block Rescriptdep.Compiler_v11.structure_item_desc_constructors) + "ReScript 11 structure_item_desc count is out of date"; + assert_true + (tag (Typedtree_v11.Tmod_unpack (unknown, unknown)) + = last_block Rescriptdep.Compiler_v11.module_expr_desc_constructors) + "ReScript 11 module_expr_desc count is out of date"; + assert_true + (tag (Typedtree_v12.Texp_extension_constructor (opaque, unknown)) + = last_block Rescriptdep.Compiler_v12.expression_desc_constructors) + "ReScript 12 expression_desc count is out of date"; + assert_true + (tag (Typedtree_v12.Tstr_attribute opaque) + = last_block Rescriptdep.Compiler_v12.structure_item_desc_constructors) + "ReScript 12 structure_item_desc count is out of date"; + assert_true + (tag (Typedtree_v12.Tmod_unpack (unknown, opaque)) + = last_block Rescriptdep.Compiler_v12.module_expr_desc_constructors) + "ReScript 12 module_expr_desc count is out of date" + +(* An expression whose constructor tag is beyond the known ones, as a later + release appending constructors would write it *) +let test_unknown_constructors_are_skipped () = + let unknown_desc = Obj.new_block 40 1 in + let v11_expression : Typedtree_v11.expression = + { + exp_desc = Obj.obj unknown_desc; + exp_loc = Obj.magic (); + exp_extra = []; + exp_type = Obj.magic (); + exp_env = (); + exp_attributes = ""; + } + in + let v12_expression : Typedtree_v12.expression = + { + exp_desc = Obj.obj unknown_desc; + exp_loc = Obj.magic (); + exp_extra = Obj.repr (); + exp_type = Obj.repr (); + exp_env = Obj.repr (); + exp_attributes = Obj.repr (); + } + in + assert_true + (Rescriptdep.Compiler_v11.expr v11_expression + = Rescriptdep.Typed_ast.Node []) + "Expected the ReScript 11 decoder to skip unknown constructors"; + assert_true + (Rescriptdep.Compiler_v12.expr v12_expression + = Rescriptdep.Typed_ast.Node []) + "Expected the ReScript 12 decoder to skip unknown constructors" + +let () = + test_identification (); + test_unsupported_compiler_fails_the_graph (); + test_value_usage_reports_unsupported_compiler (); + test_constructor_counts (); + test_unknown_constructors_are_skipped (); + print_endline "Compiler support tests passed" diff --git a/test/test_rescriptdep.ml b/test/test_rescriptdep.ml index 216d08e..30215e9 100644 --- a/test/test_rescriptdep.ml +++ b/test/test_rescriptdep.ml @@ -128,6 +128,8 @@ let test_rescriptdep () = ("rescript", "rescript"); ("rescript12/basic", "rescript12_basic"); ("rescript12/namespaced", "rescript12_namespaced"); + ("rescript13/basic", "rescript13_basic"); + ("rescript13/namespaced", "rescript13_namespaced"); ] |> List.map (fun (project_name, fixture_name) -> test_project_fixtures ~fixture_name project_name) diff --git a/test/test_value_usage.ml b/test/test_value_usage.ml index 12063b2..20800e6 100644 --- a/test/test_value_usage.ml +++ b/test/test_value_usage.ml @@ -1,9 +1,10 @@ open Stdlib open Printf -(* Value usage counts (-vb) for the same sources compiled by ReScript 11 and - ReScript 12. Reading a CMT file with the wrong typedtree layout used to - crash the process, so every project must give the same counts. *) +(* Value usage counts (-vb) for the same sources compiled by ReScript 11, 12 + and 13. Reading a CMT file with the wrong typedtree layout used to crash + the process, so every supported project must give the same counts, and + projects built by an unsupported compiler must report it without crashing. *) let count_usage bs_dir ~module_name ~value_name ~value_line = Rescriptdep.Parser.clear_cache (); @@ -17,6 +18,16 @@ let count_usage bs_dir ~module_name ~value_name ~value_line = Rescriptdep.Dependency_graph.count_value_usage_in_dependents focused_graph ~module_name ~value_name ~value_line:(Some value_line) +let find_bs_dir project = + Test_support.require_existing_path + ~hint: + "Compiled ReScript fixture project not found. Run `make test` to install \ + the fixture dependencies and build `lib/bs` first." + [ + Printf.sprintf "%s/lib/bs" project; + Printf.sprintf "test/%s/lib/bs" project; + ] + let format_counts counts = counts |> List.map (fun (name, count) -> sprintf "%s=%d" name count) @@ -25,16 +36,7 @@ let format_counts counts = (* [math_module] is the module defined by math.res (v11) / mathUtil.res (v12): ReScript 12 resolves "Math" to Stdlib.Math. *) let test_project project ~math_module = - let bs_dir = - Test_support.require_existing_path - ~hint: - "Compiled ReScript fixture project not found. Run `make test` to \ - install the fixture dependencies and build `lib/bs` first." - [ - Printf.sprintf "%s/lib/bs" project; - Printf.sprintf "test/%s/lib/bs" project; - ] - in + let bs_dir = find_bs_dir project in printf "=== Value usage in %s ===\n" project; let cases = [ @@ -67,8 +69,19 @@ let test_project project ~math_module = false)) cases +(* Value usage analysis does not decode ReScript 13 typed trees yet; every + module must report -6 (unsupported compiler) instead of a count *) +let test_unsupported_project project = + printf "=== Value usage in %s (unsupported) ===\n" project; + let counts = + count_usage (find_bs_dir project) ~module_name:"Utils" + ~value_name:"multiply" ~value_line:2 + in + printf " Utils.multiply@2: %s\n" (format_counts counts); + counts <> [] && List.for_all (fun (_, count) -> count = -6) counts + let () = - let results = + let supported = [ ("rescript", "Math"); ("rescript12/basic", "MathUtil"); @@ -77,4 +90,8 @@ let () = |> List.map (fun (project, math_module) -> test_project project ~math_module) in - exit (if List.for_all Fun.id results then 0 else 1) + let unsupported = + [ "rescript13/basic"; "rescript13/namespaced" ] + |> List.map test_unsupported_project + in + exit (if List.for_all Fun.id (supported @ unsupported) then 0 else 1) diff --git a/vendor/cmt_format.ml b/vendor/cmt_format.ml index cbc5a30..b5db5c5 100644 --- a/vendor/cmt_format.ml +++ b/vendor/cmt_format.ml @@ -19,23 +19,15 @@ let read_magic_number ic = let len_magic_number = String.length Config.cmt_magic_number in really_input_string ic len_magic_number -(* Binary annotations *) +(* Binary annotations. The typed tree layout depends on the compiler that + wrote the file, so the trees are kept opaque here and decoded by a + compiler-specific backend. *) type binary_annots = - | Packed of Types.signature * string list - | Implementation of Typedtree.structure - | Interface of Typedtree.signature - | Partial_implementation of binary_part array - | Partial_interface of binary_part array - -and binary_part = - | Partial_structure of Typedtree.structure - | Partial_structure_item of Typedtree.structure_item - | Partial_expression of Typedtree.expression - | Partial_pattern of Typedtree.pattern - | Partial_class_expr of unit - | Partial_signature of Typedtree.signature - | Partial_signature_item of Typedtree.signature_item - | Partial_module_type of Typedtree.module_type + | Packed of Obj.t * string list + | Implementation of Obj.t + | Interface of Obj.t + | Partial_implementation of Obj.t + | Partial_interface of Obj.t (* Simplified cmt_infos *) type cmt_infos = { @@ -60,21 +52,29 @@ exception Error of string let input_cmt ic = (input_value ic : cmt_infos) +(* Several compiler releases write different format versions, so [read] + accepts any version and returns the CMT magic number with the infos. + Callers must check the version before reading fields of the infos. *) +let cmi_magic_prefix = "Caml1999I" +let cmt_magic_prefix = "Caml1999T" +let has_prefix prefix magic_number = String.starts_with ~prefix magic_number + let read filename = (* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) let ic = open_in_bin filename in try let magic_number = read_magic_number ic in let cmi, cmt = - if magic_number = Config.cmt_magic_number then (None, Some (input_cmt ic)) - else if magic_number = Config.cmi_magic_number then + if has_prefix cmt_magic_prefix magic_number then + (None, Some (magic_number, input_cmt ic)) + else if has_prefix cmi_magic_prefix magic_number then let cmi = Cmi_format.input_cmi ic in let cmt = try let magic_number = read_magic_number ic in - if magic_number = Config.cmt_magic_number then + if has_prefix cmt_magic_prefix magic_number then let cmt = input_cmt ic in - Some cmt + Some (magic_number, cmt) else None with _ -> None in @@ -88,11 +88,13 @@ let read filename = close_in ic; raise e -let read_cmt filename = +let read_cmt_with_magic filename = match read filename with | _, None -> raise (Error "Not a typedtree") | _, Some cmt -> cmt +let read_cmt filename = snd (read_cmt_with_magic filename) + let read_cmi filename = match read filename with | None, _ -> raise (Error "Not an interface") diff --git a/vendor/cmt_format.mli b/vendor/cmt_format.mli index 9b28cf3..45d5392 100644 --- a/vendor/cmt_format.mli +++ b/vendor/cmt_format.mli @@ -13,23 +13,15 @@ (* *) (**************************************************************************) -(* Binary annotations *) +(* Binary annotations. The typed tree layout depends on the compiler that + wrote the file, so the trees are kept opaque here and decoded by a + compiler-specific backend. *) type binary_annots = - | Packed of Types.signature * string list - | Implementation of Typedtree.structure - | Interface of Typedtree.signature - | Partial_implementation of binary_part array - | Partial_interface of binary_part array - -and binary_part = - | Partial_structure of Typedtree.structure - | Partial_structure_item of Typedtree.structure_item - | Partial_expression of Typedtree.expression - | Partial_pattern of Typedtree.pattern - | Partial_class_expr of unit - | Partial_signature of Typedtree.signature - | Partial_signature_item of Typedtree.signature_item - | Partial_module_type of Typedtree.module_type + | Packed of Obj.t * string list + | Implementation of Obj.t + | Interface of Obj.t + | Partial_implementation of Obj.t + | Partial_interface of Obj.t (* Simplified cmt_infos *) type cmt_infos = { @@ -52,5 +44,11 @@ type cmt_infos = { (* Error handling *) exception Error of string +(* Magic number prefixes; the format version follows them *) +val cmi_magic_prefix : string +val cmt_magic_prefix : string val read_cmt : string -> cmt_infos + +(* Like [read_cmt], but also returns the CMT magic number of the file *) +val read_cmt_with_magic : string -> string * cmt_infos val read_cmi : string -> Cmi_format.cmi_infos diff --git a/vendor/typedtree.ml b/vendor/typedtree_v11.ml similarity index 100% rename from vendor/typedtree.ml rename to vendor/typedtree_v11.ml diff --git a/vendor/typedtree.mli b/vendor/typedtree_v11.mli similarity index 98% rename from vendor/typedtree.mli rename to vendor/typedtree_v11.mli index e60740c..b582299 100644 --- a/vendor/typedtree.mli +++ b/vendor/typedtree_v11.mli @@ -18,9 +18,10 @@ (** By comparison with {!Parsetree}: - Every {!Longindent.t} is accompanied by a resolved {!Path.t}. *) -(* This mirrors the typedtree layout written by ReScript 11 and earlier. CMT - files are read with [input_value], so constructor order and arity must match - the compiler exactly. ReScript 12 uses {!Typedtree_v12}. *) +(* This mirrors the typedtree layout written by ReScript 11 (11.0.0 - 11.1.4, + jscomp/ml/typedtree.mli). CMT files are read with [input_value], so + constructor order and arity must match the compiler exactly. ReScript 12 + uses {!Typedtree_v12}. *) open Types From 53a2f553bf4fb64a5cd32e7ad28b4dbe68977de7 Mon Sep 17 00:00:00 2001 From: mununki Date: Wed, 21 Oct 2026 16:53:12 +0900 Subject: [PATCH 3/4] Support value usage analysis for the ReScript 13.0 alphas - Pick the typed tree decoder from the compiler version in lib/bs/compiler-info.json where several releases write the same CMT format: ReScript 12 and 13.0.0-alpha.1 to alpha.5 all write Caml1999T022 with 14 fields, but alpha.4 inserted constructors in the middle of expression_desc and crashed -vb on for...of loops - Read 13.0.0-alpha.1 to alpha.3 and alpha.5 with the ReScript 12 decoder, extended with the constructors alpha.5 appends (for...of, break, continue), and report -6 for alpha.4 and versions not checked yet - Add a decoder for the 13.0.0-alpha.6 typed tree (Typedtree_v13, Compiler_v13) - Add a module using ReScript 13 syntax to the ReScript 13 fixtures and test value usage there, plus version identification tests --- CHANGELOG.md | 4 +- CONTRIBUTING.md | 28 ++-- README.md | 12 +- lib/compiler_v12.ml | 11 +- lib/compiler_v13.ml | 111 +++++++++++++++ lib/compilers.ml | 112 ++++++++++++--- lib/dune | 1 + test/fixtures/rescript13_basic.json | 15 +- test/fixtures/rescript13_namespaced.json | 15 +- test/rescript13/basic/src/loops.res | 17 +++ test/rescript13/namespaced/src/loops.res | 17 +++ test/test_compilers.ml | 100 ++++++++++++-- test/test_value_usage.ml | 42 +++--- vendor/typedtree_v12.ml | 10 +- vendor/typedtree_v13.ml | 168 +++++++++++++++++++++++ 15 files changed, 582 insertions(+), 81 deletions(-) create mode 100644 lib/compiler_v13.ml create mode 100644 test/rescript13/basic/src/loops.res create mode 100644 test/rescript13/namespaced/src/loops.res create mode 100644 vendor/typedtree_v13.ml diff --git a/CHANGELOG.md b/CHANGELOG.md index f6e09f5..d39012d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,12 +10,12 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Added regression coverage for dependency graph dependent-index updates - Added ReScript 12 support for value usage analysis (`-vb`) by decoding typed trees with the layout of the compiler that wrote each `.cmt` file - Added ReScript 12 fixture projects (standard and namespaced) with dependency graph and value usage regression tests -- Added ReScript 13 (13.0.0-alpha.6) support for dependency analysis; value usage analysis reports `-6` for modules built by compilers it cannot decode yet +- Added ReScript 13 support: dependency analysis for the 13.0 alphas, and value usage analysis (`-vb`) for 13.0.0-alpha.1 to alpha.3, alpha.5 and alpha.6. `-vb` reports `-6` for compilers it cannot decode, such as 13.0.0-alpha.4 - Added ReScript 13 fixture projects and self-contained compiler identification tests - Added a supported ReScript versions table to the README ### Changed -- Organized typed tree decoding into one backend per compiler release (`Compiler_v11`, `Compiler_v12`) selected by the CMT magic number and `cmt_infos` layout, with decoders skipping constructors added by later releases instead of misreading them +- Organized typed tree decoding into one backend per compiler release (`Compiler_v11`, `Compiler_v12`, `Compiler_v13`) selected by the CMT magic number, the `cmt_infos` layout and the compiler version in `lib/bs/compiler-info.json`, with decoders skipping constructors added by later releases instead of misreading them - `.cmt` files written by unknown compilers now stop the analysis with an error instead of silently producing an empty graph - Improved dependency graph performance by maintaining a reverse dependent index instead of scanning the full graph for each dependent lookup - Reduced VS Code inline value usage analysis work with debounced requests, short-lived result caching, and JSON output parsing diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 08026eb..6044eb5 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -69,7 +69,8 @@ The test directory contains sample ReScript projects used for testing the depend `basic/` (standard setup) and `namespaced/` (`"namespace": true`). `math.res` is named `mathUtil.res` there because ReScript 12 resolves `Math` to `Stdlib.Math`. - `test/rescript13/`: The same workspace for ReScript 13, with `Belt` calls replaced by - `Stdlib` ones since ReScript 13 no longer ships `Belt`. + `Stdlib` ones since ReScript 13 no longer ships `Belt`, plus `loops.res`, which uses syntax + only ReScript 13 has (`for...of`, `continue`, template literals, object literals). The packages of a workspace share their compiled dependencies, so `res:build` builds them one at a time (`--workspace-concurrency=1`); parallel builds corrupt the shared `.cmi` files. @@ -98,17 +99,24 @@ type definitions whose constructor order and arity match the compiler exactly. O tree used by value usage analysis (`-vb`) differs between the supported releases; the fields of `cmt_infos` used by the dependency graph and the `.ast` header format are shared. +`lib/compilers.ml` picks the decoder from the CMT magic number (in `compiler/ext/config.ml` of +the ReScript repository), the number of fields of the `cmt_infos` record and, where several +releases write the same CMT format, the version in `lib/bs/compiler-info.json`. For example, +ReScript 12 and 13.0.0-alpha.1 to alpha.5 all write `Caml1999T022` with 14 fields, but alpha.4 +changed the typed tree in place. + To add a release: -1. Add an entry to `all` in `lib/compilers.ml` with the release's CMT magic number (in - `compiler/ext/config.ml` of the ReScript repository) and the number of fields of its - `cmt_infos` record. This is enough for the dependency graph. -2. For value usage analysis, vendor the parts of its `compiler/ml/typedtree.mli` that are - decoded as `vendor/typedtree_vNN.ml`, keeping every constructor in order, and add a - `lib/compiler_vNN.ml` decoder with its constructor counts. `test/test_compilers.ml` checks - that the counts match the vendored definitions. -3. Add a fixture workspace (`test/rescriptNN/`), its reference JSON fixtures, and the project - to `test/test_rescriptdep.ml`, `test/test_value_usage.ml` and the `Makefile`. +1. Diff its `compiler/ml/typedtree.mli` against the release a decoder already reads. If only + constructors were appended, or constant constructors added, extend that decoder's vendored + typedtree and list the version in its entry in `lib/compilers.ml`. +2. Otherwise vendor the parts of its typedtree that are decoded as `vendor/typedtree_vNN.ml`, + keeping every constructor in order, add a `lib/compiler_vNN.ml` decoder with its constructor + counts, and add an entry to `all` in `lib/compilers.ml`. `test/test_compilers.ml` checks that + the counts match the vendored definitions. +3. Add a fixture workspace (`test/rescriptNN/`) or update the existing one, its reference JSON + fixtures, and the project to `test/test_rescriptdep.ml`, `test/test_value_usage.ml` and the + `Makefile`. ### Running the Benchmark diff --git a/README.md b/README.md index 3a83b09..2bc83c6 100644 --- a/README.md +++ b/README.md @@ -55,10 +55,14 @@ With `-vb`, each module reports its usage count, or a negative code when it coul |---|---|---| | 11.0.0 - 11.1.4 | Yes | Yes | | 12.0.0 - 12.3.1 | Yes | Yes | -| 13.0.0-alpha.6 | Yes | Not yet (`-6`) | - -rescriptdep identifies the compiler from each `.cmt` file. Files written by other compilers are -rejected with an error instead of being misread. +| 13.0.0-alpha.1 - alpha.3, alpha.5, alpha.6 | Yes | Yes | +| 13.0.0-alpha.4 | Yes | No (`-6`) | + +rescriptdep identifies the compiler from each `.cmt` file and, for ReScript 12 and later, from the +version rewatch records in `lib/bs/compiler-info.json`. Files in formats no supported compiler +writes are rejected with an error instead of being misread. Other versions of a supported format +(for example a later 13.0 prerelease) get the dependency graph, and `-6` from `-vb` until their +typed tree has been checked. ## Development diff --git a/lib/compiler_v12.ml b/lib/compiler_v12.ml index 9c15a85..fb5d3bd 100644 --- a/lib/compiler_v12.ml +++ b/lib/compiler_v12.ml @@ -1,11 +1,12 @@ -(* compiler_v12.ml - Typed tree decoder for ReScript 12 *) +(* compiler_v12.ml - Typed tree decoder for ReScript 12 and the + ReScript 13.0 alphas that keep its layout (see Typedtree_v12) *) open Stdlib open Typed_ast open Typedtree_v12 (* Constructor counts (constant, non-constant) of the decoded variants *) -let expression_desc_constructors = (0, 24) +let expression_desc_constructors = (2, 26) let module_expr_desc_constructors = (0, 6) let structure_item_desc_constructors = (0, 12) @@ -43,10 +44,14 @@ let rec expr e = | Texp_ifthenelse (e1, e2, eo) -> Node (expr e1 :: expr e2 :: option_to_list expr eo) | Texp_for (_, _, e1, e2, _, e3) -> Node [ expr e1; expr e2; expr e3 ] + | Texp_for_of (_, _, e1, e2) | Texp_for_await_of (_, _, e1, e2) -> + Node [ expr e1; expr e2 ] | Texp_send (e, _, eo) -> Node (expr e :: option_to_list expr eo) | Texp_letmodule (_, _, m, body) -> Node [ module_expr m; expr body ] | Texp_pack m -> module_expr m - | Texp_constant _ | Texp_extension_constructor _ -> Node [] + | Texp_constant _ | Texp_break | Texp_continue + | Texp_extension_constructor _ -> + Node [] and case c = option_to_list expr c.c_guard @ [ expr c.c_rhs ] diff --git a/lib/compiler_v13.ml b/lib/compiler_v13.ml new file mode 100644 index 0000000..559475d --- /dev/null +++ b/lib/compiler_v13.ml @@ -0,0 +1,111 @@ +(* compiler_v13.ml - Typed tree decoder for ReScript 13.0.0-alpha.6 *) + +open Stdlib +open Typed_ast +open Typedtree_v13 + +(* Constructor counts (constant, non-constant) of the decoded variants *) +let expression_desc_constructors = (2, 30) +let module_expr_desc_constructors = (0, 6) +let structure_item_desc_constructors = (0, 12) + +let rec expr e = + if not (has_known_constructor expression_desc_constructors e.exp_desc) then + Node [] + else + match e.exp_desc with + | Texp_ident (path, _, _) -> Ident (path_to_list path) + | Texp_let (_, vbs, body) -> Let (List.map binding vbs, expr body) + | Texp_function { body; _ } -> + (* Default values of optional parameters are bound at the head of + the body *) + Node [ expr body ] + | Texp_apply { funct; args; _ } -> + Node + (expr funct + :: List.filter_map (fun (_, arg) -> Option.map expr arg) args) + | Texp_match (e, cases, exn_cases, _) -> + Node (expr e :: List.concat_map case (cases @ exn_cases)) + | Texp_try (e, cases) -> Node (expr e :: List.concat_map case cases) + | Texp_tuple es | Texp_array es | Texp_construct (_, _, es) -> + Node (List.map expr es) + | Texp_variant (_, eo) -> Node (option_to_list expr eo) + | Texp_record { fields; extended_expression; _ } -> + let overridden = + Array.to_list fields + |> List.filter_map (function + | _, Overridden (_, e), _ -> Some (expr e) + | _, Kept _, _ -> None) + in + Node (overridden @ option_to_list expr extended_expression) + | Texp_field (e, _, _) | Texp_assert e | Texp_letexception (_, e) -> + Node [ expr e ] + | Texp_setfield (e1, _, _, e2) | Texp_sequence (e1, e2) | Texp_while (e1, e2) + -> + Node [ expr e1; expr e2 ] + | Texp_ifthenelse (e1, e2, eo) -> + Node (expr e1 :: expr e2 :: option_to_list expr eo) + | Texp_for (_, _, e1, e2, _, e3) -> Node [ expr e1; expr e2; expr e3 ] + | Texp_for_of (_, _, e1, e2) | Texp_for_await_of (_, _, e1, e2) -> + Node [ expr e1; expr e2 ] + | Texp_object_get (e, _) -> Node [ expr e ] + | Texp_object_set (e1, _, e2) -> Node [ expr e1; expr e2 ] + | Texp_object_literal fields -> + Node (List.map (fun (_, e) -> expr e) fields) + | Texp_tagged_template { tag; values; _ } -> + Node (expr tag :: List.map expr values) + | Texp_template { values; _ } -> Node (List.map expr values) + | Texp_letmodule (_, _, m, body) -> Node [ module_expr m; expr body ] + | Texp_pack m -> module_expr m + | Texp_constant _ | Texp_break | Texp_continue + | Texp_extension_constructor _ -> + Node [] + +and case c = option_to_list expr c.c_guard @ [ expr c.c_rhs ] + +and binding vb = + let name = + match vb.vb_pat.pat_desc with + | Tpat_var (id, _) -> Some (Ident.name id) + | _ -> None + in + { name; line = vb.vb_pat.pat_loc.loc_start.pos_lnum; expr = expr vb.vb_expr } + +and module_expr m = + if not (has_known_constructor module_expr_desc_constructors m.mod_desc) then + Node [] + else + match m.mod_desc with + | Tmod_ident _ -> Node [] + | Tmod_structure s -> Struct (structure s) + | Tmod_functor (_, _, _, body) | Tmod_constraint (body, _, _, _) -> + module_expr body + | Tmod_apply (f, arg, _) -> Node [ module_expr f; module_expr arg ] + | Tmod_unpack (e, _) -> expr e + +and module_items m = + match module_expr m with Struct items -> items | e -> [ Eval e ] + +and structure s = + List.concat_map + (fun item -> + if + not + (has_known_constructor structure_item_desc_constructors item.str_desc) + then [] + else + match item.str_desc with + | Tstr_eval (e, _) -> [ Eval (expr e) ] + | Tstr_value (_, vbs) -> [ Values (List.map binding vbs) ] + | Tstr_module mb -> + [ Module (Ident.name mb.mb_id, module_items mb.mb_expr) ] + | Tstr_recmodule mbs -> + List.map + (fun mb -> Module (Ident.name mb.mb_id, module_items mb.mb_expr)) + mbs + | Tstr_include incl -> [ Include (module_items incl.incl_mod) ] + | _ -> []) + s.str_items + +(* Decode the [Implementation] annotation of a CMT file *) +let implementation (tree : Obj.t) = structure (Obj.obj tree : structure) diff --git a/lib/compilers.ml b/lib/compilers.ml index 60efde8..81e001a 100644 --- a/lib/compilers.ml +++ b/lib/compilers.ml @@ -3,8 +3,9 @@ The dependency graph only reads fields of cmt_infos that every release below lays out the same way, plus the .ast header, whose format is shared too. Only the typed tree used by value usage analysis differs between releases, - so each entry says how to recognize the release from the CMT file itself - and how to decode its typed tree. *) + so each entry says how to recognize the release and how to decode its typed + tree. Releases are recognized from the CMT file itself and, where several + write the same CMT format, from the compiler version rewatch records. *) open Stdlib @@ -12,30 +13,53 @@ type t = { name : string; cmt_magic : string; (** Magic number of the typed tree section *) cmt_infos_fields : int; (** Number of fields of the cmt_infos record *) + versions : string -> bool; + (** Compiler versions, as in lib/bs/compiler-info.json, of the release *) implementation : (Obj.t -> Typed_ast.item list) option; (** [None] when value usage analysis does not support the release *) } +let major version = + match String.index_opt version '.' with + | Some idx -> String.sub version 0 idx + | None -> version + +(* For each CMT format, the first entry is used when the compiler version is + unknown *) let all = [ { name = "ReScript 11"; cmt_magic = "Caml1999T022"; cmt_infos_fields = 13; + versions = (fun version -> major version = "11"); implementation = Some Compiler_v11.implementation; }; { name = "ReScript 12"; cmt_magic = "Caml1999T022"; cmt_infos_fields = 14; + (* 13.0.0-alpha.1 to alpha.3 and alpha.5 write the ReScript 12 CMT format + with a typed tree Typedtree_v12 reads. alpha.4 inserted constructors + in the middle of expression_desc, so it is left out. *) + versions = + (fun version -> + major version = "12" + || List.mem version + [ + "13.0.0-alpha.1"; + "13.0.0-alpha.2"; + "13.0.0-alpha.3"; + "13.0.0-alpha.5"; + ]); implementation = Some Compiler_v12.implementation; }; { - (* The typed tree still changes between the 13.0 alpha releases *) name = "ReScript 13"; cmt_magic = "Caml1999T037"; cmt_infos_fields = 14; - implementation = None; + versions = (fun version -> version = "13.0.0-alpha.6"); + implementation = Some Compiler_v13.implementation; }; ] @@ -44,28 +68,82 @@ exception Unsupported of string let cmt_infos_fields (cmt_info : Cmt_format.cmt_infos) = Obj.size (Obj.repr cmt_info) -let find ~cmt_magic cmt_info = - let fields = cmt_infos_fields cmt_info in - List.find_opt - (fun compiler -> - compiler.cmt_magic = cmt_magic && compiler.cmt_infos_fields = fields) - all +(* rewatch (ReScript 12 and later) records the compiler version in + lib/bs/compiler-info.json *) +let rec find_compiler_info dir = + let candidate = Filename.concat dir "compiler-info.json" in + if Sys.file_exists candidate then Some candidate + else + let parent = Filename.dirname dir in + if parent = dir then None else find_compiler_info parent + +let read_compiler_version info_path = + try + match Yojson.Basic.from_file info_path with + | `Assoc fields -> ( + match List.assoc_opt "version" fields with + | Some (`String version) -> Some version + | _ -> None) + | _ -> None + with _ -> None + +(* CMT files are read from several domains at once *) +let version_cache : (string, string option) Hashtbl.t = Hashtbl.create 16 +let version_cache_mutex = Mutex.create () -(* Read a CMT file and identify the compiler that wrote it. Files written by - unknown releases are rejected before any field of their infos is read. *) +(* The version of the compiler that built the CMT file at [path], if known *) +let compiler_version path = + let dir = Filename.dirname path in + let dir = + if Filename.is_relative dir then Filename.concat (Sys.getcwd ()) dir + else dir + in + Mutex.protect version_cache_mutex (fun () -> + match Hashtbl.find_opt version_cache dir with + | Some version -> version + | None -> + let version = + Option.bind (find_compiler_info dir) read_compiler_version + in + Hashtbl.replace version_cache dir version; + version) + +(* Read a CMT file and identify the compiler that wrote it. Files in formats + no supported release writes are rejected before any field of their infos + is read. A release that writes a known format but has an unknown version + is supported by the dependency graph but not by value usage analysis. *) let read_cmt path = let cmt_magic, cmt_info = Cmt_format.read_cmt_with_magic path in - match find ~cmt_magic cmt_info with - | Some compiler -> (compiler, cmt_info) - | None -> + let fields = cmt_infos_fields cmt_info in + match + List.filter + (fun compiler -> + compiler.cmt_magic = cmt_magic && compiler.cmt_infos_fields = fields) + all + with + | [] -> raise (Unsupported (Printf.sprintf "%s was written by an unsupported ReScript compiler (CMT format \ %s with %d fields). Supported compilers: %s" - path cmt_magic - (cmt_infos_fields cmt_info) + path cmt_magic fields (String.concat ", " (List.map (fun c -> c.name) all)))) + | default :: _ as candidates -> ( + match compiler_version path with + | None -> (default, cmt_info) + | Some version -> ( + match + List.find_opt (fun compiler -> compiler.versions version) candidates + with + | Some compiler -> (compiler, cmt_info) + | None -> + ( { + default with + name = "ReScript " ^ version; + implementation = None; + }, + cmt_info ))) (* Decode the typed implementation of a CMT file, or [None] for interfaces and partial (error-recovery) annotations *) diff --git a/lib/dune b/lib/dune index 57235ed..1579ce0 100644 --- a/lib/dune +++ b/lib/dune @@ -7,6 +7,7 @@ typed_ast compiler_v11 compiler_v12 + compiler_v13 compilers formatter dependency_graph) diff --git a/test/fixtures/rescript13_basic.json b/test/fixtures/rescript13_basic.json index a25a8d4..3373480 100644 --- a/test/fixtures/rescript13_basic.json +++ b/test/fixtures/rescript13_basic.json @@ -63,6 +63,15 @@ "fan_out": 0, "in_cycle": false }, + { + "name": "Loops", + "path": "test/rescript13/basic/src/loops.res", + "dependencies": [], + "dependents": [], + "fan_in": 0, + "fan_out": 0, + "in_cycle": false + }, { "name": "MathUtil", "path": "test/rescript13/basic/src/mathUtil.res", @@ -99,9 +108,9 @@ ], "cycles": [], "metrics": { - "total_modules": 5, - "average_fan_in": 0.8, - "average_fan_out": 1.4, + "total_modules": 6, + "average_fan_in": 0.666666666667, + "average_fan_out": 1.16666666667, "most_depended_upon": {"module": "Comp0", "count": 1}, "most_dependencies": {"module": "App", "count": 4}, "cycles_count": 0 diff --git a/test/fixtures/rescript13_namespaced.json b/test/fixtures/rescript13_namespaced.json index f0dab46..de6d7f9 100644 --- a/test/fixtures/rescript13_namespaced.json +++ b/test/fixtures/rescript13_namespaced.json @@ -63,6 +63,15 @@ "fan_out": 0, "in_cycle": false }, + { + "name": "Loops", + "path": "test/rescript13/namespaced/src/loops.res", + "dependencies": [], + "dependents": [], + "fan_in": 0, + "fan_out": 0, + "in_cycle": false + }, { "name": "MathUtil", "path": "test/rescript13/namespaced/src/mathUtil.res", @@ -99,9 +108,9 @@ ], "cycles": [], "metrics": { - "total_modules": 5, - "average_fan_in": 0.8, - "average_fan_out": 1.4, + "total_modules": 6, + "average_fan_in": 0.666666666667, + "average_fan_out": 1.16666666667, "most_depended_upon": {"module": "Comp0", "count": 1}, "most_dependencies": {"module": "App", "count": 4}, "cycles_count": 0 diff --git a/test/rescript13/basic/src/loops.res b/test/rescript13/basic/src/loops.res new file mode 100644 index 0000000..c4ca97f --- /dev/null +++ b/test/rescript13/basic/src/loops.res @@ -0,0 +1,17 @@ +let step = x => x + 1 + +let sumPositive = xs => { + let total = ref(0) + for x of xs { + if x < 0 { + continue + } + total := total.contents + step(x) + } + total.contents +} + +let describe = (~offset=step(0), x) => `${Int.toString(step(x) + offset)}!` + +let point = {"x": step(1)} +let readX = () => point["x"] + step(2) diff --git a/test/rescript13/namespaced/src/loops.res b/test/rescript13/namespaced/src/loops.res new file mode 100644 index 0000000..c4ca97f --- /dev/null +++ b/test/rescript13/namespaced/src/loops.res @@ -0,0 +1,17 @@ +let step = x => x + 1 + +let sumPositive = xs => { + let total = ref(0) + for x of xs { + if x < 0 { + continue + } + total := total.contents + step(x) + } + total.contents +} + +let describe = (~offset=step(0), x) => `${Int.toString(step(x) + offset)}!` + +let point = {"x": step(1)} +let readX = () => point["x"] + step(2) diff --git a/test/test_compilers.ml b/test/test_compilers.ml index f292a77..5203dd4 100644 --- a/test/test_compilers.ml +++ b/test/test_compilers.ml @@ -35,32 +35,54 @@ let rescript12_cmt_info = Obj.set_field extended size (Obj.repr ()); extended -let with_cmt_file ~magic cmt_info f = - let path = Filename.temp_file "rescriptdep-compiler" ".cmt" in +(* Write a CMT file into a fresh lib/bs-like directory, with the + compiler-info.json rewatch writes when [version] is given *) +let with_cmt_file ?version ~magic cmt_info f = + let dir = Filename.temp_dir "rescriptdep-compiler" "" in + let path = Filename.concat dir "sample.cmt" in + let info_path = Filename.concat dir "compiler-info.json" in Fun.protect - ~finally:(fun () -> try Sys.remove path with _ -> ()) + ~finally:(fun () -> + (try Sys.remove path with _ -> ()); + (try Sys.remove info_path with _ -> ()); + try Sys.rmdir dir with _ -> ()) (fun () -> + Option.iter + (fun version -> + let oc = open_out info_path in + Printf.fprintf oc {|{ "version": "%s", "bsc_path": "bsc.exe" }|} + version; + close_out oc) + version; let oc = open_out_bin path in output_string oc magic; output_value oc cmt_info; close_out oc; f path) -let identify ~magic cmt_info = - with_cmt_file ~magic cmt_info (fun path -> +(* The compiler name and whether value usage analysis can decode its typed + tree, or [None] when the CMT file is rejected *) +let identify ?version ~magic cmt_info = + with_cmt_file ?version ~magic cmt_info (fun path -> match Rescriptdep.Compilers.read_cmt path with - | compiler, _ -> Some compiler.Rescriptdep.Compilers.name + | compiler, _ -> + Some + ( compiler.Rescriptdep.Compilers.name, + Option.is_some compiler.Rescriptdep.Compilers.implementation ) | exception Rescriptdep.Compilers.Unsupported _ -> None) let test_identification () = assert_true - (identify ~magic:"Caml1999T022" rescript11_cmt_info = Some "ReScript 11") + (identify ~magic:"Caml1999T022" rescript11_cmt_info + = Some ("ReScript 11", true)) "Expected 13-field T022 CMT files to be read as ReScript 11"; assert_true - (identify ~magic:"Caml1999T022" rescript12_cmt_info = Some "ReScript 12") + (identify ~magic:"Caml1999T022" rescript12_cmt_info + = Some ("ReScript 12", true)) "Expected 14-field T022 CMT files to be read as ReScript 12"; assert_true - (identify ~magic:"Caml1999T037" rescript12_cmt_info = Some "ReScript 13") + (identify ~magic:"Caml1999T037" rescript12_cmt_info + = Some ("ReScript 13", true)) "Expected 14-field T037 CMT files to be read as ReScript 13"; assert_true (identify ~magic:"Caml1999T037" rescript11_cmt_info = None) @@ -69,6 +91,22 @@ let test_identification () = (identify ~magic:"Caml1999T099" rescript12_cmt_info = None) "Expected unknown CMT format versions to be rejected" +(* ReScript 12 and the 13.0 alphas up to alpha.5 write the same CMT format, + so the compiler-info.json version picks the decoder *) +let test_identification_by_version () = + let check ~magic version expected = + assert_true + (identify ~version ~magic rescript12_cmt_info = Some expected) + (Printf.sprintf "Unexpected compiler identification for %s" version) + in + check ~magic:"Caml1999T022" "12.3.1" ("ReScript 12", true); + check ~magic:"Caml1999T022" "12.9.0" ("ReScript 12", true); + check ~magic:"Caml1999T022" "13.0.0-alpha.3" ("ReScript 12", true); + check ~magic:"Caml1999T022" "13.0.0-alpha.5" ("ReScript 12", true); + check ~magic:"Caml1999T022" "13.0.0-alpha.4" ("ReScript 13.0.0-alpha.4", false); + check ~magic:"Caml1999T037" "13.0.0-alpha.6" ("ReScript 13", true); + check ~magic:"Caml1999T037" "13.0.0-alpha.7" ("ReScript 13.0.0-alpha.7", false) + let test_unsupported_compiler_fails_the_graph () = with_cmt_file ~magic:"Caml1999T099" rescript12_cmt_info (fun path -> match @@ -81,7 +119,8 @@ let test_unsupported_compiler_fails_the_graph () = | exception Rescriptdep.Compilers.Unsupported _ -> ()) let test_value_usage_reports_unsupported_compiler () = - with_cmt_file ~magic:"Caml1999T037" rescript12_cmt_info (fun path -> + with_cmt_file ~version:"13.0.0-alpha.4" ~magic:"Caml1999T022" + rescript12_cmt_info (fun path -> let graph = Rescriptdep.Dependency_graph.add ~cmt_path:path Rescriptdep.Dependency_graph.empty "Sample" [] None @@ -117,9 +156,13 @@ let test_constructor_counts () = = last_block Rescriptdep.Compiler_v11.module_expr_desc_constructors) "ReScript 11 module_expr_desc count is out of date"; assert_true - (tag (Typedtree_v12.Texp_extension_constructor (opaque, unknown)) + (tag (Typedtree_v12.Texp_for_await_of (unknown, opaque, unknown, unknown)) = last_block Rescriptdep.Compiler_v12.expression_desc_constructors) "ReScript 12 expression_desc count is out of date"; + assert_true + ((Obj.obj (Obj.repr Typedtree_v12.Texp_continue) : int) + = fst Rescriptdep.Compiler_v12.expression_desc_constructors - 1) + "ReScript 12 expression_desc constant count is out of date"; assert_true (tag (Typedtree_v12.Tstr_attribute opaque) = last_block Rescriptdep.Compiler_v12.structure_item_desc_constructors) @@ -127,7 +170,23 @@ let test_constructor_counts () = assert_true (tag (Typedtree_v12.Tmod_unpack (unknown, opaque)) = last_block Rescriptdep.Compiler_v12.module_expr_desc_constructors) - "ReScript 12 module_expr_desc count is out of date" + "ReScript 12 module_expr_desc count is out of date"; + assert_true + (tag (Typedtree_v13.Texp_template { segments = opaque; values = [] }) + = last_block Rescriptdep.Compiler_v13.expression_desc_constructors) + "ReScript 13 expression_desc count is out of date"; + assert_true + ((Obj.obj (Obj.repr Typedtree_v13.Texp_continue) : int) + = fst Rescriptdep.Compiler_v13.expression_desc_constructors - 1) + "ReScript 13 expression_desc constant count is out of date"; + assert_true + (tag (Typedtree_v13.Tstr_attribute opaque) + = last_block Rescriptdep.Compiler_v13.structure_item_desc_constructors) + "ReScript 13 structure_item_desc count is out of date"; + assert_true + (tag (Typedtree_v13.Tmod_unpack (unknown, opaque)) + = last_block Rescriptdep.Compiler_v13.module_expr_desc_constructors) + "ReScript 13 module_expr_desc count is out of date" (* An expression whose constructor tag is beyond the known ones, as a later release appending constructors would write it *) @@ -157,13 +216,28 @@ let test_unknown_constructors_are_skipped () = (Rescriptdep.Compiler_v11.expr v11_expression = Rescriptdep.Typed_ast.Node []) "Expected the ReScript 11 decoder to skip unknown constructors"; + let v13_expression : Typedtree_v13.expression = + { + exp_desc = Obj.obj unknown_desc; + exp_loc = Obj.magic (); + exp_extra = Obj.repr (); + exp_type = Obj.repr (); + exp_env = Obj.repr (); + exp_attributes = Obj.repr (); + } + in assert_true (Rescriptdep.Compiler_v12.expr v12_expression = Rescriptdep.Typed_ast.Node []) - "Expected the ReScript 12 decoder to skip unknown constructors" + "Expected the ReScript 12 decoder to skip unknown constructors"; + assert_true + (Rescriptdep.Compiler_v13.expr v13_expression + = Rescriptdep.Typed_ast.Node []) + "Expected the ReScript 13 decoder to skip unknown constructors" let () = test_identification (); + test_identification_by_version (); test_unsupported_compiler_fails_the_graph (); test_value_usage_reports_unsupported_compiler (); test_constructor_counts (); diff --git a/test/test_value_usage.ml b/test/test_value_usage.ml index 20800e6..31cea56 100644 --- a/test/test_value_usage.ml +++ b/test/test_value_usage.ml @@ -3,8 +3,7 @@ open Printf (* Value usage counts (-vb) for the same sources compiled by ReScript 11, 12 and 13. Reading a CMT file with the wrong typedtree layout used to crash - the process, so every supported project must give the same counts, and - projects built by an unsupported compiler must report it without crashing. *) + the process, so every project must give the same counts. *) let count_usage bs_dir ~module_name ~value_name ~value_line = Rescriptdep.Parser.clear_cache (); @@ -34,8 +33,9 @@ let format_counts counts = |> String.concat ", " (* [math_module] is the module defined by math.res (v11) / mathUtil.res (v12): - ReScript 12 resolves "Math" to Stdlib.Math. *) -let test_project project ~math_module = + ReScript 12 resolves "Math" to Stdlib.Math. [extra_cases] cover syntax that + only some releases have. *) +let test_project ?(extra_cases = []) project ~math_module = let bs_dir = find_bs_dir project in printf "=== Value usage in %s ===\n" project; let cases = @@ -51,6 +51,7 @@ let test_project project ~math_module = ("Utils", "divider", 12, [ (math_module, 0); ("Utils", 1) ]); ("Utils", "whitelist", 16, [ (math_module, 1); ("Utils", 1) ]); ] + @ extra_cases in List.for_all (fun (module_name, value_name, value_line, expected) -> @@ -69,29 +70,20 @@ let test_project project ~math_module = false)) cases -(* Value usage analysis does not decode ReScript 13 typed trees yet; every - module must report -6 (unsupported compiler) instead of a count *) -let test_unsupported_project project = - printf "=== Value usage in %s (unsupported) ===\n" project; - let counts = - count_usage (find_bs_dir project) ~module_name:"Utils" - ~value_name:"multiply" ~value_line:2 - in - printf " Utils.multiply@2: %s\n" (format_counts counts); - counts <> [] && List.for_all (fun (_, count) -> count = -6) counts +(* loops.res uses step inside for...of, an optional parameter default, a + template literal, an object literal and an object field access *) +let rescript13_cases = [ ("Loops", "step", 1, [ ("Loops", 5) ]) ] let () = - let supported = + let results = [ - ("rescript", "Math"); - ("rescript12/basic", "MathUtil"); - ("rescript12/namespaced", "MathUtil"); + ("rescript", "Math", []); + ("rescript12/basic", "MathUtil", []); + ("rescript12/namespaced", "MathUtil", []); + ("rescript13/basic", "MathUtil", rescript13_cases); + ("rescript13/namespaced", "MathUtil", rescript13_cases); ] - |> List.map (fun (project, math_module) -> - test_project project ~math_module) - in - let unsupported = - [ "rescript13/basic"; "rescript13/namespaced" ] - |> List.map test_unsupported_project + |> List.map (fun (project, math_module, extra_cases) -> + test_project ~extra_cases project ~math_module) in - exit (if List.for_all Fun.id (supported @ unsupported) then 0 else 1) + exit (if List.for_all Fun.id results then 0 else 1) diff --git a/vendor/typedtree_v12.ml b/vendor/typedtree_v12.ml index 3451046..8c18ce8 100644 --- a/vendor/typedtree_v12.ml +++ b/vendor/typedtree_v12.ml @@ -1,4 +1,8 @@ -(* Typedtree layout written by ReScript 12 (compiler/ml/typedtree.mli). +(* Typedtree layout written by ReScript 12 (compiler/ml/typedtree.mli), which + ReScript 13.0.0-alpha.1 to alpha.3 keep unchanged. 13.0.0-alpha.5 adds the + [Texp_break] and [Texp_continue] constants and appends [Texp_for_of] and + [Texp_for_await_of]; ReScript 12 never writes them, so they are declared + here too and one definition reads all of these releases. CMT files are read with [input_value], so constructor order and arity must match the compiler exactly. Only the nodes that value usage analysis walks @@ -69,6 +73,8 @@ and expression_desc = | Texp_array of expression list | Texp_ifthenelse of expression * expression * expression option | Texp_sequence of expression * expression + | Texp_break + | Texp_continue | Texp_while of expression * expression | Texp_for of opaque * opaque * expression * expression * opaque * expression | Texp_send of expression * opaque * expression option @@ -77,6 +83,8 @@ and expression_desc = | Texp_assert of expression | Texp_pack of module_expr | Texp_extension_constructor of opaque * Path.t + | Texp_for_of of Ident.t * opaque * expression * expression + | Texp_for_await_of of Ident.t * opaque * expression * expression and case = { c_lhs : pattern; c_guard : expression option; c_rhs : expression } diff --git a/vendor/typedtree_v13.ml b/vendor/typedtree_v13.ml new file mode 100644 index 0000000..786d42c --- /dev/null +++ b/vendor/typedtree_v13.ml @@ -0,0 +1,168 @@ +(* Typedtree layout written by ReScript 13.0.0-alpha.6 + (compiler/ml/typedtree.mli), the first release with the Caml1999T037 CMT + format. + + CMT files are read with [input_value], so constructor order and arity must + match the compiler exactly. Only the nodes that value usage analysis walks + are spelled out; everything it never inspects is kept opaque. *) + +type opaque = Obj.t + +type pattern = { + pat_desc : pattern_desc; + pat_loc : Location.t; + pat_extra : opaque; + pat_type : opaque; + mutable pat_env : opaque; + pat_attributes : opaque; +} + +and pattern_desc = + | Tpat_any + | Tpat_var of Ident.t * string Asttypes.loc + | Tpat_alias of pattern * Ident.t * string Asttypes.loc + | Tpat_constant of opaque + | Tpat_tuple of pattern list + | Tpat_construct of opaque * opaque * pattern list + | Tpat_variant of opaque * pattern option * opaque + | Tpat_record of opaque * opaque * opaque + | Tpat_array of pattern list + | Tpat_or of pattern * pattern * opaque + +and expression = { + exp_desc : expression_desc; + exp_loc : Location.t; + exp_extra : opaque; + exp_type : opaque; + exp_env : opaque; + exp_attributes : opaque; +} + +and expression_desc = + | Texp_ident of Path.t * opaque * opaque + | Texp_constant of opaque + | Texp_let of opaque * value_binding list * expression + | Texp_function of { + params : function_param list; + body : expression; + async : bool; + } + | Texp_apply of { + funct : expression; + args : (opaque * expression option) list; + partial : bool; + transformed_jsx : bool; + } + | Texp_match of expression * case list * case list * opaque + | Texp_try of expression * case list + | Texp_tuple of expression list + | Texp_construct of opaque * opaque * expression list + | Texp_variant of opaque * expression option + | Texp_record of { + fields : (opaque * record_label_definition * bool) array; + representation : opaque; + extended_expression : expression option; + } + | Texp_field of expression * opaque * opaque + | Texp_setfield of expression * opaque * opaque * expression + | Texp_array of expression list + | Texp_ifthenelse of expression * expression * expression option + | Texp_sequence of expression * expression + | Texp_break + | Texp_continue + | Texp_while of expression * expression + | Texp_for of opaque * opaque * expression * expression * opaque * expression + | Texp_object_get of expression * opaque + | Texp_object_set of expression * opaque * expression + | Texp_object_literal of (opaque * expression) list + | Texp_letmodule of Ident.t * opaque * module_expr * expression + | Texp_letexception of opaque * expression + | Texp_assert of expression + | Texp_pack of module_expr + | Texp_extension_constructor of opaque * Path.t + | Texp_for_of of Ident.t * opaque * expression * expression + | Texp_for_await_of of Ident.t * opaque * expression * expression + | Texp_tagged_template of { + tag : expression; + raw_sources : string list; + values : expression list; + } + | Texp_template of { segments : opaque; values : expression list } + +and function_param = { + fp_lbl : opaque; + fp_param : Ident.t; + fp_pat : pattern; + fp_partial : opaque; + fp_has_default : bool; +} + +and case = { c_lhs : pattern; c_guard : expression option; c_rhs : expression } + +and record_label_definition = + | Kept of opaque + | Overridden of opaque * expression + +and value_binding = { + vb_pat : pattern; + vb_expr : expression; + vb_attributes : opaque; + vb_loc : Location.t; +} + +and module_expr = { + mod_desc : module_expr_desc; + mod_loc : Location.t; + mod_type : opaque; + mod_env : opaque; + mod_attributes : opaque; +} + +and module_expr_desc = + | Tmod_ident of Path.t * opaque + | Tmod_structure of structure + | Tmod_functor of Ident.t * opaque * opaque * module_expr + | Tmod_apply of module_expr * module_expr * opaque + | Tmod_constraint of module_expr * opaque * opaque * opaque + | Tmod_unpack of expression * opaque + +and structure = { + str_items : structure_item list; + str_type : opaque; + str_final_env : opaque; +} + +and structure_item = { + str_desc : structure_item_desc; + str_loc : Location.t; + str_env : opaque; +} + +and structure_item_desc = + | Tstr_eval of expression * opaque + | Tstr_value of opaque * value_binding list + | Tstr_primitive of opaque + | Tstr_type of opaque * opaque + | Tstr_typext of opaque + | Tstr_exception of opaque + | Tstr_module of module_binding + | Tstr_recmodule of module_binding list + | Tstr_modtype of opaque + | Tstr_open of opaque + | Tstr_include of include_declaration + | Tstr_attribute of opaque + +and module_binding = { + mb_id : Ident.t; + mb_name : opaque; + mb_expr : module_expr; + mb_attributes : opaque; + mb_loc : Location.t; +} + +and include_declaration = { + incl_mod : module_expr; + incl_type : opaque; + incl_loc : Location.t; + incl_attributes : opaque; +} From ccd2c90c528ec9f219e0cddd88a9c6e4808c17e5 Mon Sep 17 00:00:00 2001 From: mununki Date: Wed, 21 Oct 2026 22:42:28 +0900 Subject: [PATCH 4/4] Document why value usage analysis skips ReScript 13.0.0-alpha.4 --- README.md | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 2bc83c6..1a6643a 100644 --- a/README.md +++ b/README.md @@ -56,7 +56,7 @@ With `-vb`, each module reports its usage count, or a negative code when it coul | 11.0.0 - 11.1.4 | Yes | Yes | | 12.0.0 - 12.3.1 | Yes | Yes | | 13.0.0-alpha.1 - alpha.3, alpha.5, alpha.6 | Yes | Yes | -| 13.0.0-alpha.4 | Yes | No (`-6`) | +| 13.0.0-alpha.4 | Yes | No (`-6`), see below | rescriptdep identifies the compiler from each `.cmt` file and, for ReScript 12 and later, from the version rewatch records in `lib/bs/compiler-info.json`. Files in formats no supported compiler @@ -64,6 +64,18 @@ writes are rejected with an error instead of being misread. Other versions of a (for example a later 13.0 prerelease) get the dependency graph, and `-6` from `-vb` until their typed tree has been checked. +### ReScript 13.0.0-alpha.4 + +Value usage analysis (`-vb`, the inline "Used N times" count in the VS Code extension) is not +supported for projects built with 13.0.0-alpha.4, and every module reports `-6`. The dependency +graph works as usual. + +`-vb` reads the typed tree stored in `.cmt` files, which depends on the exact layout of the +compiler's data types. 13.0.0-alpha.4 inserted the `for...of` constructors in the middle of the +expression type, a layout no other release uses: 13.0.0-alpha.5 moved them to the end of the type. +Rather than keep a decoder for that single prerelease, rescriptdep skips it. Upgrade to +13.0.0-alpha.5 or later to use value usage analysis. + ## Development For detailed information about building the project, running tests, and contributing, please see [CONTRIBUTING.md](CONTRIBUTING.md).