VisitorsRuntime.ml 26.1 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 23 24 25 26 27 28 29 30 31
(* [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
32 33
(* An exception used at arity 2 and above. *)

POTTIER Francois's avatar
POTTIER Francois committed
34 35 36 37 38
exception StructuralMismatch

let fail () =
  raise StructuralMismatch

39 40 41 42 43 44 45 46 47 48 49 50 51 52
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
53 54
(* -------------------------------------------------------------------------- *)

55 56
(* A virtual base class for monoids. *)

57 58 59
class virtual ['s] monoid = object
  method private virtual zero: 's
  method private virtual plus: 's -> 's -> 's
60 61 62 63 64 65
end

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

(* Common monoids. *)

66 67
class ['s] addition_monoid = object
  inherit ['s] monoid
68 69
  method private zero = 0
  method private plus = (+)
70 71
end

72 73
class ['s] unit_monoid = object
  inherit ['s] monoid
POTTIER Francois's avatar
POTTIER Francois committed
74 75 76 77
  method private zero = ()
  method private plus () () = ()
end

78 79
(* -------------------------------------------------------------------------- *)

80
(* Visitor methods for the primitive types. *)
81

82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97
(* 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
98 99 100
   would messy. Note that, when using [@@deriving visitors { ... }], the user
   does have a choice whether the generated methods should be polymorphic in
   ['env]. *)
101

102 103
(* -------------------------------------------------------------------------- *)

104
(* [iter] *)
105

106
class ['self] iter = object (self)
107

108
  method private visit_array: 'env 'a .
109
    ('env -> 'a -> unit) -> 'env -> 'a array -> unit
110 111 112 113 114 115
  = 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
116

117
  method private visit_bool: 'env .
118
    'env -> bool -> unit
119
  = fun _ _ -> ()
120

121
  method private visit_bytes: 'env .
POTTIER Francois's avatar
POTTIER Francois committed
122 123 124
    'env -> bytes -> unit
  = fun _ _ -> ()

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

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

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

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

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

145
  method private visit_lazy_t: 'env 'a .
POTTIER Francois's avatar
POTTIER Francois committed
146 147 148 149
    ('env -> 'a -> unit) -> 'env -> 'a Lazy.t -> unit
  = fun f env (lazy x) ->
      f env x

150
  method private visit_list: 'env 'a .
151
    ('env -> 'a -> unit) -> 'env -> 'a list -> unit
152 153 154 155 156 157 158
  = fun f env xs ->
      match xs with
      | [] ->
          ()
      | x :: xs ->
          f env x;
          self # visit_list f env xs
159

160
  method private visit_nativeint: 'env .
161 162 163
    'env -> nativeint -> unit
  = fun _ _ -> ()

164
  method private visit_option: 'env 'a .
165
    ('env -> 'a -> unit) -> 'env -> 'a option -> unit
166 167 168 169 170 171
  = fun f env ox ->
      match ox with
      | None ->
          ()
      | Some x ->
          f env x
172

173
  method private visit_ref: 'env 'a .
174
    ('env -> 'a -> unit) -> 'env -> 'a ref -> unit
175 176
  = fun f env rx ->
      f env !rx
177

178
  method private visit_result: 'env 'a 'e.
179 180 181
    ('env -> 'a -> unit) ->
    ('env -> 'e -> unit) ->
     'env -> ('a, 'e) result -> unit
182 183 184 185
  = fun f g env r ->
      match r with
      | Ok a -> f env a
      | Error b -> g env b
186

187
  method private visit_string: 'env .
188
    'env -> string -> unit
189
  = fun _ _ -> ()
190

191
  method private visit_unit: 'env .
192
    'env -> unit -> unit
193
  = fun _ _ -> ()
194 195

end
196

197 198 199 200
(* -------------------------------------------------------------------------- *)

(* [map] *)

201
class ['self] map = object (self)
202

203
  method private visit_array: 'env 'a 'b .
204
    ('env -> 'a -> 'b) -> 'env -> 'a array -> 'b array
205 206
  = fun f env xs ->
      Array.map (f env) xs
207
      (* We could in principle inline [Array.map] so as to avoid allocating
POTTIER Francois's avatar
POTTIER Francois committed
208 209
         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. *)
210

211
  method private visit_bool: 'env .
212
    'env -> bool -> bool
213
  = fun _ x -> x
214

215
  method private visit_bytes: 'env .
POTTIER Francois's avatar
POTTIER Francois committed
216 217 218
    'env -> bytes -> bytes
  = fun _ x -> x

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

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

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

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

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

239
  method private visit_lazy_t: 'env 'a 'b .
POTTIER Francois's avatar
POTTIER Francois committed
240 241 242 243 244 245 246 247 248
    ('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))

249
  method private visit_list: 'env 'a 'b .
250
    ('env -> 'a -> 'b) -> 'env -> 'a list -> 'b list
251 252 253 254 255 256 257
  = fun f env xs ->
      match xs with
      | [] ->
          []
      | x :: xs ->
          let x = f env x in
          x :: self # visit_list f env xs
258

259
  method private visit_nativeint: 'env .
260 261 262
    'env -> nativeint -> nativeint
  = fun _ x -> x

263
  method private visit_option: 'env 'a 'b .
264
    ('env -> 'a -> 'b) -> 'env -> 'a option -> 'b option
265 266 267 268 269 270
  = fun f env ox ->
      match ox with
      | None ->
          None
      | Some x ->
          Some (f env x)
271

272
  method private visit_ref: 'env 'a 'b .
273
    ('env -> 'a -> 'b) -> 'env -> 'a ref -> 'b ref
274 275
  = fun f env rx ->
      ref (f env !rx)
276

277
  method private visit_result: 'env 'a 'b 'e 'f .
278 279 280
    ('env -> 'a -> 'b) ->
    ('env -> 'e -> 'f) ->
     'env -> ('a, 'e) result -> ('b, 'f) result
281 282 283 284
  = fun f g env r ->
      match r with
      | Ok a -> Ok (f env a)
      | Error b -> Error (g env b)
285

286
  method private visit_string: 'env .
287
    'env -> string -> string
288
  = fun _ x -> x
289

290
  method private visit_unit: 'env .
291
    'env -> unit -> unit
292
  = fun _ x -> x
293 294

end
295

296 297
(* -------------------------------------------------------------------------- *)

298 299 300 301 302 303 304 305 306 307 308 309 310
(* [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. *)

311
  method private visit_array: 'env 'a .
312 313 314 315 316
    ('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'

317
  method private visit_bool: 'env .
318 319 320
    'env -> bool -> bool
  = fun _ x -> x

321
  method private visit_bytes: 'env .
POTTIER Francois's avatar
POTTIER Francois committed
322 323 324
    'env -> bytes -> bytes
  = fun _ x -> x

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

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

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

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

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

345
  method private visit_lazy_t : 'env 'a .
POTTIER Francois's avatar
POTTIER Francois committed
346 347 348 349 350 351 352 353 354 355 356
    ('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'

357
  method private visit_list: 'env 'a .
358 359 360 361 362 363 364 365 366 367 368 369 370
    ('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'

371
  method private visit_nativeint: 'env .
372 373 374
    'env -> nativeint -> nativeint
  = fun _ x -> x

375
  method private visit_option: 'env 'a .
376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392
    ('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. *)

393
  method private visit_ref: 'env 'a .
394 395 396 397 398 399 400 401 402
    ('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'

403
  method private visit_result: 'env 'a 'e .
404 405 406 407 408 409 410 411 412 413 414 415
    ('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'

416
  method private visit_string: 'env .
417 418 419
    'env -> string -> string
  = fun _ x -> x

420
  method private visit_unit: 'env .
421 422 423 424 425 426 427
    'env -> unit -> unit
  = fun _ x -> x

end

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

428 429
(* [reduce] *)

430 431
class virtual ['self] reduce = object (self : 'self)

432
  inherit ['s] monoid
433

434
  method private visit_array: 'env 'a .
435
    ('env -> 'a -> 's) -> 'env -> 'a array -> 's
436
  = fun f env xs ->
437
      Array.fold_left (fun s x -> self#plus s (f env x)) self#zero xs
438 439 440
      (* 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. *)
441

442
  method private visit_bool: 'env .
443
    'env -> bool -> 's
444 445
  = fun _env _ -> self#zero

446
  method private visit_bytes: 'env .
447
    'env -> bytes -> 's
POTTIER Francois's avatar
POTTIER Francois committed
448 449
  = fun _env _ -> self#zero

450
  method private visit_char: 'env .
451
    'env -> char -> 's
452 453
  = fun _env _ -> self#zero

454
  method private visit_float: 'env .
455
    'env -> float -> 's
456 457
  = fun _env _ -> self#zero

458
  method private visit_int: 'env .
459
    'env -> int -> 's
460 461
  = fun _env _ -> self#zero

462
  method private visit_int32: 'env .
463
    'env -> int32 -> 's
464 465
  = fun _env _ -> self#zero

466
  method private visit_int64: 'env .
467
    'env -> int64 -> 's
468 469
  = fun _env _ -> self#zero

470
  method private visit_lazy_t: 'env 'a .
471
    ('env -> 'a -> 's) -> 'env -> 'a Lazy.t -> 's
POTTIER Francois's avatar
POTTIER Francois committed
472 473 474
  = fun f env (lazy x) ->
      f env x

475
  method private visit_list: 'env 'a .
476
    ('env -> 'a -> 's) -> 'env -> 'a list -> 's
477
  = fun f env xs ->
478 479
      self # list_fold_left f env self#zero xs
      (* The above line is equivalent to the following: *)
480
      (* List.fold_left (fun s x -> self#plus s (f env x)) self#zero xs *)
481 482 483 484 485
      (* 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. *)

486
  method private list_fold_left: 'env 'a .
487 488
    ('env -> 'a -> 's) -> 'env -> 's -> 'a list -> 's
  = fun f env s xs ->
489 490
    match xs with
    | [] ->
491
        s
492
    | x :: xs ->
493 494
        let s = self#plus s (f env x) in
        self # list_fold_left f env s xs
495

496
  method private visit_nativeint: 'env .
497
    'env -> nativeint -> 's
498 499
  = fun _env _ -> self#zero

500
  method private visit_option: 'env 'a .
501
    ('env -> 'a -> 's) -> 'env -> 'a option -> 's
502 503 504 505 506 507 508
  = fun f env ox ->
      match ox with
      | Some x ->
          f env x
      | None ->
          self#zero

509
  method private visit_ref: 'env 'a .
510
    ('env -> 'a -> 's) -> 'env -> 'a ref -> 's
511 512 513
  = fun f env rx ->
      f env !rx

514
  method private visit_result: 'env 'a 'e .
515 516 517
    ('env -> 'a -> 's) ->
    ('env -> 'e -> 's) ->
     'env -> ('a, 'e) result -> 's
518 519 520 521 522 523 524
  = fun f g env r ->
      match r with
      | Ok a ->
          f env a
      | Error b ->
          g env b

525
  method private visit_string: 'env .
526
    'env -> string -> 's
527 528
  = fun _env _ -> self#zero

529
  method private visit_unit: 'env .
530
    'env -> unit -> 's
531 532 533
  = fun _env _ -> self#zero

end
534

535 536
(* -------------------------------------------------------------------------- *)

537 538
(* [mapreduce] *)

539
class virtual ['self] mapreduce = object (self : 'self)
540

541
  inherit ['s] monoid
542

543 544 545 546 547 548 549 550 551 552 553 554 555
  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

556
  method private visit_list: 'env 'a 'b .
557
    ('env -> 'a -> 'b * 's) -> 'env -> 'a list -> 'b list * 's
558 559 560 561 562
  = fun f env xs ->
      match xs with
      | [] ->
          [], self#zero
      | x :: xs ->
563 564 565
          let x, sx = f env x in
          let xs, sxs = self # visit_list f env xs in
          x :: xs, self#plus sx sxs
566

567 568 569 570 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
  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 ->
      let r0, s0 = visit_'a env this.contents in
      { contents = r0 }, s0

  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

598 599 600 601 602 603
  (* TEMPORARY *)

end

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

604 605 606 607
(* [fold] *)

class ['self] fold = object (_self)

608 609 610 611 612
  (* 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
     appropriate methods. Note that [RuntimeVisitors.map] is likely to be
     appropriate in many situations. *)

613 614 615 616
end

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

617 618
(* [iter2] *)

619
class ['self] iter2 = object (self)
620

621
  method private visit_array: 'env 'a 'b .
622
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a array -> 'b array -> unit
623
  = fun f env xs1 xs2 ->
624
      (* We inline [Array.iter2]. *)
625
      if Array.length xs1 = Array.length xs2 then
626 627 628
        for i = 0 to Array.length xs1 - 1 do
          f env (Array.unsafe_get xs1 i) (Array.unsafe_get xs2 i)
        done
629 630
      else
        fail()
631

632
  method private visit_bool: 'env .
633
    'env -> bool -> bool -> unit
634
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
635

636
  method private visit_bytes: 'env .
POTTIER Francois's avatar
POTTIER Francois committed
637 638 639
    'env -> bytes -> bytes -> unit
  = fun _ x1 x2 -> if x1 = x2 then () else fail()

640
  method private visit_char: 'env .
641
    'env -> char -> char -> unit
642
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
643

644
  method private visit_float: 'env .
645
    'env -> float -> float -> unit
646
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
647

648
  method private visit_int: 'env .
649
    'env -> int -> int -> unit
650
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
651

652
  method private visit_int32: 'env .
653
    'env -> int32 -> int32 -> unit
654
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
655

656
  method private visit_int64: 'env .
657
    'env -> int64 -> int64 -> unit
658
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
659

660
  method private visit_lazy_t: 'env 'a 'b .
POTTIER Francois's avatar
POTTIER Francois committed
661 662 663 664
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a Lazy.t -> 'b Lazy.t -> unit
  = fun f env (lazy x1) (lazy x2) ->
      f env x1 x2

665
  method private visit_list: 'env 'a 'b .
666
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a list -> 'b list -> unit
667 668 669 670 671 672 673 674 675
  = 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()
676

677
  method private visit_nativeint: 'env .
678 679 680
    'env -> nativeint -> nativeint -> unit
  = fun _ x1 x2 -> if x1 = x2 then () else fail()

681
  method private visit_option: 'env 'a 'b .
682
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a option -> 'b option -> unit
683 684 685 686 687 688 689 690
  = fun f env ox1 ox2 ->
      match ox1, ox2 with
      | None, None ->
          ()
      | Some x1, Some x2 ->
          f env x1 x2
      | _, _ ->
          fail()
691

692
  method private visit_ref: 'env 'a 'b .
693
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a ref -> 'b ref -> unit
694 695
  = fun f env rx1 rx2 ->
      f env !rx1 !rx2
696

697
  method private visit_result: 'env 'a 'b 'e 'f .
698 699 700
    ('env -> 'a -> 'b -> unit) ->
    ('env -> 'e -> 'f -> unit) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> unit
701 702 703 704 705
  = 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()
706

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

711
  method private visit_unit: 'env .
712
    'env -> unit -> unit -> unit
713
  = fun _ _x1 _x2 -> ()
714 715

end
716

717 718 719 720
(* -------------------------------------------------------------------------- *)

(* [map2] *)

721
class ['self] map2 = object (self)
722

723
  method private visit_array: 'env 'a 'b 'c .
724
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a array -> 'b array -> 'c array
725 726 727 728 729
  = fun f env xs1 xs2 ->
      if Array.length xs1 = Array.length xs2 then
        Array.map2 (f env) xs1 xs2
      else
        fail()
730

731
  method private visit_bool: 'env .
732
    'env -> bool -> bool -> bool
733
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
734

735
  method private visit_bytes: 'env .
POTTIER Francois's avatar
POTTIER Francois committed
736 737 738
    'env -> bytes -> bytes -> bytes
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()

739
  method private visit_char: 'env .
740
    'env -> char -> char -> char
741
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
742

743
  method private visit_float: 'env .
744
    'env -> float -> float -> float
745
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
746

747
  method private visit_int: 'env .
748
    'env -> int -> int -> int
749
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
750

751
  method private visit_int32: 'env .
752
    'env -> int32 -> int32 -> int32
753
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
754

755
  method private visit_int64: 'env .
756
    'env -> int64 -> int64 -> int64
757
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
758

759
  method private visit_lazy_t: 'env 'a 'b 'c .
POTTIER Francois's avatar
POTTIER Francois committed
760 761 762 763 764
    ('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))

765
  method private visit_list: 'env 'a 'b 'c .
766
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a list -> 'b list -> 'c list
767 768 769 770 771 772 773 774 775
  = 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()
776

777
  method private visit_nativeint: 'env .
778 779 780
    'env -> nativeint -> nativeint -> nativeint
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()

781
  method private visit_option: 'env 'a 'b 'c .
782
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a option -> 'b option -> 'c option
783 784 785 786 787 788 789 790 791
  = 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()
792

793
  method private visit_ref: 'env 'a 'b 'c .
794
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a ref -> 'b ref -> 'c ref
795 796
  = fun f env rx1 rx2 ->
      ref (f env !rx1 !rx2)
797

798
  method private visit_result: 'env 'a 'b 'c 'e 'f 'g .
799 800 801
    ('env -> 'a -> 'b -> 'c) ->
    ('env -> 'e -> 'f -> 'g) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> ('c, 'g) result
802 803 804 805 806
  = 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()
807

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

812
  method private visit_unit: 'env .
813
    'env -> unit -> unit -> unit
814
  = fun _ _x1 _x2 -> ()
815 816

end
817

818 819 820 821
(* -------------------------------------------------------------------------- *)

(* [reduce2] *)

822 823
class virtual ['self] reduce2 = object (self : 'self)

824
  inherit ['s] monoid
825

826
  method private visit_array: 'env 'a 'b .
827
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a array -> 'b array -> 's
828
  = fun f env xs1 xs2 ->
829 830
      (* OCaml does not offer [Array.fold_left2], so we use [Array.iter2],
         which we inline. *)
831
      if Array.length xs1 = Array.length xs2 then
832
        let s = ref self#zero in
833 834 835
        for i = 0 to Array.length xs1 - 1 do
          let x1 = Array.unsafe_get xs1 i
          and x2 = Array.unsafe_get xs2 i in
836
          s := self#plus !s (f env x1 x2)
837
        done;
838
        !s
839 840 841
      else
        fail()

842
  method private visit_bool: 'env .
843
    'env -> bool -> bool -> 's
844 845 846
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

847
  method private visit_bytes: 'env .
848
    'env -> bytes -> bytes -> 's
POTTIER Francois's avatar
POTTIER Francois committed
849 850 851
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

852
  method private visit_char: 'env .
853
    'env -> char -> char -> 's
854 855 856
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

857
  method private visit_float: 'env .
858
    'env -> float -> float -> 's
859 860 861
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

862
  method private visit_int: 'env .
863
    'env -> int -> int -> 's
864 865 866
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

867
  method private visit_int32: 'env .
868
    'env -> int32 -> int32 -> 's
869 870 871
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

872
  method private visit_int64: 'env .
873
    'env -> int64 -> int64 -> 's
874 875 876
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

877
  method private visit_lazy_t: 'env 'a 'b .
878
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a Lazy.t -> 'b Lazy.t -> 's
POTTIER Francois's avatar
POTTIER Francois committed
879 880 881
  = fun f env (lazy x1) (lazy x2) ->
      f env x1 x2

882
  method private visit_list: 'env 'a 'b .
883
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a list -> 'b list -> 's
884
  = fun f env xs1 xs2 ->
885
      if List.length xs1 = List.length xs2 then
886
        List.fold_left2 (fun s x1 x2 -> self#plus s (f env x1 x2)) self#zero xs1 xs2
887 888 889
      else
        fail()

890
  method private visit_nativeint: 'env .
891
    'env -> nativeint -> nativeint -> 's
892 893 894
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

895
  method private visit_option: 'env 'a 'b .
896
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a option -> 'b option -> 's
897 898 899 900 901 902 903 904 905 906
  = 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()

907
  method private visit_ref: 'env 'a 'b .
908
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a ref -> 'b ref -> 's
909 910 911
  = fun f env rx1 rx2 ->
      f env !rx1 !rx2

912
  method private visit_result: 'env 'a 'b 'e 'f .
913 914 915
    ('env -> 'a -> 'b -> 's) ->
    ('env -> 'e -> 'f -> 's) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> 's
916 917 918 919 920 921 922 923 924 925
  = 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()

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

931
  method private visit_unit: 'env .
932
    'env -> unit -> unit -> 's
933 934 935 936
  = fun _env () () ->
      self#zero

end
937 938 939 940 941 942 943

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

(* [fold2] *)

class ['self] fold2 = object (_self)