atddiff: Add --backward, --forward, --types filters (#367)

* Add atddiff result filtering (--backward, --forward, --types)

* Update changelog

* Rephrase comment

* Update atddiff howto

* Rephrase doc

---------

Co-authored-by: Martin Jambon <[email protected]>

Author: mjambon

CHANGES.md

@@ -4,6 +4,9 @@ Unreleased
 * atdd: Fix various issues with the interoperability of user defined types,
   used in or outside of records (#355)
 * atdd: Generated `.d` files now have the suffix `_atd.d` (#355)
+* atddiff now supports options for filtering the findings based on the 
+  direction of the incompatibility (`--backward`, `--forward`) or based on the  
+  name of the affected types (`--types`) (#365)
 
 2.13.0 (2023-10-15)
 -------------------

atddiff/src/bin/Atddiff_main.ml

@@ -9,6 +9,7 @@ type conf = {
   old_file: string;
   new_file: string;
   out_file: string option;
+  filter: Atddiff.filter;
   json_defaults_old: bool;
   json_defaults_new: bool;
   exit_success: bool;
@@ -38,6 +39,7 @@ let run conf =
   else
     let out_data =
       Atddiff.compare_files
+        ~filter:conf.filter
         ~json_defaults_old:conf.json_defaults_old
         ~json_defaults_new:conf.json_defaults_new
         conf.old_file conf.new_file in
@@ -91,6 +93,31 @@ let out_file_term : string option Term.t =
   in
   Arg.value (Arg.opt (Arg.some Arg.string) None info)
 
+let backward_term : bool Term.t =
+  let info =
+    Arg.info ["backward"]
+      ~doc:"Ignore findings other than backward incompatibilies."
+  in
+  Arg.value (Arg.flag info)
+
+let forward_term : bool Term.t =
+  let info =
+    Arg.info ["forward"]
+      ~doc:"Ignore findings other than forward incompatibilies."
+  in
+  Arg.value (Arg.flag info)
+
+let types_term : string list option Term.t =
+  let info =
+    Arg.info ["types"]
+      ~docv:"TYPE_NAME1,TYPE_NAME2,..."
+      ~doc:"Select findings that affect these types. If no '--type' filter is \
+            provided, all types are selected. For example, \
+            '--type foo,bar' selects the findings that affect type 'foo', \
+            type 'bar', or both."
+  in
+  Arg.value (Arg.opt (Arg.some (Arg.list Arg.string)) None info)
+
 let json_defaults_term : bool Term.t =
   let info =
     Arg.info ["json-defaults"]
@@ -184,14 +211,32 @@ let man = [
 let cmdline_term run =
   let combine
       old_file new_file out_file
+      backward forward types
       json_defaults json_defaults_old json_defaults_new
       exit_success version =
+    let filter =
+      let module A = Atddiff in
+      let backward = if backward then [A.Filter (A.Backward)] else [] in
+      let forward = if forward then [A.Filter (A.Forward)] else [] in
+      let types =
+        match types with
+        | None -> []
+        | Some types ->
+            [A.Or
+               (List.map (fun name ->
+                  A.Filter (A.Affected_type_name name))
+               types)
+            ]
+      in
+      A.And (List.concat [backward; forward; types])
+    in
     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;
+      filter;
       json_defaults_old;
       json_defaults_new;
       exit_success;
@@ -202,6 +247,9 @@ let cmdline_term run =
         $ old_file_term
         $ new_file_term
         $ out_file_term
+        $ backward_term
+        $ forward_term
+        $ types_term
         $ json_defaults_term
         $ json_defaults_old_term
         $ json_defaults_new_term

atddiff/src/lib/Atddiff.ml

@@ -2,14 +2,50 @@
     Internal Atddiff library used by the 'atddiff' command.
 *)
 
+type simple_filter =
+  | Affected_type_name of string
+  | Backward
+  | Forward
+
+type filter =
+  | Or of filter list
+  | And of filter list
+  | Not of filter
+  | Filter of simple_filter
+
 type output_format = Text | JSON
 
 let version = Version.version
 
 let format_json res : string =
   failwith "JSON output: not implemented"
 
+let rec select_finding filter (x : Types.finding * string list) =
+  match filter with
+  | Or filters ->
+      List.exists (fun filter -> select_finding filter x) filters
+  | And filters ->
+      List.for_all (fun filter -> select_finding filter x) filters
+  | Not filter ->
+      not (select_finding filter x)
+  | Filter (Affected_type_name name) ->
+      let _, names = x in
+      List.mem name names
+  | Filter Backward ->
+      let finding, _ = x in
+      (match finding.direction with
+       | Backward | Both -> true
+       | Forward -> false
+      )
+  | Filter Forward ->
+      let finding, _ = x in
+      (match finding.direction with
+       | Forward | Both -> true
+       | Backward -> false
+      )
+
 let compare_files
+  ?(filter = And [] (* all *))
   ?(json_defaults_old = false)
   ?(json_defaults_new = false)
   ?(output_format = Text)
@@ -34,6 +70,7 @@ let compare_files
   match res with
   | [] -> Ok ()
   | res ->
+      let res = List.filter (select_finding filter) res in
       Error (
         match output_format with
         | Text -> Format_text.to_string res

atddiff/src/lib/Atddiff.mli

@@ -2,6 +2,29 @@
     Internal Atddiff library used by the 'atddiff' command.
 *)
 
+type simple_filter =
+  (* A finding reported to affect the given ATD type name.
+     It's possible that this type name exists only in one of the two versions
+     of the ATD file. *)
+  | Affected_type_name of string
+  (* Select backward incompatibilies *)
+  | Backward
+  (* Select forward incompatibilies *)
+  | Forward
+
+(* The type of a filter over the findings.
+
+   Command-line options that describe filters are translated to this type.
+
+   This query language isn't exposed by the CLI right now because it's
+   overkill and it would require a special parser.
+*)
+type filter =
+  | Or of filter list (* union; none = Or [] *)
+  | And of filter list (* intersection; all = And [] *)
+  | Not of filter (* set difference *)
+  | Filter of simple_filter
+
 type output_format = Text | JSON
 
 (*
@@ -13,6 +36,7 @@ type output_format = Text | JSON
                       populated in new JSON data.
 *)
 val compare_files :
+  ?filter:filter ->
   ?json_defaults_old:bool ->
   ?json_defaults_new:bool ->
   ?output_format:output_format ->

atddiff/src/lib/Types.ml

@@ -2,7 +2,7 @@
    Type definitions used to build comparison results
 *)
 
-type direction = Forward | Backward | Both
+type direction = Backward | Forward | Both
 
 type incompatibility_kind =
   | Missing_field of { field_name: string }

atddiff/test/filter/dune

@@ -0,0 +1,12 @@
+; Generated by ./generate-dune-rules
+; For adding tests, read the instructions in the Makefile.
+(rule
+ (targets filter.txt)
+ (deps filter_old.atd filter_new.atd)
+ (action (run %{bin:atddiff} %{deps} -o %{targets} --exit-success --backward --forward --types a,b)))
+
+(rule
+ (alias runtest)
+ (deps filter.txt)
+ (action (diff filter.expected.txt filter.txt)))
+

atddiff/test/filter/filter.expected.txt

@@ -0,0 +1,8 @@
+Incompatibility in both directions:
+File "filter_old.atd", line 7, characters 16-20
+File "filter_new.atd", line 7, characters 16-23
+Type names 'int' and 'string' are not the same and may not be compatible.
+The following types are affected:
+  a
+  b
+

atddiff/test/filter/filter_new.atd

@@ -0,0 +1,17 @@
+(*
+   Test that the command-line filters make the correct selection of findings.
+*)
+
+type a = {
+  added_field: int; (* backward incompatibility *)
+  changing_type: string;
+}
+
+type b = {
+  uses_a: a; (* backward and forward incompatibilities *)
+}
+
+(* Findings affecting only 'c' are ignored. *)
+type c = {
+  added_field_in_ignored_type: int;
+}

atddiff/test/filter/filter_old.atd

@@ -0,0 +1,17 @@
+(*
+   Test that the command-line filters make the correct selection of findings.
+*)
+
+type a = {
+  deleted_field: int; (* forward incompatibility *)
+  changing_type: int;
+}
+
+type b = {
+  uses_a: a; (* backward and forward incompatibilities *)
+}
+
+(* Findings affecting only 'c' are ignored. *)
+type c = {
+  deleted_field_in_ignored_type: int;
+}

atddiff/test/filter_backward/dune

@@ -0,0 +1,12 @@
+; Generated by ./generate-dune-rules
+; For adding tests, read the instructions in the Makefile.
+(rule
+ (targets filter.txt)
+ (deps filter_old.atd filter_new.atd)
+ (action (run %{bin:atddiff} %{deps} -o %{targets} --exit-success --backward)))
+
+(rule
+ (alias runtest)
+ (deps filter.txt)
+ (action (diff filter.expected.txt filter.txt)))
+

atddiff/test/filter_backward/filter.expected.txt

@@ -0,0 +1,15 @@
+Backward incompatibility:
+File "filter_new.atd", line 6, characters 2-18
+Required field 'added_field' is new.
+The following types are affected:
+  a
+  b
+
+Incompatibility in both directions:
+File "filter_old.atd", line 7, characters 16-20
+File "filter_new.atd", line 7, characters 16-23
+Type names 'int' and 'string' are not the same and may not be compatible.
+The following types are affected:
+  a
+  b
+

atddiff/test/filter_backward/filter_new.atd

@@ -0,0 +1,12 @@
+(*
+   Test that the command-line filters make the correct selection of findings.
+*)
+
+type a = {
+  added_field: int; (* backward incompatibility *)
+  changing_type: string;
+}
+
+type b = {
+  uses_a: a; (* backward and forward incompatibilities *)
+}

atddiff/test/filter_backward/filter_old.atd

@@ -0,0 +1,12 @@
+(*
+   Test that the command-line filters make the correct selection of findings.
+*)
+
+type a = {
+  deleted_field: int; (* forward incompatibility *)
+  changing_type: int;
+}
+
+type b = {
+  uses_a: a; (* backward and forward incompatibilities *)
+}

atddiff/test/filter_forward/dune

@@ -0,0 +1,12 @@
+; Generated by ./generate-dune-rules
+; For adding tests, read the instructions in the Makefile.
+(rule
+ (targets filter.txt)
+ (deps filter_old.atd filter_new.atd)
+ (action (run %{bin:atddiff} %{deps} -o %{targets} --exit-success --forward)))
+
+(rule
+ (alias runtest)
+ (deps filter.txt)
+ (action (diff filter.expected.txt filter.txt)))
+

atddiff/test/filter_forward/filter.expected.txt

@@ -0,0 +1,15 @@
+Forward incompatibility:
+File "filter_old.atd", line 6, characters 2-20
+Required field 'deleted_field' disappeared.
+The following types are affected:
+  a
+  b
+
+Incompatibility in both directions:
+File "filter_old.atd", line 7, characters 16-20
+File "filter_new.atd", line 7, characters 16-23
+Type names 'int' and 'string' are not the same and may not be compatible.
+The following types are affected:
+  a
+  b
+

atddiff/test/filter_forward/filter_new.atd

@@ -0,0 +1,12 @@
+(*
+   Test that the command-line filters make the correct selection of findings.
+*)
+
+type a = {
+  added_field: int; (* backward incompatibility *)
+  changing_type: string;
+}
+
+type b = {
+  uses_a: a; (* backward and forward incompatibilities *)
+}

atddiff/test/filter_forward/filter_old.atd

@@ -0,0 +1,12 @@
+(*
+   Test that the command-line filters make the correct selection of findings.
+*)
+
+type a = {
+  deleted_field: int; (* forward incompatibility *)
+  changing_type: int;
+}
+
+type b = {
+  uses_a: a; (* backward and forward incompatibilities *)
+}