VisitorsRuntime.ml 22.2 KB
Newer Older
POTTIER Francois's avatar
POTTIER Francois committed
1 2
(* -------------------------------------------------------------------------- *)

3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
(* [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
20 21
(* An exception used at arity 2 and above. *)

POTTIER Francois's avatar
POTTIER Francois committed
22 23 24 25 26
exception StructuralMismatch

let fail () =
  raise StructuralMismatch

27 28 29 30 31 32 33 34 35 36 37 38 39 40
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
41 42
(* -------------------------------------------------------------------------- *)

43 44 45
(* A virtual base class for monoids. *)

class virtual ['z] monoid = object
46 47
  method private virtual zero: 'z
  method private virtual plus: 'z -> 'z -> 'z
48 49 50 51 52 53 54 55
end

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

(* Common monoids. *)

class ['z] addition_monoid = object
  inherit ['z] monoid
56 57
  method private zero = 0
  method private plus = (+)
58 59 60 61
end

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

62
(* Visitor methods for the primitive types. *)
63

64 65
(* -------------------------------------------------------------------------- *)

66
(* [iter] *)
67

68
class ['self] iter = object (self)
69

70
  method private visit_array: 'env 'a .
71
    ('env -> 'a -> unit) -> 'env -> 'a array -> unit
72 73 74 75 76 77
  = 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
78

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

POTTIER Francois's avatar
POTTIER Francois committed
83 84 85 86
  method private visit_bytes: 'env .
    'env -> bytes -> unit
  = fun _ _ -> ()

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

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

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

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

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

POTTIER Francois's avatar
POTTIER Francois committed
107 108 109 110 111
  method private visit_lazy_t: 'env 'a .
    ('env -> 'a -> unit) -> 'env -> 'a Lazy.t -> unit
  = fun f env (lazy x) ->
      f env x

112
  method private visit_list: 'env 'a .
113
    ('env -> 'a -> unit) -> 'env -> 'a list -> unit
114 115 116 117 118 119 120
  = fun f env xs ->
      match xs with
      | [] ->
          ()
      | x :: xs ->
          f env x;
          self # visit_list f env xs
121

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

126
  method private visit_option: 'env 'a .
127
    ('env -> 'a -> unit) -> 'env -> 'a option -> unit
128 129 130 131 132 133
  = fun f env ox ->
      match ox with
      | None ->
          ()
      | Some x ->
          f env x
134

135
  method private visit_ref: 'env 'a .
136
    ('env -> 'a -> unit) -> 'env -> 'a ref -> unit
137 138
  = fun f env rx ->
      f env !rx
139

140
  method private visit_result: 'env 'a 'e.
141 142 143
    ('env -> 'a -> unit) ->
    ('env -> 'e -> unit) ->
     'env -> ('a, 'e) result -> unit
144 145 146 147
  = fun f g env r ->
      match r with
      | Ok a -> f env a
      | Error b -> g env b
148

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

153
  method private visit_unit: 'env .
154
    'env -> unit -> unit
155
  = fun _ _ -> ()
156 157

end
158

159 160 161 162
(* -------------------------------------------------------------------------- *)

(* [map] *)

163
class ['self] map = object (self)
164

165
  method private visit_array: 'env 'a 'b .
166
    ('env -> 'a -> 'b) -> 'env -> 'a array -> 'b array
167 168
  = fun f env xs ->
      Array.map (f env) xs
169
      (* We could in principle inline [Array.map] so as to avoid allocating
POTTIER Francois's avatar
POTTIER Francois committed
170 171
         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. *)
172

173
  method private visit_bool: 'env .
174
    'env -> bool -> bool
175
  = fun _ x -> x
176

POTTIER Francois's avatar
POTTIER Francois committed
177 178 179 180
  method private visit_bytes: 'env .
    'env -> bytes -> bytes
  = fun _ x -> x

181
  method private visit_char: 'env .
182
    'env -> char -> char
183
  = fun _ x -> x
184

185
  method private visit_float: 'env .
186
    'env -> float -> float
187
  = fun _ x -> x
188

189
  method private visit_int: 'env .
190
    'env -> int -> int
191
  = fun _ x -> x
192

193
  method private visit_int32: 'env .
194
    'env -> int32 -> int32
195
  = fun _ x -> x
196

197
  method private visit_int64: 'env .
198
    'env -> int64 -> int64
199
  = fun _ x -> x
200

POTTIER Francois's avatar
POTTIER Francois committed
201 202 203 204 205 206 207 208 209 210
  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))

211
  method private visit_list: 'env 'a 'b .
212
    ('env -> 'a -> 'b) -> 'env -> 'a list -> 'b list
213 214 215 216 217 218 219
  = fun f env xs ->
      match xs with
      | [] ->
          []
      | x :: xs ->
          let x = f env x in
          x :: self # visit_list f env xs
220

221 222 223 224
  method private visit_nativeint: 'env .
    'env -> nativeint -> nativeint
  = fun _ x -> x

225
  method private visit_option: 'env 'a 'b .
226
    ('env -> 'a -> 'b) -> 'env -> 'a option -> 'b option
227 228 229 230 231 232
  = fun f env ox ->
      match ox with
      | None ->
          None
      | Some x ->
          Some (f env x)
233

234
  method private visit_ref: 'env 'a 'b .
235
    ('env -> 'a -> 'b) -> 'env -> 'a ref -> 'b ref
236 237
  = fun f env rx ->
      ref (f env !rx)
238

239
  method private visit_result: 'env 'a 'b 'e 'f .
240 241 242
    ('env -> 'a -> 'b) ->
    ('env -> 'e -> 'f) ->
     'env -> ('a, 'e) result -> ('b, 'f) result
243 244 245 246
  = fun f g env r ->
      match r with
      | Ok a -> Ok (f env a)
      | Error b -> Error (g env b)
247

248
  method private visit_string: 'env .
249
    'env -> string -> string
250
  = fun _ x -> x
251

252
  method private visit_unit: 'env .
253
    'env -> unit -> unit
254
  = fun _ x -> x
255 256

end
257

258 259
(* -------------------------------------------------------------------------- *)

260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282
(* [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

POTTIER Francois's avatar
POTTIER Francois committed
283 284 285 286
  method private visit_bytes: 'env .
    'env -> bytes -> bytes
  = fun _ x -> x

287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306
  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

POTTIER Francois's avatar
POTTIER Francois committed
307 308 309 310 311 312 313 314 315 316 317 318
  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'

319 320 321 322 323 324 325 326 327 328 329 330 331 332
  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'

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

337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389
  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

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

390 391
(* [reduce] *)

392 393 394 395
class virtual ['self] reduce = object (self : 'self)

  inherit ['z] monoid

396
  method private visit_array: 'env 'a .
397 398
    ('env -> 'a -> 'z) -> 'env -> 'a array -> 'z
  = fun f env xs ->
399
      Array.fold_left (fun z x -> self#plus z (f env x)) self#zero xs
400 401 402
      (* 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. *)
403

404
  method private visit_bool: 'env .
405 406 407
    'env -> bool -> 'z
  = fun _env _ -> self#zero

POTTIER Francois's avatar
POTTIER Francois committed
408 409 410 411
  method private visit_bytes: 'env .
    'env -> bytes -> 'z
  = fun _env _ -> self#zero

412
  method private visit_char: 'env .
413 414 415
    'env -> char -> 'z
  = fun _env _ -> self#zero

416
  method private visit_float: 'env .
417 418 419
    'env -> float -> 'z
  = fun _env _ -> self#zero

420
  method private visit_int: 'env .
421 422 423
    'env -> int -> 'z
  = fun _env _ -> self#zero

424
  method private visit_int32: 'env .
425 426 427
    'env -> int32 -> 'z
  = fun _env _ -> self#zero

428
  method private visit_int64: 'env .
429 430 431
    'env -> int64 -> 'z
  = fun _env _ -> self#zero

POTTIER Francois's avatar
POTTIER Francois committed
432 433 434 435 436
  method private visit_lazy_t: 'env 'a .
    ('env -> 'a -> 'z) -> 'env -> 'a Lazy.t -> 'z
  = fun f env (lazy x) ->
      f env x

437
  method private visit_list: 'env 'a .
438 439
    ('env -> 'a -> 'z) -> 'env -> 'a list -> 'z
  = fun f env xs ->
440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456
      self # list_fold_left f env self#zero xs
      (* The above line is equivalent to the following: *)
      (* List.fold_left (fun z x -> self#plus z (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 -> 'z) -> 'env -> 'z -> 'a list -> 'z
  = fun f env z xs ->
    match xs with
    | [] ->
        z
    | x :: xs ->
        let z = self#plus z (f env x) in
        self # list_fold_left f env z xs
457

458 459 460 461
  method private visit_nativeint: 'env .
    'env -> nativeint -> 'z
  = fun _env _ -> self#zero

462
  method private visit_option: 'env 'a .
463 464 465 466 467 468 469 470
    ('env -> 'a -> 'z) -> 'env -> 'a option -> 'z
  = fun f env ox ->
      match ox with
      | Some x ->
          f env x
      | None ->
          self#zero

471
  method private visit_ref: 'env 'a .
472 473 474 475
    ('env -> 'a -> 'z) -> 'env -> 'a ref -> 'z
  = fun f env rx ->
      f env !rx

476
  method private visit_result: 'env 'a 'e .
477 478 479 480 481 482 483 484 485 486
    ('env -> 'a -> 'z) ->
    ('env -> 'e -> 'z) ->
     'env -> ('a, 'e) result -> 'z
  = fun f g env r ->
      match r with
      | Ok a ->
          f env a
      | Error b ->
          g env b

487
  method private visit_string: 'env .
488 489 490
    'env -> string -> 'z
  = fun _env _ -> self#zero

491
  method private visit_unit: 'env .
492 493 494 495
    'env -> unit -> 'z
  = fun _env _ -> self#zero

end
496

497 498
(* -------------------------------------------------------------------------- *)

499 500 501 502 503 504 505 506
(* [fold] *)

class ['self] fold = object (_self)

end

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

507 508
(* [iter2] *)

509
class ['self] iter2 = object (self)
510

511
  method private visit_array: 'env 'a 'b .
512
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a array -> 'b array -> unit
513
  = fun f env xs1 xs2 ->
514
      (* We inline [Array.iter2]. *)
515
      if Array.length xs1 = Array.length xs2 then
516 517 518
        for i = 0 to Array.length xs1 - 1 do
          f env (Array.unsafe_get xs1 i) (Array.unsafe_get xs2 i)
        done
519 520
      else
        fail()
521

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

POTTIER Francois's avatar
POTTIER Francois committed
526 527 528 529
  method private visit_bytes: 'env .
    'env -> bytes -> bytes -> unit
  = fun _ x1 x2 -> if x1 = x2 then () else fail()

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

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

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

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

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

POTTIER Francois's avatar
POTTIER Francois committed
550 551 552 553 554
  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

555
  method private visit_list: 'env 'a 'b .
556
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a list -> 'b list -> unit
557 558 559 560 561 562 563 564 565
  = 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()
566

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

571
  method private visit_option: 'env 'a 'b .
572
    ('env -> 'a -> 'b -> unit) -> 'env -> 'a option -> 'b option -> unit
573 574 575 576 577 578 579 580
  = fun f env ox1 ox2 ->
      match ox1, ox2 with
      | None, None ->
          ()
      | Some x1, Some x2 ->
          f env x1 x2
      | _, _ ->
          fail()
581

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

587
  method private visit_result: 'env 'a 'b 'e 'f .
588 589 590
    ('env -> 'a -> 'b -> unit) ->
    ('env -> 'e -> 'f -> unit) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> unit
591 592 593 594 595
  = 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()
596

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

601
  method private visit_unit: 'env .
602
    'env -> unit -> unit -> unit
603
  = fun _ _x1 _x2 -> ()
604 605

end
606

607 608 609 610
(* -------------------------------------------------------------------------- *)

(* [map2] *)

611
class ['self] map2 = object (self)
612

613
  method private visit_array: 'env 'a 'b 'c .
614
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a array -> 'b array -> 'c array
615 616 617 618 619
  = fun f env xs1 xs2 ->
      if Array.length xs1 = Array.length xs2 then
        Array.map2 (f env) xs1 xs2
      else
        fail()
620

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

POTTIER Francois's avatar
POTTIER Francois committed
625 626 627 628
  method private visit_bytes: 'env .
    'env -> bytes -> bytes -> bytes
  = fun _ x1 x2 -> if x1 = x2 then x1 else fail()

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

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

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

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

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

POTTIER Francois's avatar
POTTIER Francois committed
649 650 651 652 653 654
  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))

655
  method private visit_list: 'env 'a 'b 'c .
656
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a list -> 'b list -> 'c list
657 658 659 660 661 662 663 664 665
  = 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()
666

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

671
  method private visit_option: 'env 'a 'b 'c .
672
    ('env -> 'a -> 'b -> 'c) -> 'env -> 'a option -> 'b option -> 'c option
673 674 675 676 677 678 679 680 681
  = 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()
682

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

688
  method private visit_result: 'env 'a 'b 'c 'e 'f 'g .
689 690 691
    ('env -> 'a -> 'b -> 'c) ->
    ('env -> 'e -> 'f -> 'g) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> ('c, 'g) result
692 693 694 695 696
  = 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()
697

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

702
  method private visit_unit: 'env .
703
    'env -> unit -> unit -> unit
704
  = fun _ _x1 _x2 -> ()
705 706

end
707

708 709 710 711
(* -------------------------------------------------------------------------- *)

(* [reduce2] *)

712 713 714 715
class virtual ['self] reduce2 = object (self : 'self)

  inherit ['z] monoid

716
  method private visit_array: 'env 'a 'b .
717 718
    ('env -> 'a -> 'b -> 'z) -> 'env -> 'a array -> 'b array -> 'z
  = fun f env xs1 xs2 ->
719 720
      (* OCaml does not offer [Array.fold_left2], so we use [Array.iter2],
         which we inline. *)
721
      if Array.length xs1 = Array.length xs2 then
722
        let z = ref self#zero in
723 724 725
        for i = 0 to Array.length xs1 - 1 do
          let x1 = Array.unsafe_get xs1 i
          and x2 = Array.unsafe_get xs2 i in
726
          z := self#plus !z (f env x1 x2)
727
        done;
728 729 730 731
        !z
      else
        fail()

732
  method private visit_bool: 'env .
733 734 735 736
    'env -> bool -> bool -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

POTTIER Francois's avatar
POTTIER Francois committed
737 738 739 740 741
  method private visit_bytes: 'env .
    'env -> bytes -> bytes -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

742
  method private visit_char: 'env .
743 744 745 746
    'env -> char -> char -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

747
  method private visit_float: 'env .
748 749 750 751
    'env -> float -> float -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

752
  method private visit_int: 'env .
753 754 755 756
    'env -> int -> int -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

757
  method private visit_int32: 'env .
758 759 760 761
    'env -> int32 -> int32 -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

762
  method private visit_int64: 'env .
763 764 765 766
    'env -> int64 -> int64 -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

POTTIER Francois's avatar
POTTIER Francois committed
767 768 769 770 771
  method private visit_lazy_t: 'env 'a 'b .
    ('env -> 'a -> 'b -> 'z) -> 'env -> 'a Lazy.t -> 'b Lazy.t -> 'z
  = fun f env (lazy x1) (lazy x2) ->
      f env x1 x2

772
  method private visit_list: 'env 'a 'b .
773 774
    ('env -> 'a -> 'b -> 'z) -> 'env -> 'a list -> 'b list -> 'z
  = fun f env xs1 xs2 ->
775 776
      if List.length xs1 = List.length xs2 then
        List.fold_left2 (fun z x1 x2 -> self#plus z (f env x1 x2)) self#zero xs1 xs2
777 778 779
      else
        fail()

780 781 782 783 784
  method private visit_nativeint: 'env .
    'env -> nativeint -> nativeint -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

785
  method private visit_option: 'env 'a 'b .
786 787 788 789 790 791 792 793 794 795 796
    ('env -> 'a -> 'b -> 'z) -> 'env -> 'a option -> 'b option -> 'z
  = 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()

797
  method private visit_ref: 'env 'a 'b .
798 799 800 801
    ('env -> 'a -> 'b -> 'z) -> 'env -> 'a ref -> 'b ref -> 'z
  = fun f env rx1 rx2 ->
      f env !rx1 !rx2

802
  method private visit_result: 'env 'a 'b 'e 'f .
803 804 805 806 807 808 809 810 811 812 813 814 815
    ('env -> 'a -> 'b -> 'z) ->
    ('env -> 'e -> 'f -> 'z) ->
     'env -> ('a, 'e) result -> ('b, 'f) result -> 'z
  = 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()

816
  method private visit_string: 'env .
817 818 819 820
    'env -> string -> string -> 'z
  = fun _env x1 x2 ->
      if x1 = x2 then self#zero else fail()

821
  method private visit_unit: 'env .
822 823 824 825 826
    'env -> unit -> unit -> 'z
  = fun _env () () ->
      self#zero

end
827 828 829 830 831 832 833 834

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

(* [fold2] *)

class ['self] fold2 = object (_self)

end