move idris version to orig and newt version to src.

Development is being done on the newt version now.

src/Lib/Common.newt

@@ -1,117 +1,128 @@
 module Lib.Common
 
+import Prelude
 import Data.String
-import Data.Nat
-import Data.Maybe
-import public Data.SortedMap
+import Data.Int
+import Data.SortedMap
 
 -- l is environment size, this works for both lvl2ix and ix2lvl
-public export
-lvl2ix : Nat -> Nat -> Nat
-lvl2ix l k = minus (minus l k) 1
+
+lvl2ix : Int -> Int -> Int
+lvl2ix l k = l - k - 1
 
 hexChars : List Char
 hexChars = unpack "0123456789ABCDEF"
 
 -- export
-hexDigit : Nat -> Char
-hexDigit v = fromMaybe ' ' (getAt (mod v 16) hexChars)
+hexDigit : Int -> Char
+hexDigit v = fromMaybe ' ' (getAt (cast $ mod v 16) hexChars)
 
-export
-toHex : Nat -> List Char
-toHex 0 = []
+
+toHex : Int -> List Char
+toHex 0 = Nil
 toHex v = snoc (toHex (div v 16)) (hexDigit v)
 
-export
+
 quoteString : String -> String
-quoteString str = pack $ encode (unpack str) [< '"']
+quoteString str = pack $ encode (unpack str) (Lin :<  '"')
   where
     encode : List Char -> SnocList Char -> List Char
-    encode [] acc = acc <>> ['"']
+    encode Nil acc = acc <>> ('"' :: Nil)
     encode ('"' :: cs) acc = encode cs (acc :< '\\' :< '"')
     encode ('\n' :: cs) acc = encode cs (acc :< '\\' :< 'n')
     encode ('\\' :: cs) acc = encode cs (acc :< '\\' :< '\\')
     encode (c :: cs) acc =
-      let v : Nat = cast c in
+      let v : Int = cast c in
       if v < 32 then encode cs (acc :< '\\' :< 'u' :< hexDigit (div v 4096) :< hexDigit (div v 256) :< hexDigit (div v 16) :< hexDigit v )
       else encode cs (acc :< c)
 
-public export
-data Json : Type where
-  JsonObj : List (String, Json) -> Json
+
+data Json : U where
+  JsonObj : List (String × Json) -> Json
   JsonStr : String -> Json
   JsonBool : Bool -> Json
   JsonInt : Int -> Json
   JsonArray : List Json -> Json
 
-export
+
 renderJson : Json -> String
 renderJson (JsonObj xs) = "{" ++ joinBy "," (map renderPair xs) ++ "}"
   where
-    renderPair : (String,Json) -> String
+    renderPair : (String × Json) -> String
     renderPair (k,v) = quoteString k ++ ":" ++ renderJson v
 renderJson (JsonStr str) = quoteString str
-renderJson (JsonBool x) = ifThenElse x "true" "false"
+renderJson (JsonBool x) = ite x "true" "false"
 renderJson (JsonInt i) = cast i
 renderJson (JsonArray xs) = "[" ++ joinBy "," (map renderJson xs) ++ "]"
 
-public export
-interface ToJSON a where
+
+class ToJSON a where
   toJson : a -> Json
 
-export
-ToJSON String where
+
+instance ToJSON String where
   toJson = JsonStr
 
-export
-ToJSON Int where
+
+instance ToJSON Int where
   toJson = JsonInt
 
-public export
+
 record FC where
   constructor MkFC
   file : String
-  start : (Int,Int)
+  start : (Int × Int)
 
-export
-ToJSON FC where
+
+instance ToJSON FC where
   toJson (MkFC file (line,col)) = JsonObj (("file", toJson file) :: ("line", toJson line) :: ("col", toJson col) :: Nil)
 
-export
+
 fcLine : FC -> Int
 fcLine (MkFC file (l, c)) = l
 
-export
+
 fcCol : FC -> Int
 fcCol (MkFC file (l, c)) = c
 
-public export
-interface HasFC a where
+
+class HasFC a where
   getFC : a -> FC
 
-%name FC fc
 
-export
+
+
 emptyFC : FC
 emptyFC = MkFC "" (0,0)
 
 -- Error of a parse
-public export
+
+data QName : U where
+  QN : List String -> String -> QName
+
+instance Eq QName where
+  QN ns n == QN ns' n' = n == n' && ns == ns'
+
+instance Show QName where
+  show (QN Nil n) = n
+  show (QN ns n) = joinBy "." ns ++ "." ++ n
+
+instance Ord QName where
+  compare (QN ns nm) (QN ns' nm') = if ns == ns' then compare nm nm' else compare ns ns'
+
 data Error
   = E FC String
-  | Postpone FC Nat String
-%name Error err
+  | Postpone FC QName String
 
-export
-Show FC where
+instance Show FC where
   show fc = "\{fc.file}:\{show fc.start}"
 
-public export
+
 showError : String -> Error -> String
 showError src (E fc msg) = "ERROR at \{show fc}: \{msg}\n" ++ go 0 (lines src)
   where
     go : Int -> List String -> String
-    go l [] = ""
+    go l Nil = ""
     go l (x :: xs) =
       if l == fcLine fc then
         "  \{x}\n  \{replicate (cast $ fcCol fc) ' '}^\n"
@@ -120,35 +131,35 @@ showError src (E fc msg) = "ERROR at \{show fc}: \{msg}\n" ++ go 0 (lines src)
 showError src (Postpone fc ix msg) = "ERROR at \{show fc}: Postpone \{show ix} \{msg}\n" ++ go 0 (lines src)
   where
     go : Int -> List String -> String
-    go l [] = ""
+    go l Nil = ""
     go l (x :: xs) =
       if l == fcLine fc then
         "  \{x}\n  \{replicate (cast $ fcCol fc) ' '}^\n"
       else if fcLine fc - 3 < l then "  " ++ x ++ "\n" ++ go (l + 1) xs
       else go (l + 1) xs
 
-public export
+
 data Fixity = InfixL | InfixR | Infix
 
-export
-Show Fixity where
+
+instance Show Fixity where
   show InfixL = "infixl"
   show InfixR = "infixr"
   show Infix = "infix"
 
 
-public export
+
 record OpDef where
   constructor MkOp
   opname : String
   prec : Int
   fix : Fixity
   isPrefix : Bool
-  ||| rule is everything after the first part of the operator, splitting on `_`
-  ||| a normal infix operator will have a trailing `""` which will match to
-  ||| prec / prec - 1
+  -- rule is everything after the first part of the operator, splitting on `_`
+  -- a normal infix operator will have a trailing `""` which will match to
+  -- prec / prec - 1
   rule : List String
 
-public export
-Operators : Type
+
+Operators : U
 Operators = SortedMap String OpDef

src/Lib/Compile.newt

@@ -1,27 +1,30 @@
 -- TODO Audit how much "outside" stuff could pile up in the continuation.
 module Lib.Compile
 
+import Prelude
+import Lib.Common
 import Lib.Types
 import Lib.Prettier
 import Lib.CompileExp
 import Lib.TopContext
+import Lib.Erasure
 import Data.String
-import Data.Maybe
-import Data.Nat
+import Data.Int
+import Data.SortedMap
 
-data Kind = Plain | Return | Assign String
+data StKind = Plain | Return | Assign String
 
-data JSStmt : Kind -> Type
-data JSExp : Type
+JSStmt : StKind -> U
+JSExp : U
 
-data JAlt : Type where
-  JConAlt : String -> JSStmt e -> JAlt
-  JDefAlt : JSStmt e -> JAlt
-  JLitAlt : JSExp -> JSStmt e -> JAlt
+data JAlt : U where
+  JConAlt : ∀ e. String -> JSStmt e -> JAlt
+  JDefAlt : ∀ e. JSStmt e -> JAlt
+  JLitAlt : ∀ e. JSExp -> JSStmt e -> JAlt
 
-data JSExp : Type where
+data JSExp : U where
   LitArray : List JSExp -> JSExp
-  LitObject : List (String, JSExp) -> JSExp
+  LitObject : List (String × JSExp) -> JSExp
   LitString : String -> JSExp
   LitInt : Int -> JSExp
   Apply : JSExp -> List JSExp -> JSExp
@@ -31,70 +34,72 @@ data JSExp : Type where
   Index : JSExp -> JSExp -> JSExp
   Dot : JSExp -> String -> JSExp
 
-data JSStmt : Kind -> Type where
+data JSStmt : StKind -> U where
   -- Maybe make this a snoc...
-  JSnoc : JSStmt Plain -> JSStmt a -> JSStmt a
+  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 Nat tags
+  -- TODO - switch to Int tags
   -- FIXME add e to JAlt (or just drop it?)
-  JCase : JSExp -> List JAlt -> JSStmt a
+  JCase : ∀ a. JSExp -> List JAlt -> JSStmt a
   -- throw can't be used
-  JError : String -> JSStmt a
+  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
+-- JSEnv contains `Var` for binders or `Dot` for destructured data. It
+-- used to translate binders
 record JSEnv where
   constructor MkEnv
-  env : List JSExp
-  depth : Nat
+  jsenv : List JSExp
+  depth : Int
 
+-- this was like this, are we not using depth?
 push : JSEnv -> JSExp -> JSEnv
-push env exp = { env $= (exp ::) } env
+push (MkEnv env depth) exp = MkEnv (exp :: env) depth
 
-empty : JSEnv
-empty = MkEnv [] Z
+emptyJSEnv : JSEnv
+emptyJSEnv = MkEnv Nil 0
 
 litToJS : Literal -> JSExp
 litToJS (LString str) = LitString str
-litToJS (LChar c) = LitString $ cast c
+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 -> Nat -> JSEnv -> List String -> JSEnv
-mkEnv nm k env [] = env
-mkEnv nm k env (x :: xs) = mkEnv nm (S k) (push env (Dot (Var nm) "h\{show k}")) xs
+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
+-- given a name, find a similar one that doesn't shadow in Env
 freshName : String -> JSEnv -> String
-freshName nm env = if free env.env nm then nm else go nm 1
+freshName nm env = if free env.jsenv nm then nm else go nm 1
   where
     free : List JSExp -> String -> Bool
-    free [] nm = True
+    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 -> Nat -> String
-    go nm k = let nm' = "\{nm}\{show k}" in if free env.env nm' then nm' else go nm (S k)
+    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' : 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 [<]
+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 : 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
@@ -106,14 +111,14 @@ freshNames nms env = go nms env [<]
 -- 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 : JSEnv -> CExp -> Cont e -> JSStmt e
-termToJS env (CBnd k) f = case getAt k env.env of
+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 => ?bad_bounds
+  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'] (termToJS env' t JReturn)
+  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)
@@ -121,9 +126,9 @@ 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 k env.env of
+termToJS env (CLet nm (CBnd k) u) f = case getAt (cast k) env.jsenv of
   Just e  => termToJS (push env e) u f
-  Nothing => ?bad_bounds2
+  Nothing => fatalError "bad bounds"
 termToJS env (CLet nm t u) f =
   let nm' = freshName nm env
       env' = push env (Var nm')
@@ -139,22 +144,22 @@ 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 etas) f = termToJS env t (\ t' => (argsToJS t' args [<] f)) --  (f (Apply t' args'))))
+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 <>> [])
+    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'] $ JReturn $ etaExpand (push env (Var nm')) etas (args :< Var nm') tm
+       in JLam (nm' :: Nil) $ 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 : ∀ 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 env (CCase t alts) f =
+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.
@@ -166,7 +171,7 @@ termToJS env (CCase t alts) f =
       -- 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' = { depth $= S } env
+      let env' = MkEnv env.jsenv (1 + env.depth)
       JSnoc (JConst nm t') (maybeCaseStmt env' nm alts)
 
   where
@@ -178,31 +183,31 @@ termToJS env (CCase t alts) f =
 
     maybeCaseStmt : JSEnv -> String -> List CAlt -> JSStmt e
     -- If there is a single alt, assume it matched
-    maybeCaseStmt env nm [(CConAlt _ args u)] = (termToJS (mkEnv nm 0 env args) u f)
+    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", "interface", "let", "package", "private", "protected", "public",
-  "static", "yield",
-  "null", "true", "false",
+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"
-]
+  "String" :: "Number" :: "Array" :: "BigInt" :: Nil)
 
-||| escape identifiers for js
+
+-- 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 [] = []
+    fix Nil = Nil
     fix (x :: xs) =
       if isAlphaNum x || x == '_' then
         x :: fix xs
@@ -213,33 +218,33 @@ jsIdent id = if elem id jsKeywords then text ("$" ++ id) else text $ pack $ fix
       else
         '$' :: (toHex (cast x)) ++ fix xs
 
-stmtToDoc : JSStmt e -> Doc
+stmtToDoc : ∀ e. JSStmt e -> Doc
 
 
 expToDoc : JSExp -> Doc
-expToDoc (LitArray xs) = ?expToDoc_rhs_0
-expToDoc (LitObject xs) = text "{" <+> folddoc (\ a, e => a ++ text ", " <+/> e) (map entry xs) <+> text "}"
+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
+    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@(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 "null"
-expToDoc (Index obj ix) = expToDoc obj ++ text "[" ++ expToDoc ix ++ text "]"
+expToDoc (Index obj ix) = expToDoc obj ++ text "(" ++ expToDoc ix ++ text " :: Nil)"
 expToDoc (Dot obj nm) = expToDoc obj ++ text "." ++ jsIdent nm
 
-caseBody : JSStmt e -> Doc
+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 {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
@@ -263,87 +268,102 @@ 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)]
+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 []
-      obj := ("tag", LitString nm) :: map (\x => (x, Var x)) args
+  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 [] stmt) []
+maybeWrap stmt = Apply (JLam Nil stmt) Nil
 
-entryToDoc : TopEntry -> M Doc
-entryToDoc (MkEntry _ name ty (Fn tm)) = do
-  debug "compileFun \{pprint [] tm}"
-  ct <- compileFun tm
-  let exp = maybeWrap $ termToJS empty ct JReturn
+-- convert a Def to a Doc (compile to javascript)
+defToDoc : QName → Def → M Doc
+defToDoc name (Fn tm) = do
+  debug $ \ _ => "compileFun \{render 90 $ pprint Nil tm}"
+  tm' <- erase Nil tm Nil
+  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 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
+defToDoc name Axiom = pure $ text ""
+defToDoc name (DCon arity str) = pure $ dcon name (cast arity)
+defToDoc name (TCon arity strs) = pure $ dcon name (cast arity)
+defToDoc name (PrimTCon arity) = pure $ dcon name (cast arity)
+defToDoc name (PrimFn src _) = pure $ text "const" <+> jsIdent (show name) <+> text "=" <+> text src
 
-||| This version (call `reverse . snd <$> process "main" ([],[])`) will do dead
-||| code elimination, but the Prelude js primitives are reaching for
-||| stuff like True, False, MkUnit, fs which get eliminated
-process : (List QName, List Doc) -> QName -> M (List QName, List Doc)
-process (done,docs) nm = do
-  let False = nm `elem` done | _ => pure (done,docs)
-  top <- get
-  case TopContext.lookup nm top of
-    Nothing => error emptyFC "\{nm} not in scope"
-    Just entry@(MkEntry _ name ty (PrimFn src uses)) => do
-      (done,docs) <- foldlM assign (nm :: done, docs) uses
-      pure (done, !(entryToDoc entry) :: docs)
-    Just (MkEntry _ name ty (Fn tm)) => do
-                debug "compileFun \{pprint [] tm}"
-                ct <- compileFun tm
-                -- If ct has zero arity and is a compount expression, this fails..
-                let exp = maybeWrap $ termToJS empty 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 => pure (nm :: done, !(entryToDoc entry) :: docs)
+-- Collect the QNames used in a term
+getNames : Tm -> List QName -> List QName
+getNames (Ref x nm) acc = nm :: acc
+getNames (Lam x str _ _ t) acc = getNames t acc
+getNames (App x t u) acc = getNames u $ getNames t acc
+getNames (Pi x str icit y t u) acc = getNames u $ getNames t acc
+getNames (Let x str t u) acc = getNames u $ getNames t acc
+getNames (LetRec x str _ t u) acc = getNames u $  getNames t acc
+getNames (Case x t alts) acc = foldl getAltNames acc alts
   where
-    assign : (List QName, List Doc) -> String -> M (List QName, List Doc)
-    assign (done, docs) nm = case lookupRaw nm !get of
-      Nothing => pure (done, docs)
-      (Just (MkEntry fc name type def)) => do
-        let tag = QN [] nm
-        let False = tag `elem` 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)
+    getAltNames : List QName -> CaseAlt -> List QName
+    getAltNames acc (CaseDefault t) = getNames t acc
+    getAltNames acc (CaseCons name args t) = getNames t acc
+    getAltNames acc (CaseLit lit t) = getNames t acc
+getNames _ acc = acc
 
-    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
+-- returns a QName -> Def of in-use entries
+-- This will be what we work on for optimization passes
+getEntries : SortedMap QName Def → QName → M (SortedMap QName Def)
+getEntries acc name = do
+  top <- getTop
+  case lookup name top of
+    Nothing => do
+      putStrLn "bad name \{show name}"
+      pure acc
+    Just (MkEntry _ name type def@(Fn exp)) => case lookupMap' name acc of
+      Just _ => pure acc
+      Nothing =>
+        let acc = updateMap name def acc in
+        foldlM getEntries acc $ getNames exp Nil
+    Just (MkEntry _ name type def@(PrimFn _ used)) =>
+      let acc = updateMap name def acc in
+      foldlM getEntries acc used
+    Just entry => pure $ updateMap name entry.def 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 t !(walkTm u acc)
-    walkTm (Pi x str icit y t u) acc = walkTm t !(walkTm u acc)
-    walkTm (Let x str t u) acc = walkTm t !(walkTm u acc)
-    walkTm (LetRec x str _ t u) acc = walkTm t !(walkTm u acc)
-    walkTm (Case x t alts) acc = foldlM walkAlt acc alts
-    walkTm _ acc = pure acc
+-- sort names by dependencies
+-- In JS this is only really needed for references that don't fall
+-- under a lambda.
+sortedNames : SortedMap QName Def → QName → List QName
+sortedNames defs qn = go Nil Nil qn
+  where
+    go : List QName → List QName → QName → List QName
+    go loop acc qn =
+      -- O(n^2) it would be more efficient to drop qn from the map
+      if elem qn loop || elem qn acc then acc else
+      case lookupMap' qn defs of
+        Nothing => acc
+        Just (Fn tm) => qn :: foldl (go $ qn :: loop) acc (getNames tm Nil)
+        Just (PrimFn src used) => qn :: foldl (go $ qn :: loop) acc used
+        Just def => qn :: acc
+
+-- given a initial function, return a dependency-ordered list of javascript source
+process : QName → M (List Doc)
+process name = do
+  let wat = QN ("Prelude" :: Nil) "arrayToList"
+  entries <- getEntries EmptyMap name
+  let names = sortedNames entries name
+  for names $ \ nm => case lookupMap nm entries of
+      Nothing => error emptyFC "MISS \{show nm}"
+      Just _ => pure MkUnit
+  mapM (uncurry defToDoc) $ mapMaybe (\x => lookupMap x entries) names
 
-export
 compile : M (List Doc)
 compile = do
-  top <- get
+  top <- getTop
   case lookupRaw "main" top of
     Just (MkEntry fc name type def) => do
-      tmp <- snd <$> process ([],[]) name
-      let exec = stmtToDoc $ JPlain $ Apply (Var $ show name) []
+      tmp <- process name
+      -- tack on call to main function
+      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 $ SortedMap.toList top.defs
-
+    Nothing =>
+      -- TODO maybe dump everything if there is no main
+      error emptyFC "No main function found"

src/Lib/CompileExp.idr

