Source file ppxlib_traverse_builtins.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
175
176
177
178
179
180
181
182
183
184
185
module T = struct
type 'a map = 'a -> 'a
type 'a iter = 'a -> unit
type ('a, 'acc) fold = 'a -> 'acc -> 'acc
type ('a, 'acc) fold_map = 'a -> 'acc -> ('a * 'acc)
type ('ctx, 'a) map_with_context = 'ctx -> 'a -> 'a
type ('a, 'res) lift = 'a -> 'res
end
class map =
let any x = x in
object
method int : int T.map = any
method string : string T.map = any
method bool : bool T.map = any
method char : char T.map = any
method option : 'a. 'a T.map -> 'a option T.map = fun f x ->
match x with
| None -> None
| Some x -> Some (f x)
method list : 'a. 'a T.map -> 'a list T.map = List.map
method array : 'a. 'a T.map -> 'a array T.map = Array.map
end
class iter =
let any = ignore in
object
method int : int T.iter = any
method string : string T.iter = any
method bool : bool T.iter = any
method char : char T.iter = any
method option : 'a. 'a T.iter -> 'a option T.iter = fun f x ->
match x with
| None -> ()
| Some x -> f x
method list : 'a. 'a T.iter -> 'a list T.iter = List.iter
method array : 'a. 'a T.iter -> 'a array T.iter = Array.iter
end
class ['acc] fold =
let any _ acc = acc in
object
method int : (int , 'acc) T.fold = any
method string : (string , 'acc) T.fold = any
method bool : (bool , 'acc) T.fold = any
method char : (char , 'acc) T.fold = any
method option : 'a. ('a, 'acc) T.fold -> ('a option, 'acc) T.fold = fun f x acc ->
match x with
| None -> acc
| Some x -> f x acc
method list : 'a. ('a, 'acc) T.fold -> ('a list, 'acc) T.fold =
let rec loop f l acc =
match l with
| [] -> acc
| x :: l -> loop f l (f x acc)
in
loop
method array : 'a. ('a, 'acc) T.fold -> ('a array, 'acc) T.fold = fun f a acc ->
let r = ref acc in
for i = 0 to Array.length a - 1 do
r := f (Array.unsafe_get a i) !r
done;
!r
end
class ['acc] fold_map =
let any x acc = (x, acc) in
object
method int : (int , 'acc) T.fold_map = any
method string : (string , 'acc) T.fold_map = any
method bool : (bool , 'acc) T.fold_map = any
method char : (char , 'acc) T.fold_map = any
method option : 'a. ('a, 'acc) T.fold_map -> ('a option, 'acc) T.fold_map
= fun f x acc ->
match x with
| None -> (None, acc)
| Some x -> let x, acc = f x acc in (Some x, acc)
method list : 'a. ('a, 'acc) T.fold_map -> ('a list, 'acc) T.fold_map =
let rec loop f l acc =
match l with
| [] -> ([], acc)
| x :: l ->
let x, acc = f x acc in
let l, acc = loop f l acc in
(x :: l, acc)
in
loop
method array : 'a. ('a, 'acc) T.fold_map -> ('a array, 'acc) T.fold_map
= fun f a acc ->
let len = Array.length a in
if len = 0 then
(a, acc)
else begin
let x, acc = f (Array.unsafe_get a 0) acc in
let a' = Array.make len x in
let r = ref acc in
for i = 1 to len - 1 do
let x, acc = f (Array.unsafe_get a i) !r in
Array.unsafe_set a' i x;
r := acc
done;
(a', !r)
end
end
class ['ctx] map_with_context =
let any _ x = x in
object
method int : ('ctx, int ) T.map_with_context = any
method string : ('ctx, string) T.map_with_context = any
method bool : ('ctx, bool ) T.map_with_context = any
method char : ('ctx, char ) T.map_with_context = any
method option
: 'a. ('ctx, 'a) T.map_with_context -> ('ctx, 'a option) T.map_with_context
= fun f ctx x ->
match x with
| None -> None
| Some x -> Some (f ctx x)
method list
: 'a. ('ctx, 'a) T.map_with_context -> ('ctx, 'a list) T.map_with_context
= fun f ctx l -> List.map (f ctx) l
method array
: 'a. ('ctx, 'a) T.map_with_context -> ('ctx, 'a array) T.map_with_context
= fun f ctx a -> Array.map (f ctx) a
end
class virtual ['res] lift =
object(self)
method virtual other : 'a. ('a, 'res) T.lift
method virtual int : (int , 'res) T.lift
method virtual string : (string, 'res) T.lift
method virtual bool : (bool , 'res) T.lift
method virtual char : (char , 'res) T.lift
method virtual array : 'a. ('a, 'res) T.lift -> ('a array, 'res) T.lift
method virtual float : (float, 'res) T.lift
method virtual int32 : (int32, 'res) T.lift
method virtual int64 : (int64, 'res) T.lift
method virtual nativeint : (nativeint, 'res) T.lift
method virtual unit : (unit, 'res) T.lift
method virtual record : (string * 'res) list -> 'res
method virtual constr : string -> 'res list -> 'res
method virtual tuple : 'res list -> 'res
method option : 'a. ('a, 'res) T.lift -> ('a option, 'res) T.lift = fun f x ->
match x with
| None -> self#constr "None" []
| Some x -> self#constr "Some" [f x]
method list : 'a. ('a, 'res) T.lift -> ('a list, 'res) T.lift = fun f l ->
match l with
| [] -> self#constr "[]" []
| x :: l -> self#constr "::" [f x; self#list f l]
end
class type ['res] std_lifters =
object
method other : 'a. ('a, 'res) T.lift
method int : (int , 'res) T.lift
method string : (string, 'res) T.lift
method bool : (bool , 'res) T.lift
method char : (char , 'res) T.lift
method array : 'a. ('a, 'res) T.lift -> ('a array, 'res) T.lift
method record : (string * 'res) list -> 'res
method constr : string -> 'res list -> 'res
method tuple : 'res list -> 'res
method float : (float, 'res) T.lift
method int32 : (int32, 'res) T.lift
method int64 : (int64, 'res) T.lift
method nativeint : (nativeint, 'res) T.lift
method unit : (unit, 'res) T.lift
method option : 'a. ('a, 'res) T.lift -> ('a option, 'res) T.lift
method list : 'a. ('a, 'res) T.lift -> ('a list, 'res) T.lift
end