fix regressed error message for missing cases

This commit is contained in:
2025-02-16 21:46:19 -08:00
parent 001cba26ee
commit 041521ab47
5 changed files with 7 additions and 10 deletions

View File

@@ -286,7 +286,6 @@ maybeWrap stmt = Apply (JLam Nil stmt) Nil
defToDoc : {{Ref2 Defs St}} QName Def M Doc defToDoc : {{Ref2 Defs St}} QName Def M Doc
defToDoc name (Fn tm) = do defToDoc name (Fn tm) = do
debug $ \ _ => "compileFun \{render 90 $ pprint Nil tm}" debug $ \ _ => "compileFun \{render 90 $ pprint Nil tm}"
-- tm' <- erase Nil tm Nil
ct <- compileFun tm ct <- compileFun tm
let exp = maybeWrap $ termToJS emptyJSEnv ct JReturn let exp = maybeWrap $ termToJS emptyJSEnv ct JReturn
pure $ text "const" <+> jsIdent (show name) <+> text "=" <+/> expToDoc exp ++ text ";" pure $ text "const" <+> jsIdent (show name) <+> text "=" <+/> expToDoc exp ++ text ";"

View File

@@ -98,9 +98,6 @@ compileTerm tm@(App _ _ _) = case funArgs tm of
(t@(Ref fc nm), args) => do (t@(Ref fc nm), args) => do
args' <- traverse compileTerm args args' <- traverse compileTerm args
arity <- arityForName fc nm 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 apply (CRef (show nm)) args' Lin arity
(t, args) => do (t, args) => do
debug $ \ _ => "apply other \{render 90 $ pprint Nil t}" debug $ \ _ => "apply other \{render 90 $ pprint Nil t}"

View File

@@ -1127,10 +1127,10 @@ buildLitCase ctx prob fc scnm scty lit = do
cons <- rewriteConstraint cons Nil cons <- rewriteConstraint cons Nil
pure $ MkClause fc cons pats expr pure $ MkClause fc cons pats expr
buildDefault : Context Problem FC String M CaseAlt buildDefault : Context Problem FC String List QName M CaseAlt
buildDefault ctx prob fc scnm = do buildDefault ctx prob fc scnm missing = do
let defclauses = filter isDefault prob.clauses let defclauses = filter isDefault prob.clauses
when (length' defclauses == 0) $ \ _ => error fc "no default for literal slot on \{show scnm}" when (length' defclauses == 0) $ \ _ => error fc "missing cases \{show missing} on \{show scnm}"
CaseDefault <$> buildTree ctx (MkProb defclauses prob.ty) CaseDefault <$> buildTree ctx (MkProb defclauses prob.ty)
where where
isDefault : Clause -> Bool isDefault : Clause -> Bool
@@ -1253,9 +1253,9 @@ buildTree ctx prob@(MkProb ((MkClause fc constraints Nil expr) :: cs) ty) = do
-- build a default case for missed constructors -- build a default case for missed constructors
case miss' of case miss' of
Nil => pure $ Case fc sctm (mapMaybe id alts) Nil => pure $ Case fc sctm (mapMaybe id alts)
_ => do missed => do
-- ctx prob fc scnm -- ctx prob fc scnm
default <- buildDefault ctx prob fc scnm default <- buildDefault ctx prob fc scnm (map fst missed)
pure $ Case fc sctm (snoc alts' default) pure $ Case fc sctm (snoc alts' default)
PatLit fc v => do PatLit fc v => do

View File

@@ -87,7 +87,7 @@ liftWhereFn (name, Fn tm) = do
-- updateDef name fc type (Fn tm') -- updateDef name fc type (Fn tm')
liftWhereFn _ = pure MkUnit liftWhereFn _ = pure MkUnit
liftWhere : {{Ref2 Defs St}} M Unit liftWhere : {{Ref2 Defs St}} M Unit
liftWhere = do liftWhere = do
defs <- getRef Defs defs <- getRef Defs
ignore $ traverse liftWhereFn $ toList defs ignore $ traverse liftWhereFn $ toList defs

View File

@@ -2,6 +2,7 @@ module Node
import Prelude import Prelude
-- REVIEW - should this be IO (List String)
pfunc getArgs uses (arrayToList) : List String := `Prelude_arrayToList(null, process.argv.slice(1))` pfunc getArgs uses (arrayToList) : List String := `Prelude_arrayToList(null, process.argv.slice(1))`
pfunc readFile uses (MkIORes Left Right) : (fn : String) -> IO (Either String String) := `(fn) => (w) => { pfunc readFile uses (MkIORes Left Right) : (fn : String) -> IO (Either String String) := `(fn) => (w) => {
let fs = require('fs') let fs = require('fs')