From 82ef71003b84522c06632fc3c359fcb6b7ef60ae Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 18 Mar 2022 15:43:28 +0200 Subject: [PATCH 1/4] Add eq and ord tests with constructors conflicting with result --- src_test/eq/test_deriving_eq.cppo.ml | 7 +++++++ src_test/ord/test_deriving_ord.cppo.ml | 7 +++++++ 2 files changed, 14 insertions(+) diff --git a/src_test/eq/test_deriving_eq.cppo.ml b/src_test/eq/test_deriving_eq.cppo.ml index a2c4674..b0521ab 100644 --- a/src_test/eq/test_deriving_eq.cppo.ml +++ b/src_test/eq/test_deriving_eq.cppo.ml @@ -148,6 +148,13 @@ let test_result_result ctxt = assert_equal ~printer false (eq (Ok "123") (Error 123)); assert_equal ~printer false (eq (Error 123) (Error 0)) +module ResultOverride = struct + type t = + | Ok + | Error + [@@deriving eq] +end + let suite = "Test deriving(eq)" >::: [ "test_simple" >:: test_simple; "test_array" >:: test_arr; diff --git a/src_test/ord/test_deriving_ord.cppo.ml b/src_test/ord/test_deriving_ord.cppo.ml index fdd4d0d..51e8849 100644 --- a/src_test/ord/test_deriving_ord.cppo.ml +++ b/src_test/ord/test_deriving_ord.cppo.ml @@ -179,6 +179,13 @@ let test_record_order ctxt = assert_equal ~printer (0) (compare_ab { a = 1; b = 2; } { a = 1; b = 2; }); assert_equal ~printer (1) (compare_ab { a = 2; b = 2; } { a = 1; b = 2; }) +module ResultOverride = struct + type t = + | Ok + | Error + [@@deriving ord] +end + let suite = "Test deriving(ord)" >::: [ "test_simple" >:: test_simple; "test_variant" >:: test_variant; From 6eb57458049b25eba244403eb4b95ed87a3e3473 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 18 Mar 2022 16:54:54 +0200 Subject: [PATCH 2/4] Add constraint to ord variant wildcard_case to_int (closes #254) --- src_plugins/ord/ppx_deriving_ord.cppo.ml | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/src_plugins/ord/ppx_deriving_ord.cppo.ml b/src_plugins/ord/ppx_deriving_ord.cppo.ml index c36d57d..df3137f 100644 --- a/src_plugins/ord/ppx_deriving_ord.cppo.ml +++ b/src_plugins/ord/ppx_deriving_ord.cppo.ml @@ -35,10 +35,10 @@ let reduce_compare l = | [] -> [%expr 0] | x :: xs -> List.fold_left compare_reduce x xs -let wildcard_case int_cases = +let wildcard_case ~typ int_cases = let loc = !Ast_helper.default_loc in Exp.case [%pat? _] [%expr - let to_int = [%e Exp.function_ int_cases] in + let to_int: [%t typ] -> Ppx_deriving_runtime.int = [%e Exp.function_ int_cases] in Ppx_deriving_runtime.compare (to_int lhs) (to_int rhs)] let pattn side typs = @@ -163,7 +163,7 @@ and expr_of_typ quoter typ = | _ -> assert false) in [%expr fun lhs rhs -> - [%e Exp.match_ [%expr lhs, rhs] (cases @ [wildcard_case int_cases])]] + [%e Exp.match_ [%expr lhs, rhs] (cases @ [wildcard_case ~typ int_cases])]] | { ptyp_desc = Ptyp_var name } -> evar ("poly_"^name) | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ | { ptyp_loc } -> @@ -208,7 +208,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = ) in [%expr fun lhs rhs -> - [%e Exp.match_ [%expr lhs, rhs] (cases @ [wildcard_case int_cases])]] + [%e Exp.match_ [%expr lhs, rhs] (cases @ [wildcard_case ~typ:[%type: Ppx_deriving_ord_helper.t] int_cases])]] | Ptype_record labels, _ -> let exprs = labels |> List.map (fun ({ pld_name = { txt = name }; _ } as pld) -> @@ -235,9 +235,23 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = core_type_of_decl ~options ~path type_decl in let out_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "compare") type_decl) in + (* Capture type in helper module outside Ppx_deriving_runtime wrapper (added by sanitize). + Required for to_int constraint in variant type wildcard_case if the type name + conflicts with a Stdlib type from Ppx_deriving_runtime (e.g. bool in test). + In that case we must refer to the type being declared, not the one opened by Ppx_deriving_runtime. *) + let helper_type = + Type.mk ~loc ~attrs:[Ppx_deriving.attr_warning [%expr "-unused-type-declaration"]] + ~params:type_decl.ptype_params + ~manifest:(Ppx_deriving.core_type_of_type_decl type_decl) + (mkloc "t" loc) + in + let comparator_with_helper = + [%expr let module Ppx_deriving_ord_helper = struct [%%i Str.type_ Nonrecursive [helper_type]] end in + [%e Ppx_deriving.sanitize ~quoter (eta_expand (polymorphize comparator))]] + in [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]] (Pat.constraint_ out_var out_type) - (Ppx_deriving.sanitize ~quoter (eta_expand (polymorphize comparator)))] + comparator_with_helper] let () = Ppx_deriving.(register (create deriver From 3e43c9651af57b94fd0844214a84cc76c79cfb77 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Sat, 19 Mar 2022 18:23:16 +0200 Subject: [PATCH 3/4] Fix ord variant wildcard_case to_int type pre-OCaml 4.11 (PR #260) --- src_plugins/ord/ppx_deriving_ord.cppo.ml | 40 +++++++++++++++--------- src_test/eq/test_deriving_eq.cppo.ml | 2 ++ src_test/ord/test_deriving_ord.cppo.ml | 2 ++ 3 files changed, 30 insertions(+), 14 deletions(-) diff --git a/src_plugins/ord/ppx_deriving_ord.cppo.ml b/src_plugins/ord/ppx_deriving_ord.cppo.ml index df3137f..b5c9399 100644 --- a/src_plugins/ord/ppx_deriving_ord.cppo.ml +++ b/src_plugins/ord/ppx_deriving_ord.cppo.ml @@ -35,10 +35,14 @@ let reduce_compare l = | [] -> [%expr 0] | x :: xs -> List.fold_left compare_reduce x xs -let wildcard_case ~typ int_cases = +let wildcard_case ?typ int_cases = let loc = !Ast_helper.default_loc in + let typ = match typ with + | Some typ -> typ + | None -> [%type: _] (* don't constrain *) + in Exp.case [%pat? _] [%expr - let to_int: [%t typ] -> Ppx_deriving_runtime.int = [%e Exp.function_ int_cases] in + let to_int (x: [%t typ]) = [%e Exp.match_ [%expr x] int_cases] in Ppx_deriving_runtime.compare (to_int lhs) (to_int rhs)] let pattn side typs = @@ -163,7 +167,7 @@ and expr_of_typ quoter typ = | _ -> assert false) in [%expr fun lhs rhs -> - [%e Exp.match_ [%expr lhs, rhs] (cases @ [wildcard_case ~typ int_cases])]] + [%e Exp.match_ [%expr lhs, rhs] (cases @ [wildcard_case int_cases])]] | { ptyp_desc = Ptyp_var name } -> evar ("poly_"^name) | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ | { ptyp_loc } -> @@ -185,6 +189,24 @@ let sig_of_type ~options ~path type_decl = let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = parse_options options; let quoter = Ppx_deriving.create_quoter () in + (* Capture type in helper module outside Ppx_deriving_runtime wrapper (added by sanitize). + Required for to_int constraint in variant type wildcard_case if the type name + conflicts with a Stdlib type from Ppx_deriving_runtime (e.g. bool in test). + In that case we must refer to the type being declared, not the one opened by Ppx_deriving_runtime. *) + let helper_type = + Type.mk ~loc ~attrs:[Ppx_deriving.attr_warning [%expr "-unused-type-declaration"]] + ~params:type_decl.ptype_params + ~manifest:(Ppx_deriving.core_type_of_type_decl type_decl) + (mkloc "t" loc) + in + let helper_typ = + let name = mkloc (Longident.parse "Ppx_deriving_ord_helper.t") loc in + let params = match helper_type.ptype_params with + | [] -> [] + | _ :: _ -> [Typ.any ()] (* match all params with single wildcard *) + in + Typ.constr name params + in let comparator = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> expr_of_typ quoter manifest @@ -208,7 +230,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = ) in [%expr fun lhs rhs -> - [%e Exp.match_ [%expr lhs, rhs] (cases @ [wildcard_case ~typ:[%type: Ppx_deriving_ord_helper.t] int_cases])]] + [%e Exp.match_ [%expr lhs, rhs] (cases @ [wildcard_case ~typ:helper_typ int_cases])]] | Ptype_record labels, _ -> let exprs = labels |> List.map (fun ({ pld_name = { txt = name }; _ } as pld) -> @@ -235,16 +257,6 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = core_type_of_decl ~options ~path type_decl in let out_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "compare") type_decl) in - (* Capture type in helper module outside Ppx_deriving_runtime wrapper (added by sanitize). - Required for to_int constraint in variant type wildcard_case if the type name - conflicts with a Stdlib type from Ppx_deriving_runtime (e.g. bool in test). - In that case we must refer to the type being declared, not the one opened by Ppx_deriving_runtime. *) - let helper_type = - Type.mk ~loc ~attrs:[Ppx_deriving.attr_warning [%expr "-unused-type-declaration"]] - ~params:type_decl.ptype_params - ~manifest:(Ppx_deriving.core_type_of_type_decl type_decl) - (mkloc "t" loc) - in let comparator_with_helper = [%expr let module Ppx_deriving_ord_helper = struct [%%i Str.type_ Nonrecursive [helper_type]] end in [%e Ppx_deriving.sanitize ~quoter (eta_expand (polymorphize comparator))]] diff --git a/src_test/eq/test_deriving_eq.cppo.ml b/src_test/eq/test_deriving_eq.cppo.ml index b0521ab..6a7c0b6 100644 --- a/src_test/eq/test_deriving_eq.cppo.ml +++ b/src_test/eq/test_deriving_eq.cppo.ml @@ -131,6 +131,8 @@ and 'a poly_abs_custom = 'a module List = struct type 'a t = [`Cons of 'a | `Nil] [@@deriving eq] + type 'a u = Cons of 'a | Nil + [@@deriving eq] end type 'a std_clash = 'a List.t option [@@deriving eq] diff --git a/src_test/ord/test_deriving_ord.cppo.ml b/src_test/ord/test_deriving_ord.cppo.ml index 51e8849..ab23f9d 100644 --- a/src_test/ord/test_deriving_ord.cppo.ml +++ b/src_test/ord/test_deriving_ord.cppo.ml @@ -158,6 +158,8 @@ and 'a poly_abs_custom = 'a module List = struct type 'a t = [`Cons of 'a | `Nil] [@@deriving ord] + type 'a u = Cons of 'a | Nil + [@@deriving ord] end type 'a std_clash = 'a List.t option [@@deriving ord] From b913d33692be12ccfc065e9b3084d429ce515e59 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Sat, 19 Mar 2022 19:29:45 +0200 Subject: [PATCH 4/4] Fix ord unused-type-declaration warning disable pre-OCaml 4.08 (PR #260) Workaround for https://github.com/ocaml/ocaml/pull/1977. --- src_plugins/ord/ppx_deriving_ord.cppo.ml | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src_plugins/ord/ppx_deriving_ord.cppo.ml b/src_plugins/ord/ppx_deriving_ord.cppo.ml index b5c9399..0e781d9 100644 --- a/src_plugins/ord/ppx_deriving_ord.cppo.ml +++ b/src_plugins/ord/ppx_deriving_ord.cppo.ml @@ -194,7 +194,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = conflicts with a Stdlib type from Ppx_deriving_runtime (e.g. bool in test). In that case we must refer to the type being declared, not the one opened by Ppx_deriving_runtime. *) let helper_type = - Type.mk ~loc ~attrs:[Ppx_deriving.attr_warning [%expr "-unused-type-declaration"]] + Type.mk ~loc ~params:type_decl.ptype_params ~manifest:(Ppx_deriving.core_type_of_type_decl type_decl) (mkloc "t" loc) @@ -258,7 +258,12 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = let out_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "compare") type_decl) in let comparator_with_helper = - [%expr let module Ppx_deriving_ord_helper = struct [%%i Str.type_ Nonrecursive [helper_type]] end in + [%expr let module Ppx_deriving_ord_helper = + struct + [@@@warning "-unused-type-declaration"] + [%%i Str.type_ Nonrecursive [helper_type]] + end + in [%e Ppx_deriving.sanitize ~quoter (eta_expand (polymorphize comparator))]] in [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]]