Fix stray skolem issue

Sometimes a Bound variable on the LHS became Defined to itself.
This commit also resurfaces INFO messages, to aid finding the root
cause of errors.

src/Lib/Elab.newt

@@ -283,7 +283,7 @@ addConstraint env ix sp tm = do
   let (CheckAll) = mc.mcmode | _ => pure MkUnit
   updateMeta ix $ \case
     (Unsolved pos k a b c cons) => do
-      debug $ \ _ => "Add constraint m\{show ix} \{show sp} =?= \{show tm}"
+      debug $ \ _ => "Add constraint \{show ix} \{show sp} =?= \{show tm}"
       pure (Unsolved pos k a b c (MkMc (getFC tm) env sp tm :: cons))
     (Solved fc k tm) => error fc "Meta \{show k} already solved [addConstraint]"
     (OutOfScope) => error' "Meta \{show ix} out of scope"
@@ -391,7 +391,7 @@ solve env m sp t = do
     | _ => do
       let l = length' env
       debug $ \ _ => "meta \{show m} (\{show ix}) applied to \{show $ snoclen sp} args instead of \{show size}"
-      debug $ \ _ => "CONSTRAINT m\{show ix} \{show sp} =?= \{show t}"
+      debug $ \ _ => "CONSTRAINT \{show ix} \{show sp} =?= \{show t}"
       addConstraint env m sp t
   let l = length' env
   debug $ \ _ => "meta \{show meta}"
@@ -435,12 +435,10 @@ solve env m sp t = do
     (\case
       Postpone fc ix msg => do
         -- let someone else solve this and then check again.
-        debug $ \ _ => "CONSTRAINT2 m\{show ix} \{show sp} =?= \{show t}"
+        debug $ \ _ => "CONSTRAINT2 \{show ix} \{show sp} =?= \{show t}"
         addConstraint env m sp t
-        -- I get legit errors after stuffing in solution
+      E fc msg => throwError (E fc "\{msg} for \{show ix} \{show sp} =?= \{show t}")
-        -- report for now, tests aren't hitting this branch
+        -- debug $ \ _ => "CONSTRAINT3 \{show ix} \{show sp} =?= \{show t}"
-      err => throwError err
-        -- debug $ \ _ => "CONSTRAINT3 m\{show ix} \{show sp} =?= \{show t}"
         -- debug $ \ _ => "because \{showError "" err}"
         -- addConstraint env m sp t
         )
@@ -628,7 +626,7 @@ freshMeta ctx fc ty kind = do
   debug $ \ _ => "fresh meta \{show mc.next} : \{show ty} (\{show kind})"
   -- need the ns here
   -- we were fudging this for v1
-  let qn = QN top.ns "$m\{show mc.next}"
+  let qn = QN top.ns "\{show mc.next}"
   let newmeta = Unsolved fc qn ctx ty kind Nil
   let autos = case kind of
       AutoSolve => qn :: mc.autos
@@ -775,6 +773,9 @@ substVal k v tm = go tm
 updateContext : Context -> List (Int × Val) -> M Context
 updateContext ctx Nil = pure ctx
 updateContext ctx ((k, val) :: cs) =
