Skip to content

Instantly share code, notes, and snippets.

@HarrisonGrodin
Created August 13, 2021 06:13
Show Gist options
  • Save HarrisonGrodin/4d96437ea875fbeaa48e253deefbc10f to your computer and use it in GitHub Desktop.
Save HarrisonGrodin/4d96437ea875fbeaa48e253deefbc10f to your computer and use it in GitHub Desktop.
Simple model of Python-style dynamic dispatch in Standard ML via dynamic classification
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]]]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment