Universal type in SML; slightly different take on http://mlton.org/UniversalType

universal.sml

(* A slightly different take on http://mlton.org/UniversalType *)

(* Our interface uses an explicit tag object instead of pairs of
 * injection/projection function. This is maybe more intuitive for
 * some people, and it makes the lambda based implementation nicer,
 * at the expense of the exn based one. *)
signature UNIVERSAL_TYPE =
sig
    type 'a tag
    type t

    val new_tag : unit -> 'a tag
    val inject : 'a tag -> 'a -> t
    val project : 'a tag -> t -> 'a option
end

structure LambdaUniv :> UNIVERSAL_TYPE =
struct
    datatype t = T of {clear: unit -> unit,
                       store: unit -> unit}

    type 'a tag = 'a option ref

    fun new_tag () = ref NONE

    fun inject r a =
        T {clear = fn () => r := NONE,
           store = fn () => r := SOME a}
    fun project r (T {clear, store}) =
        let
            val () = store ()
            val res = !r
            val () = clear ()
        in
            res
        end
end

structure ExnUniv :> UNIVERSAL_TYPE =
struct
    type t = exn

    (* The old interface is more natural for exn. Doing it this
     * way basically means just wrapping up the projection/injection
     * functions. *)
    type 'a tag = ('a -> t) * (t -> 'a option)

    fun 'a new_tag () =
        let
            exception E of 'a
            fun project (e: t): 'a option =
                case e of
                    E a => SOME a
                  | _ => NONE
        in
            (E, project)
        end
    fun inject (inj, _) = inj
    fun project (_, proj) = proj
end