Modules live in separate contexts, only imported modules are in scope

This commit is contained in:
2025-01-12 08:57:01 -08:00
parent 793c3a9999
commit 5cce1a465e
18 changed files with 141 additions and 44 deletions

View File

@@ -1,5 +1,6 @@
module Lib.Common
import Prelude
import Data.String
import Data.Int
import Data.SortedMap

View File

@@ -1,12 +1,15 @@
-- TODO Audit how much "outside" stuff could pile up in the continuation.
module Lib.Compile
import Prelude
import Lib.Common
import Lib.Types
import Lib.Prettier
import Lib.CompileExp
import Lib.TopContext
import Data.String
import Data.Int
import Data.SortedMap
data StKind = Plain | Return | Assign String

View File

@@ -7,6 +7,8 @@
-- I could make names unique (e.q. on lambdas), but I might want that to vary per backend?
module Lib.CompileExp
import Prelude
import Lib.Common
import Lib.Types -- Name / Tm
import Lib.TopContext
import Lib.Prettier

View File

@@ -1,14 +1,19 @@
module Lib.Elab
import Prelude
import Lib.Common
import Lib.Parser.Impl
import Lib.Prettier
import Data.String
import Data.SnocList
import Data.IORef
import Lib.Types
import Data.SortedMap
import Lib.Eval
import Lib.Util
import Lib.TopContext
-- FIXME Def is shadowing...
import Lib.Syntax
import Lib.Types
vprint : Context -> Val -> M String
@@ -223,7 +228,11 @@ trySolveAuto (Unsolved fc k ctx ty AutoSolve _) = do
| res => do
debug $ \ _ => "FAILED to solve \{show ty}, matches: \{render 90 $ commaSep $ map (pprint Nil ∘ fst) res}"
pure False
(nm :: Nil) <- findMatches ctx ty $ map snd $ toList top.defs
let te = listValues top.defs
let rest = map {List} (\ x => listValues x.modDefs) $
mapMaybe (flip lookupMap' top.modules) top.imported
(nm :: Nil) <- findMatches ctx ty $ join (te :: rest)
| res => do
debug $ \ _ => "FAILED to solve \{show ty}, matches: \{show res}"
pure False
@@ -307,7 +316,7 @@ addConstraint env ix sp tm = do
(Unsolved pos k a b c cons) => do
debug $ \ _ => "Add constraint m\{show ix} \{show sp} =?= \{show tm}"
pure (Unsolved pos k a b c (MkMc (getFC tm) env sp tm :: cons))
(Solved _ k tm) => error' "Meta \{show k} already solved (addConstraint :: Nil)"
(Solved _ k tm) => error' "Meta \{show k} already solved [addConstraint]"
(OutOfScope) => error' "Meta \{show ix} out of scope"
mc <- readIORef top.metaCtx
checkAutos ix (listValues mc.metas)
@@ -417,7 +426,7 @@ maybeCheck action = do
solve env m sp t = do
meta@(Unsolved metaFC ix ctx_ ty kind cons) <- lookupMeta m
| _ => error (getFC t) "Meta \{show m} already solved! (solve :: Nil)"
| _ => error (getFC t) "Meta \{show m} already solved! [solve]"
debug $ \ _ => "SOLVE \{show m} \{show kind} lvl \{show $ length' env} sp \{show sp} is \{show t}"
let size = length $ filter (\x => x == Bound) ctx_.bds
debug $ \ _ => "\{show m} size is \{show size} sps \{show $ snoclen sp}"
@@ -442,7 +451,7 @@ solve env m sp t = do
updateMeta m $ \case
(Unsolved pos k _ _ _ cons) => pure $ Solved pos k soln
(Solved _ k x) => error' "Meta \{show ix} already solved! (solve2 :: Nil)"
(Solved _ k x) => error' "Meta \{show ix} already solved! [solve2]"
OutOfScope => error' "Meta \{show ix} out of scope"
maybeCheck $ for_ cons $ \case
MkMc fc env sp rhs => do
@@ -645,7 +654,7 @@ freshMeta ctx fc ty kind = do
debug $ \ _ => "fresh meta \{show mc.next} : \{show ty} (\{show kind})"
-- need the ns here
-- we were fudging this for v1
let qn = QN ("$meta" :: Nil) (show mc.next)
let qn = QN top.ns "$m\{show mc.next}"
let newmeta = Unsolved fc qn ctx ty kind Nil
writeIORef top.metaCtx $ MC (updateMap qn newmeta mc.metas) (1 + mc.next) mc.mcmode
-- infinite loop - keeps trying Ord a => Ord (a \x a)
@@ -1445,8 +1454,7 @@ infer ctx (RVar fc nm) = go 0 ctx.types
Nothing => error fc "\{show nm} not in scope"
go i ((x, ty) :: xs) = if x == nm then pure $ (Bnd fc i, ty)
else go (i + 1) xs
-- FIXME tightens up output but hardcodes a name
-- infer ctx (RApp fc (RVar _ "_$_") u icit) = infer ctx u
infer ctx (RApp fc t u icit) = do
-- If the app is explicit, add any necessary metas
(icit, t, tty) <- case the Icit icit of

View File

@@ -1,5 +1,7 @@
module Lib.Erasure
import Prelude
import Lib.Common
import Lib.Types
import Data.SnocList
import Lib.TopContext

View File

@@ -1,5 +1,8 @@
module Lib.Eval
import Prelude
import Lib.Common
import Lib.Prettier
import Lib.Types
import Lib.TopContext

View File

@@ -2,6 +2,9 @@ module Lib.Parser
-- NOW Still working on this.
import Prelude
import Lib.Common
import Data.SortedMap
import Data.String
import Lib.Parser.Impl
import Lib.Syntax

View File

@@ -1,5 +1,6 @@
module Lib.Parser.Impl
import Prelude
import Lib.Token
import Lib.Common
import Data.String

View File

@@ -1,7 +1,7 @@
-- A prettier printer, Philip Wadler
-- https://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf
module Lib.Prettier
import Prelude
import Data.Int
-- `Doc` is a pretty printing document. Constructors are private, use

View File

@@ -1,13 +1,17 @@
module Lib.ProcessDecl
import Prelude
import Data.IORef
import Data.String
import Lib.Common
import Lib.Elab
import Lib.Parser
import Lib.Syntax
import Data.SortedMap
import Lib.TopContext
import Lib.Eval
import Lib.Prettier
import Lib.Types
import Lib.Util
import Lib.Erasure

View File

@@ -1,5 +1,7 @@
module Lib.Syntax
import Prelude
import Lib.Common
import Data.String
import Lib.Parser.Impl
import Lib.Prettier

View File

@@ -7,7 +7,7 @@ module Lib.Tokenizer
-- Newt is having a rough time dealing with do blocks for Either in here
--
import Prelude
import Lib.Token
import Lib.Common
import Data.String

View File

@@ -3,6 +3,8 @@ module Lib.TopContext
import Data.IORef
import Data.SortedMap
import Data.String
import Prelude
import Lib.Common
import Lib.Types
-- I want unique ids, to be able to lookup, update, and a Ref so
@@ -10,29 +12,39 @@ import Lib.Types
lookup : QName -> TopContext -> Maybe TopEntry
lookup nm top = lookupMap' nm top.defs
lookup qn@(QN ns nm) top =
case lookupMap' qn top.defs of
Just entry => Just entry
Nothing => case lookupMap' ns top.modules of
Just mod => lookupMap' qn mod.modDefs
Nothing => Nothing
-- TODO - look at imported namespaces, and either have a map of imported names or search imported namespaces..
lookupRaw : String -> TopContext -> Maybe TopEntry
lookupRaw raw top = go $ toList top.defs
lookupRaw raw top =
case lookupMap' (QN top.ns raw) top.defs of
Just entry => Just entry
Nothing => go top.imported
where
go : List (QName × TopEntry) -> Maybe TopEntry
go : List (List String) Maybe TopEntry
go Nil = Nothing
go (((QN ns nm), entry) :: rest) = if nm == raw then Just entry else go rest
-- Maybe pretty print?
go (ns :: nss) = case lookupMap' ns top.modules of
Nothing => go nss
Just mod => case lookupMap' (QN ns raw) mod.modDefs of
Just entry => Just entry
Nothing => go nss
instance Show TopContext where
show (MkTop defs metas _ _ _ _) = "\nContext:\n (\{ joinBy "\n" $ map (show snd) $ toList defs} :: Nil)"
show (MkTop _ _ _ defs metas _ _ _) = "\nContext:\n (\{ joinBy "\n" $ map (show snd) $ toList defs} :: Nil)"
-- TODO need to get class dependencies working
emptyTop : ∀ io. {{Monad io}} {{HasIO io}} -> io TopContext
emptyTop = do
mcctx <- newIORef (MC EmptyMap 0 CheckAll)
errs <- newIORef $ the (List Error) Nil
pure $ MkTop EmptyMap mcctx False errs Nil EmptyMap
pure $ MkTop EmptyMap Nil Nil EmptyMap mcctx False errs EmptyMap
setDef : QName -> FC -> Tm -> Def -> M Unit
@@ -41,9 +53,9 @@ setDef name fc ty def = do
let (Nothing) = lookupMap' name top.defs
| Just (MkEntry fc' nm' ty' def') => error fc "\{show name} is already defined at \{show fc'}"
modify $ \case
MkTop defs metaCtx verbose errors loaded ops =>
MkTop mods imp ns defs metaCtx verbose errors ops =>
let defs = (updateMap name (MkEntry fc name ty def) top.defs) in
MkTop defs metaCtx verbose errors loaded ops
MkTop mods imp ns defs metaCtx verbose errors ops
updateDef : QName -> FC -> Tm -> Def -> M Unit
@@ -52,9 +64,9 @@ updateDef name fc ty def = do
let (Just (MkEntry fc' nm' ty' def')) = lookupMap' name top.defs
| Nothing => error fc "\{show name} not declared"
modify $ \case
MkTop defs metaCtx verbose errors loaded ops =>
MkTop mods imp ns defs metaCtx verbose errors ops =>
let defs = (updateMap name (MkEntry fc' name ty def) defs) in
MkTop defs metaCtx verbose errors loaded ops
MkTop mods imp ns defs metaCtx verbose errors ops
addError : Error -> M Unit
addError err = do

View File

@@ -1,6 +1,6 @@
module Lib.Types
-- For FC, Error
import Prelude
import Lib.Common
import Lib.Prettier
@@ -332,6 +332,14 @@ record TopEntry where
instance Show TopEntry where
show (MkEntry fc name type def) = "\{show name} : \{show type} := \{show def}"
record ModContext where
constructor MkModCtx
modDefs : SortedMap QName TopEntry
-- Do we need this if everything solved is zonked?
modMetaCtx : MetaContext
-- longer term maybe drop this, put the operator decls in ctxDefs and collect them on import
ctxOps : Operators
-- Top level context.
-- Most of the reason this is separate is to have a different type
-- `Def` for the entries.
@@ -339,15 +347,26 @@ instance Show TopEntry where
-- The price is that we have names in addition to levels. Do we want to
-- expand these during normalization?
-- A placeholder while walking through dependencies of a module
emptyModCtx : ModContext
emptyModCtx = MkModCtx EmptyMap (MC EmptyMap 0 NoCheck) EmptyMap
record TopContext where
constructor MkTop
-- We'll add a map later?
-- maybe we use a String instead of List String for the left of QN
-- I'm putting a dummy entry in
modules : SortedMap (List String) ModContext
imported : List (List String)
-- current module
ns : List String
defs : SortedMap QName TopEntry
metaCtx : IORef MetaContext
-- Global values
verbose : Bool -- command line flag
errors : IORef (List Error)
-- loaded modules
loaded : List String
-- what do we do here? we can accumulate for now, but we'll want to respect import
ops : Operators
-- we'll use this for typechecking, but need to keep a TopContext around too.
@@ -482,12 +501,18 @@ error' : ∀ a. String -> M a
error' msg = throwError $ E emptyFC msg
lookupMeta : QName -> M MetaEntry
lookupMeta ix = do
lookupMeta ix@(QN ns nm) = do
top <- get
mc <- readIORef {M} top.metaCtx
case lookupMap' ix mc.metas of
Just meta => pure meta
Nothing => pure OutOfScope
Nothing => case lookupMap' ns top.modules of
Nothing =>
error emptyFC "missing module: \{show ns}"
Just mod => case lookupMap' ix mod.modMetaCtx.metas of
Nothing =>
error emptyFC "missing meta: \{show ix}"
Just entry => pure entry
mkCtx : FC -> Context
mkCtx fc = MkCtx 0 Nil Nil Nil fc

View File

@@ -1,5 +1,7 @@
module Lib.Util
import Prelude
import Lib.Common
import Lib.Types
import Data.List1

View File

@@ -1,8 +1,10 @@
module Main
import Prelude
import Data.List1
import Data.String
import Data.IORef
import Data.SortedMap
import Lib.Common
import Lib.Compile
import Lib.Parser
@@ -18,6 +20,9 @@ import Lib.Syntax
import Lib.Syntax
import Node
primNS : List String
primNS = ("Prim" :: Nil)
jsonTopContext : M Json
jsonTopContext = do
top <- get
@@ -77,9 +82,10 @@ processModule : FC -> String -> List String -> QName -> M String
processModule importFC base stk qn@(QN ns nm) = do
top <- get
-- TODO make top.loaded a List QName
let name = joinBy "." (snoc ns nm)
let (False) = elem name top.loaded | _ => pure ""
modify (\ top => MkTop top.defs top.metaCtx top.verbose top.errors (name :: top.loaded)top.ops)
let modns = (snoc ns nm)
let name = joinBy "." modns
let (Nothing) = lookupMap modns top.modules | _ => pure ""
modify (\ top => MkTop (updateMap modns emptyModCtx top.modules) top.imported top.ns top.defs top.metaCtx top.verbose top.errors top.ops)
let fn = (joinBy "/" (base :: ns)) ++ "/" ++ nm ++ ".newt"
(Right src) <- liftIO {M} $ readFile fn
| Left err => exitFailure "ERROR at \{show importFC}: error reading \{fn}: \{show err}"
@@ -99,7 +105,7 @@ processModule importFC base stk qn@(QN ns nm) = do
let (Right (imports, ops, toks)) = partialParse fn parseImports ops toks
| Left (err, toks) => exitFailure (showError src err)
for imports $ \case
imported <- for imports $ \case
MkImport fc name' => do
let (a,b) = unsnoc $ split1 name' "."
let qname = QN a b
@@ -107,16 +113,30 @@ processModule importFC base stk qn@(QN ns nm) = do
when (elem name' stk) $ \ _ => error emptyFC "import loop \{show name} -> \{show name'}"
processModule fc base (name :: stk) qname
pure $ split name' "."
let imported = snoc imported primNS
-- I guess we should empty defs now instead of at the end?
putStrLn $ "MODNS " ++ show modns
top <- get
(decls, ops) <- parseDecls fn top.ops toks Lin
top <- get
mc <- readIORef top.metaCtx
(decls, ops) <- parseDecls fn top.ops toks Lin
modify (\ top => MkTop top.defs top.metaCtx top.verbose top.errors top.loaded ops)
freshMC <- newIORef (MC EmptyMap 0 CheckAll)
-- set imported, mod, freshMC, ops before processing
modify (\ top => MkTop top.modules imported modns EmptyMap freshMC top.verbose top.errors ops)
putStrLn "process Decls"
traverse (tryProcessDecl ns) (collectDecl decls)
-- update modules with result
top <- get
mc <- readIORef top.metaCtx
let modules = updateMap modns (MkModCtx top.defs mc top.ops) top.modules
freshMC <- newIORef (MC EmptyMap 0 CheckAll)
modify (\ top => MkTop modules Nil Nil EmptyMap freshMC top.verbose top.errors top.ops)
(Nil) <- liftIO {M} $ readIORef top.errors
| errors => do
for_ errors $ \err =>
@@ -179,9 +199,15 @@ processFile fn = do
-- let base = if base == "" then "." else base
-- declare internal primitives
processDecl ("Prim" :: Nil) (PType emptyFC "Int" Nothing)
processDecl ("Prim" :: Nil) (PType emptyFC "String" Nothing)
processDecl ("Prim" :: Nil) (PType emptyFC "Char" Nothing)
processDecl primNS (PType emptyFC "Int" Nothing)
processDecl primNS (PType emptyFC "String" Nothing)
processDecl primNS (PType emptyFC "Char" Nothing)
top <- get
let modules = updateMap primNS (MkModCtx top.defs (MC EmptyMap 0 CheckAll) top.ops) top.modules
modify (\ top => MkTop modules (primNS :: Nil) Nil EmptyMap top.metaCtx top.verbose top.errors top.ops)
src <- processModule emptyFC base Nil qn
top <- get
@@ -200,7 +226,7 @@ cmdLine : List String -> M (Maybe String × List String)
cmdLine Nil = pure (Nothing, Nil)
cmdLine ("--top" :: args) = cmdLine args -- handled later
cmdLine ("-v" :: args) = do
modify (\ top => MkTop top.defs top.metaCtx True top.errors top.loaded top.ops)
modify (\ top => MkTop top.modules top.imported top.ns top.defs top.metaCtx True top.errors top.ops)
cmdLine args
cmdLine ("-o" :: fn :: args) = do
(out, files) <- cmdLine args