more test cases, problem in Tree.newt

README.md

@@ -38,12 +38,15 @@ I have `Let` in the core language. Partly because I'd like this to make it into
 
 I've got no idea what I'm doing here. I worked off of Jesper Cockx "Elaborating Dependent (Co)pattern Matching", leaving out codata for now.
 
-For the dependent thing, I've change unify to return `VVar` constraints. I think this is an error typechecking on
-RHS (meta solutions are handled separately). On the LHS, I'm rewriting the environment to turn the var from a bind
-to a define. Unification has been tweaked to look up `VVar` in environment. Bind will hand back the same `VVar`.
+For the dependent thing, I've change unify to return `VVar` constraints. I think such constraints would be an error while typechecking on RHS (meta solutions are handled separately). On the LHS, I'm rewriting the environment to turn the var from a bind to a define. Unification has been tweaked to look up `VVar` in environment. Bind will hand back the same `VVar`.
 
-Some of this I could probably do with subst, but the RHS is `Raw`, it takes typechecking to turn it into a clean `Tm`,
-and I need this information for the typechecking.
+Some of this I could probably do with subst, but the RHS is `Raw`, it takes typechecking to turn it into a clean `Tm`, and I need this information for the typechecking.  To substitute into the goal type for the RHS, I am now
+doing a quote and eval to get case to expand. This is a bit of a stopgap because case is only eval'd when going
+from `Tm` to `Val`. I think I'll need a way to eval a VCase during unification, as we do with function applications.
+
+## Evaluation
+
+Following kovacs, I'm putting `VVar` into context env when I go under binders. This avoids substitution.
 
 ## Issues
 

TODO.md

@@ -30,6 +30,7 @@
     - keep as implicit and do auto if the type constructor is flagged auto
     - keep as implicit and mark auto, behavior overlaps a lot with implicit
     - have separate type of implict with `{{}}`
+    - `TypeClass.newt` is the exercise for this
 - [ ] do blocks
 - [ ] some solution for `+` problem (classes? ambiguity?)
 - [x] show compiler failure in the editor (exit code != 0)

newt-vscode/language-configuration.json

@@ -26,5 +26,13 @@
         ["(", ")"],
         ["\"", "\""],
         ["'", "'"]
+    ],
+    "onEnterRules": [
+      {
+        "beforeText": "^\\s+$",
+        "action": {
+          "indent": "outdent"
+        }
+      }
     ]
-}
+}

newt/Tree.newt

@@ -0,0 +1,70 @@
+module Tree
+
+-- https://youtu.be/v2yXrOkzt5w?t=3013
+
+data Nat : U where
+  Z : Nat
+  S : Nat -> Nat
+
+data Unit : U where
+  MkUnit : Unit
+
+data Void : U where
+
+infixl 4 _+_
+
+data _+_ : U -> U -> U where
+  inl : {A B : U} -> A -> A + B
+  inr : {A B : U} -> B -> A + B
+
+infix 4 _<=_
+
+_<=_ : Nat -> Nat -> U
+Z <= y = Unit
+S x <= Z = Void
+S x <= S y = x <= y
+
+cmp : (x y : Nat) -> (x <= y) + (y <= x)
+cmp Z y = inl MkUnit
+cmp (S z) Z = inr MkUnit
+cmp (S x) (S y) = cmp x y
+
+-- 53:21
+
+data Bnd : U where
+  Bot : Bnd
+  N : Nat -> Bnd
+  Top : Bnd
+
+infix 4 _<<=_
+
+_<<=_ : Bnd -> Bnd -> U
+Bot <<= _ = Unit
+N x <<= N y = x <= y
+_ <<= Top = Unit
+_ <<= _ = Void
+
+data Intv : Bnd -> Bnd -> U where
+  MkInt : {l u : Bnd} (x : Nat) (lx : l <<= N x) (xu : N x <<= u) -> Intv l u
+
+data T23 : Bnd -> Bnd -> Nat -> U where
+  leaf : {l u : Bnd} {h : Nat} (lu : l <<= u) -> T23 l u Z
+  node2 : {l u : Bnd} {h : Nat} (x : _)
+    (tlx : T23 l (N x) h) (txu : T23 (N x) u h) ->
+    T23 l u (S h)
+  node3 : {l u : Bnd} {h : Nat} (x y : _)
+    (tlx : T23 l (N x) h) (txy : T23 (N x) (N y) h) (tyu : T23 (N y) u h) ->
+    T23 l u (S h)
+
+-- -- 56:
+
+infixl 5 _*_
+infixl 1 _,_
+data Sg : (A : U) -> (A -> U) -> U where
+  _,_ : {A : U} {B : A -> U} -> (a : A) -> B a -> Sg A B
+
+data _*_ : (A B : U) -> U where
+   Foo : {A B : U} -> A -> B -> A * B
+
+TooBig : Bnd -> Bnd -> Nat -> U
+TooBig l u h = Sg Nat (\ x => T23 l (N x) h * T23 (N x) u h)

src/Lib/Elab.idr

@@ -255,7 +255,7 @@ unifyCatch fc ctx ty' ty = do
       debug "fail \{show ty'} \{show ty}"
       a <- quote ctx.lvl ty'
       b <- quote ctx.lvl ty
