This commit is contained in:
2024-10-26 16:03:40 -07:00
parent 3379e6ba3f
commit 9535675191

View File

@@ -50,8 +50,8 @@ processDecl (TypeSig fc names tm) = do
for_ names $ \nm => modify $ setDef nm ty Axiom for_ names $ \nm => modify $ setDef nm ty Axiom
processDecl (PType fc nm ty) = do processDecl (PType fc nm ty) = do
ctx <- get top <- get
ty' <- check (mkCtx ctx.metas fc) (maybe (RU fc) id ty) (VU fc) ty' <- check (mkCtx top.metas fc) (maybe (RU fc) id ty) (VU fc)
modify $ setDef nm ty' PrimTCon modify $ setDef nm ty' PrimTCon
processDecl (PFunc fc nm ty src) = do processDecl (PFunc fc nm ty src) = do
@@ -64,8 +64,10 @@ processDecl (PFunc fc nm ty src) = do
processDecl (Def fc nm clauses) = do processDecl (Def fc nm clauses) = do
putStrLn "-----" putStrLn "-----"
putStrLn "def \{show nm}" putStrLn "def \{show nm}"
ctx <- get top <- get
let Just entry = lookup nm ctx mc <- readIORef top.metas
let mstart = length mc.metas
let Just entry = lookup nm top
| Nothing => throwError $ E fc "skip def \{nm} without Decl" | Nothing => throwError $ E fc "skip def \{nm} without Decl"
let (MkEntry name ty Axiom) := entry let (MkEntry name ty Axiom) := entry
| _ => throwError $ E fc "\{nm} already defined" | _ => throwError $ E fc "\{nm} already defined"
@@ -75,31 +77,24 @@ processDecl (Def fc nm clauses) = do
putStrLn "vty is \{show vty}" putStrLn "vty is \{show vty}"
-- I can take LHS apart syntactically or elaborate it with an infer -- I can take LHS apart syntactically or elaborate it with an infer
clauses' <- traverse (makeClause ctx) clauses clauses' <- traverse (makeClause top) clauses
tm <- buildTree (mkCtx ctx.metas fc) (MkProb clauses' vty) tm <- buildTree (mkCtx top.metas fc) (MkProb clauses' vty)
putStrLn "Ok \{pprint [] tm}" putStrLn "Ok \{pprint [] tm}"
tm' <- zonk ctx 0 [] tm tm' <- zonk top 0 [] tm
putStrLn "NF \{pprint[] tm'}" putStrLn "NF \{pprint[] tm'}"
mc <- readIORef ctx.metas mc <- readIORef top.metas
-- Maybe here we try search? -- Maybe here we try search?
for_ (drop mstart mc.metas) $ \case
for_ mc.metas $ \case
(Solved k x) => pure () (Solved k x) => pure ()
(Unsolved (l,c) k ctx ty User) => do (Unsolved (l,c) k ctx ty User) => do
-- TODO print here -- TODO print here
pure () pure ()
(Unsolved (l,c) k ctx ty kind) => do (Unsolved (l,c) k ctx ty kind) => do
-- should just print, but it's too subtle in the sea of messages
-- we'd also need the ability to mark the whole top context as failure if we continue
-- put a list of errors in TopContext
-- Something wrong here - bad VVar
tm <- quote ctx.lvl !(forceMeta ty) tm <- quote ctx.lvl !(forceMeta ty)
-- putStrLn $ showError "" $ E (l,c) "Unsolved meta \{show k} type \{show ty}" -- Now that we're collecting errors, maybe we simply check at the end
addError $ E (l,c) "Unsolved meta \{show k} type \{pprint (names ctx) tm}" addError $ E (l,c) "Unsolved meta \{show k} type \{pprint (names ctx) tm}"
-- throwError $ E (l,c) "Unsolved meta \{show k}"
debug "Add def \{nm} \{pprint [] tm'} : \{pprint [] ty}" debug "Add def \{nm} \{pprint [] tm'} : \{pprint [] ty}"
modify $ setDef nm ty (Fn tm') modify $ setDef nm ty (Fn tm')
@@ -116,14 +111,12 @@ processDecl (DCheck fc tm ty) = do
putStrLn "NF " putStrLn "NF "
processDecl (Data fc nm ty cons) = do processDecl (Data fc nm ty cons) = do
ctx <- get top <- get
tyty <- check (mkCtx ctx.metas fc) ty (VU fc) tyty <- check (mkCtx top.metas fc) ty (VU fc)
modify $ setDef nm tyty Axiom modify $ setDef nm tyty Axiom
ctx <- get
cnames <- for cons $ \x => case x of cnames <- for cons $ \x => case x of
(TypeSig fc names tm) => do (TypeSig fc names tm) => do
ctx <- get dty <- check (mkCtx top.metas fc) tm (VU fc)
dty <- check (mkCtx ctx.metas fc) tm (VU fc)
debug "dty \{show names} is \{pprint [] dty}" debug "dty \{show names} is \{pprint [] dty}"
-- We only check that codomain uses the right type constructor -- We only check that codomain uses the right type constructor