VisitorsRuntime.ml 32.3 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12
(* This file provides useful / reasonable visitor methods for many of the
   built-in types of OCaml. *)

(* The classes defined in this file are automatically inherited by
   auto-generated visitors. If this is not desired, this behavior can be
   turned off at generation time by specifying [nude = true]. *)

(* Some of the code in this file can be (or has been) auto-generated by
   the [visitors] package itself: see [test/VisitorsRuntimeBootstrap].
   To avoid a complicated process and to facilitate code review, we
   keep this code under manual control in this file. *)

POTTIER Francois's avatar
POTTIER Francois committed
13 14
(* -------------------------------------------------------------------------- *)

15 16 17 18 19 20 21 22
(* For compatibility with OCaml 4.02, we take the type [('a, 'b) result] from
   the package [result]. This type appeared in the standard library in OCaml
   4.03. *)

open Result

(* -------------------------------------------------------------------------- *)

23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39
(* [array_equal eq xs1 xs2] tests whether the arrays [xs1] and [xs2] have the
   same components. The arrays must have the same length. The components are
   compared using [eq]. *)

let rec array_equal eq i n xs1 xs2 =
  i = n ||
  let x1 = Array.unsafe_get xs1 i
  and x2 = Array.unsafe_get xs2 i in
  eq x1 x2 && array_equal eq (i + 1) n xs1 xs2

let array_equal eq xs1 xs2 =
  let n = Array.length xs1 in
  assert (Array.length xs2 = n);
  array_equal eq 0 n xs1 xs2

(* -------------------------------------------------------------------------- *)

POTTIER Francois's avatar
POTTIER Francois committed
40 41
(* An exception used at arity 2 and above. *)

42 43 44 45 46
exception StructuralMismatch

let fail () =
  raise StructuralMismatch

47 48 49 50 51 52 53 54 55 56 57 58 59 60
let wrap f t =
  try
    f t;
    true
  with StructuralMismatch ->
    false

let wrap2 f t1 t2 =
  try
    f t1 t2;
    true
  with StructuralMismatch ->
    false

POTTIER Francois's avatar
POTTIER Francois committed
61 62
(* -------------------------------------------------------------------------- *)

63 64
(* A virtual base class for monoids. *)

