Functorized diffing (with improved documentation) (#4)

.depend

@@ -708,7 +708,6 @@ typing/includecore.cmo : \
     typing/errortrace.cmi \
     typing/env.cmi \
     utils/diffing_with_keys.cmi \
-    utils/diffing.cmi \
     typing/ctype.cmi \
     parsing/builtin_attributes.cmi \
     typing/btype.cmi \
@@ -726,7 +725,6 @@ typing/includecore.cmx : \
     typing/errortrace.cmx \
     typing/env.cmx \
     utils/diffing_with_keys.cmx \
-    utils/diffing.cmx \
     typing/ctype.cmx \
     parsing/builtin_attributes.cmx \
     typing/btype.cmx \

typing/includecore.ml

@@ -138,7 +138,8 @@ type label_mismatch =
   | Mutability of position
 
 type record_change =
-  (Types.label_declaration, label_mismatch) Diffing_with_keys.change
+  (Types.label_declaration, Types.label_declaration, label_mismatch)
+    Diffing_with_keys.change
 
 type record_mismatch =
   | Label_mismatch of record_change list
@@ -170,7 +171,7 @@ type private_object_mismatch =
   | Types of Errortrace.equality_error
 
 type variant_change =
-  (Types.constructor_declaration, constructor_mismatch)
+  (Types.constructor_declaration as 'l, 'l, constructor_mismatch)
     Diffing_with_keys.change
 
 type type_mismatch =
@@ -460,9 +461,15 @@ module Record_diffing = struct
                 rem1 rem2
         end
 
-  let update
-      (d:(int * Types.label_declaration as 'a,'a,_,_) Diffing.change)
-      (params1,params2 as st) =
+  module Defs = struct
+    type left = Types.label_declaration
+    type right = left
+    type diff = label_mismatch
+    type state = type_expr list * type_expr list
+  end
+  module Diff = Diffing_with_keys.Define(Defs)
+
+  let update (d:Diff.change) (params1,params2 as st) =
     match d with
     | Insert _ | Change _ | Delete _ -> st
     | Keep (x,y,_) ->
@@ -471,8 +478,8 @@ module Record_diffing = struct
         (snd x).ld_type::params1, (snd y).ld_type::params2
 
   let test _loc env (params1,params2)
-      (pos, lbl1: _ * Types.label_declaration)
-      (_, lbl2: _ * Types.label_declaration)
+      (pos, lbl1: Diff.left)
+      (_, lbl2: Diff.right)
     =
     let name1, name2 = Ident.name lbl1.ld_id, Ident.name lbl2.ld_id in
     if  name1 <> name2 then
@@ -491,27 +498,27 @@ module Record_diffing = struct
           )
       | None -> Ok ()
 
-  let weight = function
-    | Diffing.Insert _ -> 10
-    | Diffing.Delete _ -> 10
-    | Diffing.Keep _ -> 0
-    | Diffing.Change (_,_,Diffing_with_keys.Name t ) ->
+  let weight: Diff.change -> _ = function
+    | Insert _ -> 10
+    | Delete _ -> 10
+    | Keep _ -> 0
+    | Change (_,_,Diffing_with_keys.Name t ) ->
         if t.types_match then 10 else 15
-    | Diffing.Change _ -> 10
+    | Change _ -> 10
+
 
-  let key (x: Types.label_declaration) = Ident.name x.ld_id
+
+  let key (x: Defs.left) = Ident.name x.ld_id
   let diffing loc env params1 params2 cstrs_1 cstrs_2 =
-    let test = test loc env in
-    let cstrs_1 = Diffing_with_keys.with_pos cstrs_1 in
-    let cstrs_2 = Diffing_with_keys.with_pos cstrs_2 in
-    let raw = Diffing.diff
-        ~weight
-        ~test
-        ~update (params1,params2)
-        (Array.of_list cstrs_1)
-        (Array.of_list cstrs_2)
+    let module Compute = Diff.Simple(struct
+        let key_left = key
+        let key_right = key
+        let update = update
+        let test = test loc env
+        let weight = weight
+      end)
     in
-    Diffing_with_keys.refine ~key ~update ~test (params1,params2) raw
+    Compute.diff (params1,params2) cstrs_1 cstrs_2
 
   let compare ~loc env params1 params2 l r =
     if equal ~loc env params1 params2 l r then
@@ -600,20 +607,26 @@ module Variant_diffing = struct
         | None -> true
       end) cstrs1 cstrs2
 
-  let update _ () = ()
+  module Defs = struct
+    type left = Types.constructor_declaration
+    type right = left
+    type diff = constructor_mismatch
+    type state = type_expr list * type_expr list
+  end
+  module D = Diffing_with_keys.Define(Defs)
+
+  let update _ st = st
 
-  let weight = function
-    | Diffing.Insert _ -> 10
-    | Diffing.Delete _ -> 10
-    | Diffing.Keep _ -> 0
-    | Diffing.Change (_,_,Diffing_with_keys.Name t) ->
+  let weight: D.change -> _ = function
+    | Insert _ -> 10
+    | Delete _ -> 10
+    | Keep _ -> 0
+    | Change (_,_,Diffing_with_keys.Name t) ->
         if t.types_match then 10 else 15
