refactor TopContext to use a ModContext for the current context

This commit is contained in:
2026-02-21 21:27:54 -08:00
parent 0a5ad3cc9b
commit 34744a8edc
11 changed files with 112 additions and 122 deletions

View File

@@ -95,7 +95,7 @@ enumMul (x :: xs) ys = map (_,_ x) ys ++ enumMul xs ys
enumerate : (t : E) Vec (typ t) (card t) enumerate : (t : E) Vec (typ t) (card t)
enumerate Zero = Nil enumerate Zero = Nil
enumerate One = unit :: Nil enumerate One = MkUnit :: Nil
enumerate (Add x y) = enumAdd (enumerate x) (enumerate y) enumerate (Add x y) = enumAdd (enumerate x) (enumerate y)
enumerate (Mul x y) = enumMul (enumerate x) (enumerate y) enumerate (Mul x y) = enumMul (enumerate x) (enumerate y)

View File

@@ -28,12 +28,8 @@ decomposeName fn =
switchModule : FileSource String M ModContext switchModule : FileSource String M ModContext
switchModule repo modns = do switchModule repo modns = do
addPrimitives
modifyTop [ metaCtx := MC emptyMap Nil 0 CheckAll ]
mod <- processModule emptyFC repo Nil modns mod <- processModule emptyFC repo Nil modns
-- FIXME keep these in ModContext, drop from TopContext modifyTop [ currentMod := mod; ops := mod.modOps ]
modifyTop [ defs := mod.modDefs; metaCtx := mod.modMetaCtx; ops := mod.ctxOps; imported := mod.modDeps; infos := mod.modInfos; ns := modns; errors := mod.modErrors ]
top <- getTop
pure mod pure mod
-- The cheap version of type at point, find the token, lookup in global context -- The cheap version of type at point, find the token, lookup in global context
@@ -112,7 +108,7 @@ makeEdits : FC → List QName → Bool → M (List FileEdit)
makeEdits fc@(MkFC uri (MkBounds sr sc er ec)) names inPlace = do makeEdits fc@(MkFC uri (MkBounds sr sc er ec)) names inPlace = do
cons <- map applyDCon <$> traverse lookupDCon names cons <- map applyDCon <$> traverse lookupDCon names
top <- getTop top <- getTop
let (Just mod) = lookupMap' top.ns top.modules | _ => pure Nil let (Just mod) = lookupMap' top.currentMod.modName top.modules | _ => pure Nil
let lines = split mod.modSource "\n" let lines = split mod.modSource "\n"
let (Just line) = getAt' sr lines | _ => pure Nil let (Just line) = getAt' sr lines | _ => pure Nil
let cs = unpack line let cs = unpack line
@@ -171,7 +167,7 @@ getActions : FileSource → String → Int → Int → M (List CodeAction)
getActions repo modns row col = do getActions repo modns row col = do
mod <- switchModule repo modns mod <- switchModule repo modns
top <- getTop top <- getTop
let xx = filter (posInFC row col getFC) top.infos let xx = filter (posInFC row col getFC) top.currentMod.modInfos
putStrLn "Filter got \{show $ length' xx}" putStrLn "Filter got \{show $ length' xx}"
go Nil $ xx go Nil $ xx
where where

View File

@@ -1,7 +1,6 @@
module LSP module LSP
import Prelude import Prelude
-- TODO pull this into its own file
import Lib.Common import Lib.Common
import Lib.Eval import Lib.Eval
import Lib.Types import Lib.Types
@@ -165,7 +164,7 @@ errorToDiag (Postpone fc qn msg) = errorToDiag $ E fc "Postpone \{show qn} \{msg
getInfos : M (List Json) getInfos : M (List Json)
getInfos = do getInfos = do
top <- getTop top <- getTop
go Nil $ listValues $ top.metaCtx.metas go Nil $ listValues $ top.currentMod.modMetaCtx.metas
where where
go : List Json → List MetaEntry → M (List Json) go : List Json → List MetaEntry → M (List Json)
go acc Nil = pure acc go acc Nil = pure acc
@@ -194,13 +193,12 @@ checkFile fn = unsafePerformIO $ do
then resetState base then resetState base
else pure MkUnit else pure MkUnit
(Right (top, json)) <- (do (Right (top, json)) <- (do
modifyTop [ errors := Nil ]
putStrLn "processModule" putStrLn "processModule"
_ <- switchModule lspFileSource modName _ <- switchModule lspFileSource modName
-- pull out errors and infos -- pull out errors and infos
top <- getTop top <- getTop
let errors = map (errorToDiag) top.errors let errors = map (errorToDiag) top.currentMod.modErrors
infos <- getInfos infos <- getInfos
pure $ infos ++ errors pure $ infos ++ errors
).runM st.topContext ).runM st.topContext