+  -- We were turning Bound into Defined
+  if isSelf k val then updateContext ctx cs
+  else
   let ix = cast $ lvl2ix (length' ctx.env) k in
   case getAt ix ctx.env of
     (Just (VVar _ k' Lin)) =>
@@ -789,6 +790,10 @@ updateContext ctx ((k, val) :: cs) =
       updateContext ctx cs
     Nothing => error (getFC val) "INTERNAL ERROR: bad index in updateContext"
   where
+    isSelf : Int → Val → Bool
+    isSelf ix (VVar _ k Lin) = ix == k
+    isSelf ix _ = False
+
     replaceV : ∀ a. Nat -> a -> List a -> List a
     replaceV k x Nil = Nil
     replaceV Z x (y :: xs) = x :: xs

src/Main.newt

@@ -179,9 +179,9 @@ processModule importFC base stk qn@(QN ns nm) = do
   let modules = updateMap modns mod top.modules
   modifyTop [modules := modules]
 
+  logMetas $ reverse $ listValues top.metaCtx.metas
   let (Nil) = top.errors
     | errors => exitFailure "Compile failed"
-  logMetas $ reverse $ listValues top.metaCtx.metas
   pure src
   where
     tryProcessDecl : String -> List String → Decl -> M Unit

tests/Data

@@ -0,0 +1 @@
+../src/Data

tests/Data/SortedMap.newt

@@ -1 +0,0 @@
-../../src/Data/SortedMap.newt

tests/WellTyped.newt

@@ -0,0 +1,75 @@
+module WellTyped
+
+-- Idris2's "Well Typed Interpreter" example
+-- This is a little painful for lack of overloading.
+-- I can add idris/haskell style sections.
+-- This is revealing some issues. :/
+
+-- I had to put {0 ctxt : Vect n Ty} →  in manually, the `∀ ctxt` wasn't inferring the type.
+-- This may be because we have `n`, which becomes a parameter when do it manually.
+-- That would explain why Idris adds those...
+
+-- This also revealed an issue in case tree building where a bound name was accidentally made into a defined one.
+
+import Prelude
+import Data.Vect
+import Data.Fin
+
+data Ty = TyInt | TyBool | TyFun Ty Ty
+
+interpTy : Ty → U
+interpTy TyInt = Int
+interpTy TyBool = Bool
+interpTy (TyFun x y) = interpTy x → interpTy y
+
+data HasType : ∀ n. (i : Fin n) → Vect n Ty → Ty → U where
+  Stop : ∀ t n. {0 ctxt : Vect n Ty} → HasType FZ (t :- ctxt) t
+  Pop  : ∀ n t u. {0 ctxt : Vect n Ty} {0 k : Fin n} → HasType k ctxt t → HasType (FS k) (u :- ctxt) t
+
+data Expr : ∀ n. Vect n Ty → Ty → U where
+  Var : ∀ t n. {0 ctxt : Vect n Ty} {0 i : Fin n} → HasType i ctxt t → Expr ctxt t
+  Val : ∀ n. {0 ctxt : Vect n Ty} → (x : Int) → Expr ctxt TyInt
+  Lam : ∀ a n t. {0 ctxt : Vect n Ty} → Expr (a :- ctxt) t → Expr ctxt (TyFun a t)
+  App : ∀ n a t. {0 ctxt : Vect n Ty} → Expr ctxt (TyFun a t) → Expr ctxt a → Expr ctxt t
+  Op  : ∀ a b c n. {0 ctxt : Vect n Ty} → (interpTy a → interpTy b → interpTy c) →
+        Expr ctxt a → Expr ctxt b → Expr ctxt c
+  -- TODO Idris has Lazy on the arms, should work if we explicitly force
+  If  : ∀ n a. {0 ctxt : Vect n Ty} → Expr ctxt TyBool →
+        (Expr ctxt a) →
+        (Expr ctxt a) → Expr ctxt a
+
+infixr 4 _:::_
+data Env : ∀ n. Vect n Ty → U where
+  Empty  : Env VNil
+  _:::_ : ∀ a n. {0 ctxt : Vect n Ty} → interpTy a → Env ctxt → Env (a :- ctxt)
+
+lookup : ∀ n t. {0 ctxt : Vect n Ty} {0 i : Fin n} → HasType i ctxt t → Env ctxt → interpTy t
+lookup Stop (x ::: xs) = x
+lookup () Empty
+lookup (Pop k) (x ::: xs) = lookup k xs
+
+interp : ∀ n t. {0 ctxt : Vect n Ty} → Env ctxt → Expr ctxt t → interpTy t
+interp env (Var i)    = lookup i env
+interp env (Val x)    = x
+interp env (Lam x)    = \y => interp (y ::: env) x
+interp env (App x y)  = interp env x $ interp env y
+interp env (Op f x y) = f (interp env x) (interp env y)
+interp env (If x y z) = if interp env x then interp env y
+                                        else interp env z
+
+add : ∀ n. {0 ctxt : Vect n Ty} → Expr ctxt (TyFun TyInt (TyFun TyInt TyInt))
+add = Lam (Lam (Op _+_ (Var Stop) (Var (Pop Stop))))
+
+fact : ∀ n. {0 ctxt : Vect n Ty} → Expr ctxt (TyFun TyInt TyInt)
+-- TODO the `Bool =?= interpTy ...` is stuck on ?m14
+-- I think we may need to need to delay the constraint until m14 is solved?
+-- But I think I have code to do that already
+fact = Lam (If (Op {_} {_} {TyBool} _==_ (Var Stop) (Val 0))
+               (Val 1)
+               (Op _*_ (App fact (Op _-_ (Var Stop) (Val 1)))
+                       (Var Stop)))
+
+-- main : IO Unit
+-- main = do putStr "Enter a number: "
+--           Right x <- readLine | _ => putStrLn "EOF"
+--           printLn (interp Empty fact (stringToInt x))