new: atddiff tool (#358)

* Add scaffold for atddiff including CLI and tests

* Create modules

* Add a Loc module providing a comparison function for sorting purposes

* Detect added/removed type definitions

* Work in progress in Compare.ml

* Work in progress

* First version of atddiff
It mostly works but incorrect locations are reported for parametrized
types.

* Add proper support for polymorphic definitions.

* Remove unused error kind

* Add a tiny readme

* Generate dune file so that we can easily split our test files

* Drop the notion of root types, fix infinite looping for recursive types

* Update test snapshots

* Split test into smaller test cases

* Use one folder per test command

* Test the options --json-defaults-old and --json-defaults-new and fix
the error messages.

* Use and document exit code 3 for reporting findings

* Don't report as deleted/created type names that are compared pairwise in
some comparison e.g. 'type t = a' and 'type t = b' will result in
treating types 'a' and 'b' as the same type.

* Report all the type names affected by an incompatibility

* Add atddiff support for 3 kinds of JSON annotations:
- object field renaming with '<json name="...">'
- enum/variant renaming with '<json name="...">'
- JSON maps with '(string * _) list <json repr="object">'

* Update changelog

* Add type annotations to clarify command-line options

* Update changelog (again)

* Add details to changelog

CHANGES.md

@@ -6,6 +6,9 @@ Unreleased
 * atdcat: New option `-remove-wraps` which pretty-prints the type
   definitions without `wrap` constructs (#353)
 * atdd: Add `dlang` backend to generate D code from ATD definitions (#349)
+* new tool: atddiff. Compares two versions of an ATD file and reports
+  possible incompatibilities in the JSON data. Atddiff ships as part of the 
+  `atd` package together with `atdcat` (#352, #358)
 
 2.12.0 (2023-05-12)
 -------------------

Makefile

@@ -56,6 +56,7 @@ test:
 test-common:
 	$(MAKE) -C atd test
 	$(MAKE) -C atdcat test
+	$(MAKE) -C atddiff test
 
 # Test only the OCaml backends
 .PHONY: test-ocaml

atd.opam

@@ -5,7 +5,8 @@ description: """
 ATD is the OCaml library providing a parser for the ATD language and various
 utilities. ATD stands for Adjustable Type Definitions in reference to its main
 property of supporting annotations that allow a good fit with a variety of data
-formats. """
+formats. This package also provides the 'atdcat' and 'atddiff' command-line
+utilities."""
 maintainer: [
   "Louis Roché <louis@louisroche.net>"
   "Martin Jambon <martin@mjambon.com>"

atd/src/ast.mli

@@ -1,6 +1,6 @@
 (** Abstract syntax tree (AST) representing ATD data *)
 
-type loc = Lexing.position * Lexing.position
+type loc = Loc.t
     (** A location in the source code. *)
 
 exception Atd_error of string

atd/src/json.ml

@@ -223,6 +223,25 @@ let get_json_list an =
     ~field:"repr"
     an
 
+(*
+   Return true iff the type expression is of the form:
+
+     '(string * _) list <json repr="object">'
+*)
+let is_json_map (list_expr : Ast.type_expr) =
+  match list_expr with
+  | List (_, e, an) ->
+      (match e, get_json_list an with
+       | Tuple (_,
+                [
+                  (_, Name (_, (_, "string", _), _), _);
+                  _
+                ],
+                _), Object -> true
+       | _ -> false
+      )
+  | _ -> false
+
 let get_json_cons default an =
   Annot.get_field
     ~parse:(fun s -> Some s)

atd/src/json.mli

@@ -72,6 +72,18 @@ val annot_schema_json : Annot.schema
 
 val get_json_list : Annot.t -> json_list
 
+(*
+   Return true iff the type expression is of the form:
+
+     '(string * _) list <json repr="object">'
+
+   Note that it doesn't perform any dealiasing: 'string' must be literally
+   'string'. Same for 'list'.
+
+   This uses 'get_json_list' to extract the relevant annotation.
+*)
+val is_json_map : Ast.type_expr -> bool
+
 val get_json_float : Annot.t -> json_float
 
 val get_json_int : Annot.t -> json_int

atd/src/loc.ml

@@ -0,0 +1,22 @@
+(*
+   A location is a region in a source file.
+*)
+
+type t = Lexing.position * Lexing.position
+
+let compare_pos (a : Lexing.position) (b : Lexing.position) =
+  let c = String.compare a.pos_fname b.pos_fname in
+  if c <> 0 then c
+  else
+    Int.compare a.pos_cnum b.pos_cnum
+
+(* Compare two locations so as to sort them by:
+   1. file path
+   2. start position in the file
+   3. end position in the file
+*)
+let compare ((a_start, a_end) : t) ((b_start, b_end) : t) =
+  let c = compare_pos a_start b_start in
+  if c <> 0 then c
+  else
+    compare_pos a_end b_end

atd/src/loc.mli

@@ -0,0 +1,12 @@
+(*
+   A location is a region in a source file.
+*)
+
+type t = Lexing.position * Lexing.position
+
+(* Compare two locations so as to sort them by:
+   1. file path
+   2. start position in the file
+   3. end position in the file
+*)
+val compare : t -> t -> int

atd/src/version.ml

@@ -1 +1,3 @@
+(* The version string is replaced by the actual version at release time
+   by 'dune release'. *)
 let version = "%%VERSION%%"

atddiff/.gitignore

@@ -0,0 +1 @@
+/bin

atddiff/Makefile

@@ -0,0 +1,15 @@
+#
+# Compare two versions of the same ATD file.
+#
+
+DUNE ?= dune
+
+.PHONY: build
+build:
+	rm -f bin
+	$(DUNE) build
+	ln -s ../_build/install/default/bin .
+
+.PHONY: test
+test:
+	$(MAKE) -C test

atddiff/README.md

@@ -0,0 +1,10 @@
+atddiff
+=======
+
+Atddiff is a command for anticipating incompatibilities between JSON
+data and data readers when modifying type definitions.
+
+<!-- TODO: show an example -->
+<!-- TODO: link to the documentation -->
+
+See `atddiff --help` for examples and options.

atddiff/src/bin/Atddiff_main.ml

@@ -0,0 +1,239 @@
+(*
+   Entry point to the atddiff command.
+*)
+
+open Printf
+open Cmdliner
+
+type conf = {
+  old_file: string;
+  new_file: string;
+  out_file: string option;
+  json_defaults_old: bool;
+  json_defaults_new: bool;
+  exit_success: bool;
+  version: bool;
+}
+
+let ok_exit = 0
+let error_exit = 1
+let bug_exit = 2
+let finding_exit = 3
+
+let exit_info = [
+  ok_exit, "atddiff completed successfully and either found nothing to report \
+            or found issues but the --exit-success option was on.";
+  error_exit, "User error: atddiff failed due to invalid command-line \
+               options, missing files etc.";
+  bug_exit, "Internal error: atddiff failed due to a bug (including \
+             uncaught exceptions).";
+  finding_exit, "atddiff successfully found one or more issues to report.";
+] |> List.map (fun (code, doc) -> Cmd.Exit.info ~doc code)
+
+let run conf =
+  if conf.version then (
+    print_endline Atddiff.version;
+    exit ok_exit
+  )
+  else
+    let out_data =
+      Atddiff.compare_files
+        ~json_defaults_old:conf.json_defaults_old
+        ~json_defaults_new:conf.json_defaults_new
+        conf.old_file conf.new_file in
+    let exit_code, data =
+      match out_data with
+      | Ok () ->
+          ok_exit, ""
+      | Error data ->
+          (if conf.exit_success then ok_exit else finding_exit), data
+    in
+    (match conf.out_file with
+     | None -> print_string data
+     | Some out_file ->
+         let oc = open_out_bin out_file in
+         Fun.protect
+           ~finally:(fun () -> close_out_noerr oc)
+           (fun () -> output_string oc data)
+    );
+    exit exit_code
+
+(***************************************************************************)
+(* Command-line processing *)
+(***************************************************************************)
+
+let error msg =
+  eprintf "Error: %s\n%!" msg;
+  exit error_exit
+
+let old_file_term : string Term.t =
+  let info =
+    Arg.info []
+      ~docv:"OLD_ATD_FILE"
+      ~doc:"Path to the older version of the ATD file to compare"
+  in
+  Arg.required (Arg.pos 0 (Arg.some Arg.file) None info)
+
+let new_file_term : string Term.t =
+  let info =
+    Arg.info []
+      ~docv:"NEW_ATD_FILE"
+      ~doc:"Path to the newer version of the ATD file to compare"
+  in
+  Arg.required (Arg.pos 1 (Arg.some Arg.file) None info)
+
+let out_file_term : string option Term.t =
+  let info =
+    Arg.info ["o"; "output-file"]
+      ~docv:"OUTPUT_FILE"
+      ~doc:"Path to the output file. The default is to print the result to \
+            standard output."
+  in
+  Arg.value (Arg.opt (Arg.some Arg.string) None info)
+
+let json_defaults_term : bool Term.t =
+  let info =
+    Arg.info ["json-defaults"]
+      ~doc:"Shorthand for '--json-defaults-old --json-defaults-new'."
+  in
+  Arg.value (Arg.flag info)
+
+let json_defaults_old_term : bool Term.t =
+  let info =
+    Arg.info ["json-defaults-old"]
+      ~doc:"Assume that old implementations emitting JSON populate \
+            optional fields with a value when a default exists. This applies \
+            to all the fields marked with a '~'. For example, a field \
+            declared as '~items: item list' defaults to the empty list. \
+            This option makes atddiff assume that '~' fields behave like \
+            required fields in JSON for old implementations. \
+            For example, when using atdgen it is achieved with '-j-defaults'."
+  in
+  Arg.value (Arg.flag info)
+
+let json_defaults_new_term : bool Term.t =
+  let info =
+    Arg.info ["json-defaults-new"]
+      ~doc:"Assume that new implementations emitting JSON populate \
+            optional fields with a value when a default exists. This applies \
+            to all the fields marked with a '~'. For example, a field \
+            declared as '~items: item list' defaults to the empty list. \
+            This option makes atddiff assume that '~' fields behave like \
+            required fields in JSON for new implementations. \
+            For example, when using atdgen it is achieved with '-j-defaults'."
+  in
+  Arg.value (Arg.flag info)
+
+let exit_success_term : bool Term.t =
+  let info =
+    Arg.info ["exit-success"]
+      ~doc:(sprintf "Exit with success status %i instead of %i if there are \
+                     type incompatibilities to report."
+              ok_exit
+              finding_exit)
+  in
+  Arg.value (Arg.flag info)
+
+let version_term : bool Term.t =
+  let info =
+    Arg.info ["version"]
+      ~doc:"Print the version of atddiff and exits."
+  in
+  Arg.value (Arg.flag info)
+
+let doc =
+  "Assess the compatibility of two versions of the same ATD interface"
+
+(*
+   The structure of the help page.
+*)
+let man = [
+  (* 'NAME' and 'SYNOPSIS' sections are inserted here by cmdliner. *)
+
+  `S Manpage.s_description;  (* standard 'DESCRIPTION' section *)
+  `P "Atddiff compares two versions of the same ATD file and reports \
+      changes in JSON data that can cause some incompatibilities. \
+      Incompatibilities are of two kinds: forward and backward. \
+      Backward compatibility refers to the ability to read older data \
+      or data produced by an older implementation using a newer \
+      implementation. Conversely, forward compatibility is the ability \
+      to read data produced by a newer implementation. For example, if \
+      a new field is removed from a record type and was it not \
+      optional, it makes it impossible for an older implementation \
+      to read data from a newer implementation that lacks the field in \
+      question. Typically, data comes from \
+      storage (databases, configuration files, ...), from client requests, \
+      or from server responses. All these sources of data may suffer from \
+      being 'too old' (backward-incompatible) or 'too new' \
+      (forward-incompatible) for the reader. Atddiff helps developers \
+      protect themselves against unintentional breaking changes \
+      without being ATD experts.";
+
+  `P "Git users will find it convenient to run 'atddiff' via the command \
+      'git difftool -x atddiff', allowing them to select two versions of the \
+      same file as they usually do with 'git diff'.";
+
+  (* 'ARGUMENTS' and 'OPTIONS' sections are inserted here by cmdliner. *)
+  `S Manpage.s_authors;
+  `P "Martin Jambon <martin@semgrep.com>";
+
+  `S Manpage.s_see_also;
+  `P "atdcat"
+]
+
+let cmdline_term run =
+  let combine
+      old_file new_file out_file
+      json_defaults json_defaults_old json_defaults_new
+      exit_success version =
+    let json_defaults_old = json_defaults_old || json_defaults in
+    let json_defaults_new = json_defaults_new || json_defaults in
+    run {
+      old_file;
+      new_file;
+      out_file;
+      json_defaults_old;
+      json_defaults_new;
+      exit_success;
+      version;
+    }
+  in
+  Term.(const combine
+        $ old_file_term
+        $ new_file_term
+        $ out_file_term
+        $ json_defaults_term
+        $ json_defaults_old_term
+        $ json_defaults_new_term
+        $ exit_success_term
+        $ version_term
+       )
+
+let parse_command_line_and_run run =
+  let info =
+    Cmd.info
+      ~doc
+      ~exits:exit_info
+      ~man
+      "atddiff"
+  in
+  Cmd.v info (cmdline_term run) |> Cmd.eval |> exit
+
+let safe_run conf =
+  try run conf
+  with
+  (* for other exceptions, we show a backtrace *)
+  | Failure msg -> error msg
+  | Atd.Ast.Atd_error msg -> error msg
+  | e ->
+      let trace = Printexc.get_backtrace () in
+      eprintf "Error: exception %s\n%s%!"
+        (Printexc.to_string e)
+        trace
+
+let main () =
+  Printexc.record_backtrace true;
+  let conf = parse_command_line_and_run safe_run in
+  safe_run conf
+
+let () = main ()