Improvements to erasure checking, fix to codegen issue

src/Lib/Compile.idr

@@ -126,11 +126,19 @@ termToJS env (CLetRec nm t u) f =
     (JAssign _ exp) => JSnoc (JConst nm' exp) (termToJS env' u f)
     t' => JSnoc (JLet nm' t') (termToJS env' u f)
 
-termToJS env (CApp t args) f = termToJS env t (\ t' => argsToJS args [<] (\ args' => f (Apply t' args')))
+termToJS env (CApp t args etas) f = termToJS env t (\ t' => (argsToJS t' args [<] f)) --  (f (Apply t' args'))))
   where
-    argsToJS : List CExp -> SnocList JSExp -> (List JSExp -> JSStmt e) -> JSStmt e
-    argsToJS [] acc k = k (acc <>> [])
-    argsToJS (x :: xs) acc k = termToJS env x (\ x' => argsToJS xs (acc :< x') k)
+    etaExpand : JSEnv -> Nat -> SnocList JSExp -> JSExp -> JSExp
+    etaExpand env Z args tm = Apply tm (args <>> [])
+    etaExpand env (S etas) args tm =
+      let nm' = fresh "eta" env
+          env' = push env (Var nm')
+       in JLam [nm'] $ JReturn $ etaExpand (push env (Var nm')) etas (args :< Var nm') tm
+
+    argsToJS : JSExp -> List CExp -> SnocList JSExp -> (JSExp -> JSStmt e) -> JSStmt e
+    argsToJS tm [] acc k = k (etaExpand env etas acc tm)
+    -- k (acc <>> [])
+    argsToJS tm (x :: xs) acc k = termToJS env x (\ x' => argsToJS tm xs (acc :< x') k)
 
 
 termToJS env (CCase t alts) f =
@@ -171,7 +179,8 @@ jsString str = text (show str)
 keywords : List String
 keywords = [
   "var", "true", "false", "let", "case", "switch", "if", "then", "else", "String",
-  "function", "void", "undefined", "null", "await", "async", "return", "const"
+  "function", "void", "undefined", "null", "await", "async", "return", "const",
+  "Number"
 ]
 
 ||| escape identifiers for js
@@ -293,7 +302,7 @@ process (done,docs) nm = do
   where
     walkTm : Tm -> (List String, List Doc) -> M (List String, List Doc)
     walkAlt : (List String, List Doc) -> CaseAlt -> M (List String, List Doc)
-    walkAlt acc (CaseDefault t) = pure acc
+    walkAlt acc (CaseDefault t) = walkTm t acc
     walkAlt acc (CaseCons name args t) = walkTm t acc
     walkAlt acc (CaseLit lit t) = walkTm t acc
 

src/Lib/CompileExp.idr

@@ -1,6 +1,9 @@
 ||| First pass of compilation
 ||| - work out arities and fully apply functions / constructors (currying)
-||| - expand metas
+|||     currying is problemmatic because we need to insert lambdas (η-expand) and
+|||     it breaks all of the de Bruijn indices
+||| - expand metas (this is happening earlier)
+||| - erase stuff (there is another copy that essentially does the same thing)
 ||| I could make names unique (e.q. on lambdas), but I might want that to vary per backend?
 module Lib.CompileExp
 
@@ -27,7 +30,9 @@ data CExp : Type where
   CBnd : Nat -> CExp
   CLam : Name -> CExp -> CExp
   CFun : List Name -> CExp -> CExp
-  CApp : CExp -> List CExp -> CExp
+  -- REVIEW This feels like a hack, but if we put CLam here, the
+  -- deBruijn gets messed up in code gen
+  CApp : CExp -> List CExp -> Nat -> CExp
   -- TODO make DCon/TCon app separate so we can specialize
   -- U / Pi are compiled to type constructors
   CCase : CExp -> List CAlt -> CExp
@@ -71,19 +76,21 @@ compileTerm : Tm -> M CExp
 -- need to eta out extra args, fill in the rest of the apps
 apply : CExp -> List CExp -> SnocList CExp -> Nat -> Tm -> M CExp
 -- out of args, make one up (fix that last arg)
-apply t [] acc (S k) ty = pure $
-  CLam "eta\{show k}" !(apply t [] (acc :< CBnd k) k ty)
+apply t [] acc (S k) ty = pure $ CApp t (acc <>> []) (S k)
+  -- inserting Clam, index wrong?
+  -- CLam "eta\{show k}" !(apply t [] (acc :< CBnd k) k ty)
 apply t (x :: xs) acc (S k) (Pi y str icit Zero a b) =  apply t xs (acc :< CErased) k b
 apply t (x :: xs) acc (S k) (Pi y str icit Many a b) =  apply t xs (acc :< x) k b
 -- see if there is anything we have to handle here
