Fix unification issues, add debug messages

TODO.md

@@ -1,9 +1,7 @@
 
 ## TODO
 
-I may be done with `U` - I keep typing `Type`.
+- [x] Sanitize JS idents, e.g. `_+_`
-
-- [ ] Sanitize JS idents, e.g. `_+_`
 - [ ] Generate some programs that do stuff
 - [x] import
 - [ ] consider making meta application implicit in term, so its more readable when printed
@@ -51,6 +49,13 @@ I may be done with `U` - I keep typing `Type`.
 - [ ] records / copatterns
 - [ ] vscode: syntax highlighting for String
 
+### Parsing
+
+- [ ] consider allowing σ etc in identifiers
+  - Probably need to merge oper / ident first and sort out mixfix in parsing.
+
+### Background
+
 - [ ] Read Ulf Norell thesis
 
 

newt-vscode/src/extension.ts

@@ -36,7 +36,7 @@ export function activate(context: vscode.ExtensionContext) {
 
       for (let i = 0; i < lines.length; i++) {
         const line = lines[i];
-        const match = line.match(/(INFO|ERROR) at \((\d+), (\d+)\): (.*)/);
+        const match = line.match(/(INFO|ERROR) at \((\d+), (\d+)\):\s*(.*)/);
         if (match) {
           let [_full, kind, line, column, message] = match;
           let lnum = Number(line);

src/Lib/Compile.idr

@@ -1,10 +1,4 @@
--- TODO I think I'm missing the bit where a case might need to be assigned to a variable.
+-- TODO Audit how much "outside" stuff could pile up in the continuation.
--- E.g. case statement whose result is passed to complex expression should assign a variable
--- then the stuff happens. We'd need to know more about the callback for that.
--- TODO And then get primitives and a way to declare extern functions.  That may get us
--- to utility
-
--- Audit how much "outside" stuff could pile up in the continuation.
 module Lib.Compile
 
 import Lib.Types

src/Lib/Elab.idr

@@ -77,6 +77,7 @@ parameters (ctx: Context)
           else go xs (k :: acc)
       go (xs :< v) _ = error emptyFC "non-variable in pattern \{show v}"
 
+  -- REVIEW why am I converting to Tm?
   -- we have to "lift" the renaming when we go under a lambda
   -- I think that essentially means our domain ix are one bigger, since we're looking at lvl
   -- in the codomain, so maybe we can just keep that value
@@ -88,7 +89,7 @@ parameters (ctx: Context)
       goSpine ren lvl tm [<] = pure tm
       goSpine ren lvl tm (xs :< x) = do
         xtm <- go ren lvl x
-        goSpine ren lvl (App emptyFC tm xtm) xs
+        pure $ App emptyFC !(goSpine ren lvl tm xs) xtm
 
       go ren lvl (VVar fc k sp) = case findIndex (== k) ren of
         Nothing => error fc "scope/skolem thinger"
@@ -244,7 +245,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 = "\n  failed to unify \{pprint names a}\n    with \{pprint names b}\n  " <+> str
+      let msg = "unification failure\n  failed to unify \{pprint names a}\n    with \{pprint names b}\n  " <+> str
       throwError (E fc msg)
     case res of
       MkResult [] => pure ()
@@ -255,7 +256,7 @@ unifyCatch fc ctx ty' ty = do
         a <- quote ctx.lvl ty'
         b <- quote ctx.lvl ty
         let names = toList $ map fst ctx.types
-        let msg = "\n  failed to unify \{pprint names a}\n    with \{pprint names b}"
+        let msg = "unification failure\n  failed to unify \{pprint names a}\n    with \{pprint names b}"
         throwError (E fc msg)
         -- error fc "Unification yields constraints \{show cs.constraints}"
 
@@ -404,15 +405,20 @@ buildCase ctx prob scnm scty (dcName, arity, ty) = do
   -- We get unification constraints from matching the data constructors
   -- codomain with the scrutinee type
   debug "unify dcon dom with scrut\n  \{show ty'}\n  \{show scty}"
-  Just res <- catchError {e = Error} (Just <$> unify ctx' (length ctx'.env) ty' scty) (\_ => pure Nothing)
+  Just res <- catchError {e = Error} (Just <$> unify ctx' (length ctx'.env) ty' scty)
+              (\(E _ msg) => do
+                  debug "SKIP \{dcName} because unify error \{msg}"
+                  pure Nothing)
     | _ => pure Nothing
 
   -- if the value is already constrained to a different constructor, return Nothing
   debug "scrut \{scnm} constrained to \{show $ forcedName ctx scnm}"
   let True = (case forcedName ctx scnm of
-                Just nm => nm == scnm
+                Just nm => nm == dcName
                 _ => True)
-    | _ => pure Nothing
+    | _ => do
+      debug "SKIP \{dcName} because \{show scnm} forced to \{show $ forcedName ctx scnm}"
+      pure Nothing
 
   -- Additionally, we constrain the scrutinee's variable to be
   -- dcon applied to args
@@ -571,7 +577,7 @@ buildTree ctx prob@(MkProb ((MkClause fc constraints [] expr) :: cs) ty) = do
 
   cons <- getConstructors ctx (getFC pat) scty
   alts <- traverse (buildCase ctx prob scnm scty) cons
-
+  when (length (catMaybes alts) == 0) $ error (ctx.fc) "no alts"
   -- TODO check for empty somewhere?
   pure $ Case fc sctm (catMaybes alts)
 

src/Lib/Eval.idr

@@ -102,7 +102,6 @@ quoteSp : (lvl : Nat) -> Tm -> SnocList Val -> M Tm
 quoteSp lvl t [<] = pure t
 quoteSp lvl t (xs :< x) =
   pure $ App emptyFC !(quoteSp lvl t xs) !(quote lvl x)
-  -- quoteSp lvl (App t !(quote lvl x)) xs  -- snoc says previous is right
 
 quote l (VVar fc k sp) = if k < l
   then quoteSp l (Bnd emptyFC ((l `minus` k) `minus` 1)) sp -- level to index

src/Lib/Parser.idr

@@ -73,17 +73,6 @@ pArg = do
   fc <- getPos
   (Explicit,fc,) <$> atom <|> (Implicit,fc,) <$> braces typeExpr
 
-
--- starter pack, but we'll move some to prelude
--- operators : List (String, Int, Fixity)
--- operators = [
---   ("=",2,Infix),
---   ("+",4,InfixL),
---   ("-",4,InfixL),
---   ("*",5,InfixL),
---   ("/",5,InfixL)
--- ]
-
 parseApp : Parser Raw
 parseApp = do
   fc <- getPos

src/Main.idr

@@ -71,7 +71,7 @@ loadModule base stk name = do
   (src, res) <- parseFile fn
   putStrLn "module \{res.name}"
   let True = name == res.name
-    | _ => fail "module name \{show res.name} doesn't match file name \{show fn}"
+    | _ => fail "ERROR at (0, 0): module name \{show res.name} doesn't match file name \{show fn}"
   -- TODO separate imports and detect loops / redundant
   for_ res.imports $ \ (MkImport fc name') => do
     -- we could use `fc` if it had a filename in it

tests/black/TestCase4.newt

@@ -1,4 +1,4 @@
-module Case3
+module TestCase4
 
 data Nat : U where
   Z : Nat
@@ -47,7 +47,31 @@ 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)
--- TODO Doesn't work without the (forced) Z, investigate
+transpose {a} {m} {n} Nil = vec n Nil
-transpose {a} {Z} {n} Nil = vec n Nil
+-- TODO If I put S k in here for m we get a unification error on the RHS
-transpose {a} {S k} {n} (x :: xs) = zipWith (_::_) x (transpose xs)
+transpose {a} {m} {n} (x :: xs) = zipWith (_::_) x (transpose xs)
+
+ptype Int
+
+myArr : Vect (S (S (S Z))) (Vect (S (S Z)) Int)
+myArr = (1 :: 2 :: Nil) :: (3 :: 4 :: Nil) :: (5 :: 6 :: Nil) :: Nil
+
+
+/-
+
+-- this possibly needs dynamic pattern unification
+-- It's complaining about a meta in a pattern
+data Ix : U where
+
+infixr 2 _:-:_
+data Path : (Sig : Ix -> Ix -> U) (i j : Ix) -> U where
+  Stop : {Sig : Ix -> Ix -> U} {i : Ix} -> Path Sig i i
+  _:-:_ : {Sig : Ix -> Ix -> U} {i j k : Ix} -> Sig i j -> Path Sig j k -> Path Sig i k
+
+
+pmap : {s t : Ix -> Ix -> U} -> (f : {i j : Ix} -> s i j -> t i j) -> {i j : Ix} -> Path s i j -> Path t i j
+pmap f Stop = Stop
+pmap f (s :-: ss) = f s :-: pmap f ss
+-/