VisitorsRuntime.ml 31.5 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 557 558 559 560 561 562 563 564 565 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
  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

593
  method private visit_list: 'env 'a 'b .
594
    ('env -> 'a -> 'b * 's) -> 'env -> 'a list -> 'b list * 's
595 596 597 598 599
  = fun f env xs ->
      match xs with
      | [] ->
          [], self#zero
      | x :: xs ->
600 601 602
          let x, sx = f env x in
          let xs, sxs = self # visit_list f env xs in
          x :: xs, self#plus sx sxs
603 604 605 606 607 608 609 610 611
      (* 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
612

613 614 615 616 617 618 619 620 621 622 623 624 625 626 627
  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 ->
628 629
      let r0, s0 = visit_'a env !this in
      ref r0, s0
630 631 632 633 634 635 636 637 638 639 640 641 642 643

  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

644 645 646 647 648 649 650
  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
651 652 653 654 655

end

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

656 657 658 659
(* [fold] *)

class ['self] fold = object (_self)

660 661
  (* 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
Typo.  
POTTIER Francois committed
662
     appropriate methods. Note that [VisitorsRuntime.map] is likely to be
663 664
     appropriate in many situations. *)

665 666 667 668
end

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

669 670
(* [iter2] *)

671
class ['self] iter2 = object (self)
672

673
  method private visit_array: 'env 'a 'b .
674
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a array -> 'b array -> unit
675
  = fun f env xs1 xs2 ->
676
      (* We inline [Array.iter2]. *)
677
      if Array.length xs1 = Array.length xs2 then
678 679 680
        for i = 0 to Array.length xs1 - 1 do
          f env (Array.unsafe_get xs1 i) (Array.unsafe_get xs2 i)
        done
681 682
      else
        fail()
683

684
  method private visit_bool: 'env .
685
    'env -> bool -> bool -> unit
686
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
687

688
  method private visit_bytes: 'env .
POTTIER Francois's avatar
POTTIER Francois committed
689 690 691
    'env -> bytes -> bytes -> unit
  = fun _ x1 x2 -> if x1 = x2 then () else fail()

692
  method private visit_char: 'env .
693
    'env -> char -> char -> unit
694
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
695

696
  method private visit_float: 'env .
697
    'env -> float -> float -> unit
698
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
699

700
  method private visit_int: 'env .
701
    'env -> int -> int -> unit
702
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
703

704
  method private visit_int32: 'env .
705
    'env -> int32 -> int32 -> unit
706
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
707

708
  method private visit_int64: 'env .
709
    'env -> int64 -> int64 -> unit
710
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
711

712
  method private visit_lazy_t: 'env 'a 'b .
POTTIER Francois's avatar
POTTIER Francois committed
713 714 715 716
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a Lazy.t -> 'b Lazy.t -> unit
  = fun f env (lazy x1) (lazy x2) ->
      f env x1 x2

717
  method private visit_list: 'env 'a 'b .
718
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a list -> 'b list -> unit
719 720 721 722 723 724 725 726 727
  = 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()
728

729
  method private visit_nativeint: 'env .
730 731 732
    'env -> nativeint -> nativeint -> unit
  = fun _ x1 x2 -> if x1 = x2 then () else fail()

733
  method private visit_option: 'env 'a 'b .
734
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a option -> 'b option -> unit
735 736 737 738 739 740 741 742
  = fun f env ox1 ox2 ->
      match ox1, ox2 with
      | None, None ->
          ()
      | Some x1, Some x2 ->
          f env x1 x2
      | _, _ ->
          fail()
743

744
  method private visit_ref: 'env 'a 'b .
745
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a ref -> 'b ref -> unit
746 747
  = fun f env rx1 rx2 ->
      f env !rx1 !rx2
748

749
  method private visit_result: 'env 'a 'b 'e 'f .
750 751 752
    ('env -> 'a -> 'b -> unit) ->
    ('env -> 'e -> 'f -> unit) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> unit
753 754 755 756 757
  = 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()
758

759
  method private visit_string: 'env .
760
    'env -> string -> string -> unit
761
  = fun _ x1 x2 -> if x1 = x2 then () else fail()
762

763
  method private visit_unit: 'env .
764
    'env -> unit -> unit -> unit
765
  = fun _ _x1 _x2 -> ()
766 767

end
768

769 770 771 772
(* -------------------------------------------------------------------------- *)

(* [map2] *)

773
class ['self] map2 = object (self)
774

775
  method private visit_array: 'env 'a 'b 'c .
776
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a array -> 'b array -> 'c array
777 778 779 780 781
  = fun f env xs1 xs2 ->
      if Array.length xs1 = Array.length xs2 then
        Array.map2 (f env) xs1 xs2
      else
        fail()
782

783
  method private visit_bool: 'env .
784
    'env -> bool -> bool -> bool
785
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
786

787
  method private visit_bytes: 'env .
POTTIER Francois's avatar
POTTIER Francois committed
788 789 790
    'env -> bytes -> bytes -> bytes
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()

791
  method private visit_char: 'env .
792
    'env -> char -> char -> char
793
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
794

795
  method private visit_float: 'env .
796
    'env -> float -> float -> float
797
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
798

799
  method private visit_int: 'env .
800
    'env -> int -> int -> int
801
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
802

803
  method private visit_int32: 'env .
804
    'env -> int32 -> int32 -> int32
805
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
806

807
  method private visit_int64: 'env .
808
    'env -> int64 -> int64 -> int64
809
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
810

811
  method private visit_lazy_t: 'env 'a 'b 'c .
POTTIER Francois's avatar
POTTIER Francois committed
812 813 814 815 816
    ('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))

817
  method private visit_list: 'env 'a 'b 'c .
818
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a list -> 'b list -> 'c list
819 820 821 822 823 824 825 826 827
  = 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()
828

829
  method private visit_nativeint: 'env .
830 831 832
    'env -> nativeint -> nativeint -> nativeint
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()

833
  method private visit_option: 'env 'a 'b 'c .
834
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a option -> 'b option -> 'c option
835 836 837 838 839 840 841 842 843
  = 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()
844

845
  method private visit_ref: 'env 'a 'b 'c .
846
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a ref -> 'b ref -> 'c ref
847 848
  = fun f env rx1 rx2 ->
      ref (f env !rx1 !rx2)
849

850
  method private visit_result: 'env 'a 'b 'c 'e 'f 'g .
851 852 853
    ('env -> 'a -> 'b -> 'c) ->
    ('env -> 'e -> 'f -> 'g) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> ('c, 'g) result
854 855 856 857 858
  = 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()
859

860
  method private visit_string: 'env .
861
    'env -> string -> string -> string
862
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()
863

864
  method private visit_unit: 'env .
865
    'env -> unit -> unit -> unit
866
  = fun _ _x1 _x2 -> ()
867 868

end
869

870 871 872 873
(* -------------------------------------------------------------------------- *)

(* [reduce2] *)

874 875
class virtual ['self] reduce2 = object (self : 'self)

876
  inherit ['s] monoid
877

878
  method private visit_array: 'env 'a 'b .
879
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a array -> 'b array -> 's
880
  = fun f env xs1 xs2 ->
881 882
      (* OCaml does not offer [Array.fold_left2], so we use [Array.iter2],
         which we inline. *)
883
      if Array.length xs1 = Array.length xs2 then
884
        let s = ref self#zero in
885 886 887
        for i = 0 to Array.length xs1 - 1 do
          let x1 = Array.unsafe_get xs1 i
          and x2 = Array.unsafe_get xs2 i in
888
          s := self#plus !s (f env x1 x2)
889
        done;
890
        !s
891 892 893
      else
        fail()

894
  method private visit_bool: 'env .
895
    'env -> bool -> bool -> 's
896 897 898
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

899
  method private visit_bytes: 'env .
900
    'env -> bytes -> bytes -> 's
POTTIER Francois's avatar
POTTIER Francois committed
901 902 903
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

904
  method private visit_char: 'env .
905
    'env -> char -> char -> 's
906 907 908
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

909
  method private visit_float: 'env .
910
    'env -> float -> float -> 's
911 912 913
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

914
  method private visit_int: 'env .
915
    'env -> int -> int -> 's
916 917 918
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

919
  method private visit_int32: 'env .
920
    'env -> int32 -> int32 -> 's
921 922 923
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

924
  method private visit_int64: 'env .
925
    'env -> int64 -> int64 -> 's
926 927 928
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

929
  method private visit_lazy_t: 'env 'a 'b .
930
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a Lazy.t -> 'b Lazy.t -> 's
POTTIER Francois's avatar
POTTIER Francois committed
931 932 933
  = fun f env (lazy x1) (lazy x2) ->
      f env x1 x2

934
  method private visit_list: 'env 'a 'b .
935
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a list -> 'b list -> 's
936
  = fun f env xs1 xs2 ->
937
      if List.length xs1 = List.length xs2 then
938
        List.fold_left2 (fun s x1 x2 -> self#plus s (f env x1 x2)) self#zero xs1 xs2
939 940 941
      else
        fail()

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

947
  method private visit_option: 'env 'a 'b .
948
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a option -> 'b option -> 's
949 950 951 952 953 954 955 956 957 958
  = 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()

959
  method private visit_ref: 'env 'a 'b .
960
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a ref -> 'b ref -> 's