-apply t (x :: xs) acc (S k) ty = error (getFC ty) "Expected pi \{showTm ty}"
-apply t ts acc 0 ty = go (CApp t (acc <>> [])) ts
+apply t (x :: xs) acc (S k) ty = error (getFC ty) "Expected pi \{showTm ty}. Overapplied function that escaped type checking?"
+-- once we hit zero, we fold the rest
+apply t ts acc 0 ty = go (CApp t (acc <>> []) Z) ts
   where
     go : CExp -> List CExp -> M CExp
     -- drop zero arg call
-    go (CApp t []) args = go t args
+    go (CApp t [] Z) args = go t args
     go t [] = pure t
-    go t (arg :: args) = go (CApp t [arg]) args
+    go t (arg :: args) = go (CApp t [arg] 0) args
 
 -- apply : CExp -> List CExp -> SnocList CExp -> Nat -> M CExp
 -- -- out of args, make one up
@@ -111,7 +118,7 @@ compileTerm (Lam _ nm t) = pure $ CLam nm !(compileTerm t)
 compileTerm tm@(App _ _ _) with (funArgs tm)
   _ | (Meta _ k, args) = do
         -- this will be undefined, should only happen for use metas
-        pure $ CApp (CRef "Meta\{show k}") []
+        pure $ CApp (CRef "Meta\{show k}") [] Z
   _ | (t@(Ref fc nm _), args) = do
         args' <- traverse compileTerm args
         arity <- arityForName fc nm
@@ -126,7 +133,7 @@ compileTerm tm@(App _ _ _) with (funArgs tm)
         apply t' args' [<] 0 (U emptyFC)
         -- error (getFC t) "Don't know how to apply \{showTm t}"
 compileTerm (U _) = pure $ CRef "U"
-compileTerm (Pi _ nm icit rig t u) = pure $ CApp (CRef "PiType") [ !(compileTerm t), CLam nm !(compileTerm u)]
+compileTerm (Pi _ nm icit rig t u) = pure $ CApp (CRef "PiType") [ !(compileTerm t), CLam nm !(compileTerm u)] Z
 compileTerm (Case _ t alts) = do
   t' <- compileTerm t
   alts' <- traverse (\case
@@ -137,6 +144,7 @@ compileTerm (Case _ t alts) = do
 compileTerm (Lit _ lit) = pure $ CLit lit
 compileTerm (Let _ nm t u) = pure $ CLet nm !(compileTerm t) !(compileTerm u)
 compileTerm (LetRec _ nm t u) = pure $ CLetRec nm !(compileTerm t) !(compileTerm u)
+compileTerm (Erased _) = pure CErased
 
 export
 compileFun : Tm -> M CExp

src/Lib/Elab.idr

@@ -175,6 +175,7 @@ rename meta ren lvl v = go ren lvl v
     go ren lvl (VLam fc n t) = pure (Lam fc n !(go (lvl :: ren) (S lvl) !(t $$ VVar fc lvl [<])))
     go ren lvl (VPi fc n icit rig ty tm) = pure (Pi fc n icit rig !(go ren lvl ty) !(go (lvl :: ren) (S lvl) !(tm $$ VVar emptyFC lvl [<])))
     go ren lvl (VU fc) = pure (U fc)
+    go ren lvl (VErased fc) = pure (Erased fc)
     -- for now, we don't do solutions with case in them.
     go ren lvl (VCase fc sc alts) = error fc "Case in solution"
     go ren lvl (VLit fc lit) = pure (Lit fc lit)
@@ -379,7 +380,6 @@ insert : (ctx : Context) -> Tm -> Val -> M (Tm, Val)
 insert ctx tm ty = do
   case !(forceMeta ty) of
     VPi fc x Auto rig a b => do
-      -- FIXME mark meta as auto, maybe try to solve here?
       m <- freshMeta ctx (getFC tm) a AutoSolve
       debug "INSERT Auto \{pprint (names ctx) m} : \{show a}"
       debug "TM \{pprint (names ctx) tm}"
@@ -528,14 +528,6 @@ updateContext ctx ((k, val) :: cs) = let ix = (length ctx.env `minus` k) `minus`
     replaceV 0 x (y :: xs) = x :: xs
     replaceV (S k) x (y :: xs) = y :: replaceV k x xs
 
