module V = Value
module T = Term
module M = Metaenv
module C = Common

open List

let rec eval (env : V.env) (tr : T.term) =
  match tr with
  | Var  (Ix i)               -> nth env i
  | Meta m                    -> V.Stuck (V.Meta m, M.getMetaType m)
  | InsMeta (m, c)            -> appEnv (V.Stuck (V.Meta m, M.getMetaType m)) c env
  | Type                      -> V.Type
  | T0                        -> V.T0
  | Ind0 (B b, t)             -> ind0 env b (eval env t)
  | T1                        -> V.T1
  | T1tr                      -> V.T1vl
  | TNat                      -> V.TNat
  | Zero                      -> V.Zero
  | Suc  n                    -> V.Suc (eval env n)
  | IndN (B b, tz, B B ts, n) -> indN env env b (eval env tz) ts (eval env n)
  | TBool                     -> V.TBool
  | True                      -> V.True
  | False                     -> V.False
  | IndB (B b, t, f, bo)      -> indB env b (eval env t) (eval env f) (eval env bo)
  | Pi   (ic, dom, B cod)     -> V.Pi (ic, eval env dom, V.C (env, cod))
  | Lam  (ic, B scope)        -> V.Lam (ic, C (env, scope))
  | App  (ic, f, x)           -> app ic (eval env f) (eval env x)
  | Sg   (ty, B tr)           -> V.Sg (eval env ty, V.C (env, tr))
  | Pair (x, y)               -> V.Pair (eval env x, eval env y)
  | Fst  tr                   -> fst (eval env tr)
  | Snd  tr                   -> snd (eval env tr)
  | Let  (tr, _, B sc)        -> eval (eval env tr :: env) sc

and ind0 (env : V.env) (b : T.term) (t : V.value) =
    match t with
    | Stuck (s , T0) -> V.Stuck (V.Ind0 (V.C (env, b), s), V.T0)
    | _              -> failwith "eval Ind0 impossible error"

and indB (env : V.env) (b : T.term) (t : V.value) (f : V.value) (bo : V.value) =
    match bo with
    | True             -> t
    | False            -> f
    | Stuck (s, TBool) -> V.Stuck (V.IndB (V.C (env, b), t, f, s), V.TBool)
    | _                -> failwith "eval IndB impossible error"

(* B b, B B ts *)
and indN (envt : V.env) (envs : V.env) (b : T.term) (tz : V.value) (ts : T.term) (n : V.value) =
  match n with
  | Zero            -> tz
  | Suc m           -> eval (indN envt envs b tz ts m :: m :: envs) ts
  | Stuck (s, TNat) -> V.Stuck (V.IndN (V.C (envt, b), tz, V.C2 (envs, ts), s), V.TNat)
  | _               -> failwith "eval IndN impossible error"


and app (ic : C.icit) (f : V.value) (x : V.value) =
  match f with
  | Lam (ic', C (env, tr)) -> if ic == ic'
                              then eval (x :: env) tr
                              else failwith "TODO: MIXED ICITY WAAAA :(("
  | Stuck (App (f, sp), t) -> begin
    match t with
    | Pi (ic', b, C (env, tr)) -> if ic == ic'
                                  then V.Stuck ( V.App (f, (x, ic, b) :: sp)
                                               , eval (x :: env) tr)
                                  else failwith "TODO: MIXED ICITY WAAAA :(("
    | _                   -> failwith "eval app stuck f not of pi type"
    end
  | Stuck (s, t)      -> begin
    match t with
    | Pi (ic', b, C (env, tr)) -> if ic == ic'
                                  then V.Stuck ( V.App (s, [(x, ic, b)])
                                               , eval (x :: env) tr)
                                  else failwith "TODO: MIXED ICITY WAAAA :(("
    | _                   -> failwith "eval app stuck f not of pi type"
    end
  | _                 -> failwith "eval app impossible error"

and fst (p : V.value) =
  match p with
  | Pair  (a, _) -> a
  | Stuck (s, Sg (a, _)) -> V.Stuck (V.Fst s, a)
  | _                    -> failwith "eval fst impossible error"

and snd (p : V.value) =
  match p with
  | Pair  (_, b) -> b
  | Stuck (s, Sg (_, C (env, b))) -> V.Stuck (V.Snd s, (eval (fst p :: env) b))
  | _                             -> failwith "eval fst impossible error"

and appEnv (p : V.value) (c : int) (e : V.env) =
  match c with
  | 0 -> p
  | n -> match e with
         | [] -> failwith "env not big enough appenv"
         | h :: t -> app Exp (appEnv p (n-1) t) h

(* TODO? force only the first "layer" *)
and force (v : V.value) =
  match v with
  | Suc v -> V.Suc (force v)
  | Pi (i, v, c) -> V.Pi (i, force v, c)
  | Sg (v, c) -> V.Sg (force v, c)
  | Pair (v1, v2) -> Pair (force v1, force v2)
  | Stuck (Var l, t) -> V.Stuck (Var l, t)
  | Stuck (s, _) -> forceStuck s
  | x -> x

and forceStuck (s : V.stuck) =
  match s with
  | Meta m -> M.resolveMeta m
  | Ind0 (C (env, b), s) -> ind0 env b (forceStuck s)
  | IndN (C (envt, ty), z, C2 (envs, s), st) -> indN envt envs ty z s (forceStuck st)
  | IndB (C (env, b), t, f, st) -> indB env b t f (forceStuck st)
  | App  (_, []) -> failwith "weird forceStuck empty list"
  | App  (st, sp) -> forceStuckApp (forceStuck st) sp
  | Fst st -> fst (forceStuck st)
  | Snd st -> snd (forceStuck st)
  | Var _ -> failwith "forceStuck var not caught"

and forceStuckApp (s : V.value) (sp : V.spine) =
  match sp with
  | [] -> s
  | ((x, i, _) :: xs) -> app i (forceStuckApp s xs) x