Newt in Newt compiles (but does not run)

done/Data/List1.newt

@@ -8,3 +8,20 @@ record List1 a where
   constructor _:::_
   head1 : a
   tail1 : List a
+
+split1 : String → String → List1 String
+split1 str by = case split str by of
+  Nil => str ::: Nil
+  x :: xs => x ::: xs
+
+unsnoc : ∀ a. List1 a → List a × a
+unsnoc {a} (x ::: xs) = go x xs
+  where
+    go : a → List a → List a × a
+    go x Nil = (Nil, x)
+    go x (y :: ys) = let (as, a) = go y ys in (x :: as, a)
+
+splitFileName : String → String × String
+splitFileName fn = case split1 fn "." of
+    part ::: Nil => (part, "")
+    xs => mapFst (joinBy ".") $ unsnoc xs

done/Data/SortedMap.newt

@@ -200,3 +200,6 @@ foldMap f m Nil = m
 foldMap f m ((a,b) :: xs) = case lookupMap a m of
   Nothing => foldMap f (updateMap a b m) xs
   Just (_, b') => foldMap f (updateMap a (f b' b) m) xs
+
+listValues : ∀ k v. SortedMap k v → List v
+listValues sm = map snd $ toList sm

done/Lib/Compile.newt

@@ -0,0 +1,361 @@
+-- TODO Audit how much "outside" stuff could pile up in the continuation.
+module Lib.Compile
+
+import Lib.Types
+import Lib.Prettier
+import Lib.CompileExp
+import Lib.TopContext
+import Data.String
+import Data.Maybe
+import Data.Int
+
+data StKind = Plain | Return | Assign String
+
+JSStmt : StKind -> U
+JSExp : U
+
+data JAlt : U where
+  JConAlt : ∀ e. String -> JSStmt e -> JAlt
+  JDefAlt : ∀ e. JSStmt e -> JAlt
+  JLitAlt : ∀ e. JSExp -> JSStmt e -> JAlt
+
+data JSExp : U where
+  LitArray : List JSExp -> JSExp
+  LitObject : List (String × JSExp) -> JSExp
+  LitString : String -> JSExp
+  LitInt : Int -> JSExp
+  Apply : JSExp -> List JSExp -> JSExp
+  Var : String -> JSExp
+  JLam : List String -> JSStmt Return -> JSExp
+  JUndefined : JSExp
+  Index : JSExp -> JSExp -> JSExp
+  Dot : JSExp -> String -> JSExp
+
+data JSStmt : StKind -> U where
+  -- Maybe make this a snoc...
+  JSnoc : ∀ a. JSStmt Plain -> JSStmt a -> JSStmt a
+  JPlain : JSExp -> JSStmt Plain
+  JConst : (nm : String) -> JSExp -> JSStmt Plain
+  JReturn : JSExp -> JSStmt Return
+  JLet : (nm : String) -> JSStmt (Assign nm) -> JSStmt Plain  -- need somebody to assign
+  JAssign : (nm : String) -> JSExp -> JSStmt (Assign nm)
+  -- TODO - switch to Int tags
+  -- FIXME add e to JAlt (or just drop it?)
+  JCase : ∀ a. JSExp -> List JAlt -> JSStmt a
+  -- throw can't be used
+  JError : ∀ a. String -> JSStmt a
+
+Cont : StKind → U
+Cont e = JSExp -> JSStmt e
+
+-- JSEnv contains `Var` for binders or `Dot` for destructured data. It
+-- used to translate binders
+record JSEnv where
+  constructor MkEnv
+  jsenv : List JSExp
+  depth : Int
+
+-- this was like this, are we not using depth?
+push : JSEnv -> JSExp -> JSEnv
+push (MkEnv env depth) exp = MkEnv (exp :: env) depth
+
+emptyJSEnv : JSEnv
+emptyJSEnv = MkEnv Nil 0
+
+litToJS : Literal -> JSExp
+litToJS (LString str) = LitString str
+litToJS (LChar c) = LitString $ pack (c :: Nil)
+litToJS (LInt i) = LitInt i
+
+-- Stuff nm.h1, nm.h2, ... into environment
+-- TODO consider JSExp instead of nm, so we can have $foo.h1 instead of assigning a sc.
+mkEnv : String -> Int -> JSEnv -> List String -> JSEnv
+mkEnv nm k env Nil = env
+mkEnv nm k env (x :: xs) = mkEnv nm (1 + k) (push env (Dot (Var nm) "h\{show k}")) xs
+
+envNames : Env -> List String
+
+-- given a name, find a similar one that doesn't shadow in Env
+freshName : String -> JSEnv -> String
+freshName nm env = if free env.jsenv nm then nm else go nm 1
+  where
+    free : List JSExp -> String -> Bool
+    free Nil nm = True
+    free (Var n :: xs) nm = if n == nm then False else free xs nm
+    free (_ :: xs) nm = free xs nm
+
+    go : String -> Int -> String
+    go nm k = let nm' = "\{nm}\{show k}" in if free env.jsenv nm' then nm' else go nm (1 + k)
+
+freshName' : String -> JSEnv -> (String × JSEnv)
+freshName' nm env =
+  let nm' = freshName nm env -- "\{nm}$\{show $ length env}"
+      env' = push env (Var nm')
+  in (nm', env')
+
+freshNames : List String -> JSEnv -> (List String × JSEnv)
+freshNames nms env = go nms env Lin
+  where
+    go : List Name -> JSEnv -> SnocList Name -> (List String × JSEnv)
+    go Nil env acc = (acc <>> Nil, env)
+    go (n :: ns) env acc =
+      let (n', env') = freshName' n env
+      in go ns env' (acc :< n')
+
+-- This is inspired by A-normalization, look into the continuation monad
+-- There is an index on JSStmt, adopted from Stefan Hoeck's code.
+--
+-- Here we turn a Term into a statement (which may be a sequence of statements), there
+-- is a continuation, which turns the final JSExpr into a JSStmt, and the function returns
+-- a JSStmt, wrapping recursive calls in JSnoc if necessary.
+termToJS : ∀ e. JSEnv -> CExp -> Cont e -> JSStmt e
+termToJS env (CBnd k) f = case getAt (cast k) env.jsenv of
+  (Just e) => f e
+  Nothing => fatalError "Bad bounds"
+termToJS env CErased f = f JUndefined
+termToJS env (CLam nm t) f =
+  let (nm',env') = freshName' nm env -- "\{nm}$\{show $ length env}"
+  in f $ JLam (nm' :: Nil) (termToJS env' t JReturn)
+termToJS env (CFun nms t) f =
+  let (nms', env') = freshNames nms env
+  in f $ JLam nms' (termToJS env' t JReturn)
+termToJS env (CRef nm) f = f $ Var nm
+termToJS env (CMeta k) f = f $ LitString "META \{show k}"
+termToJS env (CLit lit) f = f (litToJS lit)
+-- if it's a var, just use the original
+termToJS env (CLet nm (CBnd k) u) f = case getAt (cast k) env.jsenv of
+  Just e  => termToJS (push env e) u f
+  Nothing => fatalError "bad bounds"
+termToJS env (CLet nm t u) f =
+  let nm' = freshName nm env
+      env' = push env (Var nm')
+  -- If it's a simple term, use const
+  in case termToJS env t (JAssign nm') of
+    (JAssign _ exp) => JSnoc (JConst nm' exp) (termToJS env' u f)
+    t' => JSnoc (JLet nm' t') (termToJS env' u f)
+termToJS env (CLetRec nm t u) f =
+  let nm' = freshName nm env
+      env' = push env (Var nm')
+  -- If it's a simple term, use const
+  in case termToJS env' t (JAssign nm') of
+    (JAssign _ exp) => JSnoc (JConst nm' exp) (termToJS env' u f)
+    t' => JSnoc (JLet nm' t') (termToJS env' u f)
+
+termToJS env (CApp t args etas) f = termToJS env t (\ t' => (argsToJS t' args Lin f)) --  (f (Apply t' args'))))
+  where
+    etaExpand : JSEnv -> Nat -> SnocList JSExp -> JSExp -> JSExp
+    etaExpand env Z args tm = Apply tm (args <>> Nil)
+    etaExpand env (S etas) args tm =
+      let nm' = freshName "eta" env
+          env' = push env (Var nm')
+       in JLam (nm' :: Nil) $ JReturn $ etaExpand (push env (Var nm')) etas (args :< Var nm') tm
+
+    argsToJS : ∀ e. JSExp -> List CExp -> SnocList JSExp -> (JSExp -> JSStmt e) -> JSStmt e
+    argsToJS tm Nil acc k = k (etaExpand env (cast etas) acc tm)
+    -- k (acc <>> Nil)
+    argsToJS tm (x :: xs) acc k = termToJS env x (\ x' => argsToJS tm xs (acc :< x') k)
+
+
+termToJS {e} env (CCase t alts) f =
+  -- need to assign the scrutinee to a variable (unless it is a var already?)
+  -- and add (Bnd -> JSExpr map)
+  -- TODO default case, let's drop the extra field.
+
+  termToJS env t $ \case
+    (Var nm) => maybeCaseStmt env nm alts
+    t' => do
+      -- TODO refactor nm to be a JSExp with Var{} or Dot{}
+      -- FIXME sc$ seemed to shadow something else, lets get this straightened out
+      -- we need freshName names that are not in env (i.e. do not play in debruijn)
+      let nm = "_sc$\{show env.depth}"
+      let env' = MkEnv env.jsenv (1 + env.depth)
+      JSnoc (JConst nm t') (maybeCaseStmt env' nm alts)
+
+  where
+    termToJSAlt : JSEnv -> String -> CAlt -> JAlt
+    termToJSAlt env nm (CConAlt name args u) = JConAlt name (termToJS (mkEnv nm 0 env args) u f)
+    -- intentionally reusing scrutinee name here
+    termToJSAlt env nm (CDefAlt u) = JDefAlt (termToJS  (env) u f)
+    termToJSAlt env nm (CLitAlt lit u) = JLitAlt (litToJS lit) (termToJS env u f)
+
+    maybeCaseStmt : JSEnv -> String -> List CAlt -> JSStmt e
+    -- If there is a single alt, assume it matched
+    maybeCaseStmt env nm ((CConAlt _ args u) :: Nil) = (termToJS (mkEnv nm 0 env args) u f)
+    maybeCaseStmt env nm alts@(CLitAlt _ _  :: _) =
+        (JCase (Var nm) (map (termToJSAlt env nm) alts))
+    maybeCaseStmt env nm alts =
+          (JCase (Dot (Var nm) "tag") (map (termToJSAlt env nm) alts))
+
+jsKeywords : List String
+jsKeywords = (
+  "break" :: "case" :: "catch" :: "continue" :: "debugger" :: "default" :: "delete" :: "do" :: "else" ::
+  "finally" :: "for" :: "function" :: "if" :: "in" :: "instanceof" :: "new" :: "return" :: "switch" ::
+  "this" :: "throw" :: "try" :: "typeof" :: "var" :: "void" :: "while" :: "with" ::
+  "class" :: "const" :: "enum" :: "export" :: "extends" :: "import" :: "super" ::
+  "implements" :: "class" :: "let" :: "package" :: "private" :: "protected" :: "public" ::
+  "static" :: "yield" ::
+  "null" :: "true" :: "false" ::
+  -- might not be a big issue with namespaces on names now.
+  "String" :: "Number" :: "Array" :: "BigInt" :: Nil)
+
+
+-- escape identifiers for js
+jsIdent : String -> Doc
+jsIdent id = if elem id jsKeywords then text ("$" ++ id) else text $ pack $ fix (unpack id)
+  where
+    fix : List Char -> List Char
+    fix Nil = Nil
+    fix (x :: xs) =
+      if isAlphaNum x || x == '_' then
+        x :: fix xs
+      -- make qualified names more readable
+      else if x == '.' then '_' :: fix xs
+      else if x == '$' then
+        '$' :: '$' :: fix xs
+      else
+        '$' :: (toHex (cast x)) ++ fix xs
+
+stmtToDoc : ∀ e. JSStmt e -> Doc
+
+
+expToDoc : JSExp -> Doc
+expToDoc (LitArray xs) = fatalError "TODO - LitArray to doc"
+expToDoc (LitObject xs) = text "{" <+> folddoc (\ a e => a ++ text ", " <+/> e) (map entry xs) <+> text "}"
+  where
+    entry : (String × JSExp) -> Doc
+    -- TODO quote if needed
+    entry (nm, exp) = jsIdent nm ++ text ":" <+> expToDoc exp
+
+expToDoc (LitString str) = text $ quoteString str
+expToDoc (LitInt i) = text $ show i
+-- TODO add precedence
+expToDoc (Apply x@(JLam _ _) xs) = text "(" ++ expToDoc x ++ text ")" ++ text "(" ++ nest 2 (commaSep (map expToDoc xs)) ++ text ")"
+expToDoc (Apply x xs) = expToDoc x ++ text "(" ++ nest 2 (commaSep (map expToDoc xs)) ++ text ")"
+expToDoc (Var nm) = jsIdent nm
+expToDoc (JLam nms (JReturn exp)) = text "(" <+> commaSep (map jsIdent nms) <+> text ") =>" <+> text "(" ++ expToDoc exp ++ text ")"
+expToDoc (JLam nms body) = text "(" <+> commaSep (map jsIdent nms) <+> text ") =>" <+> bracket "{" (stmtToDoc body) "}"
+expToDoc JUndefined = text "undefined"
+expToDoc (Index obj ix) = expToDoc obj ++ text "(" ++ expToDoc ix ++ text " :: Nil)"
+expToDoc (Dot obj nm) = expToDoc obj ++ text "." ++ jsIdent nm
+
+caseBody : ∀ e. JSStmt e -> Doc
+caseBody stmt@(JReturn x) = nest 2 (line ++ stmtToDoc stmt)
+-- caseBody {e = Return} stmt@(JCase{}) = nest 2 (line ++ stmtToDoc stmt)
+caseBody {e} stmt@(JCase _ _) = nest 2 (line ++ stmtToDoc stmt </> text "break;")
+caseBody stmt = line ++ text "{" ++ nest 2 (line ++ stmtToDoc stmt </> text "break;") </> text "}"
+
+altToDoc : JAlt -> Doc
+altToDoc (JConAlt nm stmt) = text "case" <+> text (quoteString nm) ++ text ":" ++ caseBody stmt
+altToDoc (JDefAlt stmt) = text "default" ++ text ":" ++ caseBody stmt
+altToDoc (JLitAlt a stmt) = text "case" <+> expToDoc a ++ text ":" ++ caseBody stmt
+
+stmtToDoc (JSnoc x y) = stmtToDoc x </> stmtToDoc y
+stmtToDoc (JPlain x) = expToDoc x ++ text ";"
+-- I might not need these split yet.
+stmtToDoc (JLet nm body) = text "let" <+> jsIdent nm ++ text ";" </> stmtToDoc body
+stmtToDoc (JAssign nm expr) = jsIdent nm <+> text "=" <+> expToDoc expr ++ text ";"
+stmtToDoc (JConst nm x) = text "const" <+> jsIdent nm <+> nest 2 (text "=" <+/> expToDoc x ++ text ";")
+stmtToDoc (JReturn x) = text "return" <+> expToDoc x ++ text ";"
+stmtToDoc (JError str) = text "throw new Error(" ++ text (quoteString str) ++ text ");"
+stmtToDoc (JCase sc alts) =
+  text "switch (" ++ expToDoc sc ++ text ")" <+> bracket "{" (stack $ map altToDoc alts) "}"
+
+mkArgs : Nat -> List String -> List String
+mkArgs Z acc = acc
+mkArgs (S k) acc = mkArgs k ("h\{show k}" :: acc)
+
+dcon : QName -> Nat -> Doc
+dcon qn@(QN ns nm) Z = stmtToDoc $ JConst (show qn) $ LitObject (("tag", LitString nm) :: Nil)
+dcon qn@(QN ns nm) arity =
+  let args = mkArgs arity Nil
+      obj = ("tag", LitString nm) :: map (\x => (x, Var x)) args
+  in stmtToDoc $ JConst (show qn) (JLam args (JReturn (LitObject obj)))
+
+-- use iife to turn stmts into expr
+maybeWrap : JSStmt Return -> JSExp
+maybeWrap (JReturn exp) = exp
+maybeWrap stmt = Apply (JLam Nil stmt) Nil
+
+entryToDoc : TopEntry -> M Doc
+entryToDoc (MkEntry _ name ty (Fn tm)) = do
+  debug $ \ _ => "compileFun \{render 90 $ pprint Nil tm}"
+  ct <- compileFun tm
+  let exp = maybeWrap $ termToJS emptyJSEnv ct JReturn
+  pure $ text "const" <+> jsIdent (show name) <+> text "=" <+/> expToDoc exp ++ text ";"
+entryToDoc (MkEntry _ name type Axiom) = pure $ text ""
+entryToDoc (MkEntry _ name type (TCon strs)) = pure $ dcon name (piArity type)
+entryToDoc (MkEntry _ name type (DCon arity str)) = pure $ dcon name (cast arity)
+entryToDoc (MkEntry _ name type PrimTCon) = pure $ dcon name (piArity type)
+entryToDoc (MkEntry _ name _ (PrimFn src _)) = pure $ text "const" <+> jsIdent (show name) <+> text "=" <+> text src
+
+
+process : (List QName × List Doc) -> QName -> M (List QName × List Doc)
+walkTm : Tm -> (List QName × List Doc) -> M (List QName × List Doc)
+walkAlt : (List QName × List Doc) -> CaseAlt -> M (List QName × List Doc)
+
+walkAlt acc (CaseDefault t) = walkTm t acc
+walkAlt acc (CaseCons name args t) = walkTm t acc
+walkAlt acc (CaseLit lit t) = walkTm t acc
+
+
+walkTm (Ref x nm y) acc = process acc nm
+walkTm (Lam x str _ _ t) acc = walkTm t acc
+walkTm (App x t u) acc = walkTm u acc >>= walkTm t
+walkTm (Pi x str icit y t u) acc = walkTm u acc >>= walkTm t
+walkTm (Let x str t u) acc = walkTm u acc >>= walkTm t
+walkTm (LetRec x str _ t u) acc = walkTm u acc >>=  walkTm t
+walkTm (Case x t alts) acc = foldlM walkAlt acc alts
+walkTm _ acc = pure acc
+
+-- This version (call `reverse ∘ snd <$> process "main" (Nil × Nil)`) will do dead
+-- code elimination, but the Prelude js primitives are reaching for
+-- stuff like True, False, MkUnit, fs which get eliminated
+process (done,docs) nm = do
+  let (False) = elem nm done | _ => pure (done,docs)
+  top <- get
+  case lookup nm top of
+    Nothing => error emptyFC "\{show nm} not in scope"
+    Just entry@(MkEntry _ name ty (PrimFn src used)) => do
+      (done,docs) <- foldlM assign (nm :: done, docs) used
+      edoc <- entryToDoc entry
+      pure (done, edoc :: docs)
+    Just (MkEntry _ name ty (Fn tm)) => do
+                debug $ \ _ => "compileFun \{render 90 $ pprint Nil tm}"
+                ct <- compileFun tm
+                -- If ct has zero arity and is a compount expression, this fails..
+                let exp = maybeWrap $ termToJS emptyJSEnv ct JReturn
+                let doc = text "const" <+> jsIdent (show name) <+> text "=" <+/> expToDoc exp ++ text ";"
+                (done,docs) <- walkTm tm (nm :: done, docs)
+                pure (done, doc :: docs)
+    Just entry => do
+      edoc <- entryToDoc entry
+      pure (nm :: done, edoc :: docs)
+  where
+    assign : (List QName × List Doc) -> String -> M (List QName × List Doc)
+    assign (done, docs) nm = do
+      top <- get
+      case lookupRaw nm top of
+        Nothing => pure (done, docs)
+        (Just (MkEntry fc name type def)) => do
+          let tag = QN Nil nm
+          let (False) = elem tag done | _ => pure (done,docs)
+          (done,docs) <- process (done, docs) name
+          let doc = text "const" <+> jsIdent nm <+> text "=" <+> jsIdent (show name) ++ text ";"
+          pure (tag :: done, doc :: docs)
+
+
+
+
+compile : M (List Doc)
+compile = do
+  top <- get
+  case lookupRaw "main" top of
+    Just (MkEntry fc name type def) => do
+      tmp <- snd <$> process (Nil, Nil) name
+      let exec = stmtToDoc $ JPlain $ Apply (Var $ show name) Nil
+      pure $ reverse (exec :: tmp)
+    -- If there is no main, compile everything for the benefit of the playground
+    Nothing => do
+      top <- get
+      traverse entryToDoc $ map snd $ toList top.defs
+