-forcedName : Context -> String -> Maybe Name
-forcedName ctx nm = case lookupName ctx nm of
-  Just (Bnd fc ix, ty) => case getAt ix ctx.env of
-    (Just (VRef x nm y sp)) => -- TODO verify is constructor?
-      Just nm
-    _ => Nothing
-  _ => Nothing
-
 -- ok, so this is a single constructor, CaseAlt
 -- return Nothing if dcon doesn't unify with scrut
 buildCase : Context -> Problem -> String -> Val -> (String, Nat, Tm) -> M (Maybe CaseAlt)
@@ -1000,7 +992,8 @@ infer ctx (RVar fc nm) = go 0 ctx.types
       Nothing => error fc "\{show nm} not in scope"
     go i ((x, ty) :: xs) = if x == nm then pure $ (Bnd fc i, ty)
       else go (i + 1) xs
-  -- need environment of name -> type..
+-- FIXME tightens up output but hardcodes a name
+-- infer ctx (RApp fc (RVar _ "_$_") u icit) = infer ctx u
 infer ctx (RApp fc t u icit) = do
   -- If the app is explicit, add any necessary metas
   (icit, t, tty) <- case the Icit icit of

src/Lib/Erasure.idr

@@ -0,0 +1,92 @@
+module Lib.Erasure
+
+import Lib.Types
+import Data.SnocList
+import Lib.TopContext
+
+EEnv = List (String, Quant)
+
+-- check App at type
+
+getType : Tm -> M (Maybe Tm)
+getType (Ref fc nm x) = do
+  top <- get
+  case lookup nm top of
+    Nothing => pure Nothing
+    (Just (MkEntry name type def)) => pure $ Just type
+getType tm = pure Nothing
+
+export
+erase : EEnv -> Tm -> List (FC, Tm) -> M Tm
+
+-- App a spine using type
+eraseSpine : EEnv -> Tm -> List (FC, Tm) -> Maybe Tm -> M Tm
+eraseSpine env tm [] _ = pure tm
+eraseSpine env t ((fc, arg) :: args) (Just (Pi fc1 str icit Zero a b)) = do
+  let u = Erased (getFC arg)
+  eraseSpine env (App fc t u) args (Just b)
+eraseSpine env t ((fc, arg) :: args) (Just (Pi fc1 str icit Many a b)) = do
+  u <- erase env arg []
+  eraseSpine env (App fc t u) args (Just b)
+eraseSpine env t ((fc, arg) :: args) _ = do
+  u <- erase env arg []
+  eraseSpine env (App fc t u) args Nothing
+
+doAlt : EEnv -> CaseAlt -> M CaseAlt
+-- REVIEW do we extend env?
+doAlt env (CaseDefault t) = CaseDefault <$> erase env t []
+doAlt env (CaseCons name args t) = do
+  top <- get
+  let Just (MkEntry str type def) = lookup name top
+    | _ => error emptyFC "\{name} dcon missing from context"
+  let env' = piEnv env type args
+  CaseCons name args <$> erase env' t []
+  where
+    piEnv : EEnv -> Tm -> List String -> EEnv
+    piEnv env (Pi fc nm icit rig t u) (arg :: args) = piEnv ((arg,rig) :: env) u args
+    piEnv env _ _ = env
+
+doAlt env (CaseLit lit t) = CaseLit lit <$> erase env t []
+
+-- Check erasure and insert "Erased" value
+-- We have a solution for Erased values, so important thing here is checking.
+-- build stack, see what to do when we hit a non-app
+erase env t sp = case t of
+  (App fc u v) => erase env u ((fc,v) :: sp)
+  (Ref fc nm x) => do
+    top <- get
+    case lookup nm top of
+      Nothing => eraseSpine env t sp Nothing
+      (Just (MkEntry name type def)) => eraseSpine env t sp (Just type)
+  (Lam fc nm u) => Lam fc nm <$> erase ((nm, Many) :: env) u []
+  -- If we get here, we're looking at a runtime pi type
+  (Pi fc nm icit rig u v) => do
+    u' <- erase env u []
+    v' <- erase ((nm, Many) :: env) v []
+    eraseSpine env (Pi fc nm icit rig u' v') sp Nothing
+  -- leaving as-is for now, we don't know the quantity of the apps
+  (Meta fc k) => pure t
+  (Case fc u alts) => do
+    -- REVIEW check if this pushes to env, and write that down or get an index on there
+    u' <- erase env u []
+    alts' <- traverse (doAlt env) alts
+    eraseSpine env (Case fc u' alts') sp Nothing
+  (Let fc nm u v) => do
+    u' <- erase env u []
+    v' <- erase ((nm, Many) :: env) v []
+    eraseSpine env (Let fc nm u' v') sp Nothing
+  (LetRec fc nm u v) => do
+    u' <- erase ((nm, Many) :: env) u []
+    v' <- erase ((nm, Many) :: env) v []
+    eraseSpine env (LetRec fc nm u' v') sp Nothing
+  (Bnd fc k) => do
+    case getAt k env of
+      Nothing => error fc "bad index \{show k}"
+      -- This is working, but empty FC
+      Just (nm, Zero) => error fc "used erased value \{show nm} (FIXME FC may be wrong here)"
+      Just (nm, Many) => eraseSpine env t sp Nothing
+  (U fc) => eraseSpine env t sp Nothing
+  (Lit fc lit) => eraseSpine env t sp Nothing
+  Erased fc => eraseSpine env t sp Nothing
+
+

