Port Eval.newt

done/Lib/Eval.newt

@@ -0,0 +1,337 @@
+module Lib.Eval
+
+import Lib.Types
+import Lib.TopContext
+
+import Data.IORef
+import Data.Fin
+import Data.List
+import Data.SnocList
+import Data.Vect
+import Data.SortedMap
+
+
+eval : Env -> Mode -> Tm -> M Val
+
+-- REVIEW everything is evalutated whether it's needed or not
+-- It would be nice if the environment were lazy.
+-- e.g. case is getting evaluated when passed to a function because
+-- of dependencies in pi-types, even if the dependency isn't used
+
+
+infixl 8 _$$_
+
+
+_$$_ : Closure -> Val -> M Val
+_$$_ (MkClosure env tm) u = eval (u :: env) CBN tm
+
+
+
+vapp : Val -> Val -> M Val
+vapp (VLam _ _ _ _ t) u = t $$ u
+vapp (VVar fc k sp) u = pure $ VVar fc k (sp :< u)
+vapp (VRef fc nm def sp) u = pure $ VRef fc nm def (sp :< u)
+vapp (VMeta fc k sp) u = pure $ VMeta fc k (sp :< u)
+vapp t u = error' "impossible in vapp \{show t} to \{show u}\n"
+
+
+vappSpine : Val -> SnocList Val -> M Val
+vappSpine t Lin = pure t
+vappSpine t (xs :< x) = do
+  rest <- vappSpine t xs
+  vapp rest x
+
+
+
+lookupVar : Env -> Int -> Maybe Val
+lookupVar env k = let l = cast $ length env in
+  if k > l
+    then Nothing
+    else case getAt (cast $ lvl2ix l k) env of
+      Just v@(VVar fc k' sp) => if k == k' then Nothing else Just v
+      Just v => Just v
+      Nothing => Nothing
+
+-- hoping to apply what we got via pattern matching
+
+unlet : Env -> Val -> M Val
+unlet env t@(VVar fc k sp) = case lookupVar env k of
+      Just tt@(VVar fc' k' sp') => do
+        debug $ \ _ =>  "lookup \{show k} is \{show tt}"
+        if k' == k then pure t else (vappSpine (VVar fc' k' sp') sp >>= unlet env)
+      Just t => vappSpine t sp >>= unlet env
+      Nothing => do
+        debug $ \ _ =>  "lookup \{show k} is Nothing in env \{show env}"
+        pure t
+unlet env x = pure x
+
+
+tryEval : Env -> Val -> M (Maybe Val)
+tryEval env (VRef fc k _ sp) = do
+  top <- get
+  case lookup k top of
+      Just (MkEntry _ name ty (Fn tm)) =>
+        catchError (
+            do
+            debug $ \ _ =>  "app \{show name} to \{show sp}"
+            vtm <- eval Nil CBN tm
+            debug $ \ _ =>  "tm is \{render 90 $ pprint Nil tm}"
+            val <- vappSpine vtm sp
+            case val of
+              VCase _ _ _ => pure Nothing
+              v => pure $ Just v)
+            (\ _ => pure Nothing)
+      _ => pure Nothing
+tryEval _ _ = pure Nothing
+
+
+-- Force far enough to compare types
+
+forceType : Env -> Val -> M Val
+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) = do
+  top <- get
+  if nm == name
+    then do
+      debug $ \ _ =>  "ECase \{show nm} \{show sp} \{show nms} \{showTm t}"
+      go env (sp <>> Nil) nms
+    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 Nil = do
+      t' <- eval env mode t
+      Just <$> vappSpine t' (Lin <>< args)
+    go env Nil 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 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) = 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
+
+-- So smalltt says:
+--   Smalltt has the following approach:
+--   - Top-level and local definitions are lazy.
+--   - We instantiate Pi types during elaboration with lazy values.
+--   - Applications headed by top-level variables are lazy.
+--   - Any other function application is call-by-value during evaluation.
+
+-- TODO maybe add glueing
+
+eval env mode (Ref fc x def) = pure $ VRef fc x def Lin
+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) = do
+  meta <- lookupMeta i
+  case meta of
+        (Unsolved _ k xs _ _ _) => pure $ VMeta fc i Lin
+        (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) = 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 (cast $ length env) Lin :: 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) Lin :: env) mode t
+  u' <- eval (VVar fc (length' env) Lin :: 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
+eval env mode (Bnd fc i) = case getAt' i env of
+  Just rval => pure rval
+  Nothing => error fc "Bad deBruin index \{show i}"
+eval env mode (Lit fc lit) = pure $ VLit fc lit
+
+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
+  sc' <- unlet env sc' -- try to expand lets from pattern matching
+  sc' <- forceType env sc'
+  vsc <- eval env mode sc
+  vcase <- evalCase env mode sc' alts
+  pure $ fromMaybe (VCase fc vsc alts) vcase
+
+
+quote : (lvl : Int) -> Val -> M Tm
+
+
+quoteSp : (lvl : Int) -> Tm -> SnocList Val -> M Tm
+quoteSp lvl t Lin = pure t
+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 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) => vappSpine t sp >>= quote l
+quote l (VLam fc x icit rig t) = do
+  val <- t $$ VVar emptyFC l Lin
+  tm <- quote (1 + 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 Lin
+  tm <- quote (1 + l) val
+  pure $ Pi fc x icit rig a' tm
+quote l (VLet fc nm t u) = do
+  t' <- quote l t
+  u' <- quote (1 + l) u
+  pure $ Let fc nm t' u'
+quote l (VLetRec fc nm ty t u) = do
+  ty' <- quote l ty
+  t' <- quote (1 + l) t
+  u' <- quote (1 + 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) = 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
+
+-- Can we assume closed terms?
+-- ezoo only seems to use it at Nil, but essentially does this:
+
+nf : Env -> Tm -> M Tm
+nf env t = eval env CBN t >>= quote (length' env)
+
+
+nfv : Env -> Tm -> M Tm
+nfv env t = eval env CBV t >>= quote (length' env)
+
+
+prvalCtx : {{ctx : Context}} -> Val -> M String
+prvalCtx {{ctx}} v = do
+  tm <- quote ctx.lvl v
+  pure $ interpolate $ pprint (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.
+
+-- we need to walk the whole thing
+-- meta in Tm have a bunch of args, which should be the relevant
+-- parts of the scope. So, meta has a bunch of lambdas, we've got a bunch of
+-- args and we need to beta reduce, which seems like a lot of work for nothing
+-- Could we put the "good bits" of the Meta in there and write it to Bnd directly
+-- off of scope? I guess this might get dicey when a meta is another meta applied
+-- to something.
+
+-- ok, so we're doing something that looks lot like eval, having to collect args,
+-- pull the def, and apply spine. Eval is trying for WHNF, so it doesn't walk the
+-- whole thing. (We'd like to insert metas inside lambdas.)
+
+zonk : TopContext -> Int -> Env -> Tm -> M Tm
+
+zonkBind : TopContext -> Int -> Env -> Tm -> M Tm
+zonkBind top l env tm = zonk top (1 + l) (VVar (getFC tm) l Lin :: env) tm
+
+-- I don't know if app needs an FC...
+
+appSpine : Tm -> List Tm -> Tm
+appSpine t Nil = t
+appSpine t (x :: xs) = appSpine (App (getFC t) t x) xs
+
+-- REVIEW When metas are subst in, the fc point elsewhere
+-- We might want to update when it is solved and update recursively?
+-- For errors, I think we want to pretend the code has been typed in place
+tweakFC : FC -> Tm -> Tm
+tweakFC fc (Bnd fc1 k) = Bnd fc k
+tweakFC fc (Ref fc1 nm x) = Ref fc nm x
+tweakFC fc (UU fc1) = UU fc
+tweakFC fc (Meta fc1 k) = Meta fc k
+tweakFC fc (Lam fc1 nm icit rig t) = Lam fc nm icit rig t
+tweakFC fc (App fc1 t u) = App fc t u
+tweakFC fc (Pi fc1 nm icit x t u) = Pi fc nm icit x t u
+tweakFC fc (Case fc1 t xs) = Case fc t xs
+tweakFC fc (Let fc1 nm t u) = Let fc nm t u
+tweakFC fc (LetRec fc1 nm ty t u) = LetRec fc nm ty t u
+tweakFC fc (Lit fc1 lit) = Lit fc lit
+tweakFC fc (Erased fc1) = Erased fc
+
+-- TODO replace this with a variant on nf
+zonkApp : TopContext -> Int -> Env -> Tm -> List Tm -> M Tm
+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 (Lin <>< 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 -> Int -> Env -> CaseAlt -> M CaseAlt
+zonkAlt top l env (CaseDefault t) = CaseDefault <$> zonkBind top l env t
+zonkAlt top l env (CaseLit lit t) = CaseLit lit <$> zonkBind top l env t
+zonkAlt top l env (CaseCons name args t) = CaseCons name args <$> go l env args t
+  where
+    go : Int -> Env -> List String -> Tm -> M Tm
+    go l env Nil tm = zonk top l env t
+    go l env (x :: xs) tm = go (1 + l) (VVar (getFC tm) l Lin :: env) xs tm
+
+zonk top l env t = case t of
+  (Meta fc k) => zonkApp top l env t Nil
+  (Lam fc nm icit rig u) => Lam fc nm icit rig <$> (zonk top (1 + l) (VVar fc l Lin :: env) u)
+  (App fc t u) => do
+    u' <- zonk top l env u
+    zonkApp top l env t (u' :: Nil)
+  (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
+  (Case fc sc alts) => Case fc <$> zonk top l env sc <*> traverse (zonkAlt top l env) alts
+  UU fc => pure $ UU fc
+  Lit fc lit => pure $ Lit fc lit
+  Bnd fc ix => pure $ Bnd fc ix
+  Ref fc ix def => pure $ Ref fc ix def
+  Erased fc => pure $ Erased fc

done/Lib/Parser.newt

@@ -0,0 +1,667 @@
+module Lib.Parser
+
+-- NOW Still working on this.
+
+import Data.Maybe
+import Data.String
+import Lib.Parser.Impl
+import Lib.Syntax
+import Lib.Token
+import Lib.Types
+
+lazy : ∀ a. (Unit → Parser a) → Parser a
+lazy pa = pa MkUnit
+
+ident : Parser String
+ident = token Ident <|> token MixFix
+
+uident : Parser String
+uident = token UIdent
+
+parenWrap : ∀ a. Parser a -> Parser a
+parenWrap pa = do
+  symbol "("
+  t <- pa
+  symbol ")"
+  pure t
+
+braces : ∀ a. Parser a -> Parser a
+braces pa = do
+  symbol "{"
+  t <- pa
+  symbol "}"
+  pure t
+
+dbraces : ∀ a. Parser a -> Parser a
+dbraces pa = do
+  symbol "{{"
+  t <- pa
+  symbol "}}"
+  pure t
+
+
+optional : ∀ a. Parser a -> Parser (Maybe a)
+optional pa = Just <$> pa <|> pure Nothing
+
+stringLit : Parser Raw
+stringLit = do
+  fc <- getPos
+  t <- token StringKind
+  pure $ RLit fc (LString t)
+
+
+-- typeExpr is term with arrows.
+typeExpr : Parser Raw
+term : (Parser Raw)
+
+interp : Parser Raw
+interp = do
+  token StartInterp
+  tm <- term
+  token EndInterp
+  pure tm
+
+
+interpString : Parser Raw
+interpString = do
+  -- fc <- getPos
+  ignore $ token StartQuote
+  part <- term
+  parts <- many (stringLit <|> interp)
+  ignore $ token EndQuote
+  pure $ foldl append part parts
+  where
+    append : Raw -> Raw -> Raw
+    append t u =
+      let fc = getFC t in
+      (RApp (getFC t) (RApp fc (RVar fc "_++_") t Explicit) u Explicit)
+
+intLit : Parser Raw
+intLit = do
+  fc <- getPos
+  t <- token Number
+  pure $ RLit fc (LInt (stringToInt t))
+
+
+charLit : Parser Raw
+charLit = do
+  fc <- getPos
+  v <- token Character
+  pure $ RLit fc (LChar $ strIndex v 0)
+
+lit : Parser Raw
+lit = intLit <|> interpString <|> stringLit <|> charLit
+
+
+
+-- helpful when we've got some / many and need FC for each
+addPos : ∀ a. Parser a -> Parser (FC × a)
+addPos pa = _,_ <$> getPos <*> pa
+
+asAtom : Parser Raw
+asAtom = do
+  fc <- getPos
+  nm <- ident
+  asPat <- optional $ keyword "@" *> parenWrap typeExpr
+  case asPat of
+    Just exp => pure $ RAs fc nm exp
+    Nothing  => pure $ RVar fc nm
+
+-- the inside of Raw
+atom : Parser Raw
+atom = do
+  pure MkUnit
+  RU <$> getPos <* keyword "U"
+    -- <|> RVar <$> getPos <*> ident
+    <|> asAtom
+    <|> RVar <$> getPos <*> uident
+    <|> RVar <$> getPos <*> token Projection
+    <|> lit
+    <|> RImplicit <$> getPos <* keyword "_"
+    <|> RHole <$> getPos <* keyword "?"
+    <|> parenWrap typeExpr
+
+-- Argument to a Spine
+pArg : Parser (Icit × FC × Raw)
+pArg = do
+  fc <- getPos
+  (\x => Explicit, fc, x) <$> atom
+    <|> (\x => Implicit, fc, x) <$> braces typeExpr
+    <|> (\x => Auto, fc, x) <$> dbraces typeExpr
+
+AppSpine : U
+AppSpine = List (Icit × FC × Raw)
+
+pratt : Operators -> Int -> String -> Raw -> AppSpine -> Parser (Raw × AppSpine)
+pratt ops prec stop left spine = do
+  (left, spine) <- runPrefix stop left spine
+  let (left, spine) = projectHead left spine
+  let spine = runProject spine
+  case spine of
+    Nil => pure (left, Nil)
+    ((Explicit, fc, tm@(RVar x nm)) :: rest) =>
+        if nm == stop then pure (left,spine) else
+        case lookupMap' nm ops of
+          Just (MkOp name p fix False rule) => if p < prec
+            then pure (left, spine)
+            else
+              runRule p fix stop rule (RApp fc (RVar fc name) left Explicit) rest
+          Just _ => fail "expected operator"
+          Nothing =>
+            if isPrefixOf "." nm
+            then pratt ops prec stop (RApp (getFC tm) tm left Explicit) rest
+            else pratt ops prec stop (RApp (getFC left) left tm Explicit) rest
+    ((icit, fc, tm) :: rest) => pratt ops prec stop (RApp (getFC left) left tm icit) rest
+  where
+    projectHead : Raw -> AppSpine -> (Raw × AppSpine)
+    projectHead t sp@((Explicit, fc', RVar fc nm) :: rest) =
+      if isPrefixOf "." nm
+        then projectHead (RApp fc (RVar fc nm) t Explicit) rest
+        else (t,sp)
+    projectHead t sp = (t, sp)
+
+    -- we need to check left/AppSpine first
+    -- we have a case above for when the next token is a projection, but
+    -- we need this to make projection bind tighter than app
+    runProject : AppSpine -> AppSpine
+    runProject (t@(Explicit, fc', tm) :: u@(Explicit, _, RVar fc nm) :: rest) =
+      if isPrefixOf "." nm
+        then runProject ((Explicit, fc', RApp fc (RVar fc nm) tm Explicit) :: rest)
+        else (t :: u :: rest)
+    runProject tms = tms
+
+    -- left has our partially applied operator and we're picking up args
+    -- for the rest of the `_`
+    runRule : Int -> Fixity -> String -> List String -> Raw -> AppSpine -> Parser (Raw × AppSpine)
+    runRule p fix stop Nil left spine = pure (left, spine)
+    runRule p fix stop ("" :: Nil) left spine = do
+      let pr = case fix of
+                InfixR => p
+                _ => p + 1
+      case spine of
+                ((_, fc, right) :: rest) => do
+                  (right, rest) <- pratt ops pr stop right rest
+                  pratt ops prec stop (RApp (getFC left) left right Explicit) rest
+                _ => fail "trailing operator"
+
+    runRule p fix stop (nm :: rule) left spine = do
+      case spine of
+        Nil => fail "short"
+        ((_, _, right) :: rest) => do
+
+          (right,rest) <- pratt ops 0 nm right rest -- stop!!
+          let ((_,fc',RVar fc name) :: rest) = rest
+            | _ => fail "expected \{nm}"
+          if name == nm
+            then runRule p fix stop rule (RApp (getFC left) left right Explicit) rest
+            else fail "expected \{nm}"
+
+    -- run any prefix operators
+    runPrefix : String -> Raw -> AppSpine -> Parser (Raw × AppSpine)
+    runPrefix stop (RVar fc nm) spine =
+      case lookupMap' nm ops of
+           -- TODO False should be an error here
+         Just (MkOp name p fix True rule) => do
+            runRule p fix stop rule (RVar fc name) spine
+         _ =>
+          pure (left, spine)
+    runPrefix stop left spine = pure (left, spine)
+
+
+
+parseOp : Parser Raw
+parseOp = do
+  fc <- getPos
+  ops <- getOps
+  hd <- atom
+  rest <- many pArg
+  (res, Nil) <- pratt ops 0 "" hd rest
+    | _ => fail "extra stuff"
+  pure res
+
+
+-- TODO case let? We see to only have it for `do`
+-- try (keyword "let" >> symbol "(")
+
+
+letExpr : Parser Raw
+letExpr = do
+  keyword "let"
+  alts <- startBlock $ someSame $ letAssign
+  keyword' "in"
+  scope <- typeExpr
+  pure $ foldl mkLet scope (reverse alts)
+  where
+    mkLet : Raw → String × FC × Maybe Raw × Raw → Raw
+    mkLet acc (n,fc,ty,v) = RLet fc n (fromMaybe (RImplicit fc) ty) v acc
+
+    letAssign : Parser (Name × FC × Maybe Raw × Raw)
+    letAssign = do
+      fc <- getPos
+      name <- ident
+      -- TODO type assertion
+      ty <- optional (keyword ":" *> typeExpr)
+      keyword "="
+      t <- typeExpr
+      pure (name,fc,ty,t)
+
+pLamArg : Parser (Icit × String × Maybe Raw)
+pLamArg = impArg <|> autoArg <|> expArg
+       <|> (\ x => (Explicit, x, Nothing)) <$> (ident <|> uident)
+       <|> keyword "_" *> pure (Explicit, "_", Nothing)
+  where
+    impArg : Parser (Icit × String × Maybe Raw)
+    impArg = do
+      nm <- braces (ident <|> uident)
+      ty <- optional (symbol ":" >> typeExpr)
+      pure (Implicit, nm, ty)
+
+    autoArg : Parser (Icit × String × Maybe Raw)
+    autoArg = do
+      nm <- dbraces (ident <|> uident)
+      ty <- optional (symbol ":" >> typeExpr)
+      pure (Auto, nm, ty)
+
+    expArg : Parser (Icit × String × Maybe Raw)
+    expArg = do
+      nm <- parenWrap (ident <|> uident)
+      ty <- optional (symbol ":" >> typeExpr)
+      pure (Explicit, nm, ty)
+
+lamExpr : Parser Raw
+lamExpr = do
+  pos <- getPos
+  keyword "\\" <|> keyword "λ"
+  args <- some $ addPos pLamArg
+  keyword "=>"
+  scope <- typeExpr
+  pure $ foldr mkLam scope args
+  where
+    mkLam : FC × Icit × Name × Maybe Raw → Raw → Raw
+    mkLam (fc, icit, name, ty) sc = RLam fc (BI fc name icit Many) sc
+
+
+caseAlt : Parser RCaseAlt
+caseAlt = do
+  pure MkUnit
+  pat <- typeExpr
+  keyword "=>"
+  t <- term
+  pure $ MkAlt pat t
+
+
+caseExpr : Parser Raw
+caseExpr = do
+  fc <- getPos
+  keyword "case"
+  sc <- term
+  keyword "of"
+  alts <- startBlock $ someSame $ caseAlt
+  pure $ RCase fc sc alts
+
+caseLamExpr : Parser Raw
+caseLamExpr = do
+  fc <- getPos
+  try ((keyword "\\" <|> keyword "λ") *> keyword "case")
+  alts <- startBlock $ someSame $ caseAlt
+  pure $ RLam fc (BI fc "$case" Explicit Many) $ RCase fc (RVar fc "$case") alts
+
+doExpr : Parser Raw
+doStmt : Parser DoStmt
+
+caseLet : Parser Raw
+caseLet = do
+  -- look ahead so we can fall back to normal let
+  fc <- getPos
+  try (keyword "let" >> symbol "(")
+  pat <- typeExpr
+  symbol ")"
+  keyword "="
+  sc <- typeExpr
+  alts <- startBlock $ manySame $ symbol "|" *> caseAlt
+  keyword "in"
+  body <- term
+  pure $ RCase fc sc (MkAlt pat body :: alts)
+
+doCaseLet : Parser DoStmt
+doCaseLet = do
+  -- look ahead so we can fall back to normal let
+  -- Maybe make it work like arrow?
+  fc <- getPos
+  try (keyword "let" >> symbol "(")
+  pat <- typeExpr
+  symbol ")"
+  keyword "="
+  sc <- typeExpr
+  alts <- startBlock $ manySame $ symbol "|" *> caseAlt
+  bodyFC <- getPos
+  body <- RDo <$> getPos <*> someSame doStmt
+  pure $ DoExpr fc (RCase fc sc (MkAlt pat body :: alts))
+
+doArrow : Parser DoStmt
+doArrow = do
+  fc <- getPos
+  left <- typeExpr
+  (Just _) <- optional $ keyword "<-"
+    | _ => pure $ DoExpr fc left
+  right <- term
+  alts <- startBlock $ manySame $ symbol "|" *> caseAlt
+  pure $ DoArrow fc left right alts
+
+doLet : Parser DoStmt
+doLet = do
+  fc <- getPos
+  keyword "let"
+  nm <- ident
+  keyword "="
+  tm <- term
+  pure $ DoLet fc nm tm
+
+doStmt
+  = doCaseLet
+  <|> doLet
+  <|> doArrow
+
+doExpr = RDo <$> getPos <* keyword "do" <*> (startBlock $ someSame doStmt)
+
+parseIfThen : Parser Raw
+parseIfThen = do
+  fc <- getPos
+  keyword "if"
+  a <- term
+  keyword "then"
+  b <- term
+  keyword "else"
+  c <- term
+  pure $ RIf fc a b c
+
+term' : Parser Raw
+
+term' =  caseExpr
+    <|> caseLet
+    <|> letExpr
+    <|> caseLamExpr
+    <|> lamExpr
+    <|> doExpr
+    <|> parseIfThen
+    -- Make this last for better error messages
+    <|> parseOp
+
+term = do
+  t <- term'
+  rest <- many (_,_ <$> getPos <* keyword "$" <*> term')
+  pure $ apply t rest
+  where
+    apply : Raw -> List (FC × Raw) -> Raw
+    apply t Nil = t
+    apply t ((fc,x) :: xs) = RApp fc t (apply x xs) Explicit
+
+varname : Parser String
+varname = (ident <|> uident <|> keyword "_" *> pure "_")
+
+quantity : Parser Quant
+quantity = fromMaybe Many <$> optional (Zero <$ keyword "0")
+
+ebind : Parser Telescope
+ebind = do
+  -- don't commit until we see the ":"
+  symbol "("
+  quant <- quantity
+  names <- try (some (addPos varname) <* symbol ":")
+  ty <- typeExpr
+  symbol ")"
+  pure $ map (makeBind quant ty) names
+  where
+    makeBind : Quant → Raw → FC × String → (BindInfo × Raw)
+    makeBind quant ty (pos, name) = (BI pos name Explicit quant, ty)
+
+
+ibind : Parser Telescope
+ibind = do
+  -- I've gone back and forth on this, but I think {m a b} is more useful than {Int}
+  symbol "{"
+  quant <- quantity
+  names <- (some (addPos varname))
+  ty <- optional (symbol ":" *> typeExpr)
+  symbol "}"
+  pure $ map (makeBind quant ty) names
+  where
+    makeBind : Quant → Maybe Raw → FC × String → BindInfo × Raw
+    makeBind quant ty (pos, name) = (BI pos name Implicit quant, fromMaybe (RImplicit pos) ty)
+
+abind : Parser Telescope
+abind = do
+  -- for this, however, it would be nice to allow {{Monad A}}
+  symbol "{{"
+  name <- optional $ try (addPos varname <* symbol ":")
+  ty <- typeExpr
+  symbol "}}"
+  case name of
+    Just (pos,name) => pure ((BI pos name Auto Many, ty) :: Nil)
+    Nothing => pure ((BI (getFC ty) "_" Auto Many, ty) :: Nil)
+
+arrow : Parser Unit
+arrow = symbol "->" <|> symbol "→"
+
+-- Collect a bunch of binders (A : U) {y : A} -> ...
+
+forAll : Parser Raw
+forAll = do
+  keyword "forall" <|> keyword "∀"
+  all <- some (addPos varname)
+  keyword "."
+  scope <- typeExpr
+  pure $ foldr mkPi scope all
+  where
+    mkPi : FC × String → Raw → Raw
+    mkPi (fc, n) sc = RPi fc (BI fc n Implicit Zero) (RImplicit fc) sc
+
+binders : Parser Raw
+binders = do
+  binds <- many (abind <|> ibind <|> ebind)
+  arrow
+  scope <- typeExpr
+  pure $ foldr mkBind scope (join binds)
+  where
+    mkBind : (BindInfo × Raw) -> Raw -> Raw
+    mkBind (info, ty) scope = RPi (getFC info) info ty scope
+
+typeExpr
+  = binders
+  <|> forAll
+  <|> (do
+        fc <- getPos
+        exp <- term
+        scope <- optional (arrow *> typeExpr)
+        case scope of
+          Nothing      => pure exp
+          -- consider Maybe String to represent missing
+          (Just scope) => pure $ RPi fc (BI fc "_" Explicit Many) exp scope)
+
+-- And top level stuff
+
+
+parseSig : Parser Decl
+parseSig = TypeSig <$> getPos <*> try (some (ident <|> uident <|> token Projection) <* keyword ":") <*> typeExpr
+
+parseImport : Parser Import
+parseImport = do
+  fc <- getPos
+  keyword "import"
+  ident <- uident
+  rest <- many $ token Projection
+  let name = joinBy "" (ident :: rest)
+  pure $ MkImport fc name
+
+-- Do we do pattern stuff now? or just name = lambda?
+-- TODO multiple names
+parseMixfix : Parser Decl
+parseMixfix = do
+  fc <- getPos
+  fix <- InfixL <$ keyword "infixl"
+     <|> InfixR <$ keyword "infixr"
+     <|> Infix <$ keyword "infix"
+  prec <- token Number
+  ops <- some $ token MixFix
+  for ops $ \ op => addOp op (cast prec) fix
+  pure $ PMixFix fc ops (cast prec) fix
+
+getName : Raw -> Parser String
+getName (RVar x nm) = pure nm
+getName (RApp x t u icit) = getName t
+getName tm = fail "bad LHS"
+
+
+
+parseDef : Parser Decl
+parseDef = do
+  fc <- getPos
+  t <- typeExpr
+  nm <- getName t
+  keyword "="
+  body <- typeExpr
+  wfc <- getPos
+  w <- optional $ do
+    keyword "where"
+    startBlock $ manySame $ (parseSig <|> parseDef)
+  let body = maybe body (\ decls => RWhere wfc decls body) w
+  -- these get collected later
+  pure $ Def fc nm ((t, body) :: Nil) -- (MkClause fc Nil t body :: Nil)
+
+
+parsePType : Parser Decl
+parsePType = do
+  fc <- getPos
+  keyword "ptype"
+  id <- uident
+  ty <- optional $ do
+    keyword ":"
+    typeExpr
+  pure $ PType fc id ty
+
+parsePFunc : Parser Decl
+parsePFunc = do
+  fc <- getPos
+  keyword "pfunc"
+  nm <- ident
+  used <- optional (keyword "uses" >> parenWrap (many $ uident <|> ident <|> token MixFix))
+  keyword ":"
+  ty <- typeExpr
+  keyword ":="
+  src <- token JSLit
+  pure $ PFunc fc nm (fromMaybe Nil used) ty src
+
+
+parseShortData : Parser Decl
+parseShortData = do
+  fc <- getPos
+  keyword "data"
+  lhs <- typeExpr
+  keyword "="
+  sigs <- sepBy (keyword "|") typeExpr
+  pure $ ShortData fc lhs sigs
+
+
+parseData : Parser Decl
+parseData = do
+  fc <- getPos
+  -- commit when we hit ":"
+  name <- try $ (keyword "data" *> (uident <|> ident <|> token MixFix) <* keyword ":")
+  ty <- typeExpr
+  keyword "where"
+  decls <- startBlock $ manySame $ parseSig
+  pure $ Data fc name ty decls
+
+nakedBind : Parser Telescope
+nakedBind = do
+  names <- some (addPos varname)
+  pure $ map makeBind names
+  where
+    makeBind : FC × String → (BindInfo × Raw)
+    makeBind (pos, name) = (BI pos name Explicit Many, RImplicit pos)
+
+parseRecord : Parser Decl
+parseRecord = do
+  fc <- getPos
+  keyword "record"
+  name <- uident
+  teles <- many $ ebind <|> nakedBind
+  keyword "where"
+  cname <- optional $ keyword "constructor" *> (uident <|> token MixFix)
+  decls <- startBlock $ manySame $ parseSig
+  pure $ Record fc name (join teles) cname decls
+
+
+
+parseClass : Parser Decl
+parseClass = do
+  fc <- getPos
+  keyword "class"
+  name <- uident
+  teles <- many $ ebind <|> nakedBind
+  keyword "where"
+  decls <- startBlock $ manySame $ parseSig
+  pure $ Class fc name (join teles) decls
+
+
+parseInstance : Parser Decl
+parseInstance = do
+  fc <- getPos
+  keyword "instance"
+  ty <- typeExpr
+  -- is it a forward declaration
+  (Just _) <- optional $ keyword "where"
+    | _ => pure $ Instance fc ty Nothing
+  decls <- startBlock $ manySame $ parseDef
+  pure $ Instance fc ty (Just decls)
+
+-- Not sure what I want here.
+-- I can't get a Tm without a type, and then we're covered by the other stuff
+parseNorm : Parser Decl
+parseNorm = DCheck <$> getPos <* keyword "#check" <*> typeExpr <* keyword ":" <*> typeExpr
+
+
+parseDecl : Parser Decl
+parseDecl = parseMixfix <|> parsePType <|> parsePFunc
+  <|> parseNorm <|> parseData <|> parseShortData <|> parseSig <|> parseDef
+  <|> parseClass <|> parseInstance <|> parseRecord
+
+
+
+parseModHeader : Parser (FC × String)
+parseModHeader = do
+  sameLevel (keyword "module")
+  fc <- getPos
+  name <- uident
+  rest <- many $ token Projection
+  -- FIXME use QName
+  let name = joinBy "" (name :: rest)
+  pure (fc, name)
+
+
+parseImports : Parser (List Import)
+parseImports = manySame parseImport
+
+
+parseMod : Parser Module
+parseMod = do
+  sameLevel (keyword "module")
+  name <- uident
+  rest <- many $ token Projection
+  imports <- manySame parseImport
+  decls <- manySame parseDecl
+  let name = joinBy "" (name :: rest)
+  pure $ MkModule name imports decls
+
+
+data ReplCmd =
+    Def Decl
+  | Norm Raw -- or just name?
+  | Check Raw
+
+
+-- Eventually I'd like immediate actions in the file, like lean, but I
+-- also want to REPL to work and we can do that first.
+parseRepl : Parser ReplCmd
+parseRepl = Def <$> parseDecl <|> Norm <$ keyword "#nf" <*> typeExpr
+  <|> Check <$ keyword "#check" <*> typeExpr

newt/Prelude.newt

@@ -534,6 +534,7 @@ getAt _ Nil = Nothing
 getAt Z (x :: xs) = Just x
 getAt (S k) (x :: xs) = getAt k xs
 
+
 splitOn : ∀ a. {{Eq a}} → a → List a → List (List a)
 splitOn {a} v xs = go Nil xs
   where
@@ -849,3 +850,14 @@ instance ∀ a. {{Show a}} → Show (Maybe a) where
 
 pfunc isPrefixOf uses (True False): String → String → Bool := `(pfx, s) => s.startsWith(pfx) ? True : False`
 pfunc strIndex : String → Int → Char := `(s, ix) => s[ix]`
+
+
+instance ∀ a. {{Show a}} → Show (SnocList a) where
+  show xs = show (xs <>> Nil)
+
+getAt' : ∀ a. Int → List a → Maybe a
+getAt' i xs = getAt (cast i) xs
+
+length' : ∀ a. List a → Int
+length' Nil = 0
+length' (x :: xs) = 1 + length' xs

src/Lib/Eval.idr

@@ -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) =
+tryEval env (VRef fc k _ sp) = do
-  case lookup k !(get) of
+  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}"
+            debug "tm is \{render 90 $ pprint [] tm}"
-            case !(vappSpine vtm sp) of
+            val <- vappSpine vtm sp
-              VCase{} => pure Nothing
+            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
+forceType env (VMeta fc ix sp) = do
-  (Unsolved x k xs _ _ _) => pure (VMeta fc ix sp)
+  meta <- lookupMeta ix
-  (Solved _ k t) => vappSpine t sp >>= forceType env
+  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
+        if k' == k
-          else evalCase env mode !(vappSpine (VVar fc' k' sp') sp) alts
+          then pure Nothing
-    Just t => evalCase env mode !(vappSpine t sp) alts
+          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) =
+eval env mode (Meta fc i) = do
-  case !(lookupMeta i) of
+  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 (Pi fc x icit rig a b) = do
-eval env mode (Let fc nm t u) = pure $ VLet fc nm !(eval env mode t) !(eval (VVar fc (length env) [<] :: env) mode u)
+  a' <- eval env mode a
-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)
+  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)
+  vsc <- eval env mode sc
-                             !(evalCase env mode sc' alts)
+  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) =
+quoteSp lvl t (xs :< x) = do
-  pure $ App emptyFC !(quoteSp lvl t xs) !(quote lvl x)
+  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
+  else error fc "Bad index in quote \{show k} depth \{show l}"
-quote l (VMeta fc i sp) =
+quote l (VMeta fc i sp) = do
-  case !(lookupMeta i) of
+  meta <- lookupMeta i
+  case meta of
         (Unsolved _ k xs _ _ _) => quoteSp l (Meta fc i) sp
-        (Solved _ k t) => quote l !(vappSpine t sp)
+        (Solved _ k t) => vappSpine t sp >>= quote l
-quote l (VLam fc x icit rig t) = pure $ Lam fc x icit rig !(quote (S l) !(t $$ VVar emptyFC l [<]))
+quote l (VLam fc x icit rig t) = do
-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 [<]))
+  val <- t $$ VVar emptyFC l [<]
-quote l (VLet fc nm t u) = pure $ Let fc nm !(quote l t) !(quote (S l) u)
+  tm <- quote (S l) val
-quote l (VLetRec fc nm ty t u) = pure $ LetRec fc nm !(quote l ty) !(quote (S l) t) !(quote (S l) u)
+  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 (App fc t u) sp = do
-zonkApp top l env t@(Meta fc k) sp = case !(lookupMeta k) of
+  u' <- zonk top l env u
-  (Solved _ j v) => do
+  zonkApp top l env t (u' :: sp)
-    sp' <- traverse (eval env CBN) sp
+zonkApp top l env t@(Meta fc k) sp = do
-    debug "zonk \{show k} -> \{show v} spine \{show sp'}"
+  meta <- lookupMeta k
-    foo <- vappSpine v ([<] <>< sp')
+  case meta of
-    debug "-> result is \{show foo}"
+    (Solved _ j v) => do
-    tweakFC fc <$> quote l foo
+      sp' <- traverse (eval env CBN) sp
-
+      debug "zonk \{show k} -> \{show v} spine \{show sp'}"
-  (Unsolved x j xs _ _ _) => pure $ appSpine t sp
+      foo <- vappSpine v ([<] <>< sp')
-zonkApp top l env t sp = pure $ appSpine !(zonk top l env t) 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