diff --git a/lib/Core/Common.ml b/lib/Core/Common.ml index 0c75935..bf3a282 100644 --- a/lib/Core/Common.ml +++ b/lib/Core/Common.ml @@ -3,7 +3,7 @@ type meta = Mv of int let cMV : int ref = ref 0 let getCMV (_ : unit) = - let c = ! cMV in + let c = !cMV in cMV.contents <- c + 1; c diff --git a/lib/Core/Convert.ml b/lib/Core/Convert.ml index 3b8b73c..c5187ca 100644 --- a/lib/Core/Convert.ml +++ b/lib/Core/Convert.ml @@ -5,7 +5,7 @@ module M = Metaenv exception Unequal (* todo, better exception *) let rec conv_tp (len : int) (v1 : V.value) (v2 : V.value) = - match v1, v2 with + match E.force v1, E.force v2 with | Type, Type -> () | T0, T0 -> () | T1, T1 -> () @@ -23,8 +23,10 @@ let rec conv_tp (len : int) (v1 : V.value) (v2 : V.value) = | Stuck (s1, Type), Stuck (s2, Type) -> conv_stuck len s1 s2 | _ -> raise Unequal -and conv_tr (len : int) (ty : V.value) (v1 : V.value) (v2 : V.value) = - match ty with +and conv_tr (len : int) (ty : V.value) (v1' : V.value) (v2' : V.value) = + let v1 = E.force v1' + and v2 = E.force v2' in + match E.force ty with | Type -> conv_tp len v1 v2 | T1 -> () (* unit η-law, this still requires evaluation :/ *) | T0 -> () (* might be nice, why not? *) @@ -45,6 +47,7 @@ and conv_tr (len : int) (ty : V.value) (v1 : V.value) (v2 : V.value) = | _ -> raise Unequal end +(* does not need to force as things are forced in subsequent calls *) and conv_sp (len : int) (sp1 : V.spine) (sp2 : V.spine) = match sp1, sp2 with | (x1, i1, t1) :: xs1 , (x2, i2, t2) :: xs2 -> @@ -55,6 +58,7 @@ and conv_sp (len : int) (sp1 : V.spine) (sp2 : V.spine) = | [] , [] -> () | _ -> raise Unequal +(* does not force as it is called by functions which do force *) and conv_stuck (len : int) (s1 : V.stuck) (s2 : V.stuck) = match s1, s2 with | Var (Lvl i), Var (Lvl j) -> if i == j then () else raise Unequal diff --git a/lib/Core/Eval.ml b/lib/Core/Eval.ml index ffc5a93..017dedb 100644 --- a/lib/Core/Eval.ml +++ b/lib/Core/Eval.ml @@ -8,8 +8,8 @@ open List let rec eval (env : V.env) (tr : T.term) = match tr with | Var (Ix i) -> nth env i - | Meta (Mv i) -> V.Stuck (V.Meta (Mv i), M.getMetaType i) - | InsMeta (Mv i, c) -> appEnv (V.Stuck (V.Meta (Mv i), M.getMetaType i)) c env + | 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) diff --git a/lib/Core/Metaenv.ml b/lib/Core/Metaenv.ml index 6e75f3a..d404ea9 100644 --- a/lib/Core/Metaenv.ml +++ b/lib/Core/Metaenv.ml @@ -1,23 +1,33 @@ module C = Common module V = Value -open List +module Mv = + struct + type t = C.meta + let compare (C.Mv i1) (C.Mv i2) = Stdlib.compare i1 i2 + end + +module MvMap = Map.Make(Mv) type mentry = Unsolved of V.value (* type *) | Solved of (V.value * V.value) (* solution : type *) -let metaEntries : mentry list ref = ref [] +let metaEntries : mentry MvMap.t ref = ref MvMap.empty -let getMetaEntry (i : int) = - nth (! metaEntries) i +let getMetaEntry (m : C.meta) = + MvMap.find m !metaEntries -let getMetaType (i : int) = - match getMetaEntry i with +let modMetaEntry (f : mentry MvMap.t -> mentry MvMap.t) = + metaEntries.contents <- f !metaEntries + +(* TODO: if not found then insert new meta for the type somehow *) +let getMetaType (m : C.meta) = + match getMetaEntry m with | Unsolved ty -> ty | Solved (_, ty) -> ty -let resolveMeta (Mv i : C.meta) = - match getMetaEntry i with - | Unsolved ty -> V.Stuck (V.Meta (Mv i), ty) +let resolveMeta (m : C.meta) = + match getMetaEntry m with + | Unsolved ty -> V.Stuck (V.Meta m, ty) | Solved (tr, _) -> tr diff --git a/lib/Core/Renaming.ml b/lib/Core/Renaming.ml new file mode 100644 index 0000000..25e616d --- /dev/null +++ b/lib/Core/Renaming.ml @@ -0,0 +1,52 @@ +module M = Metaenv +module C = Common +module V = Value +module E = Eval +module T = Term + +module Lvl = + struct + type t = V.lvl + let compare (V.Lvl i1) (V.Lvl i2) = Stdlib.compare i1 i2 + end + +module LvlMap = Map.Make(Lvl) + +type pren = + { dom : int; + cod : int; + ren : V.lvl LvlMap.t; + } + +exception InvertError + +let rec invert (len : int) (spine : V.spine) = + match spine with + | [] -> { dom = 0; + cod = len; + ren = LvlMap.empty + } + | (tr, _, _) :: xs -> + match invert len xs with + | { dom = dom; ren = ren; _ } -> + match E.force tr with + | V.Stuck (V.Var l, _) -> { dom = dom+1; + cod = len; + ren = LvlMap.add l (V.Lvl dom) ren; + } + | _ -> raise InvertError + +and rename (_ : C.meta) (_ : pren) (_ : V.value) = failwith "TODO: rename" + +(* use only explicit lambdas when solving metas *) +and lams (len : int) (t : T.term) = + if len == 0 + then t + else T.Lam (C.Exp, T.B (lams (len-1) t)) + +and solve (len : int) (m : C.meta) (sp : V.spine) (rhs : V.value) = + let pren = invert len sp in + let rhs' = rename m pren rhs in + let solu = E.eval [] (lams pren.dom rhs') in + let mety = M.getMetaType m in + M.modMetaEntry (M.MvMap.add m (M.Solved (solu, mety)))