equality_with_objects.ml

(*
 * Structural equality of objects in OO langauges like Java is
 * typically implemented using downcasts, guarded by instanceof
 * checks. The (dynamically checked) downcast provides the
 * necessary access to the structure of the other object.
 *
 * OCaml lacks downcasts, but similar access can be granted in a
 * typesafe way with equality witnesses.
 *)

let hash_array_by_id insn_array =
  Array.fold_left
    (fun sum insn -> sum + Oo.id insn)
    810625825 insn_array

let arrays_eq a b =
  let rec loop a b i bound =
    if i = bound then true
    else if a.(i) == b.(i) then loop a b (i + 1) bound
    else false in
  loop a b 0 (Array.length a)

type (_,_) equality = Refl : ('a,'a) equality

let cast : type a b . (a, b) equality -> a -> b = fun Refl x -> x

module EqTag : sig
  type 'a t
  val create : unit -> 'a t
  val equal : 'a t -> 'b t -> ('a, 'b) equality option
end = struct
  type 'a tag = ..;;
  type 'a polymorphic_equality = {
    eq : 'b . ('a tag -> 'b tag -> ('a, 'b) equality option);
  }
  type 'a t = 'a tag * 'a polymorphic_equality
  let create (type s) () =
    let module M = struct
      type _ tag += Tag : s tag
      let eq : type a b . a tag -> b tag -> (a, b) equality option =
        fun a b ->
          match a, b with
          | Tag, Tag -> Some Refl
          | _, _ -> None
    end in
    M.Tag, {eq = M.eq}
  let equal (tag1, {eq}) (tag2, _) = eq tag1 tag2
end

type tag = Tagged : 'a * 'a EqTag.t -> tag

class type insn = object ('self)
  method tag : tag
  method hash : int
  method self_equal : 'self -> bool
  method equal : <tag : tag; ..> -> bool
end

class virtual ['a] instruction (self_tag : 'a EqTag.t) = object (self)
  val inputs : insn array = [||]
  method virtual self_equal : 'a -> bool
  method equal : 'b . (<tag:tag; ..> as 'b) -> bool =
    fun other ->
      let Tagged (o, otag) = other#tag in
      match EqTag.equal otag self_tag with
      | Some refl -> self#self_equal (cast refl o)
      | None -> false
end

let boolean_tag = EqTag.create ()
let boolean_bits = Random.bits ()
class boolean b =
  object (self)
    inherit [boolean] instruction boolean_tag
    method tag = Tagged ((self :> boolean), boolean_tag)
    method hash = boolean_bits + if b then 1 else 0
    method self_equal other = b = other#value
    method value = b
  end

let integer_tag = EqTag.create ()
let integer_bits = Random.bits ()
class integer n =
  object (self)
    inherit [integer] instruction integer_tag
    method tag = Tagged ((self :> integer), integer_tag)
    method hash = integer_bits + n
    method self_equal other = n = other#value
    method value = n
  end