Extensible VariantsとClassによるOpen-Recursionを用いた拡張可能なインタプリタ

gistfile1.txt

(*
 * Extensible VariantsとClassによるOpen-Recursionを用いた拡張可能なインタプリタ
 * [author] linerlock
 * [update] 2017/05/18
 *)
module type SYNTAX = sig
  type var
  type tpe = ..
  type exp = ..

  class printer : object
    method pp_var: var -> string
    method pp_tpe: tpe -> string
    method pp_exp: exp -> string
  end
end

module Base = struct
  type var = string
  type tpe = ..
  type exp = ..

  type tpe +=
    | IntT
  type exp +=
    | IntE of int
    | AddE of exp * exp
    | SubE of exp * exp

  class printer = object (self)
    method pp_var (x: var) = x

    method pp_tpe (t: tpe) =
      match t with
      | IntT -> "int"
      | _ ->
        raise Not_found
    method pp_exp (e: exp) =
      match e with
      | IntE (n1)     -> string_of_int n1
      | AddE (e1, e2) -> Printf.sprintf "(%s + %s)" (self#pp_exp e1) (self#pp_exp e2)
      | SubE (e1, e2) -> Printf.sprintf "(%s - %s)" (self#pp_exp e1) (self#pp_exp e2)
      | _ ->
        raise Not_found
  end
end

module MulOrDivExp (S: SYNTAX) = struct
  type var = S.var
  type exp = S.exp = ..
  type tpe = S.tpe = ..

  type exp +=
    | MulE of exp * exp
    | DivE of exp * exp

  class printer = object (self)
    inherit S.printer as super

    method pp_exp (e: exp) =
      match e with
      | MulE (e1, e2) -> Printf.sprintf "(%s * %s)" (self#pp_exp e1) (self#pp_exp e2)
      | DivE (e1, e2) -> Printf.sprintf "(%s / %s)" (self#pp_exp e1) (self#pp_exp e2)
      | e ->
        super#pp_exp e
  end
end

module FunOrAppExp(S: SYNTAX) = struct
  type var = S.var
  type exp = S.exp = ..
  type tpe = S.tpe = ..

  type tpe +=
    | FunT of tpe * tpe
  type exp +=
    | VarE of var
    | FunE of var * tpe * exp
    | AppE of exp * exp

  class printer = object (self)
    inherit S.printer as super

    method pp_tpe (t: tpe) =
      match t with
      | FunT (t1, t2) -> Printf.sprintf "(%s -> %s)" (self#pp_tpe t1) (self#pp_tpe t2)
      | _ ->
        super#pp_tpe t

    method pp_exp (e: exp) =
      match e with
      | VarE (x0)         -> self#pp_var x0
      | FunE (x0, t1, e1) -> Printf.sprintf "(fun (%s: %s) -> %s)" (self#pp_var x0) (self#pp_tpe t1) (self#pp_exp e1)
      | AppE (e1, e2)     -> Printf.sprintf "(%s @ %s)" (self#pp_exp e1) (self#pp_exp e2)
      | e ->
        super#pp_exp e
  end
end

module Ex = struct
 module ArithBase = Base
 module ArithMulOrDiv = MulOrDivExp(ArithBase)
 module ArithFunOrApp = FunOrAppExp(ArithMulOrDiv)
 open ArithBase
 open ArithMulOrDiv
 open ArithFunOrApp

 let printer = new printer

 let res0 = printer#pp_exp @@ IntE 0
 let res1 = printer#pp_exp @@ MulE (IntE 0, IntE 1)
 let res2 = printer#pp_exp @@ AddE (MulE (IntE 1, AddE (IntE 2, IntE 3)), IntE 3)
 let res3 = printer#pp_exp @@ AppE (FunE ("x", IntT, AddE (VarE "x", VarE "x")), IntE 0)
end