open Syntax
open Value

(* 実際の計算をする関数 *)
(* Interpreter using combinators factored as instructions : eval8 *)

(* 初期継続 *)
let idc s t = match s with
    SCons (v, SNil) -> 
    begin match t with
        TNil -> v
      | Trail (c, s) -> c (SCons (v, s)) TNil
    end
  | _ -> failwith "stack error"

(* cons : c -> s -> t -> t *)
let rec cons c s t = match t with
    TNil -> Trail (c, s)
  | Trail (c', s') ->
    Trail (
      (fun s t ->
        begin match s with
            SCons (v, SAppend (s, s')) -> c (SCons (v, s)) (cons c' s' t)
          | _ -> failwith "stack error"
        end), 
      SAppend (s, s'))

(* apnd : t -> t -> t *)
let apnd t0 t1 = match t0 with
    TNil -> t1
  | Trail (c, s) -> cons c s t1

(* (>>) : i -> i -> i *)
let (>>) i0 i1 = fun s c t -> i0 s (fun s' t' -> i1 s' c t') t

(* num : v -> i *)
let num v = fun s c t ->
  match s with
    SCons (VEnv (vs), s) -> c (SCons (v, s)) t
  | _ -> failwith "stack error"

(* access : int -> i *)
let access n = fun s c t ->
  match s with
    SCons (VEnv (vs), s) -> c (SCons (List.nth vs n, s)) t
  | _ -> failwith "stack error"

(* push_closure : i -> i *)
let push_closure i = fun s c t ->
  match s with
    SCons (VEnv (vs), s) ->
    let vfun = VFun (fun s' c' t' ->
        begin match s' with
            SCons (v, s') -> i (SCons (VEnv (v :: vs), s')) c' t'
          | _ -> failwith "stack error"
        end) in
    c (SCons (vfun, s)) t
  | _ -> failwith "stack error"

(* return : i *)
let return = fun s _ t ->
  match s with
    SCons (v, SCons (VK (c), s)) -> c (SCons (v, s)) t
  | _ -> failwith "stack error"

(* push_env : i *)
let push_env = fun s c t ->
  match s with
    SCons (VEnv (vs), s) -> c (SCons (VEnv (vs), SCons (VEnv (vs), s))) t
  | _ -> failwith "stack error"

(* pop_env : i *)
let pop_env = fun s c t ->
  match s with
    SCons (v0, SCons (VEnv (vs), s)) -> c (SCons (VEnv (vs), SCons (v0, s))) t
  | _ -> failwith "stack error"

(* operations : op_t -> i *)
let operations op = fun s c t ->
  match s with
    SCons (v1, SCons (v0, s)) ->
    begin match (v0, v1) with
        (VNum (n0), VNum (n1)) ->
        begin match op with
            Plus -> c (SCons (VNum (n0 + n1), s)) t
          | Minus -> c (SCons (VNum (n0 - n1), s)) t
          | Times -> c (SCons (VNum (n0 * n1), s)) t
          | Divide ->
            if n1 = 0 then failwith "Division by zero"
            else c (SCons (VNum (n0 / n1), s)) t
        end
      | _ -> failwith "op is number only"
    end
  | _ -> failwith "stack error"

(* call : i *)
let call = fun s c t ->
  match s with
    SCons (v1, SCons (v0, s)) ->
    begin match v0 with
        VFun (f) -> f (SCons (v1, SCons (VK (c), s))) idc t
      | VCont (c', s', t') -> c' (SCons (v1, s')) (apnd t' (cons c s t))
      | _ -> failwith ("not app " ^ to_string v0)
    end
  | _ -> failwith "stack error"

(* control : i -> i *)
let control i = fun s c t ->
  match s with
    SCons (VEnv (vs), s) ->
    i (SCons (VEnv (VCont (c, s, t) :: vs), SNil)) idc TNil
  | _ -> failwith "stack error"

(* prompt : i -> i *)
let prompt i = fun s c t ->
  match s with
    SCons (VEnv (vs), s) ->
    c (SCons (i (SCons (VEnv (vs), SNil)) idc TNil, s)) t
  | _ -> failwith "stack error"

(* f8 : e -> string list -> i *)
let rec f8 e xs = match e with
    Num (n) -> num (VNum (n))
  | Var (x) -> access (Env.offset x xs)
  | Op (e0, op, e1) ->
    push_env >> f8 e0 xs >> pop_env >> f8 e1 xs >> (operations op)
  | Fun (x, e) -> push_closure (f8 e (x :: xs) >> return)
  | App (e0, e1) -> push_env >> f8 e0 xs >> pop_env >> f8 e1 xs >> call
  | Control (x, e) -> control (f8 e (x :: xs))
  | Prompt (e) -> prompt (f8 e xs)

(* f : e -> v *)
let f expr = f8 expr [] (SCons (VEnv ([]), SNil)) idc TNil