Source file VisitorsRuntime.ml

(* 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. *)

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

(* 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

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

(* [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

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

(* An exception used at arity 2 and above. *)

exception StructuralMismatch

let fail () =
  raise StructuralMismatch

let wrap f t =
  try
    f t;
    true
  with StructuralMismatch ->
    false

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

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

(* A virtual base class for monoids. *)

class virtual ['s] monoid = object
  method private virtual zero: 's
  method private virtual plus: 's -> 's -> 's
end

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

(* Common monoids. *)

class ['s] addition_monoid = object
  inherit ['s] monoid
  method private zero = 0
  method private plus = (+)
end

class ['s] unit_monoid = object
  inherit ['s] monoid
  method private zero = ()
  method private plus () () = ()
end

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

(* Visitor methods for the primitive types. *)

(* 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
   would messy. Note that, when using [@@deriving visitors { ... }], the user
   does have a choice whether the generated methods should be polymorphic in
   ['env]. *)

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

(* [iter] *)

class ['self] iter = object (self)

  method private visit_array: 'env 'a .
    ('env -> 'a -> unit) -> 'env -> 'a array -> unit
  = 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

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

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

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

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

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

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

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

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

  method private visit_list: 'env 'a .
    ('env -> 'a -> unit) -> 'env -> 'a list -> unit
  = fun f env xs ->
      match xs with
      | [] ->
          ()
      | x :: xs ->
          f env x;
          self # visit_list f env xs

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

  method private visit_option: 'env 'a .
    ('env -> 'a -> unit) -> 'env -> 'a option -> unit
  = fun f env ox ->
      match ox with
      | None ->
          ()
      | Some x ->
          f env x

  method private visit_ref: 'env 'a .
    ('env -> 'a -> unit) -> 'env -> 'a ref -> unit
  = fun f env rx ->
      f env !rx

  method private visit_result: 'env 'a 'e.
    ('env -> 'a -> unit) ->
    ('env -> 'e -> unit) ->
     'env -> ('a, 'e) result -> unit
  = fun f g env r ->
      match r with
      | Ok a -> f env a
      | Error b -> g env b

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

  method private visit_unit: 'env .
    'env -> unit -> unit
  = fun _ _ -> ()

end

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

(* [map] *)

class ['self] map = object (self)

  method private visit_array: 'env 'a 'b .
    ('env -> 'a -> 'b) -> 'env -> 'a array -> 'b array
  = fun f env xs ->
      Array.map (f env) xs
      (* We could in principle inline [Array.map] so as to avoid allocating
         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. *)

  method private visit_bool: 'env .
    'env -> bool -> bool
  = fun _ x -> x

  method private visit_bytes: 'env .
    'env -> bytes -> bytes
  = fun _ x -> x

  method private visit_char: 'env .
    'env -> char -> char
  = fun _ x -> x

  method private visit_float: 'env .
    'env -> float -> float
  = fun _ x -> x

  method private visit_int: 'env .
    'env -> int -> int
  = fun _ x -> x

  method private visit_int32: 'env .
    'env -> int32 -> int32
  = fun _ x -> x

  method private visit_int64: 'env .
    'env -> int64 -> int64
  = fun _ x -> x

  method private visit_lazy_t: 'env 'a 'b .
    ('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))

  method private visit_list: 'env 'a 'b .
    ('env -> 'a -> 'b) -> 'env -> 'a list -> 'b list
  = fun f env xs ->
      match xs with
      | [] ->
          []
      | x :: xs ->
          let x = f env x in
          x :: self # visit_list f env xs

  method private visit_nativeint: 'env .
    'env -> nativeint -> nativeint
  = fun _ x -> x

  method private visit_option: 'env 'a 'b .
    ('env -> 'a -> 'b) -> 'env -> 'a option -> 'b option
  = fun f env ox ->
      match ox with
      | None ->
          None
      | Some x ->
          Some (f env x)

  method private visit_ref: 'env 'a 'b .
    ('env -> 'a -> 'b) -> 'env -> 'a ref -> 'b ref
  = fun f env rx ->
      ref (f env !rx)

  method private visit_result: 'env 'a 'b 'e 'f .
    ('env -> 'a -> 'b) ->
    ('env -> 'e -> 'f) ->
     'env -> ('a, 'e) result -> ('b, 'f) result
  = fun f g env r ->
      match r with
      | Ok a -> Ok (f env a)
      | Error b -> Error (g env b)

  method private visit_string: 'env .
    'env -> string -> string
  = fun _ x -> x

  method private visit_unit: 'env .
    'env -> unit -> unit
  = fun _ x -> x

end

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

(* [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. *)

  method private visit_array: 'env 'a .
    ('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'

  method private visit_bool: 'env .
    'env -> bool -> bool
  = fun _ x -> x

  method private visit_bytes: 'env .
    'env -> bytes -> bytes
  = fun _ x -> x

  method private visit_char:'env .
    'env -> char -> char
  = fun _ x -> x

  method private visit_float: 'env .
    'env -> float -> float
  = fun _ x -> x

  method private visit_int: 'env .
    'env -> int -> int
  = fun _ x -> x

  method private visit_int32: 'env .
    'env -> int32 -> int32
  = fun _ x -> x

  method private visit_int64: 'env .
    'env -> int64 -> int64
  = fun _ x -> x

  method private visit_lazy_t : 'env 'a .
    ('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'

  method private visit_list: 'env 'a .
    ('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'

  method private visit_nativeint: 'env .
    'env -> nativeint -> nativeint
  = fun _ x -> x

  method private visit_option: 'env 'a .
    ('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. *)

  method private visit_ref: 'env 'a .
    ('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'

  method private visit_result: 'env 'a 'e .
    ('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'

  method private visit_string: 'env .
    'env -> string -> string
  = fun _ x -> x

  method private visit_unit: 'env .
    'env -> unit -> unit
  = fun _ x -> x

end

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

(* [reduce] *)

(* 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. *)

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

  inherit ['s] monoid

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

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

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

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

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

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

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

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

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

  method private visit_list: 'env 'a .
    ('env -> 'a -> 's) -> 'env -> 'a list -> 's
  = fun f env xs ->
      self # list_fold_left f env self#zero xs
      (* The above line is equivalent to the following: *)
      (* List.fold_left (fun s x -> self#plus s (f env x)) self#zero xs *)
      (* 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. *)

  method private list_fold_left: 'env 'a .
    ('env -> 'a -> 's) -> 'env -> 's -> 'a list -> 's
  = fun f env s xs ->
    match xs with
    | [] ->
        s
    | x :: xs ->
        let s = self#plus s (f env x) in
        self # list_fold_left f env s xs

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

  method private visit_option: 'env 'a .
    ('env -> 'a -> 's) -> 'env -> 'a option -> 's
  = fun f env ox ->
      match ox with
      | Some x ->
          f env x
      | None ->
          self#zero

  method private visit_ref: 'env 'a .
    ('env -> 'a -> 's) -> 'env -> 'a ref -> 's
  = fun f env rx ->
      f env !rx

  method private visit_result: 'env 'a 'e .
    ('env -> 'a -> 's) ->
    ('env -> 'e -> 's) ->
     'env -> ('a, 'e) result -> 's
  = fun f g env r ->
      match r with
      | Ok a ->
          f env a
      | Error b ->
          g env b

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

  method private visit_unit: 'env .
    'env -> unit -> 's
  = fun _env _ -> self#zero

end

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

(* [mapreduce] *)

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

  inherit ['s] monoid

  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

  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

  method private visit_list: 'env 'a 'b .
    ('env -> 'a -> 'b * 's) -> 'env -> 'a list -> 'b list * 's
  = fun f env xs ->
      match xs with
      | [] ->
          [], self#zero
      | x :: xs ->
          let x, sx = f env x in
          let xs, sxs = self # visit_list f env xs in
          x :: xs, self#plus sx sxs
      (* 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

  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 in
      ref 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

  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

end

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

(* [fold] *)

class ['self] fold = object (_self)

  (* 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 [VisitorsRuntime.map] is likely to be
     appropriate in many situations. *)

end

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

(* [iter2] *)

class ['self] iter2 = object (self)

  method private visit_array: 'env 'a 'b .
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a array -> 'b array -> unit
  = fun f env xs1 xs2 ->
      (* We inline [Array.iter2]. *)
      if Array.length xs1 = Array.length xs2 then
        for i = 0 to Array.length xs1 - 1 do
          f env (Array.unsafe_get xs1 i) (Array.unsafe_get xs2 i)
        done
      else
        fail()

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

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

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

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

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

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

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

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

  method private visit_list: 'env 'a 'b .
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a list -> 'b list -> unit
  = 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()

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

  method private visit_option: 'env 'a 'b .
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a option -> 'b option -> unit
  = fun f env ox1 ox2 ->
      match ox1, ox2 with
      | None, None ->
          ()
      | Some x1, Some x2 ->
          f env x1 x2
      | _, _ ->
          fail()

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

  method private visit_result: 'env 'a 'b 'e 'f .
    ('env -> 'a -> 'b -> unit) ->
    ('env -> 'e -> 'f -> unit) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> unit
  = 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()

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

  method private visit_unit: 'env .
    'env -> unit -> unit -> unit
  = fun _ _x1 _x2 -> ()

end

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

(* [map2] *)

class ['self] map2 = object (self)

  method private visit_array: 'env 'a 'b 'c .
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a array -> 'b array -> 'c array
  = fun f env xs1 xs2 ->
      if Array.length xs1 = Array.length xs2 then
        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. *)
      else
        fail()

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

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

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

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

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

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

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

  method private visit_lazy_t: 'env 'a 'b 'c .
    ('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))

  method private visit_list: 'env 'a 'b 'c .
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a list -> 'b list -> 'c list
  = 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()

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

  method private visit_option: 'env 'a 'b 'c .
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a option -> 'b option -> 'c option
  = 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()

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

  method private visit_result: 'env 'a 'b 'c 'e 'f 'g .
    ('env -> 'a -> 'b -> 'c) ->
    ('env -> 'e -> 'f -> 'g) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> ('c, 'g) result
  = 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()

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

  method private visit_unit: 'env .
    'env -> unit -> unit -> unit
  = fun _ _x1 _x2 -> ()

end

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

(* [reduce2] *)

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

  inherit ['s] monoid

  method private visit_array: 'env 'a 'b .
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a array -> 'b array -> 's
  = fun f env xs1 xs2 ->
      (* OCaml does not offer [Array.fold_left2], so we use [Array.iter2],
         which we inline. *)
      if Array.length xs1 = Array.length xs2 then
        let s = ref self#zero in
        for i = 0 to Array.length xs1 - 1 do
          let x1 = Array.unsafe_get xs1 i
          and x2 = Array.unsafe_get xs2 i in
          s := self#plus !s (f env x1 x2)
        done;
        !s
      else
        fail()

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

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

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

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

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

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

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

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

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

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

  method private visit_option: 'env 'a 'b .
    ('env -> 'a -> 'b -> 's) -> 'env -> 'a option -> 'b option -> 's
  = 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()

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

  method private visit_result: 'env 'a 'b 'e 'f .
    ('env -> 'a -> 'b -> 's) ->
    ('env -> 'e -> 'f -> 's) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> 's
  = 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()

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

  method private visit_unit: 'env .
    'env -> unit -> unit -> 's
  = fun _env () () ->
      self#zero

end

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

(* [mapreduce2] *)

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

  inherit ['s] monoid

  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()

  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

  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

end

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

(* [fold2] *)

class ['self] fold2 = object (_self)

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

end