Cleanup some old comments, use record update a bit more

This commit is contained in:
2025-10-11 21:45:26 -07:00
parent ddc73fb41a
commit 2794f8fe85
3 changed files with 9 additions and 30 deletions

View File

@@ -510,7 +510,7 @@ unify env mode t u = do
vtm <- eval Nil tm vtm <- eval Nil tm
appvtm <- vappSpine vtm sp' appvtm <- vappSpine vtm sp'
unify env mode t appvtm unify env mode t appvtm
_ => error fc' "unify failed \{show t} =?= \{show u} [no Fn]\n env is \{show env}" _ => error fc' "unify failed \{show t} =?= \{show u} [no Fn]"
unifyRef t@(VRef fc k sp) u = do unifyRef t@(VRef fc k sp) u = do
debug $ \ _ => "expand %ref \{show k} \{show sp} =?= \{show u}" debug $ \ _ => "expand %ref \{show k} \{show sp} =?= \{show u}"
@@ -520,7 +520,7 @@ unify env mode t u = do
vtm <- eval Nil tm vtm <- eval Nil tm
tmsp <- vappSpine vtm sp tmsp <- vappSpine vtm sp
unify env mode tmsp u unify env mode tmsp u
_ => error fc "unify failed \{show t} [no Fn] =?= \{show u}\n env is \{show env}" _ => error fc "unify failed \{show t} [no Fn] =?= \{show u}"
unifyRef t u = unifyRest t u unifyRef t u = unifyRest t u
unifyVar : Val -> Val -> M UnifyResult unifyVar : Val -> Val -> M UnifyResult
@@ -783,7 +783,6 @@ updateContext ctx ((k, val) :: cs) =
updateContext ctx cs updateContext ctx cs
Nothing => error (getFC val) "INTERNAL ERROR: bad index in updateContext" Nothing => error (getFC val) "INTERNAL ERROR: bad index in updateContext"
where where
replaceV : a. Nat -> a -> List a -> List a replaceV : a. Nat -> a -> List a -> List a
replaceV k x Nil = Nil replaceV k x Nil = Nil
replaceV Z x (y :: xs) = x :: xs replaceV Z x (y :: xs) = x :: xs
@@ -1037,9 +1036,6 @@ checkWhere ctx decls body ty = do
-- But I'll attempt letrec first -- But I'll attempt letrec first
tm <- buildTree (withPos ctx' defFC) (MkProb clauses' vty) tm <- buildTree (withPos ctx' defFC) (MkProb clauses' vty)
vtm <- eval ctx'.env tm vtm <- eval ctx'.env tm
-- Should we run the rest with the definition in place?
-- I'm wondering if switching from bind to define will mess with metas
-- let ctx' = define ctx name vtm vty
ty' <- checkWhere ctx' decls' body ty ty' <- checkWhere ctx' decls' body ty
pure $ LetRec sigFC name funTy tm ty' pure $ LetRec sigFC name funTy tm ty'

View File

