detect class declaration (#90)

marcndo · NathanReb · web-flow · commit a1506538a641 · 2024-10-29T05:35:21.000+01:00
* detect class declaration

* add test for class declaration

* add cram test for class declaration

* Polish changelog

Signed-off-by: Nathan Rebours &lt;nathan.p.rebours@gmail.com&gt;

---------

Signed-off-by: Nathan Rebours &lt;nathan.p.rebours@gmail.com&gt;
Co-authored-by: Nathan Rebours &lt;nathan.p.rebours@gmail.com&gt;
diff --git a/CHANGES.md b/CHANGES.md
@@ -2,9 +2,9 @@
 
 ### Added
 
-- Add detection of modified type declarations
-(#92, @azzsal) 
-- Add support for module_type declarations (#93, @NchamJosephMuam)
+- Add detection of modified type declarations (#92, @azzsal)
+- Add detection of module_type declarations changes (#93, @NchamJosephMuam)
+- Add detection of classes addition and removal (#90, @marcndo)
 
 ### Changed
 
diff --git a/lib/diff.ml b/lib/diff.ml
@@ -17,6 +17,13 @@ type type_ = {
   tdiff : (type_declaration, type_declaration atomic_modification) t;
 }
 
+type class_modification = Unsupported
+
+and class_ = {
+  cname : string;
+  cdiff : (class_declaration, class_modification) t;
+}
+
 type module_ = {
   mname : string;
   mdiff : (module_declaration, signature_modification) t;
@@ -34,6 +41,7 @@ and sig_item =
   | Module of module_
   | Type of type_
   | Modtype of modtype
+  | Class of class_
 
 let extract_items items =
   List.fold_left
@@ -50,6 +58,8 @@ let extract_items items =
       | Sig_type (id, type_decl, _, _) ->
           Sig_item_map.add ~name:(Ident.name id) Sig_item_map.Type
             (type_decl, id) tbl
+      | Sig_class (id, cls_decl, _, _) ->
+          Sig_item_map.add ~name:(Ident.name id) Sig_item_map.Class cls_decl tbl
       | _ -> tbl)
     Sig_item_map.empty items
 
@@ -110,6 +120,14 @@ let value_item ~typing_env ~name ~reference ~current =
           Some (Value { vname = name; vdiff = Modified { reference; current } })
       )
 
+let class_item ~name ~(reference : class_declaration option)
+    ~(current : class_declaration option) =
+  match (reference, current) with
+  | None, None -> None
+  | None, Some curr_cls -> Some (Class { cname = name; cdiff = Added curr_cls })
+  | Some ref_cls, None -> Some (Class { cname = name; cdiff = Removed ref_cls })
+  | Some _, Some _ -> None
+
 let rec items ~reference ~current =
   let env = Typing_env.for_diff ~reference ~current in
   let ref_items = extract_items reference in
@@ -121,6 +139,7 @@ let rec items ~reference ~current =
     | Module -> module_item ~typing_env:env ~name ~reference ~current
     | Modtype -> module_type_item ~typing_env:env ~name ~reference ~current
     | Type -> type_item ~typing_env:env ~name ~reference ~current
+    | Class -> class_item ~name ~reference ~current
   in
   Sig_item_map.diff ~diff_item:{ diff_item } ref_items curr_items
 
diff --git a/lib/diff.mli b/lib/diff.mli
@@ -7,6 +7,13 @@ type value = {
     (Types.value_description, Types.value_description atomic_modification) t;
 }
 
+type class_ = {
+  cname : string;
+  cdiff : (Types.class_declaration, class_modification) t;
+}
+
+and class_modification = Unsupported
+
 type type_ = {
   tname : string;
   tdiff : (Types.type_declaration, Types.type_declaration atomic_modification) t;
@@ -29,6 +36,7 @@ and sig_item =
   | Module of module_
   | Type of type_
   | Modtype of modtype
+  | Class of class_
 
 val interface :
   module_name:string ->
diff --git a/lib/sig_item_map.ml b/lib/sig_item_map.ml
@@ -5,20 +5,23 @@ type t = {
   modules_map : module_declaration String_map.t;
   modtypes_map : modtype_declaration String_map.t;
   types_map : (type_declaration * Ident.t) String_map.t;
+  class_map : class_declaration String_map.t;
 }
 
 type _ item_type =
   | Value : value_description item_type
   | Module : module_declaration item_type
   | Modtype : modtype_declaration item_type
   | Type : (type_declaration * Ident.t) item_type
+  | Class : class_declaration item_type
 
 let empty : t =
   {
     values_map = String_map.empty;
     modules_map = String_map.empty;
     modtypes_map = String_map.empty;
     types_map = String_map.empty;
+    class_map = String_map.empty;
   }
 
 let add (type a) ~name (item_type : a item_type) (item : a) maps : t =
@@ -29,6 +32,7 @@ let add (type a) ~name (item_type : a item_type) (item : a) maps : t =
   | Modtype ->
       { maps with modtypes_map = String_map.add name item maps.modtypes_map }
   | Type -> { maps with types_map = String_map.add name item maps.types_map }
+  | Class -> { maps with class_map = String_map.add name item maps.class_map }
 
 type ('a, 'diff) diff_item =
   'a item_type -> string -> 'a option -> 'a option -> 'diff option
@@ -60,4 +64,10 @@ let diff ~diff_item:{ diff_item } ref_maps curr_maps : 'diff list =
       ref_maps.types_map curr_maps.types_map
     |> String_map.bindings |> List.map snd
   in
-  value_diffs @ module_diffs @ modtype_diffs @ type_diffs
+  let class_diffs =
+    String_map.merge
+      (fun name ref_opt curr_opt -> diff_item Class name ref_opt curr_opt)
+      ref_maps.class_map curr_maps.class_map
+    |> String_map.bindings |> List.map snd
+  in
+  value_diffs @ module_diffs @ modtype_diffs @ type_diffs @ class_diffs
diff --git a/lib/sig_item_map.mli b/lib/sig_item_map.mli
@@ -7,6 +7,7 @@ type _ item_type =
   | Module : module_declaration item_type
   | Modtype : modtype_declaration item_type
   | Type : (type_declaration * Ident.t) item_type
+  | Class : class_declaration item_type
 
 val empty : t
 val add : name:string -> 'a item_type -> 'a -> t -> t
diff --git a/lib/text_diff.ml b/lib/text_diff.ml
@@ -56,6 +56,14 @@ let mtd_to_lines name mtd =
       let abstract_module_type_str = "module type " ^ name in
       CCString.lines abstract_module_type_str
 
+let cd_to_lines name cd =
+  let buf = Buffer.create 256 in
+  let formatter = Format.formatter_of_buffer buf in
+  Printtyp.class_declaration (Ident.create_local name) formatter cd;
+  Format.pp_print_flush formatter ();
+  let class_str = Buffer.contents buf in
+  CCString.lines class_str
+
 let process_diff (diff : (_, _ Diff.atomic_modification) Diff.t) name to_lines =
   match diff with
   | Added item -> [ { orig = []; new_ = to_lines name item } ]
@@ -69,6 +77,12 @@ let process_value_diff (val_diff : Diff.value) =
 let process_type_diff (type_diff : Diff.type_) =
   process_diff type_diff.tdiff type_diff.tname td_to_lines
 
+let process_class_diff (class_diff : Diff.class_) =
+  match class_diff.cdiff with
+  | Added cd -> [ { orig = []; new_ = cd_to_lines class_diff.cname cd } ]
+  | Removed cd -> [ { orig = cd_to_lines class_diff.cname cd; new_ = [] } ]
+  | Modified _ -> []
+
 let rec process_sig_diff :
     type a. _ -> (string -> a -> string list) -> (a, _) Diff.t * _ -> _ -> _ =
  fun path to_lines ((diff : (a, _) Diff.t), name) acc ->
@@ -115,6 +129,12 @@ and signature_changes module_path items acc =
             (function
               | None -> Some diff | Some existing -> Some (existing @ diff))
             acc'
+      | Class class_diff ->
+          let diff = process_class_diff class_diff in
+          String_map.update module_path
+            (function
+              | None -> Some diff | Some existing -> Some (existing @ diff))
+            acc'
       | Module sub_module_diff ->
           let sub_module_path =
             match sub_module_diff.mdiff with
diff --git a/tests/api-diff/class_detection.t b/tests/api-diff/class_detection.t
@@ -0,0 +1,55 @@
+Here we generate a `.mli` file with the class declaration:
+
+  $ cat > ref_class.mli << EOF
+  > class ref_class : object
+  >   method get : int
+  >   method set : int -> unit
+  > end 
+  > EOF
+
+We generate .cmi file
+  $ ocamlc ref_class.mli
+
+Now, we run api-diff on the same cmi file as both arguments, there should be no difference
+  $ api-diff ref_class.cmi ref_class.cmi
+
+### Adding a new class:
+
+Generate a new .mli file with an additional class
+  $ cat > add_class.mli << EOF
+  > class ref_class : object
+  >    method get : int 
+  >    method set : int -> unit
+  > end
+  > class add_class : object
+  >    method calculate : float -> float
+  > end
+  > EOF
+
+Compile the new .mli file to a .cmi file
+  $ ocamlc add_class.mli
+
+Run api-diff and check the output
+  $ api-diff ref_class.cmi add_class.cmi
+  diff module Add_class:
+  +type add_class = < calculate : float -> float >
+  +class add_class : object method calculate : float -> float end
+  
+  [1]
+
+### Removing a class:
+
+Generate a new .mli file with the class now removed
+  $ cat > remove_class.mli << EOF
+  > EOF
+
+Compile the new .mli file to a .cmi file
+  $ ocamlc remove_class.mli
+
+Run api-diff and check the output
+  $ api-diff ref_class.cmi remove_class.cmi
+  diff module Remove_class:
+  -type ref_class = < get : int; set : int -> unit >
+  -class ref_class : object method get : int method set : int -> unit end
+  
+  [1]
diff --git a/tests/api-watch/test_diff_class.ml b/tests/api-watch/test_diff_class.ml
@@ -0,0 +1,76 @@
+open Api_watch
+open Test_helpers
+
+let%expect_test "Class Addition" =
+  let reference =
+    {|
+  class cls1 : object
+    method m1 : int -> int
+  end
+  class cls2 : object
+    method m2 : string -> string
+  end
+|}
+  in
+  let current =
+    {|
+  class cls1 : object
+    method m1 : int -> int
+  end
+  class cls2 : object
+    method m2 : string -> string
+  end
+  class cls3 : object
+    method m3 : float -> float
+  end
+|}
+  in
+  try
+    let ref_compiled = compile_interface reference in
+    let curr_compiled = compile_interface current in
+    let result =
+      Diff.interface ~module_name:"Main" ~reference:ref_compiled
+        ~current:curr_compiled
+    in
+    Format.printf "%a" pp_diff_option result;
+    [%expect
+      {|
+    Some (Module Main: {Modified (Supported [ Type (cls3, Added);
+    Class (cls3, Added)])})
+    |}]
+  with e ->
+    Format.printf "Error: %s" (Printexc.to_string e);
+    [%expect.unreachable]
+
+let%expect_test "Class Removal" =
+  let reference =
+    {|
+  class cls1 : object
+    method m1 : int -> int
+  end
+  class cls2 : object
+    method m2 : string -> string
+  end
+|}
+  in
+  let current = {|
+  class cls1 : object
+    method m1 : int -> int
+  end
+|} in
+  try
+    let ref_compiled = compile_interface reference in
+    let curr_compiled = compile_interface current in
+    let result =
+      Diff.interface ~module_name:"Main" ~reference:ref_compiled
+        ~current:curr_compiled
+    in
+    Format.printf "%a" pp_diff_option result;
+    [%expect
+      {|
+    Some (Module Main: {Modified (Supported [ Type (cls2, Removed);
+    Class (cls2, Removed)])})
+    |}]
+  with e ->
+    Format.printf "Error: %s" (Printexc.to_string e);
+    [%expect.unreachable]
diff --git a/tests/test_helpers/test_helpers.ml b/tests/test_helpers/test_helpers.ml
@@ -14,6 +14,7 @@ and pp_item_diff fmt = function
   | Module module_diff -> pp_module_diff fmt module_diff
   | Type type_diff -> pp_type_diff fmt type_diff
   | Modtype module_type_diff -> pp_module_type_diff fmt module_type_diff
+  | Class class_diff -> pp_class_diff fmt class_diff
 
 and pp_value_diff fmt { vname; vdiff } =
   match vdiff with
@@ -43,6 +44,12 @@ and pp_module_type_diff fmt { mtname; mtdiff } =
       Format.fprintf fmt "Module_type %s: {Modified (%a)}" mtname
         pp_module_modification mtdiff
 
+and pp_class_diff fmt { cname; cdiff } =
+  match cdiff with
+  | Added _ -> Format.fprintf fmt "Class (%s, Added)" cname
+  | Removed _ -> Format.fprintf fmt "Class (%s, Removed)" cname
+  | Modified _ -> Format.fprintf fmt "Class (%s, Modified)" cname
+
 let pp_diff_option fmt = function
   | None -> Format.fprintf fmt "None"
   | Some module_diff ->