-    | Diffing.Change _ -> 10
+    | Change _ -> 10
 
 
-  let test loc env params1 params2 ()
-      (pos,cd1: _ * Types.constructor_declaration)
-      (_,cd2: _ * Types.constructor_declaration) =
+  let test loc env (params1,params2) (pos,cd1: D.left) (_,cd2: D.right) =
     let name1, name2 = Ident.name cd1.cd_id, Ident.name cd2.cd_id in
     if  name1 <> name2 then
       let types_match =
@@ -629,21 +642,19 @@ module Variant_diffing = struct
               cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with
       | Some reason ->
           Error (Diffing_with_keys.Type {pos; got=cd1; expected=cd2; reason})
-      | None -> Ok (Ident.name cd1.cd_id)
+      | None -> Ok ()
 
   let diffing loc env params1 params2 cstrs_1 cstrs_2 =
-    let test = test loc env params1 params2 in
-    let cstrs_1 = Diffing_with_keys.with_pos cstrs_1 in
-    let cstrs_2 = Diffing_with_keys.with_pos cstrs_2 in
-    let raw = Diffing.diff
-      ~weight
-      ~test
-      ~update ()
-      (Array.of_list cstrs_1)
-      (Array.of_list cstrs_2)
+    let key (x:Defs.left) = Ident.name x.cd_id in
+    let module Compute = D.Simple(struct
+        let key_left = key
+        let key_right = key
+        let test = test loc env
+        let update = update
+        let weight = weight
+      end)
     in
-    let key (x:Types.constructor_declaration) = Ident.name x.cd_id in
-    Diffing_with_keys.refine ~key ~update ~test () raw
+    Compute.diff (params1,params2) cstrs_1 cstrs_2
 
   let compare ~loc env params1 params2 l r =
     if equal ~loc env params1 params2 l r then

typing/includecore.mli

@@ -48,7 +48,7 @@ type label_mismatch =
   | Mutability of position
 
 type record_change =
-  (Types.label_declaration, label_mismatch) Diffing_with_keys.change
+  (Types.label_declaration as 'ld, 'ld, label_mismatch) Diffing_with_keys.change
 
 type record_mismatch =
   | Label_mismatch of record_change list
@@ -68,7 +68,7 @@ type extension_constructor_mismatch =
                             * extension_constructor
                             * constructor_mismatch
 type variant_change =
-  (Types.constructor_declaration, constructor_mismatch)
+  (Types.constructor_declaration as 'cd, 'cd, constructor_mismatch)
     Diffing_with_keys.change
 
 type private_variant_mismatch =

typing/includemod.ml

@@ -797,13 +797,27 @@ let compunit env ~mark impl_name impl_sig intf_name intf_sig =
  *)
 
 module Functor_inclusion_diff = struct
-  open Diffing
+
+  module Defs = struct
+    type left = Types.functor_parameter
+    type right = left
+    type eq = Typedtree.module_coercion
+    type diff = (Types.functor_parameter, unit) Error.functor_param_symptom
+    type state = {
+      res: module_type option;
+      env: Env.t;
+      subst: Subst.t;
+    }
+  end
+  open Defs
+
+  module Diff = Diffing.Define(Defs)
 
   let param_name = function
       | Named(x,_) -> x
       | Unit -> None
 
-  let weight = function
+  let weight: Diff.change -> _ = function
     | Insert _ -> 10
     | Delete _ -> 10
     | Change _ -> 10
@@ -818,11 +832,7 @@ module Functor_inclusion_diff = struct
         | Some _,  None | None, Some _ -> 1
       end
 
-  type state = {
-    res: module_type option;
-    env: Env.t;
-    subst: Subst.t;
-  }
+
 
   let keep_expansible_param = function
     | Mty_ident _ | Mty_alias _ as mty -> Some mty
@@ -842,7 +852,7 @@ module Functor_inclusion_diff = struct
     | None -> state, [||]
     | Some (res, expansion) -> { state with res }, expansion
 
-  let update d st = match d with
+  let update (d:Diff.change) st = match d with
     | Insert (Unit | Named (None,_))
     | Delete (Unit | Named (None,_))
     | Keep (Unit,_,_)
@@ -874,28 +884,38 @@ module Functor_inclusion_diff = struct
       end
 
   let diff env (l1,res1) (l2,_) =
-    let update = Diffing.With_left_extensions update in
-    let test st mty1 mty2 =
-      let loc = Location.none in
-      let res, _, _ =
-        functor_param ~loc st.env ~mark:Mark_neither st.subst mty1 mty2
-      in
-      res
+    let module Compute = Diff.Left_variadic(struct
+        let test st mty1 mty2 =
+          let loc = Location.none in
+          let res, _, _ =
+            functor_param ~loc st.env ~mark:Mark_neither st.subst mty1 mty2
+          in
+          res
+        let update = update
+        let weight = weight
+      end)
     in
     let param1 = Array.of_list l1 in
     let param2 = Array.of_list l2 in
     let state =
       { env; subst = Subst.identity; res = keep_expansible_param res1}
     in