65 66 67
class virtual ['s] monoid = object
  method private virtual zero: 's
  method private virtual plus: 's -> 's -> 's
68 69 70 71 72 73
end

(* -------------------------------------------------------------------------- *)

(* Common monoids. *)

74 75
class ['s] addition_monoid = object
  inherit ['s] monoid
76 77
  method private zero = 0
  method private plus = (+)
78 79
end

80 81
class ['s] unit_monoid = object
  inherit ['s] monoid
POTTIER Francois's avatar
POTTIER Francois committed
82 83 84 85
  method private zero = ()
  method private plus () () = ()
end

86 87
(* -------------------------------------------------------------------------- *)

88
(* Visitor methods for the primitive types. *)
89

90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
(* Must the methods below be declared polymorphic in ['env]? The fact is, they
   ARE polymorphic in ['env], because they do not extend it or look it up.

   By declaring them polymorphic, we gain in generality: e.g., [visit_list]
   can be called by two visitor methods which happen to have different types
   of environments. (This happens in alphaLib, where visitor methods for terms
   and patterns manipulate different types of environments.)

   However, by declaring them polymorphic, we also lose some generality, as we
   PREVENT users from overriding these methods with code that extends or looks
   up the environment.

   Here, it seems reasonable to take both the gain and the loss, and declare
   these methods polymorphic.

   We could give the user a choice by providing multiple base classes, but that
POTTIER Francois's avatar
POTTIER Francois committed
106 107 108
   would messy. Note that, when using [@@deriving visitors { ... }], the user
   does have a choice whether the generated methods should be polymorphic in
   ['env]. *)
109

110 111
(* -------------------------------------------------------------------------- *)

112
(* [iter] *)
113

114
class ['self] iter = object (self)
115

116
  method private visit_array: 'env 'a .
117
    ('env -> 'a -> unit) -> 'env -> 'a array -> unit
118 119 120 121 122 123
  = fun f env xs ->
      (* For speed, we inline [Array.iter]. Chances are, we save a closure
         allocation, as using [Array.iter] would require us to build [f env]. *)
      for i = 0 to Array.length xs - 1 do
        f env (Array.unsafe_get xs i)
      done
124

125
  method private visit_bool: 'env .
126
    'env -> bool -> unit
127
  = fun _ _ -> ()
128

129
  method private visit_bytes: 'env .
130 131 132
    'env -> bytes -> unit
  = fun _ _ -> ()

133
  method private visit_char: 'env .
134
    'env -> char -> unit
135
  = fun _ _ -> ()
136

137
  method private visit_float: 'env .
138
    'env -> float -> unit
139
  = fun _ _ -> ()
140

141
  method private visit_int: 'env .
142
    'env -> int -> unit
143
  = fun _ _ -> ()
144

145
  method private visit_int32: 'env .
146
    'env -> int32 -> unit
147
  = fun _ _ -> ()
148

149
  method private visit_int64: 'env .
150
    'env -> int64 -> unit
151
  = fun _ _ -> ()
152

153
  method private visit_lazy_t: 'env 'a .
154 155 156 157
    ('env -> 'a -> unit) -> 'env -> 'a Lazy.t -> unit
  = fun f env (lazy x) ->
      f env x

158
  method private visit_list: 'env 'a .
159
    ('env -> 'a -> unit) -> 'env -> 'a list -> unit
160 161 162 163 164 165 166
  = fun f env xs ->
      match xs with
      | [] ->
          ()
      | x :: xs ->
          f env x;
          self # visit_list f env xs
167

168
  method private visit_nativeint: 'env .
169 170 171
    'env -> nativeint -> unit
  = fun _ _ -> ()

172
  method private visit_option: 'env 'a .
173
    ('env -> 'a -> unit) -> 'env -> 'a option -> unit
174 175 176 177 178 179
  = fun f env ox ->
      match ox with
      | None ->
          ()
      | Some x ->
          f env x
180

181
  method private visit_ref: 'env 'a .
182
    ('env -> 'a -> unit) -> 'env -> 'a ref -> unit
183 184
  = fun f env rx ->
      f env !rx
185

186
  method private visit_result: 'env 'a 'e.
187 188 189
    ('env -> 'a -> unit) ->
    ('env -> 'e -> unit) ->
     'env -> ('a, 'e) result -> unit
190 191 192 193
  = fun f g env r ->
      match r with
      | Ok a -> f env a
      | Error b -> g env b
194

195
  method private visit_string: 'env .
196
    'env -> string -> unit
197
  = fun _ _ -> ()
198

199
  method private visit_unit: 'env .
200
    'env -> unit -> unit
201
  = fun _ _ -> ()
202 203

end
204

205 206 207 208
(* -------------------------------------------------------------------------- *)

(* [map] *)

209
class ['self] map = object (self)
210

211
  method private visit_array: 'env 'a 'b .
212
    ('env -> 'a -> 'b) -> 'env -> 'a array -> 'b array
213 214
  = fun f env xs ->
      Array.map (f env) xs
215
      (* We could in principle inline [Array.map] so as to avoid allocating
POTTIER Francois's avatar
POTTIER Francois committed
216 217
         the closure [f env]. That would be a bit painful, though. Anyway,
         in [flambda] mode, the compiler might be able to do that for us. *)
218

219
  method private visit_bool: 'env .
220
    'env -> bool -> bool
221
  = fun _ x -> x
222

223
  method private visit_bytes: 'env .
224 225 226
    'env -> bytes -> bytes
  = fun _ x -> x

227
  method private visit_char: 'env .
228
    'env -> char -> char
229
  = fun _ x -> x
230

231
  method private visit_float: 'env .
232
    'env -> float -> float
233
  = fun _ x -> x
234

235
  method private visit_int: 'env .
236
    'env -> int -> int
237
  = fun _ x -> x
238

239
  method private visit_int32: 'env .
240
    'env -> int32 -> int32
241
  = fun _ x -> x
242

243
  method private visit_int64: 'env .
244
    'env -> int64 -> int64
245
  = fun _ x -> x
246

247
  method private visit_lazy_t: 'env 'a 'b .
248 249 250 251 252 253 254 255 256
    ('env -> 'a -> 'b) -> 'env -> 'a Lazy.t -> 'b Lazy.t
  = fun f env thx ->
      (* We seem to have two options: either force the suspension now
         and rebuild a trivial suspension, or build now a suspension
         that will perform the traversal when forced. We choose the
         latter, which seems more interesting. If this is not the
         desired behavior, it can of course be overridden. *)
      lazy (f env (Lazy.force thx))

257
  method private visit_list: 'env 'a 'b .
258
    ('env -> 'a -> 'b) -> 'env -> 'a list -> 'b list
259 260 261 262 263 264 265
  = fun f env xs ->
      match xs with
      | [] ->
          []
      | x :: xs ->
          let x = f env x in
          x :: self # visit_list f env xs
266

267
  method private visit_nativeint: 'env .
268 269 270
    'env -> nativeint -> nativeint
  = fun _ x -> x

271
  method private visit_option: 'env 'a 'b .
272
    ('env -> 'a -> 'b) -> 'env -> 'a option -> 'b option
273 274 275 276 277 278
  = fun f env ox ->
      match ox with
      | None ->
          None
      | Some x ->
          Some (f env x)
279

280
  method private visit_ref: 'env 'a 'b .
281
    ('env -> 'a -> 'b) -> 'env -> 'a ref -> 'b ref
282 283
  = fun f env rx ->
      ref (f env !rx)
284

285
  method private visit_result: 'env 'a 'b 'e 'f .
286 287 288
    ('env -> 'a -> 'b) ->
    ('env -> 'e -> 'f) ->
     'env -> ('a, 'e) result -> ('b, 'f) result
289 290 291 292
  = fun f g env r ->
      match r with
      | Ok a -> Ok (f env a)
      | Error b -> Error (g env b)
293

294
  method private visit_string: 'env .
295
    'env -> string -> string
296
  = fun _ x -> x
297

298
  method private visit_unit: 'env .
299
    'env -> unit -> unit
300
  = fun _ x -> x
301 302

end
303

304 305
(* -------------------------------------------------------------------------- *)

306 307 308 309 310 311 312 313 314 315 316 317 318
(* [endo] *)

class ['self] endo = object (self)

  (* We might wish to inherit from [map] and override only those methods where
     a physical equality check is needed. Yet, we cannot do that, because some
     methods, like [visit_list], have more restrictive types in this class than
     in the class [map]. *)

  (* It may seem fishy to use an [endo] visitor at type [array], but one never
     knows -- maybe the user wants this. Maybe she is using an array as an
     immutable data structure. *)

319
  method private visit_array: 'env 'a .
320 321 322 323 324
    ('env -> 'a -> 'a) -> 'env -> 'a array -> 'a array
  = fun f env xs ->
      let xs' = Array.map (f env) xs in
      if array_equal (==) xs xs' then xs else xs'

325
  method private visit_bool: 'env .
326 327 328
    'env -> bool -> bool
  = fun _ x -> x

329
  method private visit_bytes: 'env .
330 331 332
    'env -> bytes -> bytes
  = fun _ x -> x

333
  method private visit_char:'env .
334 335 336
    'env -> char -> char
  = fun _ x -> x

337
  method private visit_float: 'env .
338 339 340
    'env -> float -> float
  = fun _ x -> x

341
  method private visit_int: 'env .
342 343 344
    'env -> int -> int
  = fun _ x -> x

345
  method private visit_int32: 'env .
346 347 348
    'env -> int32 -> int32
  = fun _ x -> x

349
  method private visit_int64: 'env .
350 351 352
    'env -> int64 -> int64
  = fun _ x -> x

353
  method private visit_lazy_t : 'env 'a .
354 355 356 357 358 359 360 361 362 363 364
    ('env -> 'a -> 'a) -> 'env -> 'a Lazy.t -> 'a Lazy.t
  = fun f env thx ->
      (* We could use the same code as in [map], which does not preserve sharing.
         Or, we can force the suspension now, compute [x'], and if [x] and
         [x'] coincide, then we can return the original suspension (now
         forced), so as to preserve sharing. We choose the latter behavior. If
         this is not the desired behavior, it can of course be overridden. *)
      let x = Lazy.force thx in
      let x' = f env x in
      if x == x' then thx else lazy x'

365
  method private visit_list: 'env 'a .
366 367 368 369 370 371 372 373 374 375 376 377 378
    ('env -> 'a -> 'a) -> 'env -> 'a list -> 'a list
  = fun f env this ->
      match this with
      | [] ->
          []
      | x :: xs ->
          let x' = f env x in
          let xs' = self # visit_list f env xs in
          if x == x' && xs == xs' then
            this
          else
            x' :: xs'

379
  method private visit_nativeint: 'env .
380 381 382
    'env -> nativeint -> nativeint
  = fun _ x -> x

383
  method private visit_option: 'env 'a .
384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400
    ('env -> 'a -> 'a) -> 'env -> 'a option -> 'a option
  = fun f env ox ->
      match ox with
      | None ->
          None
      | Some x ->
          let x' = f env x in
          if x == x' then
            ox
          else
            Some x'

  (* It probably does not make sense to use an [endo] visitor at type
     [ref], but one never knows -- maybe the user wants this. Anyway,
     it is consistent with the behavior of [endo] visitors at mutable
     record types. *)

401
  method private visit_ref: 'env 'a .
402 403 404 405 406 407 408 409 410
    ('env -> 'a -> 'a) -> 'env -> 'a ref -> 'a ref
  = fun f env rx ->
      let x = !rx in
      let x' = f env x in
      if x == x' then
        rx
      else
        ref x'

411
  method private visit_result: 'env 'a 'e .
412 413 414 415 416 417 418 419 420 421 422 423
    ('env -> 'a -> 'a) ->
    ('env -> 'e -> 'e) ->
     'env -> ('a, 'e) result -> ('a, 'e) result
  = fun f g env r ->
      match r with
      | Ok a ->
          let a' = f env a in
          if a == a' then r else Ok a'
      | Error b ->
          let b' = g env b in
          if b == b' then r else Error b'

424
  method private visit_string: 'env .
425 426 427
    'env -> string -> string
  = fun _ x -> x

428
  method private visit_unit: 'env .
429 430 431 432 433 434 435
    'env -> unit -> unit
  = fun _ x -> x

end

(* -------------------------------------------------------------------------- *)

436 437
(* [reduce] *)

POTTIER Francois's avatar
POTTIER Francois committed
438 439 440 441 442 443 444
(* For arrays and lists, we use [fold_left] instead of a natural (bottom-up)
   fold. The order in which the elements are traversed is the same either way
   (namely, left-to-right) but the manner in which the [plus] operations are
   associated is not the same, so the [plus] operator should be associative.

   We could go back to a natural fold, but we would lose tail recursion. *)

445 446
class virtual ['self] reduce = object (self : 'self)

447
  inherit ['s] monoid
448

449
  method private visit_array: 'env 'a .
450
    ('env -> 'a -> 's) -> 'env -> 'a array -> 's
451
  = fun f env xs ->
452
      Array.fold_left (fun s x -> self#plus s (f env x)) self#zero xs
453 454 455
      (* We might wish to inline [Array.fold_left] and save a closure
         allocation. That said, in flambda mode, the compiler might be
         able to do that automatically. *)
456

457
  method private visit_bool: 'env .
458
    'env -> bool -> 's
459 460
  = fun _env _ -> self#zero

461
  method private visit_bytes: 'env .
462
    'env -> bytes -> 's
463 464
  = fun _env _ -> self#zero

465
  method private visit_char: 'env .
466
    'env -> char -> 's
467 468
  = fun _env _ -> self#zero

469
  method private visit_float: 'env .
470
    'env -> float -> 's
471 472
  = fun _env _ -> self#zero

473
  method private visit_int: 'env .
474
    'env -> int -> 's
475 476
  = fun _env _ -> self#zero

477
  method private visit_int32: 'env .
478
    'env -> int32 -> 's
479 480
  = fun _env _ -> self#zero

481
  method private visit_int64: 'env .
482
    'env -> int64 -> 's
483 484
  = fun _env _ -> self#zero

485
  method private visit_lazy_t: 'env 'a .
486
    ('env -> 'a -> 's) -> 'env -> 'a Lazy.t -> 's
487 488 489
  = fun f env (lazy x) ->
      f env x

490
  method private visit_list: 'env 'a .
491
    ('env -> 'a -> 's) -> 'env -> 'a list -> 's
492
  = fun f env xs ->
493 494
      self # list_fold_left f env self#zero xs
      (* The above line is equivalent to the following: *)
495
      (* List.fold_left (fun s x -> self#plus s (f env x)) self#zero xs *)
496 497 498 499 500
      (* By using the auxiliary method [list_fold_left] instead of calling
         the library function [List.fold_left], we save a closure allocation,
         at least in non-flambda mode. A micro-benchmark shows no performance
         impact, either way. *)

501
  method private list_fold_left: 'env 'a .
502 503
    ('env -> 'a -> 's) -> 'env -> 's -> 'a list -> 's
  = fun f env s xs ->
504 505
    match xs with
    | [] ->
506
        s
507
    | x :: xs ->
508 509
        let s = self#plus s (f env x) in
        self # list_fold_left f env s xs
510

511
  method private visit_nativeint: 'env .
512
    'env -> nativeint -> 's
513 514
  = fun _env _ -> self#zero

515
  method private visit_option: 'env 'a .
516
    ('env -> 'a -> 's) -> 'env -> 'a option -> 's
517 518 519 520 521 522 523
  = fun f env ox ->
      match ox with
      | Some x ->
          f env x
      | None ->
          self#zero

524
  method private visit_ref: 'env 'a .
525
    ('env -> 'a -> 's) -> 'env -> 'a ref -> 's
526 527 528
  = fun f env rx ->
      f env !rx

529
  method private visit_result: 'env 'a 'e .
530 531 532
    ('env -> 'a -> 's) ->
    ('env -> 'e -> 's) ->
     'env -> ('a, 'e) result -> 's
533 534 535 536 537 538 539
  = fun f g env r ->
      match r with
      | Ok a ->
          f env a
      | Error b ->
          g env b

540
  method private visit_string: 'env .
541
    'env -> string -> 's
542 543
  = fun _env _ -> self#zero

544
  method private visit_unit: 'env .
545
    'env -> unit -> 's
546 547 548
  = fun _env _ -> self#zero

end
549

550 551
(* -------------------------------------------------------------------------- *)

552 553
(* [mapreduce] *)

554
class virtual ['self] mapreduce = object (self : 'self)
555

556
  inherit ['s] monoid
557

558 559 560 561 562 563 564 565 566 567 568 569 570
  method private visit_array: 'env 'a 'b .
    ('env -> 'a -> 'b * 's) -> 'env -> 'a array -> 'b array * 's
  = fun f env xs ->
      let s = ref self#zero in
      let xs =
        Array.map (fun x ->
          let x, sx = f env x in
          s := self#plus !s sx;
          x
        ) xs
      in
      xs, !s

571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607
  method private visit_bool: 'env .
    'env -> bool -> bool * 's
  = fun _ x -> x, self#zero

  method private visit_bytes: 'env .
    'env -> bytes -> bytes * 's
  = fun _ x -> x, self#zero

  method private visit_char: 'env .
    'env -> char -> char * 's
  = fun _ x -> x, self#zero

  method private visit_float: 'env .
    'env -> float -> float * 's
  = fun _ x -> x, self#zero

  method private visit_int: 'env .
    'env -> int -> int * 's
  = fun _ x -> x, self#zero

  method private visit_int32: 'env .
    'env -> int32 -> int32 * 's
  = fun _ x -> x, self#zero

  method private visit_int64: 'env .
    'env -> int64 -> int64 * 's
  = fun _ x -> x, self#zero

  method private visit_lazy_t: 'env 'a 'b .
    ('env -> 'a -> 'b * 's) -> 'env -> 'a Lazy.t -> 'b Lazy.t * 's
  = fun f env (lazy x) ->
      (* Because we must compute a summary now, it seems that we have to
         force the suspension now. One should be aware that this is not
         the same behavior as the one we chose in the class [map]. *)
      let y, s = f env x in
      lazy y, s

608
  method private visit_list: 'env 'a 'b .
609
    ('env -> 'a -> 'b * 's) -> 'env -> 'a list -> 'b list * 's
610 611 612 613 614
  = fun f env xs ->
      match xs with
      | [] ->
          [], self#zero
      | x :: xs ->
615 616 617
          let x, sx = f env x in
          let xs, sxs = self # visit_list f env xs in
          x :: xs, self#plus sx sxs
618 619 620 621 622 623 624 625 626
      (* This is not the same strategy as in the class [reduce], where we
         used an accumulator and a tail-recursive left fold. Here, we are
         using a right fold. The order in which list elements are visited
         is left-to-right in both cases, but the tree of [self#plus] ops
         is not balanced the same way. *)

  method private visit_nativeint: 'env .
    'env -> nativeint -> nativeint * 's
  = fun _ x -> x, self#zero
627

628 629 630 631 632 633 634 635 636 637 638 639 640 641 642
  method private visit_option: 'env 'a_0 'a_1 .
    ('env -> 'a_0 -> 'a_1 * 's) ->
    'env -> 'a_0 option -> 'a_1 option * 's
  = fun visit_'a env this ->
      match this with
      | None ->
          None, self#zero
      | Some c0 ->
          let r0, s0 = visit_'a env c0 in
          Some r0, s0

  method private visit_ref: 'env 'a_0 'a_1 .
    ('env -> 'a_0 -> 'a_1 * 's) ->
    'env -> 'a_0 ref -> 'a_1 ref * 's
  = fun visit_'a env this ->
643 644
      let r0, s0 = visit_'a env !this in
      ref r0, s0
645 646 647 648 649 650 651 652 653 654 655 656 657 658

  method private visit_result: 'env 'a_0 'a_1 'b_0 'b_1 .
    ('env -> 'a_0 -> 'a_1 * 's) ->
    ('env -> 'b_0 -> 'b_1 * 's) ->
    'env -> ('a_0, 'b_0) result -> ('a_1, 'b_1) result * 's
  = fun visit_'a visit_'b env this ->
      match this with
      | Ok c0 ->
          let r0, s0 = visit_'a env c0 in
          Ok r0, s0
      | Error c0 ->
          let r0, s0 = visit_'b env c0 in
          Error r0, s0

659 660 661 662 663 664 665
  method private visit_string: 'env .
    'env -> string -> string * 's
  = fun _ x -> x, self#zero

  method private visit_unit: 'env .
    'env -> unit -> unit * 's
  = fun _ x -> x, self#zero
666 667 668 669 670

end

(* -------------------------------------------------------------------------- *)

671 672 673 674
(* [fold] *)

class ['self] fold = object (_self)

675 676
  (* No methods are provided, as we do not wish to fix the types of these
     methods. It is up to the user to inherit from a class that defines
POTTIER Francois's avatar
POTTIER Francois committed
677
     appropriate methods. Note that [VisitorsRuntime.map] is likely to be
678 679
     appropriate in many situations. *)

680 681 682 683
end

(* -------------------------------------------------------------------------- *)

684 685
(* [iter2] *)

686
class ['self] iter2 = object (self)
687

688
  method private visit_array: 'env 'a 'b .
689
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a array -> 'b array -> unit
690
  = fun f env xs1 xs2 ->
691
      (* We inline [Array.iter2]. *)
692
      if Array.length xs1 = Array.length xs2 then
693 694 695
        for i = 0 to Array.length xs1 - 1 do
          f env (Array.unsafe_get xs1 i) (Array.unsafe_get xs2 i)
        done
696 697
      else
        fail()
698

699
  method private visit_bool: 'env .
700
    'env -> bool -> bool -> unit
701
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
702

703
  method private visit_bytes: 'env .
704 705 706
    'env -> bytes -> bytes -> unit
  = fun _ x1 x2 -> if x1 = x2 then () else fail()

707
  method private visit_char: 'env .
708
    'env -> char -> char -> unit
709
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
710

711
  method private visit_float: 'env .
712
    'env -> float -> float -> unit
713
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
714

715
  method private visit_int: 'env .
716
    'env -> int -> int -> unit
717
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
718

719
  method private visit_int32: 'env .
720
    'env -> int32 -> int32 -> unit
721
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
722

723
  method private visit_int64: 'env .
724
    'env -> int64 -> int64 -> unit
725
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
726

727
  method private visit_lazy_t: 'env 'a 'b .
728 729 730 731
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a Lazy.t -> 'b Lazy.t -> unit
  = fun f env (lazy x1) (lazy x2) ->
      f env x1 x2

732
  method private visit_list: 'env 'a 'b .
733
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a list -> 'b list -> unit
734 735 736 737 738 739 740 741 742
  = fun f env xs1 xs2 ->
      match xs1, xs2 with
      | [], [] ->
          ()
      | x1 :: xs1, x2 :: xs2 ->
          f env x1 x2;
          self # visit_list f env xs1 xs2
      | _, _ ->
          fail()
743

744
  method private visit_nativeint: 'env .
745 746 747
    'env -> nativeint -> nativeint -> unit
  = fun _ x1 x2 -> if x1 = x2 then () else fail()

748
  method private visit_option: 'env 'a 'b .
749
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a option -> 'b option -> unit
750 751 752 753 754 755 756 757
  = fun f env ox1 ox2 ->
      match ox1, ox2 with
      | None, None ->
          ()
      | Some x1, Some x2 ->
          f env x1 x2
      | _, _ ->
          fail()
758

759
  method private visit_ref: 'env 'a 'b .
760
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a ref -> 'b ref -> unit
761 762
  = fun f env rx1 rx2 ->
      f env !rx1 !rx2
763

764
  method private visit_result: 'env 'a 'b 'e 'f .
765 766 767
    ('env -> 'a -> 'b -> unit) ->
    ('env -> 'e -> 'f -> unit) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> unit
768 769 770 771 772
  = fun f g env r1 r2 ->
      match r1, r2 with
      | Ok a1, Ok a2 -> f env a1 a2
      | Error b1, Error b2 -> g env b1 b2
      | _, _ -> fail()
773

774
  method private visit_string: 'env .
775
    'env -> string -> string -> unit
776
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
777

778
  method private visit_unit: 'env .
779
    'env -> unit -> unit -> unit
780
  = fun _ _x1 _x2 -> ()
781 782

end
783

784 785 786 787
(* -------------------------------------------------------------------------- *)

(* [map2] *)

788
class ['self] map2 = object (self)
789

790
  method private visit_array: 'env 'a 'b 'c .
791
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a array -> 'b array -> 'c array
792 793
  = fun f env xs1 xs2 ->
      if Array.length xs1 = Array.length xs2 then
794 795 796
        Array.mapi (fun i x1 -> f env x1 xs2.(i)) xs1
        (* Array.map2 (f env) xs1 xs2 *)
        (* We avoid [Array.map2] because it does not exist in OCaml 4.02. *)
797 798
      else
        fail()
799

800
  method private visit_bool: 'env .
801
    'env -> bool -> bool -> bool
802
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
803

804
  method private visit_bytes: 'env .
805 806 807
    'env -> bytes -> bytes -> bytes
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()

808
  method private visit_char: 'env .
809
    'env -> char -> char -> char
810
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
811

812
  method private visit_float: 'env .
813
    'env -> float -> float -> float
814
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
815

816
  method private visit_int: 'env .
817
    'env -> int -> int -> int
818
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
819

820
  method private visit_int32: 'env .
821
    'env -> int32 -> int32 -> int32
822
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
823

824
  method private visit_int64: 'env .
825
    'env -> int64 -> int64 -> int64
826
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
827

828
  method private visit_lazy_t: 'env 'a 'b 'c .
829 830 831 832 833
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a Lazy.t -> 'b Lazy.t -> 'c Lazy.t
  = fun f env thx1 thx2 ->
      (* As in [map]. *)
      lazy (f env (Lazy.force thx1) (Lazy.force thx2))

834
  method private visit_list: 'env 'a 'b 'c .
835
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a list -> 'b list -> 'c list
836 837 838 839 840 841 842 843 844
  = fun f env xs1 xs2 ->
      match xs1, xs2 with
      | [], [] ->
          []
      | x1 :: xs1, x2 :: xs2 ->
          let x = f env x1 x2 in
          x :: self # visit_list f env xs1 xs2
      | _, _ ->
          fail()
845

846
  method private visit_nativeint: 'env .
847 848 849
    'env -> nativeint -> nativeint -> nativeint
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()

850
  method private visit_option: 'env 'a 'b 'c .
851
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a option -> 'b option -> 'c option
852 853 854 855 856 857 858 859 860
  = fun f env ox1 ox2 ->
      match ox1, ox2 with
      | None, None ->
          None
      | Some x1, Some x2 ->
          let x = f env x1 x2 in
          Some x
      | _, _ ->
          fail()
861

862
  method private visit_ref: 'env 'a 'b 'c .
863
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a ref -> 'b ref -> 'c ref
864 865
  = fun f env rx1 rx2 ->
      ref (f env !rx1 !rx2)
866

867
  method private visit_result: 'env 'a 'b 'c 'e 'f 'g .
868 869 870
    ('env -> 'a -> 'b -> 'c) ->
    ('env -> 'e -> 'f -> 'g) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> ('c, 'g) result
871 872 873 874 875
  = fun f g env r1 r2 ->
      match r1, r2 with
      | Ok a1, Ok a2 -> Ok (f env a1 a2)
      | Error b1, Error b2 -> Error (g env b1 b2)
      | _, _ -> fail()
876

877
  method private visit_string: 'env .
878
    'env -> string -> string -> string
879
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
880

881
  method private visit_unit: 'env .
882
    'env -> unit -> unit -> unit
883
  = fun _ _x1 _x2 -> ()
884 885

end
886

887 888 889 890
(* -------------------------------------------------------------------------- *)

(* [reduce2] *)

891 892
class virtual ['self] reduce2 = object (self : 'self)

893
  inherit ['s] monoid
894

895
  method private visit_array: 'env 'a 'b .
896
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a array -> 'b array -> 's
897
  = fun f env xs1 xs2 ->
898 899
      (* OCaml does not offer [Array.fold_left2], so we use [Array.iter2],
         which we inline. *)
900
      if Array.length xs1 = Array.length xs2 then
901
        let s = ref self#zero in
902 903 904
        for i = 0 to Array.length xs1 - 1 do
          let x1 = Array.unsafe_get xs1 i
          and x2 = Array.unsafe_get xs2 i in
905
          s := self#plus !s (f env x1 x2)
906
        done;
907
        !s
908 909 910
      else
        fail()

911
  method private visit_bool: 'env .
912
    'env -> bool -> bool -> 's
913 914 915
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

916
  method private visit_bytes: 'env .
917
    'env -> bytes -> bytes -> 's
918 919 920
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

921
  method private visit_char: 'env .
922
    'env -> char -> char -> 's
923 924 925
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

926
  method private visit_float: 'env .
927
    'env -> float -> float -> 's
928 929 930
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

931
  method private visit_int: 'env .
932
    'env -> int -> int -> 's
933 934 935
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

936
  method private visit_int32: 'env .
937
    'env -> int32 -> int32 -> 's
938 939 940
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

941
  method private visit_int64: 'env .
942
    'env -> int64 -> int64 -> 's
943 944 945
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

946
  method private visit_lazy_t: 'env 'a 'b .
947
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a Lazy.t -> 'b Lazy.t -> 's
948 949 950
  = fun f env (lazy x1) (lazy x2) ->
      f env x1 x2

951
  method private visit_list: 'env 'a 'b .
952
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a list -> 'b list -> 's
953
  = fun f env xs1 xs2 ->
954
      if List.length xs1 = List.length xs2 then
955
        List.fold_left2 (fun s x1 x2 -> self#plus s (f env x1 x2)) self#zero xs1 xs2
956 957 958
      else
        fail()

959
  method private visit_nativeint: 'env .
960
    'env -> nativeint -> nativeint -> 's
961 962 963
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

964
  method private visit_option: 'env 'a 'b .
965
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a option -> 'b option -> 's
966 967 968 969 970 971 972 973 974 975
  = fun f env ox1 ox2 ->
      match ox1, ox2 with
      | Some x1, Some x2 ->
          f env x1 x2
      | None, None ->
          self#zero
      | Some _, None
      | None, Some _ ->
          fail()

976
  method private visit_ref: 'env 'a 'b .
977
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a ref -> 'b ref -> 's
978 979 980
  = fun f env rx1 rx2 ->
      f env !rx1 !rx2

981
  method private visit_result: 'env 'a 'b 'e 'f .
982 983 984
    ('env -> 'a -> 'b -> 's) ->
    ('env -> 'e -> 'f -> 's) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> 's
985 986 987 988 989 990 991 992 993 994
  = fun f g env r1 r2 ->
      match r1, r2 with
      | Ok a1, Ok a2 ->
          f env a1 a2
      | Error b1, Error b2 ->
          g env b1 b2
      | Ok _, Error _
      | Error _, Ok _ ->
          fail()

995
  method private visit_string: 'env .
996
    'env -> string -> string -> 's
997 998 999
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

1000
  method private visit_unit: 'env .
1001
    'env -> unit -> unit -> 's
1002 1003 1004 1005
  = fun _env () () ->
      self#zero

end
1006 1007 1008

(* -------------------------------------------------------------------------- *)

1009 1010
(* [mapreduce2] *)

1011
class virtual ['self] mapreduce2 = object (self)
1012

1013
  inherit ['s] monoid
1014

1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032
  method private visit_array: 'env 'a 'b 'c .
    ('env -> 'a -> 'b -> 'c * 's) -> 'env -> 'a array -> 'b array -> 'c array * 's
  = fun f env xs1 xs2 ->
      let n1 = Array.length xs1
      and n2 = Array.length xs2 in
      if n1 = n2 then
        let s = ref self#zero in
        let xs = Array.init n1 (fun i ->
          let x1 = Array.unsafe_get xs1 i
          and x2 = Array.unsafe_get xs2 i in
          let x, sx = f env x1 x2 in
          s := self#plus !s sx;
          x
        ) in
        xs, !s
      else
        fail()

1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067
  method private visit_bool: 'env .
    'env -> bool -> bool -> bool * 's
  = fun _ x1 x2 -> if x1 = x2 then x1, self#zero else fail()

  method private visit_bytes: 'env .
    'env -> bytes -> bytes -> bytes * 's
  = fun _ x1 x2 -> if x1 = x2 then x1, self#zero else fail()

  method private visit_char: 'env .
    'env -> char -> char -> char * 's
  = fun _ x1 x2 -> if x1 = x2 then x1, self#zero else fail()

  method private visit_float: 'env .
    'env -> float -> float -> float * 's
  = fun _ x1 x2 -> if x1 = x2 then x1, self#zero else fail()

  method private visit_int: 'env .
    'env -> int -> int -> int * 's
  = fun _ x1 x2 -> if x1 = x2 then x1, self#zero else fail()

  method private visit_int32: 'env .
    'env -> int32 -> int32 -> int32 * 's
  = fun _ x1 x2 -> if x1 = x2 then x1, self#zero else fail()

  method private visit_int64: 'env .
    'env -> int64 -> int64 -> int64 * 's
  = fun _ x1 x2 -> if x1 = x2 then x1, self#zero else fail()

  method private visit_lazy_t: 'env 'a 'b 'c .
    ('env -> 'a -> 'b -> 'c * 's) -> 'env -> 'a Lazy.t -> 'b Lazy.t -> 'c Lazy.t * 's
  = fun f env (lazy x1) (lazy x2) ->
      (* As in [mapreduce]. *)
      let y, s = f env x1 x2 in
      lazy y, s

1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127
  method private visit_list: 'env 'a_0 'a_1 'a_2 .
    ('env -> 'a_0 -> 'a_1 -> 'a_2 * 's) ->
    'env -> 'a_0 list -> 'a_1 list -> 'a_2 list * 's
  = fun visit_'a env this_0 this_1 ->
      match this_0, this_1 with
      | [], [] ->
          [], self#zero
      | c0_0 :: c1_0, c0_1 :: c1_1 ->
          let r0, s0 = visit_'a env c0_0 c0_1 in
          let r1, s1 = self#visit_list visit_'a env c1_0 c1_1 in
          r0 :: r1, self#plus s0 s1
      | _, _ ->
          fail()

  method private visit_nativeint: 'env .
    'env -> nativeint -> nativeint -> nativeint * 's
  = fun _ x1 x2 -> if x1 = x2 then x1, self#zero else fail()

  method private visit_option: 'env 'a_0 'a_1 'a_2 .
    ('env -> 'a_0 -> 'a_1 -> 'a_2 * 's) ->
    'env -> 'a_0 option -> 'a_1 option -> 'a_2 option * 's
  = fun visit_'a env this_0 this_1 ->
      match this_0, this_1 with
      | None, None ->
          None, self#zero
      | Some c0_0, Some c0_1 ->
          let r0, s0 = visit_'a env c0_0 c0_1 in
          Some r0, s0
      | _, _ ->
          fail()

  method private visit_ref: 'env 'a_0 'a_1 'a_2 .
    ('env -> 'a_0 -> 'a_1 -> 'a_2 * 's) ->
    'env -> 'a_0 ref -> 'a_1 ref -> 'a_2 ref * 's
  = fun visit_'a env this_0 this_1 ->
      let r0, s0 = visit_'a env !this_0 !this_1 in
      ref r0, s0

  method private visit_result: 'env 'a_0 'a_1 'a_2 'b_0 'b_1 'b_2 .
    ('env -> 'a_0 -> 'a_1 -> 'a_2 * 's) ->
    ('env -> 'b_0 -> 'b_1 -> 'b_2 * 's) ->
    'env -> ('a_0, 'b_0) result -> ('a_1, 'b_1) result -> ('a_2, 'b_2) result * 's
  = fun visit_'a visit_'b env this_0 this_1 ->
      match this_0, this_1 with
      | Ok c0_0, Ok c0_1 ->
          let r0, s0 = visit_'a env c0_0 c0_1 in
          Ok r0, s0
      | Error c0_0, Error c0_1 ->
          let r0, s0 = visit_'b env c0_0 c0_1 in
          Error r0, s0
      | _, _ ->
          fail()

  method private visit_string: 'env .
    'env -> string -> string -> string * 's
  = fun _ x1 x2 -> if x1 = x2 then x1, self#zero else fail()

  method private visit_unit: 'env .
    'env -> unit -> unit -> unit * 's
  = fun _ () () -> (), self#zero
1128 1129

end
1130 1131 1132 1133 1134 1135 1136 1137 1138 1139

(* -------------------------------------------------------------------------- *)

(* [fold2] *)

class ['self] fold2 = object (_self)

  (* See the comment in the class [fold] above. *)

end