@@ -37,7 +37,7 @@ lookupRaw raw top =
instance Show TopContext where instance Show TopContext where
show (MkTop _ _ _ _ defs metas _ _ _) = "\nContext:\n [\{ joinBy "\n" $ map (show snd) $ toList defs}]" show top = "\nContext:\n [\{ joinBy "\n" $ map (show snd) $ toList top.defs}]"
-- TODO need to get class dependencies working -- TODO need to get class dependencies working
emptyTop : io. {{Monad io}} {{HasIO io}} -> io TopContext emptyTop : io. {{Monad io}} {{HasIO io}} -> io TopContext
@@ -52,32 +52,22 @@ setFlag name fc flag = do
top <- getTop top <- getTop
let (Just (MkEntry fc nm ty def flags)) = lookupMap' name top.defs let (Just (MkEntry fc nm ty def flags)) = lookupMap' name top.defs
| Nothing => error fc "\{show name} not declared" | Nothing => error fc "\{show name} not declared"
modifyTop $ \case modifyTop $ \ top => [ defs := (updateMap name (MkEntry fc name ty def (flag :: flags)) top.defs) ] top
MkTop mods imp hints ns defs metaCtx verbose errors ops =>
let defs = (updateMap name (MkEntry fc name ty def (flag :: flags)) defs) in
MkTop mods imp hints ns defs metaCtx verbose errors ops
setDef : QName -> FC -> Tm -> Def List EFlag -> M Unit setDef : QName -> FC -> Tm -> Def List EFlag -> M Unit
setDef name fc ty def flags = do setDef name fc ty def flags = do
top <- getTop top <- getTop
let (Nothing) = lookupMap' name top.defs let (Nothing) = lookupMap' name top.defs
| Just (MkEntry fc' nm' ty' def' _) => error fc "\{show name} is already defined at \{show fc'}" | Just (MkEntry fc' nm' ty' def' _) => error fc "\{show name} is already defined at \{show fc'}"
modifyTop $ \case modifyTop $ \top =>
MkTop mods imp hints ns defs metaCtx verbose errors ops => [ defs := (updateMap name (MkEntry fc name ty def flags) top.defs)] top
let defs = (updateMap name (MkEntry fc name ty def flags) top.defs) in
MkTop mods imp hints ns defs metaCtx verbose errors ops
updateDef : QName -> FC -> Tm -> Def -> M Unit updateDef : QName -> FC -> Tm -> Def -> M Unit
updateDef name fc ty def = do updateDef name fc ty def = do
top <- getTop top <- getTop
let (Just (MkEntry fc' nm' ty' def' flags)) = lookupMap' name top.defs let (Just (MkEntry fc' nm' ty' def' flags)) = lookupMap' name top.defs
| Nothing => error fc "\{show name} not declared" | Nothing => error fc "\{show name} not declared"
modifyTop $ \case putTop $ [ defs := updateMap name (MkEntry fc' name ty def flags) top.defs ] top
MkTop mods imp hints ns defs metaCtx verbose errors ops =>
let defs = (updateMap name (MkEntry fc' name ty def flags) defs) in
MkTop mods imp hints ns defs metaCtx verbose errors ops
typeName : Tm Maybe QName typeName : Tm Maybe QName
typeName (Pi fc nm Explicit rig t u) = Nothing typeName (Pi fc nm Explicit rig t u) = Nothing
@@ -93,15 +83,11 @@ addHint qn = do
Just entry => do Just entry => do
let (Just tyname) = typeName entry.type let (Just tyname) = typeName entry.type
| Nothing => error entry.fc "can't find tcon name for \{show qn}" | Nothing => error entry.fc "can't find tcon name for \{show qn}"
let xs = fromMaybe Nil $ lookupMap' tyname top.hints let xs = fromMaybe Nil $ lookupMap' tyname top.hints
let hints = updateMap tyname ((qn, entry.type) :: xs) top.hints let hints = updateMap tyname ((qn, entry.type) :: xs) top.hints
putTop $ MkTop top.modules top.imported hints top.ns top.defs top.metaCtx top.verbose top.errors top.ops putTop $ [ hints := hints ] top
pure MkUnit
Nothing => pure MkUnit Nothing => pure MkUnit
addError : Error -> M Unit addError : Error -> M Unit
addError err = do addError err = do
top <- getTop top <- getTop

View File

@@ -427,7 +427,6 @@ record TopContext where
-- Global values -- Global values
verbose : Int -- command line flag verbose : Int -- command line flag
errors : IORef (List Error) errors : IORef (List Error)
-- what do we do here? we can accumulate for now, but we'll want to respect import
ops : Operators ops : Operators
-- we'll use this for typechecking, but need to keep a TopContext around too. -- we'll use this for typechecking, but need to keep a TopContext around too.
@@ -445,13 +444,11 @@ record Context where
ctxFC : FC ctxFC : FC
-- add a binding to environment -- add a binding to environment
extend : Context -> String -> Val -> Context extend : Context -> String -> Val -> Context
extend (MkCtx lvl env types bds ctxFC) name ty = extend (MkCtx lvl env types bds ctxFC) name ty =
MkCtx (1 + lvl) (VVar emptyFC lvl Lin :: env) ((name,ty) :: types) (Bound :: bds) ctxFC MkCtx (1 + lvl) (VVar emptyFC lvl Lin :: env) ((name,ty) :: types) (Bound :: bds) ctxFC
-- I guess we define things as values? -- add a def to the environment
define : Context -> String -> Val -> Val -> Context define : Context -> String -> Val -> Val -> Context
define (MkCtx lvl env types bds ctxFC) name val ty = define (MkCtx lvl env types bds ctxFC) name val ty =
MkCtx (1 + lvl) (val :: env) ((name,ty) :: types) (Defined :: bds) ctxFC MkCtx (1 + lvl) (val :: env) ((name,ty) :: types) (Defined :: bds) ctxFC