-    Diffing.variadic_diff ~weight ~test ~update state param1 param2
+    Compute.diff state param1 param2
 
 end
 
 module Functor_app_diff = struct
   module I = Functor_inclusion_diff
-  open Diffing
-
-  let weight = function
+  module Defs= struct
+    type left = Error.functor_arg_descr * Types.module_type
+    type right = Types.functor_parameter
+    type eq = Typedtree.module_coercion
+    type diff = (Error.functor_arg_descr, unit) Error.functor_param_symptom
+    type state = I.Defs.state
+  end
+  module Diff = Diffing.Define(Defs)
+
+  let weight: Diff.change -> _ = function
     | Insert _ -> 10
     | Delete _ -> 10
     | Change _ -> 10
@@ -914,7 +934,7 @@ module Functor_app_diff = struct
           | Named _,  None | (Unit | Anonymous), Some _ -> 1
         end
 
-  let update (d: (_,Types.functor_parameter,_,_) change) (st:I.state) =
+  let update (d: Diff.change) (st:Defs.state) =
     let open Error in
     match d with
     | Insert _
@@ -958,29 +978,32 @@ module Functor_app_diff = struct
 
   let diff env ~f ~args =
     let params, res = retrieve_functor_params env f in
-    let update = Diffing.With_right_extensions update in
-    let test (state:I.state) (arg,arg_mty) param =
-      let loc = Location.none in
-      let res = match (arg:Error.functor_arg_descr), param with
-        | Unit, Unit -> Ok Tcoerce_none
-        | Unit, Named _ | (Anonymous | Named _), Unit ->
-            Result.Error (Error.Incompatible_params(arg,param))
-        | ( Anonymous | Named _ ) , Named (_, param) ->
-            match
-              modtypes ~loc state.env ~mark:Mark_neither state.subst
-                arg_mty param
-            with
-            | Error mty -> Result.Error (Error.Mismatch mty)
-            | Ok _ as x -> x
-      in
-      res
+    let module Compute = Diff.Right_variadic(struct
+        let update = update
+        let test (state:Defs.state) (arg,arg_mty) param =
+          let loc = Location.none in
+          let res = match (arg:Error.functor_arg_descr), param with
+            | Unit, Unit -> Ok Tcoerce_none
+            | Unit, Named _ | (Anonymous | Named _), Unit ->
+                Result.Error (Error.Incompatible_params(arg,param))
+            | ( Anonymous | Named _ ) , Named (_, param) ->
+                match
+                  modtypes ~loc state.env ~mark:Mark_neither state.subst
+                    arg_mty param
+                with
+                | Error mty -> Result.Error (Error.Mismatch mty)
+                | Ok _ as x -> x
+          in
+          res
+        let weight = weight
+      end)
     in
     let args = Array.of_list args in
     let params = Array.of_list params in
-    let state : I.state =
+    let state : Defs.state =
       { env; subst = Subst.identity; res = I.keep_expansible_param res }
     in
-    Diffing.variadic_diff ~weight ~test ~update state args params
+    Compute.diff state args params
 
 end
 

typing/includemod.mli

@@ -217,22 +217,30 @@ exception Apply_error of {
 val expand_module_alias: Env.t -> Path.t -> Types.module_type
 
 module Functor_inclusion_diff: sig
+  module Defs: sig
+    type left = Types.functor_parameter
+    type right = left
+    type eq = Typedtree.module_coercion
+    type diff = (Types.functor_parameter, unit) Error.functor_param_symptom
+    type state
+  end
   val diff: Env.t ->
-           Types.functor_parameter list * Types.module_type ->
-           Types.functor_parameter list * Types.module_type ->
-           (Types.functor_parameter, Types.functor_parameter,
-            Typedtree.module_coercion,
-            (Types.functor_parameter, 'c) Error.functor_param_symptom)
-           Diffing.patch
+    Types.functor_parameter list * Types.module_type ->
+    Types.functor_parameter list * Types.module_type ->
+    Diffing.Define(Defs).patch
 end
 
 module Functor_app_diff: sig
+  module Defs: sig
+    type left = Error.functor_arg_descr * Types.module_type
+    type right = Types.functor_parameter
+    type eq = Typedtree.module_coercion
+    type diff = (Error.functor_arg_descr, unit) Error.functor_param_symptom
+    type state
+  end
   val diff:
     Env.t ->
     f:Types.module_type ->
     args:(Error.functor_arg_descr * Types.module_type) list ->
-    (Error.functor_arg_descr * Types.module_type,
-     Types.functor_parameter, Typedtree.module_coercion,
-     (Error.functor_arg_descr, 'a) Error.functor_param_symptom)
-      Diffing.patch
+    Diffing.Define(Defs).patch
 end