-      let msg = "unification failure\n  failed to unify \{pprint names a}\n    with \{pprint names b}\n  " <+> str
+      let msg = "unification failure: \{str}\n  failed to unify \{pprint names a}\n    with \{pprint names b}\n  "
       throwError (E fc msg)
     case res of
       MkResult [] => pure ()
@@ -402,7 +402,7 @@ forcedName ctx nm = case lookupName ctx nm of
 -- return Nothing if dcon doesn't unify with scrut
 buildCase : Context -> Problem -> String -> Val -> (String, Nat, Tm) -> M (Maybe CaseAlt)
 buildCase ctx prob scnm scty (dcName, arity, ty) = do
-  debug "CASE \{scnm} \{dcName} \{pprint (names ctx) ty}"
+  debug "CASE \{scnm} match \{dcName} ty \{pprint (names ctx) ty}"
   vty <- eval [] CBN ty
   (ctx', ty', vars, sc) <- extendPi ctx (vty) [<] [<]
 
@@ -573,6 +573,15 @@ checkDone ctx [] body ty = do
   debugM $ dumpCtx ctx
   debug "ENV \{show ctx.env}"
   debug "TY \{show ctx.types}"
+  -- I'm running an eval here to run case statements that are
+  -- unblocked by lets in the env. (Tree.newt:cmp)
+  -- The case eval code only works in the Tm -> Val case at the moment.
+  -- we don't have anything like `vapp`
+  -- NOW In Tree.newt we have a case/case unification that might
+  -- have succeeded if it was left as a functino call.
+  ty <- quote (length ctx.env) ty
+  ty <- eval ctx.env CBV ty
+  debug "check at \{show ty}"
   got <- check ctx body ty
   debug "DONE<- got \{pprint (names ctx) got}"
   pure got
@@ -602,7 +611,6 @@ buildTree ctx prob@(MkProb ((MkClause fc cons (x :: xs) expr) :: cs) (VPi _ str
   Lam fc nm <$> buildTree ctx' ({ clauses := clauses, ty := vb } prob)
 buildTree ctx prob@(MkProb ((MkClause fc cons pats@(x :: xs) expr) :: cs) ty) =
   error fc "Extra pattern variables \{show pats}"
-buildTree ctx prob@(MkProb ((MkClause fc [] [] expr) :: cs) ty) = check (withPos ctx fc) expr ty
 -- need to find some name we can split in (x :: xs)
 -- so LHS of constraint is name (or VVar - if we do Val)
 -- then run the split

src/Lib/Eval.idr

@@ -56,7 +56,11 @@ evalCase env mode sc@(VRef _ nm y sp) (cc@(CaseCons name nms t) :: xs) =
     go env [<] rest = pure Nothing
 
 evalCase env mode sc (CaseDefault u :: xs) = pure $ Just !(eval (sc :: env) mode u)
-evalCase env mode sc _ = pure Nothing
+evalCase env mode sc cc = do
+  debug "CASE BAIL sc \{show sc} vs \{show cc}"
+  debug "env is \{show env}"
+  pure Nothing
+
 
 bind : Val -> Env -> Env
 bind v env = v :: env

src/Lib/Parser.idr

@@ -93,6 +93,7 @@ parseOp = parseApp >>= go 0
         let Just (p,fix) = lookup op' ops
           -- this is eaten, but we need `->` and `:=` to not be an operator to have fatal here
          | Nothing => case op of
+         -- Location is poor on these because we pull off of the remaining token list...
           "->" => fail "no infix decl for \{op}"
           ":=" => fail "no infix decl for \{op}"
           op => fatal "no infix decl for \{op}"
@@ -312,7 +313,7 @@ parseData : Parser Decl
 parseData = do
   fc <- getPos
   keyword "data"
-  name <- uident
+  name <- uident <|> token MixFix
   keyword ":"
   ty <- typeExpr
   keyword "where"

src/Lib/Types.idr

@@ -102,13 +102,12 @@ HasFC Tm where
 covering
 Show Tm
 
-covering
+public export covering
 Show CaseAlt where
   show (CaseDefault tm) = "_ => \{show tm}"
   show (CaseCons nm args tm) = "\{nm} \{unwords args} => \{show tm}"
 
--- public export
-covering
+public export covering
 Show Tm where
   show (Bnd _ k) = "(Bnd \{show k})"
   show (Ref _ str _) = "(Ref \{show str})"

tests/black/TestCase4.newt

@@ -47,11 +47,9 @@ zipWith : {a b c : U} {m : Nat} -> (a -> b -> c) -> Vect m a -> Vect m b -> Vect
 zipWith f Nil Nil = Nil
 zipWith f (x :: xs) (y :: ys) = f x y :: zipWith f xs ys
 
--- NOW cases very broken here - empty switches
 transpose : {a : U} {m n : Nat} -> Vect m (Vect n a) -> Vect n (Vect m a)
 transpose {a} {Z} {n} Nil = vec n Nil
 transpose {a} {S z} {n} (_::_ {a'} {j} x xs) = zipWith (_::_) x (transpose xs)
--- transpose {a} {m} {n} (_::_ {a'} {j} x xs) = zipWith (_::_) x (transpose xs)
 
 ptype Int