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
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
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 Comparable = struct
module type S = sig
type t
val compare : t compare
end
module type S1 = sig
type 'a t
val compare : 'a compare -> 'a t compare
end
module type S2 = sig
type ('a, 'b) t
val compare : 'a compare -> 'b compare -> ('a, 'b) t compare
end
module type S3 = sig
type ('a, 'b, 'c) t
val compare : 'a compare -> 'b compare -> 'c compare -> ('a, 'b, 'c) t compare
end
end
module Equal = struct
module type S = sig
type t
val equal : t equal
end
module type S1 = sig
type 'a t
val equal : 'a equal -> 'a t equal
end
module type S2 = sig
type ('a, 'b) t
val equal : 'a equal -> 'b equal -> ('a, 'b) t equal
end
module type S3 = sig
type ('a, 'b, 'c) t
val equal : 'a equal -> 'b equal -> 'c equal -> ('a, 'b, 'c) t equal
end
end
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