open Ast;;
open InterpreterStdlib;;


let default_env: environment = [Hashtbl.create 1024];;

let add_builtin s f =
  env_set_global default_env s (LBuiltinFunction (s, f))
let add_special s f =
  env_set_global default_env s (LBuiltinSpecial (s, f))

let make_env () = [Hashtbl.copy (List.hd default_env)]

(* the type annotations are unnecessary, but help constrain us from a
potentially more general function here *)
let rec eval_sym (env: environment) (s: string) =
  match env with
  | [] -> raise (Invalid_argument (Printf.sprintf "eval_sym: symbol %s has no value in current scope" s))
  | e :: rest ->
    match Hashtbl.find_opt e s with
    | None -> eval_sym rest s
    | Some v -> v

let rec eval_one env = function
  | LSymbol s -> eval_sym env s
  | LCons (func, args) -> eval_call env (eval_one env func) args
  | LQuoted v -> v
  | v -> v (* All other forms are self-evaluating *)

(* Evaluate a list of values, without evaluating the resulting
function or macro call. Since macros and functions inherently
look similar, they share a lot of code, which is extracted here *)
and eval_list env l =
  match l with
  | LNil -> LNil
  | LCons (a, b) -> LCons (eval_one env a, eval_list env b)
  | _ -> raise (Invalid_argument "eval_list: cannot process non-list")

and eval_body env body =
  match body with
  | LNil -> LNil
  | LCons (form, LNil) -> eval_one env form
  | LCons (form, next) -> ignore (eval_one env form); eval_body env next
  | _ -> LNil

and err s = raise (Invalid_argument s)
and bind_args env = function
  | LNil -> (function
      | LNil -> ()
      | _ -> err "cannot bind arguments")
  | LSymbol s ->
    (function
      | v -> env_set_local env s v; ())
  | LCons (LSymbol hl, tl) -> (function
      | LCons (ha, ta) -> 
        env_set_local env hl ha;
        bind_args env tl ta;
      | _ -> err "cannot bind arguments")
  | _ -> fun _ -> err "bind_args"
  
and eval_apply args = function
  | LLambda (e, l, b)
  | LFunction (_, e, l, b) ->
    let lexical_env = env_new_lexical e in
    bind_args lexical_env l args;
    eval_body lexical_env b
  | LUnnamedMacro (e, l, b)
  | LMacro (_, e, l, b) ->
    let lexical_env = env_new_lexical e in
    bind_args lexical_env l args;
    eval_body lexical_env b
  | v ->
    err ("Non-macro non-function value passed to eval_apply "
        ^ dbg_print_one v); LNil
    


and eval_call env func args =
  match func with
  | LBuiltinSpecial (_, f) -> f env args
  | LBuiltinFunction (_, f) -> f env (eval_list env args)
  (* The function calls don't happen in the calling environment,
     so it makes no sense to pass env to a call. *)
  | LLambda _
  | LFunction _ -> eval_apply (eval_list env args) func
  (* Macros are the same, they just return code that *will* be evaluated
  in the calling environment *)
  | LUnnamedMacro _
  | LMacro _ -> eval_one env (eval_apply args func)
  | v -> raise (Invalid_argument 
                  (Printf.sprintf "eval_apply: cannot call non-function object %s" (dbg_print_one v)))

and (* This only creates a *local* binding, contained to the body given. *)
  bind_local env =
  function
  | LCons (LSymbol s, LCons (v, body)) ->
    let e = env_new_lexical env in
    env_set_local e s v;
    eval_body e body
  | _ -> invalid_arg "invalid argument to bind-local"
and lisp_if env = function
  | LCons (cond, LCons (if_true, LNil)) ->
    (match eval_one env cond with
     | LNil -> LNil
     | _ -> eval_one env if_true)
  | LCons (cond, LCons (if_true, LCons (if_false, LNil))) ->
    (match eval_one env cond with
     | LNil -> eval_one env if_false
     | _ -> eval_one env if_true)
  | _ -> invalid_arg "invalid argument list passed to if!"

let eval_all env vs =
  let ev v = eval_one env v in
  List.map ev vs

let () = add_builtin "+" add
let () = add_builtin "-" sub
let () = add_builtin "car" car
let () = add_builtin "cdr" cdr
let () = add_builtin "cons" cons
let () = add_builtin "bind-symbol" bind_symbol 
let () = add_builtin "list" lisp_list
let () = add_special "fn" lambda
let () = add_special "fn-macro" lambda_macro
let () = add_special "let-one" bind_local
let () = add_special "quote" (fun _ -> function
    | LCons (x, LNil) -> x
                         | _ -> invalid_arg "hmm")
let () = add_special "if" lisp_if
(*let () = add_builtin "print" lisp_prin *)

(* I know this looks insane. please trust me. *)
let _ = eval_all default_env (Read.parse_str "
(bind-symbol 'defn
  (fn-macro (name lm . body)
    (list 'bind-symbol (list 'quote name) (cons 'fn (cons lm body)))))
(bind-symbol 'defmacro
  (fn-macro (name lm . body)
    (list 'bind-symbol (list 'quote name) (cons 'fn-macro (cons lm body)))))
(defmacro def
  (var val)
  (list 'bind-symbol (list 'quote var) val))
()")