done/Lib/CompileExp.newt

@@ -0,0 +1,170 @@
+-- First pass of compilation
+-- - work out arities and fully apply functions / constructors (currying)
+--     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
+
+import Data.List
+
+import Lib.Types -- Name / Tm
+import Lib.TopContext
+import Lib.Prettier
+import Lib.Util
+
+
+CExp : U
+
+
+data CAlt : U where
+  CConAlt : String -> List String -> CExp -> CAlt
+  -- REVIEW keep var name?
+  CDefAlt : CExp -> CAlt
+  -- literal
+  CLitAlt : Literal -> CExp -> CAlt
+
+data CExp : U where
+  CBnd : Int -> CExp
+  CLam : Name -> CExp -> CExp
+  CFun : List Name -> 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 -> Int -> CExp
+  -- TODO make DCon/TCon app separate so we can specialize
+  -- U / Pi are compiled to type constructors
+  CCase : CExp -> List CAlt -> CExp
+  CRef : Name -> CExp
+  CMeta : Int -> CExp
+  CLit : Literal -> CExp
+  CLet : Name -> CExp -> CExp -> CExp
+  CLetRec : Name -> CExp -> CExp -> CExp
+  CErased : CExp
+
+-- I'm counting Lam in the term for arity.  This matches what I need in
+-- code gen.
+
+lamArity : Tm -> Nat
+lamArity (Lam _ _ _ _ t) = S (lamArity t)
+lamArity _ = Z
+
+
+piArity : Tm -> Nat
+piArity (Pi _ _ _ quant _ b) = S (piArity b)
+piArity _ = Z
+
+-- This is how much we want to curry at top level
+-- leading lambda Arity is used for function defs and metas
+-- TODO - figure out how this will work with erasure
+arityForName : FC -> QName -> M Nat
+arityForName fc nm = do
+  top <- get
+  case lookup nm top of
+  -- let the magic hole through for now (will generate bad JS)
+    Nothing => error fc "Name \{show nm} not in scope"
+    (Just (MkEntry _ name type Axiom)) => pure Z
+    (Just (MkEntry _ name type (TCon strs))) => pure $ piArity type
+    (Just (MkEntry _ name type (DCon k str))) => pure $ cast k
+    (Just (MkEntry _ name type (Fn t))) => pure $ lamArity t
+    (Just (MkEntry _ name type (PrimTCon))) => pure $ piArity type
+    -- Assuming a primitive can't return a function
+    (Just (MkEntry _ name type (PrimFn t used))) => pure $ piArity type
+
+
+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 Nil acc (S k) ty = pure $ CApp t (acc <>> Nil) (1 + cast k)
+  -- inserting Clam, index wrong?
+  -- CLam "eta\{show k}" !(apply t Nil (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}. Overapplied function that escaped type checking?"
+-- once we hit zero, we fold the rest
+apply t ts acc Z ty = go (CApp t (acc <>> Nil) 0) ts
+  where
+    go : CExp -> List CExp -> M CExp
+    -- drop zero arg call
+    go (CApp t Nil 0) args = go t args
+    go t Nil = pure t
+    go t (arg :: args) = go (CApp t (arg :: Nil) 0) args
+
+-- apply : CExp -> List CExp -> SnocList CExp -> Int -> M CExp
+-- -- out of args, make one up
+-- apply t Nil acc (S k) = pure $
+--   CLam "eta\{show k}" !(apply t Nil (acc :< CBnd k) k)
+-- apply t (x :: xs) acc (S k) = apply t xs (acc :< x) k
+-- apply t ts acc 0 = go (CApp t (acc <>> Nil)) ts
+--   where
+--     go : CExp -> List CExp -> M CExp
+--     -- drop zero arg call
+--     go (CApp t Nil) args = go t args
+--     go t Nil = pure t
+--     go t (arg :: args) = go (CApp t (arg :: Nil)) args
+
+compileTerm (Bnd _ k) = pure $ CBnd k
+-- need to eta expand to arity
+compileTerm t@(Ref fc nm _) = do
+  top <- get
+  let (Just (MkEntry _ _ type _)) = lookup nm top
+          | Nothing => error fc "Undefined name \{show nm}"
+  arity <- arityForName fc nm
+  apply (CRef (show nm)) Nil Lin arity type
+
+compileTerm (Meta _ k) = pure $ CRef "meta$\{show k}" -- FIXME
+compileTerm (Lam _ nm _ _ t) = CLam nm <$> compileTerm t
+compileTerm tm@(App _ _ _) = case funArgs tm of
+  (Meta _ k, args) => do
+        -- this will be undefined, should only happen for use metas
+        pure $ CApp (CRef "Meta\{show k}") Nil 0
+  (t@(Ref fc nm _), args) => do
+        args' <- traverse compileTerm args
+        arity <- arityForName fc nm
+        top <- get
+        let (Just (MkEntry _ _ type _)) = lookup nm top
+          | Nothing => error fc "Undefined name \{show nm}"
+        apply (CRef (show nm)) args' Lin arity type
+  (t, args) => do
+        debug $ \ _ => "apply other \{render 90 $ pprint Nil t}"
+        t' <- compileTerm t
+        args' <- traverse compileTerm args
+        apply t' args' Lin Z (UU emptyFC)
+        -- error (getFC t) "Don't know how to apply \{showTm t}"
+compileTerm (UU _) = pure $ CRef "U"
+compileTerm (Pi _ nm icit rig t u) = do
+  t' <- compileTerm t
+  u' <- compileTerm u
+  pure $ CApp (CRef "PiType") (t' :: u' :: Nil) 0
+compileTerm (Case _ t alts) = do
+  t' <- compileTerm t
+  alts' <- for alts $ \case
+    CaseDefault tm => CDefAlt <$> compileTerm tm
+    -- we use the base name for the tag, some primitives assume this
+    CaseCons (QN ns nm) args tm => CConAlt nm args <$> compileTerm tm
+    CaseLit lit tm => CLitAlt lit <$> compileTerm tm
+  pure $ CCase t' alts'
+compileTerm (Lit _ lit) = pure $ CLit lit
+compileTerm (Let _ nm t u) = do
+  t' <- compileTerm t
+  u' <- compileTerm u
+  pure $ CLet nm t' u'
+compileTerm (LetRec _ nm _ t u) = do
+  t' <- compileTerm t
+  u' <- compileTerm u
+  pure $ CLetRec nm t' u'
+compileTerm (Erased _) = pure CErased
+
+
+compileFun : Tm -> M CExp
+compileFun tm = go tm Lin
+  where
+    go : Tm -> SnocList String -> M CExp
+    go (Lam _ nm _ _ t) acc = go t (acc :< nm)
+    go tm Lin = compileTerm tm
+    go tm args = CFun (args <>> Nil) <$> compileTerm tm
+
+

done/Lib/Eval.newt

@@ -79,6 +79,11 @@ tryEval env (VRef fc k _ sp) = do
             val <- vappSpine vtm sp
             case val of
               VCase _ _ _ => pure Nothing
+              -- For now? There is a spot in Compile.newt that has
+              -- two applications of fresh that is getting unfolded even
+              -- though it has the same head and spine.  Possibly because it's
+              -- coming out of a let and is instantly applied
+              VLetRec _ _ _ _ _ => pure Nothing
               v => pure $ Just v)
             (\ _ => pure Nothing)
       _ => pure Nothing

