add error for stray, incorrect constructors

Makefile

@@ -1,4 +1,3 @@
-OSRCS=$(shell find orig -name "*.idr")
 SRCS=$(shell find src -name "*.newt")
 
 # Node shaves off 40% of the time.
@@ -7,28 +6,8 @@ RUNJS=node
 
 .PHONY:
 
-# all: build/exec/newt build/exec/newt.js build/exec/newt.min.js newt.js
 all: newt.js
 
-# Original idris version
-
-build/exec/newt: ${OSRCS}
-	idris2 --build newt.ipkg
-
-build/exec/newt.js: ${OSRCS}
-	idris2 --cg node -o newt.js -p contrib -c orig/Main.idr
-
-build/exec/newt.min.js: ${OSRCS}
-	idris2 --cg node -o newt.min.js -p contrib -c orig/Main.idr --directive minimal
-
-orig_aoctest: build/exec/newt
-	scripts/orig_aoc
-
-orig_test: build/exec/newt
-	scripts/orig_test
-
-# New version
-
 newt.js: ${SRCS}
 	-rm build/* >/dev/null
 	$(RUNJS) bootstrap/newt.js src/Main.newt -o newt.js

src/Lib/Elab.newt

@@ -793,12 +793,6 @@ checkCase : Context → Problem → String → Val → (QName × Int × Tm) →
 checkCase ctx prob scnm scty (dcName, arity, ty) = do
   vty <- eval Nil ty
   (ctx', ty', vars, sc) <- extendPi ctx (vty) Lin Lin
-  (Just res) <- catchError (Just <$> unify ctx'.env UPattern ty' scty)
-              (\err => do
-                  debug $ \ _ => "SKIP \{show dcName} because unify error \{errorMsg err}"
-                  pure Nothing)
-    | _ => pure False
-
   (Right res) <- tryError (unify ctx'.env UPattern ty' scty)
           | Left err => do
             debug $ \ _ => "SKIP \{show dcName} because unify error \{errorMsg err}"
@@ -866,6 +860,7 @@ buildCase ctx prob scnm scty (dcName, arity, ty) = do
         (Right res) <- tryError (unify ctx'.env UPattern ty' scty)
           | Left err => do
             debug $ \ _ => "SKIP \{show dcName} because unify error \{errorMsg err}"
+            putStrLn "SKIP \{show dcName} because unify error \{errorMsg err}"
             pure Nothing
 
         -- Constrain the scrutinee's variable to be dcon applied to args
@@ -1104,10 +1099,10 @@ getLits ty nm ((MkClause fc cons pats expr) :: cs) = case find ((_==_ nm) ∘ fs
   _ => getLits ty nm cs
 
 -- collect constructors that are matched on
-matchedConstructors : String → List Clause → List QName
+matchedConstructors : String → List Clause → List (FC × QName)
 matchedConstructors nm Nil = Nil
 matchedConstructors nm ((MkClause fc cons pats expr) :: cs) = case find ((_==_ nm) ∘ fst) cons of
-  Just (_, (PatCon _ _ dcon _ _)) => dcon :: matchedConstructors nm cs
+  Just (_, (PatCon fc _ dcon _ _)) => (fc, dcon) :: matchedConstructors nm cs
   _ => matchedConstructors nm cs
 
 -- then build a lit case for each of those
@@ -1255,9 +1250,15 @@ buildTree ctx prob@(MkProb ((MkClause fc constraints Nil expr) :: cs) ty) = do
       -- default cases
       cons <- getConstructors ctx (getFC pat) scty'
       let matched = matchedConstructors scnm prob.clauses
-      let (hit,miss) = partition (flip elem matched ∘ fst) cons
+      let matched' = map snd matched
+      let (hit,miss) = partition (flip elem matched' ∘ fst) cons
       -- need to check miss is possible
       miss' <- filterM (checkCase ctx prob scnm scty') miss
+      for matched $ \case
+       (fc, qn) => do
+          if elem qn (map fst cons)
+            then pure MkUnit
+            else error fc "\{show qn} not a constructor for \{show scty}"
 
       debug $ \ _ => "CONS \{show $ map fst cons} matched \{show matched} miss \{show miss} miss' \{show miss'}"
 

tests/BadAlt.newt.fail

@@ -0,0 +1,10 @@
+*** Process tests/BadAlt.newt
+module Prelude
+module BadAlt
+ERROR at tests/BadAlt.newt:(6, 9): Prelude._:<_ not a constructor for (Prelude.List Prim.Int)
+  
+  foo : List Int → Int
+  foo (xs :< x) = x
+          ^
+
+Compile failed