dunham/newt
1
0
Fork 0
Code Issues Pull Requests Actions 1 Packages Projects Releases Wiki Activity

Port Eval.newt

Browse Source
This commit is contained in:
Steve Dunham
2025-01-03 22:49:07 -08:00
parent b87999a64d
commit 46434cc555
4 changed files with 1124 additions and 56 deletions
Download Patch File Download Diff File Expand all files Collapse all files

164
src/Lib/Eval.idr
View File

@@ -37,7 +37,9 @@ vapp t u = error' "impossible in vapp \{show t} to \{show u}\n"
export
vappSpine : Val -> SnocList Val -> M Val
vappSpine t [<] = pure t
vappSpine t (xs :< x) = vapp !(vappSpine t xs) x
vappSpine t (xs :< x) = do
rest <- vappSpine t xs
vapp rest x
@@ -65,16 +67,18 @@ unlet env x = pure x
export
tryEval : Env -> Val -> M (Maybe Val)
tryEval env (VRef fc k _ sp) =
case lookup k !(get) of
tryEval env (VRef fc k _ sp) = do
top <- get
case lookup k top of
Just (MkEntry _ name ty (Fn tm)) =>
catchError (
do
debug "app \{name} to \{show sp}"
debug "app \{show name} to \{show sp}"
vtm <- eval [] CBN tm
debug "tm is \{pprint [] tm}"
case !(vappSpine vtm sp) of
VCase{} => pure Nothing
debug "tm is \{render 90 $ pprint [] tm}"
val <- vappSpine vtm sp
case val of
VCase _ _ _ => pure Nothing
v => pure $ Just v)
(\ _ => pure Nothing)
_ => pure Nothing
@@ -84,49 +88,55 @@ tryEval _ _ = pure Nothing
-- Force far enough to compare types
export
forceType : Env -> Val -> M Val
forceType env (VMeta fc ix sp) = case !(lookupMeta ix) of
(Unsolved x k xs _ _ _) => pure (VMeta fc ix sp)
(Solved _ k t) => vappSpine t sp >>= forceType env
forceType env (VMeta fc ix sp) = do
meta <- lookupMeta ix
case meta of
(Unsolved x k xs _ _ _) => pure (VMeta fc ix sp)
(Solved _ k t) => vappSpine t sp >>= forceType env
forceType env x = do
Just x' <- tryEval env x
| _ => pure x
forceType env x'
evalCase : Env -> Mode -> Val -> List CaseAlt -> M (Maybe Val)
evalCase env mode sc@(VRef _ nm _ sp) (cc@(CaseCons name nms t) :: xs) =
evalCase env mode sc@(VRef _ nm _ sp) (cc@(CaseCons name nms t) :: xs) = do
top <- get
if nm == name
then do
debug "ECase \{nm} \{show sp} \{show nms} \{showTm t}"
debug "ECase \{show nm} \{show sp} \{show nms} \{showTm t}"
go env (sp <>> []) nms
else case lookup nm !(get) of
else case lookup nm top of
(Just (MkEntry _ str type (DCon k str1))) => evalCase env mode sc xs
-- bail for a stuck function
_ => pure Nothing
where
go : Env -> List Val -> List String -> M (Maybe Val)
go env (arg :: args) (nm :: nms) = go (arg :: env) args nms
go env args [] = Just <$> vappSpine !(eval env mode t) ([<] <>< args)
go env args [] = do
t' <- eval env mode t
Just <$> vappSpine t' ([<] <>< args)
go env [] rest = pure Nothing
-- REVIEW - this is handled in the caller already
evalCase env mode sc@(VVar fc k sp) alts = case lookupVar env k of
Just tt@(VVar fc' k' sp') => do
debug "lookup \{show k} is \{show tt}"
if k' == k then pure Nothing
else evalCase env mode !(vappSpine (VVar fc' k' sp') sp) alts
Just t => evalCase env mode !(vappSpine t sp) alts
if k' == k
then pure Nothing
else do
val <- vappSpine (VVar fc' k' sp') sp
evalCase env mode val alts
Just t => do
val <- vappSpine t sp
evalCase env mode val alts
Nothing => do
debug "lookup \{show k} is Nothing in env \{show env}"
pure Nothing
evalCase env mode sc (CaseDefault u :: xs) = pure $ Just !(eval (sc :: env) mode u)
evalCase env mode sc (CaseDefault u :: xs) = Just <$> eval (sc :: env) mode u
evalCase env mode sc cc = do
debug "CASE BAIL sc \{show sc} vs \{show cc}"
debug "env is \{show env}"
pure Nothing
bind : Val -> Env -> Env
bind v env = v :: env
-- So smalltt says:
-- Smalltt has the following approach:
-- - Top-level and local definitions are lazy.
@@ -137,17 +147,30 @@ bind v env = v :: env
-- TODO maybe add glueing
eval env mode (Ref fc x def) = pure $ VRef fc x def [<]
eval env mode (App _ t u) = vapp !(eval env mode t) !(eval env mode u)
eval env mode (App _ t u) = do
t' <- eval env mode t
u' <- eval env mode u
vapp t' u'
eval env mode (UU fc) = pure (VU fc)
eval env mode (Erased fc) = pure (VErased fc)
eval env mode (Meta fc i) =
case !(lookupMeta i) of
eval env mode (Meta fc i) = do
meta <- lookupMeta i
case meta of
(Unsolved _ k xs _ _ _) => pure $ VMeta fc i [<]
(Solved _ k t) => pure $ t
eval env mode (Lam fc x icit rig t) = pure $ VLam fc x icit rig (MkClosure env t)
eval env mode (Pi fc x icit rig a b) = pure $ VPi fc x icit rig !(eval env mode a) (MkClosure env b)
eval env mode (Let fc nm t u) = pure $ VLet fc nm !(eval env mode t) !(eval (VVar fc (length env) [<] :: env) mode u)
eval env mode (LetRec fc nm ty t u) = pure $ VLetRec fc nm !(eval env mode ty) !(eval (VVar fc (length env) [<] :: env) mode t) !(eval (VVar fc (length env) [<] :: env) mode u)
eval env mode (Pi fc x icit rig a b) = do
a' <- eval env mode a
pure $ VPi fc x icit rig a' (MkClosure env b)
eval env mode (Let fc nm t u) = do
t' <- eval env mode t
u' <- eval (VVar fc (length env) [<] :: env) mode u
pure $ VLet fc nm t' u'
eval env mode (LetRec fc nm ty t u) = do
ty' <- eval env mode ty
t' <- eval (VVar fc (length env) [<] :: env) mode t
u' <- eval (VVar fc (length env) [<] :: env) mode u
pure $ VLetRec fc nm ty' t' u'
-- Here, we assume env has everything. We push levels onto it during type checking.
-- I think we could pass in an l and assume everything outside env is free and
-- translate to a level
@@ -161,8 +184,9 @@ eval env mode tm@(Case fc sc alts) = do
sc' <- eval env mode sc
sc' <- unlet env sc' -- try to expand lets from pattern matching
sc' <- forceType env sc'
pure $ fromMaybe (VCase fc !(eval env mode sc) alts)
!(evalCase env mode sc' alts)
vsc <- eval env mode sc
vcase <- evalCase env mode sc' alts
pure $ fromMaybe (VCase fc vsc alts) vcase
export
quote : (lvl : Nat) -> Val -> M Tm
@@ -170,23 +194,42 @@ quote : (lvl : Nat) -> Val -> M Tm
quoteSp : (lvl : Nat) -> Tm -> SnocList Val -> M Tm
quoteSp lvl t [<] = pure t
quoteSp lvl t (xs :< x) =
pure $ App emptyFC !(quoteSp lvl t xs) !(quote lvl x)
quoteSp lvl t (xs :< x) = do
t' <- quoteSp lvl t xs
x' <- quote lvl x
pure $ App emptyFC t' x'
quote l (VVar fc k sp) = if k < l
then quoteSp l (Bnd fc (lvl2ix l k )) sp -- level to index
else ?borken
quote l (VMeta fc i sp) =
case !(lookupMeta i) of
else error fc "Bad index in quote \{show k} depth \{show l}"
quote l (VMeta fc i sp) = do
meta <- lookupMeta i
case meta of
(Unsolved _ k xs _ _ _) => quoteSp l (Meta fc i) sp
(Solved _ k t) => quote l !(vappSpine t sp)
quote l (VLam fc x icit rig t) = pure $ Lam fc x icit rig !(quote (S l) !(t $$ VVar emptyFC l [<]))
quote l (VPi fc x icit rig a b) = pure $ Pi fc x icit rig !(quote l a) !(quote (S l) !(b $$ VVar emptyFC l [<]))
quote l (VLet fc nm t u) = pure $ Let fc nm !(quote l t) !(quote (S l) u)
quote l (VLetRec fc nm ty t u) = pure $ LetRec fc nm !(quote l ty) !(quote (S l) t) !(quote (S l) u)
(Solved _ k t) => vappSpine t sp >>= quote l
quote l (VLam fc x icit rig t) = do
val <- t $$ VVar emptyFC l [<]
tm <- quote (S l) val
pure $ Lam fc x icit rig tm
quote l (VPi fc x icit rig a b) = do
a' <- quote l a
val <- b $$ VVar emptyFC l [<]
tm <- quote (S l) val
pure $ Pi fc x icit rig a' tm
quote l (VLet fc nm t u) = do
t' <- quote l t
u' <- quote (S l) u
pure $ Let fc nm t' u'
quote l (VLetRec fc nm ty t u) = do
ty' <- quote l ty
t' <- quote (S l) t
u' <- quote (S l) u
pure $ LetRec fc nm ty' t' u'
quote l (VU fc) = pure (UU fc)
quote l (VRef fc n def sp) = quoteSp l (Ref fc n def) sp
quote l (VCase fc sc alts) = pure $ Case fc !(quote l sc) alts
quote l (VCase fc sc alts) = do
sc' <- quote l sc
pure $ Case fc sc' alts
quote l (VLit fc lit) = pure $ Lit fc lit
quote l (VErased fc) = pure $ Erased fc
@@ -194,15 +237,17 @@ quote l (VErased fc) = pure $ Erased fc
-- ezoo only seems to use it at [], but essentially does this:
export
nf : Env -> Tm -> M Tm
nf env t = quote (length env) !(eval env CBN t)
nf env t = eval env CBN t >>= quote (length env)
export
nfv : Env -> Tm -> M Tm
nfv env t = quote (length env) !(eval env CBV t)
nfv env t = eval env CBV t >>= quote (length env)
export
prvalCtx : {auto ctx : Context} -> Val -> M String
prvalCtx v = pure $ interpolate $ pprint (toList $ map fst ctx.types) !(quote ctx.lvl v)
prvalCtx v = do
tm <- quote ctx.lvl v
pure $ interpolate $ pprint (toList $ map fst ctx.types) tm
-- REVIEW - might be easier if we inserted the meta without a bunch of explicit App
-- I believe Kovacs is doing that.
@@ -249,17 +294,22 @@ tweakFC fc (Erased fc1) = Erased fc
-- TODO replace this with a variant on nf
zonkApp : TopContext -> Nat -> Env -> Tm -> List Tm -> M Tm
zonkApp top l env (App fc t u) sp = zonkApp top l env t (!(zonk top l env u) :: sp)
zonkApp top l env t@(Meta fc k) sp = case !(lookupMeta k) of
(Solved _ j v) => do
sp' <- traverse (eval env CBN) sp
debug "zonk \{show k} -> \{show v} spine \{show sp'}"
foo <- vappSpine v ([<] <>< sp')
debug "-> result is \{show foo}"
tweakFC fc <$> quote l foo
(Unsolved x j xs _ _ _) => pure $ appSpine t sp
zonkApp top l env t sp = pure $ appSpine !(zonk top l env t) sp
zonkApp top l env (App fc t u) sp = do
u' <- zonk top l env u
zonkApp top l env t (u' :: sp)
zonkApp top l env t@(Meta fc k) sp = do
meta <- lookupMeta k
case meta of
(Solved _ j v) => do
sp' <- traverse (eval env CBN) sp
debug "zonk \{show k} -> \{show v} spine \{show sp'}"
foo <- vappSpine v ([<] <>< sp')
debug "-> result is \{show foo}"
tweakFC fc <$> quote l foo
(Unsolved x j xs _ _ _) => pure $ appSpine t sp
zonkApp top l env t sp = do
t' <- zonk top l env t
pure $ appSpine t' sp
zonkAlt : TopContext -> Nat -> Env -> CaseAlt -> M CaseAlt
zonkAlt top l env (CaseDefault t) = CaseDefault <$> zonkBind top l env t
@@ -273,7 +323,9 @@ zonkAlt top l env (CaseCons name args t) = CaseCons name args <$> go l env args
zonk top l env t = case t of
(Meta fc k) => zonkApp top l env t []
(Lam fc nm icit rig u) => Lam fc nm icit rig <$> (zonk top (S l) (VVar fc l [<] :: env) u)
(App fc t u) => zonkApp top l env t [!(zonk top l env u)]
(App fc t u) => do
u' <- zonk top l env u
zonkApp top l env t [u']
(Pi fc nm icit rig a b) => Pi fc nm icit rig <$> zonk top l env a <*> zonkBind top l env b
(Let fc nm t u) => Let fc nm <$> zonk top l env t <*> zonkBind top l env u
(LetRec fc nm ty t u) => LetRec fc nm <$> zonk top l env ty <*> zonkBind top l env t <*> zonkBind top l env u