[MLton] OO in SML (was: mGTK and MLton)

[Wesley W. Terpstra]

--NzB8fVQJ5HfG6fxh
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline

I was playing around with mGTK and wishing that it supported OO like
lablgtk2 when the following hack occured to me (see attached oo.sml).

With the addition of the '$' sign the syntax works pretty much like OCaml.
However, passing a method record around with every instance of the object
can't be the best way to do this; does anyone have a better idea?

I'd like to point out that using #foo to access member methods and variables
is not just motivated by OCaml. It was necessary because any other
formulation I could think of would require the structure in the name.
eg: o1&Object.increment () instead of o1&increment () as desired.

Furthermore, it seems to me that only record selectors are typeless enough
to be able to select completely different things depending on what the
object they are combined with.

See the type-safe example (test.sml) which mimics mGTK's type chaining.
Notice also in this code that the 'set' method has different arguments
depending on which object it gets applied to. =)

Suggestions for improvement?

-- 
Wesley W. Terpstra

--NzB8fVQJ5HfG6fxh
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="test.sml"

fun $ (obj, meths) sel = sel meths obj

signature OBJECT =
  sig
    type base
    type 'a t
    type constructor = unit -> int
    val inherit : 'a -> constructor -> 'a t
    
    val toStr : 'a t -> string
    val new : unit -> base t
    val newobj : unit -> (base t * { 
      toStr:'a t -> string })
  end
  
structure Object :> OBJECT =
  struct
    type base = unit
    type 'a t = int
    type constructor = unit -> int
    fun inherit x c = c ()
    
    fun toStr ob = Int.toString ob
    fun new () = 2
    fun newobj () = (new (), { toStr=toStr })
  end

signature SIGNAL =
  sig
    type base
    type 'a signal_t
    type 'a t = 'a signal_t Object.t
    val inherit : 'a -> Object.constructor -> 'a t
    
    val ping : 'a t -> string -> string
    val new : unit -> base t
    val newobj : unit -> (base t * {
      toStr:'a t -> string, 
      ping:'a t -> string -> string })
  end
  
structure Signal :> SIGNAL =
  struct
    type base = unit
    type 'a signal_t = unit
    type 'a t = 'a signal_t Object.t
    fun inherit x c = Object.inherit () c
    
    fun ping ob s = s ^ Object.toStr ob
    fun new () = inherit () (fn () => 7)
    fun newobj () = (new (), { toStr=Object.toStr, ping=ping })
  end

signature FLAG =
  sig
    type base
    type 'a flag_t
    type 'a t = 'a flag_t Signal.t
    val inherit : 'a -> Object.constructor -> 'a t
    
    val set : 'a t -> string
    val new : unit -> base t
    
    val newobj : unit -> (base t * {
      toStr:'a t -> string, 
      ping:'a t -> string -> string,
      set:'a t -> string })
  end

structure Flag :> FLAG =
  struct
    type base = unit
    type 'a flag_t = unit
    type 'a t = 'a flag_t Signal.t
    fun inherit x c = Signal.inherit () c
    
    fun set ob = Signal.ping ob "flag"
    fun new () = inherit () (fn () => 42)
    fun newobj () = (new (), { toStr=Object.toStr, ping=Signal.ping, set=set })
  end

signature TOGGLE =
  sig
    type base
    type 'a toggle_t
    type 'a t = 'a toggle_t Signal.t
    val inherit : 'a -> Object.constructor -> 'a t
    
    val set : 'a t -> bool -> unit
    val new : unit -> base t
    
    val newobj : unit -> (base t * {
      toStr:base t -> string, 
      ping:base t -> string -> string,
      set:base t -> bool -> unit })
  end

structure Toggle :> TOGGLE =
  struct
    type base = unit
    type 'a toggle_t = unit
    type 'a t = 'a toggle_t Signal.t
    fun inherit x c = Signal.inherit () c
    
    fun set ob v = ()
    fun new () = inherit () (fn () => 87)
    
    fun newobj () = (new (), { toStr=Object.toStr, ping=Signal.ping, set=set })
  end

;
let
  val ob = Object.newobj ()
  val sg = Signal.newobj ()
  val fl = Flag.newobj ()
  val tg = Toggle.newobj ()
  
  fun sgstuff x = $x#toStr ^ $x#ping "dsgf"
  fun dostuff x = $x#toStr ^ $x#ping "das" ^ $x#set
  
  (* check type safety: *)
  val w = $sg#toStr
  val x = $sg#ping "asf"
(*
  val y = sg#set (* <-- won't compile :) *)
*)
  val t = sgstuff fl (* sg,fl,tg all work, but not ob *)
  val m = dostuff fl (* try ob, sg, and tg -- they won't work *)
  
  (* note that here #set selects two different functions w/ different args *)
  val z = $fl#set        (* returning string -- use in print *)
  val () = $tg#set false (* returning unit *)
  val z2 = $tg#toStr
in
  print (x ^ " " ^ z ^ " - " ^ m ^ "\n")
end ;;

--NzB8fVQJ5HfG6fxh
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="oo.sml"

fun $ (obj, meths) sel = sel meths obj

signature CLASS =
  sig
    type t
    val newobj : int -> (t * {
      (* "methods" *)
      increment:t->unit->unit,
      decrement:t->unit->unit,
      stringify:t->unit->string,
      (* "variables" *)
      value:t->int
      })
  end

structure Object :> CLASS =
  struct
    type t = int ref
    fun newobj i = (ref i, { 
      increment=fn (x:t) => fn () => x := !x + 1, 
      decrement=fn (x:t) => fn () => x := !x - 1,
      stringify=fn (x:t) => fn () => Int.toString (!x),
      value=    fn (x:t) => !x })
  end

val o1 = Object.newobj 3
val o2 = Object.newobj 6

val _ = (
  print (Int.toString ($o1#value) ^ "\n");
  $o1#increment ();
  $o1#increment ();
  print (Int.toString ($o1#value) ^ "\n");
  if $o1#value = $o2#value
  then print "bug\n"
  else print "not equal\n";
  $o2#decrement ();
  if $o1#value = $o2#value
  then print "equal\n"
  else print "bug\n";
  print ($o2#stringify () ^ "\n")
)

--NzB8fVQJ5HfG6fxh--