Message passing by record labels, variants, GADTs and polymorphic variants.

gistfile1.ml

open Printf

module ByMonomorphicRecord = struct

  (* Interface by a monomorphic record *)    
  type point = {
    get : unit -> int;
    set : int -> unit;
    print : unit -> unit;
  }

  (* Test code. Message by record label *)
  let test_point (p : point) =
    p .print ();
    p .set 1;
    p .print ()

  (* Class point *)
  let point x =
    let x = ref x in
    { get = (fun () -> !x);
      set = (fun x' -> x := x');
      print = (fun () -> printf "x=%d\n" !x);
    }

  (* Class flipped point *)
  let flipped_point x =
    let x = ref x in
    { get = (fun () -> !x);
      set = (fun x' -> x := x');
      print = (fun () -> printf "x=%d\n" !x);
    }

  (* Since point and flipped_point share the same interface (=type),
     test_point can handle the both. *)
  let () =
    test_point (point 0);
    test_point (flipped_point 0);

  (* Sub interface colored_point *)
  type colored_point = {
    get' : unit -> int;
    set' : int -> unit;
    print' : unit -> unit;
    get_color' : unit -> string;
    set_color' : string -> unit;
  }
  (* Problem: since we use the monomorphic record,
     we cannot share the labels get, set and print.

     Copy+pasting the the definition of the super class text
     can be done automatic with some proper mechanism.
  *)


  (* Problem: we have to use different labels *)
  let test_colored_point cp =
    cp .print' ();
    cp .set' 1;
    cp .print' ()

  (* Class colored point, subclass of point.

     Here the inherited methods are defined from scratch but
     I believe they can be imported nicely from the super class
     with some more tweaking.
  *)
  let colored_point x col =
    let x = ref x in
    let col = ref col in
    { get' = (fun () -> !x);
      set' = (fun x' -> x := x');
      print' = (fun () -> printf "x=%d col=%s\n" !x !col);
      get_color' = (fun () -> !col);
      set_color' = (fun col' -> col := col');
    }

  let () = test_colored_point (colored_point 0 "red")

  (* Upcast: Problem: we need to convert it.

     The code can be generated automatically but it is inefficient.
  *)
  let point_of_colored_point cp = 
    { get   = cp.get';
      set   = cp.set';
      print = cp.print' 
    }

  (* Applying a function for the super class: We need expliciti upcast. *)
  let () = test_point (point_of_colored_point (colored_point 0 "red"))

  (* Putting objects together: we need expliciti upcast. *)
  let () = 
    List.iter test_point [ point 0;
                           flipped_point 0;
                           point_of_colored_point (colored_point 0 "red") ]

  (* Conclusion 

     * No message name sharing
     * Upcasting requres copies.
  *)
end

