fix regressed error message for missing cases
This commit is contained in:
@@ -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 ";"
|
||||||
|
|||||||
@@ -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}"
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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')
|
||||||
|
|||||||
Reference in New Issue
Block a user