125 lines
4.9 KiB
OCaml
125 lines
4.9 KiB
OCaml
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
|