use expand_head to check type of functions

Author: tsnobip

jscomp/ml/includemod.ml

@@ -533,28 +533,22 @@ let show_locs ppf (loc1, loc2) =
   show_loc "Expected declaration" ppf loc2;
   show_loc "Actual declaration" ppf loc1
 
-let include_err ppf = function
+let include_err ~env ppf = function
   | Missing_field (id, loc, kind) ->
       fprintf ppf "The %s `%a' is required but not provided" kind ident id;
       show_loc "Expected declaration" ppf loc
-  | Value_descriptions(id, 
-      ({ val_type = { desc = Tlink { desc = Tconstr (Pident {name = "function$"},_,_) }}} as d1), 
-      ({ val_type = { desc = Tarrow _ }} as d2)) ->
-          fprintf ppf
-            "@[<hv 2>Values do not match:@ %a (uncurried)@;<1 -2>is not included in@ %a (curried)@]"
-            (value_description id) d1 (value_description id) d2;
-          show_locs ppf (d1.val_loc, d2.val_loc)
-  | Value_descriptions(id, 
-      ({ val_type = { desc = Tlink { desc = Tarrow _ }}} as d1), 
-      ({ val_type = { desc = Tconstr (Pident {name = "function$"},_,_)}} as d2)) ->
-          fprintf ppf
-            "@[<hv 2>Values do not match:@ %a (curried)@;<1 -2>is not included in@ %a (uncurried)@]"
-            (value_description id) d1 (value_description id) d2;
-          show_locs ppf (d1.val_loc, d2.val_loc)
   | Value_descriptions(id, d1, d2) ->
+      let curry_kind_1, curry_kind_2 = 
+        match (Ctype.expand_head env d1.val_type,  Ctype.expand_head env d2.val_type ) with 
+        | { desc = Tarrow _ }, 
+            { desc = Tconstr (Pident {name = "function$"},_,_)} -> (" (curried)", " (uncurried)")
+        | { desc = Tconstr (Pident {name = "function$"},_,_)}, 
+            { desc = Tarrow _ } -> (" (uncurried)", " (curried)")
+        | _ -> ("", "")
+      in
       fprintf ppf
-        "@[<hv 2>Values do not match:@ %a@;<1 -2>is not included in@ %a@]"
-        (value_description id) d1 (value_description id) d2;
+        "@[<hv 2>Values do not match:@ %a%s@;<1 -2>is not included in@ %a%s@]"
+        (value_description id) d1 curry_kind_1 (value_description id) d2 curry_kind_2;
       show_locs ppf (d1.val_loc, d2.val_loc);
   | Type_declarations(id, d1, d2, errs) ->
       fprintf ppf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
@@ -647,7 +641,7 @@ let context ppf cxt =
 
 let include_err ppf (cxt, env, err) =
   Printtyp.wrap_printing_env env (fun () ->
-    fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err)
+    fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) (include_err ~env) err)
 
 let buffer = ref Bytes.empty
 let is_big obj =