いかさまdynamic typing in OCaml

さらに読者を混乱させてみる。

let to_dyn t x = (fst t) x
let of_dyn t x = (snd t) x
let int =
  (fun (i : int) -> `Int i),
  (fun (`Int i) -> (i : int))
let bool =
  (fun (b : bool) -> `Bool b),
  (fun (`Bool b) -> (b : bool))
let pair a b =
  (fun (x, y) -> `Pair (to_dyn a x, to_dyn b y)),
  (fun (`Pair (x, y)) -> (of_dyn a x, of_dyn b y))
let list a =
  (fun xs -> `List (List.map (to_dyn a) xs)),
  (fun (`List xs) -> List.map (of_dyn a) xs)
let rec print = function
  | `Int i -> string_of_int i
  | `Bool b -> string_of_bool b
  | `Pair (x, y) -> "(" ^ print x ^ ", " ^ print y ^ ")"
  | `List xs ->
      let rec prints = function
        | [] -> ""
        | [x] -> print x
        | y :: zs -> print y ^ "; " ^ prints zs in
      "[" ^ prints xs ^ "]"

使い方：

# let t = list (pair int bool) ;;
val t :
  ((int * bool) list ->
   [> `List of [> `Pair of [> `Int of int ] * [> `Bool of bool ] ] list ]) *
  ([ `List of [ `Pair of [ `Int of int ] * [ `Bool of bool ] ] list ] ->
   (int * bool) list) =
  (<fun>, <fun>)
# let d = to_dyn t [(1, true); (2, false); (-3, false)] ;;
val d :
  [> `List of [> `Pair of [> `Int of int ] * [> `Bool of bool ] ] list ] =
  `List
    [`Pair (`Int 1, `Bool true); `Pair (`Int 2, `Bool false);
     `Pair (`Int -3, `Bool false)]
# print d ;;
- : string = "[(1, true); (2, false); (-3, false)]"
# of_dyn t d ;;
- : (int * bool) list = [(1, true); (2, false); (-3, false)]

追記：拡張可能にしたりして、いよいよ混乱させてみる。

type 'a y = Y of ('a y -> 'a -> string)
let print1 (Y self) = function
  | `Int i -> string_of_int i
  | `Bool b -> string_of_bool b
  | `List xs ->
      let rec prints = function
        | [] -> ""
        | [x] -> self (Y self) x
        | y :: zs -> self (Y self) y ^ "; " ^ prints zs in
      "[" ^ prints xs ^ "]"
let print2 (Y self) = function
  | (`Int _ | `Bool _ | `List _) as x -> print1 (Y self) x
  | `Pair (x, y) -> "(" ^ self (Y self) x ^ ", " ^ self (Y self) y ^ ")"

# print2 (Y print2) d ;;
- : string = "[(1, true); (2, false); (-3, false)]"

追記の追記：しかも間違いをこっそりと直したり。(print1とprint2の最後の

  | x -> self (Y self) x

が不要だった。）