if it typechecks, it runs

TSM.ml

(* typed stack machine! *)

let ( <*> ) f g x = f (g x)

type 'a ty =
  | Bool : bool ty
  | Int : int ty
  | String : string ty

type 'a value =
  | Bool : bool -> bool value
  | Int : int -> int value
  | String : string -> string value

let value_to_type : type a. a value -> a ty = function
  | Bool _ -> Bool
  | Int _ -> Int
  | String _ -> String

let value_to_ocaml (type a) (value : a value) : a =
  match value with
  | Bool bool -> bool
  | Int int -> int
  | String string -> string

(* unfortunately we need the [ty] witness because we can't match on [ocaml] *)
let value_of_ocaml (type a) (ty : a ty) (ocaml : a) : a value =
  match ty with
  | Bool -> Bool ocaml
  | Int -> Int ocaml
  | String -> String ocaml

(* [return_type] enforces that [func] doesn't return in a type that [value] doesn't support *)
let map_value (type a b) (return_type : b ty) (func : a -> b) (value : a value)
  : b value
  =
  value_of_ocaml return_type (func (value_to_ocaml value))

let map2_value
      (type a b c)
      (return_type : c ty)
      (func : a -> b -> c)
      (first : a value)
      (second : b value)
  : c value
  =
  value_of_ocaml
    return_type
    (func (value_to_ocaml first) (value_to_ocaml second))

let get_ocaml_repr_func (type a) (ty : a ty) : a -> string =
  match ty with
  | Bool -> Bool.to_string
  | Int -> Int.to_string
  | String -> Printf.sprintf "\"%s\"" <*> String.escaped

let get_ocaml_print_func (type a) (ty : a ty) : a -> unit =
  print_string <*> get_ocaml_repr_func ty

type empty = |

type 'a stack =
  | Empty : empty stack
  | Push : ('a value * onto:'b stack) -> ('a -> 'b) stack

let empty = Empty
let push value stack = Push (value, ~onto:stack)

let push_ocaml (type a) (ty : a ty) (ocaml : a) stack =
  Push (value_of_ocaml ty ocaml, ~onto:stack)

let pop = function
  | Push (value, ~onto:rest) -> (value, rest)

let drop stack = Pair.snd (pop stack)

let dup stack =
  match stack with
  | Push (value, ~onto:_) -> Push (value, ~onto:stack)

let swap = function
  | Push (first, ~onto:(Push (second, ~onto:rest))) ->
    Push (second, ~onto:(Push (first, ~onto:rest)))

let eval_op_0_1
      (type a)
      (op : unit -> a)
      (ret_type : a ty)
      (stack : 'rest stack)
  : (a -> 'rest) stack
  =
  push (value_of_ocaml ret_type (op ())) stack

let eval_op_1_0 (type a) (op : a -> unit) (stack : (a -> 'rest) stack)
  : 'rest stack
  =
  let (top, rest) = pop stack in
  op (value_to_ocaml top);
  rest

let eval_op_1_1
      (type a b)
      (op : a -> b)
      (ret_type : b ty)
      (stack : (a -> 'rest) stack)
  : (b -> 'rest) stack
  =
  match stack with
  | Push (value, ~onto:rest) -> Push (map_value ret_type op value, ~onto:rest)

let eval_op_2_1
      (type a b c)
      (op : a -> b -> c)
      (ret_type : c ty)
      (stack : (b -> a -> 'rest) stack)
  : (c -> 'rest) stack
  =
  match stack with
  | Push (first, ~onto:(Push (second, ~onto:rest))) ->
    Push (map2_value ret_type op second first, ~onto:rest)

let and_bool stack = eval_op_2_1 Bool.logand Bool stack
let or_bool stack = eval_op_2_1 Bool.logor Bool stack
let xor_bool stack = eval_op_2_1 Bool.logxor Bool stack
let add_int stack = eval_op_2_1 Int.add Int stack
let sub_int stack = eval_op_2_1 Int.sub Int stack
let mul_int stack = eval_op_2_1 Int.mul Int stack
let concat_string stack = eval_op_2_1 String.cat String stack
let repr (type a) (ty : a ty) = eval_op_1_1 (get_ocaml_repr_func ty) String
let input stack = eval_op_0_1 read_line String stack

let print (type a) (ty : a ty) stack =
  eval_op_1_0 (get_ocaml_print_func ty) stack

let write_out_string stack = eval_op_1_0 print_string stack

let final_stack =
  empty
  |> push_ocaml Int 34
  |> push_ocaml Int 35
  |> add_int
  |> print Int
  |> push_ocaml String "\n"
  |> write_out_string
  |> push_ocaml String "Enter your name: "
  |> write_out_string
  |> input
  |> push_ocaml String "Hello, "
  |> swap
  |> concat_string
  |> push_ocaml String "!\n"
  |> concat_string
  |> write_out_string