Extensible Interpreter with Algebraic Effectsを例外のみで実装

extensible_interpreter_without_algebraic_effects.ml

type result = ..
type result +=
  | IntVal of int
type expr = ..
type expr +=
  | Int of int
  | Add of expr * expr
  | Sub of expr * expr

exception Extension of expr * (result -> result)

let rec eval1 e k =
  match e with
  | Int n0 -> k @@ IntVal n0
  | Add (e0, e1) ->
    eval1 e0 (fun v0 ->
      eval1 e1 (fun v1 ->
        match v0, v1 with
        | IntVal n0, IntVal n1 ->
          k @@ IntVal (n0 + n1)
        | _ -> failwith "type error"
      ))
  | Sub (e0, e1) ->
    eval1 e0 (fun v0 ->
      eval1 e1 (fun v1 ->
        match v0, v1 with
        | IntVal n0, IntVal n1 ->
          k @@ IntVal (n0 - n1)
        | _ -> failwith "type error"
      ))
  | _ ->
    raise (Extension (e, k))

type expr +=
  | Mul of expr * expr
  | Div of expr * expr

let rec eval2 e k =
  try eval1 e k with
  | Extension (Mul (e0, e1), k) ->
    eval2 e0 (fun v0 ->
      eval2 e1 (fun v1 ->
        match v0, v1 with
        | IntVal n0, IntVal n1 ->
          k @@ IntVal (n0 * n1)
        | _ -> failwith "type error"
      ))
  | Extension (Div (e0, e1), k) ->
    eval2 e0 (fun v0 ->
      eval2 e1 (fun v1 ->
        match v0, v1 with
        | IntVal n0, IntVal n1 ->
          k @@ IntVal (n0 / n1)
        | _ -> failwith "type error"
      ))

type result +=
  | BoolVal of bool
type expr +=
  | Gt of expr * expr
  | Eq of expr * expr

let rec eval3 e k =
  try eval2 e k with
  | Extension (Gt (e0, e1), k) ->
    eval3 e0 (fun v0 ->
      eval3 e1 (fun v1 ->
        match v0, v1 with
        | IntVal n0, IntVal n1 ->
          k @@ BoolVal (n0 > n1)
        | _ -> failwith "type error"
      ))
  | Extension (Eq (e0, e1), k) ->
    eval3 e0 (fun v0 ->
      eval3 e1 (fun v1 ->
        match v0, v1 with
        | IntVal n0, IntVal n1 ->
          k @@ BoolVal (n0 = n1)
        | _ -> failwith "type error"
      ))