View File

@@ -516,8 +516,8 @@ process names = do
compile : M (List Doc) compile : M (List Doc)
compile = do compile = do
top <- getTop top <- getTop
let exports = getExports Nil $ listValues top.defs let exports = getExports Nil $ listValues top.currentMod.modDefs
let mainName = (QN top.ns "main") let mainName = (QN top.currentMod.modName "main")
let main = lookup mainName top let main = lookup mainName top
let todo = case main of let todo = case main of
Nothing => exports Nothing => exports

View File

@@ -267,7 +267,7 @@ compileDCon ix (QN _ nm) info arity =
-- probably want to drop the Ref2 when we can -- probably want to drop the Ref2 when we can
defToCExp : {{Ref2 Defs St}} → (QName × Def) -> M (QName × CExp) defToCExp : {{Ref2 Defs St}} → (QName × Def) -> M (QName × CExp)
defToCExp (qn, Axiom) = pure (qn, CErased) defToCExp (qn, Axiom) = error emptyFC "\{show qn} is Axiom" -- pure (qn, CErased)
defToCExp (qn, (PrimOp _)) = (_,_ qn) <$> compilePop qn defToCExp (qn, (PrimOp _)) = (_,_ qn) <$> compilePop qn
defToCExp (qn, DCon ix info arity _) = pure (qn, compileDCon ix qn info arity) defToCExp (qn, DCon ix info arity _) = pure (qn, compileDCon ix qn info arity)
-- We're not using these are runtime at the moment, no typecase -- We're not using these are runtime at the moment, no typecase

View File