@@ -1,159 +0,0 @@
-||| 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
-
-public export
-data CExp : Type
-
-public export
-data CAlt : Type where
-  CConAlt : String -> List String -> CExp -> CAlt
-  -- REVIEW keep var name?
-  CDefAlt : CExp -> CAlt
-  -- literal
-  CLitAlt : Literal -> CExp -> CAlt
-
-data CExp : Type where
-  CBnd : Nat -> 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 -> Nat -> 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 : Nat -> 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.
-export
-lamArity : Tm -> Nat
-lamArity (Lam _ _ _ _ t) = S (lamArity t)
-lamArity _ = Z
-
-export
-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 = case lookup nm !get 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 0
-  (Just (MkEntry _ name type (TCon strs))) => pure $ piArity type
-  (Just (MkEntry _ name type (DCon k str))) => pure 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 uses))) => pure $ piArity type
-
-export
-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 $ 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}. 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 [] Z) args = go t args
-    go t [] = pure t
-    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
--- apply t [] acc (S k) = pure $
---   CLam "eta\{show k}" !(apply t [] (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 <>> [])) ts
---   where
---     go : CExp -> List CExp -> M CExp
---     -- drop zero arg call
---     go (CApp t []) args = go t args
---     go t [] = pure t
---     go t (arg :: args) = go (CApp t [arg]) 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 \{nm}"
-  apply (CRef (show nm)) [] [<] !(arityForName fc nm) type
-
-compileTerm (Meta _ k) = pure $ CRef "meta$\{show k}" -- FIXME
-compileTerm (Lam _ nm _ _ t) = pure $ CLam nm !(compileTerm t)
-compileTerm tm@(App _ _ _) with (funArgs tm)
-  _ | (Meta _ k, args) = do
-        error (getFC tm) "Compiling an unsolved meta \{showTm tm}"
-        info (getFC tm) "Compiling an unsolved meta \{showTm tm}"
-        pure $ CApp (CRef "Meta\{show k}") [] Z
-  _ | (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 \{nm}"
-        apply (CRef (show nm)) args' [<] arity type
-  _ | (t, args) = do
-        debug "apply other \{pprint [] t}"
-        t' <- compileTerm t
-        args' <- traverse compileTerm args
-        apply t' args' [<] 0 (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) = pure $ CApp (CRef "PiType") [ !(compileTerm t), CLam nm !(compileTerm u)] Z
-compileTerm (Case _ t alts) = do
-  t' <- compileTerm t
-  alts' <- traverse (\case
-    CaseDefault tm => pure $ CDefAlt !(compileTerm tm)
-    -- we use the base name for the tag, some primitives assume this
-    CaseCons (QN ns nm) args tm => pure $ CConAlt nm args !(compileTerm tm)
-    CaseLit lit tm => pure $ CLitAlt lit !(compileTerm tm)) alts
-  pure $ CCase t' alts'
-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
-compileFun tm = go tm [<]
-  where
-    go : Tm -> SnocList String -> M CExp
-    go (Lam _ nm _ _ t) acc = go t (acc :< nm)
-    go tm [<] = compileTerm tm
-    go tm args = pure $ CFun (args <>> []) !(compileTerm tm)
-
-

src/Lib/CompileExp.newt

@@ -0,0 +1,155 @@
+-- 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 Prelude
+import Lib.Common
+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
+
+
+
+-- 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 <- getTop
+  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 arity strs))) => pure $ cast arity
+    (Just (MkEntry _ name type (DCon k str))) => pure $ cast k
+    (Just (MkEntry _ name type (Fn t))) => pure $ lamArity t
+    (Just (MkEntry _ name type (PrimTCon arity))) => pure $ cast arity
+    -- 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)
+-- FIXME - this should be handled by Erasure.newt
+-- We somehow hit the error below, with a Pi?
+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, got \{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
+
+compileTerm (Bnd _ k) = pure $ CBnd k
+-- need to eta expand to arity
+compileTerm t@(Ref fc nm) = do
+  top <- getTop
+  let (Just (MkEntry _ _ type _)) = lookup nm top
+          | Nothing => error fc "Undefined name \{show nm}"
+  arity <- arityForName fc nm
+  case arity of
+    -- we don't need to curry functions that take one argument
+    (S Z) => pure $ CRef (show 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
+        error (getFC tm) "Compiling an unsolved meta \{show tm}"
+        -- info (getFC tm) "Compiling an unsolved meta \{show tm}"
+        -- pure $ CApp (CRef "Meta\{show k}") Nil 0
+  (t@(Ref fc nm), args) => do
+        args' <- traverse compileTerm args
+        arity <- arityForName fc nm
+        top <- getTop
+        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' :: CLam nm 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
+
+

src/Lib/Erasure.newt

@@ -1,13 +1,13 @@
 module Lib.Erasure
 
+import Prelude
+import Lib.Common
 import Lib.Types
-import Data.Maybe
 import Data.SnocList
 import Lib.TopContext
 
-public export
-EEnv : Type
-EEnv = List (String, Quant, Maybe Tm)
+EEnv : U
+EEnv = List (String × Quant × Maybe Tm)
 
 -- TODO look into removing Nothing below, can we recover all of the types?
 -- Idris does this in `chk` for linearity checking.
@@ -15,47 +15,49 @@ EEnv = List (String, Quant, Maybe Tm)
 -- check App at type
 
 getType : Tm -> M (Maybe Tm)
-getType (Ref fc nm x) = do
-  top <- get
+getType (Ref fc nm) = do
+  top <- getTop
   case lookup nm top of
     Nothing => error fc "\{show nm} not in scope"
     (Just (MkEntry _ name type def)) => pure $ Just type
 getType tm = pure Nothing
 
-export
-erase : EEnv -> Tm -> List (FC, Tm) -> M Tm
+
+erase : EEnv -> Tm -> List (FC × Tm) -> M Tm
 
 -- App a spine using type
-eraseSpine : EEnv -> Tm -> List (FC, Tm) -> (ty : Maybe Tm) -> M Tm
-eraseSpine env tm [] _ = pure tm
+eraseSpine : EEnv -> Tm -> List (FC × Tm) -> (ty : Maybe Tm) -> M Tm
+eraseSpine env tm Nil _ = 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 []
+  u <- erase env arg Nil
   -- TODO this seems wrong, we need to subst u into b to get the type
   eraseSpine env (App fc t u) args (Just b)
 -- eraseSpine env t ((fc, arg) :: args) (Just ty) = do
---   error fc "ceci n'est pas une ∏ \{showTm ty}" -- e.g. Bnd 1
+--   -- Prelude Either and IO instance of <*> have Bnd here, possibly pattern matching
+--   -- unifying in the wrong direction? we should have something like a -> b
+--   error fc "ceci n'est pas une ∏ \{showTm ty} arg \{show arg}" -- e.g. Bnd 1
 eraseSpine env t ((fc, arg) :: args) _ = do
-  u <- erase env arg []
+  u <- erase env arg Nil
   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 (CaseDefault t) = CaseDefault <$> erase env t Nil
 doAlt env (CaseCons name args t) = do
-  top <- get
+  top <- getTop
   let (Just (MkEntry _ str type def)) = lookup name top
     | _ => error emptyFC "\{show name} dcon missing from context"
   let env' = piEnv env type args
-  CaseCons name args <$> erase env' t []
+  CaseCons name args <$> erase env' t Nil
   where
     piEnv : EEnv -> Tm -> List String -> EEnv
     piEnv env (Pi fc nm icit rig t u) (arg :: args) = piEnv ((arg, rig, Just t) :: env) u args
     piEnv env _ _ = env
 
-doAlt env (CaseLit lit t) = CaseLit lit <$> erase env t []
+doAlt env (CaseLit lit t) = CaseLit lit <$> erase env t Nil
 
 -- Check erasure and insert "Erased" value
 -- We have a solution for Erased values, so important thing here is checking.
@@ -63,34 +65,34 @@ doAlt env (CaseLit lit t) = CaseLit lit <$> erase env t []
 -- This is a little fuzzy because we don't have all of the types.
 erase env t sp = case t of
   (App fc u v) => erase env u ((fc,v) :: sp)
-  (Ref fc nm x) => do
-    top <- get
+  (Ref fc nm) => do
+    top <- getTop
     case lookup nm top of
-      Nothing => error fc "\{nm} not in scope"
+      Nothing => error fc "\{show nm} not in scope"
       (Just (MkEntry _ name type def)) => eraseSpine env t sp (Just type)
-  (Lam fc nm icit rig u) => Lam fc nm icit rig <$> erase ((nm, rig, Nothing) :: env) u []
+  (Lam fc nm icit rig u) => Lam fc nm icit rig <$> erase ((nm, rig, Nothing) :: env) u Nil
   -- 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, Just u) :: env) v []
+    u' <- erase env u Nil
+    v' <- erase ((nm, Many, Just u) :: env) v Nil
     eraseSpine env (Pi fc nm icit rig u' v') sp (Just $ UU emptyFC)
   -- 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 []
+    u' <- erase env u Nil
     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, Nothing) :: env) v []
+    u' <- erase env u Nil
+    v' <- erase ((nm, Many, Nothing) :: env) v Nil
     eraseSpine env (Let fc nm u' v') sp Nothing
   (LetRec fc nm ty u v) => do
-    u' <- erase ((nm, Many, Just ty) :: env) u []
-    v' <- erase ((nm, Many, Just ty) :: env) v []
+    u' <- erase ((nm, Many, Just ty) :: env) u Nil
+    v' <- erase ((nm, Many, Just ty) :: env) v Nil
     eraseSpine env (LetRec fc nm ty u' v') sp Nothing
   (Bnd fc k) => do
-    case getAt k env of
+    case getAt (cast k) env of
       Nothing => error fc "bad index \{show k}"
       -- This is working, but empty FC
       Just (nm, Zero, ty) => error fc "used erased value \{show nm} (FIXME FC may be wrong here)"

src/Lib/Eval.newt

@@ -1,16 +1,16 @@
 module Lib.Eval
 
+import Prelude
+import Lib.Common
+import Lib.Prettier
 import Lib.Types
 import Lib.TopContext
 
 import Data.IORef
-import Data.Fin
-import Data.List
 import Data.SnocList
-import Data.Vect
 import Data.SortedMap
 
-export
+
 eval : Env -> Mode -> Tm -> M Val
 
 -- REVIEW everything is evalutated whether it's needed or not
@@ -18,90 +18,99 @@ eval : Env -> Mode -> Tm -> M Val
 -- e.g. case is getting evaluated when passed to a function because
 -- of dependencies in pi-types, even if the dependency isn't used
 
-public export
-infixl 8 $$
 
-public export
-($$) : {auto mode : Mode} -> Closure -> Val -> M Val
-($$) {mode} (MkClosure env tm) u = eval (u :: env) mode tm
+infixl 8 _$$_
+
+
+_$$_ : Closure -> Val -> M Val
+_$$_ (MkClosure env tm) u = eval (u :: env) CBN tm
+
+
 
-export
 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 (VRef fc nm sp) u = pure $ VRef fc nm (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"
 
-export
+
 vappSpine : Val -> SnocList Val -> M Val
-vappSpine t [<] = pure t
+vappSpine t Lin = pure t
 vappSpine t (xs :< x) = do
   rest <- vappSpine t xs
   vapp rest x
 
-lookupVar : Env -> Nat -> Maybe Val
-lookupVar env k = let l = length env in
+
+
+lookupVar : Env -> Int -> Maybe Val
+lookupVar env k = let l = cast $ length env in
   if k > l
     then Nothing
-    else case getAt (lvl2ix l k) env of
+    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
-export
+-- TODO see if we can drop this after updating 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}"
+        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}"
+        debug $ \ _ =>  "lookup \{show k} is Nothing in env \{show env}"
         pure t
 unlet env x = pure x
 
-export
+-- Try applying VRef to spine, back out if it is stuck
 tryEval : Env -> Val -> M (Maybe Val)
-tryEval env (VRef fc k _ sp) = do
-  top <- get
+tryEval env (VRef fc k sp) = do
+  top <- getTop
   case lookup k top of
       Just (MkEntry _ name ty (Fn tm)) =>
         catchError (
             do
-            debug "app \{show name} to \{show sp}"
-            vtm <- eval [] CBN tm
-            debug "tm is \{render 90 $ pprint [] tm}"
+            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
+              -- 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
 tryEval _ _ = pure Nothing
 
+
 -- Force far enough to compare types
-export
+
 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
+    _ => pure (VMeta fc ix sp)
+
 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
+evalCase env mode sc@(VRef _ nm sp) (cc@(CaseCons name nms t) :: xs) = do
+  top <- getTop
   if nm == name
     then do
-      debug "ECase \{show nm} \{show sp} \{show nms} \{showTm t}"
-      go env (sp <>> []) nms
+      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
@@ -109,14 +118,14 @@ evalCase env mode sc@(VRef _ nm _ sp) (cc@(CaseCons name nms t) :: xs) = do
   where
     go : Env -> List Val -> List String -> M (Maybe Val)
     go env (arg :: args) (nm :: nms) = go (arg :: env) args nms
-    go env args [] = do
+    go env args Nil = do
       t' <- eval env mode t
-      Just <$> vappSpine t' ([<] <>< args)
-    go env [] rest = pure Nothing
+      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}"
+        debug $ \ _ =>  "lookup \{show k} is \{show tt}"
         if k' == k
           then pure Nothing
           else do
@@ -126,17 +135,24 @@ evalCase env mode sc@(VVar fc k sp) alts = case lookupVar env k of
       val <- vappSpine t sp
       evalCase env mode val alts
     Nothing => do
-        debug "lookup \{show k} is Nothing in env \{show env}"
+        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}"
+  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 [<]
+eval env mode (Ref fc x) = pure $ VRef fc x Lin
 eval env mode (App _ t u) = do
   t' <- eval env mode t
   u' <- eval env mode u
@@ -146,25 +162,25 @@ 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 [<]
         (Solved _ k t) => pure $ t
+        _ => pure $ VMeta fc i Lin
 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 (length env) [<] :: env) mode u
+  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) [<] :: env) mode t
-  u' <- eval (VVar fc (length env) [<] :: env) mode u
+  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
+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
@@ -178,11 +194,12 @@ eval env mode tm@(Case fc sc alts) = do
   vcase <- evalCase env mode sc' alts
   pure $ fromMaybe (VCase fc vsc alts) vcase
 
-export
-quote : (lvl : Nat) -> Val -> M Tm
 
-quoteSp : (lvl : Nat) -> Tm -> SnocList Val -> M Tm
-quoteSp lvl t [<] = pure t
+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
@@ -194,28 +211,28 @@ quote l (VVar fc k sp) = if k < 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
+        _ => quoteSp l (Meta fc i) sp
 quote l (VLam fc x icit rig t) = do
-  val <- t $$ VVar emptyFC l [<]
-  tm <- quote (S l) val
+  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 [<]
-  tm <- quote (S l) val
+  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 (S l) u
+  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 (S l) t
-  u' <- quote (S l) u
+  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 (VRef fc n sp) = quoteSp l (Ref fc n) sp
 quote l (VCase fc sc alts) = do
   sc' <- quote l sc
   pure $ Case fc sc' alts
