├── .git-blame-ignore-revs ├── .github └── workflows │ ├── changelog.yml │ └── pr-number.yml ├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── CONTRIBUTING.md ├── LICENSE.md ├── README.md ├── api-watch.opam ├── bin ├── api_diff.ml └── dune ├── dev-tools ├── dune └── print_api.ml ├── dune-project ├── lib ├── api_watch.ml ├── diff.ml ├── diff.mli ├── dune ├── library.ml ├── library.mli ├── normalize.ml ├── normalize.mli ├── ocaml_types.ml ├── sig_item_map.ml ├── sig_item_map.mli ├── stddiff.ml ├── stddiff.mli ├── string_map.ml ├── string_map.mli ├── text_diff.ml ├── text_diff.mli ├── typing_env.ml └── typing_env.mli └── tests ├── api-diff ├── class_detection.t ├── cltype_tests.t ├── dune ├── errors.t ├── extension_constructors.t ├── fine_grained_type_expr.t ├── identical_cmi.t ├── modified_variant_type_tests.t ├── module_tests.t ├── module_type_test.t ├── module_type_vs_module_alias.t ├── parametrized_types_tests.t ├── project_comparison.t ├── record_type_tests.t ├── stack_overflow.t ├── stdlib.t ├── type_expansion.t ├── type_kind_tests.t ├── type_manifest_tests.t ├── type_privacy_tests.t ├── type_tests.t ├── value_tests.t └── word_based_diff_tests.t ├── api-watch ├── dune ├── stdlib.ml ├── test_diff.ml ├── test_diff_class.ml ├── test_diff_cltype.ml ├── test_diff_modtpe_decl.ml ├── test_diff_module.ml ├── test_expand_tconstr.ml ├── test_fully_expand_type_expr.ml ├── test_normalize.ml └── test_text_diff.ml └── test_helpers ├── dune ├── test_helpers.ml └── test_helpers.mli /.git-blame-ignore-revs: -------------------------------------------------------------------------------- 1 | # The commit upgrading to ocamlformat 0.26.1 2 | a6a668fc2780307116001f76b07a3f1a1be02592 3 | -------------------------------------------------------------------------------- /.github/workflows/changelog.yml: -------------------------------------------------------------------------------- 1 | name: Changelog check 2 | 3 | on: 4 | pull_request: 5 | branches: [ main ] 6 | types: [ opened, synchronize, reopened, labeled, unlabeled ] 7 | 8 | jobs: 9 | Changelog-Entry-Check: 10 | name: Check Changelog Action 11 | runs-on: ubuntu-20.04 12 | steps: 13 | - uses: tarides/changelog-check-action@v2 14 | -------------------------------------------------------------------------------- /.github/workflows/pr-number.yml: -------------------------------------------------------------------------------- 1 | name: PR number update 2 | 3 | on: [pull_request_target] 4 | 5 | jobs: 6 | PR-Number-Update: 7 | name: Update PR number 8 | runs-on: ubuntu-20.04 9 | steps: 10 | - uses: tarides/pr-number-action@v1.1 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | *.install 3 | _opam 4 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.26.2 2 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## unreleased 2 | 3 | ### Added 4 | 5 | - Add detection of type declarations changes (#92, @azzsal) 6 | - Add detection of module_type declarations changes (#93, @NchamJosephMuam) 7 | - Add detection of classes addition and removal (#90, @marcndo) 8 | - Add detection of addition and removal of class type declarations (#103, @azzsal) 9 | - Add initial support for unwrapped libraries (#107, @Siddhi-agg, @azzsal) 10 | - Add detection of modified class declarations and class types (#106, @azzsal) 11 | - Add word-level display of textual diffs in `api-diff`, enabled with the 12 | `--word-diff` flag (#131, #136, @azzsal) 13 | - Add `--plain` flag to `api-diff` to use text markers for inline highlighting. 14 | Can be used when the output doesn't support colors (#136, @azzsal) 15 | - Add fine-grained diff of tuple types (#139, @azzsal) 16 | - Add fine-grained diff of arrow types (#140, @azzsal) 17 | - Add fine-grained diff of type constructors (#148, @azzsal) 18 | - Add detection of addition, removal and modifications of extensible variant 19 | constructors (#146, @azzsal) 20 | 21 | ### Changed 22 | 23 | - Improve diff representation of modified record types (#109, @azzsal) 24 | - Improve diff representation of modified variant types (#111, @azzsal) 25 | - Improve the diff representation of type declarations with more fine grained diffing of 26 | type kind, type privacy and type manifest (#120, @azzsal) 27 | - Improve the diff representation of type declarations to have type parameters diff (#113,@azzsal) 28 | - Improve the textual diff representation output to have highlighting of exact 29 | changes in a line (#126,@azzsal) 30 | - Improve handling of type equalities across the reference and current 31 | versions of the interface. (#134, @azzsal) 32 | - Initialize the typing enviorment with the standard library 33 | 34 | ### Deprecated 35 | 36 | ### Fixed 37 | 38 | - Ignore hidden signature items (#102, @NchamJosephMuam) 39 | - Remove duplicate items in class and class types (#105, @azzsal) 40 | - Fixed loading of modules whose signature is given by a path to a module type: 41 | `module X : Y` (#128, @panglesd) 42 | - Fixed initialization of the typing enviorment (#134, @azzsal) 43 | - Fix a bug the was causing the tool to stack overflow when dealing with 44 | some instances of parametrized types (#134, @azzsal) 45 | - Fix a bug where the loader couldn't find module types defined in the same 46 | compilation unit. (#151, @NathanReb, @azzsal) 47 | 48 | ### Removed 49 | 50 | ### Security 51 | 52 | ## 0.1.1 53 | 54 | ### Fixed 55 | 56 | - Remove dependency on unreleased `diffutils` package 57 | (#88, #95, @azzsal) 58 | 59 | ## 0.1.0 60 | 61 | ### Added 62 | 63 | - First prototype of `api-diff` tool (@Siddhi-agg, @NathanReb) 64 | - First prototype of `api-watch` library (@Siddhi-agg, @NathanReb) 65 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # CONTRIBUTING 2 | 3 | ## Setting up your dev environment 4 | 5 | If you would like to contribute to `ocaml-api-watch` you will need to setup 6 | your dev environment first. You can follow the steps described below. 7 | 8 | First you need to clone the project locally on your machine: 9 | ``` 10 | git clone git@github.com:NathanReb/ocaml-api-watch.git 11 | ``` 12 | 13 | Now go into your local copy of the project: 14 | ``` 15 | cd ocaml-api-watch 16 | ``` 17 | 18 | And setup a local opam switch to install the right ocaml version along with the 19 | set of base dependencies: 20 | ``` 21 | opam switch create ./ --deps-only -t --with-dev-setup 22 | ``` 23 | 24 | You should also install `merlin` and `ocp-indent` for a better dev experience 25 | ``` 26 | opam install merlin ocp-indent 27 | ``` 28 | 29 | From there you should be all set. You can run the following commands to build 30 | the project: 31 | ``` 32 | dune build 33 | ``` 34 | 35 | To run the test suite: 36 | ``` 37 | dune runtest 38 | ``` 39 | 40 | To format the source and dune files: 41 | ``` 42 | dune build @fmt --auto-promote 43 | ``` 44 | 45 | ## Submitting your first contribution 46 | 47 | Before submitting a contribution, you will need to have your own fork of the 48 | project. You can create it by following 49 | [this link](https://github.com/NathanReb/ocaml-api-watch/fork). 50 | 51 | Add your fork as a git remote to your local git repository: 52 | ``` 53 | git remote add my-fork git@github.com:/ocaml-api-watch.git 54 | ``` 55 | 56 | Before working on your patch, make sure your main branch is up to date: 57 | ``` 58 | git checkout main 59 | git pull 60 | ``` 61 | 62 | You can now create a new branch where you can work on your changes: 63 | ``` 64 | git checkout -b 65 | ``` 66 | 67 | As you work on your changes, try to ensure that every commit builds and is 68 | correctly formatted. This will make it easier for maintainer to browse the 69 | history when they are looking for the source of the bug later on for instance. 70 | To do that, ensure that before you commit, you run the following commands: 71 | ``` 72 | dune build @fmt --auto-promote 73 | dune build 74 | ``` 75 | and that they exit successfully. 76 | 77 | Once your patch is complete, push your branch to your fork: 78 | ``` 79 | git push -u my-fork 80 | ``` 81 | 82 | Then head to the github project page, it should suggest you to open a PR 83 | for your newly updated branch. 84 | 85 | ## Writing tests 86 | 87 | This repo uses dune's cram tests feature for testing the provided tools and 88 | expect tests for testing our library functions. 89 | 90 | ### Cram tests 91 | 92 | We use cram tests to test our command line tools. 93 | 94 | Cram tests can be found in the `tests/api-diff` folder and are written in `.t` 95 | files. Those files are made out of text which is usually here to describe what 96 | the actual tests are doing and provide a bit of context. 97 | Among this text are also indented parts which are made of commands to execute 98 | and their expected output. 99 | 100 | For example: 101 | ``` 102 | In this test we will list the files available in the current directory. 103 | We should see two files 104 | 105 | $ ls 106 | some_file some_other_file 107 | ``` 108 | 109 | The two first lines are just descriptive text for the test. 110 | 111 | The next non empty lines are 112 | ``` 113 | $ ls 114 | ``` 115 | which is the command to run. Command lines are indented and start with a `$`. 116 | The line right below that is the command's expected output. 117 | 118 | When running the project test suite with 119 | ``` 120 | dune runtest 121 | ``` 122 | 123 | dune will execute those commands in a controlled environment and compare their 124 | output with the expected one. 125 | 126 | If all tests pass there will be no output to `dune runtest`. If some fails 127 | though, you will see a few diffs like this: 128 | ``` 129 | Done: 22/24 (jobs: 1)File "tests/api-watch/run.t", line 1, characters 0-0: 130 | git (internal) (exit 1) 131 | (cd _build/.sandbox/c19c63dd297f4f6a5ad4536031b70330/default && /usr/bin/git --no-pager diff --no-index --color=always -u ../../../default/tests/api-watch/run.t tests/api-watch/run.t.corrected) 132 | diff --git a/../../../default/tests/api-watch/run.t b/tests/api-watch/run.t.corrected 133 | index 58d9cd4..520d3bf 100644 134 | --- a/../../../default/tests/api-watch/run.t 135 | +++ b/tests/api-watch/run.t.corrected 136 | @@ -27,4 +27,4 @@ In this test we will list the files available in the current directory. 137 | We should see two files 138 | 139 | $ ls 140 | - some_file some_other_file 141 | + some_file some_file2 142 | ``` 143 | 144 | That means the command output was different from the expected one. You should 145 | fix the test until you have no diffs left. 146 | 147 | Sometimes though, it is expected that the output changes, for instance if the 148 | tool prints things in a different format than it used to. In that case, once you 149 | are sure the new output is correct according to your changes and what the test 150 | should show, you can accept this new version by running: 151 | ``` 152 | dune promote 153 | ``` 154 | 155 | This will update the expected output directly in the original `.t` file. 156 | 157 | #### Generating files on the fly 158 | 159 | It is often the case that when you write a test you will need input files for 160 | it. You could add those files to the repository and use them in the test but 161 | that results in a potentially large number of test files lying around and it 162 | also make it harder to read the test since you have to open several files to get 163 | the whole picture. 164 | 165 | What you can do instead is generate those files as part of the test, by using 166 | a bash' heredoc redirection. It's usually done like this: 167 | 168 | ``` 169 | For this test we need the following input file 170 | 171 | $ cat > ref.mli << EOF 172 | > type t = int 173 | > 174 | > val f : t -> string 175 | > EOF 176 | 177 | ``` 178 | 179 | Here, we generate a `ref.mli` file which contains the following: 180 | ``` 181 | type t = int 182 | 183 | val f : t -> string 184 | ``` 185 | 186 | the `<< EOF` part indicates that we use `EOF` as an end delimiter for our file. 187 | 188 | ### Expect tests 189 | 190 | Expect tests can be considered as the OCaml counterpart to cram tests. They use 191 | the same promotion workflow as cram tests: they contain the expected test 192 | output, if the test runner produces a different output from the one in the test 193 | file, it will show the diff. At this point you can either accept the change and 194 | promote it to the test file or try to fix the code until the output matches 195 | depending on the nature of the change. 196 | 197 | We use `ppx_expect` as our expect test runner, you can read the documentation on 198 | the project homepage [here](https://github.com/janestreet/ppx_expect). 199 | 200 | Our expect tests live in the `tests/api-watch` folder. They are written in 201 | regular `.ml` files. 202 | 203 | Imagine we want to test a simple `add` function that returns the sum of two 204 | integers, here's how we would go about it: 205 | ``` 206 | let%expect_test "0 is neutral" = 207 | let res = add 2 0 in 208 | Format.printf "%d" res; 209 | [%expect 2] 210 | ``` 211 | 212 | As you can see expected are written in a `let%expect_test "" = ...` 213 | let binding. You can define regular functions and values outside of those blocks 214 | in an expect test if you need to factor out some code. 215 | 216 | The test usually contain one or multiple calls to the function under test 217 | followed by printing statements and `[%expect ]` statements. 218 | The test runner will capture the output after executing the test block and 219 | compare it with the content of the `[%expect ...]` statements. 220 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | ## ISC License 2 | 3 | Copyright (c) 2021 Nathan Rebours 4 | 5 | Permission to use, copy, modify, and distribute this software for any 6 | purpose with or without fee is hereby granted, provided that the above 7 | copyright notice and this permission notice appear in all copies. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # api-watch 2 | 3 | *This project is WIP* 4 | 5 | `api-watch` povides libraries and tools to keep watch on your OCaml's library's API. 6 | 7 | It is a keystone of an effort to bring semantic versioning to the OCaml libraries ecosystem. 8 | -------------------------------------------------------------------------------- /api-watch.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Libraries and tools to keep watch on your OCaml lib's API changes" 4 | maintainer: ["Nathan Rebours "] 5 | authors: ["Nathan Rebours "] 6 | license: "ISC" 7 | homepage: "https://github.com/NathanReb/ocaml-api-watch" 8 | bug-reports: "https://github.com/NathanReb/ocaml-api-watch/issues" 9 | depends: [ 10 | "dune" {>= "2.7"} 11 | "ocaml" {>= "5.2.0" & < "5.3.0"} 12 | "ppx_expect" {with-test} 13 | "ppx_deriving" 14 | "ppxlib" 15 | "logs" 16 | "containers" 17 | "fmt" 18 | "cmdliner" {>= "1.1.0"} 19 | "ocamlformat" {with-dev-setup & = "0.26.2"} 20 | "odoc" {with-doc} 21 | ] 22 | build: [ 23 | ["dune" "subst"] {dev} 24 | [ 25 | "dune" 26 | "build" 27 | "-p" 28 | name 29 | "-j" 30 | jobs 31 | "@install" 32 | "@runtest" {with-test} 33 | "@doc" {with-doc} 34 | ] 35 | ] 36 | dev-repo: "git+https://github.com/NathanReb/ocaml-api-watch.git" 37 | -------------------------------------------------------------------------------- /bin/api_diff.ml: -------------------------------------------------------------------------------- 1 | let tool_name = "api-diff" 2 | 3 | type mode = Unwrapped | Wrapped of string | Cmi 4 | type mark = [ `Plain | `Color ] 5 | type display = Line of mark | Word of mark 6 | 7 | let display_mode word_diff plain = 8 | let mark = if plain then `Plain else `Color in 9 | if word_diff then Word mark else Line mark 10 | 11 | let both_directories reference current = 12 | match (Sys.is_directory reference, Sys.is_directory current) with 13 | | true, true -> Ok true 14 | | false, false -> Ok false 15 | | _ -> 16 | Error 17 | "Arguments must either both be directories or both single .cmi files." 18 | 19 | let print_warning main_module unwrapped = 20 | match (main_module, unwrapped) with 21 | | None, false -> () 22 | | Some _, false -> 23 | Printf.eprintf 24 | "%s: --main-module is ignored when diffing single .cmi files\n" 25 | tool_name 26 | | None, true -> 27 | Printf.eprintf 28 | "%s: --unwrapped is ignored when diffing single .cmi files\n" tool_name 29 | | Some _, true -> 30 | Printf.eprintf 31 | "%s: --main-module and --unwrapped are ignored when diffing single \ 32 | .cmi files\n" 33 | tool_name 34 | 35 | let mode ~reference ~current ~main_module ~unwrapped = 36 | let open CCResult.Infix in 37 | let* both_dirs = both_directories reference current in 38 | match (both_dirs, main_module, unwrapped) with 39 | | true, Some main_module, false -> Ok (Wrapped main_module) 40 | | true, None, true -> Ok Unwrapped 41 | | false, main_module, unwrapped -> 42 | print_warning main_module unwrapped; 43 | Ok Cmi 44 | | true, _, _ -> 45 | Error 46 | "Either --main-module or --unwrapped must be provided when diffing \ 47 | entire libraries." 48 | 49 | let print_diff text_diff display_mode = 50 | match display_mode with 51 | | Line mode -> 52 | Api_watch.Text_diff.With_colors.pp ~mode Format.std_formatter text_diff 53 | | Word mode -> 54 | Api_watch.Text_diff.Word.pp ~mode Format.std_formatter text_diff 55 | 56 | let run (`Word_diff word_diff) (`Plain plain) (`Main_module main_module) 57 | (`Unwrapped_library unwrapped) (`Ref_cmi reference) (`Current_cmi current) = 58 | let open CCResult.Infix in 59 | let* reference_map, current_map = 60 | let* curr_mode = mode ~reference ~current ~main_module ~unwrapped in 61 | match curr_mode with 62 | | Wrapped main_module -> 63 | let main_module = String.capitalize_ascii main_module in 64 | let+ reference_map = Api_watch.Library.load ~main_module reference 65 | and+ current_map = Api_watch.Library.load ~main_module current in 66 | (reference_map, current_map) 67 | | Unwrapped -> 68 | let+ reference_map = Api_watch.Library.load_unwrapped reference 69 | and+ current_map = Api_watch.Library.load_unwrapped current in 70 | (reference_map, current_map) 71 | | Cmi -> 72 | let+ reference_cmi, _ = Api_watch.Library.load_cmi reference 73 | and+ current_cmi, module_name = Api_watch.Library.load_cmi current in 74 | let reference_map = 75 | Api_watch.String_map.singleton module_name reference_cmi 76 | in 77 | let current_map = 78 | Api_watch.String_map.singleton module_name current_cmi 79 | in 80 | (reference_map, current_map) 81 | in 82 | let diff_map = 83 | Api_watch.Diff.library ~reference:reference_map ~current:current_map 84 | |> Api_watch.String_map.bindings 85 | |> List.filter_map (fun (_, v) -> v) 86 | in 87 | let has_changes = not (List.is_empty diff_map) in 88 | let display_mode = display_mode word_diff plain in 89 | List.iter 90 | (fun diff -> 91 | let text_diff = Api_watch.Text_diff.from_diff diff in 92 | print_diff text_diff display_mode) 93 | diff_map; 94 | if has_changes then Ok 1 else Ok 0 95 | 96 | let named f = Cmdliner.Term.(app (const f)) 97 | 98 | let plain = 99 | let doc = 100 | "Add text markers to the output to highlight inline changes. Deleted parts \ 101 | are wrapped between [-and-] and added parts between {+and+}. Useful for \ 102 | terminals or outputs that don't support colors." 103 | in 104 | named (fun x -> `Plain x) Cmdliner.Arg.(value & flag & info ~doc [ "plain" ]) 105 | 106 | let word_diff = 107 | let doc = "Display API changes in an inline word diff format." in 108 | named 109 | (fun x -> `Word_diff x) 110 | Cmdliner.Arg.(value & flag & info ~doc [ "word-diff" ]) 111 | 112 | let main_module = 113 | let docv = "MAIN_MODULE_NAME" in 114 | let doc = 115 | "The name of the library's main module. Ignored when diffing single \ 116 | $(b,.cmi) files." 117 | in 118 | named 119 | (fun x -> `Main_module x) 120 | Cmdliner.Arg.( 121 | value & opt (some string) None & info ~doc ~docv [ "main-module" ]) 122 | 123 | let unwrapped_library = 124 | let doc = 125 | "Loads a library without a main module. Ignored when diffing single \ 126 | $(b,.cmi) files." 127 | in 128 | named 129 | (fun x -> `Unwrapped_library x) 130 | Cmdliner.Arg.(value & flag & info ~doc [ "unwrapped" ]) 131 | 132 | let ref_cmi = 133 | let docv = "REF_CMI_FILES" in 134 | let doc = 135 | "A single $(b,.cmi) file or a directory containing all cmi files for the \ 136 | reference version" 137 | in 138 | named 139 | (fun x -> `Ref_cmi x) 140 | Cmdliner.Arg.(required & pos 0 (some file) None & info ~doc ~docv []) 141 | 142 | let current_cmi = 143 | let docv = "CURRENT_CMI_FILES" in 144 | let doc = 145 | "A single $(b,.cmi) file or a directory containing all cmi files for the \ 146 | current version" 147 | in 148 | named 149 | (fun x -> `Current_cmi x) 150 | Cmdliner.Arg.(required & pos 1 (some file) None & info ~doc ~docv []) 151 | 152 | let info = 153 | let open Cmdliner in 154 | Cmd.info tool_name ~version:"%%VERSION%%" ~exits:Cmd.Exit.defaults 155 | ~doc:"List API changes between two versions of a library" 156 | 157 | let term = 158 | Cmdliner.Term.( 159 | const run $ word_diff $ plain $ main_module $ unwrapped_library $ ref_cmi 160 | $ current_cmi) 161 | 162 | let () = 163 | Fmt_tty.setup_std_outputs (); 164 | let exit_code = Cmdliner.Cmd.eval_result' (Cmdliner.Cmd.v info term) in 165 | exit exit_code 166 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name api_diff) 3 | (public_name api-diff) 4 | (libraries api-watch cmdliner compiler-libs.common fmt.tty)) 5 | -------------------------------------------------------------------------------- /dev-tools/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name print_api) 3 | (libraries api-watch cmdliner compiler-libs.common)) 4 | -------------------------------------------------------------------------------- /dev-tools/print_api.ml: -------------------------------------------------------------------------------- 1 | let print_raw = new Api_watch.Ocaml_types.print 2 | 3 | let print_cmi ~raw path = 4 | let cmi_infos = Cmi_format.read_cmi path in 5 | Format.printf "cmi_name: %s\n" cmi_infos.cmi_name; 6 | Format.printf "cmi_sign:\n"; 7 | if raw then print_raw#signature cmi_infos.cmi_sign 8 | else Printtyp.signature Format.std_formatter cmi_infos.cmi_sign; 9 | Format.printf "\n" 10 | 11 | let all_cmi_files path = 12 | Sys.readdir path |> Array.to_list 13 | |> List.filter (fun p -> Filename.check_suffix p ".cmi") 14 | |> List.map (Filename.concat path) 15 | 16 | let run (`Raw raw) (`Main_module main_module) (`Input fn) = 17 | let open CCResult.Infix in 18 | match (Sys.is_directory fn, main_module) with 19 | | false, _ -> 20 | print_cmi ~raw fn; 21 | Ok () 22 | | true, None -> 23 | let cmi_files = all_cmi_files fn in 24 | List.iter (print_cmi ~raw) cmi_files; 25 | Ok () 26 | | true, Some main_module -> 27 | let+ sig_map = Api_watch.Library.load ~main_module fn in 28 | let sig_ = Api_watch.String_map.find main_module sig_map in 29 | Printtyp.signature Format.std_formatter sig_; 30 | Format.printf "\n" 31 | 32 | let named f = Cmdliner.Term.(app (const f)) 33 | 34 | let raw = 35 | let doc = "Prints the IDs of different signature items." in 36 | named (fun x -> `Raw x) Cmdliner.Arg.(value & flag & info ~doc [ "raw" ]) 37 | 38 | let main_module = 39 | let docv = "MAIN_MODULE_NAME" in 40 | let doc = 41 | "The name of the library's main module. Ignored when input is a $(b,.cmi) \ 42 | file" 43 | in 44 | named 45 | (fun x -> `Main_module x) 46 | Cmdliner.Arg.( 47 | value & opt (some string) None & info ~doc ~docv [ "main-module" ]) 48 | 49 | let input_file = 50 | let docv = "PATH" in 51 | let doc = 52 | "Path to the $(b,.cmi) file or lib directory. If $(docv) is directory\n\ 53 | \ and no $(b,--main-module) is provided, prints the API of all \ 54 | $(b,.cmi) files.\n\ 55 | \ If $(b,--main-module) is provided, prints the public API of the \ 56 | library." 57 | in 58 | named 59 | (fun x -> `Input x) 60 | Cmdliner.Arg.(required & pos 0 (some file) None & info ~doc ~docv []) 61 | 62 | let info = 63 | let open Cmdliner in 64 | Cmd.info "print_api" ~version:"%%VERSION%%" ~exits:Cmd.Exit.defaults 65 | ~doc:"Pretty prints the API of a $(b,.cmi) file or a whole library" 66 | 67 | let term = Cmdliner.Term.(const run $ raw $ main_module $ input_file) 68 | 69 | let () = 70 | let exit_code = Cmdliner.Cmd.eval_result (Cmdliner.Cmd.v info term) in 71 | exit exit_code 72 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | 3 | (name api-watch) 4 | 5 | (cram enable) 6 | (generate_opam_files true) 7 | 8 | (license ISC) 9 | (authors "Nathan Rebours ") 10 | (maintainers "Nathan Rebours ") 11 | (source 12 | (github NathanReb/ocaml-api-watch)) 13 | 14 | (package 15 | (name api-watch) 16 | (synopsis "Libraries and tools to keep watch on your OCaml lib's API changes") 17 | (depends 18 | (ocaml (and (>= 5.2.0) (< 5.3.0))) 19 | (ppx_expect :with-test) 20 | ppx_deriving 21 | ppxlib 22 | logs 23 | containers 24 | fmt 25 | (cmdliner (>= 1.1.0)) 26 | (ocamlformat (and :with-dev-setup (= 0.26.2))))) 27 | -------------------------------------------------------------------------------- /lib/api_watch.ml: -------------------------------------------------------------------------------- 1 | module String_map = String_map 2 | module Diff = Diff 3 | module Text_diff = Text_diff 4 | module Library = Library 5 | module Normalize = Normalize 6 | module Stddiff = Stddiff 7 | module Ocaml_types = Ocaml_types 8 | module Typing_env = Typing_env 9 | -------------------------------------------------------------------------------- /lib/diff.ml: -------------------------------------------------------------------------------- 1 | type type_expr = 2 | | Tuple of tuple 3 | | Arrow of arrow 4 | | Constr of constr 5 | | Atomic of Types.type_expr Stddiff.atomic_modification 6 | 7 | and tuple = (Types.type_expr, type_expr) Stddiff.List.t 8 | 9 | and arrow = { 10 | arg_label : 11 | ( arg_label option, 12 | (arg_label, arg_label_diff) Stddiff.Option.t ) 13 | Stddiff.maybe_changed; 14 | arg_type : (Types.type_expr, type_expr) Stddiff.maybe_changed; 15 | return_type : (Types.type_expr, type_expr) Stddiff.maybe_changed; 16 | } 17 | 18 | and arg_label = Labelled_arg of string | Optional_arg of string 19 | 20 | and arg_label_diff = { 21 | name : (string, string Stddiff.atomic_modification) Stddiff.maybe_changed; 22 | arg_optional : (bool, arg_optional) Stddiff.maybe_changed; 23 | } 24 | 25 | and arg_optional = Added_opt_arg | Removed_opt_arg 26 | 27 | and constr = { 28 | path : (Path.t, Path.t Stddiff.atomic_modification) Stddiff.maybe_changed; 29 | args : 30 | ( Types.type_expr list, 31 | ( Types.type_expr list, 32 | (Types.type_expr, type_expr) Stddiff.List.t ) 33 | Stddiff.entry ) 34 | Stddiff.maybe_changed; 35 | } 36 | 37 | type type_modification = { 38 | type_kind : (Types.type_decl_kind, type_kind) Stddiff.maybe_changed; 39 | type_privacy : (Asttypes.private_flag, type_privacy) Stddiff.maybe_changed; 40 | type_manifest : 41 | ( Types.type_expr option, 42 | (Types.type_expr, type_expr) Stddiff.Option.t ) 43 | Stddiff.maybe_changed; 44 | type_params : 45 | ( Types.type_expr list, 46 | ( Types.type_expr list, 47 | (Types.type_expr, type_expr) Stddiff.List.t ) 48 | Stddiff.entry ) 49 | Stddiff.maybe_changed; 50 | } 51 | 52 | and type_kind = 53 | | Record_tk of (Types.label_declaration, label) Stddiff.Map.t 54 | | Variant_tk of (Types.constructor_declaration, cstr_args) Stddiff.Map.t 55 | | Atomic_tk of Types.type_decl_kind Stddiff.atomic_modification 56 | 57 | and label = { 58 | label_type : (Types.type_expr, type_expr) Stddiff.maybe_changed; 59 | label_mutable : 60 | (Asttypes.mutable_flag, field_mutability) Stddiff.maybe_changed; 61 | } 62 | 63 | and field_mutability = Added_m | Removed_m 64 | 65 | and cstr_args = 66 | | Record_cstr of (Types.label_declaration, label) Stddiff.Map.t 67 | | Tuple_cstr of tuple 68 | | Atomic_cstr of Types.constructor_arguments Stddiff.atomic_modification 69 | 70 | and type_privacy = Added_p | Removed_p 71 | 72 | type type_ = { 73 | tname : string; 74 | tdiff : (Types.type_declaration, type_modification) Stddiff.entry; 75 | } 76 | 77 | type value = { 78 | vname : string; 79 | vdiff : (Types.value_description, type_expr) Stddiff.entry; 80 | } 81 | 82 | type class_ = { 83 | cname : string; 84 | cdiff : Types.class_declaration Stddiff.atomic_entry; 85 | } 86 | 87 | type cltype = { 88 | ctname : string; 89 | ctdiff : Types.class_type_declaration Stddiff.atomic_entry; 90 | } 91 | 92 | type extcstr = { 93 | ecname : string; 94 | ectname : string; 95 | ecexn : bool; 96 | ecdiff : (Types.extension_constructor, extcstr_modification) Stddiff.entry; 97 | } 98 | 99 | and extcstr_modification = { 100 | extcstr_params : 101 | ( Types.type_expr list, 102 | ( Types.type_expr list, 103 | (Types.type_expr, type_expr) Stddiff.List.t ) 104 | Stddiff.entry ) 105 | Stddiff.maybe_changed; 106 | extcstr_private : (Asttypes.private_flag, type_privacy) Stddiff.maybe_changed; 107 | extcstr_args : (Types.constructor_arguments, cstr_args) Stddiff.maybe_changed; 108 | } 109 | 110 | type module_ = { 111 | mname : string; 112 | mdiff : (Types.module_declaration, signature_modification) Stddiff.entry; 113 | } 114 | 115 | and modtype = { 116 | mtname : string; 117 | mtdiff : (Types.modtype_declaration, signature_modification) Stddiff.entry; 118 | } 119 | 120 | and signature_modification = Unsupported | Supported of sig_item list 121 | 122 | and sig_item = 123 | | Value of value 124 | | Module of module_ 125 | | Type of type_ 126 | | Modtype of modtype 127 | | Class of class_ 128 | | Classtype of cltype 129 | | Extcstr of extcstr 130 | 131 | let extract_items items = 132 | List.fold_left 133 | (fun tbl item -> 134 | match (item : Types.signature_item) with 135 | | Sig_module (id, _, mod_decl, _, Exported) -> 136 | Sig_item_map.add ~name:(Ident.name id) Sig_item_map.Module mod_decl 137 | tbl 138 | | Sig_modtype (id, mtd_decl, Exported) -> 139 | Sig_item_map.add ~name:(Ident.name id) Sig_item_map.Modtype mtd_decl 140 | tbl 141 | | Sig_value (id, val_des, Exported) -> 142 | Sig_item_map.add ~name:(Ident.name id) Sig_item_map.Value val_des tbl 143 | | Sig_type (id, type_decl, _, Exported) -> 144 | if 145 | Sig_item_map.has ~name:(Ident.name id) Sig_item_map.Class tbl 146 | || Sig_item_map.has ~name:(Ident.name id) Sig_item_map.Classtype tbl 147 | then tbl 148 | else 149 | Sig_item_map.add ~name:(Ident.name id) Sig_item_map.Type 150 | (type_decl, id) tbl 151 | | Sig_class (id, cls_decl, _, Exported) -> 152 | Sig_item_map.add ~name:(Ident.name id) Sig_item_map.Class cls_decl tbl 153 | | Sig_class_type (id, class_type_decl, _, Exported) -> 154 | if Sig_item_map.has ~name:(Ident.name id) Sig_item_map.Class tbl then 155 | tbl 156 | else 157 | Sig_item_map.add ~name:(Ident.name id) Sig_item_map.Classtype 158 | class_type_decl tbl 159 | | Sig_typext (id, typext, status, Exported) -> 160 | let exn = match status with Text_exception -> true | _ -> false in 161 | Sig_item_map.add 162 | ~name:(Path.name typext.ext_type_path) 163 | (Sig_item_map.Extcstr (Ident.name id)) 164 | (typext, exn) tbl 165 | | _ -> tbl) 166 | Sig_item_map.empty items 167 | 168 | let extract_lbls lbls = 169 | List.fold_left 170 | (fun map lbl -> String_map.add (Ident.name lbl.Types.ld_id) lbl map) 171 | String_map.empty lbls 172 | 173 | let extract_cstrs cstrs = 174 | List.fold_left 175 | (fun map cstr -> String_map.add (Ident.name cstr.Types.cd_id) cstr map) 176 | String_map.empty cstrs 177 | 178 | let module_type_fallback ~loc ~typing_env ~name ~reference ~current = 179 | let modtype_coercion1 () = 180 | Includemod.modtypes ~loc typing_env ~mark:Mark_both reference current 181 | in 182 | let modtype_coercion2 () = 183 | Includemod.modtypes ~loc typing_env ~mark:Mark_both current reference 184 | in 185 | match (modtype_coercion1 (), modtype_coercion2 ()) with 186 | | Tcoerce_none, Tcoerce_none -> None 187 | | _, _ -> Some (Module { mname = name; mdiff = Modified Unsupported }) 188 | | exception Includemod.Error _ -> 189 | Some (Module { mname = name; mdiff = Modified Unsupported }) 190 | 191 | let expand_alias_types ~typing_env ~type_expr = 192 | Ctype.full_expand ~may_forget_scope:false typing_env type_expr 193 | 194 | let rec type_expr ~typing_env ?(ref_params = []) ?(cur_params = []) reference 195 | current = 196 | match (Types.get_desc reference, Types.get_desc current) with 197 | | Ttuple ref_exps, Ttuple cur_exps -> ( 198 | let type_exprs = 199 | type_exprs ~typing_env ~ref_params ~cur_params ~reference:ref_exps 200 | ~current:cur_exps 201 | in 202 | match type_exprs with 203 | | Stddiff.Same _ -> Stddiff.Same reference 204 | | Changed change -> Changed (Tuple change)) 205 | | ( Tarrow (ref_arg_label, ref_arg_type, ref_return_type, _), 206 | Tarrow (cur_arg_label, cur_arg_type, cur_return_type, _) ) -> ( 207 | let arrow = 208 | arrow ~typing_env ~ref_params ~cur_params 209 | ~reference:(ref_arg_label, ref_arg_type, ref_return_type) 210 | ~current:(cur_arg_label, cur_arg_type, cur_return_type) 211 | in 212 | match arrow with 213 | | Stddiff.Same _ -> Stddiff.Same reference 214 | | Changed change -> Changed (Arrow change)) 215 | | Tconstr (ref_path, ref_args, _), Tconstr (cur_path, cur_args, _) -> 216 | expand_and_diff_tconstr ~typing_env ~ref_params ~cur_params 217 | ~reference:(reference, ref_path, ref_args) 218 | ~current:(current, cur_path, cur_args) 219 | | _ -> 220 | let normed_ref, normed_cur = 221 | Normalize.type_params_arity ~reference:ref_params ~current:cur_params 222 | in 223 | if 224 | Ctype.is_equal typing_env true 225 | (normed_ref @ [ reference ]) 226 | (normed_cur @ [ current ]) 227 | then Same reference 228 | else 229 | Changed 230 | (Atomic 231 | { 232 | reference = expand_alias_types ~typing_env ~type_expr:reference; 233 | current = expand_alias_types ~typing_env ~type_expr:current; 234 | }) 235 | 236 | and expand_and_diff_tconstr ~typing_env ~ref_params ~cur_params ~reference 237 | ~current = 238 | let ref_expr, ref_path, ref_args = reference in 239 | let cur_expr, cur_path, cur_args = current in 240 | let expanded_ref = 241 | Option.value 242 | (Typing_env.fully_expand_tconstr ~typing_env ~path:ref_path ~args:ref_args) 243 | ~default:ref_expr 244 | in 245 | let expanded_cur = 246 | Option.value 247 | (Typing_env.fully_expand_tconstr ~typing_env ~path:cur_path ~args:cur_args) 248 | ~default:cur_expr 249 | in 250 | match (Types.get_desc expanded_ref, Types.get_desc expanded_cur) with 251 | | Tconstr (ref_path, ref_args, _), Tconstr (cur_path, cur_args, _) -> ( 252 | let constr = 253 | constr ~typing_env ~ref_params ~cur_params 254 | ~reference:(ref_path, ref_args) ~current:(cur_path, cur_args) 255 | in 256 | match constr with 257 | | Stddiff.Same _ -> Stddiff.Same cur_expr 258 | | Changed change -> Changed change) 259 | | _, _ -> ( 260 | let diff = 261 | type_expr ~typing_env ~ref_params ~cur_params expanded_ref expanded_cur 262 | in 263 | match diff with 264 | | Same _ -> Same cur_expr 265 | | Changed change -> Changed change) 266 | 267 | and constr ~typing_env ~ref_params ~cur_params ~reference ~current = 268 | let open Stddiff in 269 | let ref_path, ref_args = reference in 270 | let cur_path, cur_args = current in 271 | let path = 272 | if String.equal (Path.name ref_path) (Path.name cur_path) then Same ref_path 273 | else Changed { reference = ref_path; current = cur_path } 274 | in 275 | let args = 276 | match (ref_args, cur_args) with 277 | | [], _ :: _ -> Changed (Added cur_args) 278 | | _ :: _, [] -> Changed (Removed ref_args) 279 | | _ -> ( 280 | let type_exprs = 281 | type_exprs ~typing_env ~ref_params ~cur_params ~reference:ref_args 282 | ~current:cur_args 283 | in 284 | match type_exprs with 285 | | Same same_params -> Same same_params 286 | | Changed change -> Changed (Modified change)) 287 | in 288 | match (path, args) with 289 | | Same _, Same _ -> Same current 290 | | _ -> Changed (Constr { path; args }) 291 | 292 | and type_exprs ~typing_env ~ref_params ~cur_params ~reference ~current = 293 | Stddiff.List.diff 294 | ~diff_one:(fun ref cur -> 295 | type_expr ~typing_env ~ref_params ~cur_params ref cur) 296 | ~reference ~current 297 | 298 | and arrow ~typing_env ~ref_params ~cur_params ~reference ~current = 299 | let unwrap_optional_arg lbl typ = 300 | match lbl with 301 | | Asttypes.Nolabel | Labelled _ -> typ 302 | | Optional _ -> ( 303 | match Types.get_desc typ with 304 | | Tconstr (_, [ te ], _) -> te 305 | | _ -> assert false) 306 | in 307 | let ref_arg_label, ref_arg_type, ref_return_type = reference in 308 | let cur_arg_label, cur_arg_type, cur_return_type = current in 309 | let arg_label = arg_label ~reference:ref_arg_label ~current:cur_arg_label in 310 | let arg_type = 311 | type_expr ~typing_env ~ref_params ~cur_params 312 | (unwrap_optional_arg ref_arg_label ref_arg_type) 313 | (unwrap_optional_arg cur_arg_label cur_arg_type) 314 | in 315 | let return_type = 316 | type_expr ~typing_env ~ref_params ~cur_params ref_return_type 317 | cur_return_type 318 | in 319 | match (arg_label, arg_type, return_type) with 320 | | Stddiff.Same _, Same _, Same _ -> Same reference 321 | | _ -> Changed { arg_label; arg_type; return_type } 322 | 323 | and arg_label ~reference ~current = 324 | let open Stddiff in 325 | let convert = function 326 | | Asttypes.Nolabel -> None 327 | | Labelled name -> Some (Labelled_arg name) 328 | | Optional name -> Some (Optional_arg name) 329 | in 330 | Option.diff 331 | ~diff_one:(fun ref cur -> 332 | match (ref, cur) with 333 | | Labelled_arg ref_name, Labelled_arg cur_name -> 334 | if String.equal ref_name cur_name then Same (Labelled_arg ref_name) 335 | else 336 | Changed 337 | { 338 | name = Changed { reference = ref_name; current = cur_name }; 339 | arg_optional = Same false; 340 | } 341 | | Labelled_arg ref_name, Optional_arg cur_name -> 342 | let name = 343 | if String.equal ref_name cur_name then Same ref_name 344 | else Changed { reference = ref_name; current = cur_name } 345 | in 346 | let arg_optional = Changed Added_opt_arg in 347 | Changed { name; arg_optional } 348 | | Optional_arg ref_name, Labelled_arg cur_name -> 349 | let name = 350 | if String.equal ref_name cur_name then Same ref_name 351 | else Changed { reference = ref_name; current = cur_name } 352 | in 353 | let arg_optional = Changed Removed_opt_arg in 354 | Changed { name; arg_optional } 355 | | Optional_arg ref_name, Optional_arg cur_name -> 356 | if String.equal ref_name cur_name then Same (Optional_arg ref_name) 357 | else 358 | Changed 359 | { 360 | name = Changed { reference = ref_name; current = cur_name }; 361 | arg_optional = Same true; 362 | }) 363 | ~reference:(convert reference) ~current:(convert current) 364 | 365 | let rec type_item ~typing_env ~name ~reference ~current = 366 | match (reference, current) with 367 | | None, None -> None 368 | | Some (reference, _), None -> 369 | Some (Type { tname = name; tdiff = Removed reference }) 370 | | None, Some (current, _) -> 371 | Some (Type { tname = name; tdiff = Added current }) 372 | | Some (reference, _), Some (current, _) -> 373 | type_declarations ~typing_env ~name ~reference ~current 374 | 375 | and type_declarations ~typing_env ~name ~reference ~current = 376 | if 377 | Normalize.is_type_params ~reference:reference.Types.type_params 378 | ~current:current.Types.type_params 379 | then () 380 | else Normalize.type_declarations ~reference ~current; 381 | let ref_params = reference.type_params in 382 | let cur_params = current.type_params in 383 | let type_kind = 384 | type_kind ~typing_env ~ref_params ~cur_params ~reference:reference.type_kind 385 | ~current:current.type_kind 386 | in 387 | let type_privacy = 388 | type_privacy ~reference:reference.type_private ~current:current.type_private 389 | in 390 | let type_manifest = 391 | type_manifest ~typing_env ~ref_params ~cur_params 392 | ~reference:reference.type_manifest ~current:current.type_manifest 393 | in 394 | let type_params = type_params ~reference:ref_params ~current:cur_params in 395 | match { type_kind; type_privacy; type_manifest; type_params } with 396 | | { 397 | type_kind = Same _; 398 | type_privacy = Same _; 399 | type_manifest = Same _; 400 | type_params = Same _; 401 | } -> 402 | None 403 | | diff -> Some (Type { tname = name; tdiff = Modified diff }) 404 | 405 | and type_kind ~typing_env ~ref_params ~cur_params ~reference ~current = 406 | let open Stddiff.Map in 407 | match (reference, current) with 408 | | Type_record (ref_label_lst, _), Type_record (cur_label_lst, _) -> 409 | let label_map = 410 | record_type ~typing_env ~ref_params ~cur_params ~ref_label_lst 411 | ~cur_label_lst 412 | in 413 | if String_map.is_empty label_map.changed_map then Same reference 414 | else Changed (Record_tk label_map) 415 | | Type_variant (ref_constructor_lst, _), Type_variant (cur_constructor_lst, _) 416 | -> 417 | let cstr_map = 418 | variant_type ~typing_env ~ref_params ~cur_params ~ref_constructor_lst 419 | ~cur_constructor_lst 420 | in 421 | if String_map.is_empty cstr_map.changed_map then Same reference 422 | else Changed (Variant_tk cstr_map) 423 | | Type_abstract _, Type_abstract _ -> Same reference 424 | | Type_open, Type_open -> Same reference 425 | | ref_type_kind, cur_type_kind -> 426 | Changed (Atomic_tk { reference = ref_type_kind; current = cur_type_kind }) 427 | 428 | and record_type ~typing_env ~ref_params ~cur_params ~ref_label_lst 429 | ~cur_label_lst = 430 | let open Stddiff in 431 | let ref_lbls = extract_lbls ref_label_lst in 432 | let cur_lbls = extract_lbls cur_label_lst in 433 | Map.diff 434 | ~diff_one:(label ~typing_env ~ref_params ~cur_params) 435 | ~reference:ref_lbls ~current:cur_lbls 436 | 437 | and label ~typing_env ~ref_params ~cur_params reference current = 438 | let open Stddiff in 439 | let label_type = 440 | type_expr ~typing_env ~ref_params ~cur_params reference.ld_type 441 | current.ld_type 442 | in 443 | let label_mutable = 444 | label_mutable ~reference:reference.ld_mutable ~current:current.ld_mutable 445 | in 446 | match (label_type, label_mutable) with 447 | | Same _, Same _ -> Same reference 448 | | Same _, label_mutable -> 449 | Changed { label_type = Same reference.ld_type; label_mutable } 450 | | Changed type_diff, label_mutable -> 451 | Changed { label_type = Changed type_diff; label_mutable } 452 | 453 | and label_mutable ~reference ~current = 454 | match (reference, current) with 455 | | Asttypes.Mutable, Asttypes.Mutable | Asttypes.Immutable, Asttypes.Immutable 456 | -> 457 | Same reference 458 | | Asttypes.Mutable, Asttypes.Immutable -> Changed Removed_m 459 | | Asttypes.Immutable, Asttypes.Mutable -> Changed Added_m 460 | 461 | and variant_type ~typing_env ~ref_params ~cur_params ~ref_constructor_lst 462 | ~cur_constructor_lst = 463 | let open Stddiff in 464 | let ref_cstrs = extract_cstrs ref_constructor_lst in 465 | let cur_cstrs = extract_cstrs cur_constructor_lst in 466 | Map.diff 467 | ~diff_one:(cstr ~typing_env ~ref_params ~cur_params) 468 | ~reference:ref_cstrs ~current:cur_cstrs 469 | 470 | and cstr ~typing_env ~ref_params ~cur_params reference current = 471 | let diff = 472 | cstr_args ~typing_env ~ref_params ~cur_params ~reference:reference.cd_args 473 | ~current:current.cd_args 474 | in 475 | match diff with 476 | | Stddiff.Same _ -> Same reference 477 | | Changed change -> Changed change 478 | 479 | and cstr_args ~typing_env ~ref_params ~cur_params ~reference ~current = 480 | match (reference, current) with 481 | | Cstr_tuple ref_type_exprs, Cstr_tuple cur_type_exprs -> ( 482 | let type_exprs = 483 | type_exprs ~typing_env ~ref_params ~cur_params ~reference:ref_type_exprs 484 | ~current:cur_type_exprs 485 | in 486 | match type_exprs with 487 | | Same _ -> Same reference 488 | | Changed change -> Changed (Tuple_cstr change)) 489 | | Cstr_record ref_record, Cstr_record cur_record -> 490 | let label_map = 491 | record_type ~typing_env ~ref_params ~cur_params 492 | ~ref_label_lst:ref_record ~cur_label_lst:cur_record 493 | in 494 | if String_map.is_empty label_map.changed_map then Same reference 495 | else Changed (Record_cstr label_map) 496 | | _ -> Changed (Atomic_cstr { reference; current }) 497 | 498 | and type_params ~reference ~current = 499 | let open Stddiff in 500 | match (reference, current) with 501 | | [], _ :: _ -> Changed (Added current) 502 | | _ :: _, [] -> Changed (Removed reference) 503 | | _ -> ( 504 | let params_diff = 505 | List.diff ~diff_one:(fun t1 _ -> Same t1) ~reference ~current 506 | in 507 | match params_diff with 508 | | Same same_params -> Same same_params 509 | | Changed change -> Changed (Modified change)) 510 | 511 | and type_privacy ~reference ~current = 512 | match (reference, current) with 513 | | Asttypes.Public, Asttypes.Public -> Same Asttypes.Public 514 | | Asttypes.Public, Asttypes.Private -> Changed Added_p 515 | | Asttypes.Private, Asttypes.Public -> Changed Removed_p 516 | | Asttypes.Private, Asttypes.Private -> Same Asttypes.Private 517 | 518 | and type_manifest ~typing_env ~ref_params ~cur_params ~reference ~current = 519 | let open Stddiff in 520 | Option.diff 521 | ~diff_one:(type_expr ~typing_env ~ref_params ~cur_params) 522 | ~reference ~current 523 | 524 | let value_descripiton ~typing_env reference current = 525 | let open Types in 526 | type_expr ~typing_env reference.val_type current.val_type 527 | 528 | let value_item ~typing_env ~name ~reference ~current = 529 | match (reference, current) with 530 | | None, None -> None 531 | | Some reference, None -> 532 | Some (Value { vname = name; vdiff = Removed reference }) 533 | | None, Some current -> Some (Value { vname = name; vdiff = Added current }) 534 | | Some reference, Some current -> ( 535 | let val_type_diff = value_descripiton ~typing_env reference current in 536 | match val_type_diff with 537 | | Same _ -> None 538 | | Changed type_expr_diff -> 539 | Some (Value { vname = name; vdiff = Modified type_expr_diff })) 540 | 541 | let class_item ~typing_env ~name ~(reference : Types.class_declaration option) 542 | ~(current : Types.class_declaration option) = 543 | match (reference, current) with 544 | | None, None -> None 545 | | None, Some curr_cls -> Some (Class { cname = name; cdiff = Added curr_cls }) 546 | | Some ref_cls, None -> Some (Class { cname = name; cdiff = Removed ref_cls }) 547 | | Some ref_cls, Some curr_cls -> ( 548 | let cls_mismatch_lst = 549 | Includeclass.class_declarations typing_env ref_cls curr_cls 550 | in 551 | match cls_mismatch_lst with 552 | | [] -> None 553 | | _ -> 554 | Some 555 | (Class 556 | { 557 | cname = name; 558 | cdiff = Modified { reference = ref_cls; current = curr_cls }; 559 | })) 560 | 561 | let class_type_item ~typing_env ~name 562 | ~(reference : Types.class_type_declaration option) 563 | ~(current : Types.class_type_declaration option) = 564 | match (reference, current) with 565 | | None, None -> None 566 | | None, Some curr_class_type -> 567 | Some (Classtype { ctname = name; ctdiff = Added curr_class_type }) 568 | | Some ref_class_type, None -> 569 | Some (Classtype { ctname = name; ctdiff = Removed ref_class_type }) 570 | | Some ref_class_type, Some curr_class_type -> ( 571 | let cls_type_mismatch_lst = 572 | Includeclass.class_type_declarations ~loc:ref_class_type.clty_loc 573 | typing_env ref_class_type curr_class_type 574 | in 575 | match cls_type_mismatch_lst with 576 | | [] -> None 577 | | _ -> 578 | Some 579 | (Classtype 580 | { 581 | ctname = name; 582 | ctdiff = 583 | Modified 584 | { reference = ref_class_type; current = curr_class_type }; 585 | })) 586 | 587 | let extension_constructors ~typing_env ~type_name ~name ~reference ~current = 588 | let ref_exn, ref_extcstr = reference in 589 | let cur_exn, cur_extcstr = current in 590 | let ecexn = 591 | match (ref_exn, cur_exn) with 592 | | true, true | false, false -> ref_exn 593 | | _ -> false 594 | in 595 | let extcstr_params = 596 | type_params ~reference:ref_extcstr.Types.ext_type_params 597 | ~current:cur_extcstr.Types.ext_type_params 598 | in 599 | let extcstr_private = 600 | type_privacy ~reference:ref_extcstr.ext_private 601 | ~current:cur_extcstr.ext_private 602 | in 603 | let extcstr_args = 604 | cstr_args ~typing_env ~ref_params:ref_extcstr.ext_type_params 605 | ~cur_params:cur_extcstr.ext_type_params ~reference:ref_extcstr.ext_args 606 | ~current:cur_extcstr.ext_args 607 | in 608 | match { extcstr_params; extcstr_private; extcstr_args } with 609 | | { 610 | extcstr_params = Same _ | Changed _; 611 | extcstr_private = Same _; 612 | extcstr_args = Same _; 613 | } -> 614 | None 615 | | diff -> 616 | Some 617 | (Extcstr 618 | { ecname = name; ectname = type_name; ecexn; ecdiff = Modified diff }) 619 | 620 | let extcstr_item ~typing_env ~type_name ~name ~reference ~current = 621 | match (reference, current) with 622 | | None, None -> None 623 | | None, Some (curr_extcstr, curr_exn) -> 624 | Some 625 | (Extcstr 626 | { 627 | ecname = name; 628 | ectname = type_name; 629 | ecexn = curr_exn; 630 | ecdiff = Added curr_extcstr; 631 | }) 632 | | Some (ref_extcstr, ref_exn), None -> 633 | Some 634 | (Extcstr 635 | { 636 | ecname = name; 637 | ectname = type_name; 638 | ecexn = ref_exn; 639 | ecdiff = Removed ref_extcstr; 640 | }) 641 | | Some (ref_extcstr, ref_exn), Some (cur_extcstr, cur_exn) -> 642 | extension_constructors ~typing_env ~type_name ~name 643 | ~reference:(ref_exn, ref_extcstr) ~current:(cur_exn, cur_extcstr) 644 | 645 | let rec items ~reference ~current ~typing_env = 646 | let ref_items = extract_items reference in 647 | let curr_items = extract_items current in 648 | let diff_item : type a. (a, 'diff) Sig_item_map.diff_item = 649 | fun item_type name reference current -> 650 | match item_type with 651 | | Value -> value_item ~typing_env ~name ~reference ~current 652 | | Module -> module_item ~typing_env ~name ~reference ~current 653 | | Modtype -> module_type_item ~typing_env ~name ~reference ~current 654 | | Type -> type_item ~typing_env ~name ~reference ~current 655 | | Class -> class_item ~typing_env ~name ~reference ~current 656 | | Classtype -> class_type_item ~typing_env ~name ~reference ~current 657 | | Extcstr extcstr_name -> 658 | extcstr_item ~typing_env ~name:extcstr_name ~type_name:name ~reference 659 | ~current 660 | in 661 | Sig_item_map.diff ~diff_item:{ diff_item } ref_items curr_items 662 | 663 | and module_item ~typing_env ~name ~(reference : Types.module_declaration option) 664 | ~(current : Types.module_declaration option) = 665 | match (reference, current) with 666 | | None, None -> None 667 | | None, Some curr_md -> Some (Module { mname = name; mdiff = Added curr_md }) 668 | | Some ref_md, None -> Some (Module { mname = name; mdiff = Removed ref_md }) 669 | | Some reference, Some current -> 670 | module_declaration ~typing_env ~name ~reference ~current 671 | 672 | and module_type_item ~typing_env ~name 673 | ~(reference : Types.modtype_declaration option) 674 | ~(current : Types.modtype_declaration option) = 675 | match (reference, current) with 676 | | None, None -> None 677 | | None, Some curr_mtd -> 678 | Some (Modtype { mtname = name; mtdiff = Added curr_mtd }) 679 | | Some ref_mtd, None -> 680 | Some (Modtype { mtname = name; mtdiff = Removed ref_mtd }) 681 | | Some ref_mtd, Some curr_mtd -> 682 | modtype_declaration ~typing_env ~name ~reference:ref_mtd ~current:curr_mtd 683 | 684 | and module_declaration ~typing_env ~name ~reference ~current = 685 | module_type ~typing_env ~name ~ref_module_type:reference.md_type 686 | ~current_module_type:current.md_type ~reference_location:reference.md_loc 687 | 688 | and modtype_declaration ~typing_env ~name ~reference ~current = 689 | match (reference.mtd_type, current.mtd_type) with 690 | | Some ref_sub, Some curr_sub -> 691 | module_type ~typing_env ~name ~ref_module_type:ref_sub 692 | ~current_module_type:curr_sub ~reference_location:reference.mtd_loc 693 | | Some _, None | None, Some _ -> 694 | Some (Modtype { mtname = name; mtdiff = Modified Unsupported }) 695 | | None, None -> None 696 | 697 | and module_type ~typing_env ~name ~ref_module_type ~current_module_type 698 | ~reference_location = 699 | match (ref_module_type, current_module_type) with 700 | | Mty_signature ref_submod, Mty_signature curr_submod -> 701 | signatures ~reference:ref_submod ~current:curr_submod 702 | |> Option.map (fun mdiff -> Module { mname = name; mdiff }) 703 | | ref_modtype, curr_modtype -> 704 | module_type_fallback ~loc:reference_location ~typing_env ~name 705 | ~reference:ref_modtype ~current:curr_modtype 706 | 707 | and signatures ~reference ~current = 708 | let initialized_env = Typing_env.initialized_env () in 709 | let modified_reference, modified_current, typing_env = 710 | Typing_env.for_diff ~reference ~current 711 | in 712 | match 713 | items ~reference:modified_reference ~current:modified_current ~typing_env 714 | with 715 | | [] -> ( 716 | let coercion1 () = 717 | Includemod.signatures initialized_env ~mark:Mark_both reference current 718 | in 719 | let coercion2 () = 720 | Includemod.signatures initialized_env ~mark:Mark_both current reference 721 | in 722 | match (coercion1 (), coercion2 ()) with 723 | | Tcoerce_none, Tcoerce_none -> None 724 | | _, _ -> Some (Modified Unsupported) 725 | | exception Includemod.Error _ -> Some (Modified Unsupported)) 726 | | item_changes -> Some (Modified (Supported item_changes)) 727 | 728 | let interface ~module_name ~reference ~current = 729 | let sig_out = signatures ~reference ~current in 730 | Option.map (fun mdiff -> { mname = module_name; mdiff }) sig_out 731 | 732 | let library ~reference ~current = 733 | let open Types in 734 | let mod_dec_of_sig sign = 735 | { 736 | md_type = Mty_signature sign; 737 | md_attributes = []; 738 | md_loc = Location.none; 739 | md_uid = Uid.internal_not_actually_unique; 740 | } 741 | in 742 | String_map.merge 743 | (fun module_name ref_sig_opt cur_sig_opt -> 744 | match (ref_sig_opt, cur_sig_opt) with 745 | | None, None -> None 746 | | Some ref_sig, None -> 747 | Some 748 | (Some 749 | { 750 | mname = module_name; 751 | mdiff = 752 | Modified 753 | (Supported 754 | [ 755 | Module 756 | { 757 | mname = module_name; 758 | mdiff = Removed (mod_dec_of_sig ref_sig); 759 | }; 760 | ]); 761 | }) 762 | | None, Some cur_sig -> 763 | Some 764 | (Some 765 | { 766 | mname = module_name; 767 | mdiff = 768 | Modified 769 | (Supported 770 | [ 771 | Module 772 | { 773 | mname = module_name; 774 | mdiff = Added (mod_dec_of_sig cur_sig); 775 | }; 776 | ]); 777 | }) 778 | | Some ref_sig, Some cur_sig -> ( 779 | let module_diff = 780 | interface ~module_name ~reference:ref_sig ~current:cur_sig 781 | in 782 | match module_diff with None -> None | Some _ -> Some module_diff)) 783 | reference current 784 | -------------------------------------------------------------------------------- /lib/diff.mli: -------------------------------------------------------------------------------- 1 | type type_expr = 2 | | Tuple of tuple 3 | | Arrow of arrow 4 | | Constr of constr 5 | | Atomic of Types.type_expr Stddiff.atomic_modification 6 | 7 | and tuple = (Types.type_expr, type_expr) Stddiff.List.t 8 | 9 | and arrow = { 10 | arg_label : 11 | ( arg_label option, 12 | (arg_label, arg_label_diff) Stddiff.Option.t ) 13 | Stddiff.maybe_changed; 14 | arg_type : (Types.type_expr, type_expr) Stddiff.maybe_changed; 15 | return_type : (Types.type_expr, type_expr) Stddiff.maybe_changed; 16 | } 17 | 18 | and arg_label = Labelled_arg of string | Optional_arg of string 19 | 20 | and arg_label_diff = { 21 | name : (string, string Stddiff.atomic_modification) Stddiff.maybe_changed; 22 | arg_optional : (bool, arg_optional) Stddiff.maybe_changed; 23 | } 24 | 25 | and arg_optional = Added_opt_arg | Removed_opt_arg 26 | 27 | and constr = { 28 | path : (Path.t, Path.t Stddiff.atomic_modification) Stddiff.maybe_changed; 29 | args : 30 | ( Types.type_expr list, 31 | ( Types.type_expr list, 32 | (Types.type_expr, type_expr) Stddiff.List.t ) 33 | Stddiff.entry ) 34 | Stddiff.maybe_changed; 35 | } 36 | 37 | type type_modification = { 38 | type_kind : (Types.type_decl_kind, type_kind) Stddiff.maybe_changed; 39 | type_privacy : (Asttypes.private_flag, type_privacy) Stddiff.maybe_changed; 40 | type_manifest : 41 | ( Types.type_expr option, 42 | (Types.type_expr, type_expr) Stddiff.Option.t ) 43 | Stddiff.maybe_changed; 44 | type_params : 45 | ( Types.type_expr list, 46 | ( Types.type_expr list, 47 | (Types.type_expr, type_expr) Stddiff.List.t ) 48 | Stddiff.entry ) 49 | Stddiff.maybe_changed; 50 | } 51 | 52 | and type_kind = 53 | | Record_tk of (Types.label_declaration, label) Stddiff.Map.t 54 | | Variant_tk of (Types.constructor_declaration, cstr_args) Stddiff.Map.t 55 | | Atomic_tk of Types.type_decl_kind Stddiff.atomic_modification 56 | 57 | and label = { 58 | label_type : (Types.type_expr, type_expr) Stddiff.maybe_changed; 59 | label_mutable : 60 | (Asttypes.mutable_flag, field_mutability) Stddiff.maybe_changed; 61 | } 62 | 63 | and field_mutability = Added_m | Removed_m 64 | 65 | and cstr_args = 66 | | Record_cstr of (Types.label_declaration, label) Stddiff.Map.t 67 | | Tuple_cstr of tuple 68 | | Atomic_cstr of Types.constructor_arguments Stddiff.atomic_modification 69 | 70 | and type_privacy = Added_p | Removed_p 71 | 72 | type type_ = { 73 | tname : string; 74 | tdiff : (Types.type_declaration, type_modification) Stddiff.entry; 75 | } 76 | 77 | type value = { 78 | vname : string; 79 | vdiff : (Types.value_description, type_expr) Stddiff.entry; 80 | } 81 | 82 | type class_ = { 83 | cname : string; 84 | cdiff : Types.class_declaration Stddiff.atomic_entry; 85 | } 86 | 87 | type cltype = { 88 | ctname : string; 89 | ctdiff : Types.class_type_declaration Stddiff.atomic_entry; 90 | } 91 | 92 | type extcstr = { 93 | ecname : string; 94 | ectname : string; 95 | ecexn : bool; 96 | ecdiff : (Types.extension_constructor, extcstr_modification) Stddiff.entry; 97 | } 98 | 99 | and extcstr_modification = { 100 | extcstr_params : 101 | ( Types.type_expr list, 102 | ( Types.type_expr list, 103 | (Types.type_expr, type_expr) Stddiff.List.t ) 104 | Stddiff.entry ) 105 | Stddiff.maybe_changed; 106 | extcstr_private : (Asttypes.private_flag, type_privacy) Stddiff.maybe_changed; 107 | extcstr_args : (Types.constructor_arguments, cstr_args) Stddiff.maybe_changed; 108 | } 109 | 110 | type module_ = { 111 | mname : string; 112 | mdiff : (Types.module_declaration, signature_modification) Stddiff.entry; 113 | } 114 | 115 | and modtype = { 116 | mtname : string; 117 | mtdiff : (Types.modtype_declaration, signature_modification) Stddiff.entry; 118 | } 119 | 120 | and signature_modification = Unsupported | Supported of sig_item list 121 | 122 | and sig_item = 123 | | Value of value 124 | | Module of module_ 125 | | Type of type_ 126 | | Modtype of modtype 127 | | Class of class_ 128 | | Classtype of cltype 129 | | Extcstr of extcstr 130 | 131 | val interface : 132 | module_name:string -> 133 | reference:Types.signature -> 134 | current:Types.signature -> 135 | module_ option 136 | 137 | val library : 138 | reference:Types.signature String_map.t -> 139 | current:Types.signature String_map.t -> 140 | module_ option String_map.t 141 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name api_watch) 3 | (public_name api-watch) 4 | (preprocess 5 | (pps ppx_deriving.std ppxlib.traverse)) 6 | (libraries compiler-libs.common ppxlib.traverse_builtins unix containers fmt)) 7 | -------------------------------------------------------------------------------- /lib/library.ml: -------------------------------------------------------------------------------- 1 | let ( let> ) x f = 2 | match x with Ok None -> Ok None | Ok (Some x) -> f x | Error x -> Error x 3 | 4 | let mod_name file = 5 | String.capitalize_ascii Filename.(remove_extension (basename file)) 6 | 7 | let load_cmi file_path = 8 | try 9 | let cmi_infos = Cmi_format.read_cmi file_path in 10 | Ok (cmi_infos.cmi_sign, cmi_infos.cmi_name) 11 | with e -> 12 | Error 13 | (Printf.sprintf "Error parsing %s: %s" file_path (Printexc.to_string e)) 14 | 15 | let lazy_sig path = 16 | let open CCResult.Infix in 17 | Lazy.from_fun (fun () -> 18 | let+ cmi_sign, _ = load_cmi path in 19 | cmi_sign) 20 | 21 | let collect_modules dir = 22 | try 23 | let files = Sys.readdir dir in 24 | let map = 25 | Array.fold_left 26 | (fun acc file -> 27 | let path = Filename.concat dir file in 28 | if (not (Sys.is_directory path)) && Filename.check_suffix file ".cmi" 29 | then String_map.add (mod_name file) (lazy_sig path) acc 30 | else acc) 31 | String_map.empty files 32 | in 33 | Ok map 34 | with Sys_error e -> 35 | Error (Printf.sprintf "Error reading directory %s: %s" dir e) 36 | 37 | let get_sig modname map = 38 | let open CCResult.Infix in 39 | match String_map.find_opt modname map with 40 | | None -> Ok None 41 | | Some lazy_sig -> 42 | let* sig_ = Lazy.force lazy_sig in 43 | Ok (Some sig_) 44 | 45 | type 'a named = { name : string; value : 'a } 46 | (** Attach a module name to its various representations, e.g. a [signature] or a 47 | [module_type]. 48 | Mostly used to report lookup failures. *) 49 | 50 | (** A module for "flat path", paths without a functor application in them. *) 51 | module Flat_path = struct 52 | type component = Id of Ident.t | Comp of string 53 | type t = component list 54 | 55 | let from_path path = 56 | match Path.flatten path with 57 | | `Contains_apply -> None 58 | | `Ok (id, comps) -> Some (Id id :: List.map (fun s -> Comp s) comps) 59 | 60 | let modname_from_component = function Id id -> Ident.name id | Comp s -> s 61 | end 62 | 63 | let rec path_in_module ~module_path flat_path = 64 | match flat_path with 65 | | [] -> module_path 66 | | hd :: tl -> 67 | let module_path = 68 | Path.Pdot (module_path, Flat_path.modname_from_component hd) 69 | in 70 | path_in_module ~module_path tl 71 | 72 | let rewrite_mty_path mty path = 73 | let open Types in 74 | match mty with 75 | | Mty_ident _ -> Mty_ident path 76 | | Mty_alias _ -> Mty_alias path 77 | | _ -> assert false 78 | 79 | let lookup_error ~path ~module_name = 80 | Error (Printf.sprintf "Could not find module %s in %s" path module_name) 81 | 82 | let find_module_item modname sig_ = 83 | let open Types in 84 | let mty_opt = 85 | List.find_map 86 | (function 87 | | Sig_module (id, _, { md_type; _ }, _, _) 88 | when String.equal (Ident.name id) modname -> 89 | Some md_type 90 | | _ -> None) 91 | sig_.value 92 | in 93 | match mty_opt with 94 | | Some mty -> Ok mty 95 | | None -> lookup_error ~path:modname ~module_name:sig_.name 96 | 97 | let find_module_type_in_sig modname sig_ = 98 | let open Types in 99 | let mty_opt = 100 | List.find_map 101 | (function 102 | | Sig_modtype (id, { mtd_type; _ }, _) 103 | when String.equal (Ident.name id) modname -> 104 | Some mtd_type 105 | | _ -> None) 106 | sig_.value 107 | in 108 | match mty_opt with 109 | | Some mty -> Ok mty 110 | | None -> lookup_error ~path:modname ~module_name:sig_.name 111 | 112 | let populate_env typing_env sig_ = 113 | List.fold_left 114 | (fun env sigi -> 115 | match sigi with 116 | | Types.Sig_modtype (id, modtype, Exported) -> 117 | Env.add_modtype id modtype env 118 | | _ -> env) 119 | typing_env sig_ 120 | 121 | let rec find_module_in_sig ~library_modules path sig_ = 122 | let open CCResult.Infix in 123 | let typing_env = populate_env Env.empty sig_.value in 124 | match (path : Flat_path.t) with 125 | | [ last ] -> 126 | let modname = Flat_path.modname_from_component last in 127 | find_module_item modname sig_ 128 | | hd :: tl -> 129 | let modname = Flat_path.modname_from_component hd in 130 | let* mty = find_module_item modname sig_ in 131 | find_module_in_md_type ~typing_env ~library_modules tl 132 | { name = modname; value = mty } 133 | | [] -> assert false 134 | 135 | and find_module_in_md_type ~typing_env ~library_modules path mty = 136 | let open CCResult.Infix in 137 | let* sig_ = sig_of_module_type ~typing_env ~library_modules mty.value in 138 | match sig_ with 139 | | None -> 140 | let res = 141 | match mty.value with 142 | | Mty_alias mty_path | Mty_ident mty_path -> 143 | let expanded_path = path_in_module ~module_path:mty_path path in 144 | rewrite_mty_path mty.value expanded_path 145 | | _ -> mty.value 146 | in 147 | Ok res 148 | | Some s -> 149 | find_module_in_sig ~library_modules path { name = mty.name; value = s } 150 | 151 | and find_module_in_lib ~library_modules path : 152 | (Types.module_type option, string) result = 153 | let open Types in 154 | let open CCResult.Infix in 155 | let> path = Ok (Flat_path.from_path path) in 156 | match path with 157 | | [ comp ] -> 158 | let modname = Flat_path.modname_from_component comp in 159 | let> sig_ = get_sig modname library_modules in 160 | Ok (Some (Mty_signature sig_)) 161 | | comp :: inner_path -> 162 | let modname = Flat_path.modname_from_component comp in 163 | let> parent_sig = get_sig modname library_modules in 164 | let+ mty = 165 | find_module_in_sig ~library_modules inner_path 166 | { name = modname; value = parent_sig } 167 | in 168 | Some mty 169 | | _ -> Ok None 170 | 171 | and find_local_module_type ~typing_env path = 172 | try Some (`Local, Env.find_modtype_expansion path typing_env) 173 | with Not_found -> None 174 | 175 | and find_global_module_type ~library_modules path = 176 | let typing_env = Env.empty in 177 | match path with 178 | | Path.Pdot (parent_mod_path, mty_name) -> 179 | let> parent_mod = find_module_in_lib ~library_modules parent_mod_path in 180 | let> sig_ = sig_of_module_type ~typing_env ~library_modules parent_mod in 181 | let> mty = 182 | find_module_type_in_sig mty_name { name = mty_name; value = sig_ } 183 | in 184 | Ok (Some (`Global, mty)) 185 | | _ -> assert false (* Path to module type cannot be root modules/functors *) 186 | 187 | and find_module_type ~typing_env ~library_modules path = 188 | match find_local_module_type ~typing_env path with 189 | | Some modtype -> Ok (Some modtype) 190 | | None -> find_global_module_type ~library_modules path 191 | 192 | (*and find_module_type_in_lib ~library_modules ~typing_env path : 193 | (Types.module_type option, string) result = 194 | match (find_local_module_type ~typing_env path) with 195 | | Some x -> 196 | Ok (Some x) 197 | | None -> 198 | find_global_module_type ~library_modules 199 | *) 200 | and typing_env_for ~typing_env = function 201 | | `Local -> typing_env 202 | | `Global -> Env.empty 203 | 204 | and sig_of_module_type ~library_modules ~typing_env module_type = 205 | match module_type with 206 | | Types.Mty_alias path -> 207 | (* find_module_in_lib only looks up globally, we shoud proabably fix it. *) 208 | let> mty = find_module_in_lib ~library_modules path in 209 | sig_of_module_type ~typing_env:Env.empty ~library_modules mty 210 | | Mty_ident path -> 211 | let> where, mty = find_module_type ~typing_env ~library_modules path in 212 | let typing_env = typing_env_for ~typing_env where in 213 | sig_of_module_type ~typing_env ~library_modules mty 214 | | Mty_signature sig_ -> Ok (Some sig_) 215 | | Mty_functor _ -> Ok None 216 | 217 | let rec expand_sig ~typing_env ~library_modules sig_ = 218 | let open Types in 219 | let open CCResult.Infix in 220 | let typing_env = populate_env typing_env sig_ in 221 | CCResult.map_l 222 | (fun item -> 223 | match item with 224 | | Sig_module (id, presence, ({ md_type; _ } as mod_decl), rs, vis) -> 225 | let* md_type = 226 | expand_module_type ~typing_env ~library_modules md_type 227 | in 228 | let presence = 229 | match md_type with 230 | | Mty_alias _ -> presence 231 | | _ -> Mp_present (* What is this fixing? *) 232 | in 233 | let mod_decl' = { mod_decl with md_type } in 234 | Ok (Sig_module (id, presence, mod_decl', rs, vis)) 235 | | _ -> Ok item) 236 | sig_ 237 | 238 | and expand_module_type ~typing_env ~library_modules module_type = 239 | let open CCResult.Infix in 240 | let+ res = 241 | let> sig_ = sig_of_module_type ~typing_env ~library_modules module_type in 242 | let+ expanded = expand_sig ~typing_env ~library_modules sig_ in 243 | Some (Types.Mty_signature expanded) 244 | in 245 | Option.value ~default:module_type res 246 | 247 | type t = Types.signature String_map.t 248 | 249 | let load_unwrapped project_path : (t, string) result = 250 | let open CCResult.Infix in 251 | let* library_modules = collect_modules project_path in 252 | let module_res_map = 253 | String_map.map (fun sig_ -> Lazy.force sig_) library_modules 254 | in 255 | String_map.fold 256 | (fun key value acc -> 257 | let* acc = acc in 258 | let* value = value in 259 | Ok (String_map.add key value acc)) 260 | module_res_map (Ok String_map.empty) 261 | 262 | let load ~main_module project_path : (t, string) result = 263 | let open CCResult.Infix in 264 | let* library_modules = collect_modules project_path in 265 | let* main_sig = 266 | let* x = get_sig main_module library_modules in 267 | match x with 268 | | Some s -> Ok s 269 | | None -> 270 | Error 271 | (Printf.sprintf "Could not find main module %s in %s" main_module 272 | project_path) 273 | in 274 | let expanded_main_sig = 275 | match expand_sig ~typing_env:Env.empty ~library_modules main_sig with 276 | | Ok expanded_sig -> expanded_sig 277 | | Error e -> failwith e 278 | in 279 | Ok (String_map.singleton main_module expanded_main_sig) 280 | -------------------------------------------------------------------------------- /lib/library.mli: -------------------------------------------------------------------------------- 1 | val load_cmi : string -> (Types.signature * string, string) result 2 | 3 | type t = Types.signature String_map.t 4 | (** Type representing a library's root modules. 5 | For wrapped libraries, contains only the main module. 6 | For unwrapped libraries, contains all root-level modules. *) 7 | 8 | val load_unwrapped : string -> (t, string) result 9 | (** Load an unwrapped library, returning all root-level modules. 10 | Each module in the returned map represents a .cmi file at the root 11 | of the project path. *) 12 | 13 | val load : main_module:string -> string -> (t, string) result 14 | (** Load a wrapped library, returning only its main module. 15 | The returned map will contain a single entry for the main module, 16 | with all its dependencies expanded. *) 17 | -------------------------------------------------------------------------------- /lib/normalize.ml: -------------------------------------------------------------------------------- 1 | open Types 2 | 3 | let get_type_param_name param = 4 | match get_desc param with Tvar (Some name) -> name | _ -> assert false 5 | 6 | let gen_unique_type_var_name = 7 | let counter = ref 1 in 8 | fun ~reset -> 9 | if reset then counter := 0 else (); 10 | let unique_name = Printf.sprintf "t%d" !counter in 11 | counter := !counter + 1; 12 | unique_name 13 | 14 | let mutate_type_expr desc te = 15 | let tran = Transient_expr.repr te in 16 | Transient_expr.set_desc tran desc 17 | 18 | let rec type_params reference current = 19 | match (reference, current) with 20 | | [], [] -> 21 | let _ = gen_unique_type_var_name ~reset:true in 22 | () 23 | | ref_param :: reference', [] -> 24 | let normed_name = gen_unique_type_var_name ~reset:false in 25 | mutate_type_expr (Tvar (Some normed_name)) ref_param; 26 | type_params reference' [] 27 | | [], cur_param :: current' -> 28 | let normed_name = gen_unique_type_var_name ~reset:false in 29 | mutate_type_expr (Tvar (Some normed_name)) cur_param; 30 | type_params [] current' 31 | | ref_param :: reference', cur_param :: current' -> 32 | let normed_name = gen_unique_type_var_name ~reset:false in 33 | mutate_type_expr (Tvar (Some normed_name)) ref_param; 34 | mutate_type_expr (Tvar (Some normed_name)) cur_param; 35 | type_params reference' current' 36 | 37 | let type_declarations ~reference ~current = 38 | type_params reference.type_params current.type_params 39 | 40 | let rec is_type_params ~reference ~current = 41 | match (reference, current) with 42 | | [], _ | _, [] -> true 43 | | ref_type_param :: reference', cur_type_param :: current' -> 44 | String.equal 45 | (get_type_param_name ref_type_param) 46 | (get_type_param_name cur_type_param) 47 | && is_type_params ~reference:reference' ~current:current' 48 | 49 | let append_tvar_none n params_lst = 50 | let rest = 51 | List.init n (fun _ -> create_expr (Tvar None) ~level:0 ~scope:0 ~id:0) 52 | in 53 | params_lst @ rest 54 | 55 | let type_params_arity ~reference ~current = 56 | let ref_len = List.length reference in 57 | let cur_len = List.length current in 58 | if ref_len = cur_len then (reference, current) 59 | else if ref_len > cur_len then 60 | (reference, append_tvar_none (ref_len - cur_len) current) 61 | else (append_tvar_none (cur_len - ref_len) reference, current) 62 | -------------------------------------------------------------------------------- /lib/normalize.mli: -------------------------------------------------------------------------------- 1 | val type_declarations : 2 | reference:Types.type_declaration -> current:Types.type_declaration -> unit 3 | (** Rename the occurances of each corresponding pair of type parameters in 4 | [reference] and [current] to a unique ti, 5 | where 1 <= i <= Int.max(List.length [current], List.length [reference]) *) 6 | 7 | val is_type_params : 8 | reference:Types.type_expr list -> current:Types.type_expr list -> bool 9 | (** Return true if each pair of corresponding type paramters 10 | in [reference] and [current] 11 | have the same name, false otherwise *) 12 | 13 | val type_params_arity : 14 | reference:Types.type_expr list -> 15 | current:Types.type_expr list -> 16 | Types.type_expr list * Types.type_expr list 17 | (** Appends dummy type_expr values to the shorter list, until its length is the 18 | same as the other list *) 19 | -------------------------------------------------------------------------------- /lib/ocaml_types.ml: -------------------------------------------------------------------------------- 1 | open Asttypes 2 | 3 | type type_expr = Types.type_expr 4 | and row_desc = Types.row_desc 5 | and row_field = Types.row_field 6 | and field_kind = Types.field_kind 7 | and commutable = Types.commutable 8 | and ident = Ident.t 9 | and uid = Shape.Uid.t 10 | 11 | and type_desc = Types.type_desc = 12 | | Tvar of string option 13 | | Tarrow of arg_label * type_expr * type_expr * commutable 14 | | Ttuple of type_expr list 15 | | Tconstr of Path.t * type_expr list * abbrev_memo ref 16 | | Tobject of type_expr * (Path.t * type_expr list) option ref 17 | | Tfield of string * field_kind * type_expr * type_expr 18 | | Tnil 19 | | Tlink of type_expr 20 | | Tsubst of type_expr * type_expr option 21 | | Tvariant of row_desc 22 | | Tunivar of string option 23 | | Tpoly of type_expr * type_expr list 24 | | Tpackage of Path.t * (Longident.t * type_expr) list 25 | 26 | and fixed_explanation = Types.fixed_explanation = 27 | | Univar of type_expr (** The row type was bound to an univar *) 28 | | Fixed_private (** The row type is private *) 29 | | Reified of Path.t (** The row was reified *) 30 | | Rigid (** The row type was made rigid during constraint verification *) 31 | 32 | and abbrev_memo = Types.abbrev_memo = 33 | | Mnil (** No known abbreviation *) 34 | | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo 35 | | Mlink of abbrev_memo ref 36 | 37 | and field_kind_view = Types.field_kind_view = Fprivate | Fpublic | Fabsent 38 | 39 | and row_desc_repr = Types.row_desc_repr = 40 | | Row of { 41 | fields : (label * row_field) list; 42 | more : type_expr; 43 | closed : bool; 44 | fixed : fixed_explanation option; 45 | name : (Path.t * type_expr list) option; 46 | } 47 | 48 | and row_field_view = Types.row_field_view = 49 | | Rpresent of type_expr option 50 | | Reither of bool * type_expr list * bool 51 | | Rabsent 52 | 53 | and value_description = Types.value_description = { 54 | val_type : type_expr; 55 | val_kind : value_kind; 56 | val_loc : Location.t; 57 | val_attributes : Parsetree.attributes; 58 | val_uid : uid; 59 | } 60 | 61 | and value_kind = Types.value_kind = 62 | | Val_reg (* Regular value *) 63 | | Val_prim of Primitive.description (* Primitive *) 64 | | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) 65 | | Val_self of class_signature * self_meths * ident Types.Vars.t * string 66 | (* Self *) 67 | | Val_anc of class_signature * ident Types.Meths.t * string 68 | (* Ancestor *) 69 | 70 | and self_meths = Types.self_meths = 71 | | Self_concrete of ident Types.Meths.t 72 | | Self_virtual of ident Types.Meths.t ref 73 | 74 | and class_signature = Types.class_signature = { 75 | csig_self : type_expr; 76 | mutable csig_self_row : type_expr; 77 | mutable csig_vars : (mutable_flag * virtual_flag * type_expr) Types.Vars.t; 78 | mutable csig_meths : (method_privacy * virtual_flag * type_expr) Types.Meths.t; 79 | } 80 | 81 | and method_privacy = Types.method_privacy = Mpublic | Mprivate of field_kind 82 | (* The [field_kind] is always [Fabsent] in a complete class type. *) 83 | 84 | and type_declaration = Types.type_declaration = { 85 | type_params : type_expr list; 86 | type_arity : int; 87 | type_kind : type_decl_kind; 88 | type_private : private_flag; 89 | type_manifest : type_expr option; 90 | type_variance : Types.Variance.t list; 91 | type_separability : Types.Separability.t list; 92 | type_is_newtype : bool; 93 | type_expansion_scope : int; 94 | type_loc : Location.t; 95 | type_attributes : Parsetree.attributes; 96 | type_immediate : Type_immediacy.t; 97 | type_unboxed_default : bool; 98 | (* true if the unboxed-ness of this type was chosen by a compiler flag *) 99 | type_uid : uid; 100 | } 101 | 102 | and type_decl_kind = (label_declaration, constructor_declaration) type_kind 103 | 104 | and ('lbl, 'cstr) type_kind = ('lbl, 'cstr) Types.type_kind = 105 | | Type_abstract of type_origin 106 | | Type_record of 'lbl list * record_representation 107 | | Type_variant of 'cstr list * variant_representation 108 | | Type_open 109 | 110 | and type_origin = Types.type_origin = 111 | | Definition 112 | | Rec_check_regularity (* See Typedecl.transl_type_decl *) 113 | | Existential of string 114 | 115 | and record_representation = Types.record_representation = 116 | | Record_regular (* All fields are boxed / tagged *) 117 | | Record_float (* All fields are floats *) 118 | | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) 119 | | Record_inlined of int (* Inlined record *) 120 | | Record_extension of Path.t 121 | (* Inlined record under extension *) 122 | (* The argument is the path of the extension *) 123 | 124 | and variant_representation = Types.variant_representation = 125 | | Variant_regular (* Constant or boxed constructors *) 126 | | Variant_unboxed (* One unboxed single-field constructor *) 127 | 128 | and label_declaration = Types.label_declaration = { 129 | ld_id : ident; 130 | ld_mutable : mutable_flag; 131 | ld_type : type_expr; 132 | ld_loc : Location.t; 133 | ld_attributes : Parsetree.attributes; 134 | ld_uid : uid; 135 | } 136 | 137 | and constructor_declaration = Types.constructor_declaration = { 138 | cd_id : ident; 139 | cd_args : constructor_arguments; 140 | cd_res : type_expr option; 141 | cd_loc : Location.t; 142 | cd_attributes : Parsetree.attributes; 143 | cd_uid : uid; 144 | } 145 | 146 | and constructor_arguments = Types.constructor_arguments = 147 | | Cstr_tuple of type_expr list 148 | | Cstr_record of label_declaration list 149 | 150 | and extension_constructor = Types.extension_constructor = { 151 | ext_type_path : Path.t; 152 | ext_type_params : type_expr list; 153 | ext_args : constructor_arguments; 154 | ext_ret_type : type_expr option; 155 | ext_private : private_flag; 156 | ext_loc : Location.t; 157 | ext_attributes : Parsetree.attributes; 158 | ext_uid : uid; 159 | } 160 | 161 | and type_transparence = Types.type_transparence = 162 | | Type_public (* unrestricted expansion *) 163 | | Type_new (* "new" type *) 164 | | Type_private (* private type *) 165 | 166 | (* Type expressions for the class language *) 167 | and class_type = Types.class_type = 168 | | Cty_constr of Path.t * type_expr list * class_type 169 | | Cty_signature of class_signature 170 | | Cty_arrow of arg_label * type_expr * class_type 171 | 172 | and class_declaration = Types.class_declaration = { 173 | cty_params : type_expr list; 174 | mutable cty_type : class_type; 175 | cty_path : Path.t; 176 | cty_new : type_expr option; 177 | cty_variance : Types.Variance.t list; 178 | cty_loc : Location.t; 179 | cty_attributes : Parsetree.attributes; 180 | cty_uid : uid; 181 | } 182 | 183 | and class_type_declaration = Types.class_type_declaration = { 184 | clty_params : type_expr list; 185 | clty_type : class_type; 186 | clty_path : Path.t; 187 | clty_hash_type : type_declaration; (* object type with an open row *) 188 | clty_variance : Types.Variance.t list; 189 | clty_loc : Location.t; 190 | clty_attributes : Parsetree.attributes; 191 | clty_uid : uid; 192 | } 193 | 194 | (* Type expressions for the module language *) 195 | and visibility = Types.visibility = Exported | Hidden 196 | 197 | and module_type = Types.module_type = 198 | | Mty_ident of Path.t 199 | | Mty_signature of signature 200 | | Mty_functor of functor_parameter * module_type 201 | | Mty_alias of Path.t 202 | 203 | and functor_parameter = Types.functor_parameter = 204 | | Unit 205 | | Named of ident option * module_type 206 | 207 | and module_presence = Types.module_presence = Mp_present | Mp_absent 208 | and signature = signature_item list 209 | 210 | and signature_item = Types.signature_item = 211 | | Sig_value of ident * value_description * visibility 212 | | Sig_type of ident * type_declaration * rec_status * visibility 213 | | Sig_typext of ident * extension_constructor * ext_status * visibility 214 | | Sig_module of 215 | ident * module_presence * module_declaration * rec_status * visibility 216 | | Sig_modtype of ident * modtype_declaration * visibility 217 | | Sig_class of ident * class_declaration * rec_status * visibility 218 | | Sig_class_type of ident * class_type_declaration * rec_status * visibility 219 | 220 | and module_declaration = Types.module_declaration = { 221 | md_type : module_type; 222 | md_attributes : Parsetree.attributes; 223 | md_loc : Location.t; 224 | md_uid : uid; 225 | } 226 | 227 | and modtype_declaration = Types.modtype_declaration = { 228 | mtd_type : module_type option; (* None: abstract *) 229 | mtd_attributes : Parsetree.attributes; 230 | mtd_loc : Location.t; 231 | mtd_uid : uid; 232 | } 233 | 234 | and rec_status = Types.rec_status = 235 | | Trec_not (* first in a nonrecursive group *) 236 | | Trec_first (* first in a recursive group *) 237 | | Trec_next (* not first in a recursive/nonrecursive group *) 238 | 239 | and ext_status = Types.ext_status = 240 | | Text_first (* first constructor in an extension *) 241 | | Text_next (* not first constructor in an extension *) 242 | | Text_exception 243 | [@@deriving traverse] 244 | 245 | class virtual _iter = 246 | object 247 | inherit iter 248 | inherit Ppxlib_traverse_builtins.iter 249 | method ref iter_a a_ref = iter_a !a_ref 250 | method virtual_flag _ = () 251 | method types__vars__t _ _ = () 252 | method types__variance__t _ = () 253 | method types__type_expr _ = () 254 | method types__separability__t _ = () 255 | method types__row_field _ = () 256 | method types__row_desc _ = () 257 | method types__meths__t _ _ = () 258 | method types__field_kind _ = () 259 | method types__commutable _ = () 260 | method type_immediacy__t _ = () 261 | method shape__uid__t _ = () 262 | method private_flag _ = () 263 | method primitive__description _ = () 264 | method path__t _ = () 265 | method parsetree__attributes _ = () 266 | method mutable_flag _ = () 267 | method longident__t _ = () 268 | method location__t _ = () 269 | method label _ = () 270 | method ident__t _ = () 271 | method arg_label _ = () 272 | end 273 | 274 | class virtual iter = _iter 275 | 276 | class print = 277 | object (self) 278 | inherit iter as super 279 | 280 | method! type_expr te = 281 | Format.printf "{%d:" (Types.get_id te); 282 | self#type_desc (Types.get_desc te); 283 | Format.printf "}" 284 | 285 | method! type_desc td = 286 | match td with 287 | | Tsubst (ty, None) -> 288 | Format.printf "Subst("; 289 | self#type_expr ty; 290 | Format.printf ", None)" 291 | | Tsubst (ty, Some ty') -> 292 | Format.printf "Subst("; 293 | self#type_expr ty; 294 | Format.printf ", "; 295 | self#type_expr ty'; 296 | Format.printf ")" 297 | | Tconstr (path, _, _) -> Path.print Format.std_formatter path 298 | | Tvar (Some s) -> Format.printf "var:'%s" s 299 | | Tvar None -> Format.printf "var:NONE" 300 | | Tunivar (Some s) -> Format.printf "uvar:'%s" s 301 | | Tunivar None -> Format.printf "uvar:NONE" 302 | | _ -> super#type_desc td 303 | 304 | method! signature_item sigi = 305 | match sigi with 306 | | Sig_type (id, type_decl, _rec_status, _visbility) -> 307 | Format.printf "type_decl:\n"; 308 | Format.printf "id:%s uid:%a\n" (Ident.unique_name id) Shape.Uid.print 309 | type_decl.type_uid; 310 | Printtyp.signature Format.std_formatter [ sigi ]; 311 | Format.print_newline () 312 | | Sig_value (id, value, _) -> 313 | Format.printf "value desc: %a\n" (Printtyp.value_description id) value; 314 | Format.printf "id:%s uid:%a\n" (Ident.unique_name id) Shape.Uid.print 315 | value.val_uid; 316 | Format.printf "val %s :" (Ident.name id); 317 | self#type_expr value.val_type; 318 | Format.print_newline () 319 | | _ -> 320 | Printtyp.signature Format.std_formatter [ sigi ]; 321 | Format.print_newline () 322 | end 323 | -------------------------------------------------------------------------------- /lib/sig_item_map.ml: -------------------------------------------------------------------------------- 1 | open Types 2 | 3 | type t = { 4 | values_map : value_description String_map.t; 5 | modules_map : module_declaration String_map.t; 6 | modtypes_map : modtype_declaration String_map.t; 7 | types_map : (type_declaration * Ident.t) String_map.t; 8 | class_map : class_declaration String_map.t; 9 | class_type_map : class_type_declaration String_map.t; 10 | ext_cstr_map : (extension_constructor * bool) String_map.t; 11 | } 12 | 13 | type _ item_type = 14 | | Value : value_description item_type 15 | | Module : module_declaration item_type 16 | | Modtype : modtype_declaration item_type 17 | | Type : (type_declaration * Ident.t) item_type 18 | | Class : class_declaration item_type 19 | | Classtype : class_type_declaration item_type 20 | | Extcstr : string -> (extension_constructor * bool) item_type 21 | 22 | let empty : t = 23 | { 24 | values_map = String_map.empty; 25 | modules_map = String_map.empty; 26 | modtypes_map = String_map.empty; 27 | types_map = String_map.empty; 28 | class_map = String_map.empty; 29 | class_type_map = String_map.empty; 30 | ext_cstr_map = String_map.empty; 31 | } 32 | 33 | let ext_cstr_full_name ~type_name ~name = Printf.sprintf "%s-%s" type_name name 34 | 35 | let add (type a) ~name (item_type : a item_type) (item : a) maps : t = 36 | match item_type with 37 | | Value -> { maps with values_map = String_map.add name item maps.values_map } 38 | | Module -> 39 | { maps with modules_map = String_map.add name item maps.modules_map } 40 | | Modtype -> 41 | { maps with modtypes_map = String_map.add name item maps.modtypes_map } 42 | | Type -> { maps with types_map = String_map.add name item maps.types_map } 43 | | Class -> { maps with class_map = String_map.add name item maps.class_map } 44 | | Classtype -> 45 | { 46 | maps with 47 | class_type_map = String_map.add name item maps.class_type_map; 48 | } 49 | | Extcstr extcstr_name -> 50 | { 51 | maps with 52 | ext_cstr_map = 53 | String_map.add 54 | (ext_cstr_full_name ~type_name:name ~name:extcstr_name) 55 | item maps.ext_cstr_map; 56 | } 57 | 58 | let has (type a) ~name (item_type : a item_type) maps : bool = 59 | match item_type with 60 | | Value -> String_map.mem name maps.values_map 61 | | Module -> String_map.mem name maps.modules_map 62 | | Modtype -> String_map.mem name maps.modtypes_map 63 | | Type -> String_map.mem name maps.types_map 64 | | Class -> String_map.mem name maps.class_map 65 | | Classtype -> String_map.mem name maps.class_type_map 66 | | Extcstr extcstr_name -> 67 | String_map.mem 68 | (ext_cstr_full_name ~type_name:name ~name:extcstr_name) 69 | maps.ext_cstr_map 70 | 71 | type ('a, 'diff) diff_item = 72 | 'a item_type -> string -> 'a option -> 'a option -> 'diff option 73 | 74 | type 'diff poly_diff_item = { diff_item : 'a. ('a, 'diff) diff_item } 75 | 76 | let diff ~diff_item:{ diff_item } ref_maps curr_maps : 'diff list = 77 | let value_diffs = 78 | String_map.merge 79 | (fun name ref_opt curr_opt -> diff_item Value name ref_opt curr_opt) 80 | ref_maps.values_map curr_maps.values_map 81 | |> String_map.bindings |> List.map snd 82 | in 83 | let module_diffs = 84 | String_map.merge 85 | (fun name ref_opt curr_opt -> diff_item Module name ref_opt curr_opt) 86 | ref_maps.modules_map curr_maps.modules_map 87 | |> String_map.bindings |> List.map snd 88 | in 89 | let modtype_diffs = 90 | String_map.merge 91 | (fun name ref_opt curr_opt -> diff_item Modtype name ref_opt curr_opt) 92 | ref_maps.modtypes_map curr_maps.modtypes_map 93 | |> String_map.bindings |> List.map snd 94 | in 95 | let type_diffs = 96 | String_map.merge 97 | (fun name ref_opt curr_opt -> diff_item Type name ref_opt curr_opt) 98 | ref_maps.types_map curr_maps.types_map 99 | |> String_map.bindings |> List.map snd 100 | in 101 | let class_diffs = 102 | String_map.merge 103 | (fun name ref_opt curr_opt -> diff_item Class name ref_opt curr_opt) 104 | ref_maps.class_map curr_maps.class_map 105 | |> String_map.bindings |> List.map snd 106 | in 107 | let class_type_diffs = 108 | String_map.merge 109 | (fun name ref_opt curr_opt -> diff_item Classtype name ref_opt curr_opt) 110 | ref_maps.class_type_map curr_maps.class_type_map 111 | |> String_map.bindings |> List.map snd 112 | in 113 | let ext_cstr_diffs = 114 | String_map.merge 115 | (fun full_name ref_opt curr_opt -> 116 | let names = String.split_on_char '-' full_name in 117 | let type_name = List.hd names in 118 | let cstr_name = List.hd (List.tl names) in 119 | diff_item (Extcstr cstr_name) type_name ref_opt curr_opt) 120 | ref_maps.ext_cstr_map curr_maps.ext_cstr_map 121 | |> String_map.bindings |> List.map snd 122 | in 123 | value_diffs @ module_diffs @ modtype_diffs @ type_diffs @ class_diffs 124 | @ class_type_diffs @ ext_cstr_diffs 125 | -------------------------------------------------------------------------------- /lib/sig_item_map.mli: -------------------------------------------------------------------------------- 1 | open Types 2 | 3 | type t 4 | 5 | type _ item_type = 6 | | Value : value_description item_type 7 | | Module : module_declaration item_type 8 | | Modtype : modtype_declaration item_type 9 | | Type : (type_declaration * Ident.t) item_type 10 | | Class : class_declaration item_type 11 | | Classtype : class_type_declaration item_type 12 | | Extcstr : string -> (extension_constructor * bool) item_type 13 | 14 | val empty : t 15 | val add : name:string -> 'a item_type -> 'a -> t -> t 16 | val has : name:string -> 'a item_type -> t -> bool 17 | 18 | type ('a, 'diff) diff_item = 19 | 'a item_type -> string -> 'a option -> 'a option -> 'diff option 20 | 21 | type 'diff poly_diff_item = { diff_item : 'a. ('a, 'diff) diff_item } 22 | 23 | val diff : diff_item:'diff poly_diff_item -> t -> t -> 'diff list 24 | -------------------------------------------------------------------------------- /lib/stddiff.ml: -------------------------------------------------------------------------------- 1 | (** Type aliases for representing common OCaml types diffs *) 2 | 3 | (** Represent a change of an entry in a collection *) 4 | type ('item, 'diff) entry = 5 | | Added of 'item 6 | | Removed of 'item 7 | | Modified of 'diff 8 | 9 | type 'a atomic_modification = { reference : 'a; current : 'a } 10 | (** The simplest diff representation for the modification of a value of type 'a. 11 | [reference] is the value before and [current] is the value after the change 12 | occured. Use this type when there is no better representation available. *) 13 | 14 | type 'item atomic_entry = ('item, 'item atomic_modification) entry 15 | type ('same, 'change) maybe_changed = Same of 'same | Changed of 'change 16 | 17 | module List = struct 18 | type ('a, 'diff) t = ('a, ('a, 'diff) entry) maybe_changed list 19 | 20 | let diff ~diff_one ~reference ~current = 21 | let rec aux reference current (acc, all) = 22 | match (reference, current) with 23 | | [], [] -> (List.rev acc, all) 24 | | hd :: tl, [] -> aux tl [] (Changed (Removed hd) :: acc, false) 25 | | [], hd :: tl -> aux [] tl (Changed (Added hd) :: acc, false) 26 | | hd :: tl, hd' :: tl' -> ( 27 | let res = diff_one hd hd' in 28 | match res with 29 | | Same same -> aux tl tl' (Same same :: acc, true && all) 30 | | Changed change -> 31 | aux tl tl' (Changed (Modified change) :: acc, false && all)) 32 | in 33 | let list_diff, all_same = aux reference current ([], true) in 34 | if all_same then Same reference else Changed list_diff 35 | end 36 | 37 | module Option = struct 38 | type ('a, 'diff) t = ('a, 'diff) entry 39 | 40 | let diff ~diff_one ~reference ~current = 41 | match (reference, current) with 42 | | None, None -> Same None 43 | | Some ref, None -> Changed (Removed ref) 44 | | None, Some cur -> Changed (Added cur) 45 | | Some ref, Some cur -> ( 46 | let res = diff_one ref cur in 47 | match res with 48 | | Same same -> Same (Some same) 49 | | Changed change -> Changed (Modified change)) 50 | end 51 | 52 | module Map = struct 53 | type ('a, 'diff) t = { 54 | same_map : 'a String_map.t; 55 | changed_map : ('a, 'diff) entry String_map.t; 56 | } 57 | 58 | let diff ~diff_one ~reference ~current = 59 | let same_seq, changed_seq = 60 | String_map.merge 61 | (fun _ ref_opt cur_opt -> 62 | match (ref_opt, cur_opt) with 63 | | None, None -> None 64 | | Some ref, None -> Some (Changed (Removed ref)) 65 | | None, Some cur -> Some (Changed (Added cur)) 66 | | Some ref, Some cur -> ( 67 | match diff_one ref cur with 68 | | Same _ -> Some (Same ref) 69 | | Changed change -> Some (Changed (Modified change)))) 70 | reference current 71 | |> String_map.to_seq 72 | |> Seq.partition_map (fun (name, i) -> 73 | match i with 74 | | Same i -> Either.Left (name, i) 75 | | Changed i -> Either.Right (name, i)) 76 | in 77 | { 78 | same_map = String_map.of_seq same_seq; 79 | changed_map = String_map.of_seq changed_seq; 80 | } 81 | end 82 | -------------------------------------------------------------------------------- /lib/stddiff.mli: -------------------------------------------------------------------------------- 1 | (** Type aliases for representing common OCaml types diffs *) 2 | 3 | (** Represent a change of an entry in a collection *) 4 | type ('item, 'diff) entry = 5 | | Added of 'item 6 | | Removed of 'item 7 | | Modified of 'diff 8 | 9 | type 'a atomic_modification = { reference : 'a; current : 'a } 10 | (** The simplest diff representation for the modification of a value of type 'a. 11 | [reference] is the value before and [current] is the value after the change 12 | occured. Use this type when there is no better representation available. *) 13 | 14 | type 'item atomic_entry = ('item, 'item atomic_modification) entry 15 | type ('same, 'change) maybe_changed = Same of 'same | Changed of 'change 16 | 17 | module List : sig 18 | type ('a, 'diff) t = ('a, ('a, 'diff) entry) maybe_changed list 19 | 20 | val diff : 21 | diff_one:('a -> 'a -> ('a, 'diff) maybe_changed) -> 22 | reference:'a list -> 23 | current:'a list -> 24 | ('a list, ('a, 'diff) t) maybe_changed 25 | end 26 | 27 | module Option : sig 28 | type ('a, 'diff) t = ('a, 'diff) entry 29 | 30 | val diff : 31 | diff_one:('a -> 'a -> ('a, 'diff) maybe_changed) -> 32 | reference:'a option -> 33 | current:'a option -> 34 | ('a option, ('a, 'diff) t) maybe_changed 35 | end 36 | 37 | module Map : sig 38 | type ('a, 'diff) t = { 39 | same_map : 'a String_map.t; 40 | changed_map : ('a, 'diff) entry String_map.t; 41 | } 42 | 43 | val diff : 44 | diff_one:('a -> 'a -> ('a, 'diff) maybe_changed) -> 45 | reference:'a String_map.t -> 46 | current:'a String_map.t -> 47 | ('a, 'diff) t 48 | end 49 | -------------------------------------------------------------------------------- /lib/string_map.ml: -------------------------------------------------------------------------------- 1 | include Map.Make (String) 2 | -------------------------------------------------------------------------------- /lib/string_map.mli: -------------------------------------------------------------------------------- 1 | include Map.S with type key = string 2 | -------------------------------------------------------------------------------- /lib/text_diff.mli: -------------------------------------------------------------------------------- 1 | (** Utilities for custom diff printing *) 2 | 3 | type t 4 | (** Type for representing library interface diffs as text diff. 5 | 6 | Changes are arranged per fully qualified module path. Keys are module path, 7 | as strings, that map to the textual diff for the content of said module. 8 | 9 | The removal or addition of a module is listed under its parent. E.g. if 10 | [Main.M] was removed, this will show in the textual diff under the key 11 | ["Main"]. On the other hand, if [Main.M] is present in both versions but 12 | received a new function [Main.M.do_something], this will show in the textual 13 | diff under the key ["Main.M"]. Identical modules won't appear in the map. *) 14 | 15 | val pp : Format.formatter -> t -> unit 16 | (** Pretty-print the text diff in a human readable, git diff like format. *) 17 | 18 | val from_diff : Diff.module_ -> t 19 | (** Converts from a low-level diff to a textual diff *) 20 | 21 | module With_colors : sig 22 | val pp : mode:[ `Plain | `Color ] -> Format.formatter -> t -> unit 23 | (** Same as regular [pp] but prints added lines in green and removed lines in 24 | red. *) 25 | end 26 | 27 | module Word : sig 28 | val pp : mode:[ `Plain | `Color ] -> Format.formatter -> t -> unit 29 | (** Pretty-print the text diff in an inlined word diff format, similar to 30 | [git diff --word-diff=[]] *) 31 | end 32 | -------------------------------------------------------------------------------- /lib/typing_env.ml: -------------------------------------------------------------------------------- 1 | open Types 2 | 3 | type t = Env.t 4 | type subst_kind = Type | Module | Modtype [@@deriving ord] 5 | 6 | module Subst_item_map = Map.Make (struct 7 | type t = subst_kind * string [@@deriving ord] 8 | end) 9 | 10 | let apply_subst subst signature = 11 | List.map 12 | (function 13 | | Sig_type (id, td, r, v) -> 14 | Sig_type (id, Subst.type_declaration subst td, r, v) 15 | | Sig_value (id, vd, v) -> 16 | Sig_value (id, Subst.value_description subst vd, v) 17 | | Sig_class (id, cd, rc, v) -> 18 | Sig_class (id, Subst.class_declaration subst cd, rc, v) 19 | | Sig_class_type (id, ct, rc, v) -> 20 | Sig_class_type (id, Subst.cltype_declaration subst ct, rc, v) 21 | | Sig_modtype (id, m, v) -> 22 | Sig_modtype (id, Subst.modtype_declaration Subst.Keep subst m, v) 23 | | Sig_module (id, mp, md, rc, v) -> 24 | Sig_module 25 | (id, mp, Subst.module_declaration Subst.Keep subst md, rc, v) 26 | | Sig_typext (id, ec, es, v) -> 27 | Sig_typext (id, Subst.extension_constructor subst ec, es, v)) 28 | signature 29 | 30 | (* Traverses the current signature and generates unique IDs for items 31 | that have conflicting IDs with items in the reference signature. It then 32 | replaces the old IDs with the new generated ones using substitutions. 33 | *) 34 | let replace_matching_ids ~reference ~current = 35 | let ref_env = Env.add_signature reference Env.empty in 36 | let subst, modified_current = 37 | List.fold_right 38 | (fun item (subst, lst) -> 39 | match item with 40 | | Sig_type (id, td, r, v) as sig_typ_decl -> ( 41 | match Env.find_type_index id ref_env with 42 | | Some _ -> 43 | let new_id = Ident.rename id in 44 | ( Subst.add_type id (Path.Pident new_id) subst, 45 | Sig_type (new_id, td, r, v) :: lst ) 46 | | None -> (subst, sig_typ_decl :: lst)) 47 | | Sig_module (id, mp, md, r, v) as sig_mod_decl -> ( 48 | match Env.find_module_index id ref_env with 49 | | Some _ -> 50 | let new_id = Ident.rename id in 51 | ( Subst.add_module id (Path.Pident new_id) subst, 52 | Sig_module (new_id, mp, md, r, v) :: lst ) 53 | | None -> (subst, sig_mod_decl :: lst)) 54 | | Sig_modtype (id, mtd, v) -> ( 55 | match Env.find_modtype_index id ref_env with 56 | | Some _ -> 57 | let new_id = Ident.rename id in 58 | ( Subst.add_modtype id (Mty_ident (Pident new_id)) subst, 59 | Sig_modtype (new_id, mtd, v) :: lst ) 60 | | None -> 61 | (* This is a special case for functor paramters. 62 | When two functors have different parameters, 63 | they might treated equally by Includemod.modtypes, thus 64 | one of parameters' id has to be rewritten. For example: 65 | module F (M : X) : A and module F (M : Y) : A 66 | X and Y could have the same stamp, thus they would be 67 | treated equally, so Y stamp has to be rewritten. 68 | Note: This should be removed once we have fine-grained 69 | diffing of functors *) 70 | let new_id = ref (Ident.rename id) in 71 | while Option.is_some (Env.find_modtype_index !new_id ref_env) do 72 | new_id := Ident.rename id 73 | done; 74 | ( Subst.add_modtype id (Mty_ident (Pident !new_id)) subst, 75 | Sig_modtype (!new_id, mtd, v) :: lst )) 76 | | Sig_value (id, vd, v) as sig_val -> ( 77 | match Env.find_value_index id ref_env with 78 | | Some _ -> 79 | let new_id = Ident.rename id in 80 | (subst, Sig_value (new_id, vd, v) :: lst) 81 | | None -> (subst, sig_val :: lst)) 82 | | Sig_class (id, cd, r, v) as sig_cls_decl -> ( 83 | match Env.find_class_index id ref_env with 84 | | Some _ -> 85 | let new_id = Ident.rename id in 86 | (subst, Sig_class (new_id, cd, r, v) :: lst) 87 | | None -> (subst, sig_cls_decl :: lst)) 88 | | Sig_class_type (id, ct, r, v) as sig_cltype -> ( 89 | match Env.find_cltype_index id ref_env with 90 | | Some _ -> 91 | let new_id = Ident.rename id in 92 | (subst, Sig_class_type (new_id, ct, r, v) :: lst) 93 | | None -> (subst, sig_cltype :: lst)) 94 | | _ -> (subst, item :: lst)) 95 | current (Subst.identity, []) 96 | in 97 | apply_subst subst modified_current 98 | 99 | let extract_subst_items signature = 100 | List.fold_left 101 | (fun acc item -> 102 | match item with 103 | | Sig_type (id, { type_manifest = None; _ }, _, _) -> 104 | Subst_item_map.add (Type, Ident.name id) id acc 105 | | Sig_module (id, _, _, _, _) -> 106 | Subst_item_map.add (Module, Ident.name id) id acc 107 | | Sig_modtype (id, _, _) -> 108 | Subst_item_map.add (Modtype, Ident.name id) id acc 109 | | _ -> acc) 110 | Subst_item_map.empty signature 111 | 112 | let pair_items ~reference ~current = 113 | let subst_items = extract_subst_items reference in 114 | List.fold_left 115 | (fun subst item -> 116 | match item with 117 | | Sig_type (id, { type_manifest = None; _ }, _, _) -> ( 118 | match Subst_item_map.find_opt (Type, Ident.name id) subst_items with 119 | | None -> subst 120 | | Some ref_id -> Subst.add_type id (Path.Pident ref_id) subst) 121 | | Sig_module (id, _, _, _, _) -> ( 122 | match Subst_item_map.find_opt (Module, Ident.name id) subst_items with 123 | | None -> subst 124 | | Some ref_id -> Subst.add_module id (Path.Pident ref_id) subst) 125 | | Sig_modtype (id, _, _) -> ( 126 | match 127 | Subst_item_map.find_opt (Modtype, Ident.name id) subst_items 128 | with 129 | | None -> subst 130 | | Some ref_id -> 131 | Subst.add_modtype id (Mty_ident (Path.Pident ref_id)) subst) 132 | | _ -> subst) 133 | Subst.identity current 134 | 135 | let initialized_env = 136 | Compmisc.init_path (); 137 | let env = Compmisc.initial_env () in 138 | fun () -> env 139 | 140 | let for_diff ~reference ~current = 141 | let current = replace_matching_ids ~reference ~current in 142 | let env = 143 | Env.add_signature reference (Env.in_signature true (initialized_env ())) 144 | in 145 | let env = Env.add_signature reference (Env.in_signature true env) in 146 | let env = Env.add_signature current env in 147 | let subst = pair_items ~reference ~current in 148 | let modified_current = apply_subst subst current in 149 | (reference, modified_current, env) 150 | 151 | let expand_tconstr ~typing_env ~path ~args = 152 | let type_decl = 153 | try Some (Env.find_type path typing_env) with Not_found -> None 154 | in 155 | match type_decl with 156 | | None -> None 157 | | Some td -> ( 158 | match td.Types.type_manifest with 159 | | None -> None 160 | | Some type_expr -> 161 | Some (Ctype.apply typing_env td.Types.type_params type_expr args)) 162 | 163 | let fully_expand_tconstr ~typing_env ~path ~args = 164 | let rec aux last path args = 165 | match expand_tconstr ~typing_env ~path ~args with 166 | | None -> last 167 | | Some expr -> ( 168 | match Types.get_desc expr with 169 | | Tconstr (path, args, _) -> aux (Some expr) path args 170 | | _ -> Some expr) 171 | in 172 | aux None path args 173 | 174 | let pp fmt t = 175 | let summary = Env.summary t in 176 | Format.fprintf fmt "@[[@;"; 177 | let pp_in_box kind id f = 178 | Format.fprintf fmt "%s %s:@[@;" kind (Ident.unique_toplevel_name id); 179 | f (); 180 | Format.fprintf fmt "@]@;" 181 | in 182 | let rec pp_rec s = 183 | match (s : Env.summary) with 184 | | Env_empty -> () 185 | | Env_value (s, id, vd) -> 186 | pp_rec s; 187 | pp_in_box "value" id (fun () -> 188 | Format.fprintf fmt "%a" Printtyp.(value_description id) vd) 189 | | Env_type (s, id, td) -> 190 | pp_rec s; 191 | pp_in_box "type" id (fun () -> 192 | Format.fprintf fmt "%a" Printtyp.(type_declaration id) td) 193 | | Env_extension (s, id, ec) -> 194 | pp_rec s; 195 | pp_in_box "extension" id (fun () -> 196 | Format.fprintf fmt "%a" Printtyp.(extension_constructor id) ec) 197 | | Env_module (s, id, mp, { md_type; _ }) -> 198 | pp_rec s; 199 | pp_in_box "module" id (fun () -> 200 | Format.fprintf fmt "%s@;" 201 | (match mp with 202 | | Mp_present -> "Mp_present" 203 | | Mp_absent -> "Mp_absent"); 204 | (match md_type with 205 | | Mty_functor (Named (Some pid, _pmt), _fmt) -> 206 | Ident.print Format.std_formatter pid 207 | | _ -> ()); 208 | Format.fprintf fmt "%a" Printtyp.modtype md_type) 209 | | Env_modtype (s, id, mtyp) -> 210 | pp_rec s; 211 | pp_in_box "module type" id (fun () -> 212 | Format.fprintf fmt "%a" (Printtyp.modtype_declaration id) mtyp) 213 | | Env_class (s, id, cd) -> 214 | pp_rec s; 215 | pp_in_box "class" id (fun () -> 216 | Format.fprintf fmt "%a" (Printtyp.class_declaration id) cd) 217 | | Env_cltype (s, id, ctd) -> 218 | pp_rec s; 219 | pp_in_box "class type" id (fun () -> 220 | Format.fprintf fmt "%a" (Printtyp.cltype_declaration id) ctd) 221 | | Env_open (s, path) -> 222 | pp_rec s; 223 | Format.fprintf fmt "open %a@;" Printtyp.path path 224 | | Env_functor_arg (s, id) -> 225 | pp_rec s; 226 | Format.fprintf fmt "functor arg %s@;" (Ident.unique_toplevel_name id) 227 | | Env_constraints (s, td_map) -> 228 | pp_rec s; 229 | Format.fprintf fmt "constraints@[@;"; 230 | Path.Map.iter 231 | (fun path td -> 232 | Format.fprintf fmt "%a@[@;" Printtyp.path path; 233 | Printtyp.type_declaration (Path.head path) fmt td; 234 | Format.fprintf fmt "@]@;") 235 | td_map; 236 | Format.fprintf fmt "@]@;" 237 | | Env_copy_types s -> 238 | pp_rec s; 239 | Format.fprintf fmt "copy_types@;" 240 | | Env_persistent (s, id) -> 241 | pp_rec s; 242 | Format.fprintf fmt "persistent %s@;" (Ident.unique_toplevel_name id) 243 | | Env_value_unbound (s, name, vu_reason) -> 244 | pp_rec s; 245 | Format.fprintf fmt "value unbound %s: %s@;" name 246 | (match vu_reason with 247 | | Val_unbound_instance_variable -> "instance variable" 248 | | Val_unbound_self -> "self" 249 | | Val_unbound_ancestor -> "ancestor" 250 | | Val_unbound_ghost_recursive _ -> "ghost recursive") 251 | | Env_module_unbound (s, name, Mod_unbound_illegal_recursion) -> 252 | pp_rec s; 253 | Format.fprintf fmt "module unbound %s: illegal recursion@;" name 254 | in 255 | pp_rec summary; 256 | Format.fprintf fmt "@]@;]@;" 257 | -------------------------------------------------------------------------------- /lib/typing_env.mli: -------------------------------------------------------------------------------- 1 | (** Utilities to setup and manipulate typing environments *) 2 | 3 | open Types 4 | 5 | type t = Env.t 6 | 7 | val initialized_env : unit -> t 8 | (** Returns a environment initialized with the standard library. *) 9 | 10 | val for_diff : 11 | reference:signature -> current:signature -> signature * signature * t 12 | (** Returns two modified signatures with unique IDs that are suitable 13 | for placing in the same typing environment that we use for diffing. 14 | 15 | To do so, we first add the [reference] signature to a fresh typing 16 | environment and then modify the [current] signature items to have 17 | different IDs from the [reference] signature items. 18 | We then build a subsitition for non alias types, modules and module types, 19 | so that these items appearing in the [current] signature are treated 20 | equally across the two signatures by the compiler. 21 | We then run the subst aganist the signature items in the [current] 22 | signature before diffing them with signature items in the [reference] signature. 23 | *) 24 | 25 | val expand_tconstr : 26 | typing_env:t -> 27 | path:Path.t -> 28 | args:Types.type_expr list -> 29 | Types.type_expr option 30 | (** Expand the given [Tconstr] once, looking up the environment for an existing 31 | alias and applying the type parameters as needed. 32 | 33 | Returns [None] if the given [Tconstr] cannot be expanded further, i.e. if 34 | it points to reocrd, variant or abstract type or if is not present in 35 | the typing environment 36 | *) 37 | 38 | val fully_expand_tconstr : 39 | typing_env:t -> 40 | path:Path.t -> 41 | args:Types.type_expr list -> 42 | Types.type_expr option 43 | (** Recursively expand the given path and args, looking up the environment for 44 | an existing 45 | alias and applying the type parameters as needed at each step, until expanded to anything but a [Tconstr ...]. 46 | *) 47 | 48 | val pp : Format.formatter -> Env.t -> unit 49 | (** Use for debugging *) 50 | -------------------------------------------------------------------------------- /tests/api-diff/class_detection.t: -------------------------------------------------------------------------------- 1 | Here we generate a `.mli` file with the class declaration: 2 | 3 | $ cat > ref_class.mli << EOF 4 | > class ref_class : object 5 | > method get : int 6 | > method set : int -> unit 7 | > end 8 | > EOF 9 | 10 | We generate .cmi file 11 | $ ocamlc ref_class.mli 12 | 13 | Now, we run api-diff on the same cmi file as both arguments, there should be no difference 14 | $ api-diff ref_class.cmi ref_class.cmi 15 | 16 | ### Adding a new class: 17 | 18 | Generate a new .mli file with an additional class 19 | $ cat > add_class.mli << EOF 20 | > class ref_class : object 21 | > method get : int 22 | > method set : int -> unit 23 | > end 24 | > class add_class : object 25 | > method calculate : float -> float 26 | > end 27 | > EOF 28 | 29 | Compile the new .mli file to a .cmi file 30 | $ ocamlc add_class.mli 31 | 32 | Run api-diff and check the output 33 | $ api-diff ref_class.cmi add_class.cmi 34 | diff module Add_class: 35 | +class add_class : object method calculate : float -> float end 36 | 37 | [1] 38 | 39 | ### Removing a class: 40 | 41 | Generate a new .mli file with the class now removed 42 | $ cat > remove_class.mli << EOF 43 | > EOF 44 | 45 | Compile the new .mli file to a .cmi file 46 | $ ocamlc remove_class.mli 47 | 48 | Run api-diff and check the output 49 | $ api-diff ref_class.cmi remove_class.cmi 50 | diff module Remove_class: 51 | -class ref_class : object method get : int method set : int -> unit end 52 | 53 | [1] 54 | 55 | ### Modifing a class: 56 | 57 | $ cat > modify_class.mli < class ref_class : object 59 | > method set : int -> int 60 | > method size : int 61 | > end 62 | > EOF 63 | 64 | We generate a .cmi file 65 | 66 | $ ocamlc modify_class.mli 67 | 68 | Run api-watcher on the two cmi files, there should be a difference 69 | 70 | $ api-diff ref_class.cmi modify_class.cmi 71 | diff module Modify_class: 72 | -class ref_class : object method get : int method set : int -> unit end 73 | +class ref_class : object method set : int -> int method size : int end 74 | 75 | [1] 76 | -------------------------------------------------------------------------------- /tests/api-diff/cltype_tests.t: -------------------------------------------------------------------------------- 1 | Here we generate a basic `.mli` file with a class type declaration (class interface): 2 | 3 | $ cat > ref_cltype.mli << EOF 4 | > class type ref_cltype = object 5 | > method m1 : string 6 | > method m2 : string -> unit 7 | > end 8 | > EOF 9 | 10 | We generate .cmi file 11 | $ ocamlc ref_cltype.mli 12 | 13 | Now, we run api-diff on the same cmi file as both arguments, there should be no difference 14 | $ api-diff ref_cltype.cmi ref_cltype.cmi 15 | 16 | ### Adding a new class type: 17 | 18 | Generate a new .mli file with an additional class type 19 | $ cat > add_cltype.mli << EOF 20 | > class type ref_cltype = object 21 | > method m1 : string 22 | > method m2 : string -> unit 23 | > end 24 | > class type new_cltype = object 25 | > method mk : int -> unit 26 | > method mn : int -> int 27 | > end 28 | > EOF 29 | 30 | Compile the new .mli file to a .cmi file 31 | $ ocamlc add_cltype.mli 32 | 33 | Run api-diff and check the output 34 | $ api-diff ref_cltype.cmi add_cltype.cmi 35 | diff module Add_cltype: 36 | +class type new_cltype = 37 | + object method mk : int -> unit method mn : int -> int end 38 | 39 | [1] 40 | 41 | ### Removing a class type: 42 | 43 | Generate a new .mli file with the class type now removed 44 | $ cat > remove_cltype.mli << EOF 45 | > EOF 46 | 47 | Compile the new .mli file to a .cmi file 48 | $ ocamlc remove_cltype.mli 49 | 50 | Run api-diff and check the output 51 | $ api-diff ref_cltype.cmi remove_cltype.cmi 52 | diff module Remove_cltype: 53 | -class type ref_cltype = 54 | - object method m1 : string method m2 : string -> unit end 55 | 56 | [1] 57 | 58 | ### Modifing a class type: 59 | 60 | $ cat > modify_cltype.mli << EOF 61 | > class type ref_cltype = object 62 | > method m2 : float -> unit 63 | > method m3 : int -> float 64 | > end 65 | > EOF 66 | 67 | We generate a .cmi file 68 | 69 | $ ocamlc modify_cltype.mli 70 | 71 | Run api-watcher on the two cmi files, there should be a difference 72 | 73 | $ api-diff ref_cltype.cmi modify_cltype.cmi 74 | diff module Modify_cltype: 75 | -class type ref_cltype = 76 | - object method m1 : string method m2 : string -> unit end 77 | +class type ref_cltype = 78 | + object method m2 : float -> unit method m3 : int -> float end 79 | 80 | [1] 81 | -------------------------------------------------------------------------------- /tests/api-diff/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (deps 3 | (package api-watch))) 4 | -------------------------------------------------------------------------------- /tests/api-diff/errors.t: -------------------------------------------------------------------------------- 1 | api-diff only accepts arguments of the same nature, that is it either 2 | diff a .cmi file with another .cmi file or a directory with a directory 3 | 4 | $ mkdir test 5 | $ touch test.cmi 6 | $ api-diff test test.cmi 7 | api-diff: Arguments must either both be directories or both single .cmi files. 8 | [123] 9 | 10 | When diffing all libraries, the Either --main-module or --unwrapped must be specified 11 | 12 | $ mkdir test2 13 | $ api-diff test test2 14 | api-diff: Either --main-module or --unwrapped must be provided when diffing entire libraries. 15 | [123] 16 | 17 | When passing --main-module and/or --unwrapped while diffing single .cmi files, the user will be warn 18 | that it is ignored 19 | 20 | $ touch test2.cmi 21 | $ api-diff --main-module main test.cmi test2.cmi 22 | api-diff: --main-module is ignored when diffing single .cmi files 23 | api-diff: Error parsing test.cmi: Cmi_format.Error(_) 24 | [123] 25 | 26 | $ touch test2.cmi 27 | $ api-diff --unwrapped test.cmi test2.cmi 28 | api-diff: --unwrapped is ignored when diffing single .cmi files 29 | api-diff: Error parsing test.cmi: Cmi_format.Error(_) 30 | [123] 31 | 32 | $ touch test2.cmi 33 | $ api-diff --main-module main --unwrapped test.cmi test2.cmi 34 | api-diff: --main-module and --unwrapped are ignored when diffing single .cmi files 35 | api-diff: Error parsing test.cmi: Cmi_format.Error(_) 36 | [123] 37 | -------------------------------------------------------------------------------- /tests/api-diff/extension_constructors.t: -------------------------------------------------------------------------------- 1 | Here we generate a `.mli` file to test changes in extension constructors 2 | 3 | $ cat > ref_extcstr.mli << EOF 4 | > type o = .. 5 | > type o += A of int 6 | > EOF 7 | 8 | We generate the .cmi file 9 | 10 | $ ocamlc ref_extcstr.mli 11 | 12 | ### Marking an extension constructor private 13 | 14 | $ cat > cur_private_extcstr.mli << EOF 15 | > type o = .. 16 | > type o += private A of int 17 | > EOF 18 | 19 | We generate the .cmi file 20 | 21 | $ ocamlc cur_private_extcstr.mli 22 | 23 | Run the api-watcher on the two cmi files 24 | 25 | $ api-diff --plain ref_extcstr.cmi cur_private_extcstr.cmi 26 | diff module Cur_private_extcstr: 27 | -type o += A of int 28 | +type o +={+ private+} A of int 29 | 30 | [1] 31 | 32 | ### Changing a constructor argument 33 | 34 | $ cat > cur_change_param_extcstr.mli << EOF 35 | > type o = .. 36 | > type o += A of float 37 | > EOF 38 | 39 | We generate the .cmi file 40 | 41 | $ ocamlc cur_change_param_extcstr.mli 42 | 43 | Run the api-watcher on the two cmi files 44 | 45 | $ api-diff --plain ref_extcstr.cmi cur_change_param_extcstr.cmi 46 | diff module Cur_change_param_extcstr: 47 | -type o += A of [-int-] 48 | +type o += A of {+float+} 49 | 50 | [1] 51 | 52 | Here we generate a `.mli` file to test changes in exceptions 53 | 54 | $ cat > ref_exception.mli << EOF 55 | > exception BadExp of int 56 | > EOF 57 | 58 | We generate the .cmi file 59 | 60 | $ ocamlc ref_exception.mli 61 | 62 | ### Changing a constructor argument 63 | 64 | $ cat > cur_change_param_exn.mli << EOF 65 | > exception BadExp of float 66 | > EOF 67 | 68 | We generate the .cmi file 69 | 70 | $ ocamlc cur_change_param_exn.mli 71 | 72 | Run the api-watcher on the two cmi files, both should be displayed in the exception syntax 73 | 74 | $ api-diff --plain ref_exception.cmi cur_change_param_exn.cmi 75 | diff module Cur_change_param_exn: 76 | -exception BadExp of [-int-] 77 | +exception BadExp of {+float+} 78 | 79 | [1] 80 | 81 | ### Marking an exception private 82 | 83 | $ cat > cur_private_exn.mli << EOF 84 | > type exn += private BadExp of int 85 | > EOF 86 | 87 | We generate the .cmi file 88 | 89 | $ ocamlc cur_private_exn.mli 90 | 91 | Run the api-watcher on the two cmi files, both should be displayed in the extension constructor syntax 92 | 93 | $ api-diff --plain ref_exception.cmi cur_private_exn.cmi 94 | diff module Cur_private_exn: 95 | -type exn += BadExp of int 96 | +type exn +={+ private+} BadExp of int 97 | 98 | [1] 99 | 100 | Here we generate a `.mli` with a parameterized extensible variant type: 101 | 102 | $ cat > ref_param_ext_var.mli << EOF 103 | > type ('a, 'b) po = .. 104 | > type ('a, 'b) po += A of 'a 105 | > EOF 106 | 107 | We generate the .cmi file 108 | 109 | $ ocamlc ref_param_ext_var.mli 110 | 111 | ### Removing a type paramter from a parameterized extensible variant type 112 | 113 | $ cat > cur_param_ext_var.mli << EOF 114 | > type 'a po = .. 115 | > type 'a po += A of 'a 116 | > EOF 117 | 118 | We generate the .cmi file 119 | 120 | $ ocamlc cur_param_ext_var.mli 121 | 122 | Run the api-watcher, there should be no diff on the constructors 123 | 124 | $ api-diff --plain ref_param_ext_var.cmi cur_param_ext_var.cmi 125 | diff module Cur_param_ext_var: 126 | -type ('a[-, 'b-]) po = 127 | +type ('a) po = 128 | .. 129 | 130 | [1] 131 | -------------------------------------------------------------------------------- /tests/api-diff/fine_grained_type_expr.t: -------------------------------------------------------------------------------- 1 | Here we generate a `.mli` file with a tuple: 2 | 3 | $ cat > ref_tuple.mli << EOF 4 | > type t = int * int * int 5 | > EOF 6 | 7 | We generate the .cmi file 8 | 9 | $ ocamlc ref_tuple.mli 10 | 11 | ### Changing a component in a tuple 12 | 13 | $ cat > change_tuple.mli << EOF 14 | > type t = float * int * int 15 | > EOF 16 | 17 | We generate the .cmi file 18 | 19 | $ ocamlc change_tuple.mli 20 | 21 | Run the api-watcher on the two cmi files, a diff should be reported between the first 22 | components of the two tuples 23 | 24 | $ api-diff --plain ref_tuple.cmi change_tuple.cmi 25 | diff module Change_tuple: 26 | -type t = [-int-] * int * int 27 | +type t = {+float+} * int * int 28 | 29 | [1] 30 | 31 | ### Adding a component to a tuple 32 | 33 | $ cat > add_tuple.mli << EOF 34 | > type t = int * int * int * string 35 | > EOF 36 | 37 | We generate the .cmi file 38 | 39 | $ ocamlc add_tuple.mli 40 | 41 | Run the api-watcher on the two cmi files, the added component should be marked 42 | 43 | $ api-diff --plain ref_tuple.cmi add_tuple.cmi 44 | diff module Add_tuple: 45 | -type t = int * int * int 46 | +type t = int * int * int{+ * string+} 47 | 48 | [1] 49 | 50 | Here we generate a `.mli` file a nested tuple: 51 | 52 | $ cat > ref_nested_tuple.mli << EOF 53 | > type t = int * (int * int) 54 | > EOF 55 | 56 | We generate the .cmi file 57 | 58 | $ ocamlc ref_nested_tuple.mli 59 | 60 | ### Changing a component in the nested tuple 61 | 62 | $ cat > change_nested_tuple.mli << EOF 63 | > type t = int * (float * int) 64 | > EOF 65 | 66 | We generate the .cmi file 67 | 68 | $ ocamlc change_nested_tuple.mli 69 | 70 | Run the api-watcher on the two cmi files, a diff should be reported in the first component of the nested tuple 71 | 72 | $ api-diff --plain ref_nested_tuple.cmi change_nested_tuple.cmi 73 | diff module Change_nested_tuple: 74 | -type t = int * ([-int-] * int) 75 | +type t = int * ({+float+} * int) 76 | 77 | [1] 78 | 79 | Here we generate a `.mli` file with an arrow type: 80 | 81 | $ cat > ref_arrow.mli << EOF 82 | > type t = int -> int -> int 83 | > EOF 84 | 85 | We generate the .cmi file 86 | 87 | $ ocamlc ref_arrow.mli 88 | 89 | ### Changing a argument type in the arrow type 90 | 91 | $ cat > change_arg_type_in_arrow.mli << EOF 92 | > type t = float -> int -> int 93 | > EOF 94 | 95 | We generate the .cmi file 96 | 97 | $ ocamlc change_arg_type_in_arrow.mli 98 | 99 | Run the api-watcher on the two cmi files, a diff should be reported between the argument type of the two arrow types 100 | 101 | $ api-diff --plain ref_arrow.cmi change_arg_type_in_arrow.cmi 102 | diff module Change_arg_type_in_arrow: 103 | -type t = [-int-] -> int -> int 104 | +type t = {+float+} -> int -> int 105 | 106 | [1] 107 | 108 | ### Making an argument optional in the arrow type 109 | 110 | $ cat > opt_arg_type.mli << EOF 111 | > type t = ?opt:int -> int -> int 112 | > EOF 113 | 114 | We generate the .cmi file 115 | 116 | $ ocamlc opt_arg_type.mli << EOF 117 | 118 | Run the api-watcher on the two cmi files, the optional argument name should be highlighted 119 | 120 | $ api-diff --plain ref_arrow.cmi opt_arg_type.cmi 121 | diff module Opt_arg_type: 122 | -type t = int -> int -> int 123 | +type t = {+?opt:+}int -> int -> int 124 | 125 | [1] 126 | 127 | ### Changing the arg type in a arrow type with an arrow type as its argument 128 | 129 | $ cat > ref_arrow_arg.mli << EOF 130 | > type t = (int -> int) -> int 131 | > EOF 132 | 133 | We generate the .cmi file 134 | 135 | $ ocamlc ref_arrow_arg.mli << EOF 136 | 137 | $ cat > cur_arrow_arg.mli << EOF 138 | > type t = (float -> string) -> int 139 | > EOF 140 | 141 | We generate the .cmi file 142 | 143 | $ ocamlc cur_arrow_arg.mli << EOF 144 | 145 | Run the api-watcher on the two cmi files, the argument arrow type should parenthesized 146 | 147 | $ api-diff --plain ref_arrow_arg.cmi cur_arrow_arg.cmi 148 | diff module Cur_arrow_arg: 149 | -type t = ([-int-] -> [-int-]) -> int 150 | +type t = ({+float+} -> {+string+}) -> int 151 | 152 | [1] 153 | 154 | Here we generate a file with a tuple type nested inside an arrow type: 155 | 156 | $ cat > ref_tuple_in_arrow.mli << EOF 157 | > type t = int * float * string -> string -> char 158 | > EOF 159 | 160 | We generate the .cmi file 161 | 162 | $ ocamlc ref_tuple_in_arrow.mli 163 | 164 | $ cat > cur_tuple_in_arrow.mli << EOF 165 | > type t = int * char * string -> string -> string 166 | > EOF 167 | 168 | $ ocamlc cur_tuple_in_arrow.mli 169 | 170 | Run the api-watcher on the two cmi files, the tuple should not be parenthesized 171 | 172 | $ api-diff --plain ref_tuple_in_arrow.cmi cur_tuple_in_arrow.cmi 173 | diff module Cur_tuple_in_arrow: 174 | -type t = int * [-float-] * string -> string -> [-char-] 175 | +type t = int * {+char+} * string -> string -> {+string+} 176 | 177 | [1] 178 | 179 | Here we generate a file with arrow type nested inside a tuple type: 180 | 181 | $ cat > ref_arrow_in_tuple.mli << EOF 182 | > type s = (int -> int) * float * ((int -> int) -> int) 183 | > EOF 184 | 185 | We generate the .cmi file 186 | 187 | $ ocamlc ref_arrow_in_tuple.mli 188 | 189 | $ cat > cur_arrow_in_tuple.mli << EOF 190 | > type s = (float -> float) * string * ((string -> string) -> float) 191 | > EOF 192 | 193 | $ ocamlc cur_arrow_in_tuple.mli 194 | 195 | Run the api-watcher on the two cmi files, the arrows should not be parenthesized 196 | 197 | $ api-diff --plain ref_arrow_in_tuple.cmi cur_arrow_in_tuple.cmi 198 | diff module Cur_arrow_in_tuple: 199 | -type s = ([-int-] -> [-int-]) * [-float-] * (([-int-] -> [-int-]) -> [-int-]) 200 | +type s = ({+float+} -> {+float+}) * {+string+} * (({+string+} -> {+string+}) -> {+float+}) 201 | 202 | [1] 203 | 204 | 205 | Here we generate a `.mli` file with a type constructor, to test changes 206 | in abstract type constrs: 207 | 208 | 209 | $ cat > ref_abstract_type_constr.mli << EOF 210 | > val x : int 211 | > EOF 212 | 213 | We generate the .cmi file 214 | 215 | $ ocamlc ref_abstract_type_constr.mli 216 | 217 | $ cat > cur_abstract_type_constr.mli << EOF 218 | > val x : float 219 | > EOF 220 | 221 | We generate the .cmi file 222 | 223 | $ ocamlc cur_abstract_type_constr.mli 224 | 225 | Run the api-watcher on the two .cmi files 226 | 227 | $ api-diff --plain ref_abstract_type_constr.cmi cur_abstract_type_constr.cmi 228 | diff module Cur_abstract_type_constr: 229 | -val x : [-int-] 230 | +val x : {+float+} 231 | 232 | [1] 233 | 234 | We generate a `.mli` file with a record type and a type constructor, to test changes in nominal type constrs: 235 | 236 | $ cat > ref_nominal_type_constr.mli << EOF 237 | > type t = { a : int; b : float } 238 | > val x : t 239 | > EOF 240 | 241 | We generate the .cmi file 242 | 243 | $ ocamlc ref_nominal_type_constr.mli 244 | 245 | $ cat > cur_nominal_type_constr.mli << EOF 246 | > type t = { a : float; b : float } 247 | > val x : t 248 | > EOF 249 | 250 | We generate the .cmi file 251 | 252 | $ ocamlc cur_nominal_type_constr.mli 253 | 254 | Run the api-watcher on the two .cmi files, there should be a diff on the record 255 | type declaration only 256 | 257 | $ api-diff --plain ref_nominal_type_constr.cmi cur_nominal_type_constr.cmi 258 | diff module Cur_nominal_type_constr: 259 | type t = 260 | - { b : float; a : [-int-]; } 261 | + { b : float; a : {+float+}; } 262 | 263 | [1] 264 | 265 | We generate a `.mli` with an alias to tuple type, to test changes in alias type 266 | constrs: 267 | 268 | $ cat > ref_alias_tuple.mli << EOF 269 | > type t = int * int 270 | > val x : t 271 | > EOF 272 | 273 | We generate the .cmi file 274 | 275 | $ ocamlc ref_alias_tuple.mli 276 | 277 | $ cat > cur_alias_tuple.mli << EOF 278 | > type t = int * float 279 | > val x : t 280 | > EOF 281 | 282 | We generate the .cmi file 283 | 284 | $ ocamlc cur_alias_tuple.mli 285 | 286 | Run the api-watcher on the two cmi files, the alias to t should expand 287 | 288 | $ api-diff --plain ref_alias_tuple.cmi cur_alias_tuple.cmi 289 | diff module Cur_alias_tuple: 290 | -val x : int * [-int-] 291 | +val x : int * {+float+} 292 | -type t = int * [-int-] 293 | +type t = int * {+float+} 294 | 295 | [1] 296 | 297 | We generate a `.mli` with a type constructor that has arguments 298 | 299 | $ cat > ref_type_constr_with_args.mli << EOF 300 | > val x : (int, string) result 301 | > EOF 302 | 303 | We generate the .cmi file 304 | 305 | $ ocamlc ref_type_constr_with_args.mli 306 | 307 | $ cat > cur_type_constr_with_args.mli << EOF 308 | > val x : (float, string) result 309 | > EOF 310 | 311 | We generate the .cmi file 312 | 313 | $ ocamlc cur_type_constr_with_args.mli 314 | 315 | Run the api-watcher on the two cmi files 316 | 317 | $ api-diff --plain ref_type_constr_with_args.cmi cur_type_constr_with_args.cmi 318 | diff module Cur_type_constr_with_args: 319 | -val x : ([-int-], string) Stdlib.result 320 | +val x : ({+float+}, string) Stdlib.result 321 | 322 | [1] 323 | 324 | We generate a `.mli` with a type constrcutor that expands to a tuple 325 | 326 | $ cat > ref_type_constr_to_tuple.mli << EOF 327 | > type ('a, 'b) t = 'a * 'b 328 | > val x : (int, float) t 329 | > EOF 330 | 331 | We generate the .cmi file 332 | 333 | $ ocamlc ref_type_constr_to_tuple.mli 334 | 335 | $ cat > cur_type_constr_to_tuple.mli << EOF 336 | > type ('a, 'b) t = 'a * 'b 337 | > val x : (float, int) t 338 | > EOF 339 | 340 | We generate the .cmi file 341 | 342 | $ ocamlc cur_type_constr_to_tuple.mli 343 | 344 | Run the api-watcher on the two cmi files, for now type exprs should expand to their original definition if they were different 345 | 346 | $ api-diff --plain ref_type_constr_to_tuple.cmi cur_type_constr_to_tuple.cmi 347 | diff module Cur_type_constr_to_tuple: 348 | -val x : [-int-] * [-float-] 349 | +val x : {+float+} * {+int+} 350 | 351 | [1] 352 | 353 | We generate a `.mli` with a long alias chain 354 | 355 | $ cat > ref_long_alias_chain.mli << EOF 356 | > type ('a, 'b) t = 'a * 'b * int 357 | > type ('a, 'b) u = ('a, 'b) t * float 358 | > type ('a, 'b) s = ('a, 'b) u 359 | > type 'a r = ('a, 'a) s 360 | > val x : int r 361 | 362 | We generate the .cmi file 363 | 364 | $ ocamlc ref_long_alias_chain.mli 365 | 366 | $ cat > cur_long_alias_chain.mli << EOF 367 | > type ('a, 'b) t = 'a * 'b * int 368 | > type ('a, 'b) u = ('a, 'b) t * float 369 | > type ('a, 'b) s = ('a, 'b) u 370 | > type 'a r = ('a, 'a) s 371 | > val x : float r 372 | 373 | We generate the .cmi file 374 | 375 | $ ocamlc cur_long_alias_chain.mli 376 | 377 | Run the api-watcher on the two cmi files 378 | 379 | $ api-diff --plain ref_long_alias_chain.cmi cur_long_alias_chain.cmi 380 | diff module Cur_long_alias_chain: 381 | -val x : ([-int-] * [-int-] * int) * float 382 | +val x : ({+float+} * {+float+} * int) * float 383 | 384 | [1] 385 | -------------------------------------------------------------------------------- /tests/api-diff/identical_cmi.t: -------------------------------------------------------------------------------- 1 | ## Tests for Identical .cmi files: 2 | 3 | Here we generate a basic `.mli` file with two types and a function: 4 | 5 | $ cat > ref.mli << EOF 6 | > type t = int 7 | > type unused_type = string 8 | > val f : t -> string 9 | > EOF 10 | 11 | We generate the .cmi file 12 | 13 | $ ocamlc ref.mli 14 | 15 | And now we run api-watcher on that same cmi file as both arguments, 16 | there should be no diff: 17 | 18 | $ api-diff ref.cmi ref.cmi 19 | -------------------------------------------------------------------------------- /tests/api-diff/modified_variant_type_tests.t: -------------------------------------------------------------------------------- 1 | Here we generate a `.mli` file with a variant type: 2 | 3 | $ cat > ref.mli << EOF 4 | > type rank = Ace | King | Queen | Number of int 5 | > EOF 6 | 7 | We generate the .cmi file 8 | 9 | $ ocamlc ref.mli 10 | 11 | # Tests for different kind of modifications to a variant type: 12 | 13 | ### Adding a constructor to a variant type: 14 | 15 | $ cat > add_constructor.mli << EOF 16 | > type rank = Ace | King | Queen | Jack | Number of int 17 | > EOF 18 | 19 | We generate the .cmi file 20 | 21 | $ ocamlc add_constructor.mli 22 | 23 | Run the api-watcher on the two cmi files 24 | 25 | $ api-diff ref.cmi add_constructor.cmi 26 | diff module Add_constructor: 27 | type rank = 28 | | Ace 29 | | King 30 | | Number of int 31 | | Queen 32 | + | Jack 33 | 34 | [1] 35 | 36 | ### Removing a constructor from a variant type: 37 | 38 | $ cat > remove_constructor.mli << EOF 39 | > type rank = Ace | King | Queen 40 | > EOF 41 | 42 | We generate the .cmi file 43 | 44 | $ ocamlc remove_constructor.mli 45 | 46 | Run the api-watcher on the two cmi files 47 | 48 | $ api-diff ref.cmi remove_constructor.cmi 49 | diff module Remove_constructor: 50 | type rank = 51 | | Ace 52 | | King 53 | | Queen 54 | - | Number of int 55 | 56 | [1] 57 | 58 | ### Modifying a constructor arguments in a variant type: 59 | 60 | $ cat > modify_constructor_type.mli << EOF 61 | > type rank = Ace | King | Queen | Number of float 62 | > EOF 63 | 64 | We generate the .cmi file 65 | 66 | $ ocamlc modify_constructor_type.mli 67 | 68 | Run the api-watcher on the two cmi files 69 | 70 | $ api-diff ref.cmi modify_constructor_type.cmi 71 | diff module Modify_constructor_type: 72 | type rank = 73 | | Ace 74 | | King 75 | | Queen 76 | - | Number of int 77 | + | Number of float 78 | 79 | [1] 80 | 81 | Tests for modifying constructor record argument 82 | 83 | $ cat > shapes.mli << EOF 84 | > type point = float * float 85 | > type shape = 86 | > | Circle of { center : point; raduis: int } 87 | > | Rectangle of { lower_left: point; upper_right: point } 88 | > EOF 89 | 90 | We generate the .cmi file 91 | 92 | $ ocamlc shapes.mli 93 | 94 | ### Adding a field to a record type in a constructor argument: 95 | 96 | $ cat > add_field.mli << EOF 97 | > type point = float * float 98 | > type shape = 99 | > | Circle of { center : point; raduis : int; color : int; } 100 | > | Rectangle of { lower_left : point; upper_right : point; color : int; } 101 | > EOF 102 | 103 | We generate the .cmi file 104 | 105 | $ ocamlc add_field.mli 106 | 107 | Run the api-watcher on the two cmi files 108 | 109 | $ api-diff shapes.cmi add_field.cmi 110 | diff module Add_field: 111 | type shape = 112 | - | Circle of { center : point; raduis : int; } 113 | + | Circle of { center : point; raduis : int; color : int; } 114 | - | Rectangle of { lower_left : point; upper_right : point; } 115 | + | Rectangle of { lower_left : point; upper_right : point; color : int; } 116 | 117 | [1] 118 | 119 | ### Removing a field from a record type in a constructor argument: 120 | 121 | $ cat > remove_field.mli << EOF 122 | > type point = float * float 123 | > type shape = 124 | > | Circle of { center : point; } 125 | > | Rectangle of { lower_left: point; upper_right: point; } 126 | > EOF 127 | 128 | We generate the .cmi file 129 | 130 | $ ocamlc remove_field.mli 131 | 132 | Run the api-watcher on the two cmi files 133 | 134 | $ api-diff shapes.cmi remove_field.cmi 135 | diff module Remove_field: 136 | type shape = 137 | | Rectangle of { lower_left : point; upper_right : point; } 138 | - | Circle of { center : point; raduis : int; } 139 | + | Circle of { center : point; } 140 | 141 | [1] 142 | 143 | ### Modifying a field in a record type in a constructor argument: 144 | 145 | $ cat > modify_field.mli << EOF 146 | > type point = float * float 147 | > type shape = 148 | > | Circle of { center : point; raduis: float; } 149 | > | Rectangle of { lower_left: point; upper_right: point; } 150 | > EOF 151 | 152 | We generate the .cmi file 153 | 154 | $ ocamlc modify_field.mli 155 | 156 | Run the api-watcher on the two cmi files 157 | 158 | $ api-diff shapes.cmi modify_field.cmi 159 | diff module Modify_field: 160 | type shape = 161 | | Rectangle of { lower_left : point; upper_right : point; } 162 | - | Circle of { center : point; raduis : int; } 163 | + | Circle of { center : point; raduis : float; } 164 | 165 | [1] 166 | 167 | Tests for modifying constructor tuple argument 168 | 169 | $ cat > shapes2.mli << EOF 170 | > type point = float * float 171 | > type shape = 172 | > | Circle of point * int 173 | > | Rectangle of point * point 174 | > EOF 175 | 176 | We generate the .cmi file 177 | 178 | $ ocamlc shapes2.mli 179 | 180 | ### Adding an component to a tuple type in a constructor argument: 181 | 182 | $ cat > add_component.mli << EOF 183 | > type point = float * float 184 | > type shape = 185 | > | Circle of point * int * int 186 | > | Rectangle of point * point * int 187 | > EOF 188 | 189 | We generate the .cmi file 190 | 191 | $ ocamlc add_component.mli 192 | 193 | Run the api-watcher on the two cmi files 194 | 195 | $ api-diff shapes2.cmi add_component.cmi 196 | diff module Add_component: 197 | type shape = 198 | - | Circle of point * int 199 | + | Circle of point * int * int 200 | - | Rectangle of point * point 201 | + | Rectangle of point * point * int 202 | 203 | [1] 204 | 205 | ### Removing a component from a tuple type in a constructor argument: 206 | 207 | $ cat > remove_component.mli << EOF 208 | > type point = float * float 209 | > type shape = 210 | > | Circle of point 211 | > | Rectangle of point * point 212 | > EOF 213 | 214 | We generate the .cmi file 215 | 216 | $ ocamlc remove_component.mli 217 | 218 | Run the api-watcher on the two cmi files 219 | 220 | $ api-diff shapes2.cmi remove_component.cmi 221 | diff module Remove_component: 222 | type shape = 223 | | Rectangle of point * point 224 | - | Circle of point * int 225 | + | Circle of point 226 | 227 | [1] 228 | 229 | ### Modifying a component in a tuple type in a constructor argument: 230 | 231 | $ cat > modify_component.mli << EOF 232 | > type point = float * float 233 | > type shape = 234 | > | Circle of point * float 235 | > | Rectangle of point * point 236 | > EOF 237 | 238 | We generate the .cmi file 239 | 240 | $ ocamlc modify_component.mli 241 | 242 | Run the api-watcher on the two cmi files 243 | 244 | $ api-diff shapes2.cmi modify_component.cmi 245 | diff module Modify_component: 246 | type shape = 247 | | Rectangle of point * point 248 | - | Circle of point * int 249 | + | Circle of point * float 250 | 251 | [1] 252 | -------------------------------------------------------------------------------- /tests/api-diff/module_tests.t: -------------------------------------------------------------------------------- 1 | # Tests for module modifications 2 | 3 | Here we generate a `.mli` file with a module: 4 | 5 | $ cat > mod_ref.mli << EOF 6 | > module M : sig val x : int end 7 | > 8 | > EOF 9 | 10 | We generate the .cmi file 11 | 12 | $ ocamlc mod_ref.mli 13 | 14 | And now we run api-watcher on that same cmi file as both arguments, 15 | there should be no diff: 16 | 17 | $ api-diff mod_ref.cmi mod_ref.cmi 18 | 19 | ### Adding a module: 20 | 21 | Generate a new .mli file with an additional module 22 | $ cat > add_module.mli << EOF 23 | > module M : sig val x : int end 24 | > module N : sig val y : float end 25 | > 26 | > EOF 27 | 28 | Compile the new .mli file to a .cmi file 29 | $ ocamlc add_module.mli 30 | 31 | Run api-diff and check the output 32 | $ api-diff mod_ref.cmi add_module.cmi 33 | diff module Add_module: 34 | +module N: sig val y : float end 35 | 36 | [1] 37 | 38 | ### Removing a module: 39 | 40 | Generate a new .mli file with the module removed 41 | $ cat > remove_module.mli << EOF 42 | > 43 | > EOF 44 | 45 | Compile the new .mli file to a .cmi file 46 | $ ocamlc remove_module.mli 47 | 48 | Run api-diff and check the output 49 | $ api-diff mod_ref.cmi remove_module.cmi 50 | diff module Remove_module: 51 | -module M: sig val x : int end 52 | 53 | [1] 54 | 55 | ### Modifying a module: 56 | 57 | Generate a new .mli file with the module modified 58 | $ cat > modify_module.mli << EOF 59 | > module M : sig val x : float end 60 | > 61 | > EOF 62 | 63 | Compile the new .mli file to a .cmi file 64 | $ ocamlc modify_module.mli 65 | 66 | Run api-diff and check the output 67 | $ api-diff mod_ref.cmi modify_module.cmi 68 | diff module Modify_module.M: 69 | -val x : int 70 | +val x : float 71 | 72 | [1] 73 | 74 | Generate a new .mli file with values and submodules 75 | $ cat > orig_module.mli << EOF 76 | > module M : sig val x : float end 77 | > type ('a, 'b) result = Ok of 'a | Error of 'b 78 | > val a : string -> int 79 | > val f : int -> string 80 | > module D : sig 81 | > val b : int list -> int 82 | > val g : int -> string 83 | > end 84 | > EOF 85 | 86 | Compile the new .mli file to a .cmi file 87 | $ ocamlc orig_module.mli 88 | 89 | Generate a new .mli file with the values and submodules modified 90 | $ cat > modified_module.mli << EOF 91 | > module M : sig val x : float end 92 | > type ('a, 'b) result = Ok of 'a | Error of 'b 93 | > val a : string -> float 94 | > val f : int -> (string, string) result 95 | > module D : sig 96 | > val b : float list -> float 97 | > val g : int -> (string, string) result 98 | > end 99 | > module E : sig val x: int end 100 | > EOF 101 | 102 | Compile the modified .mli file to a .cmi file 103 | $ ocamlc modified_module.mli 104 | 105 | Run api-diff and check the output 106 | $ api-diff orig_module.cmi modified_module.cmi 107 | diff module Modified_module: 108 | -val a : string -> int 109 | +val a : string -> float 110 | -val f : int -> string 111 | +val f : int -> (string, string) result 112 | +module E: sig val x : int end 113 | 114 | diff module Modified_module.D: 115 | -val b : int list -> int 116 | +val b : float list -> float 117 | -val g : int -> string 118 | +val g : int -> (string, string) result 119 | 120 | [1] 121 | -------------------------------------------------------------------------------- /tests/api-diff/module_type_test.t: -------------------------------------------------------------------------------- 1 | # Tests for module type type modifications 2 | 3 | Here we generate a `.mli` file with a module type: 4 | 5 | $ cat > modtype_ref.mli << EOF 6 | > module type M = sig val x : int end 7 | > 8 | > EOF 9 | 10 | We generate the .cmi file 11 | 12 | $ ocamlc modtype_ref.mli 13 | 14 | And now we run api-watcher on that same cmi file as both arguments, 15 | there should be no diff: 16 | 17 | $ api-diff modtype_ref.cmi modtype_ref.cmi 18 | 19 | ### Adding a module type: 20 | 21 | Generate a new .mli file with an additional module type 22 | $ cat > add_modtype.mli << EOF 23 | > module type M = sig val x : int end 24 | > module type P = sig val y : float end 25 | > 26 | > EOF 27 | 28 | Compile the new .mli file to a .cmi file 29 | $ ocamlc add_modtype.mli 30 | 31 | Run api-diff and check the output 32 | $ api-diff modtype_ref.cmi add_modtype.cmi 33 | diff module Add_modtype: 34 | +module type P = sig val y : float end 35 | 36 | [1] 37 | 38 | ### Removing a module type: 39 | 40 | Generate a new .mli file with the module type removed 41 | $ cat > remove_modtype.mli << EOF 42 | > 43 | > EOF 44 | 45 | Compile the new .mli file to a .cmi file 46 | $ ocamlc remove_modtype.mli 47 | 48 | Run api-diff and check the output 49 | $ api-diff modtype_ref.cmi remove_modtype.cmi 50 | diff module Remove_modtype: 51 | -module type M = sig val x : int end 52 | 53 | [1] 54 | 55 | ### Modifying a module type: 56 | 57 | Generate a new .mli file with the module type modified 58 | $ cat > modify_modtype.mli << EOF 59 | > module type M = sig val x : float end 60 | > 61 | > EOF 62 | 63 | Compile the new .mli file to a .cmi file 64 | $ ocamlc modify_modtype.mli 65 | 66 | Run api-diff and check the output 67 | $ api-diff modtype_ref.cmi modify_modtype.cmi 68 | diff module Modify_modtype.M: 69 | -val x : int 70 | +val x : float 71 | 72 | [1] 73 | 74 | 75 | # Switching a module type from concrete to abstract 76 | 77 | Generate a new .mli file with a concrete submodule type 78 | $ cat > conc_modtype.mli << EOF 79 | > module type M = sig val x : float end 80 | > module type P 81 | > EOF 82 | 83 | Compile the new .mli file to a .cmi file 84 | $ ocamlc conc_modtype.mli 85 | 86 | Generate a new .mli file with an abstract submodule type 87 | $ cat > abs_modtype.mli << EOF 88 | > module type M 89 | > module type P = sig val y : string end 90 | > module type N = sig val d : int end 91 | > EOF 92 | 93 | Compile the modified .mli file to a .cmi file 94 | $ ocamlc abs_modtype.mli 95 | 96 | Run api-diff and check the output 97 | $ api-diff conc_modtype.cmi abs_modtype.cmi 98 | diff module Abs_modtype: 99 | +module type N = sig val d : int end 100 | 101 | diff module Abs_modtype.M: 102 | + 103 | 104 | diff module Abs_modtype.P: 105 | + 106 | 107 | [1] 108 | -------------------------------------------------------------------------------- /tests/api-diff/module_type_vs_module_alias.t: -------------------------------------------------------------------------------- 1 | This tests issue #121 (https://github.com/ocaml-semver/ocaml-api-watch/issues/121) 2 | 3 | Let's setup a test case: 4 | 5 | $ cat > deps.mli << EOF 6 | > module X : sig end 7 | > module type Y = sig end 8 | > EOF 9 | 10 | $ cat > file.mli << EOF 11 | > module A = Deps.X 12 | > module B : Deps.Y 13 | > EOF 14 | 15 | $ ocamlc -c deps.mli 16 | $ ocamlc -c -I . file.mli 17 | 18 | $ api-diff --main-module file . . 19 | -------------------------------------------------------------------------------- /tests/api-diff/parametrized_types_tests.t: -------------------------------------------------------------------------------- 1 | Here we generate a `.mli` file with a single type variable: 2 | 3 | $ cat > ref.mli << EOF 4 | > type ('a, 'b) t = { a: 'a; b: 'b } 5 | > EOF 6 | 7 | We generate the .cmi file 8 | 9 | $ ocamlc ref.mli 10 | 11 | # Renaming a type variable consistently across the type declaration: 12 | 13 | $ cat > rename_type_vars.mli << EOF 14 | > type ('c, 'd) t = { a : 'c; b: 'd } 15 | > EOF 16 | 17 | We generate the .cmi file 18 | 19 | $ ocamlc rename_type_vars.mli 20 | 21 | Run the api-watcher on the two cmi files, there should be no diff 22 | 23 | $ api-diff ref.cmi rename_type_vars.cmi 24 | 25 | # Adding a type variable to a type declaration: 26 | 27 | $ cat > add_type_var.mli << EOF 28 | > type ('a, 'b, 'c) t = { a : 'a; b: 'b * 'c } 29 | > EOF 30 | 31 | We generate the .cmi file 32 | 33 | $ ocamlc add_type_var.mli 34 | 35 | Run the api-watcher on the two cmi files 36 | 37 | $ api-diff ref.cmi add_type_var.cmi 38 | diff module Add_type_var: 39 | -type ('a, 'b) t = 40 | +type ('a, 'b, 'c) t = 41 | - { a : 'a; b : 'b; } 42 | + { a : 'a; b : 'b * 'c; } 43 | 44 | [1] 45 | 46 | # Removing a type variable from a type declaration: 47 | 48 | $ cat > remove_type_var.mli << EOF 49 | > type 'a t = { a : 'a; b : int } 50 | > EOF 51 | 52 | We generate the .cmi file 53 | 54 | $ ocamlc remove_type_var.mli 55 | 56 | Run the api-watcher on the two cmi files 57 | 58 | $ api-diff ref.cmi remove_type_var.cmi 59 | diff module Remove_type_var: 60 | -type ('a, 'b) t = 61 | +type ('a) t = 62 | - { a : 'a; b : 'b; } 63 | + { a : 'a; b : int; } 64 | 65 | [1] 66 | 67 | # Changing the use of type variables in a type declaration: 68 | 69 | $ cat > change_type_var_use.mli << EOF 70 | > type ('a, 'b) t = { a : 'b; b : 'a } 71 | > EOF 72 | 73 | We generate the .cmi file 74 | 75 | $ ocamlc change_type_var_use.mli 76 | 77 | Run the api-watcher on the two cmi files 78 | 79 | $ api-diff ref.cmi change_type_var_use.cmi 80 | diff module Change_type_var_use: 81 | type ('a, 'b) t = 82 | - { a : 'a; b : 'b; } 83 | + { a : 'b; b : 'a; } 84 | 85 | [1] 86 | 87 | # Swapping the order of type variables in a type declaration: 88 | 89 | $ cat > swap_type_vars.mli << EOF 90 | > type ('b, 'a) t = { a : 'a; b : 'b } 91 | > EOF 92 | 93 | We generate the .cmi file 94 | 95 | $ ocamlc swap_type_vars.mli 96 | 97 | Run the api-watcher on the two cmi files 98 | 99 | $ api-diff ref.cmi swap_type_vars.cmi 100 | diff module Swap_type_vars: 101 | type ('t1, 't2) t = 102 | - { a : 't1; b : 't2; } 103 | + { a : 't2; b : 't1; } 104 | 105 | [1] 106 | 107 | Here we generate `.mli` files with two paramterized types: 108 | 109 | $ cat > ref2.mli << EOF 110 | > type 'a t = A of 'a 111 | > type ('a, 'b) s = { a : 'a; b : 'b } 112 | > EOF 113 | 114 | We generate the .cmi file 115 | 116 | $ ocamlc ref2.mli 117 | 118 | # Adding a type variable to the first type and removing a one from the second: 119 | 120 | $ cat > add_remove.mli << EOF 121 | > type ('x, 'y) t = A of 'x * 'y 122 | > type 'm s = { a : 'm; b : int } 123 | > EOF 124 | 125 | We generate the .cmi file 126 | 127 | $ ocamlc add_remove.mli 128 | 129 | Run the api-watcher on the two cmi files 130 | 131 | $ api-diff ref2.cmi add_remove.cmi 132 | diff module Add_remove: 133 | -type ('t1, 't2) s = 134 | +type ('t1) s = 135 | - { a : 't1; b : 't2; } 136 | + { a : 't1; b : int; } 137 | -type ('t1) t = 138 | +type ('t1, 't2) t = 139 | - | A of 't1 140 | + | A of 't1 * 't2 141 | 142 | [1] 143 | 144 | Here we generate a `.mli` file with an arrow paramterized type: 145 | 146 | $ cat > ref_arrow.mli << EOF 147 | > type 'a t = 'a -> 'a 148 | > EOF 149 | 150 | We generate the .cmi file 151 | 152 | $ ocamlc ref_arrow.mli 153 | 154 | # Renaming a type variable consistently across the type declaration: 155 | 156 | $ cat > rename_arrow.mli << EOF 157 | > type 'b t = 'b -> 'b 158 | > EOF 159 | 160 | We generate the .cmi file 161 | 162 | $ ocamlc rename_arrow.mli 163 | 164 | Run the api-watcher on the two cmi files, there should be no diff 165 | 166 | $ api-diff ref_arrow.cmi rename_arrow.cmi 167 | 168 | -------------------------------------------------------------------------------- /tests/api-diff/project_comparison.t: -------------------------------------------------------------------------------- 1 | # Test for wrapped libraries 2 | 3 | Create the first version of a simple project 4 | $ mkdir -p project_v1/lib 5 | 6 | $ cat > project_v1/dune-project < (lang dune 2.9) 8 | > (name myproject) 9 | > EOF 10 | 11 | $ cat > project_v1/lib/dune < (library 13 | > (name mylib)) 14 | > EOF 15 | 16 | Create math.ml file with basic math functions and an Advanced module 17 | $ cat > project_v1/lib/math.ml < let add x y = x + y 19 | > let subtract x y = x - y 20 | > module Advanced = struct 21 | > let square x = x * x 22 | > type shape = Square | Circle 23 | > end 24 | > EOF 25 | 26 | Create math.mli interface file 27 | $ cat > project_v1/lib/math.mli < val add : int -> int -> int 29 | > val subtract : int -> int -> int 30 | > module Advanced : sig 31 | > val square : int -> int 32 | > type shape = Square | Circle 33 | > end 34 | > EOF 35 | 36 | Create utils.ml file with a double function 37 | $ cat > project_v1/lib/utils.ml < let double x = x * 2 39 | > EOF 40 | 41 | Create utils.mli interface file 42 | $ cat > project_v1/lib/utils.mli < val double : int -> int 44 | > EOF 45 | 46 | Build the first version 47 | $ cd project_v1 && dune build && cd .. 48 | 49 | Create the second version of the same project with some changes 50 | $ cp -r project_v1 project_v2 51 | 52 | Update math.ml in project_v2 with new functions and modifications 53 | $ cat > project_v2/lib/math.ml < let add x y z = x + y + z 55 | > let subtract x y = x - y 56 | > let multiply x y = x * y 57 | > module Advanced = struct 58 | > let square x = x * x 59 | > let cube x = x * x * x 60 | > type shape = Square | Circle | Triangle 61 | > end 62 | > module New_module = struct 63 | > let hello () = "Hello, World!" 64 | > end 65 | > EOF 66 | 67 | Update math.mli in project_v2 to reflect changes 68 | $ cat > project_v2/lib/math.mli < val add : int -> int -> int -> int 70 | > val subtract : int -> int -> int 71 | > val multiply : int -> int -> int 72 | > module Advanced : sig 73 | > val square : int -> int 74 | > val cube : int -> int 75 | > type shape = Square | Circle | Triangle 76 | > end 77 | > module New_module : sig 78 | > val hello : unit -> string 79 | > end 80 | > EOF 81 | 82 | Update utils.ml in project_v2 with a new triple function 83 | $ cat > project_v2/lib/utils.ml < let double x = x * 2 85 | > let triple x = x * 3 86 | > EOF 87 | 88 | Update utils.mli in project_v2 to include the new triple function 89 | $ cat > project_v2/lib/utils.mli < val double : int -> int 91 | > val triple : int -> int 92 | > EOF 93 | 94 | Build the second version 95 | $ cd project_v2 && dune build && cd .. 96 | 97 | Run the api-diff tool on the two project versions 98 | $ api-diff --main-module mylib project_v1/_build/default/lib/.mylib.objs/byte project_v2/_build/default/lib/.mylib.objs/byte 99 | diff module Mylib.Math: 100 | -val add : int -> int -> int 101 | +val add : int -> int -> int -> int 102 | +val multiply : int -> int -> int 103 | +module New_module: sig val hello : unit -> string end 104 | 105 | diff module Mylib.Math.Advanced: 106 | +val cube : int -> int 107 | type shape = 108 | | Circle 109 | | Square 110 | + | Triangle 111 | 112 | diff module Mylib.Utils: 113 | +val triple : int -> int 114 | 115 | [1] 116 | 117 | 118 | # Test for unwrapped libraries 119 | 120 | Create the first version of a simple project 121 | $ mkdir -p proj_v1/lib 122 | 123 | $ cat > proj_v1/dune-project < (lang dune 2.9) 125 | > (name myproject) 126 | > EOF 127 | 128 | $ cat > proj_v1/lib/dune < (library 130 | > (name mylib) 131 | > (wrapped false)) 132 | > EOF 133 | 134 | Create math.ml file with basic math functions and an Advanced module 135 | $ cat > proj_v1/lib/math.ml < let add x y = x + y 137 | > let subtract x y = x - y 138 | > module Advanced = struct 139 | > let square x = x * x 140 | > type shape = Square | Circle 141 | > end 142 | > EOF 143 | 144 | Create math.mli interface file 145 | $ cat > proj_v1/lib/math.mli < val add : int -> int -> int 147 | > val subtract : int -> int -> int 148 | > module Advanced : sig 149 | > val square : int -> int 150 | > type shape = Square | Circle 151 | > end 152 | > EOF 153 | 154 | Create utils.ml file with a double function 155 | $ cat > proj_v1/lib/utils.ml < let double x = x * 2 157 | > EOF 158 | 159 | Create utils.mli interface file 160 | $ cat > proj_v1/lib/utils.mli < val double : int -> int 162 | > EOF 163 | 164 | Build the first version 165 | $ cd proj_v1 && dune build && cd .. 166 | 167 | Create the second version of the same project with some changes 168 | $ cp -r proj_v1 proj_v2 169 | 170 | Update math.ml in proj_v2 with new functions and modifications 171 | $ cat > proj_v2/lib/math.ml < let add x y z = x + y + z 173 | > let subtract x y = x - y 174 | > let multiply x y = x * y 175 | > module Advanced = struct 176 | > let square x = x * x 177 | > let cube x = x * x * x 178 | > type shape = Square | Circle | Triangle 179 | > end 180 | > module New_module = struct 181 | > let hello () = "Hello, World!" 182 | > end 183 | > EOF 184 | 185 | Update math.mli in proj_v2 to reflect changes 186 | $ cat > proj_v2/lib/math.mli < val add : int -> int -> int -> int 188 | > val subtract : int -> int -> int 189 | > val multiply : int -> int -> int 190 | > module Advanced : sig 191 | > val square : int -> int 192 | > val cube : int -> int 193 | > type shape = Square | Circle | Triangle 194 | > end 195 | > module New_module : sig 196 | > val hello : unit -> string 197 | > end 198 | > EOF 199 | 200 | Update utils.ml in proj_v2 with a new triple function 201 | $ cat > proj_v2/lib/utils.ml < let double x = x * 2 203 | > let triple x = x * 3 204 | > EOF 205 | 206 | Update utils.mli in proj_v2 to include the new triple function 207 | $ cat > proj_v2/lib/utils.mli < val double : int -> int 209 | > val triple : int -> int 210 | > EOF 211 | 212 | Build the second version 213 | $ cd proj_v2 && dune build && cd .. 214 | 215 | Run the api-diff tool on the two project versions 216 | $ api-diff --unwrapped proj_v1/_build/default/lib/.mylib.objs/byte proj_v2/_build/default/lib/.mylib.objs/byte 217 | diff module Math: 218 | -val add : int -> int -> int 219 | +val add : int -> int -> int -> int 220 | +val multiply : int -> int -> int 221 | +module New_module: sig val hello : unit -> string end 222 | 223 | diff module Math.Advanced: 224 | +val cube : int -> int 225 | type shape = 226 | | Circle 227 | | Square 228 | + | Triangle 229 | 230 | diff module Utils: 231 | +val triple : int -> int 232 | 233 | [1] 234 | -------------------------------------------------------------------------------- /tests/api-diff/record_type_tests.t: -------------------------------------------------------------------------------- 1 | Here we generate a `.mli` file with a record type: 2 | 3 | $ cat > ref.mli << EOF 4 | > type student = { first_name: string; last_name: string; id: int option } 5 | > EOF 6 | 7 | We generate the .cmi file 8 | 9 | $ ocamlc ref.mli 10 | 11 | # Tests for different kind of modifications to a record type: 12 | 13 | ### Adding a field to a record type: 14 | 15 | $ cat > add_field.mli << EOF 16 | > type student = { first_name: string; last_name: string; id: int option; level: int } 17 | > EOF 18 | 19 | We generate the .cmi file 20 | 21 | $ ocamlc add_field.mli 22 | 23 | Run the api-watcher on the two cmi files 24 | 25 | $ api-diff ref.cmi add_field.cmi 26 | diff module Add_field: 27 | type student = 28 | - { first_name : string; id : int option; last_name : string; } 29 | + { first_name : string; id : int option; last_name : string; level : int; } 30 | 31 | [1] 32 | 33 | ### Removing a field from a record type: 34 | 35 | $ cat > remove_field.mli << EOF 36 | > type student = { first_name: string; last_name: string } 37 | > EOF 38 | 39 | We generate the .cmi file 40 | 41 | $ ocamlc remove_field.mli 42 | 43 | Run the api-watcher on the two cmi files 44 | 45 | $ api-diff ref.cmi remove_field.cmi 46 | diff module Remove_field: 47 | type student = 48 | - { first_name : string; last_name : string; id : int option; } 49 | + { first_name : string; last_name : string; } 50 | 51 | [1] 52 | 53 | ### Modifying a field type in a record type: 54 | 55 | $ cat > modify_field_type.mli << EOF 56 | > type student = { first_name: string; last_name: string; id: int } 57 | > EOF 58 | 59 | We generate the .cmi file 60 | 61 | $ ocamlc modify_field_type.mli << EOF 62 | 63 | Run api-watcher on the two cmi files 64 | 65 | $ api-diff ref.cmi modify_field_type.cmi 66 | diff module Modify_field_type: 67 | type student = 68 | - { first_name : string; last_name : string; id : int option; } 69 | + { first_name : string; last_name : string; id : int; } 70 | 71 | [1] 72 | 73 | ### Modifying a field type in a record type to a same alias type: 74 | 75 | $ cat > alias_field_type.mli << EOF 76 | > type y = int option 77 | > type student = { first_name: string; last_name: string; id: y } 78 | > EOF 79 | 80 | We generate the .cmi file 81 | 82 | $ ocamlc alias_field_type.mli << EOF 83 | 84 | Run api-watcher on the two cmi files 85 | 86 | $ api-diff --word-diff -- ref.cmi alias_field_type.cmi 87 | diff module Alias_field_type: 88 | +type y = int option 89 | 90 | [1] 91 | 92 | -------------------------------------------------------------------------------- /tests/api-diff/stack_overflow.t: -------------------------------------------------------------------------------- 1 | Here we generate a basic `.mli` file with two types and a function: 2 | Referencing a paramterized type should not cause a stackoverflow 3 | 4 | $ cat > ref.mli << EOF 5 | > type 'a t 6 | > val f : unit -> 'a t 7 | > EOF 8 | 9 | We generate the .cmi file 10 | 11 | $ ocamlc ref.mli 12 | 13 | and the current, unmodified version: 14 | 15 | $ cat > curr.mli << EOF 16 | > type 'a t 17 | > val f : unit -> 'a t 18 | > EOF 19 | 20 | We generate the .cmi file 21 | 22 | $ ocamlc curr.mli 23 | Run api-watcher on the two cmi files 24 | 25 | $ api-diff ref.cmi curr.cmi 26 | -------------------------------------------------------------------------------- /tests/api-diff/stdlib.t: -------------------------------------------------------------------------------- 1 | Here we generate a `.mli` file with a type alias referencing a standard library type 2 | 3 | $ cat > ref.mli << EOF 4 | > type t = String.t 5 | > EOF 6 | 7 | We generate the .cmi file 8 | 9 | $ ocamlc ref.mli 10 | 11 | # A type that references the same type in the standard library 12 | 13 | $ cat > cur.mli << EOF 14 | > type t = string 15 | > EOF 16 | 17 | We generate the .cmi file 18 | 19 | $ ocamlc cur.mli 20 | 21 | Run the api-watcher on the two cmi files, there should be no diff 22 | 23 | $ api-diff ref.cmi cur.cmi 24 | -------------------------------------------------------------------------------- /tests/api-diff/type_expansion.t: -------------------------------------------------------------------------------- 1 | Here we generate a file for testing the expansion of alias types 2 | 3 | # A `.mli` file with an alias type 4 | 5 | $ cat > ref_alias.mli << EOF 6 | > type t = int 7 | > type u = t 8 | > EOF 9 | 10 | We generate the .cmi file 11 | 12 | $ ocamlc ref_alias.mli 13 | 14 | ### Changing the alias type 15 | 16 | $ cat > cur_alias.mli << EOF 17 | > type t = float 18 | > type u = t 19 | > EOF 20 | 21 | We generate the .cmi file 22 | 23 | $ ocamlc cur_alias.mli 24 | 25 | Run the api-watcher on the two cmi files, type u should expand 26 | 27 | $ api-diff ref_alias.cmi cur_alias.cmi 28 | diff module Cur_alias: 29 | -type t = int 30 | +type t = float 31 | -type u = int 32 | +type u = float 33 | 34 | [1] 35 | 36 | Here we generate a file for testing the unexpanding of concrete types 37 | 38 | # A `.mli` file with a record type 39 | 40 | $ cat > ref_record.mli << EOF 41 | > type t = { a : int } 42 | > type u = t 43 | > EOF 44 | 45 | We generate the .cmi file 46 | 47 | $ ocamlc ref_record.mli 48 | 49 | ### Changing the record type 50 | 51 | $ cat > cur_record.mli << EOF 52 | > type t = { a : float } 53 | > type u = t 54 | > EOF 55 | 56 | We generate the .cmi file 57 | 58 | $ ocamlc cur_record.mli 59 | 60 | Run the api-watcher on the two cmi files, type u should not expand 61 | 62 | $ api-diff ref_record.cmi cur_record.cmi 63 | diff module Cur_record: 64 | type t = 65 | - { a : int; } 66 | + { a : float; } 67 | 68 | [1] 69 | -------------------------------------------------------------------------------- /tests/api-diff/type_kind_tests.t: -------------------------------------------------------------------------------- 1 | Here we generate files for testing the changes in the type kinds 2 | 3 | # A `.mli` file with a record type 4 | 5 | $ cat > ref_record_kind.mli << EOF 6 | > type t = { a: int; b: float } 7 | > EOF 8 | 9 | We generate the .cmi file 10 | 11 | $ ocamlc ref_record_kind.mli 12 | 13 | ### A `.mli` file with a variant type: 14 | 15 | $ cat > ref_variant_kind.mli << EOF 16 | > type t = A of int | B of string 17 | > EOF 18 | 19 | We generate the .cmi file 20 | 21 | $ ocamlc ref_variant_kind.mli 22 | 23 | ### A `.mli` file with an abstract type: 24 | 25 | $ cat > ref_abstract_kind.mli << EOF 26 | > type t 27 | > EOF 28 | 29 | We generate the .cmi file 30 | 31 | $ ocamlc ref_abstract_kind.mli 32 | 33 | ### A `.mli` file with an open type: 34 | 35 | $ cat > ref_open_kind.mli << EOF 36 | > type t = .. 37 | > EOF 38 | 39 | We generate the .cmi file 40 | 41 | $ ocamlc ref_open_kind.mli 42 | 43 | Run the api-watcher on record and varient type kinds cmi files 44 | 45 | $ api-diff ref_record_kind.cmi ref_variant_kind.cmi 46 | diff module Ref_variant_kind: 47 | type t = 48 | - { a : int; b : float; } 49 | + | A of int 50 | + | B of string 51 | 52 | [1] 53 | 54 | Run the api-watcher on record and abstract type kinds cmi files 55 | 56 | $ api-diff ref_record_kind.cmi ref_abstract_kind.cmi 57 | diff module Ref_abstract_kind: 58 | -type t = 59 | +type t 60 | - { a : int; b : float; } 61 | 62 | [1] 63 | 64 | Run the api-watcher on record and open type kinds cmi files 65 | 66 | $ api-diff ref_record_kind.cmi ref_open_kind.cmi 67 | diff module Ref_open_kind: 68 | type t = 69 | - { a : int; b : float; } 70 | + .. 71 | 72 | [1] 73 | 74 | Run the api-watcher on two abstract type kinds cmi files 75 | 76 | $ api-diff ref_abstract_kind.cmi ref_abstract_kind.cmi 77 | 78 | Run the api-watcher on two open type kinds cmi files 79 | 80 | $ api-diff ref_open_kind.cmi ref_open_kind.cmi 81 | 82 | Here we generate a `.mli` file with a recursive type 83 | 84 | $ cat > recursive.mli << EOF 85 | > type 'a lst = Nil | Cons of 'a * 'a lst 86 | > EOF 87 | 88 | We generate the .cmi file 89 | 90 | $ ocamlc recursive.mli 91 | 92 | # Adding another item to the Cons constructor 93 | 94 | $ cat > add_item.mli << EOF 95 | > type 'a lst = Nil | Cons of 'a * 'a * 'a lst 96 | > EOF 97 | 98 | We generate the .cmi file 99 | 100 | $ ocamlc add_item.mli 101 | 102 | Run the api-watcher on the two cmi files 103 | 104 | $ api-diff recursive.cmi add_item.cmi 105 | diff module Add_item: 106 | type 'a lst = 107 | | Nil 108 | - | Cons of 'a * 'a lst 109 | + | Cons of 'a * 'a * 'a lst 110 | 111 | [1] 112 | -------------------------------------------------------------------------------- /tests/api-diff/type_manifest_tests.t: -------------------------------------------------------------------------------- 1 | Here we generate a `.mli` file to test the changes in the type manifest 2 | 3 | $ cat > ref.mli << EOF 4 | > type t 5 | > EOF 6 | 7 | We generate the .cmi file 8 | 9 | $ ocamlc ref.mli 10 | 11 | ### Adding a type manifest 12 | 13 | $ cat > add_manifest.mli << EOF 14 | > type t = int list 15 | > EOF 16 | 17 | We generate the .cmi file 18 | 19 | $ ocamlc add_manifest.mli 20 | 21 | Run the api-watcher on the two cmi files 22 | 23 | $ api-diff ref.cmi add_manifest.cmi 24 | diff module Add_manifest: 25 | -type t 26 | +type t = int list 27 | 28 | [1] 29 | 30 | ### Adding a type manifest and private type abberivation 31 | 32 | $ cat > add_manifest_private.mli << EOF 33 | > type t = private int list 34 | > EOF 35 | 36 | We generate the .cmi file 37 | 38 | $ ocamlc add_manifest_private.mli 39 | 40 | Run the api-watcher on the two cmi files 41 | 42 | $ api-diff ref.cmi add_manifest_private.cmi 43 | diff module Add_manifest_private: 44 | -type t 45 | +type t = private int list 46 | 47 | [1] 48 | 49 | ### Adding a type manifest, private and a record type 50 | 51 | $ cat > add_manifest_private_record.mli << EOF 52 | > type u = { a : int } 53 | > type t = u = private { a : int } 54 | > EOF 55 | 56 | We generate the .cmi file 57 | 58 | $ ocamlc add_manifest_private_record.mli 59 | 60 | Run the api-watcher on the two cmi files 61 | 62 | $ api-diff ref.cmi add_manifest_private_record.cmi 63 | diff module Add_manifest_private_record: 64 | -type t 65 | +type t = u = private 66 | + { a : int; } 67 | +type u = { a : int; } 68 | 69 | [1] 70 | -------------------------------------------------------------------------------- /tests/api-diff/type_privacy_tests.t: -------------------------------------------------------------------------------- 1 | Here we generate a `.mli` file with a private type abbreviation 2 | 3 | $ cat > ref.mli << EOF 4 | > type t = private { a : int; b : float } 5 | > EOF 6 | 7 | We generate the .cmi file 8 | 9 | $ ocamlc ref.mli 10 | 11 | # Removing a private type abbreviation from a type declaration 12 | 13 | $ cat > remove_private.mli << EOF 14 | > type t = { a : int; b : float } 15 | > EOF 16 | 17 | We generate the .cmi file 18 | 19 | $ ocamlc remove_private.mli 20 | 21 | Run the api-watcher on the two cmi files 22 | 23 | $ api-diff ref.cmi remove_private.cmi 24 | diff module Remove_private: 25 | -type t = private 26 | +type t = 27 | { a : int; b : float; } 28 | 29 | [1] 30 | 31 | # Removing a private type abbreviation from a type declaration and modifying record fields 32 | 33 | $ cat > remove_private_modify_record.mli << EOF 34 | > type t = { a : float } 35 | > EOF 36 | 37 | We generate the .cmi file 38 | 39 | $ ocamlc remove_private_modify_record.mli 40 | 41 | Run the api-watcher on the two cmi files 42 | 43 | $ api-diff ref.cmi remove_private_modify_record.cmi 44 | diff module Remove_private_modify_record: 45 | -type t = private 46 | +type t = 47 | - { a : int; b : float; } 48 | + { a : float; } 49 | 50 | [1] 51 | -------------------------------------------------------------------------------- /tests/api-diff/type_tests.t: -------------------------------------------------------------------------------- 1 | Here we generate a basic `.mli` file with two types and a function: 2 | 3 | $ cat > ref.mli << EOF 4 | > type t = int 5 | > type unused_type = string 6 | > val f : t -> string 7 | > EOF 8 | 9 | We generate the .cmi file 10 | 11 | $ ocamlc ref.mli 12 | 13 | # Tests for different .cmi files for type modifications 14 | 15 | ### A file with an additional type: 16 | 17 | $ cat > add_type.mli < type t = int 19 | > type unused_type = string 20 | > type added_t = float 21 | > val f : t -> string 22 | > EOF 23 | 24 | We generate the .cmi file 25 | 26 | $ ocamlc add_type.mli 27 | 28 | Run api-watcher on the two cmi files, there should be a difference 29 | 30 | $ api-diff ref.cmi add_type.cmi 31 | diff module Add_type: 32 | +type added_t = float 33 | 34 | [1] 35 | 36 | ### A file with a removed type: 37 | 38 | $ cat > remove_type.mli < type t = int 40 | > val f : t -> string 41 | > EOF 42 | 43 | We generate the .cmi file 44 | 45 | $ ocamlc remove_type.mli 46 | 47 | Run api-watcher on the two cmi files, there should be a difference 48 | 49 | $ api-diff ref.cmi remove_type.cmi 50 | diff module Remove_type: 51 | -type unused_type = string 52 | 53 | [1] 54 | 55 | ### A file with a modified type: 56 | 57 | $ cat > modify_type.mli < type t = float 59 | > type unused_type = string 60 | > val f : t -> string 61 | > EOF 62 | 63 | We generate a .cmi file 64 | 65 | $ ocamlc modify_type.mli 66 | 67 | Run api-watcher on the two cmi files, there should be a difference 68 | 69 | $ api-diff ref.cmi modify_type.cmi 70 | diff module Modify_type: 71 | -val f : int -> string 72 | +val f : float -> string 73 | -type t = int 74 | +type t = float 75 | 76 | [1] 77 | -------------------------------------------------------------------------------- /tests/api-diff/value_tests.t: -------------------------------------------------------------------------------- 1 | Here we generate a basic `.mli` file with two types and a function: 2 | 3 | $ cat > ref.mli << EOF 4 | > type t = int 5 | > type unused_type = string 6 | > val f : t -> string 7 | > EOF 8 | 9 | We generate the .cmi file 10 | 11 | $ ocamlc ref.mli 12 | 13 | ## Different .cmi files for value tests: 14 | 15 | ### Adding a value: 16 | 17 | Generate a new .mli file with an additional value 18 | $ cat > add_value.mli << EOF 19 | > type t = int 20 | > type unused_type = string 21 | > val f : t -> string 22 | > val g : t -> t 23 | > EOF 24 | 25 | Compile the new .mli file to a .cmi file 26 | $ ocamlc add_value.mli 27 | 28 | Run api-diff and check the output 29 | $ api-diff ref.cmi add_value.cmi 30 | diff module Add_value: 31 | +val g : t -> t 32 | 33 | [1] 34 | 35 | ### Removing a value: 36 | 37 | Generate a new .mli file with the value removed 38 | $ cat > remove_value.mli << EOF 39 | > type t = int 40 | > type unused_type = string 41 | > EOF 42 | 43 | Compile the new .mli file to a .cmi file 44 | $ ocamlc remove_value.mli 45 | 46 | Run api-diff and check the output 47 | $ api-diff ref.cmi remove_value.cmi 48 | diff module Remove_value: 49 | -val f : t -> string 50 | 51 | [1] 52 | 53 | ### Modifying a value: 54 | 55 | Generate a new .mli file with the value modified 56 | $ cat > modify_value.mli << EOF 57 | > type t = int 58 | > type unused_type = string 59 | > val f : t -> t 60 | > EOF 61 | 62 | Compile the new .mli file to a .cmi file 63 | $ ocamlc modify_value.mli 64 | 65 | Run api-diff and check the output 66 | $ api-diff ref.cmi modify_value.cmi 67 | diff module Modify_value: 68 | -val f : t -> string 69 | +val f : t -> int 70 | 71 | [1] 72 | 73 | ### Value referencing an abstract type 74 | 75 | api-diff should be able to tell two, non alias types from both versions of the 76 | API should be considered equal when referenced by a value. 77 | 78 | Generate a reference .mli file: 79 | $ cat > value_with_abstract_type_ref.mli << EOF 80 | > type t = { a : int } 81 | > val x : t 82 | > EOF 83 | 84 | and the current .mli file, (identical): 85 | $ cat > value_with_abstract_type_cur.mli << EOF 86 | > type t = { a : float } 87 | > val x : t 88 | > EOF 89 | 90 | Let's compile both interfaces: 91 | $ ocamlc value_with_abstract_type_ref.mli 92 | $ ocamlc value_with_abstract_type_cur.mli 93 | 94 | and run the tool, it should report no diff: 95 | $ api-diff value_with_abstract_type_ref.cmi value_with_abstract_type_cur.cmi 96 | diff module Value_with_abstract_type_cur: 97 | type t = 98 | - { a : int; } 99 | + { a : float; } 100 | 101 | [1] 102 | -------------------------------------------------------------------------------- /tests/api-diff/word_based_diff_tests.t: -------------------------------------------------------------------------------- 1 | Here we generate a `.mli` file with some types: 2 | 3 | $ cat > ref.mli << EOF 4 | > type t = int 5 | > type ('a, 'b, 'c) u = { mutable a : 'a; b : 'b; c : 'c } 6 | > type v = A of int * int | B of { a : int; b : float } 7 | > type 'a p = 'a * 'a 8 | > EOF 9 | 10 | We generate the .cmi file 11 | 12 | $ ocamlc ref.mli 13 | 14 | Changing the types in the ref.mli 15 | 16 | $ cat > cur.mli << EOF 17 | > type t 18 | > type ('a) u = { a : 'a; b : int; } 19 | > type v = A of { a : int; b : int } | B of { a : int; b : string } 20 | > type p = int * int 21 | > EOF 22 | 23 | We generate the .cmi file 24 | 25 | $ ocamlc cur.mli 26 | 27 | Run api-watcher on the two cmi file with word-level diffing flag enabled 28 | 29 | $ api-diff --word-diff ref.cmi cur.cmi 30 | diff module Cur: 31 | type 'a p = 'aint * 'aint 32 | type t = int 33 | type ('a, 'b, 'c) u = 34 | { mutable a : 'a; b : 'bint; c : 'c; } 35 | type v = 36 | | A of int * int{ a : int; b : int; } 37 | | B of { a : int; b : floatstring; } 38 | 39 | [1] 40 | 41 | Run api-watcher on the two cmi file with plain and word-level diffing flags enabled 42 | 43 | $ api-diff --word-diff --plain ref.cmi cur.cmi 44 | diff module Cur: 45 | type [-'a-] p = [-'a-]{+int+} * [-'a-]{+int+} 46 | type t[- =-][- int-] 47 | type ('a[-, 'b-][-, 'c-]) u = 48 | {[- mutable-] a : 'a; b : [-'b-]{+int+};[- c : 'c;-] } 49 | type v = 50 | | A of [-int * int-]{+{ a : int; b : int; }+} 51 | | B of { a : int; b : [-float-]{+string+}; } 52 | 53 | [1] 54 | -------------------------------------------------------------------------------- /tests/api-watch/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test) 3 | (inline_tests) 4 | (preprocess 5 | (pps ppx_expect)) 6 | (libraries api-watch test_helpers)) 7 | -------------------------------------------------------------------------------- /tests/api-watch/stdlib.ml: -------------------------------------------------------------------------------- 1 | open Api_watch 2 | open Test_helpers 3 | 4 | let%expect_test "Identical types" = 5 | let reference = compile_interface {| type t = String.t |} in 6 | let current = compile_interface {| type t = string |} in 7 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 8 | Format.printf "%a" pp_diff_option result; 9 | [%expect {| None |}] 10 | -------------------------------------------------------------------------------- /tests/api-watch/test_diff.ml: -------------------------------------------------------------------------------- 1 | open Api_watch 2 | open Test_helpers 3 | 4 | let%expect_test "test_diff_interface" = 5 | let result = Diff.interface ~module_name:"Main" ~reference:[] ~current:[] in 6 | Format.printf "%a" pp_diff_option result; 7 | [%expect {| None |}] 8 | 9 | let%expect_test "Simple value, identical" = 10 | let reference = compile_interface {|val x : int|} in 11 | let current = compile_interface {|val x : int|} in 12 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 13 | Format.printf "%a" pp_diff_option result; 14 | [%expect {| None |}] 15 | 16 | let%expect_test "Simple value, modified" = 17 | let reference = compile_interface {|val x : int|} in 18 | let current = compile_interface {|val x : string|} in 19 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 20 | Format.printf "%a" pp_diff_option result; 21 | [%expect 22 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 23 | 24 | let ref_signature = 25 | compile_interface 26 | {| 27 | type t = int 28 | type unused_type = string 29 | val f : t -> string 30 | |} 31 | 32 | let%expect_test "Same signature" = 33 | let result = 34 | Diff.interface ~module_name:"Main" ~reference:ref_signature 35 | ~current:ref_signature 36 | in 37 | Format.printf "%a" pp_diff_option result; 38 | [%expect {| None |}] 39 | 40 | let add_value_signature = 41 | compile_interface 42 | {| 43 | type t = int 44 | type unused_type = string 45 | val f : t -> string 46 | val g : t -> t 47 | |} 48 | 49 | let%expect_test "Adding a value" = 50 | let result = 51 | Diff.interface ~module_name:"Main" ~reference:ref_signature 52 | ~current:add_value_signature 53 | in 54 | Format.printf "%a" pp_diff_option result; 55 | [%expect {|Some (Module Main: {Modified (Supported [ Value (g, Added)])})|}] 56 | 57 | let remove_value_signature = 58 | compile_interface {| 59 | type t = int 60 | type unused_type = string 61 | |} 62 | 63 | let%expect_test "Removing a value" = 64 | let result = 65 | Diff.interface ~module_name:"Main" ~reference:ref_signature 66 | ~current:remove_value_signature 67 | in 68 | Format.printf "%a" pp_diff_option result; 69 | [%expect {|Some (Module Main: {Modified (Supported [ Value (f, Removed)])})|}] 70 | 71 | let modify_value_signature = 72 | compile_interface 73 | {| 74 | type t = int 75 | type unused_type = string 76 | val f : t -> t 77 | |} 78 | 79 | let%expect_test "Modifying a value" = 80 | let result = 81 | Diff.interface ~module_name:"Main" ~reference:ref_signature 82 | ~current:modify_value_signature 83 | in 84 | Format.printf "%a" pp_diff_option result; 85 | [%expect 86 | {|Some (Module Main: {Modified (Supported [ Value (f, Modified)])})|}] 87 | 88 | let add_type_signature = 89 | compile_interface 90 | {| 91 | type t = int 92 | type unused_type = string 93 | type added_t = float 94 | val f : t -> string 95 | |} 96 | 97 | let%expect_test "Adding a type" = 98 | let result = 99 | Diff.interface ~module_name:"Main" ~reference:ref_signature 100 | ~current:add_type_signature 101 | in 102 | Format.printf "%a" pp_diff_option result; 103 | [%expect 104 | {|Some (Module Main: {Modified (Supported [ Type (added_t, Added)])})|}] 105 | 106 | let remove_type_signature = 107 | compile_interface {| 108 | type t = int 109 | val f : t -> string 110 | |} 111 | 112 | let%expect_test "Removing a type" = 113 | let result = 114 | Diff.interface ~module_name:"Main" ~reference:ref_signature 115 | ~current:remove_type_signature 116 | in 117 | Format.printf "%a" pp_diff_option result; 118 | [%expect 119 | {|Some (Module Main: {Modified (Supported [ Type (unused_type, Removed)])})|}] 120 | 121 | let%expect_test "Modifying a simple type" = 122 | let reference = compile_interface {|type t = int|} in 123 | let current = compile_interface {|type t = string|} in 124 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 125 | Format.printf "%a" pp_diff_option result; 126 | [%expect 127 | {| Some (Module Main: {Modified (Supported [ Type (t, Modified)])}) |}] 128 | 129 | let%expect_test "Modifying a type used in a value" = 130 | let reference = 131 | compile_interface {| 132 | type t = int 133 | val f : t -> string 134 | |} 135 | in 136 | let current = 137 | compile_interface {| 138 | type t = float 139 | val f : t -> string 140 | |} 141 | in 142 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 143 | Format.printf "%a" pp_diff_option result; 144 | [%expect 145 | {| 146 | Some (Module Main: {Modified (Supported [ Value (f, Modified); 147 | Type (t, Modified)])}) 148 | |}] 149 | 150 | let ref_module_signature = 151 | compile_interface {| 152 | module M : sig val x : int end 153 | |} 154 | 155 | let%expect_test "Same module" = 156 | let result = 157 | Diff.interface ~module_name:"Main" ~reference:ref_module_signature 158 | ~current:ref_module_signature 159 | in 160 | Format.printf "%a" pp_diff_option result; 161 | [%expect {| None |}] 162 | 163 | let add_module_signature = 164 | compile_interface 165 | {| 166 | module M : sig val x : int end 167 | module N : sig val y : float end 168 | |} 169 | 170 | let%expect_test "Adding a module" = 171 | let result = 172 | Diff.interface ~module_name:"Main" ~reference:ref_module_signature 173 | ~current:add_module_signature 174 | in 175 | Format.printf "%a" pp_diff_option result; 176 | [%expect {|Some (Module Main: {Modified (Supported [ Module N: Added])})|}] 177 | 178 | let remove_module_signature = compile_interface {| 179 | 180 | |} 181 | 182 | let%expect_test "Removing a module" = 183 | let result = 184 | Diff.interface ~module_name:"Main" ~reference:ref_module_signature 185 | ~current:remove_module_signature 186 | in 187 | Format.printf "%a" pp_diff_option result; 188 | [%expect {|Some (Module Main: {Modified (Supported [ Module M: Removed])})|}] 189 | 190 | let modify_module_signature = 191 | compile_interface {| 192 | module M : sig val x : float end 193 | |} 194 | 195 | let%expect_test "Modifying a module" = 196 | let result = 197 | Diff.interface ~module_name:"Main" ~reference:ref_module_signature 198 | ~current:modify_module_signature 199 | in 200 | Format.printf "%a" pp_diff_option result; 201 | [%expect 202 | {|Some (Module Main: {Modified (Supported [ Module M: {Modified (Supported [ Value (x, Modified)])}])})|}] 203 | 204 | let%expect_test "One value more general than the other" = 205 | let general = compile_interface {|val x : 'a list|} in 206 | let specialized = compile_interface {|val x : float list|} in 207 | let result = 208 | Diff.interface ~module_name:"Main" ~reference:general ~current:specialized 209 | in 210 | Format.printf "%a" pp_diff_option result; 211 | [%expect 212 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}]; 213 | let rev_result = 214 | Diff.interface ~module_name:"Main" ~reference:specialized ~current:general 215 | in 216 | Format.printf "%a" pp_diff_option rev_result; 217 | [%expect 218 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 219 | 220 | let%expect_test "Same abstract type" = 221 | let reference = compile_interface {| 222 | type t 223 | val x : t 224 | |} in 225 | let current = compile_interface {| 226 | type t 227 | val x : t 228 | |} in 229 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 230 | Format.printf "%a" pp_diff_option result; 231 | [%expect {| None |}] 232 | 233 | let%expect_test "Same record type" = 234 | let reference = 235 | compile_interface {| 236 | type t = {a:int; b:float} 237 | val x : t 238 | |} 239 | in 240 | let current = 241 | compile_interface {| 242 | type t = {a:int; b:float} 243 | val x : t 244 | |} 245 | in 246 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 247 | Format.printf "%a" pp_diff_option result; 248 | [%expect {| None |}] 249 | 250 | let%expect_test "Adding a record field" = 251 | let reference = 252 | compile_interface {| 253 | type t = {a:int; b:float} 254 | val x : t 255 | |} 256 | in 257 | let current = 258 | compile_interface 259 | {| 260 | type t = {a:int; b:float; c:bool} 261 | val x : t 262 | |} 263 | in 264 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 265 | Format.printf "%a" pp_diff_option result; 266 | [%expect 267 | {| Some (Module Main: {Modified (Supported [ Type (t, Modified)])}) |}] 268 | 269 | let%expect_test "Removing a record field" = 270 | let reference = 271 | compile_interface {| 272 | type t = {a:int; b:float} 273 | val x : t 274 | |} 275 | in 276 | let current = compile_interface {| 277 | type t = {a:int} 278 | val x : t 279 | |} in 280 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 281 | Format.printf "%a" pp_diff_option result; 282 | [%expect 283 | {| Some (Module Main: {Modified (Supported [ Type (t, Modified)])}) |}] 284 | 285 | let%expect_test "Modifying a record field" = 286 | let reference = 287 | compile_interface {| 288 | type t = {a:int; b:float} 289 | val x : t 290 | |} 291 | in 292 | let current = 293 | compile_interface {| 294 | type t = {a:int; b:string} 295 | val x : t 296 | |} 297 | in 298 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 299 | Format.printf "%a" pp_diff_option result; 300 | [%expect 301 | {| Some (Module Main: {Modified (Supported [ Type (t, Modified)])}) |}] 302 | 303 | let%expect_test "Same variant type" = 304 | let reference = 305 | compile_interface {| 306 | type t = A | B of int 307 | val x : t 308 | |} 309 | in 310 | let current = 311 | compile_interface {| 312 | type t = A | B of int 313 | val x : t 314 | |} 315 | in 316 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 317 | Format.printf "%a" pp_diff_option result; 318 | [%expect {| None |}] 319 | 320 | let%expect_test "Adding a variant" = 321 | let reference = 322 | compile_interface {| 323 | type t = A | B of int 324 | val x : t 325 | |} 326 | in 327 | let current = 328 | compile_interface {| 329 | type t = A | B of int | C 330 | val x : t 331 | |} 332 | in 333 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 334 | Format.printf "%a" pp_diff_option result; 335 | [%expect 336 | {| Some (Module Main: {Modified (Supported [ Type (t, Modified)])}) |}] 337 | 338 | let%expect_test "Removing a variant" = 339 | let reference = 340 | compile_interface {| 341 | type t = A | B of int 342 | val x : t 343 | |} 344 | in 345 | let current = compile_interface {| 346 | type t = A 347 | val x : t 348 | |} in 349 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 350 | Format.printf "%a" pp_diff_option result; 351 | [%expect 352 | {| Some (Module Main: {Modified (Supported [ Type (t, Modified)])}) |}] 353 | 354 | let%expect_test "Modifying a variant type" = 355 | let reference = 356 | compile_interface {| 357 | type t = A | B of int 358 | val x : t 359 | |} 360 | in 361 | let current = 362 | compile_interface {| 363 | type t = A | B of float 364 | val x : t 365 | |} 366 | in 367 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 368 | Format.printf "%a" pp_diff_option result; 369 | [%expect 370 | {| Some (Module Main: {Modified (Supported [ Type (t, Modified)])}) |}] 371 | 372 | let%expect_test "Inlined polymorphic variant, identical" = 373 | let reference = compile_interface {|val x : [ `A | `B ]|} in 374 | let current = compile_interface {|val x : [ `A | `B ]|} in 375 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 376 | Format.printf "%a" pp_diff_option result; 377 | [%expect {| None |}] 378 | 379 | let%expect_test "Inlined polymorphic variant, modified" = 380 | let reference = compile_interface {|val x : [ `A | `B ]|} in 381 | let current = compile_interface {|val x : [ `A | `C ]|} in 382 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 383 | Format.printf "%a" pp_diff_option result; 384 | [%expect 385 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 386 | 387 | let%expect_test "Inlined polymorphic variant, extended" = 388 | let reference = compile_interface {|val x : [ `A | `B ]|} in 389 | let current = compile_interface {|val x : [ `A | `B | `C ]|} in 390 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 391 | Format.printf "%a" pp_diff_option result; 392 | [%expect 393 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 394 | 395 | let%expect_test "Inlined polymorphic variant, reduced" = 396 | let reference = compile_interface {|val x : [ `A | `B ]|} in 397 | let current = compile_interface {|val x : [ `A ]|} in 398 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 399 | Format.printf "%a" pp_diff_option result; 400 | [%expect 401 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 402 | 403 | let%expect_test "Named polymorphic variant, identical" = 404 | let reference = 405 | compile_interface {| 406 | type t = [ `A | `B ] 407 | val x : t 408 | |} 409 | in 410 | let current = 411 | compile_interface {| 412 | type t = [ `A | `B ] 413 | val x : t 414 | |} 415 | in 416 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 417 | Format.printf "%a" pp_diff_option result; 418 | [%expect {| None |}] 419 | 420 | let%expect_test "Named polymorphic variant, modified" = 421 | let reference = 422 | compile_interface {| 423 | type t = [ `A | `B ] 424 | val x : t 425 | |} 426 | in 427 | let current = 428 | compile_interface {| 429 | type t = [ `A | `C ] 430 | val x : t 431 | |} 432 | in 433 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 434 | Format.printf "%a" pp_diff_option result; 435 | [%expect 436 | {| 437 | Some (Module Main: {Modified (Supported [ Value (x, Modified); 438 | Type (t, Modified)])}) 439 | |}] 440 | 441 | let%expect_test "Named polymorphic variant, extended" = 442 | let reference = 443 | compile_interface {| 444 | type t = [ `A | `B ] 445 | val x : t 446 | |} 447 | in 448 | let current = 449 | compile_interface {| 450 | type t = [ `A | `B | `C ] 451 | val x : t 452 | |} 453 | in 454 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 455 | Format.printf "%a" pp_diff_option result; 456 | [%expect 457 | {| 458 | Some (Module Main: {Modified (Supported [ Value (x, Modified); 459 | Type (t, Modified)])}) 460 | |}] 461 | 462 | let%expect_test "Named polymorphic variant, reduced" = 463 | let reference = 464 | compile_interface {| 465 | type t = [ `A | `B ] 466 | val x : t 467 | |} 468 | in 469 | let current = compile_interface {| 470 | type t = [ `A ] 471 | val x : t 472 | |} in 473 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 474 | Format.printf "%a" pp_diff_option result; 475 | [%expect 476 | {| 477 | Some (Module Main: {Modified (Supported [ Value (x, Modified); 478 | Type (t, Modified)])}) 479 | |}] 480 | 481 | let%expect_test "Open polymorphic variant, identical" = 482 | let reference = compile_interface {|val x : [> `A | `B ]|} in 483 | let current = compile_interface {|val x : [> `A | `B ]|} in 484 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 485 | Format.printf "%a" pp_diff_option result; 486 | [%expect {| None |}] 487 | 488 | let%expect_test "Open polymorphic variant, modified" = 489 | let reference = compile_interface {|val x : [> `A | `B ]|} in 490 | let current = compile_interface {|val x : [> `A | `C ]|} in 491 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 492 | Format.printf "%a" pp_diff_option result; 493 | [%expect 494 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 495 | 496 | let%expect_test "Open polymorphic variant, extended" = 497 | let reference = compile_interface {|val x : [> `A | `B ]|} in 498 | let current = compile_interface {|val x : [> `A | `B | `C ]|} in 499 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 500 | Format.printf "%a" pp_diff_option result; 501 | [%expect 502 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 503 | 504 | let%expect_test "Open polymorphic variant, reduced" = 505 | let reference = compile_interface {|val x : [> `A | `B ]|} in 506 | let current = compile_interface {|val x : [> `A ]|} in 507 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 508 | Format.printf "%a" pp_diff_option result; 509 | [%expect 510 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 511 | 512 | let%expect_test "Less polymorphic variant, identical" = 513 | let reference = compile_interface {|val x : [< `A | `B ]|} in 514 | let current = compile_interface {|val x : [< `A | `B ]|} in 515 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 516 | Format.printf "%a" pp_diff_option result; 517 | [%expect {| None |}] 518 | 519 | let%expect_test "Less polymorphic variant, modified" = 520 | let reference = compile_interface {|val x : [< `A | `B ]|} in 521 | let current = compile_interface {|val x : [< `A | `C ]|} in 522 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 523 | Format.printf "%a" pp_diff_option result; 524 | [%expect 525 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 526 | 527 | let%expect_test "Less polymorphic variant, extended" = 528 | let reference = compile_interface {|val x : [< `A | `B ]|} in 529 | let current = compile_interface {|val x : [< `A | `B | `C ]|} in 530 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 531 | Format.printf "%a" pp_diff_option result; 532 | [%expect 533 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 534 | 535 | let%expect_test "Less polymorphic variant, reduced" = 536 | let reference = compile_interface {|val x : [< `A | `B ]|} in 537 | let current = compile_interface {|val x : [< `A ]|} in 538 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 539 | Format.printf "%a" pp_diff_option result; 540 | [%expect 541 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 542 | 543 | let%expect_test "Changing from less to more polymorphic" = 544 | let reference = compile_interface {|val x : [< `A | `B ]|} in 545 | let current = compile_interface {|val x : [> `A | `B ]|} in 546 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 547 | Format.printf "%a" pp_diff_option result; 548 | [%expect 549 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 550 | 551 | let%expect_test "Changing from more to less polymorphic" = 552 | let reference = compile_interface {|val x : [> `A | `B ]|} in 553 | let current = compile_interface {|val x : [< `A | `B ]|} in 554 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 555 | Format.printf "%a" pp_diff_option result; 556 | [%expect 557 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 558 | 559 | let%expect_test "Changing from open and more to closed polymorphic" = 560 | let reference = compile_interface {|val x : [> `A | `B ]|} in 561 | let current = compile_interface {|val x : [ `A | `B ]|} in 562 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 563 | Format.printf "%a" pp_diff_option result; 564 | [%expect 565 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 566 | 567 | let%expect_test "Changing from open and less to closed polymorphic" = 568 | let reference = compile_interface {|val x : [< `A | `B ]|} in 569 | let current = compile_interface {|val x : [ `A | `B ]|} in 570 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 571 | Format.printf "%a" pp_diff_option result; 572 | [%expect 573 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 574 | 575 | let%expect_test "Extensible variant type, identical" = 576 | let reference = 577 | compile_interface 578 | {| 579 | type t = .. 580 | type t += A | B of int 581 | val x : t 582 | |} 583 | in 584 | let current = 585 | compile_interface 586 | {| 587 | type t = .. 588 | type t += A | B of int 589 | val x : t 590 | |} 591 | in 592 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 593 | Format.printf "%a" pp_diff_option result; 594 | [%expect {| None |}] 595 | 596 | let%expect_test "Extensible variant type, extended" = 597 | let reference = 598 | compile_interface 599 | {| 600 | type t = .. 601 | type t += A | B of int 602 | val x : t 603 | |} 604 | in 605 | let current = 606 | compile_interface 607 | {| 608 | type t = .. 609 | type t += A | B of int | C 610 | val x : t 611 | |} 612 | in 613 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 614 | Format.printf "%a" pp_diff_option result; 615 | [%expect 616 | {| Some (Module Main: {Modified (Supported [ Extension_constructor (C, Added)])}) |}] 617 | 618 | let%expect_test "Extensible variant type, reduced" = 619 | let reference = 620 | compile_interface 621 | {| 622 | type t = .. 623 | type t += A | B of int 624 | val x : t 625 | |} 626 | in 627 | let current = 628 | compile_interface {| 629 | type t = .. 630 | type t += A 631 | val x : t 632 | |} 633 | in 634 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 635 | Format.printf "%a" pp_diff_option result; 636 | [%expect 637 | {| Some (Module Main: {Modified (Supported [ Extension_constructor (B, Removed)])}) |}] 638 | 639 | let%expect_test "Extensible variant type, modified" = 640 | let reference = 641 | compile_interface 642 | {| 643 | type t = .. 644 | type t += A | B of int 645 | val x : t 646 | |} 647 | in 648 | let current = 649 | compile_interface 650 | {| 651 | type t = .. 652 | type t += A | B of string 653 | val x : t 654 | |} 655 | in 656 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 657 | Format.printf "%a" pp_diff_option result; 658 | [%expect 659 | {| Some (Module Main: {Modified (Supported [ Extension_constructor (B, Modified)])}) |}] 660 | 661 | let%expect_test "Changing from abstract to record type" = 662 | let reference = compile_interface {| 663 | type t 664 | val x : t 665 | |} in 666 | let current = 667 | compile_interface {| 668 | type t = {a:string; b:int} 669 | val x : t 670 | |} 671 | in 672 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 673 | Format.printf "%a" pp_diff_option result; 674 | [%expect 675 | {| Some (Module Main: {Modified (Supported [ Type (t, Modified)])}) |}] 676 | 677 | let%expect_test "Changing from record to variant type" = 678 | let reference = 679 | compile_interface {| 680 | type t = {a:string; b:int} 681 | val x : t 682 | |} 683 | in 684 | let current = 685 | compile_interface {| 686 | type t = A of string | B of int 687 | val x : t 688 | |} 689 | in 690 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 691 | Format.printf "%a" pp_diff_option result; 692 | [%expect 693 | {| Some (Module Main: {Modified (Supported [ Type (t, Modified)])}) |}] 694 | 695 | let%expect_test "Values referencing types with parameters, identical" = 696 | let reference = 697 | compile_interface 698 | {| 699 | type ('a, 'b) result = Ok of 'a | Error of 'b 700 | val x : (int ,string) result 701 | |} 702 | in 703 | let current = 704 | compile_interface 705 | {| 706 | type ('a, 'b) result = Ok of 'a | Error of 'b 707 | val x : (int ,string) result 708 | |} 709 | in 710 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 711 | Format.printf "%a" pp_diff_option result; 712 | [%expect {| None |}] 713 | 714 | let%expect_test "Values referencing types with parameters, modified" = 715 | let reference = 716 | compile_interface 717 | {| 718 | type ('a, 'b) result = Ok of 'a | Error of 'b 719 | val x : (int ,string) result 720 | |} 721 | in 722 | let current = 723 | compile_interface 724 | {| 725 | type ('a, 'b) result = Ok of 'a | Error of 'b 726 | val x : (float ,string) result 727 | |} 728 | in 729 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 730 | Format.printf "%a" pp_diff_option result; 731 | [%expect 732 | {|Some (Module Main: {Modified (Supported [ Value (x, Modified)])})|}] 733 | -------------------------------------------------------------------------------- /tests/api-watch/test_diff_class.ml: -------------------------------------------------------------------------------- 1 | open Api_watch 2 | open Test_helpers 3 | 4 | let%expect_test "Class Addition" = 5 | let reference = 6 | {| 7 | class cls1 : object 8 | method m1 : int -> int 9 | end 10 | class cls2 : object 11 | method m2 : string -> string 12 | end 13 | |} 14 | in 15 | let current = 16 | {| 17 | class cls1 : object 18 | method m1 : int -> int 19 | end 20 | class cls2 : object 21 | method m2 : string -> string 22 | end 23 | class cls3 : object 24 | method m3 : float -> float 25 | end 26 | |} 27 | in 28 | try 29 | let ref_compiled = compile_interface reference in 30 | let curr_compiled = compile_interface current in 31 | let result = 32 | Diff.interface ~module_name:"Main" ~reference:ref_compiled 33 | ~current:curr_compiled 34 | in 35 | Format.printf "%a" pp_diff_option result; 36 | [%expect 37 | {| Some (Module Main: {Modified (Supported [ Class (cls3, Added)])}) |}] 38 | with e -> 39 | Format.printf "Error: %s" (Printexc.to_string e); 40 | [%expect.unreachable] 41 | 42 | let%expect_test "Class Removal" = 43 | let reference = 44 | {| 45 | class cls1 : object 46 | method m1 : int -> int 47 | end 48 | class cls2 : object 49 | method m2 : string -> string 50 | end 51 | |} 52 | in 53 | let current = {| 54 | class cls1 : object 55 | method m1 : int -> int 56 | end 57 | |} in 58 | try 59 | let ref_compiled = compile_interface reference in 60 | let curr_compiled = compile_interface current in 61 | let result = 62 | Diff.interface ~module_name:"Main" ~reference:ref_compiled 63 | ~current:curr_compiled 64 | in 65 | Format.printf "%a" pp_diff_option result; 66 | [%expect 67 | {| Some (Module Main: {Modified (Supported [ Class (cls2, Removed)])}) |}] 68 | with e -> 69 | Format.printf "Error: %s" (Printexc.to_string e); 70 | [%expect.unreachable] 71 | 72 | let%expect_test "Class Modification" = 73 | let reference = 74 | compile_interface 75 | {| 76 | class cls1 : object 77 | method m1: int -> int 78 | method m2: int -> char 79 | end 80 | |} 81 | in 82 | let current = 83 | compile_interface 84 | {| 85 | class cls1 : object 86 | method m2: float -> float 87 | method m3: char -> char 88 | end 89 | |} 90 | in 91 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 92 | Format.printf "%a" pp_diff_option result; 93 | [%expect 94 | {| Some (Module Main: {Modified (Supported [ Class (cls1, Modified)])}) |}] 95 | 96 | let%expect_test "Class Modification" = 97 | let reference = 98 | compile_interface 99 | {| 100 | class cls1 : object 101 | method m1: int -> int 102 | method m2: char -> int 103 | end 104 | |} 105 | in 106 | let current = 107 | compile_interface 108 | {| 109 | class cls1 : object 110 | method m1: int -> int 111 | method m2: char -> int 112 | method m3: string -> string 113 | end 114 | |} 115 | in 116 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 117 | Format.printf "%a" pp_diff_option result; 118 | [%expect 119 | {| Some (Module Main: {Modified (Supported [ Class (cls1, Modified)])}) |}] 120 | -------------------------------------------------------------------------------- /tests/api-watch/test_diff_cltype.ml: -------------------------------------------------------------------------------- 1 | open Api_watch 2 | open Test_helpers 3 | 4 | let%expect_test "Class type addition" = 5 | let reference = compile_interface {||} in 6 | let current = 7 | compile_interface 8 | {| 9 | class type cltype = 10 | object 11 | method m1 : float 12 | method m2 : int -> int 13 | end 14 | |} 15 | in 16 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 17 | Format.printf "%a" pp_diff_option result; 18 | [%expect 19 | {| Some (Module Main: {Modified (Supported [ Class_type (cltype, Added)])}) |}] 20 | 21 | let%expect_test "Class type removal" = 22 | let reference = 23 | compile_interface 24 | {| 25 | class type cltype = 26 | object 27 | method m1 : float 28 | method m2 : int -> int 29 | end 30 | |} 31 | in 32 | let current = compile_interface {||} in 33 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 34 | Format.printf "%a" pp_diff_option result; 35 | [%expect 36 | {| Some (Module Main: {Modified (Supported [ Class_type (cltype, Removed)])}) |}] 37 | 38 | let%expect_test "Class type modification" = 39 | let reference = 40 | compile_interface 41 | {| 42 | class type cltype = 43 | object 44 | method m1 : float 45 | method m2 : int -> int 46 | end 47 | |} 48 | in 49 | let current = 50 | compile_interface 51 | {| 52 | class type cltype = 53 | object 54 | method m2 : int -> float 55 | method m3 : float -> float 56 | end 57 | |} 58 | in 59 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 60 | Format.printf "%a" pp_diff_option result; 61 | [%expect 62 | {| Some (Module Main: {Modified (Supported [ Class_type (cltype, Modified)])}) |}] 63 | 64 | let%expect_test "Class type modification" = 65 | let reference = 66 | compile_interface 67 | {| 68 | class type cltype = 69 | object 70 | method m1 : float 71 | end 72 | |} 73 | in 74 | let current = 75 | compile_interface 76 | {| 77 | class type cltype = 78 | object 79 | method m1 : float 80 | method m2 : int -> int 81 | end 82 | |} 83 | in 84 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 85 | Format.printf "%a" pp_diff_option result; 86 | [%expect 87 | {| Some (Module Main: {Modified (Supported [ Class_type (cltype, Modified)])}) |}] 88 | -------------------------------------------------------------------------------- /tests/api-watch/test_diff_modtpe_decl.ml: -------------------------------------------------------------------------------- 1 | open Api_watch 2 | open Test_helpers 3 | 4 | let%expect_test "Modified module type" = 5 | let reference = 6 | compile_interface 7 | {| 8 | module type M = sig 9 | val b : int list -> int 10 | end 11 | |} 12 | in 13 | let current = 14 | compile_interface 15 | {| 16 | module type M = sig 17 | val b : float list -> float 18 | end 19 | |} 20 | in 21 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 22 | Format.printf "%a" pp_diff_option result; 23 | [%expect 24 | {| Some (Module Main: {Modified (Supported [ Module M: {Modified (Supported [ Value (b, Modified)])}])}) |}] 25 | 26 | let%expect_test "Concrete to abstract module_type" = 27 | let reference = 28 | compile_interface {| 29 | module type P = sig val x : int end 30 | |} 31 | in 32 | let current = compile_interface {| 33 | module type P 34 | |} in 35 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 36 | Format.printf "%a" pp_diff_option result; 37 | [%expect 38 | {| Some (Module Main: {Modified (Supported [ Module_type P: {Modified (Unsupported)}])}) |}] 39 | 40 | let%expect_test "Module type addition" = 41 | let reference = compile_interface {| 42 | |} in 43 | let current = 44 | compile_interface {| 45 | module type M = sig val x : int end 46 | |} 47 | in 48 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 49 | Format.printf "%a" pp_diff_option result; 50 | [%expect 51 | {| Some (Module Main: {Modified (Supported [ Module_type M: Added])}) |}] 52 | 53 | let%expect_test "Module type removal" = 54 | let reference = 55 | compile_interface {| 56 | module type P = sig val y : int list end 57 | |} 58 | in 59 | let current = compile_interface {| 60 | |} in 61 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 62 | Format.printf "%a" pp_diff_option result; 63 | [%expect 64 | {| Some (Module Main: {Modified (Supported [ Module_type P: Removed])}) |}] 65 | -------------------------------------------------------------------------------- /tests/api-watch/test_diff_module.ml: -------------------------------------------------------------------------------- 1 | open Api_watch 2 | open Test_helpers 3 | 4 | let%expect_test "Modules with both value and submodule changes" = 5 | let reference = 6 | compile_interface 7 | {| 8 | type ('a, 'b) result = Ok of 'a | Error of 'b 9 | val f : int -> string 10 | module M : sig 11 | val g : int -> string 12 | end 13 | |} 14 | in 15 | let current = 16 | compile_interface 17 | {| 18 | type ('a, 'b) result = Ok of 'a | Error of 'b 19 | val f : int -> (string, string) result 20 | module M : sig 21 | val g : int -> (string, string) result 22 | end 23 | |} 24 | in 25 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 26 | Format.printf "%a" pp_diff_option result; 27 | [%expect 28 | {| 29 | Some (Module Main: {Modified (Supported [ Value (f, Modified); 30 | Module M: {Modified (Supported [ Value (g, Modified)])}])})|}] 31 | 32 | let%expect_test "Modules with multiple value and submodule changes" = 33 | let reference = 34 | compile_interface 35 | {| 36 | type ('a, 'b) result = Ok of 'a | Error of 'b 37 | val a : string -> int 38 | val f : int -> string 39 | module M : sig 40 | val b : int list -> int 41 | val g : int -> string 42 | val z : string 43 | end 44 | |} 45 | in 46 | let current = 47 | compile_interface 48 | {| 49 | type ('a, 'b) result = Ok of 'a | Error of 'b 50 | val a : string -> float 51 | val f : int -> (string, string) result 52 | module M : sig 53 | val b : float list -> float 54 | val g : int -> (string, string) result 55 | val z : string 56 | end 57 | module N : sig val x: int end 58 | |} 59 | in 60 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 61 | Format.printf "%a" pp_diff_option result; 62 | [%expect 63 | {| 64 | Some (Module Main: {Modified (Supported [ Value (a, Modified); 65 | Value (f, Modified); 66 | Module M: {Modified (Supported [ Value (b, Modified); 67 | Value (g, Modified)])}; 68 | Module N: Added])})|}] 69 | 70 | let%expect_test "Modules with both supported changes" = 71 | let reference = compile_interface {| 72 | val x: int 73 | module M: sig 74 | end|} in 75 | let current = 76 | compile_interface {| 77 | module M: sig 78 | type exn += Some_exn 79 | end 80 | |} 81 | in 82 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 83 | Format.printf "%a" pp_diff_option result; 84 | [%expect 85 | {| 86 | Some (Module Main: {Modified (Supported [ Value (x, Removed); 87 | Module M: {Modified (Supported [ Extension_constructor (Some_exn, Added)])}])}) 88 | |}] 89 | 90 | let%expect_test "Submodules with different functor types." = 91 | let reference = 92 | compile_interface 93 | {| 94 | module type X = sig 95 | val x : int 96 | end 97 | 98 | module F (M : X) : sig 99 | val double : int 100 | end 101 | |} 102 | in 103 | let current = 104 | compile_interface 105 | {| 106 | module type Y = sig 107 | val y : float 108 | end 109 | 110 | module F (M : Y) : sig 111 | val double : int 112 | end 113 | |} 114 | in 115 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 116 | Format.printf "%a" pp_diff_option result; 117 | [%expect 118 | {| 119 | Some (Module Main: {Modified (Supported [ Module F: {Modified (Unsupported)}; 120 | Module_type X: Removed; 121 | Module_type Y: Added])}) 122 | |}] 123 | 124 | let%expect_test "Submodule with module type modified from signature to functor" 125 | = 126 | let reference = 127 | compile_interface 128 | {| 129 | module M : sig 130 | val x : int 131 | val y : string 132 | end 133 | |} 134 | in 135 | let current = 136 | compile_interface 137 | {| 138 | module M : functor (X : sig val z : float end) -> sig 139 | val x : int 140 | val y : string 141 | end 142 | |} 143 | in 144 | let result = Diff.interface ~module_name:"Main" ~reference ~current in 145 | Format.printf "%a" pp_diff_option result; 146 | [%expect 147 | {| 148 | Some (Module Main: {Modified (Supported [ Module M: {Modified (Unsupported)}])})|}] 149 | -------------------------------------------------------------------------------- /tests/api-watch/test_expand_tconstr.ml: -------------------------------------------------------------------------------- 1 | open Api_watch 2 | open Test_helpers 3 | 4 | let interface = 5 | compile_interface 6 | {| 7 | type ('a, 'b) t1 = ('a * 'b) list 8 | val v1 : (string, int) t1 9 | 10 | type ('a, 'b) t2 = { f1 : 'a; f2 : 'b } 11 | val v2 : (string, int) t2 12 | 13 | type ('a, 'b) t3 = ('a * 'b) list 14 | val v3 : (string, int) t3 15 | |} 16 | 17 | let env = 18 | List.fold_right 19 | (fun sig_item env -> 20 | match sig_item with 21 | | Types.Sig_type (id, td, _, _) -> 22 | if String.starts_with ~prefix:"t3" (Ident.name id) then env 23 | else Env.add_type ~check:true id td env 24 | | _ -> env) 25 | interface Env.empty 26 | 27 | let value_map = 28 | List.fold_left 29 | (fun map sig_item -> 30 | match sig_item with 31 | | Types.Sig_value (id, vd, _) -> 32 | String_map.add (Ident.name id) vd.val_type map 33 | | _ -> map) 34 | String_map.empty interface 35 | 36 | let%expect_test "test_expand_tconstr_on_alias_types" = 37 | let v1_type = String_map.find "v1" value_map in 38 | let path, args = get_tconstr v1_type in 39 | let expanded_type_expr = 40 | Typing_env.expand_tconstr ~typing_env:env ~path ~args 41 | in 42 | match expanded_type_expr with 43 | | None -> assert false 44 | | Some e -> 45 | Printtyp.type_expr Format.std_formatter e; 46 | [%expect {| (string * int) list |}] 47 | 48 | let%expect_test "test_expand_tconstr_on_nominal_types" = 49 | let v2_type = String_map.find "v2" value_map in 50 | let path, args = get_tconstr v2_type in 51 | let expanded_type_expr = 52 | Typing_env.expand_tconstr ~typing_env:env ~path ~args 53 | in 54 | match expanded_type_expr with 55 | | Some _ -> assert false 56 | | None -> 57 | Printtyp.type_expr Format.std_formatter v2_type; 58 | [%expect {| (string, int) t2 |}] 59 | 60 | let%expect_test "test_expand_tconstr_on_type_not_in_the_env" = 61 | let v3_type = String_map.find "v3" value_map in 62 | let path, args = get_tconstr v3_type in 63 | let expanded_type_expr = 64 | Typing_env.expand_tconstr ~typing_env:env ~path ~args 65 | in 66 | match expanded_type_expr with 67 | | None -> 68 | Printtyp.type_expr Format.std_formatter v3_type; 69 | [%expect {| (string, int) t3 |}] 70 | | Some _ -> assert false 71 | -------------------------------------------------------------------------------- /tests/api-watch/test_fully_expand_type_expr.ml: -------------------------------------------------------------------------------- 1 | open Api_watch 2 | open Test_helpers 3 | 4 | let interface = 5 | compile_interface 6 | {| 7 | type ('a, 'b) t1 = ('a * 'b) list 8 | type ('a, 'b) t2 = ('a, 'b) t1 9 | val v1 : (string, int) t2 10 | 11 | type ('a, 'b) t3 = { f1 : 'a; f2 : 'b } 12 | type ('a, 'b) t4 = ('a, 'b) t3 13 | val v2 : (string, int) t4 14 | 15 | type ('a, 'b) not_in_env = 'a * 'b 16 | val v3 : (string, int) not_in_env 17 | |} 18 | 19 | let env = 20 | List.fold_right 21 | (fun sig_item env -> 22 | match sig_item with 23 | | Types.Sig_type (id, td, _, _) -> 24 | if String.starts_with ~prefix:"not_in_env" (Ident.name id) then env 25 | else Env.add_type ~check:true id td env 26 | | _ -> env) 27 | interface Env.empty 28 | 29 | let value_map = 30 | List.fold_left 31 | (fun map sig_item -> 32 | match sig_item with 33 | | Types.Sig_value (id, vd, _) -> 34 | String_map.add (Ident.name id) vd.val_type map 35 | | _ -> map) 36 | String_map.empty interface 37 | 38 | let%expect_test "test_fully_expand_type_expr_on_alias_types" = 39 | let v1_type = String_map.find "v1" value_map in 40 | let path, args = get_tconstr v1_type in 41 | let expanded_type_expr = 42 | Typing_env.fully_expand_tconstr ~typing_env:env ~path ~args 43 | in 44 | match expanded_type_expr with 45 | | None -> assert false 46 | | Some expr -> 47 | Printtyp.type_expr Format.std_formatter expr; 48 | [%expect {| (string * int) list |}] 49 | 50 | let%expect_test "test_fully_expand_type_expr_on_nominal_types" = 51 | let v2_type = String_map.find "v2" value_map in 52 | let path, args = get_tconstr v2_type in 53 | let expanded_type_expr = 54 | Typing_env.fully_expand_tconstr ~typing_env:env ~path ~args 55 | in 56 | match expanded_type_expr with 57 | | None -> assert false 58 | | Some expr -> 59 | Printtyp.type_expr Format.std_formatter expr; 60 | [%expect {| (string, int) t3 |}] 61 | 62 | let%expect_test "test_fully_expand_type_expr_on_type_not_in_the_env" = 63 | let v3_type = String_map.find "v3" value_map in 64 | let path, args = get_tconstr v3_type in 65 | let expanded_type_expr = 66 | Typing_env.fully_expand_tconstr ~typing_env:env ~path ~args 67 | in 68 | match expanded_type_expr with 69 | | Some _ -> assert false 70 | | None -> 71 | Printtyp.type_expr Format.std_formatter v3_type; 72 | [%expect {| (string, int) not_in_env |}] 73 | -------------------------------------------------------------------------------- /tests/api-watch/test_normalize.ml: -------------------------------------------------------------------------------- 1 | open Api_watch 2 | open Test_helpers 3 | 4 | let%expect_test "test_normalize_type_declarations" = 5 | let ref_id, reference = 6 | compile_interface {|type ('a, 'b) t = 'a * 'b|} 7 | |> first_type_declaration |> Option.get 8 | in 9 | let cur_id, current = 10 | compile_interface {|type ('c, 'd, 'e) t = 'c * 'd * 'e|} 11 | |> first_type_declaration |> Option.get 12 | in 13 | Normalize.type_declarations ~reference ~current; 14 | Printtyp.type_declaration ref_id Format.std_formatter reference; 15 | Format.force_newline (); 16 | Printtyp.type_declaration cur_id Format.std_formatter current; 17 | [%expect 18 | {| 19 | type ('t1, 't2) t = 't1 * 't2 20 | type ('t1, 't2, 't3) t = 't1 * 't2 * 't3 |}] 21 | 22 | let%expect_test "test_normalize_is_type_params_true" = 23 | let reference = 24 | List.init 5 (fun i -> 25 | Types.create_expr 26 | (Tvar (Some (CCString.of_char (Char.chr (Char.code 'a' + i))))) 27 | ~level:0 ~scope:0 ~id:i) 28 | in 29 | let current = 30 | List.init 3 (fun i -> 31 | Types.create_expr 32 | (Tvar (Some (CCString.of_char (Char.chr (Char.code 'a' + i))))) 33 | ~level:0 ~scope:0 ~id:i) 34 | in 35 | Printf.printf "%b" (Normalize.is_type_params ~reference ~current); 36 | [%expect "true"] 37 | 38 | let%expect_test "test_normalize_is_type_params_false" = 39 | let reference = 40 | List.init 5 (fun i -> 41 | Types.create_expr 42 | (Tvar (Some (CCString.of_char (Char.chr (Char.code 'a' + i + 1))))) 43 | ~level:0 ~scope:0 ~id:i) 44 | in 45 | let current = 46 | List.init 3 (fun i -> 47 | Types.create_expr 48 | (Tvar (Some (CCString.of_char (Char.chr (Char.code 'a' + i))))) 49 | ~level:0 ~scope:0 ~id:i) 50 | in 51 | Printf.printf "%b" (Normalize.is_type_params ~reference ~current); 52 | [%expect "false"] 53 | 54 | let%expect_test "test_normalize_type_params_arity" = 55 | let reference = 56 | List.init 5 (fun i -> 57 | Types.create_expr 58 | (Tvar (Some (Printf.sprintf "t%d" i))) 59 | ~level:0 ~scope:0 ~id:i) 60 | in 61 | let current = 62 | List.init 3 (fun i -> 63 | Types.create_expr 64 | (Tvar (Some (Printf.sprintf "t%d" i))) 65 | ~level:0 ~scope:0 ~id:i) 66 | in 67 | let normed_ref, normed_cur = 68 | Normalize.type_params_arity ~reference ~current 69 | in 70 | Printf.printf "%b" 71 | (Ctype.is_equal Env.empty true normed_ref reference 72 | && Ctype.is_equal Env.empty true normed_cur 73 | (current 74 | @ List.init 2 (fun _ -> 75 | Types.create_expr (Tvar None) ~level:0 ~scope:0 ~id:0))); 76 | [%expect "true"] 77 | -------------------------------------------------------------------------------- /tests/api-watch/test_text_diff.ml: -------------------------------------------------------------------------------- 1 | open Api_watch 2 | open Test_helpers 3 | 4 | let%expect_test "multi-line items are represented as multi-line diffs" = 5 | let reference = compile_interface {| 6 | |} in 7 | let current = 8 | compile_interface 9 | {| 10 | val f : 11 | some_long_labeled_argument: int -> 12 | some_other_long_labeled_arg: int * int -> 13 | string * string -> 14 | unit -> 15 | string 16 | 17 | module M : sig 18 | val some_val : int -> int -> int -> string 19 | val some_other_val : string -> string -> string -> int 20 | val yet_some_other_val : string -> bool -> string 21 | end 22 | |} 23 | in 24 | let diff_opt = Diff.interface ~module_name:"Main" ~reference ~current in 25 | let diff = Option.get diff_opt in 26 | let text_diff = Text_diff.from_diff diff in 27 | Format.printf "%a" Text_diff.pp text_diff; 28 | [%expect 29 | {| 30 | diff module Main: 31 | +val f : 32 | + some_long_labeled_argument:int -> 33 | + some_other_long_labeled_arg:int * int -> string * string -> unit -> string 34 | +module M: sig 35 | + val some_val : int -> int -> int -> string 36 | + val some_other_val : string -> string -> string -> int 37 | + val yet_some_other_val : string -> bool -> string 38 | +end 39 | |}] 40 | -------------------------------------------------------------------------------- /tests/test_helpers/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_helpers) 3 | (libraries compiler-libs.common api-watch)) 4 | -------------------------------------------------------------------------------- /tests/test_helpers/test_helpers.ml: -------------------------------------------------------------------------------- 1 | open Api_watch.Diff 2 | open Api_watch.Typing_env 3 | 4 | let rec pp_module_modification fmt = function 5 | | Unsupported -> Format.fprintf fmt "Unsupported" 6 | | Supported changes -> 7 | Format.fprintf fmt "Supported [ %a]" 8 | (Format.pp_print_list 9 | ~pp_sep:(fun fmt () -> Format.fprintf fmt ";\n") 10 | pp_item_diff) 11 | changes 12 | 13 | and pp_item_diff fmt = function 14 | | Value value_diff -> pp_value_diff fmt value_diff 15 | | Module module_diff -> pp_module_diff fmt module_diff 16 | | Type type_diff -> pp_type_diff fmt type_diff 17 | | Modtype module_type_diff -> pp_module_type_diff fmt module_type_diff 18 | | Class class_diff -> pp_class_diff fmt class_diff 19 | | Classtype class_type_diff -> pp_class_type_diff fmt class_type_diff 20 | | Extcstr extcstr_diff -> pp_extension_cstr_diff fmt extcstr_diff 21 | 22 | and pp_value_diff fmt { vname; vdiff } = 23 | match vdiff with 24 | | Added _ -> Format.fprintf fmt "Value (%s, Added)" vname 25 | | Removed _ -> Format.fprintf fmt "Value (%s, Removed)" vname 26 | | Modified _ -> Format.fprintf fmt "Value (%s, Modified)" vname 27 | 28 | and pp_type_diff fmt { tname; tdiff } = 29 | match tdiff with 30 | | Added _ -> Format.fprintf fmt "Type (%s, Added)" tname 31 | | Removed _ -> Format.fprintf fmt "Type (%s, Removed)" tname 32 | | Modified _ -> Format.fprintf fmt "Type (%s, Modified)" tname 33 | 34 | and pp_module_diff fmt { mname; mdiff } = 35 | match mdiff with 36 | | Added _ -> Format.fprintf fmt "Module %s: Added" mname 37 | | Removed _ -> Format.fprintf fmt "Module %s: Removed" mname 38 | | Modified mdiff -> 39 | Format.fprintf fmt "Module %s: {Modified (%a)}" mname 40 | pp_module_modification mdiff 41 | 42 | and pp_module_type_diff fmt { mtname; mtdiff } = 43 | match mtdiff with 44 | | Added _ -> Format.fprintf fmt "Module_type %s: Added" mtname 45 | | Removed _ -> Format.fprintf fmt "Module_type %s: Removed" mtname 46 | | Modified mtdiff -> 47 | Format.fprintf fmt "Module_type %s: {Modified (%a)}" mtname 48 | pp_module_modification mtdiff 49 | 50 | and pp_class_diff fmt { cname; cdiff } = 51 | match cdiff with 52 | | Added _ -> Format.fprintf fmt "Class (%s, Added)" cname 53 | | Removed _ -> Format.fprintf fmt "Class (%s, Removed)" cname 54 | | Modified _ -> Format.fprintf fmt "Class (%s, Modified)" cname 55 | 56 | and pp_class_type_diff fmt { ctname; ctdiff } = 57 | match ctdiff with 58 | | Added _ -> Format.fprintf fmt "Class_type (%s, Added)" ctname 59 | | Removed _ -> Format.fprintf fmt "Class_type (%s, Removed)" ctname 60 | | Modified _ -> Format.fprintf fmt "Class_type (%s, Modified)" ctname 61 | 62 | and pp_extension_cstr_diff fmt { ecname; ecexn; ecdiff; ectname = _ } = 63 | if ecexn then 64 | match ecdiff with 65 | | Added _ -> Format.fprintf fmt "Exception (%s, Added)" ecname 66 | | Removed _ -> Format.fprintf fmt "Exception (%s, Removed)" ecname 67 | | Modified _ -> Format.fprintf fmt "Exception (%s, Modified)" ecname 68 | else 69 | match ecdiff with 70 | | Added _ -> Format.fprintf fmt "Extension_constructor (%s, Added)" ecname 71 | | Removed _ -> 72 | Format.fprintf fmt "Extension_constructor (%s, Removed)" ecname 73 | | Modified _ -> 74 | Format.fprintf fmt "Extension_constructor (%s, Modified)" ecname 75 | 76 | let pp_diff_option fmt = function 77 | | None -> Format.fprintf fmt "None" 78 | | Some module_diff -> 79 | Format.fprintf fmt "Some (%a)" pp_module_diff module_diff 80 | 81 | let parse_interface content = 82 | let lexbuf = Lexing.from_string content in 83 | Parse.interface lexbuf 84 | 85 | let generate_signature intf = 86 | let typing_env = initialized_env () in 87 | let typed_tree = Typemod.type_interface typing_env intf in 88 | typed_tree.sig_type 89 | 90 | let compile_interface (content : string) : Types.signature = 91 | let intf = parse_interface content in 92 | let signature = generate_signature intf in 93 | signature 94 | 95 | let first_type_declaration (signature : Types.signature) : 96 | (Ident.t * Types.type_declaration) option = 97 | List.find_map 98 | (fun sig_item -> 99 | match sig_item with 100 | | Types.Sig_type (id, td, _, _) -> Some (id, td) 101 | | _ -> None) 102 | signature 103 | 104 | let get_tconstr type_expr = 105 | match Types.get_desc type_expr with 106 | | Tconstr (path, args, _) -> (path, args) 107 | | _ -> 108 | invalid_arg 109 | "get_tconstr should be called with a type expr that is a\n\ 110 | \ type constructor" 111 | -------------------------------------------------------------------------------- /tests/test_helpers/test_helpers.mli: -------------------------------------------------------------------------------- 1 | val pp_diff_option : Format.formatter -> Api_watch.Diff.module_ option -> unit 2 | val compile_interface : string -> Types.signature 3 | 4 | val first_type_declaration : 5 | Types.signature -> (Ident.t * Types.type_declaration) option 6 | 7 | val get_tconstr : Types.type_expr -> Path.t * Types.type_expr list 8 | --------------------------------------------------------------------------------