open Syntax
open Value

(* 実際の計算をする関数 *)
(* 2CPS interpreter : eval9 *)

(* 初期継続 *)
let idc s t m = match s with
    SCons (v, SNil) -> 
    begin match t with
        TNil -> m v
      | Trail (c, s) -> c (SCons (v, s)) TNil m
    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 m -> i0 s (fun s' t' m' -> i1 s' c t' m') t m

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

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

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

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

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

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

(* operations : op_t -> i *)
let operations op = fun s c t m ->
  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 m
          | Minus -> c (SCons (VNum (n0 - n1), s)) t m
          | Times -> c (SCons (VNum (n0 * n1), s)) t m
          | Divide ->
            if n1 = 0 then failwith "Division by zero"
            else c (SCons (VNum (n0 / n1), s)) t m
        end
      | _ -> failwith "op is number only"
    end
  | _ -> failwith "stack error"

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

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

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

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

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