@@ -223,31 +240,45 @@ 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:
-export
+-- 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)
+nf env t = eval env CBN t >>= quote (length' env)
+
 
-export
 nfv : Env -> Tm -> M Tm
-nfv env t = eval env CBV t >>= quote (length env)
+nfv env t = eval env CBV t >>= quote (length' env)
 
-export
-prvalCtx : {auto ctx : Context} -> Val -> M String
-prvalCtx v = do
+
+prvalCtx : {{ctx : Context}} -> Val -> M String
+prvalCtx {{ctx}} v = do
   tm <- quote ctx.lvl v
-  pure $ interpolate $ pprint (toList $ map fst ctx.types) tm
+  pure $ render 90 $ pprint (map fst ctx.types) tm
 
-export
-zonk : TopContext -> Nat -> Env -> Tm -> M Tm
+-- REVIEW - might be easier if we inserted the meta without a bunch of explicit App
+-- I believe Kovacs is doing that.
 
-zonkBind : TopContext -> Nat -> Env -> Tm -> M Tm
-zonkBind top l env tm = zonk top (S l) (VVar (getFC tm) l [<] :: env) tm
+-- 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 [] = t
+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
@@ -255,7 +286,7 @@ appSpine t (x :: xs) = appSpine (App (getFC t) t x) xs
 -- 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 (Ref fc1 nm) = Ref fc nm
 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
@@ -268,7 +299,7 @@ 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 : 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)
@@ -277,30 +308,30 @@ zonkApp top l env t@(Meta fc k) sp = do
   case meta of
     (Solved _ j v) => do
       sp' <- traverse (eval env CBN) sp
-      debug "zonk \{show k} -> \{show v} spine \{show sp'}"
-      foo <- vappSpine v ([<] <>< sp')
-      debug "-> result is \{show foo}"
+      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
+    _ => 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 : 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 : Nat -> Env -> List String -> Tm -> M Tm
-    go l env [] tm = zonk top l env t
-    go l env (x :: xs) tm = go (S l) (VVar (getFC tm) l [<] :: env) xs tm
+    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 []
-  (Lam fc nm icit rig u) => Lam fc nm icit rig <$> (zonk top (S l) (VVar fc l [<] :: env) u)
+  (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']
+    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
@@ -308,5 +339,5 @@ zonk top l env t = case t of
   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
+  Ref fc ix => pure $ Ref fc ix
   Erased fc => pure $ Erased fc

src/Lib/Parser.newt

@@ -1,58 +1,67 @@
 module Lib.Parser
 
-import Data.Maybe
+-- NOW Still working on this.
+
+import Prelude
+import Lib.Common
+import Data.SortedMap
 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 : Parser a -> Parser a
+parenWrap : ∀ a. Parser a -> Parser a
 parenWrap pa = do
-  sym "("
+  symbol "("
   t <- pa
-  sym ")"
+  symbol ")"
   pure t
 
-braces : Parser a -> Parser a
+braces : ∀ a. Parser a -> Parser a
 braces pa = do
-  sym "{"
+  symbol "{"
   t <- pa
-  sym "}"
+  symbol "}"
   pure t
 
-dbraces : Parser a -> Parser a
+dbraces : ∀ a. Parser a -> Parser a
 dbraces pa = do
-  sym "{{"
+  symbol "{{"
   t <- pa
-  sym "}}"
+  symbol "}}"
   pure t
 
 
-optional : Parser a -> Parser (Maybe a)
+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 (cast t))
+  pure $ RLit fc (LString t)
 
 
 -- typeExpr is term with arrows.
-export
 typeExpr : Parser Raw
-export
 term : (Parser Raw)
 
 interp : Parser Raw
-interp = token StartInterp *> term <* token EndInterp
+interp = do
+  token StartInterp
+  tm <- term
+  token EndInterp
+  pure tm
 
 
 interpString : Parser Raw
@@ -73,14 +82,14 @@ intLit : Parser Raw
 intLit = do
   fc <- getPos
   t <- token Number
-  pure $ RLit fc (LInt (cast t))
+  pure $ RLit fc (LInt (stringToInt t))
 
 
 charLit : Parser Raw
 charLit = do
   fc <- getPos
   v <- token Character
-  pure $ RLit fc (LChar $ assert_total $ strIndex v 0)
+  pure $ RLit fc (LChar $ strIndex v 0)
 
 lit : Parser Raw
 lit = intLit <|> interpString <|> stringLit <|> charLit
@@ -88,8 +97,8 @@ lit = intLit <|> interpString <|> stringLit <|> charLit
 
 
 -- helpful when we've got some / many and need FC for each
-addPos : Parser a -> Parser (FC, a)
-addPos pa = (,) <$> getPos <*> pa
+addPos : ∀ a. Parser a -> Parser (FC × a)
+addPos pa = _,_ <$> getPos <*> pa
 
 asAtom : Parser Raw
 asAtom = do
@@ -102,7 +111,9 @@ asAtom = do
 
 -- the inside of Raw
 atom : Parser Raw
-atom = RU <$> getPos <* keyword "U"
+atom = do
+  pure MkUnit
+  RU <$> getPos <* keyword "U"
     -- <|> RVar <$> getPos <*> ident
     <|> asAtom
     <|> RVar <$> getPos <*> uident
@@ -113,26 +124,26 @@ atom = RU <$> getPos <* keyword "U"
     <|> parenWrap typeExpr
 
 -- Argument to a Spine
-pArg : Parser (Icit,FC,Raw)
+pArg : Parser (Icit × FC × Raw)
 pArg = do
   fc <- getPos
-  (Explicit,fc,) <$> atom
-    <|> (Implicit,fc,) <$> braces typeExpr
-    <|> (Auto,fc,) <$> dbraces typeExpr
+  (\x => Explicit, fc, x) <$> atom
+    <|> (\x => Implicit, fc, x) <$> braces typeExpr
+    <|> (\x => Auto, fc, x) <$> dbraces typeExpr
 
-AppSpine : Type
-AppSpine = List (Icit,FC,Raw)
+AppSpine : U
+AppSpine = List (Icit × FC × Raw)
 
-pratt : Operators -> Int -> String -> Raw -> AppSpine -> Parser (Raw, AppSpine)
+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
-    [] => pure (left, [])
+    Nil => pure (left, Nil)
     ((Explicit, fc, tm@(RVar x nm)) :: rest) =>
         if nm == stop then pure (left,spine) else
-        case lookup nm ops of
+        case lookupMap' nm ops of
           Just (MkOp name p fix False rule) => if p < prec
             then pure (left, spine)
             else
@@ -144,7 +155,7 @@ pratt ops prec stop left spine = do
             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 : 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
@@ -163,9 +174,9 @@ pratt ops prec stop left spine = do
 
     -- 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 [] left spine = pure (left,spine)
-    runRule p fix stop [""] left spine = do
+    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
@@ -176,19 +187,21 @@ pratt ops prec stop left spine = do
                 _ => fail "trailing operator"
 
     runRule p fix stop (nm :: rule) left spine = do
-      let ((_,_,right)::rest) = spine | _ => fail "short"
-      (right,rest) <- pratt ops 0 nm right rest -- stop!!
-      let ((_,fc',RVar fc name) :: rest) = rest
-        | _ => fail "expected \{nm}"
+      case spine of
+        Nil => fail "short"
+        ((_, _, right) :: rest) => do
 
-      if name == nm
-          then runRule p fix stop rule (RApp (getFC left) left right Explicit) rest
-          else fail "expected \{nm}"
+          (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 : String -> Raw -> AppSpine -> Parser (Raw × AppSpine)
     runPrefix stop (RVar fc nm) spine =
-      case lookup nm ops of
+      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
@@ -204,24 +217,27 @@ parseOp = do
   ops <- getOps
   hd <- atom
   rest <- many pArg
-  (res, []) <- pratt ops 0 "" hd rest
+  (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" >> sym "(")
+-- try (keyword "let" >> symbol "(")
+
 
-export
 letExpr : Parser Raw
 letExpr = do
   keyword "let"
   alts <- startBlock $ someSame $ letAssign
   keyword' "in"
   scope <- typeExpr
-  pure $ foldl (\ acc, (n,fc,ty,v) => RLet fc n (fromMaybe (RImplicit fc) ty) v acc) scope (reverse alts)
+  pure $ foldl mkLet scope (reverse alts)
   where
-    letAssign : Parser (Name,FC,Maybe Raw,Raw)
+    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
@@ -231,15 +247,29 @@ letExpr = do
       t <- typeExpr
       pure (name,fc,ty,t)
 
-pLamArg : Parser (Icit, String, Maybe Raw)
-pLamArg = (Implicit,,) <$> braces (ident <|> uident) <*> optional (sym ":" >> typeExpr)
-       <|> (Auto,,) <$> dbraces (ident <|> uident) <*> optional (sym ":" >> typeExpr)
-       <|> (Explicit,,) <$> parenWrap (ident <|> uident) <*> optional (sym ":" >> typeExpr)
-       <|> (Explicit,,Nothing) <$> (ident <|> uident)
-       <|> (Explicit,"_",Nothing) <$ keyword "_"
+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)
 
--- lam: λ {A} {b : A} (c : Blah) d e f. something
-export
 lamExpr : Parser Raw
 lamExpr = do
   pos <- getPos
@@ -247,16 +277,21 @@ lamExpr = do
   args <- some $ addPos pLamArg
   keyword "=>"
   scope <- typeExpr
-  pure $ foldr (\(fc, icit, name, ty), sc => RLam pos (BI fc name icit Many) sc) scope args
+  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
 
-export
+
 caseExpr : Parser Raw
 caseExpr = do
   fc <- getPos
@@ -280,12 +315,12 @@ caseLet : Parser Raw
 caseLet = do
   -- look ahead so we can fall back to normal let
   fc <- getPos
-  try (keyword "let" >> sym "(")
+  try (keyword "let" >> symbol "(")
   pat <- typeExpr
-  sym ")"
+  symbol ")"
   keyword "="
   sc <- typeExpr
-  alts <- startBlock $ manySame $ sym "|" *> caseAlt
+  alts <- startBlock $ manySame $ symbol "|" *> caseAlt
   keyword "in"
   body <- term
   pure $ RCase fc sc (MkAlt pat body :: alts)
@@ -295,12 +330,12 @@ doCaseLet = do
   -- look ahead so we can fall back to normal let
   -- Maybe make it work like arrow?
   fc <- getPos
-  try (keyword "let" >> sym "(")
+  try (keyword "let" >> symbol "(")
   pat <- typeExpr
-  sym ")"
+  symbol ")"
   keyword "="
   sc <- typeExpr
-  alts <- startBlock $ manySame $ sym "|" *> caseAlt
+  alts <- startBlock $ manySame $ symbol "|" *> caseAlt
   bodyFC <- getPos
   body <- RDo <$> getPos <*> someSame doStmt
   pure $ DoExpr fc (RCase fc sc (MkAlt pat body :: alts))
@@ -312,18 +347,27 @@ doArrow = do
   (Just _) <- optional $ keyword "<-"
     | _ => pure $ DoExpr fc left
   right <- term
-  alts <- startBlock $ manySame $ sym "|" *> caseAlt
+  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 <$> getPos <* keyword "let" <*> ident <* keyword "=" <*> term
+  <|> doLet
   <|> doArrow
 
 doExpr = RDo <$> getPos <* keyword "do" <*> (startBlock $ someSame doStmt)
 
-ifThenElse : Parser Raw
-ifThenElse = do
+parseIfThen : Parser Raw
+parseIfThen = do
   fc <- getPos
   keyword "if"
   a <- term
@@ -341,17 +385,17 @@ term' =  caseExpr
     <|> caseLamExpr
     <|> lamExpr
     <|> doExpr
-    <|> ifThenElse
+    <|> parseIfThen
     -- Make this last for better error messages
     <|> parseOp
 
 term = do
   t <- term'
-  rest <- many ((,) <$> getPos <* keyword "$" <*> term')
+  rest <- many (_,_ <$> getPos <* keyword "$" <*> term')
   pure $ apply t rest
   where
-    apply : Raw -> List (FC,Raw) -> Raw
-    apply t [] = t
+    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
@@ -363,36 +407,43 @@ quantity = fromMaybe Many <$> optional (Zero <$ keyword "0")
 ebind : Parser Telescope
 ebind = do
   -- don't commit until we see the ":"
-  sym "("
+  symbol "("
   quant <- quantity
-  names <- try (some (addPos varname) <* sym ":")
+  names <- try (some (addPos varname) <* symbol ":")
   ty <- typeExpr
-  sym ")"
-  pure $ map (\(pos, name) => (BI pos name Explicit quant, ty)) names
+  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 {Nat}
-  sym "{"
+  -- 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 (sym ":" *> typeExpr)
-  sym "}"
-  pure $ map (\(pos,name) => (BI pos name Implicit quant, fromMaybe (RImplicit pos) ty)) names
+  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}}
-  sym "{{"
-  name <- optional $ try (addPos varname <* sym ":")
+  symbol "{{"
+  name <- optional $ try (addPos varname <* symbol ":")
   ty <- typeExpr
-  sym "}}"
+  symbol "}}"
   case name of
-    Just (pos,name) => pure [(BI pos name Auto Many, ty)]
-    Nothing => pure [(BI (getFC ty) "_" Auto Many, ty)]
+    Just (pos,name) => pure ((BI pos name Auto Many, ty) :: Nil)
+    Nothing => pure ((BI (getFC ty) "_" Auto Many, ty) :: Nil)
 
 arrow : Parser Unit
-arrow = sym "->" <|> sym "→"
+arrow = symbol "->" <|> symbol "→"
 
 -- Collect a bunch of binders (A : U) {y : A} -> ...
 
@@ -402,7 +453,10 @@ forAll = do
   all <- some (addPos varname)
   keyword "."
   scope <- typeExpr
-  pure $ foldr (\ (fc, n), sc => RPi fc (BI fc n Implicit Zero) (RImplicit fc) sc) scope all
+  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
@@ -411,24 +465,24 @@ binders = do
   scope <- typeExpr
   pure $ foldr mkBind scope (join binds)
   where
-    mkBind : (BindInfo, Raw) -> Raw -> Raw
+    mkBind : (BindInfo × Raw) -> Raw -> Raw
     mkBind (info, ty) scope = RPi (getFC info) info ty scope
 
 typeExpr
   = binders
   <|> forAll
-  <|> do
+  <|> (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
+          (Just scope) => pure $ RPi fc (BI fc "_" Explicit Many) exp scope)
 
 -- And top level stuff
 
-export
+
 parseSig : Parser Decl
 parseSig = TypeSig <$> getPos <*> try (some (ident <|> uident <|> token Projection) <* keyword ":") <*> typeExpr
 
@@ -451,7 +505,7 @@ parseMixfix = do
      <|> Infix <$ keyword "infix"
   prec <- token Number
   ops <- some $ token MixFix
-  for_ ops $ \ op => addOp op (cast prec) fix
+  for ops $ \ op => addOp op (cast prec) fix
   pure $ PMixFix fc ops (cast prec) fix
 
 getName : Raw -> Parser String
@@ -460,7 +514,7 @@ getName (RApp x t u icit) = getName t
 getName tm = fail "bad LHS"
 
 
-export
+
 parseDef : Parser Decl
 parseDef = do
   fc <- getPos
@@ -474,9 +528,9 @@ parseDef = do
     startBlock $ manySame $ (parseSig <|> parseDef)
   let body = maybe body (\ decls => RWhere wfc decls body) w
   -- these get collected later
-  pure $ Def fc nm [(t, body)] -- [MkClause fc [] t body]
+  pure $ Def fc nm ((t, body) :: Nil) -- (MkClause fc Nil t body :: Nil)
+
 
-export
 parsePType : Parser Decl
 parsePType = do
   fc <- getPos
@@ -492,12 +546,12 @@ parsePFunc = do
   fc <- getPos
   keyword "pfunc"
   nm <- ident
-  uses <- optional (keyword "uses" >> parenWrap (many $ uident <|> ident <|> token MixFix))
+  used <- optional (keyword "uses" >> parenWrap (many $ uident <|> ident <|> token MixFix))
   keyword ":"
   ty <- typeExpr
   keyword ":="
-  src <- cast <$> token JSLit
-  pure $ PFunc fc nm (fromMaybe [] uses) ty src
+  src <- token JSLit
+  pure $ PFunc fc nm (fromMaybe Nil used) ty src
 
 
 parseShortData : Parser Decl
@@ -509,7 +563,7 @@ parseShortData = do
   sigs <- sepBy (keyword "|") typeExpr
   pure $ ShortData fc lhs sigs
 
-export
+
 parseData : Parser Decl
 parseData = do
   fc <- getPos
@@ -523,9 +577,11 @@ parseData = do
 nakedBind : Parser Telescope
 nakedBind = do
   names <- some (addPos varname)
-  pure $ map (\(pos,name) => (BI pos name Explicit Many, RImplicit pos)) names
+  pure $ map makeBind names
+  where
+    makeBind : FC × String → (BindInfo × Raw)
+    makeBind (pos, name) = (BI pos name Explicit Many, RImplicit pos)
 
-export
 parseRecord : Parser Decl
 parseRecord = do
   fc <- getPos
@@ -538,7 +594,7 @@ parseRecord = do
   pure $ Record fc name (join teles) cname decls
 
 
-export
+
 parseClass : Parser Decl
 parseClass = do
   fc <- getPos
@@ -549,7 +605,7 @@ parseClass = do
   decls <- startBlock $ manySame $ parseSig
   pure $ Class fc name (join teles) decls
 
-export
+
 parseInstance : Parser Decl
 parseInstance = do
   fc <- getPos
@@ -566,15 +622,15 @@ parseInstance = do
 parseNorm : Parser Decl
 parseNorm = DCheck <$> getPos <* keyword "#check" <*> typeExpr <* keyword ":" <*> typeExpr
 
-export
+
 parseDecl : Parser Decl
 parseDecl = parseMixfix <|> parsePType <|> parsePFunc
   <|> parseNorm <|> parseData <|> parseShortData <|> parseSig <|> parseDef
   <|> parseClass <|> parseInstance <|> parseRecord
 
 
-export
-parseModHeader : Parser (FC, String)
+
+parseModHeader : Parser (FC × String)
 parseModHeader = do
   sameLevel (keyword "module")
   fc <- getPos
@@ -584,33 +640,30 @@ parseModHeader = do
   let name = joinBy "" (name :: rest)
   pure (fc, name)
 
-export
-parseImports : Parser (List Import)
-parseImports = manySame $ parseImport
 
-export
+parseImports : Parser (List Import)
+parseImports = manySame parseImport
+
+
 parseMod : Parser Module
 parseMod = do
-  startBlock $ do
-    keyword "module"
-    name <- uident
-    rest <- many $ token Projection
-    -- FIXME use QName
-    let name = joinBy "" (name :: rest)
-    imports <- manySame $ parseImport
-    decls <- manySame $ parseDecl
-    pure $ MkModule name imports decls
-
-public export
-data ReplCmd =
-    Def Decl
-  | Norm Raw -- or just name?
-  | Check Raw
+  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
 
 
--- 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.
-export
-parseRepl : Parser ReplCmd
-parseRepl = Def <$> parseDecl <|> Norm <$ keyword "#nf" <*> typeExpr
-  <|> Check <$ keyword "#check" <*> typeExpr
+-- 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

src/Lib/Parser/Impl.idr

@@ -1,219 +0,0 @@
-module Lib.Parser.Impl
-
-import Prelude
-import Lib.Token
-import Lib.Common
-import Data.String
-import Data.Nat
-import Data.List1
-import Data.SortedMap
-
-public export
-TokenList : Type
-TokenList = List BTok
-
--- Result of a parse
-public export
-data Result : Type -> Type where
-  OK : a -> (toks : TokenList) -> (com : Bool) -> Operators -> Result a
-  Fail : Bool -> Error -> (toks : TokenList) -> (com : Bool) -> Operators -> Result a
-
-export
-Functor Result where
-  map f (OK a toks com ops) = OK (f a) toks com ops
-  map _ (Fail fatal err toks com ops) = Fail fatal err toks com ops
-
--- So sixty just has a newtype function here now (probably for perf).
--- A record might be more ergonomic, but would require a record impl before
--- self hosting.
-
--- FC is a line and column for indents. The idea being that we check
--- either the col < tokCol or line == tokLine, enabling sameLevel.
-
--- We need State for operators (or postpone that to elaboration)
--- Since I've already built out the pratt stuff, I guess I'll
--- leave it in the parser for now
-
--- This is a Reader in FC, a State in Operators, Commit flag, TokenList
-
-export
-data Parser a = P (TokenList -> Bool -> Operators -> (lc : FC) -> Result a)
-
-export
-runP : Parser a -> TokenList -> Bool -> Operators -> FC -> Result a
-runP (P f) = f
-
--- FIXME no filename, also half the time it is pointing at the token after the error
-error : String -> TokenList -> String -> Error
-error fn [] msg = E (MkFC fn (0,0)) msg
-error fn ((MkBounded val (MkBounds line col _ _)) :: _) msg = E (MkFC fn (line,col)) msg
-
-export
-parse : String -> Parser a -> TokenList -> Either Error a
-parse fn pa toks = case runP pa toks False empty (MkFC fn (-1,-1)) of
-  Fail fatal err toks com ops => Left err
-  OK a [] _ _ => Right a
-  OK a ts _ _ => Left (error fn ts "Extra toks")
-
-||| Intended for parsing a top level declaration
-export
-partialParse : String -> Parser a -> Operators -> TokenList -> Either (Error, TokenList) (a, Operators, TokenList)
-partialParse fn pa ops toks = case runP pa toks False ops (MkFC fn (0,0)) of
-  Fail fatal err toks com ops => Left (err, toks)
-  OK a ts _ ops => Right (a,ops,ts)
-
--- I think I want to drop the typeclasses for v1
-
-export
-try : Parser a -> Parser a
-try (P pa) = P $ \toks,com,ops,col => case pa toks com ops col of
-  (Fail x err toks com ops) => Fail x err toks False ops
-  res => res
-
-export
-fail : String -> Parser a
-fail msg = P $ \toks,com,ops,col => Fail False (error col.file toks msg) toks com ops
-
-export
-fatal : String -> Parser a
-fatal msg = P $ \toks,com,ops,col => Fail True (error col.file toks msg) toks com ops
-
-export
-getOps : Parser (Operators)
-getOps = P $ \ toks, com, ops, col => OK ops toks com ops
-
-export
-addOp : String -> Int -> Fixity -> Parser ()
-addOp nm prec fix = P $ \ toks, com, ops, col =>
-  let parts = split (=='_') nm in
-  case parts of
-    "" ::: key :: rule => OK () toks com (insert key (MkOp nm prec fix False rule) ops)
-    key ::: rule => OK () toks com (insert key (MkOp nm prec fix True rule) ops)
-
-
-
-export
-Functor Parser where
-  map f (P pa) = P $ \ toks, com, ops, col => map f (pa toks com ops col)
-
-export
-Applicative Parser where
-  pure pa = P (\ toks, com, ops, col => OK pa toks com ops)
-  P pab <*> P pa = P $ \toks,com,ops,col =>
-    case pab toks com ops col of
-      Fail fatal err toks com ops => Fail fatal err toks com ops
-      OK f toks com ops =>
-        case pa toks com ops col of
-          (OK x toks com ops) => OK (f x) toks com ops
-          (Fail fatal err toks com ops) => Fail fatal err toks com ops
-
--- Second argument lazy so we don't have circular refs when defining parsers.
-export
-(<|>) : Parser a -> (Parser a) -> Parser a
-(P pa) <|> (P pb) = P $ \toks,com,ops,col =>
-  case pa toks False ops col of
-    OK a toks' _ ops => OK a toks' com ops
-    Fail True  err toks' com ops  => Fail True err toks' com ops
-    Fail fatal err toks' True ops => Fail fatal err toks' True ops
-    Fail fatal err toks' False ops => pb toks com ops col
-
-export
-Monad Parser where
-  P pa >>= pab = P $ \toks,com,ops,col =>
-    case pa toks com ops col of
-      (OK a toks com ops) => runP (pab a) toks com ops col
-      (Fail fatal err xs x ops) => Fail fatal err xs x ops
-
-
-satisfy : (BTok -> Bool) -> String -> Parser String
-satisfy f msg = P $ \toks,com,ops,col =>
-  case toks of
-    (t :: ts) => if f t then OK (value t) ts True ops else Fail False (error col.file toks "\{msg} at \{show $ kind t}:\{value t}") toks com ops
-    [] => Fail False (error col.file toks "\{msg} at EOF") toks com ops
-
-export
-commit : Parser ()
-commit = P $ \toks,com,ops,col => OK () toks True ops
-
-
-export some : Parser a -> Parser (List a)
-export many : Parser a -> Parser (List a)
-some p = (::) <$> p <*> many p
-many p = some p <|> pure []
-
--- one or more `a` seperated by `s`
-export
-sepBy : Parser s -> Parser a -> Parser (List a)
-sepBy s a = (::) <$> a <*> many (s *> a)
-
-export
-getPos : Parser FC
-getPos = P $ \toks, com, ops, indent => case toks of
-  [] => OK emptyFC toks com ops
-  (t :: ts) => OK (MkFC indent.file (getStart t)) toks com ops
-
-||| Start an indented block and run parser in it
-export
-startBlock : Parser a -> Parser a
-startBlock (P p) = P $ \toks,com,ops,indent => case toks of
-  [] => p toks com ops indent
-  (t :: _) =>
-    -- If next token is at or before the current level, we've got an empty block
-    let (tl,tc) = getStart t in
-    let (MkFC file (line,col)) = indent in
-    p toks com ops (MkFC file (tl, ifThenElse (tc <= col) (col + 1) tc))
-
-||| Assert that parser starts at our current column by
-||| checking column and then updating line to match the current
-export
-sameLevel : Parser a -> Parser a
-sameLevel (P p) = P $ \toks, com, ops, indent => case toks of
-  [] => p toks com ops indent
-  (t :: _) =>
-    let (tl,tc) = getStart t in
-    let (MkFC file (line,col)) = indent in
-    if tc == col then p toks com ops (MkFC file (tl, col))
-    else if col < tc then Fail False (error file toks "unexpected indent") toks com ops
-    else Fail False (error file toks "unexpected indent") toks com ops
-
-export
-someSame : Parser a -> Parser (List a)
-someSame pa = some $ sameLevel pa
-
-export
-manySame : Parser a -> Parser (List a)
-manySame pa = many $ sameLevel pa
-
-||| check indent on next token and run parser
-export
-indented : Parser a -> Parser a
-indented (P p) = P $ \toks,com,ops,indent => case toks of
-  [] => p toks com ops indent
-  (t::_) =>
-    let (tl,tc) = getStart t
-    in if tc > fcCol indent || tl == fcLine indent then p toks com ops indent
-    else Fail False (error (file indent) toks "unexpected outdent") toks com ops
-
-||| expect token of given kind
-export
-token' : Kind -> Parser String
-token' k = satisfy (\t => t.val.kind == k) "Expected a \{show k} token"
-
-export
-keyword' : String -> Parser ()
--- FIXME make this an appropriate whitelist
-keyword' kw = ignore $ satisfy (\t => t.val.text == kw && (t.val.kind == Keyword || t.val.kind == Symbol || t.val.kind == Number)) "Expected \{kw}"
-
-||| expect indented token of given kind
-export
-token : Kind -> Parser String
-token = indented . token'
-
-export
-keyword : String -> Parser ()
-keyword kw = indented $ keyword' kw
-
-export
-sym : String -> Parser ()
-sym = keyword
-

src/Lib/Parser/Impl.newt

@@ -0,0 +1,223 @@
+module Lib.Parser.Impl
+
+import Prelude
+import Lib.Token
+import Lib.Common
+import Data.String
+import Data.Int
+import Data.List1
+import Data.SortedMap
+
+
+TokenList : U
+TokenList = List BTok
+
+-- Result of a parse
+
+data Result : U -> U where
+  OK : ∀ a. a -> (toks : TokenList) -> (com : Bool) -> Operators -> Result a
+  Fail : ∀ a. Bool -> Error -> (toks : TokenList) -> (com : Bool) -> Operators -> Result a
+
+
+instance Functor Result where
+  map f (OK a toks com ops) = OK (f a) toks com ops
+  map _ (Fail fatal err toks com ops) = Fail fatal err toks com ops
+
+-- So sixty just has a newtype function here now (probably for perf).
+-- A record might be more ergonomic, but would require a record impl before
+-- self hosting.
+
+-- FC is a line and column for indents. The idea being that we check
+-- either the col < tokCol or line == tokLine, enabling sameLevel.
+
+-- We need State for operators (or postpone that to elaboration)
+-- Since I've already built out the pratt stuff, I guess I'll
+-- leave it in the parser for now
+
+-- This is a Reader in FC, a State in Operators, Commit flag, TokenList
+
+
+data Parser a = P (TokenList -> Bool -> Operators -> (lc : FC) -> Result a)
+
+
+runP : ∀ a. Parser a -> TokenList -> Bool -> Operators -> FC -> Result a
+runP (P f) = f
+
+-- FIXME no filename, also half the time it is pointing at the token after the error
+perror : String -> TokenList -> String -> Error
+perror fn Nil msg = E (MkFC fn (0,0)) msg
+perror fn ((MkBounded val (MkBounds line col _ _)) :: _) msg = E (MkFC fn (line,col)) msg
+
+
+parse : ∀ a. String -> Parser a -> TokenList -> Either Error a
+parse fn pa toks = case runP pa toks False EmptyMap (MkFC fn (-1,-1)) of
+  Fail fatal err toks com ops => Left err
+  OK a Nil _ _ => Right a
+  OK a ts _ _ => Left (perror fn ts "Extra toks")
+
+-- Intended for parsing a top level declaration
+
+partialParse : ∀ a. String -> Parser a -> Operators -> TokenList -> Either (Error × TokenList) (a × Operators × TokenList)
+partialParse fn pa ops toks = case runP pa toks False ops (MkFC fn (0,0)) of
+  Fail fatal err toks com ops => Left (err, toks)
+  OK a ts _ ops => Right (a,ops,ts)
+
+-- I think I want to drop the typeclasses for v1
+
+
+try : ∀ a. Parser a -> Parser a
+try (P pa) = P $ \toks com ops col => case pa toks com ops col of
+  (Fail x err toks com ops) => Fail x err toks False ops
+  res => res
+
+
+fail : ∀ a. String -> Parser a
+fail msg = P $ \toks com ops col => Fail False (perror col.file toks msg) toks com ops
+
+
+fatal : ∀ a. String -> Parser a
+fatal msg = P $ \toks com ops col => Fail True (perror col.file toks msg) toks com ops
+
+
+getOps : Parser (Operators)
+getOps = P $ \ toks com ops col => OK ops toks com ops
+
+
+addOp : String -> Int -> Fixity -> Parser Unit
+addOp nm prec fix = P $ \ toks com ops col =>
+  let parts = split nm "_" in
+  case parts of
+    "" :: key :: rule => OK MkUnit toks com (updateMap key (MkOp nm prec fix False rule) ops)
+    key :: rule => OK MkUnit toks com (updateMap key (MkOp nm prec fix True rule) ops)
+    Nil => Fail True (perror col.file toks "Internal error parsing mixfix") toks com ops
+
+
+
+
+instance Functor Parser where
+  map f (P pa) = P $ \ toks com ops col => map f (pa toks com ops col)
+
+
+instance Applicative Parser where
+  return pa = P (\ toks com ops col => OK pa toks com ops)
+  P pab <*> P pa = P $ \toks com ops col =>
+    case pab toks com ops col of
+      Fail fatal err toks com ops => Fail fatal err toks com ops
+      OK f toks com ops =>
+        case pa toks com ops col of
+          (OK x toks com ops) => OK (f x) toks com ops
+          (Fail fatal err toks com ops) => Fail fatal err toks com ops
+
+-- Second argument lazy so we don't have circular refs when defining parsers.
+
+instance Alternative Parser where
+  (P pa) <|> (P pb) = P $ \toks com ops col =>
+    case pa toks False ops col of
+      OK a toks' _ ops => OK a toks' com ops
+      Fail True  err toks' com ops  => Fail True err toks' com ops
+      Fail fatal err toks' True ops => Fail fatal err toks' True ops
+      Fail fatal err toks' False ops => pb toks com ops col
+
+
+instance Monad Parser where
+  pure = return
+  bind (P pa) pab = P $ \toks com ops col =>
+    case pa toks com ops col of
+      (OK a toks com ops) => runP (pab a) toks com ops col
+      (Fail fatal err xs x ops) => Fail fatal err xs x ops
+
+
+satisfy : (BTok -> Bool) -> String -> Parser String
+satisfy f msg = P $ \toks com ops col =>
+  case toks of
+    (t :: ts) => if f t then OK (value t) ts True ops else Fail False (perror col.file toks "\{msg} at \{show t.val.kind}:\{value t}") toks com ops
+    Nil => Fail False (perror col.file toks "\{msg} at EOF") toks com ops
+
+
+commit : Parser Unit
+commit = P $ \toks com ops col => OK MkUnit toks True ops
+
+
+some : ∀ a. Parser a -> Parser (List a)
+many : ∀ a. Parser a -> Parser (List a)
+
+some p = do
+  x <- p
+  xs <- many p
+  pure (x :: xs)
+many p = some p <|> pure Nil
+
+-- one or more `a` seperated by `s`
+
+sepBy : ∀ s a. Parser s -> Parser a -> Parser (List a)
+sepBy s a = _::_ <$> a <*> many (s *> a)
+
+
+getPos : Parser FC
+getPos = P $ \toks com ops indent => case toks of
+  Nil => OK emptyFC toks com ops
+  (t :: ts) => OK (MkFC indent.file (getStart t)) toks com ops
+
+-- Start an indented block and run parser in it
+
+startBlock : ∀ a. Parser a -> Parser a
+startBlock (P p) = P $ \toks com ops indent => case toks of
+  Nil => p toks com ops indent
+  (t :: _) =>
+    -- If next token is at or before the current level, we've got an empty block
+    let (tl,tc) = getStart t in
+    let (MkFC file (line,col)) = indent in
+    p toks com ops (MkFC file (tl, ite (tc <= col) (col + 1) tc))
+
+-- Assert that parser starts at our current column by
+-- checking column and then updating line to match the current
+
+sameLevel : ∀ a. Parser a -> Parser a
+sameLevel (P p) = P $ \toks com ops indent => case toks of
+  Nil => p toks com ops indent
+  (t :: _) =>
+    let (tl,tc) = getStart t in
+    let (MkFC file (line,col)) = indent in
+    if tc == col then p toks com ops (MkFC file (tl, col))
+    else if col < tc then Fail False (perror file toks "unexpected indent") toks com ops
+    else Fail False (perror file toks "unexpected indent") toks com ops
+
+
+someSame : ∀ a. Parser a -> Parser (List a)
+someSame pa = some $ sameLevel pa
+
+
+manySame : ∀ a. Parser a -> Parser (List a)
+manySame pa = many $ sameLevel pa
+
+-- check indent on next token and run parser
+
+indented : ∀ a. Parser a -> Parser a
+indented (P p) = P $ \toks com ops indent => case toks of
+  Nil => p toks com ops indent
+  (t :: _) =>
+    let (tl,tc) = getStart t
+    in if tc > fcCol indent || tl == fcLine indent then p toks com ops indent
+    else Fail False (perror indent.file toks "unexpected outdent") toks com ops
+
+-- expect token of given kind
+
+token' : Kind -> Parser String
+token' k = satisfy (\t => t.val.kind == k) "Expected a \{show k} token"
+
+keyword' : String -> Parser Unit
+-- FIXME make this an appropriate whitelist
+keyword' kw = ignore $ satisfy (\t => t.val.text == kw && (t.val.kind == Keyword || t.val.kind == Symbol || t.val.kind == Number)) "Expected \{kw}"
+
+-- expect indented token of given kind
+
+token : Kind -> Parser String
+token = indented ∘ token'
+
+
+keyword : String -> Parser Unit
+keyword kw = indented $ keyword' kw
+
+symbol : String -> Parser Unit
+symbol = keyword
+

src/Lib/Prettier.idr

@@ -1,149 +0,0 @@
-||| A prettier printer, Philip Wadler
-||| https://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf
-module Lib.Prettier
-
-import Data.String
-import Data.Nat
-import Data.Maybe
-
-||| `Doc` is a pretty printing document.  Constructors are private, use
-||| methods below.  `Alt` in particular has some invariants on it, see paper
-||| for details. (Something along the lines of "the first line of left is not
-||| bigger than the first line of the right".)
-export
-data Doc = Empty | Line | Text String | Nest Nat Doc | Seq Doc Doc | Alt Doc Doc
-
-||| The original paper had a List-like structure Doc (the above was DOC) which
-||| had Empty and a tail on Text and Line.
-data Item = TEXT String | LINE Nat
-
-export
-empty : Doc
-empty = Empty
-
-flatten : Doc -> Doc
-flatten Empty = Empty
-flatten (Seq x y) = Seq (flatten x) (flatten y)
-flatten (Nest i x) = flatten x
-flatten Line = Text " "
-flatten (Text str) = Text str
-flatten (Alt x y) = flatten x
-
-group : Doc -> Doc
-group x = Alt (flatten x) x
-
--- TODO - we can accumulate snoc and cat all at once
-layout : List Item -> SnocList String -> String
-layout [] acc = fastConcat $ acc <>> []
-layout (LINE k :: x) acc = layout x (acc :< "\n" :< replicate k ' ')
-layout (TEXT str :: x) acc = layout x (acc :< str)
-
-||| Whether a documents first line fits.
-fits : Nat -> List Item -> Bool
-fits w ((TEXT s) :: xs) = if length s < w then fits (w `minus` length s) xs else False
-fits w _ = True
-
--- vs Wadler, we're collecting the left side as a SnocList to prevent
--- blowing out the stack on the Text case.  The original had DOC as
--- a Linked-List like structure (now List Item)
-
--- I've now added a `fit` boolean to indicate if we should cut when we hit the line length
--- Wadler was relying on laziness to stop the first branch before LINE if necessary
-be : Bool -> SnocList Item -> Nat -> Nat -> List (Nat, Doc) -> Maybe (List Item)
-be fit acc w k [] = Just (acc <>> [])
-be fit acc w k ((i, Empty) :: xs) = be fit acc w k xs
-be fit acc w k ((i, Line) :: xs) = (be False (acc :< LINE i) w i xs)
-be fit acc w k ((i, (Text s)) :: xs) =
-  if not fit || (k + length s < w)
-     then (be fit (acc :< TEXT s) w (k + length s) xs)
-     else Nothing
-be fit acc w k ((i, (Nest j x)) :: xs) = be fit acc w k ((i + j, x) :: xs)
-be fit acc w k ((i, (Seq x y)) :: xs) = be fit acc w k ((i,x) :: (i,y) :: xs)
-be fit acc w k ((i, (Alt x y)) :: xs) =
-  (acc <>>) <$> (be True [<] w k ((i,x) :: xs) <|> be fit [<] w k ((i,y) :: xs))
-
-best : Nat -> Nat -> Doc -> List Item
-best w k x = fromMaybe [] $ be False [<] w k [(0,x)]
-
--- Public interface
-public export
-interface Pretty a where
-  pretty : a -> Doc
-
-export
-render : Nat -> Doc -> String
-render w x = layout (best w 0 x) [<]
-
-public export
-Semigroup Doc where x <+> y = Seq x (Seq (Text " ") y)
-
--- Match System.File so we don't get warnings
-public export
-infixl 5 </>
-
-export
-line : Doc
-line = Line
-
-export
-text : String -> Doc
-text = Text
-
-export
-nest : Nat -> Doc -> Doc
-nest = Nest
-
-export
-(++) : Doc -> Doc -> Doc
-x ++ y = Seq x y
-
-export
-(</>) : Doc -> Doc -> Doc
-x </> y = x ++ line ++ y
-
-||| fold, but doesn't emit extra nil
-export
-folddoc : (Doc -> Doc -> Doc) -> List Doc -> Doc
-folddoc f [] = Empty
-folddoc f [x] = x
-folddoc f (x :: xs) = f x (folddoc f xs)
-
-||| separate with space
-export
-spread : List Doc -> Doc
-spread = folddoc (<+>)
-
-||| separate with new lines
-export
-stack : List Doc -> Doc
-stack = folddoc (</>)
-
-||| bracket x with l and r, indenting contents on new line
-export
-bracket : String -> Doc -> String -> Doc
-bracket l x r = group (text l ++ nest 2 (line ++ x) ++ line ++ text r)
-
-export
-infixl 5 <+/>
-
-||| Either space or newline
-export
-(<+/>) : Doc -> Doc -> Doc
-x <+/> y = x ++ Alt (text " ") line ++ y
-
-||| Reformat some docs to fill. Not sure if I want this precise behavior or not.
-export
-fill : List Doc -> Doc
-fill [] = Empty
-fill [x] = x
-fill (x :: y :: xs) = Alt (flatten x <+> fill (flatten y :: xs)) (x </> fill (y :: xs))
-
-||| separate with comma
-export
-commaSep : List Doc -> Doc
-commaSep = folddoc (\a, b => a ++ text "," <+/> b)
-
-||| If we stick Doc into a String, try to avoid line-breaks via `flatten`
-public export
-Interpolation Doc where
-  interpolate = render 80 . flatten

src/Lib/Prettier.newt

@@ -0,0 +1,153 @@
+-- A prettier printer, Philip Wadler
+-- https://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf
+module Lib.Prettier
+import Prelude
+import Data.Int
+
+-- TODO I broke this when I converted from Nat to Int, and we're disabling it
+-- by flattening the Doc for now.
+
+-- `Doc` is a pretty printing document.  Constructors are private, use
+-- methods below.  `Alt` in particular has some invariants on it, see paper
+-- for details. (Something along the lines of "the first line of left is not
+-- bigger than the first line of the right".)
+
+data Doc = Empty | Line | Text String | Nest Int Doc | Seq Doc Doc | Alt Doc Doc
+
+-- The original paper had a List-like structure Doc (the above was DOC) which
+-- had Empty and a tail on Text and Line.
+data Item = TEXT String | LINE Int
+
+
+empty : Doc
+empty = Empty
+
+flatten : Doc -> Doc
+flatten Empty = Empty
+flatten (Seq x y) = Seq (flatten x) (flatten y)
+flatten (Nest i x) = flatten x
+flatten Line = Text " "
+flatten (Text str) = Text str
+flatten (Alt x y) = flatten x
+
+noAlt : Doc -> Doc
+noAlt Empty = Empty
+noAlt (Seq x y) = Seq (noAlt x) (noAlt y)
+noAlt (Nest i x) = noAlt x
+noAlt Line = Line
+noAlt (Text str) = Text str
+noAlt (Alt x y) = noAlt x
+
+group : Doc -> Doc
+group x = Alt (flatten x) x
+
+-- TODO - we can accumulate snoc and cat all at once
+layout : List Item -> SnocList String -> String
+layout Nil acc = fastConcat $ acc <>> Nil
+layout (LINE k :: x) acc = layout x (acc :< "\n" :< replicate (cast k) ' ')
+layout (TEXT str :: x) acc = layout x (acc :< str)
+
+-- Whether a documents first line fits.
+fits : Int -> List Item -> Bool
+fits w ((TEXT s) :: xs) = if slen s < w then fits (w - slen s) xs else False
+fits w _ = True
+
+-- vs Wadler, we're collecting the left side as a SnocList to prevent
+-- blowing out the stack on the Text case.  The original had DOC as
+-- a Linked-List like structure (now List Item)
+
+-- I've now added a `fit` boolean to indicate if we should cut when we hit the line length
+-- Wadler was relying on laziness to stop the first branch before LINE if necessary
+be : Bool -> SnocList Item -> Int -> Int -> List (Int × Doc) -> Maybe (List Item)
+be fit acc w k Nil = Just (acc <>> Nil)
+be fit acc w k ((i, Empty) :: xs) = be fit acc w k xs
+be fit acc w k ((i, Line) :: xs) = (be False (acc :< LINE i) w i xs)
+be fit acc w k ((i, (Text s)) :: xs) =
+  if not fit || (k + slen s < w)
+     then (be fit (acc :< TEXT s) w (k + slen s) xs)
+     else Nothing
+be fit acc w k ((i, (Nest j x)) :: xs) = be fit acc w k ((i + j, x) :: xs)
+be fit acc w k ((i, (Seq x y)) :: xs) = be fit acc w k ((i,x) :: (i,y) :: xs)
+be fit acc w k ((i, (Alt x y)) :: xs) =
+  (_<>>_ acc) <$> (be True Lin w k ((i,x) :: xs) <|> be fit Lin w k ((i,y) :: xs))
+
+best : Int -> Int -> Doc -> List Item
+best w k x = fromMaybe Nil $ be False Lin w k ((0,x) :: Nil)
+
+-- Public class
+
+class Pretty a where
+  pretty : a -> Doc
+
+
+render : Int -> Doc -> String
+render w x = layout (best w 0 (noAlt x)) Lin
+
+
+instance Semigroup Doc where x <+> y = Seq x (Seq (Text " ") y)
+
+-- Match System.File so we don't get warnings
+
+infixl 5 _</>_
+
+
+line : Doc
+line = Line
+
+
+text : String -> Doc
+text = Text
+
+
+nest : Int -> Doc -> Doc
+nest = Nest
+
+instance Concat Doc where
+  x ++ y = Seq x y
+
+
+_</>_ : Doc -> Doc -> Doc
+x </> y = x ++ line ++ y
+
+-- fold, but doesn't emit extra nil
+
+folddoc : (Doc -> Doc -> Doc) -> List Doc -> Doc
+folddoc f Nil = Empty
+folddoc f (x :: Nil) = x
+folddoc f (x :: xs) = f x (folddoc f xs)
+
+-- separate with space
+
+spread : List Doc -> Doc
+spread = folddoc _<+>_
+
+-- separate with new lines
+
+stack : List Doc -> Doc
+stack = folddoc _</>_
+
+-- bracket x with l and r, indenting contents on new line
+
+bracket : String -> Doc -> String -> Doc
+bracket l x r = group (text l ++ nest 2 (line ++ x) ++ line ++ text r)
+
+
+infixl 5 _<+/>_
+
+-- Either space or newline
+
+_<+/>_ : Doc -> Doc -> Doc
+x <+/> y = x ++ Alt (text " ") line ++ y
+
+-- Reformat some docs to fill. Not sure if I want this precise behavior or not.
+
+fill : List Doc -> Doc
+fill Nil = Empty
+fill (x :: Nil) = x
+fill (x :: y :: xs) = Alt (flatten x <+> fill (flatten y :: xs)) (x </> fill (y :: xs))
+
+-- separate with comma
+
+commaSep : List Doc -> Doc
+commaSep = folddoc (\a b => a ++ text "," <+/> b)
+

src/Lib/ProcessDecl.idr

@@ -1,426 +0,0 @@
-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 (toList ctx.types)) []
-  where
-    isVar : Nat -> Val -> Bool
-    isVar k (VVar _ k' [<]) = k == k'
-    isVar _ _ = False
-
-    go : List String -> Nat -> List (Val, String, Val) -> List String -> M (List String)
-    go _ _ [] 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 go names (S k) xs ("  \{n} : \{pprint names !(quote ctx.lvl ty)}":: acc)
-      else go names (S k) xs ("  \{n} = \{pprint names !(quote ctx.lvl v)} : \{pprint names !(quote ctx.lvl ty)}":: acc)
-
-export
-logMetas : Nat -> M ()
-logMetas mstart = do
-  -- FIXME, now this isn't logged for Sig / Data.
-  top <- get
-  mc <- readIORef top.metaCtx
-  let mlen = length mc.metas `minus` mstart
-  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 \{pprint [] !(quote 0 soln)}"
-      pure ()
-    (Unsolved fc k ctx ty User cons) => do
-      ty' <- quote ctx.lvl ty
-      let names = (toList $ map fst ctx.types)
-      env <- dumpEnv ctx
-      let msg = "\{env}  -----------\n  \{pprint names ty'}"
-      info fc "User Hole\n\{msg}"
-
-    (Unsolved fc k ctx ty kind cons) => do
-      tm <- quote ctx.lvl !(forceMeta 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 \{pprint (names ctx) tm} \{show $ length cons} constraints"
-      msgs <- for cons $ \ (MkMc fc env sp val) => do
-            pure "  * (m\{show k} (\{unwords $ map show $ sp <>> []}) =?= \{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
-          --   [] => findMatches ctx ty $ toList top.defs
-          --   xs => pure xs
-          matches <- findMatches ctx ty $ toList top.defs
-          -- TODO try putting mc into TopContext for to see if it gives better terms
-          pure $ ["  \{show $ length matches} Solutions: \{show matches}"]
-          -- pure $ "  \{show $ length matches} Solutions:" :: map (("  " ++) . interpolate . pprint (names ctx) . fst) matches
-
-        _ => pure []
-      info fc $ unlines ([msg] ++ msgs ++ sols)
-      -- addError $ E fc $ unlines ([msg] ++ msgs ++ sols)
-
-
--- Used for Class and Record
-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
-
-teleToPi : Telescope -> Raw -> Raw
-teleToPi [] end = end
-teleToPi ((info, ty) :: tele) end = RPi (getFC info) info ty (teleToPi tele end)
-
-impTele : Telescope -> Telescope
-impTele tele = map (\(BI fc nm _ quant, ty) => (BI fc nm Implicit Zero, ty)) tele
-
-
-export
-processDecl : List String -> Decl -> M ()
-
--- REVIEW I supposed I could have updated top here instead of the dance with the parser...
-processDecl ns  (PMixFix{})  = pure ()
-
-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 ()
-  ty <- check (mkCtx fc) tm (VU fc)
-  ty <- zonk top 0 [] ty
-  putStrLn "TypeSig \{unwords names} : \{pprint [] 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 uses ty src) = do
-  top <- get
-  ty <- check (mkCtx fc) ty (VU fc)
-  ty' <- nf [] ty
-  putStrLn "pfunc \{nm} : \{pprint [] ty'} := \{show src}"
-  -- TODO wire through fc?
-  for_ uses $ \ name => case lookupRaw name top of
-    Nothing => error fc "\{name} not in scope"
-    _ => pure ()
-  setDef (QN ns nm) fc ty' (PrimFn src uses)
-
-processDecl ns (Def fc nm clauses) = 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 \{pprint [] ty}"
-  vty <- eval empty CBN ty
-
-  debug "\{nm} vty is \{show vty}"
-
-
-  -- I can take LHS apart syntactically or elaborate it with an infer
-  clauses' <- traverse (makeClause top) clauses
-  tm <- buildTree (mkCtx fc) (MkProb clauses' vty)
-  -- putStrLn "Ok \{pprint [] tm}"
-
-  mc <- readIORef top.metaCtx
-  let mlen = length mc.metas `minus` mstart
-  solveAutos mstart
-  -- TODO - make nf that expands all metas and drop zonk
-  -- Day1.newt is a test case
-  -- tm' <- nf [] tm
-  tm' <- zonk top 0 [] tm
-  when top.verbose $ 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' []
-  when top.verbose $ putStrLn "ERASED\n\{render 80 $ pprint[] tm'}"
-  debug "Add def \{nm} \{pprint [] tm'} : \{pprint [] 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 \{pprint [] ty'}"
-  vty <- eval [] CBN ty'
-  res <- check (mkCtx fc) tm vty
-  putStrLn "  got \{pprint [] res}"
-  norm <- nf [] res
-  putStrLn "  NF \{pprint [] norm}"
-  norm <- nfv [] res
-  putStrLn "  NFV \{pprint [] 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 (\ acc, (BI fc nm icit _, _) => RApp fc acc (RVar fc nm) icit) (RVar classFC nm) tele
-  let dcType = teleToPi (impTele tele) $
-    foldr (\(fc, nm, ty), acc =>  RPi fc (BI fc nm Explicit Many) ty acc  ) tail fields
-
-  putStrLn "tcon type \{pretty tcType}"
-  putStrLn "dcon type \{pretty dcType}"
-  let decl = Data classFC nm tcType [TypeSig classFC [dcName] dcType]
-  putStrLn "Decl:"
-  putStrLn $ render 90 $ pretty decl
-  processDecl ns decl
-  for_ fields $ \ (fc,name,ty) => do
-      let funType = teleToPi (impTele tele) $ RPi fc (BI fc "_" Auto Many) tail ty
-      let autoPat = foldl (\acc, (fc,nm,ty) => RApp fc acc (RVar fc nm) Explicit) (RVar classFC dcName) fields
-      let lhs = foldl (\acc, (BI fc' nm icit quant, _) => RApp fc' acc (RVar fc' nm) Implicit) (RVar fc name) tele
-      let lhs = RApp classFC lhs autoPat Auto
-      let decl = Def fc name [(lhs, (RVar fc name))]
-
-      putStrLn "\{name} : \{pretty funType}"
-      putStrLn "\{pretty decl}"
-      processDecl ns $ TypeSig fc [name] funType
-      processDecl ns decl
-
-
-processDecl ns (Instance instfc ty decls) = do
-
-  putStrLn "-----"
-  putStrLn "Instance \{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 \{pprint [] 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 [] codomain
-  let sigDecl = TypeSig instfc [instname] 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 "\{pprint [] codomain} doesn't appear to be a TCon application"
-  let (Just (MkEntry _ name type (TCon cons))) = lookup tconName top
-    | _ => error tyFC "\{tconName} is not a type constructor"
-  let [con] = cons
-    | _ => error tyFC "\{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 [] CBN dcty
-    | x => error (getFC x) "dcty not Pi"
-  debug "dcty \{pprint [] 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'}"
-  conTele <- getFields !(apply vdcty args') env []
-  -- declare individual functions, collect their defs
-  defs <- for conTele $ \case
-     (MkBinder fc nm Explicit rig ty) => do
-       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
-          | _ => error instfc "no definition for \{nm}"
-
-       setDef (QN ns nm') fc ty' Axiom
-       let decl = (Def fc nm' xs)
-       putStrLn "***"
-       putStrLn "«\{nm'}» : \{pprint [] 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'))]
-  putStrLn "SIGDECL"
-  putStrLn "\{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
-      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
-
-    tenv : Nat -> Env
-    tenv Z = []
-    tenv (S k) = (VVar emptyFC k [<] :: 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 [] tm = tm
-
-    apply : Val -> List Val -> M Val
-    apply x [] = pure x
-    apply (VPi fc nm icit rig a b) (x :: xs) = apply !(b $$ x) xs
-    apply x (y :: xs) = error instfc "expected pi type \{show x}"
-
-processDecl ns (ShortData fc lhs sigs) = do
-  (nm,args) <- getArgs lhs []
-  let ty = foldr (\ (fc,n), a => (RPi fc (BI fc n Explicit Zero) (RU fc) a)) (RU fc) args
-  cons <- traverse (mkDecl args []) sigs
-  let dataDecl = Data fc nm ty cons
-  putStrLn "SHORTDATA"
-  putStrLn "\{pretty dataDecl}"
-  processDecl ns dataDecl
-  where
-    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 (\ (fc,nm), acc => RPi fc (BI fc nm Implicit Zero) (RU fc) acc) base args
-      pure $ TypeSig fc' [name] ty
-    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
-      unifyCatch fc (mkCtx fc) !(eval [] CBN tyty) !(eval [] CBN 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 \{pprint [] dty}"
-
-          -- We only check that codomain uses 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 (\(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) $
-            error (getFC codomain) "Constructor codomain is \{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
-    checkDeclType : Tm -> M ()
-    checkDeclType (UU _) = pure ()
-    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\{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 fc nm icit _, _) => RApp fc acc (RVar fc nm) icit) (RVar recordFC nm) tele
-  let dcType = teleToPi (impTele tele) $
-    foldr (\(fc, nm, ty), acc =>  RPi fc (BI fc nm Explicit Many) ty acc  ) tail fields
-
-  putStrLn "tcon type \{pretty tcType}"
-  putStrLn "dcon type \{pretty dcType}"
-  let decl = Data recordFC nm tcType [TypeSig recordFC [dcName] dcType]
-  putStrLn "Decl:"
-  putStrLn $ render 90 $ pretty decl
-  processDecl ns decl
-  for_ fields $ \ (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, (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} : \{pretty funType}"
-    -- putStrLn "\{pretty decl}"
-    -- processDecl ns $ TypeSig fc [name] funType
-    -- processDecl ns decl
-
-    -- `.fieldName`
-    let pname = "." ++ name
-    let lhs = foldl (\acc, (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))]
-    putStrLn "\{pname} : \{pretty funType}"
-    putStrLn "\{pretty pdecl}"
-    processDecl ns $ TypeSig fc [pname] funType
-    processDecl ns pdecl

src/Lib/ProcessDecl.newt

@@ -0,0 +1,457 @@
+module Lib.ProcessDecl
+
+import Prelude
+import Data.IORef
+import Data.String
+
+import Lib.Common
+import Lib.Elab
+import Lib.Parser
+import Lib.Syntax
+import Data.SortedMap
+import Lib.TopContext
+import Lib.Eval
+import Lib.Prettier
+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 : List MetaEntry -> M Unit
+logMetas Nil = pure MkUnit
+logMetas (OutOfScope :: rest) = logMetas rest
+logMetas (Solved fc k soln :: rest) = logMetas rest
+logMetas (Unsolved fc k ctx ty User cons :: rest) = 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}"
+      logMetas rest
+logMetas (Unsolved fc k ctx ty kind cons :: rest) = 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 <- getTop
+          -- 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 (("  " ++) ∘ render 90 ∘ pprint (names ctx) ∘ fst) matches
+
+        _ => pure Nil
+      info fc $ unlines ((msg :: Nil) ++ msgs ++ sols)
+      logMetas rest
+
+
+-- 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
+  log 1 $ \ _ => "-----"
+
+  top <- getTop
+  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
+  log 1 $ \ _ => "TypeSig \{unwords names} : \{render 90 $ pprint Nil ty}"
+  ignore $ for names $ \nm => setDef (QN ns nm) fc ty Axiom
+
+processDecl ns (PType fc nm ty) = do
+  top <- getTop
+  ty' <- check (mkCtx fc) (maybe (RU fc) id ty) (VU fc)
+  let arity = cast $ piArity ty'
+  setDef (QN ns nm) fc ty' (PrimTCon arity)
+
+processDecl ns  (PFunc fc nm used ty src) = do
+  top <- getTop
+  ty <- check (mkCtx fc) ty (VU fc)
+  ty' <- nf Nil ty
+  log 1 $ \ _ => "pfunc \{nm} : \{render 90 $ pprint Nil ty'} = \{show src}"
+  -- TODO wire through fc for not in scope error
+  used' <- for used $ \ name => case lookupRaw name top of
+    Nothing => error fc "\{name} not in scope"
+    Just entry => pure entry.name
+  setDef (QN ns nm) fc ty' (PrimFn src used')
+
+processDecl ns (Def fc nm clauses) = do
+  log 1 $ \ _ => "-----"
+  log 1 $ \ _ => "Def \{show nm}"
+  top <- getTop
+  mc <- readIORef top.metaCtx
+  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}"
+
+  log 1 $ \ _ => "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
+  clauses' <- traverse makeClause clauses
+  tm <- buildTree (mkCtx fc) (MkProb clauses' vty)
+  -- log 1 $ \ _ => "Ok \{render 90 $ pprint Nil tm}"
+
+  mc <- readIORef top.metaCtx
+  solveAutos
+  -- TODO - make nf that expands all metas and drop zonk
+  -- Idris2 doesn't expand metas for performance - a lot of these are dropped during erasure.
+  -- Day1.newt is a test case
+  -- tm' <- nf Nil tm
+  tm' <- zonk top 0 Nil tm
+  debug $ \ _ => "NF\n\{render 80 $ pprint Nil tm'}"
+  -- This is done in Compile.newt now, we can't store the result because we need the real thing at compile time
+  -- tm'' <- erase Nil tm' Nil
+  -- debug $ \ _ => "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')
+
+processDecl ns (DCheck fc tm ty) = do
+  log 1 $ \ _ => "----- DCheck"
+  top <- getTop
+
+  info 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
+  log 1 $ \ _ => "-----"
+  log 1 $ \ _ => "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
+
+  log 1 $ \ _ => "tcon type \{render 90 $ pretty tcType}"
+  log 1 $ \ _ => "dcon type \{render 90 $ pretty dcType}"
+  let decl = Data classFC nm tcType (TypeSig classFC (dcName :: Nil) dcType :: Nil)
+  log 1 $ \ _ => "Decl:"
+  log 1 $ \ _ => 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)
+
+      log 1 $ \ _ => "\{name} : \{render 90 $ pretty funType}"
+      log 1 $ \ _ => "\{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
+
+  log 1 $ \ _ => "-----"
+  log 1 $ \ _ => "Instance \{render 90 $ pretty ty}"
+  top <- getTop
+  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 = render 90 $ 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)
+       log 1 $ \ _ => "***"
+       log 1 $ \ _ => "«\{nm'}» : \{render 90 $ pprint Nil ty'}"
+       log 1 $ \ _ => 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)
+  log 1 $ \ _ => "SIGDECL"
+  log 1 $ \ _ => "\{render 90 $ pretty sigDecl}"
+  log 1 $ \ _ => 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
+  log 1 $ \ _ => "SHORTDATA"
+  log 1 $ \ _ => "\{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
+  log 1 $ \ _ => "-----"
+  log 1 $ \ _ => "Data \{nm}"
+  top <- getTop
+  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"
+  log 1 $ \ _ => "setDef \{nm}  TCon \{show $ join cnames}"
+  let arity = cast $ piArity tyty
+  updateDef (QN ns nm) fc tyty (TCon arity (join cnames))
+  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
+  log 1 $ \ _ => "-----"
+  log 1 $ \ _ => "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
+
+  log 1 $ \ _ => "tcon type \{render 90 $ pretty tcType}"
+  log 1 $ \ _ => "dcon type \{render 90 $ pretty dcType}"
+  let decl = Data recordFC nm tcType (TypeSig recordFC (dcName :: Nil) dcType :: Nil)
+  log 1 $ \ _ => "Decl:"
+  log 1 $ \ _ => render 90 $ pretty decl
+  processDecl ns decl
+  ignore $ 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))]
+      -- log 1 $ \ _ => "\{name} : \{render 90 $ pretty funType}"
+      -- log 1 $ \ _ => "\{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)
+      log 1 $ \ _ => "\{pname} : \{render 90 $ pretty funType}"
+      log 1 $ \ _ => "\{render 90 $ pretty pdecl}"
+      processDecl ns $ TypeSig fc (pname :: Nil) funType
+      processDecl ns pdecl

src/Lib/Syntax.newt

@@ -1,14 +1,14 @@
 module Lib.Syntax
 
+import Prelude
+import Lib.Common
 import Data.String
-import Data.Maybe
 import Lib.Prettier
 import Lib.Types
 
-public export
-data Raw : Type
+Raw : U
+
 
-public export
 data Pattern
   = PatVar FC Icit Name
   | PatCon FC Icit QName (List Pattern) (Maybe Name)
@@ -16,7 +16,7 @@ data Pattern
   -- Not handling this yet, but we need to be able to work with numbers and strings...
   | PatLit FC Literal
 
-export
+
 getIcit : Pattern -> Icit
 getIcit (PatVar x icit str) = icit
 getIcit (PatCon x icit str xs as) = icit
@@ -24,19 +24,19 @@ getIcit (PatWild x icit) = icit
 getIcit (PatLit fc lit) = Explicit
 
 
-export
-HasFC Pattern where
+
+instance HasFC Pattern where
   getFC (PatVar fc _ _) = fc
   getFC (PatCon fc _ _ _ _) = fc
   getFC (PatWild fc _) = fc
   getFC (PatLit fc lit) = fc
 
 -- %runElab deriveShow `{Pattern}
-public export
-Constraint : Type
-Constraint = (String, Pattern)
 
-public export
+Constraint : U
+Constraint = (String × Pattern)
+
+
 record Clause where
   constructor MkClause
   clauseFC : FC
@@ -52,17 +52,17 @@ record Clause where
   expr : Raw
 
 -- could be a pair, but I suspect stuff will be added?
-public export
+
 data RCaseAlt = MkAlt Raw Raw
 
-public export
-data DoStmt : Type where
+
+data DoStmt : U where
   DoExpr : (fc : FC) -> Raw -> DoStmt
   DoLet : (fc : FC) -> String -> Raw -> DoStmt
   DoArrow : (fc : FC) -> Raw -> Raw -> List RCaseAlt -> DoStmt
 
-data Decl : Type
-data Raw : Type where
+Decl : U
+data Raw : U where
   RVar : (fc : FC) -> (nm : Name) -> Raw
   RLam : (fc : FC) -> BindInfo -> (ty : Raw) -> Raw
   RApp : (fc : FC) -> (t : Raw) -> (u : Raw) -> (icit : Icit) -> Raw
@@ -79,11 +79,7 @@ data Raw : Type where
   RWhere : (fc : FC) -> (List Decl) -> Raw -> Raw
   RAs : (fc : FC) -> Name -> Raw -> Raw
 
-%name Raw tm
-
-
-export
-HasFC Raw where
+instance HasFC Raw where
   getFC (RVar fc nm) = fc
   getFC (RLam fc _ ty) = fc
   getFC (RApp fc t u icit) = fc
@@ -101,34 +97,29 @@ HasFC Raw where
   getFC (RAs fc _ _) = fc
 
 
--- derive some stuff - I'd like json, eq, show, ...
-
-
-
-public export
 data Import = MkImport FC Name
 
 
-public export
-Telescope : Type
-Telescope = List (BindInfo, Raw)
 
-public export
+Telescope : U
+Telescope = List (BindInfo × Raw)
+
+
 data Decl
   = TypeSig FC (List Name) Raw
-  | Def FC Name (List (Raw, Raw)) -- (List Clause)
+  | Def FC Name (List (Raw × Raw)) -- (List Clause)
   | DCheck FC Raw Raw
   | Data FC Name Raw (List Decl)
   | ShortData FC Raw (List Raw)
   | PType FC Name (Maybe Raw)
   | PFunc FC Name (List String) Raw String
-  | PMixFix FC (List Name) Nat Fixity
+  | PMixFix FC (List Name) Int Fixity
   | Class FC Name Telescope (List Decl)
   | Instance FC Raw (Maybe (List Decl))
   | Record FC Name Telescope (Maybe Name) (List Decl)
 
-public export
-HasFC Decl where
+
+instance HasFC Decl where
   getFC (TypeSig x strs tm) = x
   getFC (Def x str xs) = x
   getFC (DCheck x tm tm1) = x
@@ -141,7 +132,7 @@ HasFC Decl where
   getFC (Instance x tm xs) = x
   getFC (Record x str tm str1 xs) = x
 
-public export
+
 record Module where
   constructor MkModule
   modname : Name
@@ -151,90 +142,76 @@ record Module where
 foo : List String -> String
 foo ts = "(" ++ unwords ts ++ ")"
 
--- Show Literal where
---   show (LString str) = foo [ "LString", show str]
---   show (LInt i) = foo [ "LInt", show i]
---   show (LChar c) = foo [ "LChar", show c]
+instance Show Raw
+instance Show Pattern
 
-export
-covering
-implementation Show Raw
-
-export
-implementation Show Decl
-
-export Show Pattern
-
-export
-covering
-Show Clause where
+instance Show Clause where
   show (MkClause fc cons pats expr) = show (fc, cons, pats, expr)
 
-Show Import where
-  show (MkImport _ str) = foo ["MkImport", show str]
+instance Show Import where
+  show (MkImport _ str) = foo ("MkImport" :: show str :: Nil)
 
-Show BindInfo where
-  show (BI _ nm icit quant) = foo ["BI", show nm, show icit, show quant]
+instance Show BindInfo where
+  show (BI _ nm icit quant) = foo ("BI" :: show nm :: show icit :: show quant :: Nil)
 
 -- this is for debugging, use pretty when possible
-covering
-Show Decl where
-  show (TypeSig _ str x) = foo ["TypeSig", show str, show x]
-  show (Def _ str clauses) = foo ["Def", show str, show clauses]
-  show (Data _ str xs ys) = foo ["Data", show str, show xs, show ys]
-  show (DCheck _ x y) = foo ["DCheck", show x, show y]
-  show (PType _ name ty) = foo ["PType", name, show ty]
-  show (ShortData _ lhs sigs) = foo ["ShortData", show lhs, show sigs]
-  show (PFunc _ nm uses ty src) = foo ["PFunc", nm, show uses, show ty, show src]
-  show (PMixFix _ nms prec fix) = foo ["PMixFix", show nms, show prec, show fix]
-  show (Class _ nm tele decls) = foo ["Class",  nm, "...", (show $ map show decls)]
-  show (Instance _ nm decls) = foo ["Instance",  show nm, (show $ map show decls)]
-  show (Record _ nm tele nm1 decls) = foo ["Record", show nm, show tele, show nm1, show decls]
 
-export covering
-Show Module where
-  show (MkModule name imports decls) = foo ["MkModule", show name, show imports, show decls]
+instance Show Decl where
+  show (TypeSig _ str x) = foo ("TypeSig" :: show str :: show x :: Nil)
+  show (Def _ str clauses) = foo ("Def" :: show str :: show clauses :: Nil)
+  show (Data _ str xs ys) = foo ("Data" :: show str :: show xs :: show ys :: Nil)
+  show (DCheck _ x y) = foo ("DCheck" :: show x :: show y :: Nil)
+  show (PType _ name ty) = foo ("PType" :: name :: show ty :: Nil)
+  show (ShortData _ lhs sigs) = foo ("ShortData" :: show lhs :: show sigs :: Nil)
+  show (PFunc _ nm used ty src) = foo ("PFunc" :: nm :: show used :: show ty :: show src :: Nil)
+  show (PMixFix _ nms prec fix) = foo ("PMixFix" :: show nms :: show prec :: show fix :: Nil)
+  show (Class _ nm tele decls) = foo ("Class" ::  nm :: "..." :: (show $ map show decls) :: Nil)
+  show (Instance _ nm decls) = foo ("Instance" ::  show nm :: (show $ map show decls) :: Nil)
+  show (Record _ nm tele nm1 decls) = foo ("Record" :: show nm :: show tele :: show nm1 :: show decls :: Nil)
 
-export
-covering
-Show Pattern where
-  show (PatVar _ icit str) = foo ["PatVar", show icit, show str]
-  show (PatCon _ icit str xs as) = foo ["PatCon", show icit, show str, show xs, show as]
-  show (PatWild _ icit) = foo ["PatWild", show icit]
-  show (PatLit _ lit) = foo ["PatLit", show lit]
 
-covering
-Show RCaseAlt where
-  show (MkAlt x y)= foo ["MkAlt", show x, show y]
+instance Show Module where
+  show (MkModule name imports decls) = foo ("MkModule" :: show name :: show imports :: show decls :: Nil)
 
-covering
-Show Raw where
+
+instance Show Pattern where
+  show (PatVar _ icit str) = foo ("PatVar" :: show icit :: show str :: Nil)
+  show (PatCon _ icit str xs as) = foo ("PatCon" :: show icit :: show str :: show xs :: show as :: Nil)
+  show (PatWild _ icit) = foo ("PatWild" :: show icit :: Nil)
+  show (PatLit _ lit) = foo ("PatLit" :: show lit :: Nil)
+
+
+instance Show RCaseAlt where
+  show (MkAlt x y)= foo ("MkAlt" :: show x :: show y :: Nil)
+
+
+instance Show Raw where
   show (RImplicit _) = "_"
   show (RHole _) = "?"
-  show (RVar _ name) = foo ["RVar", show name]
-  show (RAnn _ t ty) = foo [ "RAnn", show t, show ty]
-  show (RLit _ x) = foo [ "RLit", show x]
-  show (RLet _ x ty v scope) = foo [ "Let", show x, " : ", show ty, " = ", show v, " in ", show scope]
-  show (RPi _ bi y z) = foo [ "Pi", show bi, show y, show z]
-  show (RApp _ x y z) = foo [ "App", show x, show y, show z]
-  show (RLam _ bi y) = foo [ "Lam", show bi, show y]
-  show (RCase _ x xs) = foo [ "Case", show x, show xs]
-  show (RDo _ stmts) = foo [ "DO", "FIXME"]
+  show (RVar _ name) = foo ("RVar" :: show name :: Nil)
+  show (RAnn _ t ty) = foo ( "RAnn" :: show t :: show ty :: Nil)
+  show (RLit _ x) = foo ( "RLit" :: show x :: Nil)
+  show (RLet _ x ty v scope) = foo ( "Let" :: show x :: " : " :: show ty :: " = " :: show v :: " in " :: show scope :: Nil)
+  show (RPi _ bi y z) = foo ( "Pi" :: show bi :: show y :: show z :: Nil)
+  show (RApp _ x y z) = foo ( "App" :: show x :: show y :: show z :: Nil)
+  show (RLam _ bi y) = foo ( "Lam" :: show bi :: show y :: Nil)
+  show (RCase _ x xs) = foo ( "Case" :: show x :: show xs :: Nil)
+  show (RDo _ stmts) = foo ( "DO" :: "FIXME" :: Nil)
   show (RU _) = "U"
-  show (RIf _ x y z) = foo [ "If", show x, show y, show z]
-  show (RWhere _ _ _) = foo [ "Where", "FIXME"]
-  show (RAs _ nm x) = foo [ "RAs", nm, show x]
+  show (RIf _ x y z) = foo ( "If" :: show x :: show y :: show z :: Nil)
+  show (RWhere _ _ _) = foo ( "Where" :: "FIXME" :: Nil)
+  show (RAs _ nm x) = foo ( "RAs" :: nm :: show x :: Nil)
 
-export
-Pretty Literal where
-  pretty (LString str) = text $ interpolate str
+
+instance Pretty Literal where
+  pretty (LString t) = text t
   pretty (LInt i) = text $ show i
   pretty (LChar c) = text $ show c
 
-export
-Pretty Pattern where
+
+instance Pretty Pattern where
   -- FIXME - wrap Implicit with {}
-  pretty (PatVar _ icit nm) = text nm
+  pretty (PatVar _ icit str) = text str
   pretty (PatCon _ icit nm args Nothing) = text (show nm) <+> spread (map pretty args)
   pretty (PatCon _ icit nm args (Just as)) = text as ++ text "@(" ++ text (show nm) <+> spread (map pretty args) ++ text ")"
   pretty (PatWild _ icit) = text "_"
@@ -245,17 +222,17 @@ wrap Explicit x = text "(" ++ x ++ text ")"
 wrap Implicit x = text "{" ++ x ++ text "}"
 wrap Auto x = text "{{" ++ x ++ text "}}"
 
-export
-Pretty Raw where
+
+instance Pretty Raw where
   pretty = asDoc 0
     where
     bindDoc : BindInfo -> Doc
-    bindDoc (BI _ nm icit quant) = ?rhs_0
+    bindDoc (BI _ nm icit quant) = text "BINDDOC"
 
-    par : Nat -> Nat -> Doc -> Doc
+    par : Int -> Int -> Doc -> Doc
     par p p' d = if p' < p then text "(" ++ d ++ text ")" else d
 
-    asDoc : Nat -> Raw -> Doc
+    asDoc : Int -> Raw -> Doc
     asDoc p (RVar _ str) = text str
     asDoc p (RLam _ (BI _ nm icit q) x) = par p 0 $ text "\\" ++ wrap icit (text nm) <+> text "=>" <+> asDoc 0 x
     -- This needs precedence and operators...
@@ -281,21 +258,24 @@ Pretty Raw where
     asDoc p (RWhere _ dd b) = text "TODO pretty where"
     asDoc p (RAs _ nm x) = text nm ++ text "@(" ++ asDoc 0 x ++ text ")"
 
-prettyBind : (BindInfo, Raw) -> Doc
+prettyBind : (BindInfo × Raw) -> Doc
 prettyBind (BI _ nm icit quant, ty) = wrap icit (text (show quant ++ nm) <+> text ":" <+> pretty ty)
 
 pipeSep : List Doc -> Doc
-pipeSep = folddoc (\a, b => a <+/> text "|" <+> b)
+pipeSep = folddoc (\a b => a <+/> text "|" <+> b)
 
-export
-Pretty Decl where
+
+instance Pretty Decl where
   pretty (TypeSig _ nm ty) = spread (map text nm) <+> text ":" <+> nest 2 (pretty ty)
-  pretty (Def _ nm clauses) = stack $ map (\(a,b) => pretty a <+> text "=" <+> pretty b) clauses
+  pretty (Def _ nm clauses) = stack $ map prettyPair clauses
+    where
+      prettyPair : Raw × Raw → Doc
+      prettyPair (a, b) = pretty a <+> text "=" <+> pretty b
   pretty (Data _ nm x xs) = text "data" <+> text nm <+> text ":" <+>  pretty x <+> (nest 2 $ text "where" </> stack (map pretty xs))
   pretty (DCheck _ x y) = text "#check" <+> pretty x <+> text ":" <+> pretty y
   pretty (PType _ nm ty) = text "ptype" <+> text nm <+> (maybe empty (\ty => text ":" <+> pretty ty) ty)
-  pretty (PFunc _ nm [] ty src) = text "pfunc" <+> text nm <+> text ":" <+> nest 2 (pretty ty <+> text ":=" <+/> text (show src))
-  pretty (PFunc _ nm uses ty src) = text "pfunc" <+> text nm <+> text "uses" <+> spread (map text uses) <+> text ":" <+> nest 2 (pretty ty <+> text ":=" <+/> text (show src))
+  pretty (PFunc _ nm Nil ty src) = text "pfunc" <+> text nm <+> text ":" <+> nest 2 (pretty ty <+> text ":=" <+/> text (show src))
+  pretty (PFunc _ nm used ty src) = text "pfunc" <+> text nm <+> text "uses" <+> spread (map text used) <+> text ":" <+> nest 2 (pretty ty <+> text ":=" <+/> text (show src))
   pretty (PMixFix _ names prec fix) = text (show fix) <+> text (show prec) <+> spread (map text names)
   pretty (Record _ nm tele cname decls) = text "record" <+> text nm <+> text ":" <+> spread (map prettyBind tele)
     <+> (nest 2 $ text "where" </> stack (maybe empty (\ nm' => text "constructor" <+> text nm') cname :: map pretty decls))
@@ -304,8 +284,8 @@ Pretty Decl where
   pretty (Instance _ _ _) = text "TODO pretty Instance"
   pretty (ShortData _ lhs sigs) = text "data" <+> pretty lhs <+> text "=" <+> pipeSep (map pretty sigs)
 
-export
-Pretty Module where
+
+instance Pretty Module where
   pretty (MkModule name imports decls) =
     text "module" <+> text name
       </> stack (map doImport imports)

src/Lib/Token.newt

@@ -1,6 +1,7 @@
 module Lib.Token
 
-public export
+import Prelude
+
 record Bounds where
   constructor MkBounds
   startLine : Int
@@ -8,21 +9,21 @@ record Bounds where
   endLine : Int
   endCol : Int
 
-export
-Eq Bounds where
+
+instance Eq Bounds where
   (MkBounds sl sc el ec) == (MkBounds sl' sc' el' ec') =
       sl == sl'
    && sc == sc'
    && el == el'
    && ec == ec'
 
-public export
+
 record WithBounds ty where
   constructor MkBounded
   val : ty
   bounds : Bounds
 
-public export
+
 data Kind
   = Ident
   | UIdent
@@ -47,8 +48,8 @@ data Kind
   | StartInterp
   | EndInterp
 
-export
-Show Kind where
+
+instance Show Kind where
   show Ident   = "Ident"
   show UIdent   = "UIdent"
   show Keyword = "Keyword"
@@ -71,33 +72,29 @@ Show Kind where
   show StartInterp = "StartInterp"
   show EndInterp = "EndInterp"
 
-export
-Eq Kind where
+
+instance Eq Kind where
   a == b = show a == show b
 
-public export
+
 record Token where
   constructor Tok
   kind : Kind
   text : String
 
 
-export
-Show Token where
+
+instance Show Token where
   show (Tok k v) = "<\{show k}:\{show v}>"
 
-public export
-BTok : Type
+
+BTok : U
 BTok = WithBounds Token
 
-export
+
 value : BTok -> String
 value (MkBounded (Tok _ s) _) = s
 
-export
-kind : BTok -> Kind
-kind (MkBounded (Tok k s) _) = k
 
-export
-getStart : BTok -> (Int, Int)
+getStart : BTok -> (Int × Int)
 getStart (MkBounded _ (MkBounds l c _ _)) = (l,c)

src/Lib/Tokenizer.newt

@@ -5,23 +5,27 @@ module Lib.Tokenizer
 -- Currently this processes a stream of characters, I may switch it to
 -- combinators for readability in the future.
 
+-- Newt is having a rough time dealing with do blocks for Either in here
+--
+import Prelude
 import Lib.Token
 import Lib.Common
 import Data.String
+import Data.SnocList
 
 standalone : List Char
-standalone = unpack "()\\{}[,.@]"
+standalone = unpack "()\\{}[],.@"
 
 keywords : List String
-keywords = ["let", "in", "where", "case", "of", "data", "U", "do",
-            "ptype", "pfunc", "module", "infixl", "infixr", "infix",
-            "∀", "forall", "import", "uses",
-            "class", "instance", "record", "constructor",
-            "if", "then", "else",
+keywords = ("let" :: "in" :: "where" :: "case" :: "of" :: "data" :: "U" :: "do" ::
+            "ptype" :: "pfunc" :: "module" :: "infixl" :: "infixr" :: "infix" ::
+            "∀" :: "forall" :: "import" :: "uses" ::
+            "class" :: "instance" :: "record" :: "constructor" ::
+            "if" :: "then" :: "else" ::
             -- it would be nice to find a way to unkeyword "." so it could be
             -- used as an operator too
-            "$", "λ", "?", "@", ".",
-             "->", "→", ":", "=>", ":=", "=", "<-", "\\", "_", "|"]
+            "$" :: "λ" :: "?" :: "@" :: "." ::
+             "->" :: "→" :: ":" :: "=>" :: ":=" :: "=" :: "<-" :: "\\" :: "_" :: "|" :: Nil)
 
 record TState where
   constructor TS
@@ -30,20 +34,24 @@ record TState where
   acc : SnocList BTok
   chars : List Char
 
+singleton : Char → String
+singleton c = pack $ c :: Nil
+
 -- This makes a big case tree...
 rawTokenise : TState -> Either Error TState
 
 quoteTokenise : TState -> Int -> Int -> SnocList Char -> Either Error TState
 quoteTokenise ts@(TS el ec toks chars) startl startc acc = case chars of
   '"' :: cs => Right (TS el ec (toks :< stok) chars)
-  '\\' :: '{' :: cs => do
-    let tok = MkBounded (Tok StartInterp "\\{") (MkBounds el ec el (ec + 2))
-    (TS el ec toks chars) <- rawTokenise $ TS el (ec + 2) (toks :< stok :< tok) cs
-    case chars of
-      '}' :: cs =>
-        let tok = MkBounded (Tok EndInterp "}") (MkBounds el ec el (ec + 1))
-        in quoteTokenise (TS el (ec + 1) (toks :< tok) cs) el (ec + 1) [<]
-      cs => Left $ E (MkFC "" (el, ec)) "Expected '{'"
+  '\\' :: '{' :: cs =>
+    let tok = MkBounded (Tok StartInterp "\\{") (MkBounds el ec el (ec + 2)) in
+    case (rawTokenise $ TS el (ec + 2) (toks :< stok :< tok) cs) of
+      Left err => Left err
+      Right (TS el ec toks chars) => case chars of
+        '}' :: cs =>
+          let tok = MkBounded (Tok EndInterp "}") (MkBounds el ec el (ec + 1))
+          in quoteTokenise (TS el (ec + 1) (toks :< tok) cs) el (ec + 1) Lin
+        cs => Left $ E (MkFC "" (el, ec)) "Expected '{'"
   -- TODO newline in string should be an error
   '\n' :: cs => Left $ E (MkFC "" (el, ec)) "Newline in string"
   '\\' :: 'n' :: cs => quoteTokenise (TS el (ec + 2) toks cs) startl startc (acc :< '\n')
@@ -53,7 +61,7 @@ quoteTokenise ts@(TS el ec toks chars) startl startc acc = case chars of
 
   where
     stok : BTok
-    stok = MkBounded (Tok StringKind (pack $ acc <>> [])) (MkBounds startl startc el ec)
+    stok = MkBounded (Tok StringKind (pack $ acc <>> Nil)) (MkBounds startl startc el ec)
 
 
 
@@ -62,42 +70,45 @@ rawTokenise ts@(TS sl sc toks chars) = case chars of
   ' ' :: cs => rawTokenise (TS sl (sc + 1) toks cs)
   '\n' :: cs => rawTokenise (TS (sl + 1) 0 toks cs)
 
-  '"' :: cs => do
-    let tok = mktok False sl (sc + 1) StartQuote "\""
-    (TS sl sc toks chars) <- quoteTokenise (TS sl (sc + 1) (toks :< tok) cs) sl (sc + 1) [<]
-    case chars of
-      '"' :: cs => let tok = mktok False sl (sc + 1) EndQuote "\"" in
-        rawTokenise (TS sl (sc + 1) (toks :< tok) cs)
-      cs => Left $ E (MkFC "" (sl, sc)) "Expected '\"'"
+  '"' :: cs =>
+    let tok = mktok False sl (sc + 1) StartQuote "\"" in
+    case quoteTokenise (TS sl (sc + 1) (toks :< tok) cs) sl (sc + 1) Lin of
+      Left err => Left err
+      Right (TS sl sc toks chars) => case chars of
+        '"' :: cs => let tok = mktok False sl (sc + 1) EndQuote "\"" in
+          rawTokenise (TS sl (sc + 1) (toks :< tok) cs)
+        cs => Left $ E (MkFC "" (sl, sc)) "Expected '\"'"
 
-  '{' :: '{' :: cs => do
-    let tok = mktok False sl (sc + 2) Keyword "{{"
-    (TS sl sc toks chars) <- rawTokenise (TS sl (sc + 2) (toks :< tok) cs)
-    case chars of
-      '}' :: '}' :: cs => let tok = mktok False sl (sc + 2) Keyword "}}" in
-        rawTokenise (TS sl (sc + 2) (toks :< tok) cs)
-      cs => Left $ E (MkFC "" (sl, sc)) "Expected '}}'"
+  '{' :: '{' :: cs =>
+    let tok = mktok False sl (sc + 2) Keyword "{{" in
+    case rawTokenise (TS sl (sc + 2) (toks :< tok) cs) of
+      Left err => Left err
+      Right (TS sl sc toks chars) => case chars of
+        '}' :: '}' :: cs => let tok = mktok False sl (sc + 2) Keyword "}}" in
+          rawTokenise (TS sl (sc + 2) (toks :< tok) cs)
+        cs => Left $ E (MkFC "" (sl, sc)) "Expected '}}'"
 
   '}' :: cs => Right ts
-  '{' :: cs => do
-    let tok = mktok False sl (sc + 1) Symbol "{"
-    (TS sl sc toks chars) <- rawTokenise (TS sl (sc + 1) (toks :< tok) cs)
-    case chars of
-      '}' :: cs => let tok = mktok False sl (sc + 1) Symbol "}" in
-        rawTokenise (TS sl (sc + 1) (toks :< tok) cs)
-      cs => Left $ E (MkFC "" (sl, sc)) "Expected '}'"
+  '{' :: cs =>
+    let tok = mktok False sl (sc + 1) Symbol "{" in
+    case rawTokenise (TS sl (sc + 1) (toks :< tok) cs) of
+      Left err => Left err
+      Right (TS sl sc toks chars) => case chars of
+        '}' :: cs => let tok = mktok False sl (sc + 1) Symbol "}" in
+          rawTokenise (TS sl (sc + 1) (toks :< tok) cs)
+        cs => Left $ E (MkFC "" (sl, sc)) "Expected '}'"
 
   ',' :: cs => rawTokenise (TS sl (sc + 1) (toks :< mktok False sl (sc + 1) Ident ",") cs)
   '_' :: ',' :: '_' :: cs => rawTokenise (TS sl (sc + 3) (toks :< mktok False sl (sc + 3) MixFix "_,_") cs)
   '_' :: '.' :: '_' :: cs => rawTokenise (TS sl (sc + 3) (toks :< mktok False sl (sc + 3) MixFix "_._") cs)
   '\'' :: '\\' :: c :: '\'' :: cs =>
-    let ch = ifThenElse (c == 'n') '\n' c
+    let ch = ite (c == 'n') '\n' c
     in rawTokenise (TS sl (sc + 4) (toks :< mktok False sl (sc + 4) Character (singleton ch)) cs)
   '\'' :: c :: '\'' :: cs => rawTokenise (TS sl (sc + 3) (toks :< mktok False sl (sc + 3) Character (singleton c)) cs)
   '#' :: cs => doRest (TS sl (sc + 1) toks cs) Pragma isIdent (Lin :< '#')
   '-' :: '-' :: cs => lineComment (TS sl (sc + 2) toks cs)
   '/' :: '-' :: cs => blockComment (TS sl (sc + 2) toks cs)
-  '`' :: cs => doBacktick (TS sl (sc + 1) toks cs) [<]
+  '`' :: cs => doBacktick (TS sl (sc + 1) toks cs) Lin
   '.' :: cs => doRest (TS sl (sc + 1) toks cs) Projection isIdent (Lin :< '.')
   '-' :: c :: cs => if isDigit c
     then doRest (TS sl (sc + 2) toks cs) Number isDigit (Lin :< '-' :< c)
@@ -115,7 +126,7 @@ rawTokenise ts@(TS sl sc toks chars) = case chars of
     doBacktick : TState -> SnocList Char -> Either Error TState
     doBacktick (TS l c toks Nil) acc = Left $ E (MkFC "" (l,c)) "EOF in backtick string"
     doBacktick (TS el ec toks ('`' :: cs)) acc =
-      let tok = MkBounded (Tok JSLit (pack $ acc <>> [])) (MkBounds sl sc el ec) in
+      let tok = MkBounded (Tok JSLit (pack $ acc <>> Nil)) (MkBounds sl sc el ec) in
       rawTokenise (TS el (ec + 1) (toks :< tok) cs)
     doBacktick (TS l c toks ('\n' :: cs)) acc = doBacktick (TS (l + 1) 0 toks cs) (acc :< '\n')
     doBacktick (TS l c toks (ch :: cs)) acc = doBacktick (TS l (c + 1) toks cs) (acc :< ch)
@@ -138,23 +149,23 @@ rawTokenise ts@(TS sl sc toks chars) = case chars of
     blockComment (TS line col toks (c :: cs)) = blockComment (TS line (col + 1) toks cs)
 
     doRest : TState -> Kind -> (Char -> Bool) -> SnocList Char -> Either Error TState
-    doRest (TS l c toks Nil) kind pred acc = rawTokenise (TS l c (toks :< mktok True l c kind (pack $ acc <>> [])) Nil)
+    doRest (TS l c toks Nil) kind pred acc = rawTokenise (TS l c (toks :< mktok True l c kind (pack $ acc <>> Nil)) Nil)
     doRest (TS l c toks (ch :: cs)) kind pred acc = if pred ch
       then doRest (TS l (c + 1) toks cs) kind pred (acc :< ch)
       else
-        let kind = if elem '_' acc then MixFix else kind in
-        rawTokenise (TS l c (toks :< mktok True l (c - 1) kind (pack $ acc <>> [])) (ch :: cs))
+        let kind = if snocelem '_' acc then MixFix else kind in
+        rawTokenise (TS l c (toks :< mktok True l (c - 1) kind (pack $ acc <>> Nil)) (ch :: cs))
 
     doChar : Char -> List Char ->  Either Error TState
     doChar c cs = if elem c standalone
-      then rawTokenise (TS sl (sc + 1) (toks :< mktok True sl (sc + 1) Symbol (singleton c)) cs)
+      then rawTokenise (TS sl (sc + 1) (toks :< mktok True sl (sc + 1) Symbol (pack $ c :: Nil)) cs)
       else let kind = if isDigit c then Number else if isUpper c then UIdent else Ident in
-        doRest (TS sl sc toks (c :: cs)) kind isIdent [<]
+        doRest (TS sl sc toks (c :: cs)) kind isIdent Lin
+
 
-export
 tokenise : String -> String -> Either Error (List BTok)
 tokenise fn text = case rawTokenise (TS 0 0 Lin (unpack text)) of
-  Right (TS trow tcol acc []) => Right $ acc <>> []
+  Right (TS trow tcol acc Nil) => Right $ acc <>> Nil
   Right (TS trow tcol acc chars) => Left $ E (MkFC fn (trow, tcol)) "Extra toks"
   Left (E (MkFC file start) str) => Left $ E (MkFC fn start) str
   Left err => Left err

src/Lib/TopContext.idr

@@ -1,54 +0,0 @@
-module Lib.TopContext
-
-import Data.IORef
-import Data.SortedMap
-import Data.String
-import Lib.Types
-
--- I want unique ids, to be able to lookup, update, and a Ref so
--- I don't need good Context discipline. (I seem to have made mistakes already.)
-
-export
-lookup : QName -> TopContext -> Maybe TopEntry
-lookup nm top = lookup nm top.defs
-
--- TODO - look at imported namespaces, and either have a map of imported names or search imported namespaces..
-export
-lookupRaw : String -> TopContext -> Maybe TopEntry
-lookupRaw raw top = go $ toList top.defs
-  where
-    go : List (QName, TopEntry) -> Maybe TopEntry
-    go Nil = Nothing
-    go (((QN ns nm), entry) :: rest) = if nm == raw then Just entry else go rest
-
--- Maybe pretty print?
-export
-covering
-Show TopContext where
-  show (MkTop defs metas _ _ _ _) = "\nContext:\n [\{ joinBy "\n" $ map (show . snd) $ toList defs}]"
-
-public export
-empty : HasIO m => m TopContext
-empty = pure $ MkTop empty !(newIORef (MC [] 0 CheckAll)) False !(newIORef []) [] empty
-
-public export
-setDef : QName -> FC -> Tm -> Def -> M ()
-setDef name fc ty def = do
-  top <- get
-  let Nothing = lookup name top.defs
-    | Just (MkEntry fc' nm' ty' def') => error fc "\{name} is already defined at \{show fc'}"
-  put $ { defs $= (insert name (MkEntry fc name ty def)) } top
-
-public export
-updateDef : QName -> FC -> Tm -> Def -> M ()
-updateDef name fc ty def = do
-  top <- get
-  let Just (MkEntry fc' nm' ty' def') = lookup name top.defs
-    | Nothing => error fc "\{name} not declared"
-  put $ { defs $= (insert name (MkEntry fc' name ty def)) } top
-
-public export
-addError : Error -> M ()
-addError err = do
-  top <- get
-  modifyIORef top.errors (err ::)

src/Lib/TopContext.newt

@@ -0,0 +1,74 @@
+module Lib.TopContext
+
+import Data.IORef
+import Data.SortedMap
+import Data.String
+import Prelude
+import Lib.Common
+import Lib.Types
+
+-- I want unique ids, to be able to lookup, update, and a Ref so
+-- I don't need good Context discipline. (I seem to have made mistakes already.)
+
+
+lookup : QName -> TopContext -> Maybe TopEntry
+lookup qn@(QN ns nm) top =
+  case lookupMap' qn top.defs of
+    Just entry => Just entry
+    Nothing => case lookupMap' ns top.modules of
+      Just mod => lookupMap' qn mod.modDefs
+      Nothing => Nothing
+
+-- TODO - look at imported namespaces, and either have a map of imported names or search imported namespaces..
+
+lookupRaw : String -> TopContext -> Maybe TopEntry
+lookupRaw raw top =
+  case lookupMap' (QN top.ns raw) top.defs of
+    Just entry => Just entry
+    Nothing => go top.imported
+  where
+    go : List (List String) → Maybe TopEntry
+    go Nil = Nothing
+    go (ns :: nss) = case lookupMap' ns top.modules of
+      Nothing => go nss
+      Just mod => case lookupMap' (QN ns raw) mod.modDefs of
+        Just entry => Just entry
+        Nothing => go nss
+
+
+instance Show TopContext where
+  show (MkTop _ _ _ defs metas _ _ _) = "\nContext:\n (\{ joinBy "\n" $ map (show ∘ snd) $ toList defs} :: Nil)"
+
+-- TODO need to get class dependencies working
+emptyTop : ∀ io. {{Monad io}} {{HasIO io}} -> io TopContext
+emptyTop = do
+  mcctx <- newIORef (MC EmptyMap 0 CheckAll)
+  errs <- newIORef $ the (List Error) Nil
+  pure $ MkTop EmptyMap Nil Nil EmptyMap mcctx 0 errs EmptyMap
+
+
+setDef : QName -> FC -> Tm -> Def -> M Unit
+setDef name fc ty def = do
+  top <- getTop
+  let (Nothing) = lookupMap' name top.defs
+    | Just (MkEntry fc' nm' ty' def') => error fc "\{show name} is already defined at \{show fc'}"
+  modifyTop $ \case
+    MkTop mods imp ns defs metaCtx verbose errors ops =>
+      let defs = (updateMap name (MkEntry fc name ty def) top.defs) in
+      MkTop mods imp ns defs metaCtx verbose errors ops
+
+
+updateDef : QName -> FC -> Tm -> Def -> M Unit
+updateDef name fc ty def = do
+  top <- getTop
+  let (Just (MkEntry fc' nm' ty' def')) = lookupMap' name top.defs
+    | Nothing => error fc "\{show name} not declared"
+  modifyTop $ \case
+    MkTop mods imp ns defs metaCtx verbose errors ops =>
+      let defs = (updateMap name (MkEntry fc' name ty def) defs) in
+      MkTop mods imp ns defs metaCtx verbose errors ops
+
+addError : Error -> M Unit
+addError err = do
+  top <- getTop
+  modifyIORef top.errors (_::_ err)

src/Lib/Types.newt

@@ -1,129 +1,81 @@
 module Lib.Types
 
--- For FC, Error
-import public Lib.Common
-import public Lib.Prettier
+import Prelude
+import Lib.Common
+import Lib.Prettier
 
-import Data.Fin
 import Data.IORef
-import Data.List
 import Data.SnocList
 import Data.SortedMap
 import Data.String
-import Data.Vect
 
-public export
-data QName : Type where
-  QN : List String -> String -> QName
-
-public export
-Eq QName where
-  QN ns n == QN ns' n' = n == n' && ns == ns'
-
-public export
-Show QName where
-  show (QN [] n) = n
-  show (QN ns n) = joinBy "." ns ++ "." ++ n
-
-public export
-Interpolation QName where
-  interpolate = show
-
-export
-Ord QName where
-  compare (QN ns nm) (QN ns' nm') = if ns == ns' then compare nm nm' else compare ns ns'
-
-
-public export
-Name : Type
+Name : U
 Name = String
 
-public export
 data Icit = Implicit | Explicit | Auto
 
-%name Icit icit
-
-export
-Show Icit where
+instance Show Icit where
   show Implicit = "Implicit"
   show Explicit = "Explicit"
   show Auto = "Auto"
 
-public export
 data BD = Bound | Defined
 
-public export
-Eq BD where
+instance Eq BD where
   Bound == Bound = True
   Defined == Defined = True
   _ == _ = False
 
-public export
-Show BD where
+instance Show BD where
   show Bound = "bnd"
   show Defined = "def"
 
-public export
 data Quant = Zero | Many
 
-public export
-Show Quant where
+instance Show Quant where
   show Zero = "0 "
   show Many = ""
 
-Eq Quant where
+instance Eq Quant where
   Zero == Zero = True
   Many == Many = True
   _ == _ = False
 
 -- We could make this polymorphic and use for environment...
-public export
-data BindInfo : Type where
+
+data BindInfo : U where
   BI : (fc : FC) -> (name : Name) -> (icit : Icit) -> (quant : Quant) -> BindInfo
 
-%name BindInfo bi
-
-public export
-HasFC BindInfo where
+instance HasFC BindInfo where
   getFC (BI fc _ _ _) = fc
 
-public export
-data Tm : Type
+Tm : U
 
-public export
 data Literal = LString String | LInt Int | LChar Char
 
-%name Literal lit
-
-public export
-Show Literal where
+instance Show Literal where
   show (LString str) = show str
   show (LInt i) = show i
   show (LChar c) = show c
 
-public export
-data CaseAlt : Type where
+data CaseAlt : U where
   CaseDefault : Tm -> CaseAlt
   CaseCons : (name : QName) -> (args : List String) -> Tm ->  CaseAlt
   CaseLit : Literal -> Tm ->  CaseAlt
 
-data Def : Type
+Def : U
 
-
-public export
-Eq Literal where
+instance Eq Literal where
   LString x == LString y = x == y
   LInt x == LInt y = x == y
   LChar x == LChar y = x == y
   _ == _ = False
 
-data Tm : Type where
-  Bnd : FC -> Nat -> Tm
+data Tm : U where
+  Bnd : FC -> Int -> Tm
   -- Maybe Def here instead of Maybe Tm, we'll have DCon, TCon, etc.
-  Ref : FC -> QName -> Def -> Tm
-  Meta : FC -> Nat -> Tm
-  -- kovacs optimization, I think we can App out meta instead
-  -- InsMeta : Nat -> List BD -> Tm
+  Ref : FC -> QName -> Tm
+  Meta : FC -> QName -> Tm
   Lam : FC -> Name -> Icit -> Quant -> Tm -> Tm
   App : FC -> Tm -> Tm -> Tm
   UU   : FC -> Tm
@@ -132,16 +84,13 @@ data Tm : Type where
   -- need type?
   Let : FC -> Name -> Tm -> Tm -> Tm
   -- for desugaring where
-  LetRec : FC -> Name -> Tm -> Tm -> Tm -> Tm
+  LetRec : FC -> Name -> (ty : Tm) -> (t : Tm) -> (u : Tm) -> Tm
   Lit : FC -> Literal -> Tm
   Erased : FC -> Tm
 
-%name Tm t, u, v
-
-export
-HasFC Tm where
+instance HasFC Tm where
   getFC (Bnd fc k) = fc
-  getFC (Ref fc str x) = fc
+  getFC (Ref fc str) = fc
   getFC (Meta fc k) = fc
   getFC (Lam fc str _ _ t) = fc
   getFC (App fc t u) = fc
@@ -153,21 +102,11 @@ HasFC Tm where
   getFC (LetRec fc _ _ _ _) = fc
   getFC (Erased fc) = fc
 
-covering
-Show Tm
+showCaseAlt : CaseAlt → String
 
-public export
-covering
-Show CaseAlt where
-  show (CaseDefault tm) = "_ => \{show tm}"
-  show (CaseCons nm args tm) = "\{show nm} \{unwords args} => \{show tm}"
-  show (CaseLit lit tm) = "\{show lit} => \{show tm}"
-
-public export
-covering
-Show Tm where
+instance Show Tm where
   show (Bnd _ k) = "(Bnd \{show k})"
-  show (Ref _ str _) = "(Ref \{show str})"
+  show (Ref _ str) = "(Ref \{show str})"
   show (Lam _ nm icit rig t) = "(\\ \{show rig}\{nm}  => \{show  t})"
   show (App _ t u) = "(\{show t} \{show u})"
   show (Meta _ i) = "(Meta \{show i})"
@@ -176,61 +115,67 @@ Show Tm where
   show (Pi _ str Explicit rig t u) = "(Pi (\{show rig}\{str} : \{show t}) => \{show u})"
   show (Pi _ str Implicit rig t u) = "(Pi {\{show rig}\{str} : \{show t}} => \{show u})"
   show (Pi _ str Auto rig t u) = "(Pi {{\{show rig}\{str} : \{show t}}} => \{show u})"
-  show (Case _ sc alts) = "(Case \{show sc} \{show alts})"
+  show (Case _ sc alts) = "(Case \{show sc} \{show $ map showCaseAlt   alts})"
   show (Let _ nm t u) = "(Let \{nm} \{show t} \{show u})"
   show (LetRec _ nm ty t u) = "(LetRec \{nm} : \{show ty} \{show t} \{show u})"
   show (Erased _) = "ERASED"
 
-public export
+
+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
 
 -- I can't really show val because it's HOAS...
 
 -- TODO derive
-export
-Eq Icit where
+
+instance Eq Icit where
   Implicit == Implicit = True
   Explicit == Explicit = True
   Auto == Auto = True
   _ == _ = False
 
-||| Eq on Tm. We've got deBruijn indices, so I'm not comparing names
-export
-Eq (Tm) where
+-- Eq on Tm. We've got deBruijn indices, so I'm not comparing names
+
+instance Eq (Tm) where
   -- (Local x) == (Local y) = x == y
   (Bnd _ x) == (Bnd _ y) = x == y
-  (Ref _ x _) == Ref _ y _ = x == y
+  (Ref _ x) == Ref _ y = x == y
   (Lam _ n _ _ t) == Lam _ n' _ _ t' = t == t'
   (App _ t u) == App _ t' u' = t == t' && u == u'
   (UU _) == (UU _) = True
   (Pi _ n icit rig t u) == (Pi _ n' icit' rig' t' u') = icit == icit' && rig == rig' && t == t' && u == u'
   _ == _ = False
 
-
-
 -- TODO App and Lam should have <+/> but we need to fix
 -- INFO pprint to `nest 2 ...`
 -- maybe return Doc and have an Interpolation..
 -- If we need to flatten, case is going to get in the way.
 
-pprint' : Nat -> List String -> Tm -> Doc
-pprintAlt : Nat -> List String -> CaseAlt -> Doc
+pprint' : Int -> List String -> Tm -> Doc
+pprintAlt : Int -> List String -> CaseAlt -> Doc
 pprintAlt p names (CaseDefault t) = text "_" <+> text "=>" <+> pprint' p ("_" :: names) t
 pprintAlt p names (CaseCons name args t) = text (show name) <+> spread (map text args) <+> (nest 2 $ text "=>" <+/> pprint' p (reverse args ++ names) t)
 -- `;` is not in surface syntax, but sometimes we print on one line
 pprintAlt p names (CaseLit lit t) = text (show lit) <+> (nest 2 $ text "=>" <+/> pprint' p names t ++ text ";")
 
-parens : Nat -> Nat -> Doc -> Doc
+parens : Int -> Int -> Doc -> Doc
 parens a b doc = if a < b
   then text "(" ++ doc ++ text ")"
   else doc
 
-pprint' p names (Bnd _ k) = case getAt k names of
+pprint' p names (Bnd _ k) = case getAt (cast k) names of
   -- Either a bug or we're printing without names
   Nothing => text "BND:\{show k}"
   Just nm => text "\{nm}:\{show k}"
-pprint' p names (Ref _ str mt) = text (show str)
+pprint' p names (Ref _ str) = text (show str)
 pprint' p names (Meta _ k) = text "?m:\{show k}"
 pprint' p names (Lam _ nm icit quant t) = parens 0 p $ nest 2 $ text "\\ \{show quant}\{nm} =>" <+/> pprint' 0 (nm :: names) t
 pprint' p names (App _ t u) = parens 0 p $ pprint' 0 names t <+> pprint' 1 names u
@@ -250,12 +195,12 @@ pprint' p names (Let _ nm t u) = parens 0 p $ text "let" <+> text nm <+> text ":
 pprint' p names (LetRec _ nm ty t u) = parens 0 p $ text "letrec" <+> text nm <+> text ":" <+> pprint' 0 names ty <+> text ":=" <+> pprint' 0 names t <+> text "in" </> (nest 2 $ pprint' 0 (nm :: names) u)
 pprint' p names (Erased _) = text "ERASED"
 
-||| Pretty printer for Tm.
-export
+-- Pretty printer for Tm.
+
 pprint : List String -> Tm -> Doc
 pprint names tm = pprint' 0 names tm
 
-data Val : Type
+Val : U
 
 -- IS/TypeTheory.idr is calling this a Kripke function space
 -- Yaffle, IS/TypeTheory use a function here.
@@ -267,18 +212,16 @@ data Val : Type
 
 -- Yaffle is vars -> vars here
 
-public export
-data Closure : Type
+Closure : U
 
-public export
-data Val : Type where
+data Val : U where
   -- This will be local / flex with spine.
-  VVar : FC -> (k : Nat) -> (sp : SnocList Val) -> Val
-  VRef : FC -> (nm : QName) -> Def -> (sp : SnocList Val) -> Val
+  VVar : FC -> (k : Int) -> (sp : SnocList Val) -> Val
+  VRef : FC -> (nm : QName) -> (sp : SnocList Val) -> Val
   -- neutral case
   VCase : FC -> (sc : Val) -> List CaseAlt -> Val
   -- we'll need to look this up in ctx with IO
-  VMeta : FC -> (ix : Nat) -> (sp : SnocList Val) -> Val
+  VMeta : FC -> QName -> (sp : SnocList Val) -> Val
   VLam : FC -> Name -> Icit -> Quant -> Closure -> Val
   VPi : FC -> Name -> Icit -> Quant -> (a : Val) -> (b : Closure) -> Val
   VLet : FC -> Name -> Val -> Val -> Val
@@ -287,20 +230,16 @@ data Val : Type where
   VErased : FC -> Val
   VLit : FC -> Literal -> Val
 
-public export
-Env : Type
+Env : U
 Env = List Val
 
-public export
 data Mode = CBN | CBV
 
-public export
 data Closure = MkClosure Env Tm
 
-public export
 getValFC : Val -> FC
 getValFC (VVar fc _ _) = fc
-getValFC (VRef fc _ _ _) = fc
+getValFC (VRef fc _ _) = fc
 getValFC (VCase fc _ _) = fc
 getValFC (VMeta fc _ _) = fc
 getValFC (VLam fc _ _ _ _) = fc
@@ -311,24 +250,20 @@ getValFC (VLit fc _) = fc
 getValFC (VLet fc _ _ _) = fc
 getValFC (VLetRec fc _ _ _ _) = fc
 
+instance HasFC Val where getFC = getValFC
 
-public export
-HasFC Val where getFC = getValFC
+showClosure : Closure → String
 
-Show Closure
-
-covering
-export
-Show Val where
-  show (VVar _ k [<]) = "%var\{show k}"
-  show (VVar _ k sp) = "(%var\{show k} \{unwords $ map show (sp <>> [])})"
-  show (VRef _ nm _ [<]) = show nm
-  show (VRef _ nm _ sp) = "(\{show nm} \{unwords $ map show (sp <>> [])})"
-  show (VMeta _ ix sp) = "(%meta \{show ix} [\{show $ length sp} sp])"
-  show (VLam _ str icit quant x) = "(%lam \{show quant}\{str} \{show x})"
-  show (VPi fc str Implicit rig x y) = "(%pi {\{show rig} \{str} : \{show  x}}. \{show  y})"
-  show (VPi fc str Explicit rig x y) = "(%pi (\{show rig} \{str} : \{show  x}). \{show  y})"
-  show (VPi fc str Auto rig x y) = "(%pi {{\{show rig} \{str} : \{show  x}}}. \{show  y})"
+instance Show Val where
+  show (VVar _ k Lin) = "%var\{show k}"
+  show (VVar _ k sp) = "(%var\{show k} \{unwords $ map show (sp <>> Nil)})"
+  show (VRef _ nm Lin) = show nm
+  show (VRef _ nm sp) = "(\{show nm} \{unwords $ map show (sp <>> Nil)})"
+  show (VMeta _ ix sp) = "(%meta \{show ix} (\{show $ snoclen sp} sp :: Nil))"
+  show (VLam _ str icit quant x) = "(%lam \{show quant}\{str} \{showClosure x})"
+  show (VPi fc str Implicit rig x y) = "(%pi {\{show rig} \{str} : \{show  x}}. \{showClosure  y})"
+  show (VPi fc str Explicit rig x y) = "(%pi (\{show rig} \{str} : \{show  x}). \{showClosure  y})"
+  show (VPi fc str Auto rig x y) = "(%pi {{\{show rig} \{str} : \{show  x}}}. \{showClosure  y})"
   show (VCase fc sc alts) = "(%case \{show sc} ...)"
   show (VU _) = "U"
   show (VLit _ lit) = show lit
@@ -336,59 +271,55 @@ Show Val where
   show (VLetRec _ nm ty a b) = "(%letrec \{show nm} : \{show ty} = \{show a} in \{show b}"
   show (VErased _) = "ERASED"
 
-covering
-Show Closure where
-  show (MkClosure xs t) = "(%cl [\{show $ length xs} env] \{show t})"
 
-record Context
+showClosure (MkClosure xs t) = "(%cl (\{show $ length xs} env :: Nil) \{show t})"
+
+-- instance Show Closure where
+--   show = showClosure
+
+Context : U
 
-public export
 data MetaKind = Normal | User | AutoSolve
 
-public export
-Show MetaKind where
+instance Show MetaKind where
   show Normal = "Normal"
   show User = "User"
   show AutoSolve = "Auto"
 
-public export
-Eq MetaKind where
-  a == b = show a == show b
-
-
 -- constrain meta applied to val to be a val
-public export
+
 data MConstraint = MkMc FC Env (SnocList Val) Val
 
-public export
-data MetaEntry = Unsolved FC Nat Context Val MetaKind (List MConstraint) | Solved FC Nat Val
+data MetaEntry
+  = Unsolved FC QName Context Val MetaKind (List MConstraint)
+  | Solved FC QName Val
+  | OutOfScope
 
-public export
+-- The purpose of this is to only check one level of constraints when trying an Auto solution
+-- The idea being we narrow it down to the likely solution, and let any consequent type error
+-- bubble up to the user, rather than have a type error wipe out all solutions.
+-- We also don't bother adding constraints if not in CheckAll mode
 data MetaMode = CheckAll | CheckFirst | NoCheck
 
-public export
 record MetaContext where
   constructor MC
-  metas : List MetaEntry
-  next : Nat
+  metas : SortedMap QName MetaEntry
+  next : Int
   mcmode : MetaMode
 
-public export
-data Def = Axiom | TCon (List QName) | DCon Nat QName | Fn Tm | PrimTCon
-         | PrimFn String (List String)
+data Def = Axiom | TCon Int (List QName) | DCon Int QName | Fn Tm | PrimTCon Int
+         | PrimFn String (List QName)
 
-public export
-covering
-Show Def where
+instance Show Def where
   show Axiom = "axiom"
-  show (TCon strs) = "TCon \{show strs}"
+  show (TCon _ strs) = "TCon \{show strs}"
   show (DCon k tyname) = "DCon \{show k} \{show tyname}"
   show (Fn t) = "Fn \{show t}"
-  show (PrimTCon) = "PrimTCon"
+  show (PrimTCon _) = "PrimTCon"
   show (PrimFn src used) = "PrimFn \{show src} \{show used}"
 
-||| entry in the top level context
-public export
+-- entry in the top level context
+
 record TopEntry where
   constructor MkEntry
   fc : FC
@@ -398,202 +329,204 @@ record TopEntry where
 
 -- FIXME snoc
 
-export
-covering
-Show TopEntry where
-  show (MkEntry fc name type def) = "\{name} : \{show type} := \{show def}"
+instance Show TopEntry where
+  show (MkEntry fc name type def) = "\{show name} : \{show type} := \{show def}"
+
+record ModContext where
+  constructor MkModCtx
+  modDefs : SortedMap QName TopEntry
+  -- Do we need this if everything solved is zonked?
+  modMetaCtx : MetaContext
+  -- longer term maybe drop this, put the operator decls in ctxDefs and collect them on import
+  ctxOps : Operators
+
+-- Top level context.
+-- Most of the reason this is separate is to have a different type
+-- `Def` for the entries.
+--
+-- The price is that we have names in addition to levels. Do we want to
+-- expand these during normalization?
+
+-- A placeholder while walking through dependencies of a module
+emptyModCtx : ModContext
+emptyModCtx = MkModCtx EmptyMap (MC EmptyMap 0 NoCheck) EmptyMap
 
-||| Top level context.
-||| Most of the reason this is separate is to have a different type
-||| `Def` for the entries.
-|||
-||| The price is that we have names in addition to levels. Do we want to
-||| expand these during normalization?
-public export
 record TopContext where
   constructor MkTop
-  -- We'll add a map later?
+  -- maybe we use a String instead of List String for the left of QN
+  -- I'm putting a dummy entry in
+  modules : SortedMap (List String) ModContext
+  imported : List (List String)
+
+  -- current module
+  ns : List String
   defs : SortedMap QName TopEntry
   metaCtx : IORef MetaContext
-  verbose : Bool -- command line flag
+
+  -- Global values
+  verbose : Int -- command line flag
   errors : IORef (List Error)
-  ||| loaded modules
-  loaded : List String
+  -- what do we do here? we can accumulate for now, but we'll want to respect import
   ops : Operators
 
 -- we'll use this for typechecking, but need to keep a TopContext around too.
-public export
+
 record Context where
-  [noHints]
   constructor MkCtx
-  lvl : Nat
+  lvl : Int
   -- shall we use lvl as an index?
   env : Env                  -- Values in scope
-  types : Vect lvl (String, Val) -- types and names in scope
+  types : List (String × Val) -- types and names in scope
   -- so we'll try "bds" determines length of local context
-  bds : Vect lvl BD          -- bound or defined
+  bds : List BD          -- bound or defined
 
   -- FC to use if we don't have a better option
   ctxFC : FC
 
-%name Context ctx
+-- add a binding to environment
 
-||| add a binding to environment
-export
 extend : Context -> String -> Val -> Context
-extend ctx name ty =
-    { lvl $= S, env $= (VVar emptyFC ctx.lvl [<] ::), types $= ((name, ty) ::), bds $= (Bound ::) } ctx
+extend (MkCtx lvl env types bds ctxFC) name ty =
+  MkCtx (1 + lvl) (VVar emptyFC lvl Lin :: env) ((name,ty) :: types) (Bound :: bds) ctxFC
 
 -- I guess we define things as values?
-export
+
 define : Context -> String -> Val -> Val -> Context
-define ctx name val ty =
-  { lvl $= S, env $= (val ::), types $= ((name,ty) ::), bds $= (Defined ::) } ctx
+define (MkCtx lvl env types bds ctxFC) name val ty =
+  MkCtx (1 + lvl) (val :: env) ((name,ty) :: types) (Defined :: bds) ctxFC
 
-
-export
-covering
-Show MetaEntry where
+instance Show MetaEntry where
   show (Unsolved pos k ctx ty kind constraints) = "Unsolved \{show pos} \{show k} \{show kind} : \{show ty} \{show ctx.bds} cs \{show $ length constraints}"
   show (Solved _ k x) = "Solved \{show k} \{show x}"
+  show OutOfScope = "OutOfScope"
 
-export
 withPos : Context -> FC -> Context
-withPos ctx fc = { ctxFC := fc } ctx
+withPos (MkCtx lvl env types bds ctxFC) fc = (MkCtx lvl env types bds fc)
 
-export
 names : Context -> List String
-names ctx = toList $ map fst ctx.types
+names ctx = map fst ctx.types
 
 -- public export
--- M : Type -> Type
+-- M : U -> U
 -- M = (StateT TopContext (EitherT Error IO))
 
-public export
 record M a where
   constructor MkM
-  runM : TopContext -> IO (Either Error (TopContext, a))
+  runM : TopContext -> IO (Either Error (TopContext × a))
 
-export
-Functor M where
+instance Functor M where
   map f (MkM run) = MkM $ \tc => do
-    result <- run tc
-    case result of
-      Left err => pure $ Left err
-      Right (tc', a) => pure $ Right (tc', f a)
+    (Right (tc', a))  <- (run tc)
+      | Left err => pure $ Left err
+    pure $ Right (tc', f a)
 
-export
-Applicative M where
-  pure x = MkM $ \tc => pure $ Right (tc, x)
+instance Applicative M where
+  return x = MkM $ \tc => pure $ Right (tc, x)
   (MkM f) <*> (MkM x) = MkM $ \tc => do
-    resultF <- f tc
-    case resultF of
-      Left err => pure $ Left err
-      Right (tc', f') => do
-        resultX <- x tc'
-        case resultX of
-          Left err => pure $ Left err
-          Right (tc'', x') => pure $ Right (tc'', f' x')
+    Right (tc', f') <- f tc
+      | Left err => pure $ Left err
+    Right (tc'', x') <- x tc'
+      | Left err => pure $ Left err
+    pure $ Right (tc'', f' x')
 
-export
-Monad M where
-  (MkM x) >>= f = MkM $ \tc => do
-    resultX <- x tc
-    case resultX of
-      Left err => pure $ Left err
-      Right (tc', a) => runM (f a) tc'
+instance Monad M where
+  pure = return
+  bind (MkM x) f = MkM $ \tc => do
+    (Right (tc', a)) <- x tc
+      | Left err => pure $ Left err
+    .runM (f a) tc'
 
-export
-HasIO M where
+instance HasIO M where
   liftIO io = MkM $ \tc => do
     result <- io
     pure $ Right (tc, result)
 
-export
-throwError : Error -> M a
+throwError : ∀ a. Error -> M a
 throwError err = MkM $ \_ => pure $ Left err
 
-export
-catchError : M a -> (Error -> M a) -> M a
+catchError : ∀ a. M a -> (Error -> M a) -> M a
 catchError (MkM ma) handler = MkM $ \tc => do
-  result <- ma tc
-  case result of
-    Left err => runM (handler err) tc
-    Right (tc', a) => pure $ Right (tc', a)
+  (Right (tc', a)) <- ma tc
+    | Left err => .runM (handler err) tc
+  pure $ Right (tc', a)
 
-export
-tryError : M a -> M (Either Error a)
-tryError ma = catchError (map Right ma) (pure . Left)
+tryError : ∀ a. M a -> M (Either Error a)
+tryError ma = catchError (map Right ma) (pure ∘ Left)
 
-export
-get : M TopContext
-get = MkM $ \ tc => pure $ Right (tc, tc)
+filterM : ∀ a. (a → M Bool) → List a → M (List a)
+filterM pred Nil = pure Nil
+filterM pred (x :: xs) = do
+  check <- pred x
+  if check then _::_ x <$> filterM pred xs else filterM pred xs
 
-export
-put : TopContext -> M Unit
-put tc = MkM $ \_ => pure $ Right (tc, MkUnit)
 
-export
-modify : (TopContext -> TopContext) -> M Unit
-modify f = do
-  tc <- get
-  put (f tc)
+getTop : M TopContext
+getTop = MkM $ \ tc => pure $ Right (tc, tc)
 
-||| Force argument and print if verbose is true
-export
+putTop : TopContext -> M Unit
+putTop tc = MkM $ \_ => pure $ Right (tc, MkUnit)
+
+modifyTop : (TopContext -> TopContext) -> M Unit
+modifyTop f = do
+  tc <- getTop
+  putTop (f tc)
+
+-- Force argument and print if verbose is true
+
+log : Int -> Lazy String -> M Unit
+log lvl x = do
+  top <- getTop
+  when (lvl <= top.verbose) $ \ _ => putStrLn $ force x
+
+logM : Int → M String -> M Unit
+logM lvl x = do
+  top <- getTop
+  when (lvl <= top.verbose) $ \ _ => do
+    msg <- x
+    putStrLn msg
+
+-- deprecated for `log 2`
 debug : Lazy String -> M Unit
-debug x = do
-  top <- get
-  when top.verbose $ putStrLn $ Force x
+debug x = log 2 x
 
-export
 info : FC -> String -> M Unit
 info fc msg = putStrLn "INFO at \{show fc}: \{msg}"
 
-||| Version of debug that makes monadic computation lazy
-export
-debugM : M String -> M Unit
-debugM x = do
-  top <- get
-  when top.verbose $ do putStrLn !(x)
+-- Version of debug that makes monadic computation lazy
 
-export
-Show Context where
+debugM : M String -> M Unit
+debugM x = logM 2 x
+
+instance Show Context where
   show ctx = "Context \{show $ map fst $ ctx.types}"
 
-export
 errorMsg : Error -> String
 errorMsg (E x str) = str
 errorMsg (Postpone x k str) = str
 
-export
-HasFC Error where
+instance HasFC Error where
   getFC (E x str) = x
   getFC (Postpone x k str) = x
 
-export
-error : FC -> String -> M a
+error : ∀ a. FC -> String -> M a
 error fc msg = throwError $ E fc msg
 
-export
-error' : String -> M a
+error' : ∀ a. String -> M a
 error' msg = throwError $ E emptyFC msg
 
+lookupMeta : QName -> M MetaEntry
+lookupMeta ix@(QN ns nm) = do
+  top <- getTop
+  mc <- readIORef {M} top.metaCtx
+  case lookupMap' ix mc.metas of
+    Just meta => pure meta
+    Nothing => case lookupMap' ns top.modules of
+      Nothing =>
+          error emptyFC "missing module: \{show ns}"
+      Just mod => case lookupMap' ix mod.modMetaCtx.metas of
+        Nothing =>
+          error emptyFC "missing meta: \{show ix}"
+        Just entry => pure entry
 
-export
-lookupMeta : Nat -> M MetaEntry
-lookupMeta ix = do
-  top <- get
-  mc <- readIORef top.metaCtx
-  go mc.metas
-  where
-    go : List MetaEntry -> M MetaEntry
-    go [] = error' "Meta \{show ix} not found"
-    go (meta@(Unsolved _ k ys _ _ _) :: xs) = if k == ix then pure meta else go xs
-    go (meta@(Solved _ k x) :: xs) = if k == ix then pure meta else go xs
-
--- we need more of topcontext later - Maybe switch it up so we're not passing
--- around top
-export
 mkCtx : FC -> Context
-mkCtx fc = MkCtx 0 [] [] [] fc
+mkCtx fc = MkCtx 0 Nil Nil Nil fc

src/Lib/Util.idr

@@ -1,28 +0,0 @@
-module Lib.Util
-
-import Lib.Types
-
-export
-funArgs : Tm -> (Tm, List Tm)
-funArgs tm = go tm []
-  where
-    go : Tm -> List Tm -> (Tm, List Tm)
-    go (App _ t u) args = go t (u :: args)
-    go t args = (t, args)
-
-public export
-data Binder : Type where
-  MkBinder : FC -> String -> Icit -> Quant -> Tm -> Binder
-
--- I don't have a show for terms without a name list
-export
-Show Binder where
-  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 (MkBinder fc nm icit quant t :: ts) u
-    go ts tm = (tm, reverse ts)

src/Lib/Util.newt

@@ -0,0 +1,58 @@
+module Lib.Util
+
+import Prelude
+import Lib.Common
+import Lib.Types
+import Data.List1
+
+-- pi arity is primitive functions
+piArity : Tm -> Nat
+piArity (Pi _ _ _ quant _ b) = S (piArity b)
+piArity _ = Z
+
+funArgs : Tm -> (Tm × List Tm)
+funArgs tm = go tm Nil
+  where
+    go : Tm -> List Tm -> (Tm × List Tm)
+    go (App _ t u) args = go t (u :: args)
+    go t args = (t, args)
+
+data Binder : U where
+  MkBinder : FC -> String -> Icit -> Quant -> Tm -> Binder
+
+-- I don't have a show for terms without a name list
+
+instance Show Binder where
+  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 (MkBinder fc nm icit quant t :: ts) u
+    go ts tm = (tm, reverse ts)
+
+
+
+getBaseDir : String → String → M (String × QName)
+getBaseDir fn modName = do
+  let (path, modName') = unsnoc $ split1 modName "."
+  let parts = split1 fn "/"
+  let (dirs,file) = unsnoc parts
+  let (name, ext) = splitFileName file
+
+  let parts = split1 fn "/"
+  let (dirs,file) = unsnoc parts
+  let (path, modName') = unsnoc $ split1 modName "."
+  unless (modName' == name) $ \ _ => error (MkFC fn (0,0)) "module name \{modName'} doesn't match \{name}"
+  let (Right base) = baseDir (Lin <>< dirs) (Lin <>< path)
+    | Left err => error (MkFC fn (0,0)) err
+  let base = if base == "" then "." else base
+  pure (base, QN path modName')
+  where
+    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"