Point example from “Inheritance is not subtyping” https://doi.org/10.1145/96709.96721

inheritance_is_not_subtyping.ml

(** Point example from {{: https://doi.org/10.1145/96709.96721} “Inheritance is not subtyping”} *)

[@@@warning "-unused-value-declaration"]

type color = Red | Green

class type ['a] point = object
  method x : float
  method y : float
  method move : float -> float -> 'a
  method equal : 'a -> bool
end

class type ['a] color_point = object
  inherit ['a] point
  method color : color
end

class ['a] cart_point' (make : float -> float -> 'a) (x : float) (y : float) : ['a] point =
  object (self)

    constraint 'a = 'a #point

    method x = x
    method y = y

    method move (dx : float) (dy : float) : 'a =
      make (self#x +. dx) (self#y +. dy)

    method equal (other : 'a) : bool =
      self#x = other#x && self#y = other#y

  end

class ['a] color_point' (make : float -> float -> color -> 'a) (x : float) (y : float) (c : color) : ['a] color_point =
  object (self)

    constraint 'a = 'a #color_point

    inherit ['a] cart_point' (fun x y -> make x y c) x y as super

    method color : color = c

    method! equal (other : 'a) : bool =
      super#equal other && self#color = other#color

  end

let rec cart_point (x : float) (y : float) : 'a point as 'a =
  new cart_point' cart_point x y

let rec color_point (x : float) (y : float) (c : color) : 'a color_point as 'a =
  new color_point' color_point x y c

let () = begin

  let p1 = color_point 3.0 4.0 Red in
  let p2 = color_point 3.5 4.5 Green in

  assert (p1#equal p1);
  assert (not ((p1#move 0.5 0.5)#equal p2));
  assert ((p1#move 0.5 0.5)#equal (color_point 3.5 4.5 Red));

end

(*
module Bad = struct

  class p = object (self : 'self)
    method i : int = 5
    method id : 'self = self
    method eq (other : 'self) : bool =
      self#i = other#i
  end

  class c = object (self : 'self)
    inherit p as super
    method b : int = 5
    method! eq (other : 'self) : bool =
      self#i = other#i && self#b = other#b
  end

  let _test (x : p) =
    let v : p = (new c :> p) in
    (*          ^^^^^^^^^^^^
      Error: Type c = < b : int; eq : c -> bool; i : int; id : c >
        is not a subtype of p = < eq : p -> bool; i : int; id : p >
        Type p = < eq : p -> bool; i : int; id : p > is not a subtype of
          c = < b : int; eq : c -> bool; i : int; id : c >
        The first object type has no method b
    *)
    v#eq x

end
*)