refactor TopContext to use a ModContext for the current context
This commit is contained in:
@@ -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)
|
||||||
|
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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 ::)]
|
|
||||||
|
|||||||
@@ -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 =>
|
||||||
|
|||||||
@@ -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
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user