rtt.ml

(* See also: http://caml.inria.fr/pub/docs/manual-ocaml/extn.html#sec238 *)

type _ typ =
  | Unit : unit typ
  | Int : int typ
  | Float : float typ
  | String : string typ
  | Pair : ('a typ * 'b typ) -> ('a * 'b) typ
  | List : 'a typ -> 'a list typ

let foo : type a. a typ -> a -> a =
  fun ty v ->
    match ty with
    | Int -> 42
    | _ -> v

let () =
  Printf.printf "%d\n" @@ foo Int 30;
  Printf.printf "%f\n" @@ foo Float 30.0;
  Printf.printf "%s\n" @@ foo String "foobar";
  ()

let rec show : type a. a typ -> a -> string =
  fun ty v ->
    match ty with
    | Unit -> "()"
    | Int -> string_of_int v
    | Float -> string_of_float v
    | String -> v
    | Pair (ty1, ty2) ->
        Printf.sprintf "(%s, %s)" (show ty1 @@ fst v) (show ty2 @@ snd v)
    | List ty' ->
        Printf.sprintf "[%s]" (String.concat "; " @@ List.map (show ty') v)

type (_, _) eq = Eq : ('a, 'a) eq

let rec eq_typ: type a b. a typ -> b typ -> (a, b) eq option =
  fun a b ->
    match a, b with
    | Unit, Unit -> Some Eq
    | Int, Int -> Some Eq
    | Float, Float -> Some Eq
    | String, String -> Some Eq
    | Pair (a1, a2), Pair (b1, b2) ->
        begin match eq_typ a1 b1, eq_typ a2 b2 with
        | Some Eq, Some Eq -> Some Eq
        | _ -> None
        end
    | List a, List b ->
        begin match eq_typ a b with
        | Some Eq -> Some Eq
        | None -> None
        end
    | _ -> None

type dyn = Dyn : 'a typ * 'a -> dyn

let try_cast : type a. a typ -> dyn -> a option =
  fun typ (Dyn (ty, v)) ->
    match eq_typ typ ty with
    | Some Eq -> Some v
    | None -> None

let marshal_to_string: type a. a typ -> a -> string =
  fun ty v ->
    Marshal.to_string (Dyn (ty, v)) []

let unmarshal_from_string: type a. string -> a typ -> a option =
  fun s ty ->
    try_cast ty @@ Marshal.from_string s 0

let () =
  let t1 = Pair (Int, String) in
  let t2 = Pair (Float, String) in
  let b = marshal_to_string t1 (42, "foo") in
  let pr t = function
    | Some v -> Printf.printf "Some %s\n" @@ show t v
    | None -> print_endline "None"
  in
  pr t1 @@ unmarshal_from_string b t1;
  pr t2 @@ unmarshal_from_string b t2