Simple model of Python-style dynamic dispatch in Standard ML via dynamic classification

dynamic-dispatch.sml

signature OBJECT =
  sig
    type 'a tag
    type t

    val new : unit -> t list tag
    and make : 'a tag -> 'a -> t
    val get : t -> 'a tag -> 'a

    (* primitives *)
    val Bool : bool tag
    and Int : int tag
    and String : string tag

    structure Key : ORDERED
    val keyTag : 'a tag -> Key.t
    and key : t -> Key.t
  end

structure Object :> OBJECT =
  struct
    structure Key =
      struct
        type t = int
        val eq : t * t -> bool = op =
        val compare = Int.compare
      end

    type 'a tag = { tag : 'a Universal.tag, key : Key.t }
    type t = { obj : Universal.universal, key : Key.t }

    local
      val counter : Key.t ref = ref 0
    in
      val new = fn () =>
        { tag = Universal.tag (), key = !counter } before Ref.modify (fn i => i + 1) counter
    end

    val Bool : bool tag = new ()
    and Int : int tag = new ()
    and String : string tag = new ()

    val make = fn tag : 'a tag => fn x =>
      { obj = Universal.tagInject (#tag tag) x, key = #key tag }

    val get = fn t : t => fn tag : 'a tag => Universal.tagProject (#tag tag) (#obj t)

    val keyTag : 'a tag -> Key.t = #key
    and key : t -> Key.t = #key
  end

signature REGISTRY =
  sig
    exception MethodError

    val register : 'a Object.tag list -> ('a list -> Object.t) -> unit
    val $ : Object.t list -> Object.t
  end

functor Registry () :> REGISTRY =
  struct
    structure Dict =
      RedBlackDict (
        structure Key =
          ListOrdered (
            structure Ordered = Object.Key
          )
      )

    val registry : (Object.t list -> Object.t) Dict.dict ref = ref Dict.empty

    exception MethodError

    val register = fn tags => fn f =>
      Ref.modify
        (fn registry =>
          Dict.insert
            registry
            (List.map Object.keyTag tags)
            (fn args => f (ListPair.mapEq (Fn.uncurry Object.get) (args, tags)))
        )
        registry

    val $ = fn args =>
      case Dict.find (!registry) (List.map Object.key args) of
        NONE   => raise MethodError
      | SOME f => f args
  end


(* Demo *)

val bool = Object.make Object.Bool
and int = Object.make Object.Int
and string = Object.make Object.String

val zero = int 0

structure Add = Registry ()
structure Print = Registry ()

(* built-ins *)

val () = Print.register [Object.Bool] (fn [b] => (print (Bool.toString b ^ "\n"); zero))
val () = Print.register [Object.Int] (fn [i] => (print (Int.toString i ^ "\n"); zero))
val () = Print.register [Object.String] (fn [s] => (print (String.toString s ^ "\n"); zero))

val () = Add.register [Object.Int, Object.Int] (fn [i, j] => int (i + j))
val () = Add.register [Object.String, Object.String] (fn [s1, s2] => string (s1 ^ s2))

val _ = Print.$ [Add.$ [int 3, int 4]]
val _ = Print.$ [Add.$ [string "foo", string "bar"]]



val Coord = Object.new ()
val Scalar = Object.new ()

val () = Print.register [Coord] (fn [[x, y]] => (print "x = "; Print.$ [x]; print "y = "; Print.$ [y]))
val () = Add.register [Coord, Coord] (fn [[x1, y1], [x2, y2]] => Object.make Coord [Add.$ [x1, x2], Add.$ [y1, y2]])
val () = Add.register [Coord, Scalar] (fn [[x, y], [i]] => Object.make Coord [Add.$ [x, i], Add.$ [y, i]])

val _ = Print.$ [Object.make Coord [int 1, int 2]]
val _ = Print.$ [Add.$ [Object.make Coord [int 1, int 2], Object.make Coord [int 3, int 4]]]
val _ = Print.$ [Add.$ [Object.make Coord [int 1, int 2], Object.make Scalar [int 3]]]