done/Lib/Parser.newt

@@ -654,14 +654,14 @@ parseMod = do
   pure $ MkModule name imports decls
 
 
-data ReplCmd =
+-- data ReplCmd =
-    Def Decl
+--     Def Decl
-  | Norm Raw -- or just name?
+--   | Norm Raw -- or just name?
-  | Check Raw
+--   | Check Raw
 
 
--- Eventually I'd like immediate actions in the file, like lean, but I
+-- -- 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.
+-- -- also want to REPL to work and we can do that first.
-parseRepl : Parser ReplCmd
+-- parseRepl : Parser ReplCmd
-parseRepl = Def <$> parseDecl <|> Norm <$ keyword "#nf" <*> typeExpr
+-- parseRepl = Def <$> parseDecl <|> Norm <$ keyword "#nf" <*> typeExpr
-  <|> Check <$ keyword "#check" <*> typeExpr
+--   <|> Check <$ keyword "#check" <*> typeExpr

done/Lib/ProcessDecl.newt

@@ -0,0 +1,471 @@
+module Lib.ProcessDecl
+
+import Data.IORef
+import Data.String
+import Data.Vect
+import Data.List
+import Data.Maybe
+
+import Lib.Elab
+import Lib.Parser
+import Lib.Syntax
+import Lib.TopContext
+import Lib.Eval
+import Lib.Types
+import Lib.Util
+import Lib.Erasure
+
+dumpEnv : Context -> M String
+dumpEnv ctx =
+  unlines ∘ reverse <$> go (names ctx) 0 (reverse $ zip ctx.env ctx.types) Nil
+  where
+    isVar : Int -> Val -> Bool
+    isVar k (VVar _ k' Lin) = k == k'
+    isVar _ _ = False
+
+    go : List String -> Int -> List (Val × String × Val) -> List String -> M (List String)
+    go _ _ Nil acc = pure acc
+    go names k ((v, n, ty) :: xs) acc = if isVar k v
+      -- TODO - use Doc and add <+/> as appropriate to printing
+      then do
+        ty' <- quote ctx.lvl ty
+        go names (1 + k) xs ("  \{n} : \{render 90 $ pprint names ty'}":: acc)
+      else do
+        v' <- quote ctx.lvl v
+        ty' <- quote ctx.lvl ty
+        go names (1 + k) xs ("  \{n} = \{render 90 $ pprint names v'} : \{render 90 $ pprint names ty'}":: acc)
+
+
+logMetas : Int -> M Unit
+logMetas mstart = do
+  -- FIXME, now this isn't logged for Sig / Data.
+  top <- get
+  mc <- readIORef {M} top.metaCtx
+  let mlen = cast {Int} {Nat} $ length' mc.metas - mstart
+  ignore $ for (reverse $ take mlen mc.metas) $ \case
+    (Solved fc k soln) => do
+      -- TODO put a flag on this, vscode is getting overwhelmed and
+      -- dropping errors
+      --info fc "solve \{show k} as \{render 90 $ pprint Nil !(quote 0 soln)}"
+      pure MkUnit
+    (Unsolved fc k ctx ty User cons) => do
+      ty' <- quote ctx.lvl ty
+      let names = map fst ctx.types
+      env <- dumpEnv ctx
+      let msg = "\{env}  -----------\n  \{render 90 $ pprint names ty'}"
+      info fc "User Hole\n\{msg}"
+
+    (Unsolved fc k ctx ty kind cons) => do
+      ty' <- forceMeta ty
+      tm <- quote ctx.lvl ty'
+      -- Now that we're collecting errors, maybe we simply check at the end
+      -- TODO - log constraints?
+      -- FIXME in Combinatory, the val doesn't match environment?
+      let msg = "Unsolved meta \{show k} \{show kind} type \{render 90 $ pprint (names ctx) tm} \{show $ length' cons} constraints"
+      msgs <- for cons $ \case
+        (MkMc fc env sp val) => do
+            pure "  * (m\{show k} (\{unwords $ map show $ sp <>> Nil}) =?= \{show val}"
+      sols <- case kind of
+        AutoSolve => do
+          x <- quote ctx.lvl ty
+          ty <- eval ctx.env CBN x
+          debug $ \ _ => "AUTO ---> \{show ty}"
+          -- we want the context here too.
+          top <- get
+          -- matches <- case !(contextMatches ctx ty) of
+          --   Nil => findMatches ctx ty $ toList top.defs
+          --   xs => pure xs
+          matches <- findMatches ctx ty $ map snd $ toList top.defs
+          -- TODO try putting mc into TopContext for to see if it gives better terms
+          pure $ ("  \{show $ length' matches} Solutions: \{show matches}" :: Nil)
+          -- pure $ "  \{show $ length' matches} Solutions:" :: map (("  " ++) ∘ interpolate ∘ pprint (names ctx) ∘ fst) matches
+
+        _ => pure Nil
+      info fc $ unlines ((msg :: Nil) ++ msgs ++ sols)
+      -- addError $ E fc $ unlines ((msg :: Nil) ++ msgs ++ sols)
+
+
+-- Used for Class and Record
+getSigs : List Decl -> List (FC × String × Raw)
+getSigs Nil = Nil
+getSigs ((TypeSig _ Nil _) :: xs) = getSigs xs
+getSigs ((TypeSig fc (nm :: nms) ty) :: xs) = (fc, nm, ty) :: getSigs xs
+getSigs (_ :: xs) = getSigs xs
+
+teleToPi : Telescope -> Raw -> Raw
+teleToPi Nil end = end
+teleToPi ((info, ty) :: tele) end = RPi (getFC info) info ty (teleToPi tele end)
+
+impTele : Telescope -> Telescope
+impTele tele = map foo tele
+  where
+    foo : BindInfo × Raw → BindInfo × Raw
+    foo (BI fc nm _ _ , ty) = (BI fc nm Implicit Zero, ty)
+
+
+
+processDecl : List String -> Decl -> M Unit
+
+-- REVIEW I supposed I could have updated top here instead of the dance with the parser...
+processDecl ns  (PMixFix _ _ _ _)  = pure MkUnit
+
+processDecl ns  (TypeSig fc names tm) = do
+  putStrLn "-----"
+
+  top <- get
+  mc <- readIORef top.metaCtx
+  -- let mstart = length' mc.metas
+  for names $ \nm => do
+    let (Nothing) = lookupRaw nm top
+      | Just entry => error fc "\{show nm} is already defined at \{show entry.fc}"
+    pure MkUnit
+  ty <- check (mkCtx fc) tm (VU fc)
+  ty <- zonk top 0 Nil ty
+  putStrLn "TypeSig \{unwords names} : \{render 90 $ pprint Nil ty}"
+  for_ names $ \nm => setDef (QN ns nm) fc ty Axiom
+  -- Zoo4eg has metas in TypeSig, need to decide if I want to support leaving them unsolved here
+  -- logMetas mstart
+
+processDecl ns (PType fc nm ty) = do
+  top <- get
+  ty' <- check (mkCtx fc) (maybe (RU fc) id ty) (VU fc)
+  setDef (QN ns nm) fc ty' PrimTCon
+
+processDecl ns  (PFunc fc nm used ty src) = do
+  top <- get
+  ty <- check (mkCtx fc) ty (VU fc)
+  ty' <- nf Nil ty
+  putStrLn "pfunc \{nm} : \{render 90 $ pprint Nil ty'} = \{show src}"
+  -- TODO wire through fc?
+  for used $ \ name => case lookupRaw name top of
+    Nothing => error fc "\{name} not in scope"
+    _ => pure MkUnit
+  setDef (QN ns nm) fc ty' (PrimFn src used)
+
+processDecl ns (Def fc nm claused) = do
+  putStrLn "-----"
+  putStrLn "Def \{show nm}"
+  top <- get
+  mc <- readIORef top.metaCtx
+  let mstart = length' mc.metas
+  let (Just entry) = lookupRaw nm top
+    | Nothing => throwError $ E fc "No declaration for \{nm}"
+  let (MkEntry fc name ty Axiom) = entry
+    | _ => throwError $ E fc "\{nm} already defined at \{show entry.fc}"
+
+  putStrLn "check \{nm} at \{render 90 $ pprint Nil ty}"
+  vty <- eval Nil CBN ty
+
+  debug $ \ _ => "\{nm} vty is \{show vty}"
+
+
+  -- I can take LHS apart syntactically or elaborate it with an infer
+  claused' <- traverse (makeClause top) claused
+  tm <- buildTree (mkCtx fc) (MkProb claused' vty)
+  -- putStrLn "Ok \{render 90 $ pprint Nil tm}"
+
+  mc <- readIORef top.metaCtx
+  let mlen = length' mc.metas - mstart
+  solveAutos mstart
+  -- TODO - make nf that expands all metas and drop zonk
+  -- Day1.newt is a test case
+  -- tm' <- nf Nil tm
+  tm' <- zonk top 0 Nil tm
+  when top.verbose $ \ _ => putStrLn "NF\n\{render 80 $ pprint Nil 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 Nil tm' Nil
+  when top.verbose $ \ _ => putStrLn "ERASED\n\{render 80 $ pprint Nil tm'}"
+  debug $ \ _ => "Add def \{nm} \{render 90 $ pprint Nil tm'} : \{render 90 $ pprint Nil ty}"
+  updateDef (QN ns nm) fc ty (Fn tm')
+  -- logMetas mstart
+
+processDecl ns (DCheck fc tm ty) = do
+  putStrLn "----- DCheck"
+  top <- get
+
+  putStrLn "INFO at \{show fc}: check \{show tm} at \{show ty}"
+  ty' <- check (mkCtx fc) ty (VU fc)
+  putStrLn "  got type \{render 90 $ pprint Nil ty'}"
+  vty <- eval Nil CBN ty'
+  res <- check (mkCtx fc) tm vty
+  putStrLn "  got \{render 90 $ pprint Nil res}"
+  norm <- nf Nil res
+  putStrLn "  NF \{render 90 $ pprint Nil norm}"
+  norm <- nfv Nil res
+  putStrLn "  NFV \{render 90 $ pprint Nil norm}"
+
+processDecl ns (Class classFC nm tele decls) = do
+  -- REVIEW maybe we can leverage Record for this
+  -- a couple of catches, we don't want the dotted accessors and
+  -- the self argument should be an auto-implicit
+  putStrLn "-----"
+  putStrLn "Class \{nm}"
+  let fields = getSigs decls
+  -- We'll need names for the telescope
+  let dcName = "Mk\{nm}"
+  let tcType = teleToPi tele (RU classFC)
+  let tail = foldl mkApp (RVar classFC nm) tele
+  let dcType = teleToPi (impTele tele) $ foldr mkPi tail fields
+
+  putStrLn "tcon type \{render 90 $ pretty tcType}"
+  putStrLn "dcon type \{render 90 $ pretty dcType}"
+  let decl = Data classFC nm tcType (TypeSig classFC (dcName :: Nil) dcType :: Nil)
+  putStrLn "Decl:"
+  putStrLn $ render 90 $ pretty decl
+  processDecl ns decl
+  ignore $ for fields $ \case
+    (fc,name,ty) => do
+      let funType = teleToPi (impTele tele) $ RPi fc (BI fc "_" Auto Many) tail ty
+      let autoPat = foldl mkAutoApp (RVar classFC dcName) fields
+      let lhs = makeLHS (RVar fc name) tele
+      let lhs = RApp classFC lhs autoPat Auto
+      let decl = Def fc name ((lhs, (RVar fc name)) :: Nil)
+
+      putStrLn "\{name} : \{render 90 $ pretty funType}"
+      putStrLn "\{render 90 $ pretty decl}"
+      processDecl ns $ TypeSig fc (name :: Nil) funType
+      processDecl ns decl
+  where
+    makeLHS : Raw → Telescope → Raw
+    makeLHS acc ((BI fc' nm icit quant,  _) :: tele) = RApp fc' (makeLHS acc tele) (RVar fc' nm) Implicit
+    makeLHS acc Nil = acc
+
+    -- TODO probably should just do the fold ourselves then.
+    mkAutoApp : Raw → FC × String × Raw → Raw
+    mkAutoApp acc (fc, nm, ty) = RApp fc acc (RVar fc nm) Explicit
+
+    mkPi : FC × String × Raw → Raw → Raw
+    mkPi (fc, nm, ty) acc = RPi fc (BI fc nm Explicit Many) ty acc
+
+    mkApp : Raw → BindInfo × Raw → Raw
+    mkApp acc (BI fc nm icit _, _) = RApp fc acc (RVar fc nm) icit
+
+-- TODO - these are big, break them out into individual functions
+processDecl ns (Instance instfc ty decls) = do
+
+  putStrLn "-----"
+  putStrLn "Instance \{render 90 $ pretty ty}"
+  top <- get
+  let tyFC = getFC ty
+
+  vty <- check (mkCtx instfc) ty (VU instfc)
+  -- Here `tele` holds arguments to the instance
+  let (codomain, tele) = splitTele vty
+  -- env represents the environment of those arguments
+  let env = tenv (length tele)
+  debug $ \ _ => "codomain \{render 90 $ pprint Nil codomain}"
+  debug $ \ _ => "tele is \{show tele}"
+
+  -- ok so we need a name, a hack for now.
+  -- Maybe we need to ask the user (e.g. `instance someName : Monad Foo where`)
+  -- or use "Monad\{show $ length' defs}"
+  let instname = interpolate $ pprint Nil codomain
+  let sigDecl = TypeSig instfc (instname :: Nil) ty
+  -- This needs to be declared before processing the defs, but the defs need to be
+  -- declared before this - side effect is that a duplicate def is noted at the first
+  -- member
+  case lookupRaw instname top of
+    Just _ => pure MkUnit -- TODO check that the types match
+    Nothing => processDecl ns sigDecl
+
+  let (Just decls) = collectDecl <$> decls
+    | _ => do
+      debug $ \ _ => "Forward declaration \{show sigDecl}"
+
+  let (Ref _ tconName _, args) = funArgs codomain
+    | (tm, _) => error tyFC "\{render 90 $ pprint Nil codomain} doesn't appear to be a TCon application"
+  let (Just (MkEntry _ name type (TCon cons))) = lookup tconName top
+    | _ => error tyFC "\{show tconName} is not a type constructor"
+  let (con :: Nil) = cons
+    | _ => error tyFC "\{show tconName} has multiple constructors \{show cons}"
+  let (Just (MkEntry _ _ dcty (DCon _ _))) = lookup con top
+    | _ => error tyFC "can't find constructor \{show con}"
+  vdcty@(VPi _ nm icit rig a b) <- eval Nil CBN dcty
+    | x => error (getFC x) "dcty not Pi"
+  debug $ \ _ => "dcty \{render 90 $ pprint Nil dcty}"
+  let (_,args) = funArgs codomain
+
+  debug $ \ _ => "traverse \{show $ map showTm args}"
+  -- This is a little painful because we're reverse engineering the
+  -- individual types back out from the composite type
+  args' <- traverse (eval env CBN) args
+  debug $ \ _ => "args' is \{show args'}"
+  appty <- apply vdcty args'
+  conTele <- getFields appty env Nil
+  -- declare individual functions, collect their defs
+  defs <- for conTele $ \case
+     (MkBinder fc nm Explicit rig ty) => do
+       let ty' = foldr (\ x acc => case the Binder x of (MkBinder fc nm' icit rig ty') => Pi fc nm' icit rig ty' acc) ty tele
+       let nm' = "\{instname},\{nm}"
+       -- we're working with a Tm, so we define directly instead of processDecl
+       let (Just (Def fc name xs)) = find (\x => case the Decl x of
+        (Def y name xs) => name == nm
+        _ => False) decls
+          | _ => error instfc "no definition for \{nm}"
+
+       setDef (QN ns nm') fc ty' Axiom
+       let decl = (Def fc nm' xs)
+       putStrLn "***"
+       putStrLn "«\{nm'}» : \{render 90 $ pprint Nil ty'}"
+       putStrLn $ render 80 $ pretty decl
+       pure $ Just decl
+     _ => pure Nothing
+
+  for (mapMaybe id defs) $ \decl => do
+    -- debug because already printed above, but nice to have it near processing
+    debug $ \ _ => render 80 $ pretty decl
+    processDecl ns decl
+  let (QN _ con') = con
+  let decl = Def instfc instname ((RVar instfc instname, mkRHS instname conTele (RVar instfc con')) :: Nil)
+  putStrLn "SIGDECL"
+  putStrLn "\{render 90 $ pretty sigDecl}"
+  putStrLn $ render 80 $ pretty decl
+  processDecl ns decl
+  where
+    -- try to extract types of individual fields from the typeclass dcon
+    -- We're assuming they don't depend on each other.
+    getFields : Val -> Env -> List Binder -> M (List Binder)
+    getFields tm@(VPi fc nm Explicit rig ty sc) env bnds = do
+      bnd <- MkBinder fc nm Explicit rig <$> quote (length' env) ty
+      appsc <- sc $$ VVar fc (length' env) Lin
+      getFields appsc env (bnd :: bnds)
+    getFields tm@(VPi fc nm _ rig ty sc) env bnds = do
+      appsc <- sc $$ VVar fc (length' env) Lin
+      getFields appsc env bnds
+    getFields tm xs bnds = pure $ reverse bnds
+
+    tenv : Nat -> Env
+    tenv Z = Nil
+    tenv (S k) = (VVar emptyFC (cast k) Lin :: tenv k)
+
+    mkRHS : String -> List Binder -> Raw -> Raw
+    mkRHS instName (MkBinder fc nm Explicit rig ty :: bs) tm = mkRHS instName bs (RApp fc tm (RVar fc "\{instName},\{nm}") Explicit)
+    mkRHS instName (b :: bs) tm = mkRHS instName bs tm
+    mkRHS instName Nil tm = tm
+
+    apply : Val -> List Val -> M Val
+    apply x Nil = pure x
+    apply (VPi fc nm icit rig a b) (x :: xs) = do
+      bx <- b $$ x
+      apply bx xs
+    apply x (y :: xs) = error instfc "expected pi type \{show x}"
+
+processDecl ns (ShortData fc lhs sigs) = do
+  (nm,args) <- getArgs lhs Nil
+  let ty = foldr mkPi (RU fc) args
+  cons <- traverse (mkDecl args Nil) sigs
+  let dataDecl = Data fc nm ty cons
+  putStrLn "SHORTDATA"
+  putStrLn "\{render 90 $ pretty dataDecl}"
+  processDecl ns dataDecl
+  where
+    mkPi : FC × Name → Raw → Raw
+    mkPi (fc,n) a = RPi fc (BI fc n Explicit Zero) (RU fc) a
+
+    getArgs : Raw -> List (FC × String) -> M (String × List (FC × String))
+    getArgs (RVar fc1 nm) acc = pure (nm, acc)
+    getArgs (RApp _ t (RVar fc' nm) _) acc = getArgs t ((fc', nm) :: acc)
+    getArgs tm _ = error (getFC tm) "Expected contructor application, got: \{show tm}"
+
+    mkDecl : List (FC × Name) -> List Raw -> Raw -> M Decl
+    mkDecl args acc (RVar fc' name) = do
+      let base = foldr (\ ty acc => RPi (getFC ty) (BI (getFC ty) "_" Explicit Many) ty acc) lhs acc
+      let ty = foldr mkPi base args
+      pure $ TypeSig fc' (name :: Nil) ty
+      where
+        mkPi : FC × String → Raw → Raw
+        mkPi (fc,nm) acc = RPi fc (BI fc nm Implicit Zero) (RU fc) acc
+
+    mkDecl args acc (RApp fc' t u icit) = mkDecl args (u :: acc) t
+    mkDecl args acc tm = error (getFC tm) "Expected contructor application, got: \{show tm}"
+
+processDecl ns (Data fc nm ty cons) = do
+  putStrLn "-----"
+  putStrLn "Data \{nm}"
+  top <- get
+  mc <- readIORef top.metaCtx
+  tyty <- check (mkCtx fc) ty (VU fc)
+  case lookupRaw nm top of
+    Just (MkEntry _ name type Axiom) => do
+      tyty' <- eval Nil CBN tyty
+      type' <- eval Nil CBN type
+      unifyCatch fc (mkCtx fc) tyty' type'
+    Just (MkEntry _ name type _) => error fc "\{show nm} already declared"
+    Nothing => setDef (QN ns nm) fc tyty Axiom
+  cnames <- for cons $ \x => case x of
+      (TypeSig fc names tm) => do
+          debug $ \ _ => "check dcon \{show names} \{show tm}"
+          dty <- check (mkCtx fc) tm (VU fc)
+          debug $ \ _ => "dty \{show names} is \{render 90 $ pprint Nil dty}"
+
+          -- We only check that codomain used the right type constructor
+          -- We know it's in U because it's part of a checked Pi type
+          let (codomain, tele) = splitTele dty
+          -- for printing
+          let tnames = reverse $ map binderName tele
+          let (Ref _ hn _, args) = funArgs codomain
+            | (tm, _) => error (getFC tm) "expected \{nm} got \{render 90 $ pprint tnames tm}"
+          when (hn /= QN ns nm) $ \ _ =>
+            error (getFC codomain) "Constructor codomain is \{render 90 $ pprint tnames codomain} rather than \{nm}"
+
+          for names $ \ nm' => do
+            setDef (QN ns nm') fc dty (DCon (getArity dty) hn)
+          pure $ map (QN ns) names
+      decl => throwError $ E (getFC decl) "expected constructor declaration"
+  putStrLn "setDef \{nm}  TCon \{show $ join cnames}"
+  updateDef (QN ns nm) fc tyty (TCon (join cnames))
+  -- logMetas mstart
+  where
+    binderName : Binder → Name
+    binderName (MkBinder _ nm _ _ _) = nm
+
+    checkDeclType : Tm -> M Unit
+    checkDeclType (UU _) = pure MkUnit
+    checkDeclType (Pi _ str icit rig t u) = checkDeclType u
+    checkDeclType _ = error fc "data type doesn't return U"
+
+processDecl ns (Record recordFC nm tele cname decls) = do
+  putStrLn "-----"
+  putStrLn "Record"
+  let fields = getSigs decls
+  let dcName = fromMaybe "Mk\{show nm}" cname
+  let tcType = teleToPi tele (RU recordFC)
+  -- REVIEW - I probably want to stick the telescope in front of the fields
+  let tail = foldl (\ acc bi => case the (BindInfo × Raw) bi of (BI fc nm icit _, _) => RApp fc acc (RVar fc nm) icit) (RVar recordFC nm) tele
+  let dcType = teleToPi (impTele tele) $
+    foldr (\ x acc => case the (FC × String × Raw) x of (fc, nm, ty) =>  RPi fc (BI fc nm Explicit Many) ty acc  ) tail fields
+
+  putStrLn "tcon type \{render 90 $ pretty tcType}"
+  putStrLn "dcon type \{render 90 $ pretty dcType}"
+  let decl = Data recordFC nm tcType (TypeSig recordFC (dcName :: Nil) dcType :: Nil)
+  putStrLn "Decl:"
+  putStrLn $ render 90 $ pretty decl
+  processDecl ns decl
+  for_ fields $ \case
+    (fc,name,ty) => do
+      -- TODO dependency isn't handled yet
+      -- we'll need to replace stuff like `len` with `len self`.
+      let funType = teleToPi (impTele tele) $ RPi fc (BI fc "_" Explicit Many) tail ty
+      let autoPat = foldl (\acc x => case the (FC × String × Raw) x of (fc,nm,ty) => RApp fc acc (RVar fc nm) Explicit) (RVar recordFC dcName) fields
+
+      -- `fieldName` - consider dropping to keep namespace clean
+      -- let lhs = foldl (\acc, (BI fc' nm icit quant, _) => RApp fc' acc (RVar fc' nm) Implicit) (RVar fc name) tele
+      -- let lhs = RApp recordFC lhs autoPat Explicit
+      -- let decl = Def fc name [(lhs, (RVar fc name))]
+      -- putStrLn "\{name} : \{render 90 $ pretty funType}"
+      -- putStrLn "\{render 90 $ pretty decl}"
+      -- processDecl ns $ TypeSig fc (name :: Nil) funType
+      -- processDecl ns decl
+
+      -- `.fieldName`
+      let pname = "." ++ name
+      let lhs = foldl (\acc x => case the (BindInfo × Raw) x of (BI fc' nm icit quant, _) => RApp fc' acc (RVar fc' nm) Implicit) (RVar fc pname) tele
+      let lhs = RApp recordFC lhs autoPat Explicit
+      let pdecl = Def fc pname ((lhs, (RVar fc name)) :: Nil)
+      putStrLn "\{pname} : \{render 90 $ pretty funType}"
+      putStrLn "\{render 90 $ pretty pdecl}"
+      processDecl ns $ TypeSig fc (pname :: Nil) funType
+      processDecl ns pdecl

done/Lib/Types.newt

@@ -146,6 +146,9 @@ showCaseAlt (CaseDefault tm) = "_ => \{show tm}"
 showCaseAlt (CaseCons nm args tm) = "\{show nm} \{unwords args} => \{show tm}"
 showCaseAlt (CaseLit lit tm) = "\{show lit} => \{show tm}"
 
+instance Show CaseAlt where
+  show = showCaseAlt
+
 
 showTm : Tm -> String
 showTm = show
@@ -488,20 +491,20 @@ error fc msg = throwError $ E fc msg
 error' : ∀ a. String -> M a
 error' msg = throwError $ E emptyFC msg
 
-freshMeta : Context -> FC -> Val -> MetaKind -> M Tm
+-- freshMeta : Context -> FC -> Val -> MetaKind -> M Tm
-freshMeta ctx fc ty kind = do
+-- freshMeta ctx fc ty kind = do
-  top <- get
+--   top <- get
-  mc <- readIORef top.metaCtx
+--   mc <- readIORef top.metaCtx
-  debug $ \ _ => "fresh meta \{show mc.next} : \{show ty} (\{show kind})"
+--   debug $ \ _ => "fresh meta \{show mc.next} : \{show ty} (\{show kind})"
-  writeIORef top.metaCtx $ MC (Unsolved fc mc.next ctx ty kind Nil :: mc.metas) (1 + mc.next)
+--   writeIORef top.metaCtx $ MC (Unsolved fc mc.next ctx ty kind Nil :: mc.metas) (1 + mc.next)
-  pure $ applyBDs 0 (Meta fc mc.next) ctx.bds
+--   pure $ applyBDs 0 (Meta fc mc.next) ctx.bds
-  where
+--   where
-    -- hope I got the right order here :)
+--     -- hope I got the right order here :)
-    applyBDs : Int -> Tm -> List BD -> Tm
+--     applyBDs : Int -> Tm -> List BD -> Tm
-    applyBDs k t Nil = t
+--     applyBDs k t Nil = t
-    -- review the order here
+--     -- review the order here
-    applyBDs k t (Bound :: xs) = App emptyFC (applyBDs (1 + k) t xs) (Bnd emptyFC k)
+--     applyBDs k t (Bound :: xs) = App emptyFC (applyBDs (1 + k) t xs) (Bnd emptyFC k)
-    applyBDs k t (Defined :: xs) = applyBDs (1 + k) t xs
+--     applyBDs k t (Defined :: xs) = applyBDs (1 + k) t xs
 
 lookupMeta : Int -> M MetaEntry
 lookupMeta ix = do

done/Lib/Util.newt

@@ -11,16 +11,16 @@ funArgs tm = go tm Nil
     go t args = (t, args)
 
 data Binder : U where
-  MkBind : FC -> String -> Icit -> Quant -> Tm -> Binder
+  MkBinder : FC -> String -> Icit -> Quant -> Tm -> Binder
 
 -- I don't have a show for terms without a name list
 
 instance Show Binder where
-  show (MkBind _ nm icit quant t) = "(\{show quant}\{nm} \{show icit} : ... :: Nil)"
+  show (MkBinder _ nm icit quant t) = "(\{show quant}\{nm} \{show icit} : ... :: Nil)"
 
 splitTele : Tm -> (Tm × List Binder)
 splitTele = go Nil
   where
     go : List Binder -> Tm -> (Tm × List Binder)
-    go ts (Pi fc nm icit quant t u) = go (MkBind fc nm icit quant t :: ts) u
+    go ts (Pi fc nm icit quant t u) = go (MkBinder fc nm icit quant t :: ts) u
     go ts tm = (tm, reverse ts)

done/Main.newt

@@ -0,0 +1,234 @@
+module Main
+
+import Data.List
+import Data.List1
+import Data.String
+import Data.Vect
+import Data.IORef
+import Lib.Common
+import Lib.Compile
+import Lib.Parser
+import Lib.Elab
+import Lib.Parser.Impl
+import Lib.Prettier
+import Lib.ProcessDecl
+import Lib.Token
+import Lib.Tokenizer
+import Lib.TopContext
+import Lib.Types
+import Lib.Syntax
+import Lib.Syntax
+import Node
+-- import System
+-- import System.Directory
+-- import System.File
+-- import System.Path
+-- import Data.Buffer
+
+jsonTopContext : M Json
+jsonTopContext = do
+  top <- get
+  pure $ JsonObj (("context", JsonArray (map jsonDef $ listValues top.defs)) :: Nil)
+  where
+    jsonDef : TopEntry -> Json
+    -- There is no FC here...
+    jsonDef (MkEntry fc (QN ns name) type def) = JsonObj
+      (  ("fc", toJson fc)
+      :: ("name", toJson name)
+      :: ("type", toJson (render 80 $ pprint Nil type) )
+      :: Nil)
+
+dumpContext : TopContext -> M Unit
+dumpContext top = do
+    putStrLn "Context:"
+    go $ listValues top.defs
+    putStrLn "---"
+  where
+    go : List TopEntry -> M Unit
+    go Nil = pure MkUnit
+    go (x :: xs) = putStrLn "    \{show x}" >> go xs
+
+writeSource : String -> M Unit
+writeSource fn = do
+  docs <- compile
+  let src = unlines $
+        ( "\"use strict\";"
+        ::  "const PiType = (h0, h1) => ({ tag: \"PiType\", h0, h1 })"
+        :: Nil)
+        ++ map (render 90) docs
+  (Right _) <- liftIO {M} $ writeFile fn src
+    | Left err => exitFailure (show err)
+  -- (Right _) <- chmodRaw fn 493 | Left err => exitFailure (show err)
+  pure MkUnit
+
+
+parseDecls : String -> Operators -> TokenList -> SnocList Decl -> M (List Decl × Operators)
+parseDecls fn ops Nil acc = pure (acc <>> Nil, ops)
+parseDecls fn ops toks@(first :: _) acc =
+  case partialParse fn (sameLevel parseDecl) ops toks of
+    Left (err, toks) => do
+      putStrLn $ showError "" err
+      addError err
+      parseDecls fn ops (recover toks) acc
+    Right (decl,ops,toks) => parseDecls fn ops toks (acc :< decl)
+  where
+    recover : TokenList -> TokenList
+    recover Nil = Nil
+    -- skip to top token, but make sure there is progress
+    recover (tok :: toks) = if tok.bounds.startCol == 0 && tok.bounds /= first.bounds
+      then (tok :: toks)
+      else recover toks
+
+-- New style loader, one def at a time
+processModule : FC -> String -> List String -> QName -> M String
+processModule importFC base stk qn@(QN ns nm) = do
+  top <- get
+  -- TODO make top.loaded a List QName
+  let name = joinBy "." (snoc ns nm)
+  let (False) = elem name top.loaded | _ => pure ""
+  modify (\ top => MkTop top.defs top.metaCtx top.verbose top.errors (name :: top.loaded)top.ops)
+  let fn = (joinBy "/" (base :: ns)) ++ "/" ++ nm ++ ".newt"
+  (Right src) <- liftIO {M} $ readFile fn
+    | Left err => exitFailure "ERROR at \{show importFC}: error reading \{fn}: \{show err}"
+  let (Right toks) = tokenise fn src
+    | Left err => exitFailure (showError src err)
+
+  let (Right ((nameFC, modName), ops, toks)) = partialParse fn parseModHeader top.ops toks
+    | Left (err, toks) => exitFailure (showError src err)
+
+  putStrLn "module \{modName}"
+  let ns = split modName "."
+  let (path, modName') = unsnoc $ split1 modName "."
+  -- let bparts = split base "/"
+  let (True) = qn == QN path modName'
+    | _ => exitFailure "ERROR at \{show nameFC}: module name \{show modName} doesn't match file name \{show fn}"
+
+  let (Right (imports, ops, toks)) = partialParse fn parseImports ops toks
+    | Left (err, toks) => exitFailure (showError src err)
+
+  for_ imports $ \case
+    MkImport fc name' => do
+      let (a,b) = unsnoc $ split1 name' "."
+      let qname = QN a b
+      -- we could use `fc` if it had a filename in it
+      when (elem name' stk) $ \ _ => error emptyFC "import loop \{show name} -> \{show name'}"
+
+      processModule fc base (name :: stk) qname
+
+  top <- get
+  mc <- readIORef top.metaCtx
+  -- REVIEW suppressing unsolved and solved metas from previous files
+  -- I may want to know about (or exitFailure early on) unsolved
+  let mstart = length mc.metas
+  -- let Right (decls, ops, toks) = partialParse fn (manySame parseDecl) top.ops toks
+  --   | Left (err, toks) => exitFailure (showError src err)
+  (decls, ops) <- parseDecls fn top.ops toks Lin
+  modify (\ top => MkTop top.defs top.metaCtx top.verbose top.errors top.loaded ops)
+  putStrLn "process Decls"
+
+  traverse (tryProcessDecl ns) (collectDecl decls)
+
+  -- we don't want implict errors from half-processed functions
+  -- but suppress them all on error for simplicity.
+  errors <- readIORef top.errors
+  if stk == Nil then logMetas (cast mstart) else pure MkUnit
+  pure src
+  where
+
+    -- parseDecls :
+    -- tryParseDecl :
+    tryProcessDecl : List String -> Decl -> M Unit
+    tryProcessDecl ns decl = do
+      Left err <- tryError $ processDecl ns decl | _ => pure MkUnit
+      addError err
+
+
+baseDir : SnocList String -> SnocList String -> Either String String
+baseDir dirs Lin = Right $ joinBy "/" (dirs <>> Nil)
+baseDir (dirs :< d) (ns :< n) = if d == n
+  then baseDir dirs ns
+  else Left "module path doesn't match directory"
+baseDir Lin _ = Left "module path doesn't match directory"
+
+
+processFile : String -> M Unit
+processFile fn = do
+  putStrLn "*** Process \{fn}"
+  let parts = split1 fn "/"
+  let (dirs,file) = unsnoc parts
+  let dir = if dirs == Nil then "." else joinBy "/" dirs
+  let (name, ext) = splitFileName file
+  putStrLn "\{show dir} \{show name} \{show ext}"
+  (Right src) <- liftIO {M} $ readFile fn
+    | Left err => error (MkFC fn (0,0)) "error reading \{fn}: \{show err}"
+  let (Right toks) = tokenise fn src
+    | Left err => throwError err
+  let (Right ((nameFC, modName), _, _)) = partialParse fn parseModHeader EmptyMap toks
+    | Left (err,toks) => throwError err
+  let ns = split modName "."
+  let (path, modName') = unsnoc $ split1 modName "."
+
+  -- Any case splits after this point causes it to loop, no idea why
+
+  -- let (True) = modName' == name
+  --   | False => throwError $ E (MkFC fn (0,0)) "module name \{modName'} doesn't match \{name}"
+  -- let (Right base) = baseDir (Lin <>< dirs) (Lin <>< path)
+  --   | Left err => pure MkUnit -- exitFailure "ERROR at \{show nameFC}: \{err}"
+  -- let base = if base == "" then "." else base
+
+  -- declare internal primitives
+  processDecl ("Prim" :: Nil) (PType emptyFC "Int" Nothing)
+  processDecl ("Prim" :: Nil) (PType emptyFC "String" Nothing)
+  processDecl ("Prim" :: Nil) (PType emptyFC "Char" Nothing)
+  let base = "port" -- FIXME
+  src <- processModule emptyFC base Nil (QN path modName')
+  top <- get
+  -- -- dumpContext top
+
+  -- (Nil) <- liftIO {M} $ readIORef top.errors
+  --   | errors => do
+  --     for_ errors $ \err =>
+  --       putStrLn (showError src err)
+  --     exitFailure "Compile failed"
+  pure MkUnit
+
+
+cmdLine : List String -> M (Maybe String × List String)
+cmdLine Nil = pure (Nothing, Nil)
+cmdLine ("--top" :: args) = cmdLine args -- handled later
+cmdLine ("-v" :: args) = do
+  modify (\ top => MkTop top.defs top.metaCtx True top.errors top.loaded top.ops)
+  cmdLine args
+cmdLine ("-o" :: fn :: args) = do
+  (out, files) <- cmdLine args
+  pure ((out <|> Just fn), files)
+
+cmdLine (fn :: args) = do
+  let (True) = isSuffixOf ".newt" fn
+    | _ => error emptyFC "Bad argument \{show fn}"
+  (out, files) <- cmdLine args
+  pure $ (out, fn :: files)
+
+main' : M Unit
+main' = do
+  let (arg0 :: args) = getArgs
+    | _ => error emptyFC "error reading args"
+  (out, files) <- cmdLine args
+  traverse_ processFile files
+
+  when (elem "--top" args) $ \ _ => do
+    json <- jsonTopContext
+    putStrLn "TOP:\{renderJson json}"
+
+  case out of
+    Nothing => pure MkUnit
+    Just name => writeSource name
+
+
+main : IO Unit
+main = do
+  -- we'll need to reset for each file, etc.
+  ctx <- emptyTop
+  (Right _)  <- .runM main' ctx
+    | Left err => exitFailure "ERROR at \{show $ getFC err}: \{errorMsg err}"
+  putStrLn "done"

done/Node.newt

@@ -0,0 +1,34 @@
+module Node
+
+import Prelude
+
+pfunc fs : JSObject := `require('fs')`
+pfunc getArgs : List String := `arrayToList(String, process.argv.slice(1))`
+pfunc readFile uses (fs MkIORes Left Right) : (fn : String) -> IO (Either String String) := `(fn) => (w) => {
+  let result
+  try {
+    let content = fs.readFileSync(fn, 'utf8')
+    result = Right(undefined, undefined, content)
+  } catch (e) {
+    let err = ""+e
+    result = Left(undefined, undefined, e)
+  }
+  return MkIORes(undefined, result, w)
+}`
+
+-- I wonder if I should automatically `uses` the constructors in the types
+pfunc writeFile uses (fs MkIORes MkUnit) : String → String → IO (Either String Unit) := `(fn, content) => {
+  let result
+  try {
+    fs.writeFileSync(fn, content, 'utf8')
+    result = Right(undefined, undefined, MkUnit)
+  } catch (e) {
+      let err = ""+e
+      result = Left(undefined, undefined, e)
+  }
+  return MkIORes(undefined, result, w)
+}`
+
+-- maybe System.exit or something, like the original putStrLn msg >> exitFailure
+pfunc exitFailure : ∀ a. String → a := `(_, msg) => { throw new Error(msg) }`
+

done/Test/Parser.newt

@@ -0,0 +1,26 @@
+module Test.Parser
+
+import Prelude
+import Lib.Parser
+import Lib.Tokenizer
+import Node
+
+
+
+main : IO Unit
+main = do
+  let fn = "port/Lib/Parser.newt"
+  (Right text) <- readFile fn
+    | Left msg => putStrLn $ "ERROR: " ++ msg
+  let (Right toks) = tokenise fn text
+    | Left (E fc msg) => putStrLn msg
+    | _ => putStrLn "postpone error"
+  -- debugLog toks
+
+  let (OK a toks com ops) = runP parseMod toks False EmptyMap (MkFC fn (0,0))
+    | fail => debugLog fail
+  putStrLn "Module"
+  debugLog $ a
+  let (MkModule name imports decls) = a
+  let lines = map (render 90 ∘ pretty) decls
+  putStrLn $ joinBy "\n" lines

newt/Prelude.newt

@@ -9,7 +9,7 @@ the _ a = a
 const : ∀ a b. a → b → a
 const a b = a
 
-
+data Unit = MkUnit
 data Bool = True | False
 
 not : Bool → Bool
@@ -185,9 +185,16 @@ instance Traversable List where
   traverse f Nil = return Nil
   traverse f (x :: xs) = return _::_ <*> f x <*> traverse f xs
 
+
+traverse_ : ∀ t f a b. {{Traversable t}} {{Applicative f}} → (a → f b) → t a → f Unit
+traverse_ f xs = return (const MkUnit) <*> traverse f xs
+
 for : {t : U → U} {f : U → U} → {{Traversable t}} {{appf : Applicative f}} → {a : U} → {b : U} → t a → (a → f b) → f (t b)
 for stuff fun = traverse fun stuff
 
+for_ : {t : U → U} {f : U → U} → {{Traversable t}} {{appf : Applicative f}} → {a : U} → {b : U} → t a → (a → f b) → f Unit
+for_ stuff fun = return (const MkUnit) <*> traverse fun stuff
+
 instance Applicative Maybe where
   return a = Just a
   Nothing <*> _ = Nothing
@@ -259,7 +266,7 @@ instance Eq String where
 instance Eq Char where
   a == b = jsEq a b
 
-data Unit = MkUnit
+
 
 ptype Array : U → U
 pfunc listToArray : {a : U} -> List a -> Array a := `
@@ -749,6 +756,10 @@ ordNub {a} {{ordA}} xs = go $ qsort _<_ xs
     go (a :: b :: xs) = if a == b then go (a :: xs) else a :: go (b :: xs)
     go t = t
 
+nub : ∀ a. {{Eq a}} → List a → List a
+nub Nil = Nil
+nub (x :: xs) = if elem x xs then nub xs else x :: nub xs
+
 ite : ∀ a. Bool → a → a → a
 ite c t e = if c then t else e
 
@@ -809,6 +820,9 @@ force f = f MkUnit
 when : ∀ f. {{Applicative f}} → Bool → Lazy (f Unit) → f Unit
 when b fa = if b then force fa else return MkUnit
 
+unless : ∀ f. {{Applicative f}} → Bool → Lazy (f Unit) → f Unit
+unless b fa = when (not b) fa
+
 instance ∀ a. {{Ord a}} → Ord (List a) where
   compare Nil Nil = EQ
   compare Nil ys = LT
@@ -838,6 +852,12 @@ isDigit _ = False
 isUpper : Char → Bool
 isUpper c = let o = ord c in 64 < o && o < 91
 
+isAlphaNum : Char → Bool
+isAlphaNum c = let o = ord c in
+  64 < o && o < 91 ||
+  47 < o && o < 58 ||
+  96 < o && o < 123
+
 ignore : ∀ f a. {{Functor f}} → f a → f Unit
 ignore = map (const MkUnit)
 
@@ -849,6 +869,7 @@ instance ∀ a. {{Show a}} → Show (Maybe a) where
 -- TODO
 
 pfunc isPrefixOf uses (True False): String → String → Bool := `(pfx, s) => s.startsWith(pfx) ? True : False`
+pfunc isSuffixOf uses (True False): String → String → Bool := `(pfx, s) => s.endsWith(pfx) ? True : False`
 pfunc strIndex : String → Int → Char := `(s, ix) => s[ix]`
 
 
@@ -861,3 +882,22 @@ getAt' i xs = getAt (cast i) xs
 length' : ∀ a. List a → Int
 length' Nil = 0
 length' (x :: xs) = 1 + length' xs
+
+unlines : List String → String
+unlines lines = joinBy "\n" lines
+
+-- TODO inherit Semigroup
+class Monoid a where
+  neutral : a
+
+findIndex' : ∀ a. (a → Bool) → List a → Maybe Int
+findIndex' {a} pred xs = go xs 0
+  where
+    go : List a → Int → Maybe Int
+    go Nil ix = Nothing
+    go (x :: xs) ix = if pred x then Just ix else go xs (ix + 1)
+
+pfunc fatalError : ∀ a. String → a := `(_, msg) => { throw new Error(msg) }`
+
+foldlM : ∀ m a e. {{Monad m}} → (a → e → m a) → a → List e → m a
+foldlM f a xs = foldl (\ ma b => ma >>= flip f b) (pure a) xs

newt/SortedMap.newt

@@ -198,3 +198,6 @@ foldMap f m Nil = m
 foldMap f m ((a,b) :: xs) = case lookupMap a m of
   Nothing => foldMap f (updateMap a b m) xs
   Just (_, b') => foldMap f (updateMap a (f b' b) m) xs
+
+listValues : ∀ k v. SortedMap k v → List v
+listValues sm = map snd $ toList sm

scripts/translate.sh

@@ -18,7 +18,7 @@ find src -type f -name '*.idr' | while read -r file; do
       s/\binterface\b/class/g;
       s/import public/import/g;
       s/\[\]/Nil/g;
-      s{\[([^<].*?)\]}{"(" . (join " ::", split /,/, $1) . " :: Nil)"}ge;
+      s{\[([^<|][^()]*?)\]}{"(" . (join " ::", split /,/, $1) . " :: Nil)"}ge;
       s/\bsym\b/symbol/g;
       s/^export//g;
       s/^\s*covering//g;

src/Lib/Compile.idr

@@ -74,8 +74,8 @@ mkEnv nm k env (x :: xs) = mkEnv nm (S k) (push env (Dot (Var nm) "h\{show k}"))
 envNames : Env -> List String
 
 ||| given a name, find a similar one that doesn't shadow in Env
-fresh : String -> JSEnv -> String
+freshName : String -> JSEnv -> String
-fresh nm env = if free env.env nm then nm else go nm 1
+freshName nm env = if free env.env nm then nm else go nm 1
   where
     free : List JSExp -> String -> Bool
     free [] nm = True
@@ -85,9 +85,9 @@ fresh nm env = if free env.env nm then nm else go nm 1
     go : String -> Nat -> String
     go nm k = let nm' = "\{nm}\{show k}" in if free env.env nm' then nm' else go nm (S k)
 
-fresh' : String -> JSEnv -> (String, JSEnv)
+freshName' : String -> JSEnv -> (String, JSEnv)
-fresh' nm env =
+freshName' nm env =
-  let nm' = fresh nm env -- "\{nm}$\{show $ length env}"
+  let nm' = freshName nm env -- "\{nm}$\{show $ length env}"
       env' = push env (Var nm')
   in (nm', env')
 
@@ -97,7 +97,7 @@ freshNames nms env = go nms env [<]
     go : List Name -> JSEnv -> SnocList Name -> (List String, JSEnv)
     go Nil env acc = (acc <>> Nil, env)
     go (n :: ns) env acc =
-      let (n', env') = fresh' n env
+      let (n', env') = freshName' n env
       in go ns env' (acc :< n')
 
 -- This is inspired by A-normalization, look into the continuation monad
@@ -112,7 +112,7 @@ termToJS env (CBnd k) f = case getAt k env.env of
   Nothing => ?bad_bounds
 termToJS env CErased f = f JUndefined
 termToJS env (CLam nm t) f =
-  let (nm',env') = fresh' nm env -- "\{nm}$\{show $ length env}"
+  let (nm',env') = freshName' nm env -- "\{nm}$\{show $ length env}"
   in f $ JLam [nm'] (termToJS env' t JReturn)
 termToJS env (CFun nms t) f =
   let (nms', env') = freshNames nms env
@@ -125,14 +125,14 @@ termToJS env (CLet nm (CBnd k) u) f = case getAt k env.env of
   Just e  => termToJS (push env e) u f
   Nothing => ?bad_bounds2
 termToJS env (CLet nm t u) f =
-  let nm' = fresh nm env
+  let nm' = freshName nm env
       env' = push env (Var nm')
   -- If it's a simple term, use const
   in case termToJS env t (JAssign nm') of
     (JAssign _ exp) => JSnoc (JConst nm' exp) (termToJS env' u f)
     t' => JSnoc (JLet nm' t') (termToJS env' u f)
 termToJS env (CLetRec nm t u) f =
-  let nm' = fresh nm env
+  let nm' = freshName nm env
       env' = push env (Var nm')
   -- If it's a simple term, use const
   in case termToJS env' t (JAssign nm') of
@@ -144,7 +144,7 @@ termToJS env (CApp t args etas) f = termToJS env t (\ t' => (argsToJS t' args [<
     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
+      let nm' = freshName "eta" env
           env' = push env (Var nm')
        in JLam [nm'] $ JReturn $ etaExpand (push env (Var nm')) etas (args :< Var nm') tm
 
@@ -164,7 +164,7 @@ termToJS env (CCase t alts) f =
     t' => do
       -- TODO refactor nm to be a JSExp with Var{} or Dot{}
       -- FIXME sc$ seemed to shadow something else, lets get this straightened out
-      -- we need fresh names that are not in env (i.e. do not play in debruijn)
+      -- we need freshName names that are not in env (i.e. do not play in debruijn)
       let nm = "_sc$\{show env.depth}"
       let env' = { depth $= S } env
       JSnoc (JConst nm t') (maybeCaseStmt env' nm alts)
@@ -184,8 +184,8 @@ termToJS env (CCase t alts) f =
     maybeCaseStmt env nm alts =
           (JCase (Dot (Var nm) "tag") (map (termToJSAlt env nm) alts))
 
-keywords : List String
+jsKeywords : List String
-keywords = [
+jsKeywords = [
   "break", "case", "catch", "continue", "debugger", "default", "delete", "do", "else",
   "finally", "for", "function", "if", "in", "instanceof", "new", "return", "switch",
   "this", "throw", "try", "typeof", "var", "void", "while", "with",
@@ -199,7 +199,7 @@ keywords = [
 
 ||| escape identifiers for js
 jsIdent : String -> Doc
-jsIdent id = if elem id keywords then text ("$" ++ id) else text $ pack $ fix (unpack id)
+jsIdent id = if elem id jsKeywords then text ("$" ++ id) else text $ pack $ fix (unpack id)
   where
     fix : List Char -> List Char
     fix [] = []

src/Lib/Elab.idr

@@ -320,21 +320,24 @@ invert lvl sp = go sp []
 -- we have to "lift" the renaming when we go under a lambda
 -- I think that essentially means our domain ix are one bigger, since we're looking at lvl
 -- in the codomain, so maybe we can just keep that value
-rename : Nat -> List Nat -> Nat -> Val  -> M Tm
-rename meta ren lvl v = go ren lvl v
-  where
-    go : List Nat -> Nat -> Val  -> M Tm
-    goSpine : List Nat -> Nat -> Tm -> SnocList Val  -> M Tm
-    goSpine ren lvl tm [<] = pure tm
-    goSpine ren lvl tm (xs :< x) = do
-      xtm <- go ren lvl x
-      pure $ App emptyFC !(goSpine ren lvl tm xs) xtm
 
-    go ren lvl (VVar fc k sp) = case findIndex (== k) ren of
+
+rename : Nat -> List Nat -> Nat -> Val  -> M Tm
+
+renameSpine : Nat -> List Nat -> Nat -> Tm -> SnocList Val  -> M Tm
+renameSpine meta ren lvl tm [<] = pure tm
+renameSpine meta ren lvl tm (xs :< x) = do
+  xtm <- rename meta ren lvl x
+  pure $ App emptyFC !(renameSpine meta ren lvl tm xs) xtm
+
+
+
+
+rename meta ren lvl (VVar fc k sp) = case findIndex (== k) ren of
   Nothing => error fc "scope/skolem thinger VVar \{show k} ren \{show ren}"
-      Just x => goSpine ren lvl (Bnd fc $ cast x) sp
+  Just x => renameSpine meta ren lvl (Bnd fc $ cast x) sp
-    go ren lvl (VRef fc nm def sp) = goSpine ren lvl (Ref fc nm def) sp
+rename meta ren lvl (VRef fc nm def sp) = renameSpine meta ren lvl (Ref fc nm def) sp
-    go ren lvl (VMeta fc ix sp) = do
+rename meta ren lvl (VMeta fc ix sp) = do
   -- So sometimes we have an unsolved meta in here which reference vars out of scope.
   debug "rename Meta \{show ix} spine \{show sp}"
   if ix == meta
@@ -343,22 +346,22 @@ rename meta ren lvl v = go ren lvl v
     else case !(lookupMeta ix) of
       Solved fc _ val => do
         debug "rename: \{show ix} is solved"
-            go ren lvl !(vappSpine val sp)
+        rename meta ren lvl !(vappSpine val sp)
       _ => do
         debug "rename: \{show ix} is unsolved"
-            catchError (goSpine ren lvl (Meta fc ix) sp) (\err => throwError $ Postpone fc ix (errorMsg err))
+        catchError (renameSpine meta ren lvl (Meta fc ix) sp) (\err => throwError $ Postpone fc ix (errorMsg err))
-    go ren lvl (VLam fc n icit rig t) = pure (Lam fc n icit rig !(go (lvl :: ren) (S lvl) !(t $$ VVar fc lvl [<])))
+rename meta ren lvl (VLam fc n icit rig t) = pure (Lam fc n icit rig !(rename meta (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 [<])))
+rename meta ren lvl (VPi fc n icit rig ty tm) = pure (Pi fc n icit rig !(rename meta ren lvl ty) !(rename meta (lvl :: ren) (S lvl) !(tm $$ VVar emptyFC lvl [<])))
-    go ren lvl (VU fc) = pure (UU fc)
+rename meta ren lvl (VU fc) = pure (UU fc)
-    go ren lvl (VErased fc) = pure (Erased fc)
+rename meta ren lvl (VErased fc) = pure (Erased fc)
-    -- for now, we don't do solutions with case in them.
+-- for now, we don't do solutions with case in them.
-    go ren lvl (VCase fc sc alts) = error fc "Case in solution"
+rename meta ren lvl (VCase fc sc alts) = error fc "Case in solution"
-    go ren lvl (VLit fc lit) = pure (Lit fc lit)
+rename meta ren lvl (VLit fc lit) = pure (Lit fc lit)
-    go ren lvl (VLet fc name val body) =
+rename meta ren lvl (VLet fc name val body) =
-      pure $ Let fc name !(go ren lvl val) !(go (lvl :: ren) (S lvl) body)
+  pure $ Let fc name !(rename meta ren lvl val) !(rename meta (lvl :: ren) (S lvl) body)
-    -- these probably shouldn't show up in solutions...
+-- these probably shouldn't show up in solutions...
-    go ren lvl (VLetRec fc name ty val body) =
+rename meta ren lvl (VLetRec fc name ty val body) =
-      pure $ LetRec fc name !(go ren lvl ty) !(go (lvl :: ren) (S lvl) val) !(go (lvl :: ren) (S lvl) body)
+  pure $ LetRec fc name !(rename meta ren lvl ty) !(rename meta (lvl :: ren) (S lvl) val) !(rename meta (lvl :: ren) (S lvl) body)
 
 lams : Nat -> List String -> Tm -> Tm
 lams 0 _ tm = tm
@@ -564,7 +567,7 @@ unifyCatch fc ctx ty' ty = do
         a <- quote ctx.lvl ty'
         b <- quote ctx.lvl ty
         let names = toList $ map fst ctx.types
-        let msg = "unification failure\n  failed to unify \{pprint names a}\n             with \{pprint names b}"
+        let msg = "xxunification failure\n  failed to unify \{pprint names a}\n             with \{pprint names b}"
         let msg = msg ++ "\nconstraints \{show cs.constraints}"
         throwError (E fc msg)
         -- error fc "Unification yields constraints \{show cs.constraints}"

src/Lib/Eval.idr

@@ -79,6 +79,7 @@ tryEval env (VRef fc k _ sp) = do
             val <- vappSpine vtm sp
             case val of
               VCase _ _ _ => pure Nothing
+              VLetRec _ _ _ _ _ => pure Nothing
               v => pure $ Just v)
             (\ _ => pure Nothing)
       _ => pure Nothing

src/Lib/ProcessDecl.idr

@@ -83,7 +83,7 @@ getSigs : List Decl -> List (FC, String, Raw)
 getSigs [] = []
 getSigs ((TypeSig _ [] _) :: xs) = getSigs xs
 getSigs ((TypeSig fc (nm :: nms) ty) :: xs) = (fc, nm, ty) :: getSigs xs
-getSigs (_:: xs) = getSigs xs
+getSigs (_ :: xs) = getSigs xs
 
 teleToPi : Telescope -> Raw -> Raw
 teleToPi [] end = end
@@ -272,8 +272,8 @@ processDecl ns (Instance instfc ty decls) = do
   conTele <- getFields !(apply vdcty args') env []
   -- declare individual functions, collect their defs
   defs <- for conTele $ \case
-     (MkBind fc nm Explicit rig ty) => do
+     (MkBinder fc nm Explicit rig ty) => do
-       let ty' = foldr (\(MkBind fc nm' icit rig ty'), acc => Pi fc nm' icit rig ty' acc) ty tele
+       let ty' = foldr (\(MkBinder fc nm' icit rig ty'), acc => Pi fc nm' icit rig ty' acc) ty tele
        let nm' = "\{instname},\{nm}"
        -- we're working with a Tm, so we define directly instead of processDecl
        let Just (Def fc name xs) = find (\case (Def y name xs) => name == nm; _ => False) decls
@@ -302,7 +302,7 @@ processDecl ns (Instance instfc ty decls) = do
     -- We're assuming they don't depend on each other.
     getFields : Val -> Env -> List Binder -> M (List Binder)
     getFields tm@(VPi fc nm Explicit rig ty sc) env bnds = do
-      bnd <- MkBind fc nm Explicit rig <$> quote (length env) ty
+      bnd <- MkBinder fc nm Explicit rig <$> quote (length env) ty
       getFields !(sc $$ VVar fc (length env) [<]) env (bnd :: bnds)
     getFields tm@(VPi fc nm _ rig ty sc) env bnds = getFields !(sc $$ VVar fc (length env) [<]) env bnds
     getFields tm xs bnds = pure $ reverse bnds
@@ -312,7 +312,7 @@ processDecl ns (Instance instfc ty decls) = do
     tenv (S k) = (VVar emptyFC k [<] :: tenv k)
 
     mkRHS : String -> List Binder -> Raw -> Raw
-    mkRHS instName (MkBind fc nm Explicit rig ty :: bs) tm = mkRHS instName bs (RApp fc tm (RVar fc "\{instName},\{nm}") Explicit)
+    mkRHS instName (MkBinder fc nm Explicit rig ty :: bs) tm = mkRHS instName bs (RApp fc tm (RVar fc "\{instName},\{nm}") Explicit)
     mkRHS instName (b :: bs) tm = mkRHS instName bs tm
     mkRHS instName [] tm = tm
 
@@ -364,7 +364,7 @@ processDecl ns (Data fc nm ty cons) = do
           -- We know it's in U because it's part of a checked Pi type
           let (codomain, tele) = splitTele dty
           -- for printing
-          let tnames = reverse $ map (\(MkBind _ nm _ _ _) => nm) tele
+          let tnames = reverse $ map (\(MkBinder _ nm _ _ _) => nm) tele
           let (Ref _ hn _, args) := funArgs codomain
             | (tm, _) => error (getFC tm) "expected \{nm} got \{pprint tnames tm}"
           when (hn /= QN ns nm) $

src/Lib/Util.idr

@@ -12,17 +12,17 @@ funArgs tm = go tm []
 
 public export
 data Binder : Type where
-  MkBind : FC -> String -> Icit -> Quant -> Tm -> Binder
+  MkBinder : FC -> String -> Icit -> Quant -> Tm -> Binder
 
 -- I don't have a show for terms without a name list
 export
 Show Binder where
-  show (MkBind _ nm icit quant t) = "[\{show quant}\{nm} \{show icit} : ...]"
+  show (MkBinder _ nm icit quant t) = "[\{show quant}\{nm} \{show icit} : ...]"
 
 export
 splitTele : Tm -> (Tm, List Binder)
 splitTele = go []
   where
     go : List Binder -> Tm -> (Tm, List Binder)
-    go ts (Pi fc nm icit quant t u) = go (MkBind fc nm icit quant t :: ts) u
+    go ts (Pi fc nm icit quant t u) = go (MkBinder fc nm icit quant t :: ts) u
     go ts tm = (tm, reverse ts)