Source file ppx_compare_lib.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
open Import0
let phys_equal = phys_equal
external polymorphic_compare : 'a -> 'a -> int = "%compare"
external polymorphic_equal : 'a -> 'a -> bool = "%equal"
external ( && ) : bool -> bool -> bool = "%sequand"
let compare_abstract ~type_name _ _ =
Printf.ksprintf
failwith
"Compare called on the type %s, which is abstract in an implementation."
type_name
;;
let equal_abstract ~type_name _ _ =
Printf.ksprintf
failwith
"Equal called on the type %s, which is abstract in an implementation."
type_name
;;
type 'a compare = 'a -> 'a -> int
type 'a equal = 'a -> 'a -> bool
module Builtin = struct
let compare_bool : bool compare = Poly.compare
let compare_char : char compare = Poly.compare
let compare_float : float compare = Poly.compare
let compare_int : int compare = Poly.compare
let compare_int32 : int32 compare = Poly.compare
let compare_int64 : int64 compare = Poly.compare
let compare_nativeint : nativeint compare = Poly.compare
let compare_string : string compare = Poly.compare
let compare_unit : unit compare = Poly.compare
let compare_array compare_elt a b =
if phys_equal a b
then 0
else (
let len_a = Array0.length a in
let len_b = Array0.length b in
let ret = compare len_a len_b in
if ret <> 0
then ret
else (
let rec loop i =
if i = len_a
then 0
else (
let l = Array0.unsafe_get a i
and r = Array0.unsafe_get b i in
let res = compare_elt l r in
if res <> 0 then res else loop (i + 1))
in
loop 0))
;;
let rec compare_list compare_elt a b =
match a, b with
| [], [] -> 0
| [], _ -> -1
| _, [] -> 1
| x :: xs, y :: ys ->
let res = compare_elt x y in
if res <> 0 then res else compare_list compare_elt xs ys
;;
let compare_option compare_elt a b =
match a, b with
| None, None -> 0
| None, Some _ -> -1
| Some _, None -> 1
| Some a, Some b -> compare_elt a b
;;
let compare_ref compare_elt a b = compare_elt !a !b
let equal_bool : bool equal = Poly.equal
let equal_char : char equal = Poly.equal
let equal_int : int equal = Poly.equal
let equal_int32 : int32 equal = Poly.equal
let equal_int64 : int64 equal = Poly.equal
let equal_nativeint : nativeint equal = Poly.equal
let equal_string : string equal = Poly.equal
let equal_unit : unit equal = Poly.equal
let equal_float x y = equal_int (compare_float x y) 0
let equal_array equal_elt a b =
phys_equal a b
||
let len_a = Array0.length a in
let len_b = Array0.length b in
equal len_a len_b
&&
let rec loop i =
i = len_a
||
let l = Array0.unsafe_get a i
and r = Array0.unsafe_get b i in
equal_elt l r && loop (i + 1)
in
loop 0
;;
let rec equal_list equal_elt a b =
match a, b with
| [], [] -> true
| [], _ | _, [] -> false
| x :: xs, y :: ys -> equal_elt x y && equal_list equal_elt xs ys
;;
let equal_option equal_elt a b =
match a, b with
| None, None -> true
| None, Some _ | Some _, None -> false
| Some a, Some b -> equal_elt a b
;;
let equal_ref equal_elt a b = equal_elt !a !b
end