diff --git a/playground/samples/Tour.newt b/playground/samples/Tour.newt index 0fbe028..07f0e67 100644 --- a/playground/samples/Tour.newt +++ b/playground/samples/Tour.newt @@ -16,7 +16,7 @@ on hover. I'm emitting INFO for solved metas. The Day1.newt and Day2.newt are last year's advent of code, translated - from Lean. You need to visit `Lib.newt` to get it to the worker. + from Lean. -/ diff --git a/src/Lib/Elab.idr b/src/Lib/Elab.idr index 296e418..582ab23 100644 --- a/src/Lib/Elab.idr +++ b/src/Lib/Elab.idr @@ -58,17 +58,6 @@ forceMeta (VMeta fc ix sp) = case !(lookupMeta ix) of (Solved _ k t) => vappSpine t sp >>= forceMeta forceMeta x = pure x -tryEval : Val -> M (Maybe Val) -tryEval (VRef fc k _ sp) = - case lookup k !(get) of - Just (MkEntry name ty (Fn tm)) => do - vtm <- eval [] CBN tm - case !(vappSpine vtm sp) of - VCase{} => pure Nothing - v => pure $ Just v - _ => pure Nothing -tryEval _ = pure Nothing - -- Force far enough to compare types forceType : Val -> M Val forceType (VMeta fc ix sp) = case !(lookupMeta ix) of diff --git a/src/Lib/Eval.idr b/src/Lib/Eval.idr index d6303ed..752e1c3 100644 --- a/src/Lib/Eval.idr +++ b/src/Lib/Eval.idr @@ -4,6 +4,7 @@ module Lib.Eval import Lib.Parser.Impl import Lib.Prettier import Lib.Types +import Lib.TopContext import Control.Monad.Error.Interface import Data.IORef @@ -44,6 +45,18 @@ vappSpine : Val -> SnocList Val -> M Val vappSpine t [<] = pure t vappSpine t (xs :< x) = vapp !(vappSpine t xs) x +export +tryEval : Val -> M (Maybe Val) +tryEval (VRef fc k _ sp) = + case lookup k !(get) of + Just (MkEntry name ty (Fn tm)) => do + vtm <- eval [] CBN tm + case !(vappSpine vtm sp) of + VCase{} => pure Nothing + v => pure $ Just v + _ => pure Nothing +tryEval _ = pure Nothing + evalCase : Env -> Mode -> Val -> List CaseAlt -> M (Maybe Val) evalCase env mode sc@(VRef _ nm _ sp) (cc@(CaseCons name nms t) :: xs) = if nm == name @@ -94,11 +107,12 @@ eval env mode (Bnd fc i) = case getAt i env of Nothing => error' "Bad deBruin index \{show i}" eval env mode (Lit fc lit) = pure $ VLit fc lit -eval env mode tm@(Case fc sc alts) = - case !(evalCase env mode !(eval env mode sc) alts) of - Just v => pure v - Nothing => pure $ fromMaybe (VCase fc !(eval env mode sc) alts) - !(evalCase env mode !(eval env mode sc) alts) +eval env mode tm@(Case fc sc alts) = do + -- TODO we need to be able to tell eval to expand aggressively here. + sc' <- eval env mode sc + let sc' = fromMaybe sc' !(tryEval sc') + pure $ fromMaybe (VCase fc !(eval env mode sc) alts) + !(evalCase env mode sc' alts) export quote : (lvl : Nat) -> Val -> M Tm