695 lines
23 KiB
OCaml
695 lines
23 KiB
OCaml
|
(* Generated code should depend on the environment in scope as little as possible.
|
||
|
|
E.g. rather than [foo = []] do [match foo with [] ->], to eliminate the use of [=]. It
|
||
|
|
is especially important to not use polymorphic comparisons, since we are moving more
|
||
|
|
and more to code that doesn't have them in scope. *)
|
||
|
|
|
||
|
|
(* Note: I am introducing a few unnecessary explicit closures, (not all of them some are
|
||
|
|
unnecessary due to the value restriction).
|
||
|
|
*)
|
||
|
|
|
||
|
|
open Base
|
||
|
|
open Ppxlib
|
||
|
|
open Ast_builder.Default
|
||
|
|
include Ppx_compare_expander_intf
|
||
|
|
|
||
|
|
(* Two-argument function, possibly with [local_] arguments *)
|
||
|
|
let ptyp_arrow2 ~loc ~local_args arg1 arg2 res =
|
||
|
|
if local_args
|
||
|
|
then [%type: [%t arg1] -> [%t arg2] -> [%t res]]
|
||
|
|
else [%type: [%t arg1] -> [%t arg2] -> [%t res]]
|
||
|
|
;;
|
||
|
|
|
||
|
|
type kind =
|
||
|
|
| Compare
|
||
|
|
| Equal
|
||
|
|
|
||
|
|
module type Params = sig
|
||
|
|
val name : string
|
||
|
|
val kind : kind
|
||
|
|
val chain : expression -> expression -> expression
|
||
|
|
val const : loc:Location.t -> Ordering.t -> expression
|
||
|
|
val result_type : loc:Location.t -> core_type
|
||
|
|
val poly : loc:Location.t -> expression -> expression -> expression
|
||
|
|
|
||
|
|
val abstract
|
||
|
|
: loc:Location.t
|
||
|
|
-> type_name:string
|
||
|
|
-> expression
|
||
|
|
-> expression
|
||
|
|
-> expression
|
||
|
|
|
||
|
|
module Attrs : Attrs
|
||
|
|
end
|
||
|
|
|
||
|
|
module Make_attrs (Name : sig
|
||
|
|
val name : string
|
||
|
|
end) : Attrs = struct
|
||
|
|
let ignore_label_declaration =
|
||
|
|
Attribute.declare
|
||
|
|
(Name.name ^ ".ignore")
|
||
|
|
Attribute.Context.label_declaration
|
||
|
|
Ast_pattern.(pstr nil)
|
||
|
|
()
|
||
|
|
;;
|
||
|
|
|
||
|
|
let ignore_core_type =
|
||
|
|
Attribute.declare
|
||
|
|
(Name.name ^ ".ignore")
|
||
|
|
Attribute.Context.core_type
|
||
|
|
Ast_pattern.(pstr nil)
|
||
|
|
()
|
||
|
|
;;
|
||
|
|
end
|
||
|
|
|
||
|
|
module Compare_params : Params = struct
|
||
|
|
let name = "compare"
|
||
|
|
let kind = Compare
|
||
|
|
|
||
|
|
let chain a b =
|
||
|
|
let loc = a.pexp_loc in
|
||
|
|
[%expr
|
||
|
|
match [%e a] with
|
||
|
|
| 0 -> [%e b]
|
||
|
|
| n -> n]
|
||
|
|
;;
|
||
|
|
|
||
|
|
let const ~loc (ord : Ordering.t) =
|
||
|
|
eint
|
||
|
|
~loc
|
||
|
|
(match ord with
|
||
|
|
| Less -> -1
|
||
|
|
| Equal -> 0
|
||
|
|
| Greater -> 1)
|
||
|
|
;;
|
||
|
|
|
||
|
|
let result_type ~loc = [%type: int]
|
||
|
|
let poly ~loc a b = [%expr Stdlib.compare [%e a] [%e b]]
|
||
|
|
|
||
|
|
let abstract ~loc ~type_name a b =
|
||
|
|
[%expr
|
||
|
|
Ppx_compare_lib.compare_abstract
|
||
|
|
~type_name:[%e estring ~loc type_name]
|
||
|
|
[%e a]
|
||
|
|
[%e b]]
|
||
|
|
;;
|
||
|
|
|
||
|
|
module Attrs = Make_attrs (struct
|
||
|
|
let name = name
|
||
|
|
end)
|
||
|
|
end
|
||
|
|
|
||
|
|
module Equal_params : Params = struct
|
||
|
|
let name = "equal"
|
||
|
|
let kind = Equal
|
||
|
|
|
||
|
|
let chain a b =
|
||
|
|
let loc = a.pexp_loc in
|
||
|
|
[%expr Stdlib.( && ) [%e a] [%e b]]
|
||
|
|
;;
|
||
|
|
|
||
|
|
let const ~loc (ord : Ordering.t) =
|
||
|
|
match ord with
|
||
|
|
| Equal -> [%expr true]
|
||
|
|
| Less | Greater -> [%expr false]
|
||
|
|
;;
|
||
|
|
|
||
|
|
let result_type ~loc = [%type: bool]
|
||
|
|
let poly ~loc a b = [%expr Stdlib.( = ) [%e a] [%e b]]
|
||
|
|
|
||
|
|
let abstract ~loc ~type_name a b =
|
||
|
|
[%expr
|
||
|
|
Ppx_compare_lib.equal_abstract ~type_name:[%e estring ~loc type_name] [%e a] [%e b]]
|
||
|
|
;;
|
||
|
|
|
||
|
|
module Attrs = Make_attrs (struct
|
||
|
|
let name = name
|
||
|
|
end)
|
||
|
|
end
|
||
|
|
|
||
|
|
module Make (Params : Params) = struct
|
||
|
|
open Params
|
||
|
|
module Attrs = Attrs
|
||
|
|
|
||
|
|
let str_attributes =
|
||
|
|
[ Attribute.T Attrs.ignore_label_declaration; Attribute.T Attrs.ignore_core_type ]
|
||
|
|
;;
|
||
|
|
|
||
|
|
let is_ignored_gen ~loc ~compare_attr ~equal_attr ast =
|
||
|
|
match kind, Attribute.get compare_attr ast, Attribute.get equal_attr ast with
|
||
|
|
| _, Some (), Some () | Compare, Some (), None | Equal, None, Some () -> true
|
||
|
|
| _, None, None -> false
|
||
|
|
| Compare, None, Some () ->
|
||
|
|
Location.raise_errorf
|
||
|
|
~loc
|
||
|
|
"Cannot use [@@equal.ignore] with [@@@@deriving compare]."
|
||
|
|
| Equal, Some (), None ->
|
||
|
|
Location.raise_errorf ~loc "Cannot use [@@compare.ignore] with [@@@@deriving equal]"
|
||
|
|
;;
|
||
|
|
|
||
|
|
let core_type_is_ignored ty =
|
||
|
|
is_ignored_gen
|
||
|
|
~loc:ty.ptyp_loc
|
||
|
|
~compare_attr:Compare_params.Attrs.ignore_core_type
|
||
|
|
~equal_attr:Equal_params.Attrs.ignore_core_type
|
||
|
|
ty
|
||
|
|
;;
|
||
|
|
|
||
|
|
let label_is_ignored ld =
|
||
|
|
is_ignored_gen
|
||
|
|
~loc:ld.pld_loc
|
||
|
|
~compare_attr:Compare_params.Attrs.ignore_label_declaration
|
||
|
|
~equal_attr:Equal_params.Attrs.ignore_label_declaration
|
||
|
|
ld
|
||
|
|
;;
|
||
|
|
|
||
|
|
let with_tuple loc ~value ~ltys f =
|
||
|
|
(* generate
|
||
|
|
let id_1, id_2, id_3, ... id_n = value in expr
|
||
|
|
where expr is the result of (f [id_1, ty_1 ; id_2, ty_2; ...])
|
||
|
|
*)
|
||
|
|
let names_types =
|
||
|
|
List.map ltys ~f:(fun (lbl, t) -> gen_symbol ~prefix:"t" (), lbl, t)
|
||
|
|
in
|
||
|
|
let pattern =
|
||
|
|
let l = List.map names_types ~f:(fun (n, lbl, _) -> lbl, pvar ~loc n) in
|
||
|
|
Ppxlib_jane.Jane_syntax.Pattern.pat_of ~loc ~attrs:[] (Jpat_tuple (l, Closed))
|
||
|
|
in
|
||
|
|
let e = f (List.map names_types ~f:(fun (n, _, t) -> evar ~loc n, t)) in
|
||
|
|
let binding = value_binding ~loc ~pat:pattern ~expr:value in
|
||
|
|
pexp_let ~loc Nonrecursive [ binding ] e
|
||
|
|
;;
|
||
|
|
|
||
|
|
let phys_equal_first a b cmp =
|
||
|
|
let loc = cmp.pexp_loc in
|
||
|
|
[%expr if Stdlib.( == ) [%e a] [%e b] then [%e const ~loc Equal] else [%e cmp]]
|
||
|
|
;;
|
||
|
|
|
||
|
|
let rec chain_if ~loc = function
|
||
|
|
| [] -> const ~loc Equal
|
||
|
|
| [ x ] -> x
|
||
|
|
| x :: xs -> chain x (chain_if ~loc:x.pexp_loc xs)
|
||
|
|
;;
|
||
|
|
|
||
|
|
let tp_name n = Printf.sprintf "_cmp__%s" n
|
||
|
|
|
||
|
|
let type_ ~with_local ~hide ~loc ty =
|
||
|
|
let loc = { loc with loc_ghost = true } in
|
||
|
|
let ptyp_attributes =
|
||
|
|
if hide
|
||
|
|
then Merlin_helpers.hide_attribute :: ty.ptyp_attributes
|
||
|
|
else ty.ptyp_attributes
|
||
|
|
in
|
||
|
|
let hty = { ty with ptyp_attributes } in
|
||
|
|
ptyp_arrow2 ~loc ~local_args:with_local ty hty (result_type ~loc)
|
||
|
|
;;
|
||
|
|
|
||
|
|
let function_name ~with_local typename =
|
||
|
|
let name =
|
||
|
|
match typename with
|
||
|
|
| "t" -> name
|
||
|
|
| s -> name ^ "_" ^ s
|
||
|
|
in
|
||
|
|
if with_local then name ^ "__local" else name
|
||
|
|
;;
|
||
|
|
|
||
|
|
let compare_ignore ~loc value1 value2 =
|
||
|
|
[%expr
|
||
|
|
let (_ : _) = [%e value1]
|
||
|
|
and (_ : _) = [%e value2] in
|
||
|
|
[%e const ~loc Equal]]
|
||
|
|
;;
|
||
|
|
|
||
|
|
let rec compare_applied ~hide ~with_local ~constructor ~args value1 value2 =
|
||
|
|
let args =
|
||
|
|
List.map args ~f:(compare_of_ty_fun ~hide ~with_local ~type_constraint:false)
|
||
|
|
@ [ value1; value2 ]
|
||
|
|
in
|
||
|
|
type_constr_conv
|
||
|
|
~loc:(Located.loc constructor)
|
||
|
|
constructor
|
||
|
|
args
|
||
|
|
~f:(function_name ~with_local)
|
||
|
|
|
||
|
|
and compare_of_tuple ~hide ~with_local loc ltys value1 value2 =
|
||
|
|
with_tuple loc ~value:value1 ~ltys (fun elems1 ->
|
||
|
|
with_tuple loc ~value:value2 ~ltys (fun elems2 ->
|
||
|
|
let exprs =
|
||
|
|
List.map2_exn elems1 elems2 ~f:(fun (v1, t) (v2, _) ->
|
||
|
|
compare_of_ty ~hide ~with_local t v1 v2)
|
||
|
|
in
|
||
|
|
chain_if ~loc exprs))
|
||
|
|
|
||
|
|
and compare_variant ~hide ~with_local loc row_fields value1 value2 =
|
||
|
|
let map row =
|
||
|
|
match row.prf_desc with
|
||
|
|
| Rtag ({ txt = cnstr; _ }, true, _) | Rtag ({ txt = cnstr; _ }, _, []) ->
|
||
|
|
case
|
||
|
|
~guard:None
|
||
|
|
~lhs:
|
||
|
|
(ppat_tuple
|
||
|
|
~loc
|
||
|
|
[ ppat_variant ~loc cnstr None; ppat_variant ~loc cnstr None ])
|
||
|
|
~rhs:(const ~loc Equal)
|
||
|
|
| Rtag ({ txt = cnstr; _ }, false, tp :: _) ->
|
||
|
|
let v1 = gen_symbol ~prefix:"_left" ()
|
||
|
|
and v2 = gen_symbol ~prefix:"_right" () in
|
||
|
|
let body = compare_of_ty ~hide ~with_local tp (evar ~loc v1) (evar ~loc v2) in
|
||
|
|
case
|
||
|
|
~guard:None
|
||
|
|
~lhs:
|
||
|
|
(ppat_tuple
|
||
|
|
~loc
|
||
|
|
[ ppat_variant ~loc cnstr (Some (pvar ~loc v1))
|
||
|
|
; ppat_variant ~loc cnstr (Some (pvar ~loc v2))
|
||
|
|
])
|
||
|
|
~rhs:body
|
||
|
|
| Rinherit { ptyp_desc = Ptyp_constr (id, args); _ } ->
|
||
|
|
(* quite sadly, this code doesn't handle:
|
||
|
|
type 'a id = 'a with compare
|
||
|
|
type t = [ `a | [ `b ] id ] with compare
|
||
|
|
because it will generate a pattern #id, when id is not even a polymorphic
|
||
|
|
variant in the first place.
|
||
|
|
The culprit is caml though, since it only allows #id but not #([`b] id)
|
||
|
|
*)
|
||
|
|
let v1 = gen_symbol ~prefix:"_left" ()
|
||
|
|
and v2 = gen_symbol ~prefix:"_right" () in
|
||
|
|
case
|
||
|
|
~guard:None
|
||
|
|
~lhs:
|
||
|
|
(ppat_tuple
|
||
|
|
~loc
|
||
|
|
[ ppat_alias ~loc (ppat_type ~loc id) (Located.mk ~loc v1)
|
||
|
|
; ppat_alias ~loc (ppat_type ~loc id) (Located.mk ~loc v2)
|
||
|
|
])
|
||
|
|
~rhs:
|
||
|
|
(compare_applied
|
||
|
|
~hide
|
||
|
|
~with_local
|
||
|
|
~constructor:id
|
||
|
|
~args
|
||
|
|
(evar ~loc v1)
|
||
|
|
(evar ~loc v2))
|
||
|
|
| Rinherit ty ->
|
||
|
|
Location.raise_errorf ~loc:ty.ptyp_loc "Ppx_compare.compare_variant: unknown type"
|
||
|
|
in
|
||
|
|
let e =
|
||
|
|
let matched = pexp_tuple ~loc [ value1; value2 ] in
|
||
|
|
match List.map ~f:map row_fields with
|
||
|
|
| [ v ] -> pexp_match ~loc matched [ v ]
|
||
|
|
| l ->
|
||
|
|
pexp_match
|
||
|
|
~loc
|
||
|
|
matched
|
||
|
|
(l
|
||
|
|
@ (* Providing we didn't screw up badly we now know that the tags of the variants
|
||
|
|
are different. We let pervasive do its magic. *)
|
||
|
|
[ case ~guard:None ~lhs:[%pat? x, y] ~rhs:(poly ~loc [%expr x] [%expr y]) ])
|
||
|
|
in
|
||
|
|
phys_equal_first value1 value2 e
|
||
|
|
|
||
|
|
and branches_of_sum ~hide ~with_local cds =
|
||
|
|
let rightmost_index = List.length cds - 1 in
|
||
|
|
List.concat
|
||
|
|
(List.mapi cds ~f:(fun i cd ->
|
||
|
|
let rightmost = i = rightmost_index in
|
||
|
|
let loc = cd.pcd_loc in
|
||
|
|
if Option.is_some cd.pcd_res
|
||
|
|
then
|
||
|
|
(* If we get GADTs support, fix the constant sum type optimization for them *)
|
||
|
|
Location.raise_errorf ~loc "GADTs are not supported by comparelib";
|
||
|
|
match cd.pcd_args with
|
||
|
|
| Pcstr_record lds ->
|
||
|
|
let value1 = gen_symbol ~prefix:"_a" () in
|
||
|
|
let value2 = gen_symbol ~prefix:"_b" () in
|
||
|
|
let res =
|
||
|
|
case
|
||
|
|
~guard:None
|
||
|
|
~lhs:
|
||
|
|
(ppat_tuple
|
||
|
|
~loc
|
||
|
|
[ pconstruct cd (Some (pvar ~loc value1))
|
||
|
|
; pconstruct cd (Some (pvar ~loc value2))
|
||
|
|
])
|
||
|
|
~rhs:
|
||
|
|
(compare_of_record_no_phys_equal
|
||
|
|
~hide
|
||
|
|
~with_local
|
||
|
|
loc
|
||
|
|
lds
|
||
|
|
(evar ~loc value1)
|
||
|
|
(evar ~loc value2))
|
||
|
|
in
|
||
|
|
if rightmost
|
||
|
|
then [ res ]
|
||
|
|
else (
|
||
|
|
let pany = ppat_any ~loc in
|
||
|
|
let pcnstr = pconstruct cd (Some pany) in
|
||
|
|
let case l r ord =
|
||
|
|
case ~guard:None ~lhs:(ppat_tuple ~loc [ l; r ]) ~rhs:(const ~loc ord)
|
||
|
|
in
|
||
|
|
[ res; case pcnstr pany Less; case pany pcnstr Greater ])
|
||
|
|
| Pcstr_tuple pcd_args ->
|
||
|
|
(match pcd_args with
|
||
|
|
| [] ->
|
||
|
|
let pcnstr = pconstruct cd None in
|
||
|
|
let pany = ppat_any ~loc in
|
||
|
|
let case l r ord =
|
||
|
|
case ~guard:None ~lhs:(ppat_tuple ~loc [ l; r ]) ~rhs:(const ~loc ord)
|
||
|
|
in
|
||
|
|
if rightmost
|
||
|
|
then [ case pcnstr pcnstr Equal ]
|
||
|
|
else
|
||
|
|
[ case pcnstr pcnstr Equal
|
||
|
|
; case pcnstr pany Less
|
||
|
|
; case pany pcnstr Greater
|
||
|
|
]
|
||
|
|
| tps ->
|
||
|
|
let ids_ty =
|
||
|
|
List.map tps ~f:(fun ty ->
|
||
|
|
let a = gen_symbol ~prefix:"_a" () in
|
||
|
|
let b = gen_symbol ~prefix:"_b" () in
|
||
|
|
a, b, ty)
|
||
|
|
in
|
||
|
|
let lpatt =
|
||
|
|
List.map ids_ty ~f:(fun (l, _r, _ty) -> pvar ~loc l) |> ppat_tuple ~loc
|
||
|
|
and rpatt =
|
||
|
|
List.map ids_ty ~f:(fun (_l, r, _ty) -> pvar ~loc r) |> ppat_tuple ~loc
|
||
|
|
and body =
|
||
|
|
List.map ids_ty ~f:(fun (l, r, ty) ->
|
||
|
|
compare_of_ty ~hide ~with_local ty (evar ~loc l) (evar ~loc r))
|
||
|
|
|> chain_if ~loc
|
||
|
|
in
|
||
|
|
let res =
|
||
|
|
case
|
||
|
|
~guard:None
|
||
|
|
~lhs:
|
||
|
|
(ppat_tuple
|
||
|
|
~loc
|
||
|
|
[ pconstruct cd (Some lpatt); pconstruct cd (Some rpatt) ])
|
||
|
|
~rhs:body
|
||
|
|
in
|
||
|
|
if rightmost
|
||
|
|
then [ res ]
|
||
|
|
else (
|
||
|
|
let pany = ppat_any ~loc in
|
||
|
|
let pcnstr = pconstruct cd (Some pany) in
|
||
|
|
let case l r ord =
|
||
|
|
case ~guard:None ~lhs:(ppat_tuple ~loc [ l; r ]) ~rhs:(const ~loc ord)
|
||
|
|
in
|
||
|
|
[ res; case pcnstr pany Less; case pany pcnstr Greater ]))))
|
||
|
|
|
||
|
|
and compare_sum ~hide ~with_local loc cds value1 value2 =
|
||
|
|
let is_sum_type_with_all_constant_constructors =
|
||
|
|
List.for_all cds ~f:(fun cd ->
|
||
|
|
Option.is_none cd.pcd_res
|
||
|
|
&&
|
||
|
|
(* we could support GADTs, but the general case
|
||
|
|
doesn't, so let's hold off *)
|
||
|
|
match cd.pcd_args with
|
||
|
|
| Pcstr_tuple l -> List.is_empty l
|
||
|
|
| Pcstr_record l -> List.is_empty l)
|
||
|
|
in
|
||
|
|
if is_sum_type_with_all_constant_constructors
|
||
|
|
then
|
||
|
|
(* the compiler will optimize the polymorphic comparison to an integer one *)
|
||
|
|
poly ~loc value1 value2
|
||
|
|
else (
|
||
|
|
let mcs = branches_of_sum ~hide ~with_local cds in
|
||
|
|
let e = pexp_match ~loc (pexp_tuple ~loc [ value1; value2 ]) mcs in
|
||
|
|
phys_equal_first value1 value2 e)
|
||
|
|
|
||
|
|
and compare_of_ty ~hide ~with_local ty value1 value2 =
|
||
|
|
let loc = ty.ptyp_loc in
|
||
|
|
if core_type_is_ignored ty
|
||
|
|
then compare_ignore ~loc value1 value2
|
||
|
|
else (
|
||
|
|
match Ppxlib_jane.Jane_syntax.Core_type.of_ast ty with
|
||
|
|
| Some (Jtyp_tuple ltps, _attrs) ->
|
||
|
|
compare_of_tuple ~hide ~with_local loc ltps value1 value2
|
||
|
|
| Some (Jtyp_layout _, _) ->
|
||
|
|
Location.raise_errorf
|
||
|
|
~loc
|
||
|
|
"Layout annotations are not currently supported with [ppx_compare]."
|
||
|
|
| None ->
|
||
|
|
(match ty.ptyp_desc with
|
||
|
|
| Ptyp_constr (constructor, args) ->
|
||
|
|
compare_applied ~hide ~with_local ~constructor ~args value1 value2
|
||
|
|
| Ptyp_tuple tys ->
|
||
|
|
compare_of_tuple
|
||
|
|
~hide
|
||
|
|
~with_local
|
||
|
|
loc
|
||
|
|
(List.map ~f:(fun ty -> None, ty) tys)
|
||
|
|
value1
|
||
|
|
value2
|
||
|
|
| Ptyp_var name -> eapply ~loc (evar ~loc (tp_name name)) [ value1; value2 ]
|
||
|
|
| Ptyp_arrow _ ->
|
||
|
|
Location.raise_errorf ~loc "ppx_compare: Functions can not be compared."
|
||
|
|
| Ptyp_variant (row_fields, Closed, None) ->
|
||
|
|
compare_variant ~hide ~with_local loc row_fields value1 value2
|
||
|
|
| Ptyp_any -> compare_ignore ~loc value1 value2
|
||
|
|
| _ -> Location.raise_errorf ~loc "ppx_compare: unknown type"))
|
||
|
|
|
||
|
|
and compare_of_ty_fun ~hide ~with_local ~type_constraint ty =
|
||
|
|
let loc = { ty.ptyp_loc with loc_ghost = true } in
|
||
|
|
let do_hide hide_fun x = if hide then hide_fun x else x in
|
||
|
|
let a = gen_symbol ~prefix:"a" () in
|
||
|
|
let b = gen_symbol ~prefix:"b" () in
|
||
|
|
let e_a = evar ~loc a in
|
||
|
|
let e_b = evar ~loc b in
|
||
|
|
let mk_pat x =
|
||
|
|
if type_constraint then ppat_constraint ~loc (pvar ~loc x) ty else pvar ~loc x
|
||
|
|
in
|
||
|
|
let body =
|
||
|
|
do_hide Merlin_helpers.hide_expression (compare_of_ty ~hide ~with_local ty e_a e_b)
|
||
|
|
in
|
||
|
|
eta_reduce_if_possible
|
||
|
|
[%expr
|
||
|
|
fun [%p mk_pat a] [%p do_hide Merlin_helpers.hide_pattern (mk_pat b)] -> [%e body]]
|
||
|
|
|
||
|
|
and compare_of_record_no_phys_equal ~hide ~with_local loc lds value1 value2 =
|
||
|
|
let is_evar = function
|
||
|
|
| { pexp_desc = Pexp_ident _; _ } -> true
|
||
|
|
| _ -> false
|
||
|
|
in
|
||
|
|
assert (is_evar value1);
|
||
|
|
assert (is_evar value2);
|
||
|
|
List.filter lds ~f:(fun ld -> not (label_is_ignored ld))
|
||
|
|
|> List.map ~f:(fun ld ->
|
||
|
|
let loc = ld.pld_loc in
|
||
|
|
let label = Located.map lident ld.pld_name in
|
||
|
|
compare_of_ty
|
||
|
|
~hide
|
||
|
|
~with_local
|
||
|
|
ld.pld_type
|
||
|
|
(pexp_field ~loc value1 label)
|
||
|
|
(pexp_field ~loc value2 label))
|
||
|
|
|> chain_if ~loc
|
||
|
|
;;
|
||
|
|
|
||
|
|
let compare_of_record ~hide ~with_local loc lds value1 value2 =
|
||
|
|
compare_of_record_no_phys_equal ~hide ~with_local loc lds value1 value2
|
||
|
|
|> phys_equal_first value1 value2
|
||
|
|
;;
|
||
|
|
|
||
|
|
let compare_abstract loc type_name v_a v_b = abstract ~loc ~type_name v_a v_b
|
||
|
|
|
||
|
|
let scheme_of_td ~hide ~with_local td =
|
||
|
|
let loc = td.ptype_loc in
|
||
|
|
let type_ = combinator_type_of_type_declaration td ~f:(type_ ~hide ~with_local) in
|
||
|
|
match td.ptype_params with
|
||
|
|
| [] -> type_
|
||
|
|
| l ->
|
||
|
|
let vars = List.map l ~f:get_type_param_name in
|
||
|
|
ptyp_poly ~loc vars type_
|
||
|
|
;;
|
||
|
|
|
||
|
|
let compare_of_td ~hide ~with_local td ~rec_flag =
|
||
|
|
let loc = td.ptype_loc in
|
||
|
|
let a = gen_symbol ~prefix:"a" () in
|
||
|
|
let b = gen_symbol ~prefix:"b" () in
|
||
|
|
let v_a = evar ~loc a in
|
||
|
|
let v_b = evar ~loc b in
|
||
|
|
let function_body =
|
||
|
|
match td.ptype_kind with
|
||
|
|
| Ptype_variant cds -> compare_sum ~hide ~with_local loc cds v_a v_b
|
||
|
|
| Ptype_record lds -> compare_of_record ~hide ~with_local loc lds v_a v_b
|
||
|
|
| Ptype_open ->
|
||
|
|
Location.raise_errorf ~loc "ppx_compare: open types are not yet supported"
|
||
|
|
| Ptype_abstract ->
|
||
|
|
(match td.ptype_manifest with
|
||
|
|
| None -> compare_abstract loc td.ptype_name.txt v_a v_b
|
||
|
|
| Some ty ->
|
||
|
|
(match ty.ptyp_desc with
|
||
|
|
| Ptyp_variant (_, Open, _) | Ptyp_variant (_, Closed, Some (_ :: _)) ->
|
||
|
|
Location.raise_errorf
|
||
|
|
~loc:ty.ptyp_loc
|
||
|
|
"ppx_compare: cannot compare open polymorphic variant types"
|
||
|
|
| Ptyp_variant (row_fields, _, _) ->
|
||
|
|
compare_variant ~hide ~with_local loc row_fields v_a v_b
|
||
|
|
| _ -> compare_of_ty ~hide ~with_local ty v_a v_b))
|
||
|
|
in
|
||
|
|
let extra_names =
|
||
|
|
List.map td.ptype_params ~f:(fun p -> tp_name (get_type_param_name p).txt)
|
||
|
|
in
|
||
|
|
let patts = List.map (extra_names @ [ a; b ]) ~f:(pvar ~loc)
|
||
|
|
and bnd = pvar ~loc (function_name ~with_local td.ptype_name.txt) in
|
||
|
|
let poly_scheme =
|
||
|
|
match extra_names with
|
||
|
|
| [] -> false
|
||
|
|
| _ :: _ -> true
|
||
|
|
in
|
||
|
|
let body =
|
||
|
|
eta_reduce_if_possible_and_nonrec ~rec_flag (eabstract ~loc patts function_body)
|
||
|
|
in
|
||
|
|
if poly_scheme
|
||
|
|
then
|
||
|
|
value_binding
|
||
|
|
~loc
|
||
|
|
~pat:(ppat_constraint ~loc bnd (scheme_of_td ~hide ~with_local td))
|
||
|
|
~expr:body
|
||
|
|
else
|
||
|
|
value_binding
|
||
|
|
~loc
|
||
|
|
~pat:bnd
|
||
|
|
~expr:(pexp_constraint ~loc body (scheme_of_td ~hide ~with_local td))
|
||
|
|
;;
|
||
|
|
|
||
|
|
let bindings_of_tds tds ~hide ~with_local ~rec_flag =
|
||
|
|
List.map tds ~f:(fun td -> compare_of_td td ~hide ~with_local ~rec_flag)
|
||
|
|
;;
|
||
|
|
|
||
|
|
let eta_expand2 ~loc f =
|
||
|
|
eabstract
|
||
|
|
~loc
|
||
|
|
[ pvar ~loc "a"; pvar ~loc "b" ]
|
||
|
|
(eapply ~loc f [ evar ~loc "a"; evar ~loc "b" ])
|
||
|
|
;;
|
||
|
|
|
||
|
|
let aliases_of_tds tds ~hide =
|
||
|
|
(* So that ~localize doesn't double the size of the generated code, we define the non
|
||
|
|
local_ function as an alias to the local_ function. This only works for ground
|
||
|
|
types, as [('a -> 'a -> int) -> 'a list -> 'a list -> int] is a type that is
|
||
|
|
neither stronger nor weaker than the same type with local_ on the 'a and 'a
|
||
|
|
list. If the compiler supports polymorphism over locality one day, we may be able
|
||
|
|
to only generate one version of the code, the local version. *)
|
||
|
|
if List.for_all tds ~f:(fun td -> List.is_empty td.ptype_params)
|
||
|
|
then
|
||
|
|
Some
|
||
|
|
(List.map tds ~f:(fun td ->
|
||
|
|
let loc = td.ptype_name.loc in
|
||
|
|
value_binding
|
||
|
|
~loc
|
||
|
|
~pat:(pvar ~loc (function_name ~with_local:false td.ptype_name.txt))
|
||
|
|
~expr:
|
||
|
|
(pexp_constraint
|
||
|
|
~loc
|
||
|
|
(eta_expand2
|
||
|
|
~loc
|
||
|
|
(evar ~loc (function_name ~with_local:true td.ptype_name.txt)))
|
||
|
|
(scheme_of_td ~hide ~with_local:false td))))
|
||
|
|
else None
|
||
|
|
;;
|
||
|
|
|
||
|
|
let str_type_decl ~ctxt (rec_flag, tds) localize =
|
||
|
|
let loc = Expansion_context.Deriver.derived_item_loc ctxt in
|
||
|
|
let hide = not (Expansion_context.Deriver.inline ctxt) in
|
||
|
|
let tds = List.map tds ~f:name_type_params_in_td in
|
||
|
|
let rec_flag =
|
||
|
|
(object
|
||
|
|
inherit type_is_recursive rec_flag tds as super
|
||
|
|
|
||
|
|
method! label_declaration ld =
|
||
|
|
if not (label_is_ignored ld) then super#label_declaration ld
|
||
|
|
|
||
|
|
method! core_type ty = if not (core_type_is_ignored ty) then super#core_type ty
|
||
|
|
end)
|
||
|
|
#go
|
||
|
|
()
|
||
|
|
in
|
||
|
|
if localize
|
||
|
|
then
|
||
|
|
[ pstr_value ~loc rec_flag (bindings_of_tds tds ~hide ~with_local:true ~rec_flag)
|
||
|
|
; (match aliases_of_tds tds ~hide with
|
||
|
|
| Some values -> pstr_value ~loc Nonrecursive values
|
||
|
|
| None ->
|
||
|
|
pstr_value
|
||
|
|
~loc
|
||
|
|
rec_flag
|
||
|
|
(bindings_of_tds tds ~hide ~with_local:false ~rec_flag))
|
||
|
|
]
|
||
|
|
else
|
||
|
|
[ pstr_value ~loc rec_flag (bindings_of_tds tds ~hide ~with_local:false ~rec_flag) ]
|
||
|
|
;;
|
||
|
|
|
||
|
|
let mk_sig ~ctxt ~localize (_rec_flag, tds) =
|
||
|
|
let hide = not (Expansion_context.Deriver.inline ctxt) in
|
||
|
|
let tds = List.map tds ~f:name_type_params_in_td in
|
||
|
|
List.concat_map tds ~f:(fun td ->
|
||
|
|
let generate ~with_local =
|
||
|
|
let compare_of =
|
||
|
|
combinator_type_of_type_declaration td ~f:(type_ ~hide ~with_local)
|
||
|
|
in
|
||
|
|
let name = function_name ~with_local td.ptype_name.txt in
|
||
|
|
let loc = td.ptype_loc in
|
||
|
|
psig_value
|
||
|
|
~loc
|
||
|
|
(value_description
|
||
|
|
~loc
|
||
|
|
~name:{ td.ptype_name with txt = name }
|
||
|
|
~type_:compare_of
|
||
|
|
~prim:[])
|
||
|
|
in
|
||
|
|
if localize
|
||
|
|
then [ generate ~with_local:false; generate ~with_local:true ]
|
||
|
|
else [ generate ~with_local:false ])
|
||
|
|
;;
|
||
|
|
|
||
|
|
let sig_type_decl ~ctxt (rec_flag, tds) localize =
|
||
|
|
let loc = Expansion_context.Deriver.derived_item_loc ctxt in
|
||
|
|
let module_name =
|
||
|
|
match kind with
|
||
|
|
| Compare -> "Comparable"
|
||
|
|
| Equal -> "Equal"
|
||
|
|
in
|
||
|
|
let mk_named_sig ~with_local =
|
||
|
|
let module_type_name = if with_local then "S_local" else "S" in
|
||
|
|
let sg_name = Printf.sprintf "Ppx_compare_lib.%s.%s" module_name module_type_name in
|
||
|
|
mk_named_sig ~loc ~sg_name ~handle_polymorphic_variant:false tds
|
||
|
|
in
|
||
|
|
match mk_named_sig ~with_local:false, mk_named_sig ~with_local:true with
|
||
|
|
| Some include_infos, _ when not localize -> [ psig_include ~loc include_infos ]
|
||
|
|
| Some include_infos, Some include_infos_local when localize ->
|
||
|
|
[ psig_include ~loc include_infos; psig_include ~loc include_infos_local ]
|
||
|
|
| _ -> mk_sig ~ctxt ~localize (rec_flag, tds)
|
||
|
|
;;
|
||
|
|
|
||
|
|
let compare_core_type ~with_local ty =
|
||
|
|
compare_of_ty_fun ~hide:true ~with_local ~type_constraint:true ty
|
||
|
|
;;
|
||
|
|
|
||
|
|
let core_type ~with_local = compare_core_type ~with_local
|
||
|
|
end
|
||
|
|
|
||
|
|
module Compare = struct
|
||
|
|
include Make (Compare_params)
|
||
|
|
|
||
|
|
let equal_core_type ~with_local ty =
|
||
|
|
let loc = { ty.ptyp_loc with loc_ghost = true } in
|
||
|
|
let arg1 = gen_symbol () in
|
||
|
|
let arg2 = gen_symbol () in
|
||
|
|
let body =
|
||
|
|
Merlin_helpers.hide_expression
|
||
|
|
[%expr
|
||
|
|
match
|
||
|
|
[%e compare_core_type ~with_local ty] [%e evar ~loc arg1] [%e evar ~loc arg2]
|
||
|
|
with
|
||
|
|
| 0 -> true
|
||
|
|
| _ -> false]
|
||
|
|
in
|
||
|
|
[%expr fun ([%p pvar ~loc arg1] : [%t ty]) [%p pvar ~loc arg2] -> [%e body]]
|
||
|
|
;;
|
||
|
|
end
|
||
|
|
|
||
|
|
module Equal = Make (Equal_params)
|