module ByVariant = struct

  (* Mimicing higher kinded polymorphism *)
  module M : sig
    type ('ret, 'meth) app
    val inj : 'meth -> ('ret, 'meth) app
    val prj : ('ret, 'meth) app -> 'meth
  end = struct
    type ('ret, 'meth) app = 'meth
    let inj x = x
    let prj x = x
  end

  open M

  (* 'meth o : An object whose interface is 'meth.

     This is 

          type 'meth o = ('ret . 'ret 'meth -> 'ret)

     but it is not possible in OCaml:

     * We need higher rank polymorphism therefore use polymorphic record memeber
     * We need higher kinded polymoprhism therefore use M.app trick

  *)
  type 'meth o = { o : 'ret . ('ret, 'meth) app -> 'ret }

  (* Message passing.

     The message's type is ('ret, 'meth) app, which is the encoding of
     'ret 'meth,
     where
       * 'ret is the return type of the method
       * 'meth is the interface
  *)
  let meth : 'meth o -> ('ret, 'meth) app -> 'ret = fun o m -> o.o m

  (* Interface of point as variant *)
  type point_intf = 
    | Get
    | Set of int
    | Print

  (* Add the return types as ghost parameters to point_intf.
     At the same time we convert the type to the app version
     in order to apply them to meth more easily.

     The direct use of the constructors Get, Set and Print must be
     prohibited by the module signature since with M.inj 
     we can fabricate methods with wrong return types.

     These can be auto generated.
  *)
  let get   : (int,  point_intf) app = M.inj Get
  let set x : (unit, point_intf) app = M.inj (Set x)
  let print : (unit, point_intf) app = M.inj Print

  (* Test code *)    
  let test o =
    meth o print;
    meth o (set (meth o get + 1));
    meth o print

  (* Method definition of class point. 
     Methods may return different typed values and therefore
     we cannot make this definition well-typed without the use of Obj.magic.
     But this is type-safe as far as messages with proper types 
     by get, set and print are used.
  *)
  let point_meth x (m: ('res, _) app) : 'res = match M.prj m with
    | Get    -> Obj.magic !x
    | Set x' -> Obj.magic (x := x')
    | Print  -> Obj.magic (printf "x=%d\n" !x)

  (* New (or class) of point *)
  let point_new x =
    let x = ref x in
    { o = fun m -> point_meth x m }

  let () = 
    print_endline "by variant";
    test (point_new 0)

  (* flipped_point, which inherits point *)
  let flipped_point_meth x (m: ('res, _) app) : 'res = match M.prj m with
    | Set x' -> Obj.magic (x := -x') (* override *)
    | _ -> point_meth x m (* inherit *)

  let flipped_point_new x =
    let x = ref x in
    { o = fun m -> flipped_point_meth x m }

  (* We can put point and flipped_point in one list, since they have
     the same type (interface). *)
  let () = 
    test (flipped_point_new 0);
    List.iter test [ point_new 0; flipped_point_new 0 ]

  (* Sub interface: colored_point.

     The super interface are wrapped by Point constructor.
  *)
  type colored_point_intf = 
    | Point of point_intf (* inherit *)
    | Get_color
    | Set_color of string

  (* Adding return types as ghost parameters.
     We need to use different message names get', set' and print'
     since they have different types from the super messages.

     The inherited interfaces can be autogenerated.
  *)
  let get'   : (int,  colored_point_intf) app = M.inj (Point (M.prj get))
  let set' x : (unit, colored_point_intf) app = M.inj (Point (M.prj (set x)))
  let print' : (unit, colored_point_intf) app = M.inj (Point (M.prj print))
  let get_color : (string, colored_point_intf) app = M.inj Get_color
  let set_color c : (unit, colored_point_intf) app = M.inj (Set_color c)

  let test' o =
    meth o print';
    meth o (set' (meth o get' + 1));
    meth o (set_color "blue");
    meth o print'

  (* Sub methods definition.
     How methods are merged is controlled by the order of pattern matching.

     Accesses to the super class methods require extra pattern match,
     which costs a bit.
  *)
  let colored_point_meth x c (m: ('res, _) app) : 'res = match M.prj m with
    | Point Print -> (* override *)
        Obj.magic (printf "x=%d col=%s\n" !x !c)
    | Point m -> point_meth x (M.inj m) (* inherit *)
    | Get_color -> Obj.magic !c
    | Set_color c' -> Obj.magic (c := c')

  (* Sub new/class *)
  let colored_point_new x c =
    let x = ref x in
    let c = ref c in
    { o = fun m -> colored_point_meth x c m }

  let () = test' (colored_point_new 0 "red")

  (* Upcast: upcast requres the lifting of method from super to sub.
     This needs a bit of runtime penalty but much smaller than 
     the one by monomorphic records
  *)
  let point_of_colored_point o = 
    { o = fun m -> meth o (M.inj (Point (M.prj m))) }

  let () =
    (* Appliying a function for the super requires explicit upcasting *)
    test (point_of_colored_point (colored_point_new 0 "red"));

    (* Putting super and sub objects in one list require explicit upcasting *)
    List.iter (fun o -> meth o print) 
      [ point_new 0;
        point_of_colored_point (colored_point_new 0 "red") ]

  (* Conclusion

     * labels cannot be shared between super and sub classes 
     * call of super methods costs a bit
     * upcasting is less costy than the mono-record version but still there is
  *)
end


module ByGADT = struct

  (* Almost the same as ByVariant. 

     Only difference is that we no longer require Obj.magic 
     for the method return types.
  *)

  type ('ret, 'meth) app
  (*
     We omit defining the inj/prj between 'ret 'meth and
    ('ret, 'meth) app.
  *)

  (* 'ret . 'ret 'meth app -> 'ret *)
  type 'meth o = { o : 'ret . ('ret, 'meth) app -> 'ret }

  let meth : 'meth o -> ('ret, 'meth) app -> 'ret = fun o m -> o.o m

  type point_intf_

  type _ point_intf = 
    | Get : int point_intf
    | Set : int -> unit point_intf
    | Print : unit point_intf

  (* If we had higher kinded polymorphism, we do not need this...
     inj/prj are now replaced by Obj.magic
  *)
  let get   : (int,  point_intf_) app = Obj.magic Get
  let set x : (unit, point_intf_) app = Obj.magic (Set x)
  let print : (unit, point_intf_) app = Obj.magic Print

  let test o =
    meth o print;
    meth o (set (meth o get + 1));
    meth o print

  (* GADT requires explicit type annotation... 

     Now we need no Obj.magic for the return type of each method.
  *)
  let point_meth : type res . int ref -> (res, point_intf_) app -> res = 
    fun x m -> 
      match (Obj.magic m : res point_intf) with
      | Get    -> !x
      | Set x' -> x := x'
      | Print  -> printf "x=%d\n" !x

  let point_new x =
    let x = ref x in
    { o = fun m -> point_meth x m }

  let () = 
    print_endline "by GADT";
    test (point_new 0)

  let flipped_point_meth : type res . int ref -> (res, point_intf_) app -> res = 
    fun x m ->
      match (Obj.magic m : res point_intf) with
      | Set x' -> x := -x'
      | _ -> point_meth x m

  let flipped_point_new x =
    let x = ref x in
    { o = fun m -> flipped_point_meth x m }

  let () = 
    test (flipped_point_new 0);
    List.iter test [ point_new 0; flipped_point_new 0 ]

  type colored_point_intf_

  type _ colored_point_intf = 
    | Point     : 'a point_intf -> 'a colored_point_intf
    | Get_color : string colored_point_intf
    | Set_color : string -> unit colored_point_intf

  let get'   : (int,  colored_point_intf_) app = Obj.magic (Point Get)
  let set' x : (unit, colored_point_intf_) app = Obj.magic (Point (Set x))
  let print' : (unit, colored_point_intf_) app = Obj.magic (Point Print)
  let get_color :   (string, colored_point_intf_) app = Obj.magic Get_color
  let set_color c : (unit,   colored_point_intf_) app = Obj.magic (Set_color c)

  let test' o =
    meth o print';
    meth o (set' (meth o get' + 1));
    meth o (set_color "blue");
    meth o print'

  let colored_point_meth : type res . int ref -> string ref -> (res, colored_point_intf_) app -> res =
    fun x c m ->
      match (Obj.magic m : res colored_point_intf) with
      | Point Print -> (* override *)
          printf "x=%d col=%s\n" !x !c
      | Point m -> point_meth x (Obj.magic m) (* inherit *)
      | Get_color -> !c
      | Set_color c' -> c := c'

  let colored_point_new x c =
    let x = ref x in
    let c = ref c in
    { o = fun m -> colored_point_meth x c m }

  let () = test' (colored_point_new 0 "red")

  let point_of_colored_point o = 
    { o = fun m -> meth o (Obj.magic (Point (Obj.magic m))) }

  let () =
    test (point_of_colored_point (colored_point_new 0 "red"));

    List.iter (fun o -> meth o print) 
      [ point_new 0;
        point_of_colored_point (colored_point_new 0 "red") ]
    
  (* Conclusion

     * Same as ByVariant
     * GADT only helps the type inference of the method return types.
  *)
end



module ByPolyVariant = struct

  (* By Variants and GADT's, we could not embed a super interface
     into its sub interface directly. We needed a wrapper:
       Point of point_intf.

     Here, with the polymorphic variant we try direct embedding.
  *)

  module M : sig
    type ('ret, 'meth) app
    val inj : 'meth -> ('ret, 'meth) app
    val prj : ('ret, 'meth) app -> 'meth
  end = struct
    type ('ret, 'meth) app = 'meth
    let inj x = x
    let prj x = x
  end

  open M

  (* 'ret . 'ret 'meth app -> 'ret *)
  type 'meth o = { o : 'ret . ('ret, 'meth) app -> 'ret }

  let meth : 'meth o -> ('ret, 'meth) app -> 'ret = fun o m -> o.o m

  (* Interface of point, now using polymorphic variant *)    
(*
  type point_intf = 
    [ `Get
    | `Set of int
    | `Print
    ]
*)

  (* What is great here is that methods do not need to be grouped 
     into one named interface. 

     get and print requires lambda abstractions for polymorphism.
  *)
  let get ()   : (int,  [> `Get]) app        = M.inj `Get
  let set x    : (unit, [> `Set of int]) app = M.inj (`Set x)
  let print () : (unit, [> `Print]) app      = M.inj `Print
    
  (* o's type is inferred as  
       [> `Get | `Set | `Print ] o
     which indicates o must be able to handle Get Set Print messages at least
  *)
  let test o =
    meth o (print ());
    meth o (set (meth o (get ()) + 1));
    meth o (print ())

  (* Methods for print, which has Get, Set and Print *)
  let point_meth x (m: ('res, _) app) : 'res = match M.prj m with
    | `Get    -> Obj.magic !x
    | `Set x' -> Obj.magic (x := x')
    | `Print  -> Obj.magic (printf "x=%d\n" !x)

  (* Class/New for print *)
  let point_new x =
    let x = ref x in
    { o = fun m -> point_meth x m }

  let () = 
    print_endline "by poly variant";
    test (point_new 0)

  let flipped_point_meth x (m: ('res, _) app) : 'res = match M.prj m with
    | `Set x' -> Obj.magic (x := -x')
    | _ -> point_meth x m

  let flipped_point_new x =
    let x = ref x in
    { o = fun m -> flipped_point_meth x m }

  let () = 
    test (flipped_point_new 0);
    List.iter test [ point_new 0; flipped_point_new 0 ]

  (* Defining Get_color and Set_color methods.
     They are independent each other and also of the super methods.
  *)
  let get_color () : (string, [> `Get_color]) app = M.inj `Get_color
  let set_color c  : (unit, [> `Set_color of string]) app = M.inj (`Set_color c)

  (*
    val test' :
      [> `Get | `Print | `Set of int | `Set_color of string ] o -> unit

    since Get_color is not used, it is not required. Nice.
  *)
  let test' o =
    meth o (print ());
    meth o (set (meth o (get ()) + 1));
    meth o (set_color "blue");
    meth o (print ())

  (* Sub methods. We have the return type problem again, so we need to 
     use Obj.magic.

     We have a new glitch at inheritance. The last case is clearly 
     assures that m is for `Get and `Set of int, but the typing of 
     polymorphic variants cannot refine the type: m's type is

     ('res, [< `Get | `Set of int | `Print | `Get_color | `Set_color of string]) app
     
     We need to fix the type by Obj.magic. This is still type safe.
  *)
  let colored_point_meth x c (m: ('res, _) app) : 'res = match M.prj m with
    | `Print -> (* override *)
        Obj.magic (printf "x=%d col=%s\n" !x !c)
    | `Get_color -> Obj.magic !c
    | `Set_color c' -> Obj.magic (c := c')
    | (`Get | `Set _) -> point_meth x (M.inj (Obj.magic m)) (* inherit *)

  (* Sub class/new *)
  let colored_point_new x c =
    let x = ref x in
    let c = ref c in
    { o = fun m -> colored_point_meth x c m }

  let () = test' (colored_point_new 0 "red")

  let () =
    (* Good: we do not need explicit upcasting to apply a function for super *)
    test (colored_point_new 0 "red");

    (* Putting super and sub objects in one list require explicit upcasting.

       This upcasting is purely in type, therefore no runtime cost required.
    *)
    List.iter (fun o -> meth o (print ())) 
      [ (point_new 0 : 'a o);
        (colored_point_new 0 "red" :> 'a o) (* easy upcasting! *)
      ]

  (* Conclusion

     * Messages are sharable!
     * Less explicit upcasts.
     * Super calls still create nested pattern matches, so a bit costy.
  *)

end