@@ -119,7 +119,10 @@ isCandidate _ _ = False
setMetaMode : MetaMode M Unit setMetaMode : MetaMode M Unit
-- ideally we would support dotted paths like metaCtx.mcmode := CheckFirst -- ideally we would support dotted paths like metaCtx.mcmode := CheckFirst
setMetaMode mcmode = modifyTop [ metaCtx $= [mcmode := mcmode] ] setMetaMode mcmode = modifyTop [ currentMod $= [modMetaCtx $= [mcmode := mcmode] ] ]
setMetaContext : MetaContext M Unit
setMetaContext mc = modifyTop [ currentMod $= [ modMetaCtx := mc ]]
findMatches : Context -> Val -> List (QName × Tm) -> M (List QName) findMatches : Context -> Val -> List (QName × Tm) -> M (List QName)
findMatches ctx ty Nil = pure Nil findMatches ctx ty Nil = pure Nil
@@ -129,7 +132,7 @@ findMatches ctx ty ((name, type) :: xs) = do
top <- getTop top <- getTop
-- save context -- save context
let mc = top.metaCtx let mc = top.currentMod.modMetaCtx
catchError (do catchError (do
-- TODO sort out the FC here -- TODO sort out the FC here
let fc = getFC ty let fc = getFC ty
@@ -140,11 +143,11 @@ findMatches ctx ty ((name, type) :: xs) = do
setMetaMode CheckFirst setMetaMode CheckFirst
tm <- check ctx (RVar fc nm) ty tm <- check ctx (RVar fc nm) ty
debug $ \ _ => "Found \{rpprint Nil tm} for \{show ty}" debug $ \ _ => "Found \{rpprint Nil tm} for \{show ty}"
modifyTop [ metaCtx := mc ] setMetaContext mc
(_::_ name) <$> findMatches ctx ty xs) (_::_ name) <$> findMatches ctx ty xs)
(\ err => do (\ err => do
debug $ \ _ => "No match \{show ty} \{rpprint Nil type} \{showError "" err}" debug $ \ _ => "No match \{show ty} \{rpprint Nil type} \{showError "" err}"
modifyTop [ metaCtx := mc ] setMetaContext mc
findMatches ctx ty xs) findMatches ctx ty xs)
contextMatches : Context -> Val -> M (List (Tm × Val)) contextMatches : Context -> Val -> M (List (Tm × Val))
@@ -156,17 +159,17 @@ contextMatches ctx ty = go (zip ctx.env ctx.types)
type <- quote ctx.lvl vty type <- quote ctx.lvl vty
let (True) = isCandidate ty type | False => go xs let (True) = isCandidate ty type | False => go xs
top <- getTop top <- getTop
let mc = top.metaCtx let mc = top.currentMod.modMetaCtx
catchError(do catchError(do
debug $ \ _ => "TRY context \{nm} : \{rpprint (names ctx) type} for \{show ty}" debug $ \ _ => "TRY context \{nm} : \{rpprint (names ctx) type} for \{show ty}"
unifyCatch (getFC ty) ctx ty vty unifyCatch (getFC ty) ctx ty vty
let mc' = top.metaCtx let mc' = top.currentMod.modMetaCtx
modifyTop [ metaCtx := mc] setMetaContext mc
tm <- quote ctx.lvl tm tm <- quote ctx.lvl tm
(_::_ (tm, vty)) <$> go xs) (_::_ (tm, vty)) <$> go xs)
(\ err => do (\ err => do
debug $ \ _ => "No match \{show ty} \{rpprint (names ctx) type} \{showError "" err}" debug $ \ _ => "No match \{show ty} \{rpprint (names ctx) type} \{showError "" err}"
modifyTop [ metaCtx := mc] setMetaContext mc
go xs) go xs)
getArity : Tm -> List Quant getArity : Tm -> List Quant
@@ -229,7 +232,7 @@ trySolveAuto _ = pure False
solveAutos : M Unit solveAutos : M Unit
solveAutos = do solveAutos = do
top <- getTop top <- getTop
let mc = top.metaCtx let mc = top.currentMod.modMetaCtx
let autos = filter isAuto $ mapMaybe (flip lookupMap' mc.metas) mc.autos let autos = filter isAuto $ mapMaybe (flip lookupMap' mc.metas) mc.autos
res <- run autos res <- run autos
-- If anything is solved, we try again from the top -- If anything is solved, we try again from the top
@@ -248,13 +251,13 @@ solveAutos = do
updateMeta : QName -> (MetaEntry -> M MetaEntry) -> M Unit updateMeta : QName -> (MetaEntry -> M MetaEntry) -> M Unit
updateMeta ix f = do updateMeta ix f = do
top <- getTop top <- getTop
let mc = top.metaCtx let mc = top.currentMod.modMetaCtx
let (Just me) = lookupMap' ix mc.metas | Nothing => pure MkUnit let (Just me) = lookupMap' ix mc.metas | Nothing => pure MkUnit
me <- f me me <- f me
let autos = case me of let autos = case me of
Solved _ _ _ => filter (_/=_ ix) mc.autos Solved _ _ _ => filter (_/=_ ix) mc.autos
_ => mc.autos _ => mc.autos
modifyTop [ metaCtx := MC (updateMap ix me mc.metas) autos mc.next mc.mcmode ] setMetaContext $ [metas $= updateMap ix me; autos := autos] mc
-- Try to solve autos that reference the meta ix -- Try to solve autos that reference the meta ix
checkAutos : QName -> List QName -> M Unit checkAutos : QName -> List QName -> M Unit
@@ -278,7 +281,7 @@ checkAutos ix (_ :: rest) = checkAutos ix rest
addConstraint : Env -> QName -> SnocList Val -> Val -> M Unit addConstraint : Env -> QName -> SnocList Val -> Val -> M Unit
addConstraint env ix sp tm = do addConstraint env ix sp tm = do
top <- getTop top <- getTop
let mc = top.metaCtx let mc = top.currentMod.modMetaCtx
let (CheckAll) = mc.mcmode | _ => pure MkUnit let (CheckAll) = mc.mcmode | _ => pure MkUnit
updateMeta ix $ \case updateMeta ix $ \case
(Unsolved pos k a b c cons) => do (Unsolved pos k a b c cons) => do
@@ -373,7 +376,7 @@ ctx.boundNames = map snd $ filter (\x => fst x == Bound) $ zip ctx.bds (map fst
maybeCheck : M Unit -> M Unit maybeCheck : M Unit -> M Unit
maybeCheck action = do maybeCheck action = do
top <- getTop top <- getTop
let mc = top.metaCtx let mc = top.currentMod.modMetaCtx
case mc.mcmode of case mc.mcmode of
CheckAll => action CheckAll => action
CheckFirst => do CheckFirst => do
@@ -426,7 +429,7 @@ solve env m sp t = do
unify env UNormal val rhs unify env UNormal val rhs
-- check any autos -- check any autos
top <- getTop top <- getTop
let mc = top.metaCtx let mc = top.currentMod.modMetaCtx
let (CheckAll) = mc.mcmode | _ => pure MkUnit let (CheckAll) = mc.mcmode | _ => pure MkUnit
debug $ \ _ => "check autos depending on \{show ix} \{debugStr mc.mcmode}" debug $ \ _ => "check autos depending on \{show ix} \{debugStr mc.mcmode}"
checkAutos ix mc.autos checkAutos ix mc.autos
@@ -617,16 +620,17 @@ unifyCatch fc ctx ty' ty = do
freshMeta : Context -> FC -> Val -> MetaKind -> M Tm freshMeta : Context -> FC -> Val -> MetaKind -> M Tm
freshMeta ctx fc ty kind = do freshMeta ctx fc ty kind = do
top <- getTop top <- getTop
let mc = top.metaCtx let mc = top.currentMod.modMetaCtx
debug $ \ _ => "fresh meta \{show mc.next} : \{show ty} (\{show kind})" debug $ \ _ => "fresh meta \{show mc.next} : \{show ty} (\{show kind})"
-- need the ns here -- need the ns here
-- we were fudging this for v1 -- we were fudging this for v1
let qn = QN top.ns "$m\{show mc.next}" let qn = QN top.currentMod.modName "$m\{show mc.next}"
let newmeta = Unsolved fc qn ctx ty kind Nil let newmeta = Unsolved fc qn ctx ty kind Nil
let autos = case kind of let autos = case kind of
AutoSolve => qn :: mc.autos AutoSolve => qn :: mc.autos
_ => mc.autos _ => mc.autos
modifyTop [metaCtx := MC (updateMap qn newmeta mc.metas) autos (1 + mc.next) mc.mcmode ] setMetaContext $ [ metas $= updateMap qn newmeta; autos := autos; next $= 1 +] mc
-- I tried checking Auto immediately if CheckAll, but there isn't enough information yet. -- I tried checking Auto immediately if CheckAll, but there isn't enough information yet.
pure $ applyBDs 0 (Meta fc qn) ctx.bds pure $ applyBDs 0 (Meta fc qn) ctx.bds
where where

View File

@@ -51,7 +51,6 @@ logMetas (Unsolved fc k ctx ty User cons :: rest) = do
logMetas (Unsolved fc k ctx ty kind cons :: rest) = do logMetas (Unsolved fc k ctx ty kind cons :: rest) = do
ty' <- forceMeta ty ty' <- forceMeta ty
tm <- quote ctx.lvl ty' tm <- quote ctx.lvl ty'
-- FIXME in Combinatory.newt, the val doesn't match environment?
let msg = "Unsolved meta \{show k} \{show kind} type \{render 90 $ pprint (names ctx) tm} \{show $ length' cons} constraints" let msg = "Unsolved meta \{show k} \{show kind} type \{render 90 $ pprint (names ctx) tm} \{show $ length' cons} constraints"
msgs <- for cons $ \case msgs <- for cons $ \case
(MkMc fc env sp val) => do (MkMc fc env sp val) => do
@@ -69,7 +68,7 @@ logMetas (Unsolved fc k ctx ty kind cons :: rest) = do
pure (" \{show $ length' matches} Solutions: \{show matches}" :: Nil) pure (" \{show $ length' matches} Solutions: \{show matches}" :: Nil)
_ => pure Nil _ => pure Nil
-- info fc $ unlines ((msg :: Nil) ++ msgs ++ sols)
addError $ E fc $ unlines ((msg :: Nil) ++ msgs ++ sols) addError $ E fc $ unlines ((msg :: Nil) ++ msgs ++ sols)
logMetas rest logMetas rest
@@ -95,7 +94,7 @@ impTele tele = map foo tele
checkAlreadyDef : FC Name M Unit checkAlreadyDef : FC Name M Unit
checkAlreadyDef fc nm = do checkAlreadyDef fc nm = do
top <- getTop top <- getTop
case lookup (QN top.ns nm) top of case lookup (QN top.currentMod.modName nm) top of
Nothing => pure MkUnit Nothing => pure MkUnit
Just entry => error fc "\{show nm} is already defined at \{show entry.fc}" Just entry => error fc "\{show nm} is already defined at \{show entry.fc}"
@@ -158,7 +157,7 @@ processDef ns fc nm clauses = do
log 1 $ \ _ => "-----" log 1 $ \ _ => "-----"
log 1 $ \ _ => "Def \{show nm}" log 1 $ \ _ => "Def \{show nm}"
top <- getTop top <- getTop
let mc = top.metaCtx let mc = top.currentMod.modMetaCtx
let (Just entry) = lookup (QN ns nm) top let (Just entry) = lookup (QN ns nm) top
| Nothing => throwError $ E fc "No declaration for \{nm}" | Nothing => throwError $ E fc "No declaration for \{nm}"
let (MkEntry fc name ty Axiom _) = entry let (MkEntry fc name ty Axiom _) = entry
@@ -436,7 +435,7 @@ processData ns fc (nameFC, nm) ty cons = do
log 1 $ \ _ => "-----" log 1 $ \ _ => "-----"
log 1 $ \ _ => "Data \{nm}" log 1 $ \ _ => "Data \{nm}"
top <- getTop top <- getTop
let mc = top.metaCtx let mc = top.currentMod.modMetaCtx
tyty <- check (mkCtx fc) ty (VU fc) tyty <- check (mkCtx fc) ty (VU fc)
case lookup (QN ns nm) top of case lookup (QN ns nm) top of
Just (MkEntry _ name type Axiom _) => do Just (MkEntry _ name type Axiom _) => do

View File

@@ -16,21 +16,14 @@ import Lib.Elab
-- declare internal primitives -- declare internal primitives
addPrimitives : M ModContext addPrimitives : M ModContext
addPrimitives = do addPrimitives = do
modifyTop [ currentMod := emptyModCtx "Prim" ""; hints := emptyMap; ops := emptyMap ]
processDecl primNS (PType emptyFC "Int" Nothing) processDecl primNS (PType emptyFC "Int" Nothing)
processDecl primNS (PType emptyFC "String" Nothing) processDecl primNS (PType emptyFC "String" Nothing)
processDecl primNS (PType emptyFC "Char" Nothing) processDecl primNS (PType emptyFC "Char" Nothing)
setDef (QN primNS "PiType") emptyFC (Erased emptyFC) (PrimFn "(h0, h1) => ({ tag: \"PiType\", h0, h1 });" (S (S Z)) Nil) Nil setDef (QN primNS "PiType") emptyFC (Erased emptyFC) (PrimFn "(h0, h1) => ({ tag: \"PiType\", h0, h1 });" (S (S Z)) Nil) Nil
top <- getTop top <- getTop
let mod = MkModCtx "" top.defs (MC emptyMap Nil 0 CheckAll) top.ops Nil top.errors Nil modifyTop [ modules $= updateMap primNS top.currentMod ]
let modules = updateMap primNS mod top.modules pure top.currentMod
-- TODO - do we clear this? Try just modules := modules, but wait until this refactor is done.
modifyTop [ modules := modules
; imported := primNS :: Nil
; hints := emptyMap
; ns := ""
; defs := emptyMap
]
pure mod
record FileSource where record FileSource where
getFile : FC String M (String × String) getFile : FC String M (String × String)
@@ -60,9 +53,11 @@ importHints (entry :: entries) = do
when (elem Hint entry.eflags) $ \ _ => addHint entry.name when (elem Hint entry.eflags) $ \ _ => addHint entry.name
importHints entries importHints entries
-- HACK this is returning src to help render errors.. mergeOps : Operators Operators Operators
-- Maybe return module, put src and errors in module, add error for import with error, callers can sort out what they want to do? mergeOps mod top = foldMap (flip const) top $ toList mod
-- The issue here is command line newt wants to report all errors (we can print that though?) LSP wants something more subtle
-- processModule might reset the currentModule in the topContext
-- do not rely on topContext state afterwards - it may or may not contain the module
processModule : FC FileSource List String String M ModContext processModule : FC FileSource List String String M ModContext
processModule importFC repo stk modns = do processModule importFC repo stk modns = do
top <- getTop top <- getTop
@@ -70,8 +65,8 @@ processModule importFC repo stk modns = do
let (Nothing) = lookupMap' modns top.modules let (Nothing) = lookupMap' modns top.modules
| Just mod => pure mod | Just mod => pure mod
let (False) = modns == primNS let (False) = modns == primNS | _ => addPrimitives
| _ => addPrimitives
let parts = split modns "." let parts = split modns "."
let fn = joinBy "/" parts ++ ".newt" let fn = joinBy "/" parts ++ ".newt"
-- TODO now we can pass in the module name... -- TODO now we can pass in the module name...
@@ -92,47 +87,60 @@ processModule importFC repo stk modns = do
imported <- for imports $ \case imported <- for imports $ \case
MkImport fc (nameFC, name') => do MkImport fc (nameFC, name') => do
when (elem name' stk) $ \ _ => error nameFC "import loop \{modns} → \{name'}" when (elem name' stk) $ \ _ => error nameFC "import loop \{modns} → \{name'}"
processModule nameFC repo (modns :: stk) name' mod <- processModule nameFC repo (modns :: stk) name'
pure $ name' pure $ name'
processModule nameFC repo (modns :: stk) primNS processModule nameFC repo (modns :: stk) primNS
let imported = snoc imported primNS let imported = snoc imported primNS
putStrLn "module \{modName}" putStrLn "module \{modName}"
top <- getTop
let freshMC = MC emptyMap Nil 0 CheckAll
let mod = MkModCtx modns src emptyMap freshMC emptyMap imported Nil Nil
modifyTop [ currentMod := mod
; hints := emptyMap
; ops := ops
]
log 1 $ \ _ => "MODNS " ++ show modns -- top hints / ops include all directly imported modules
for_ imports $ \case
(MkImport fc (nameFC, ns)) => do
let (Just mod) = lookupMap' ns top.modules | _ => error emptyFC "namespace \{show ns} missing"
importHints (listValues mod.modDefs)
modifyTop [ ops $= mergeOps mod.modOps ]
-- add error if an import contains an error
-- maybe move this to after reporting
case mod.modErrors of
Nil => pure MkUnit
_ => addError $ E nameFC "Error in import \{ns}"
log 1 $ \ _ => "parse Decls"
top <- getTop top <- getTop
(decls, ops) <- parseDecls fn top.ops toks Lin (decls, ops) <- parseDecls fn top.ops toks Lin
top <- getTop -- TODO only include this module's ops
let freshMC = MC emptyMap Nil 0 CheckAll -- aside from reworking parsing, we could filter
-- NOW Print and drop errors here -- other options are removing updates from parsing (so we must use incremental parsing)
-- clear per module fields before processing this module -- or removing pratt from parsing (so it happens in elaboration)
modifyTop [ imported := imported modifyTop [ currentMod $= [ modOps := ops ] ]
; hints := emptyMap
; ns := modns
; defs := emptyMap
; infos := Nil
; metaCtx := freshMC
; ops := ops
]
for imported $ \ ns => do
let (Just mod) = lookupMap' ns top.modules | _ => error emptyFC "namespace \{show ns} missing"
importHints (listValues mod.modDefs)
log 1 $ \ _ => "process Decls" log 1 $ \ _ => "process Decls"
traverse (tryProcessDecl src modns) (collectDecl decls) traverse (tryProcessDecl src modns) (collectDecl decls)
top <- getTop
-- This has addErrors as a side-effect -- This has addErrors as a side-effect
logMetas $ reverse $ listValues top.metaCtx.metas logMetas $ reverse $ listValues top.currentMod.modMetaCtx.metas
-- print errors (for batch processing case)
for_ top.currentMod.modErrors $ \ err => putStrLn $ showError src err
-- update modules with result, leave the rest of context in case this is top file -- update modules with result, leave the rest of context in case this is top file
top <- getTop top <- getTop
let mod = MkModCtx src top.defs top.metaCtx top.ops imported top.errors top.infos let modules = updateMap modns top.currentMod top.modules
let modules = updateMap modns mod top.modules
modifyTop [modules := modules] modifyTop [modules := modules]
-- FIXME module context should hold errors, to report in replay pure top.currentMod
pure mod
where where
tryProcessDecl : String String Decl M Unit tryProcessDecl : String String Decl M Unit
tryProcessDecl src ns decl = do tryProcessDecl src ns decl = do

View File

@@ -7,32 +7,31 @@ import Prelude
import Lib.Common import Lib.Common
import Lib.Types import Lib.Types
-- I want unique ids, to be able to lookup, update, and a Ref so -- TODO move the def in here (along with M) or merge this into types
-- I don't need good Context discipline. (I seem to have made mistakes already.) -- The Monad can be its own file if we pull all of the monad update functions there.
lookup : QName -> TopContext -> Maybe TopEntry lookup : QName -> TopContext -> Maybe TopEntry
lookup qn@(QN ns nm) top = lookup qn@(QN ns nm) top =
if ns == top.ns if ns == top.currentMod.modName
then lookupMap' qn top.defs then lookupMap' qn top.currentMod.modDefs
else case lookupMap' ns top.modules of else case lookupMap' ns top.modules of
Just mod => lookupMap' qn mod.modDefs Just mod => lookupMap' qn mod.modDefs
Nothing => Nothing Nothing => Nothing
lookupImported : String TopContext -> List TopEntry lookupImported : String TopContext -> List TopEntry
lookupImported raw top = lookupImported raw top =
mapMaybe (flip lookup top) $ (QN top.ns raw) :: map (flip QN raw) top.imported mapMaybe (flip lookup top) $ (QN top.currentMod.modName raw) :: map (flip QN raw) top.currentMod.modDeps
-- For repl / out of scope errors -- For repl / out of scope errors
lookupAll : String TopContext -> List TopEntry lookupAll : String TopContext -> List TopEntry
lookupAll raw top = lookupAll raw top =
mapMaybe (flip lookup top) $ (QN top.ns raw) :: map (flip QN raw) (map fst $ toList top.modules) mapMaybe (flip lookup top) $ (QN top.currentMod.modName raw) :: map (flip QN raw) (map fst $ toList top.modules)
lookupRaw : String -> TopContext -> Maybe TopEntry lookupRaw : String -> TopContext -> Maybe TopEntry
lookupRaw raw top = lookupRaw raw top =
case lookupMap' (QN top.ns raw) top.defs of case lookupMap' (QN top.currentMod.modName raw) top.currentMod.modDefs of
Just entry => Just entry Just entry => Just entry
Nothing => go top.imported Nothing => go top.currentMod.modDeps
where where
go : List String Maybe TopEntry go : List String Maybe TopEntry
go Nil = Nothing go Nil = Nothing
@@ -42,35 +41,33 @@ lookupRaw raw top =
Just entry => Just entry Just entry => Just entry
Nothing => go nss Nothing => go nss
instance Show TopContext where instance Show TopContext where
show top = "\nContext:\n [\{ joinBy "\n" $ map (show snd) $ toList top.defs}]" show top = "\nContext:\n [\{ joinBy "\n" $ map (show snd) $ toList top.currentMod.modDefs}]"
emptyTop : TopContext emptyTop : TopContext
emptyTop = MkTop emptyMap Nil emptyMap Nil "" emptyMap (MC emptyMap Nil 0 CheckAll) 0 Nil emptyMap emptyTop = MkTop emptyMap emptyMap (emptyModCtx "" "") 0 emptyMap
setFlag : QName FC EFlag M Unit setFlag : QName FC EFlag M Unit
setFlag name fc flag = do 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.currentMod.modDefs
| Nothing => error fc "\{show name} not declared" | Nothing => error fc "\{show name} not declared"
modifyTop [ defs $= (updateMap name (MkEntry fc name ty def (flag :: flags))) ] modifyTop [ currentMod $= [ modDefs $= (updateMap name (MkEntry fc name ty def (flag :: flags)))] ]
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.currentMod.modDefs
| 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 $ \top =>
[ defs := (updateMap name (MkEntry fc name ty def flags) top.defs)] top modifyTop [currentMod $= [ modDefs $= (updateMap name (MkEntry fc name ty def flags))] ]
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.currentMod.modDefs
| Nothing => error fc "\{show name} not declared" | Nothing => error fc "\{show name} not declared"
putTop $ [ defs := updateMap name (MkEntry fc' name ty def flags) top.defs ] top modifyTop [ currentMod $= [ modDefs := updateMap name (MkEntry fc' name ty def flags) top.currentMod.modDefs ] ]
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
@@ -88,15 +85,11 @@ addHint qn = do
| 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 $ [ hints := hints ] top modifyTop [ hints := hints ]
Nothing => pure MkUnit Nothing => pure MkUnit
addError : Error -> M Unit addError : Error -> M Unit
addError err = do addError err = modifyTop [ currentMod $= [ modErrors $= (err ::) ] ]
top <- getTop
modifyTop [ errors $= (err ::) ]
addInfo : EditorInfo M Unit addInfo : EditorInfo M Unit
addInfo info = do addInfo info = modifyTop [ currentMod $= [modInfos $= (info ::) ] ]
top <- getTop
modifyTop [ infos $= (info ::)]

View File

@@ -398,12 +398,13 @@ data EditorInfo
record ModContext where record ModContext where
constructor MkModCtx constructor MkModCtx
modName : String
modSource : String modSource : String
modDefs : SortedMap QName TopEntry modDefs : SortedMap QName TopEntry
-- Do we need this if everything solved is zonked? -- Do we need this if everything solved is zonked?
modMetaCtx : MetaContext modMetaCtx : MetaContext
-- longer term maybe drop this, put the operator decls in ctxDefs and collect them on import -- longer term maybe drop this, put the operator decls in ctxDefs and collect them on import
ctxOps : Operators modOps : Operators
modDeps : List String modDeps : List String
modErrors : List Error modErrors : List Error
modInfos : List EditorInfo modInfos : List EditorInfo
@@ -416,8 +417,8 @@ record ModContext where
-- expand these during normalization? -- expand these during normalization?
-- A placeholder while walking through dependencies of a module -- A placeholder while walking through dependencies of a module
emptyModCtx : String ModContext emptyModCtx : String String ModContext
emptyModCtx source = MkModCtx source emptyMap (MC emptyMap Nil 0 NoCheck) emptyMap Nil Nil Nil emptyModCtx modName source = MkModCtx modName source emptyMap (MC emptyMap Nil 0 NoCheck) emptyMap Nil Nil Nil
HintTable : U HintTable : U
HintTable = SortedMap QName (List (QName × Tm)) HintTable = SortedMap QName (List (QName × Tm))
@@ -428,23 +429,17 @@ instance HasFC EditorInfo where
getFC (CaseSplit fc _ _ _) = fc getFC (CaseSplit fc _ _ _) = fc
getFC (MissingCases fc _ _) = fc getFC (MissingCases fc _ _) = fc
-- modules are "modules"
-- currentMod represents the current module
-- when we switch modules, load imports into ops and hints
-- as we process the decls, update ops and currentMod.ops
record TopContext where record TopContext where
constructor MkTop constructor MkTop
modules : SortedMap String ModContext modules : SortedMap String ModContext
imported : List String
-- TCon name → function name × type
hints : HintTable hints : HintTable
infos : List EditorInfo
-- current module -- current module
ns : String currentMod : ModContext
defs : SortedMap QName TopEntry verbose : Int -- command line flag increments this
metaCtx : MetaContext
-- Global values
verbose : Int -- command line flag
errors : List Error
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.
@@ -592,7 +587,7 @@ error' msg = throwError $ E emptyFC msg
lookupMeta : QName -> M MetaEntry lookupMeta : QName -> M MetaEntry
lookupMeta ix@(QN ns nm) = do lookupMeta ix@(QN ns nm) = do
top <- getTop top <- getTop
case lookupMap' ix top.metaCtx.metas of case lookupMap' ix top.currentMod.modMetaCtx.metas of
Just meta => pure meta Just meta => pure meta
Nothing => case lookupMap' ns top.modules of Nothing => case lookupMap' ns top.modules of
Nothing => Nothing =>

View File

@@ -65,11 +65,8 @@ baseDir Lin _ = Left "module path doesn't match directory"
showErrors : String -> String -> M Unit showErrors : String -> String -> M Unit
showErrors fn src = do showErrors fn src = do
top <- getTop top <- getTop
-- TODO {M} needed to sort out scrutinee let (Nil) = top.currentMod.modErrors
let (Nil) = top.errors | _ => throwError $ E (MkFC fn $ MkBounds 0 0 0 0) "Compile failed"
| errors => do
traverse (putStrLn showError src) errors
throwError $ E (MkFC fn $ MkBounds 0 0 0 0) "Compile failed"
pure MkUnit pure MkUnit