src/Lib/Eval.idr

@@ -145,6 +145,7 @@ bind v env = v :: env
 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 (U fc) = pure (VU fc)
+eval env mode (Erased fc) = pure (VErased fc)
 eval env mode (Meta fc i) =
   case !(lookupMeta i) of
         (Unsolved _ k xs _ _ _) => pure $ VMeta fc i [<]
@@ -179,7 +180,7 @@ quoteSp lvl t (xs :< x) =
   pure $ App emptyFC !(quoteSp lvl t xs) !(quote lvl x)
 
 quote l (VVar fc k sp) = if k < l
-  then quoteSp l (Bnd emptyFC ((l `minus` k) `minus` 1)) sp -- level to index
+  then quoteSp l (Bnd fc ((l `minus` k) `minus` 1)) sp -- level to index
   else ?borken
 quote l (VMeta fc i sp) =
   case !(lookupMeta i) of
@@ -193,6 +194,7 @@ quote l (VU fc) = pure (U 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 (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 [], but essentially does this:
@@ -234,6 +236,23 @@ appSpine : Tm -> List Tm -> Tm
 appSpine t [] = 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 (U fc1) = U fc
+tweakFC fc (Meta fc1 k) = Meta fc k
+tweakFC fc (Lam fc1 nm t) = Lam fc nm 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 t u) = LetRec fc nm 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 -> 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)
@@ -243,7 +262,8 @@ zonkApp top l env t@(Meta fc k) sp = case !(lookupMeta k) of
     debug "zonk \{show k} -> \{show v} spine \{show sp'}"
     foo <- vappSpine v ([<] <>< sp')
     debug "-> result is \{show foo}"
-    quote l 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
 
@@ -268,3 +288,4 @@ zonk top l env t = case t of
   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

src/Lib/Parser.idr

@@ -111,8 +111,8 @@ pratt ops prec stop left spine = do
             else
               runRule p fix stop rule (RApp fc (RVar fc name) left Explicit) rest
           Just _ => fail "expected operator"
-          Nothing => pratt ops prec stop (RApp fc left tm Explicit) rest
-    ((icit, fc, tm) :: rest) => pratt ops prec stop (RApp fc left tm icit) rest
+          Nothing => 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
     runRule : Int -> Fixity -> String -> List String -> Raw -> AppSpine -> Parser (Raw,AppSpine)
     runRule p fix stop [] left spine = pure (left,spine)
@@ -121,7 +121,7 @@ pratt ops prec stop left spine = do
       case spine of
                 ((_, fc, right) :: rest) => do
                   (right, rest) <- pratt ops pr stop right rest
-                  pratt ops prec stop (RApp fc left right Explicit) rest
+                  pratt ops prec stop (RApp (getFC left) left right Explicit) rest
                 _ => fail "trailing operator"
 
     runRule p fix stop (nm :: rule) left spine = do
@@ -131,7 +131,7 @@ pratt ops prec stop left spine = do
         | _ => fail "expected \{nm}"
 
       if name == nm
-          then runRule p fix stop rule (RApp fc left right Explicit) rest
+          then runRule p fix stop rule (RApp (getFC left) left right Explicit) rest
           else fail "expected \{nm}"
 
 
@@ -257,8 +257,9 @@ term =  caseExpr
     <|> letExpr
     <|> lamExpr
     <|> doExpr
-    <|> parseOp
     <|> ifThenElse
+    -- Make this last for better error messages
+    <|> parseOp
 
 varname : Parser String
 varname = (ident <|> uident <|> keyword "_" *> pure "_")

src/Lib/ProcessDecl.idr

@@ -13,6 +13,7 @@ import Lib.TopContext
 import Lib.Eval
 import Lib.Types
 import Lib.Util
+import Lib.Erasure
 
 -- Check that the arguments are not explicit and the type constructor in codomain matches
 -- Later we will build a table of codomain type, and maybe make the user tag the candidates
@@ -223,6 +224,12 @@ processDecl (Def fc nm clauses) = do
   -- tm' <- nf [] tm
   tm' <- zonk top 0 [] tm
   putStrLn "NF\n\{render 80 $ pprint[] tm'}"
+  -- TODO we want to keep both versions, but this is checking in addition to erasing
+  -- currently CompileExp is also doing erasure.
+  -- TODO we need erasure info on the lambdas or to fake up an appropriate environment
+  -- and erase inside. Currently the checking is imprecise
+  tm'' <- erase [] tm' []
+  putStrLn "ERASED\n\{render 80 $ pprint[] tm'}"
   debug "Add def \{nm} \{pprint [] tm'} : \{pprint [] ty}"
   updateDef nm fc ty (Fn tm')
   -- logMetas mstart

src/Lib/Types.idr

@@ -127,6 +127,7 @@ data Tm : Type where
   -- for desugaring where
   LetRec : FC -> Name -> Tm -> Tm -> Tm
   Lit : FC -> Literal -> Tm
+  Erased : FC -> Tm
 
 %name Tm t, u, v
 
@@ -143,6 +144,7 @@ HasFC Tm where
   getFC (Lit fc _) = fc
   getFC (Let fc _ _ _) = fc
   getFC (LetRec fc _ _ _) = fc
+  getFC (Erased fc) = fc
 
 covering
 Show Tm
@@ -168,6 +170,7 @@ Show Tm where
   show (Case _ sc alts) = "(Case \{show sc} \{show alts})"
   show (Let _ nm t u) = "(Let \{nm} \{show t} \{show u})"
   show (LetRec _ nm t u) = "(LetRec \{nm} \{show t} \{show u})"
+  show (Erased _) = "ERASED"
 
 public export
 showTm : Tm -> String
@@ -242,7 +245,7 @@ pprint names tm = go 0 names tm
     go p names (Lit _ lit) = text (show lit)
     go p names (Let _ nm t u) = parens 0 p $ text "let" <+> text nm <+> ":=" <+> go 0 names t <+> "in" </> (nest 2 $ go 0 (nm :: names) u)
     go p names (LetRec _ nm t u) = parens 0 p $ text "letrec" <+> text nm <+> ":=" <+> go 0 names t <+> "in" </> (nest 2 $ go 0 (nm :: names) u)
-
+    go p names (Erased _) = "ERASED"
 data Val : Type
 
 
@@ -276,6 +279,7 @@ data Val : Type where
   VLet : FC -> Name -> Val -> Val -> Val
   VLetRec : FC -> Name -> Val -> Val -> Val
   VU : FC -> Val
+  VErased : FC -> Val
   VLit : FC -> Literal -> Val
 
 public export
@@ -287,6 +291,7 @@ getValFC (VMeta fc _ _) = fc
 getValFC (VLam fc _ _) = fc
 getValFC (VPi fc _ _ _ a b) = fc
 getValFC (VU fc) = fc
+getValFC (VErased fc) = fc
 getValFC (VLit fc _) = fc
 getValFC (VLet fc _ _ _) = fc
 getValFC (VLetRec fc _ _ _) = fc
@@ -312,6 +317,7 @@ Show Val where
   show (VLit _ lit) = show lit
   show (VLet _ nm a b) = "(%let \{show nm} = \{show a} in \{show b}"
   show (VLetRec _ nm a b) = "(%letrec \{show nm} = \{show a} in \{show b}"
+  show (VErased _) = "ERASED"
 
 public export
 Env : Type
@@ -521,7 +527,7 @@ freshMeta ctx fc ty kind = do
   mc <- readIORef top.metas
   debug "fresh meta \{show mc.next} : \{show ty}"
   writeIORef top.metas $ { next $= S, metas $= (Unsolved fc mc.next ctx ty kind [] ::) } mc
-  pure $ applyBDs 0 (Meta emptyFC mc.next) ctx.bds
+  pure $ applyBDs 0 (Meta fc mc.next) ctx.bds
   where
     -- hope I got the right order here :)
     applyBDs : Nat -> Tm -> Vect k BD -> Tm