use string for module names

This commit is contained in:
2026-02-13 10:18:28 -08:00
parent 4ec199b064
commit 24048eadf1
12 changed files with 58 additions and 60 deletions

View File

@@ -12,19 +12,19 @@ import Lib.Token
import Lib.Elab import Lib.Elab
-- For now we cheat and assume capitalized directories are a module component -- For now we cheat and assume capitalized directories are a module component
decomposeName : String String × List String decomposeName : String String × String
decomposeName fn = decomposeName fn =
go Nil $ Lin <>< split (fst $ splitFileName fn) "/" go Nil $ Lin <>< split (fst $ splitFileName fn) "/"
where where
go : List String SnocList String String × List String go : List String SnocList String String × String
go acc Lin = (".", acc) go acc Lin = (".", joinBy "." acc)
go acc (xs :< x) = if isUpper $ strIndex x 0 go acc (xs :< x) = if isUpper $ strIndex x 0
then go (x :: acc) xs then go (x :: acc) xs
else (joinBy "/" (xs :< x <>> Nil), acc) else (joinBy "/" (xs :< x <>> Nil), joinBy "." acc)
-- 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
-- Later we will either get good FC for entries or scan them all and build a cache. -- Later we will either get good FC for entries or scan them all and build a cache.
getHoverInfo : FileSource List String Int Int M (Maybe (String × FC)) getHoverInfo : FileSource String Int Int M (Maybe (String × FC))
getHoverInfo repo modns row col = do getHoverInfo repo modns row col = do
mod <- processModule emptyFC repo Nil modns mod <- processModule emptyFC repo Nil modns
-- not necessarily loaded into top... (Maybe push this down into that branch of processModule) -- not necessarily loaded into top... (Maybe push this down into that branch of processModule)

View File

@@ -73,7 +73,7 @@ updateFile fn src = unsafePerformIO $ do
let (Right ((nameFC, modName), _, _)) = partialParse fn parseModHeader emptyMap toks let (Right ((nameFC, modName), _, _)) = partialParse fn parseModHeader emptyMap toks
| Left (err,toks) => writeIORef state st | Left (err,toks) => writeIORef state st
Right (ctx,_) <- (invalidateModule $ split modName ".").runM st.topContext Right (ctx,_) <- (invalidateModule modName).runM st.topContext
| _ => writeIORef state st | _ => writeIORef state st
-- TODO It doesn't have record type, but eta expanding resolves this. See if there is a quick fix. -- TODO It doesn't have record type, but eta expanding resolves this. See if there is a quick fix.
-- modifyIORef state [ topContext := ctx ] -- modifyIORef state [ topContext := ctx ]
@@ -90,7 +90,7 @@ fcToRange (MkFC uri (MkBounds sr sc er ec)) =
hoverInfo : String Int Int JSObject hoverInfo : String Int Int JSObject
hoverInfo uri line col = unsafePerformIO $ do hoverInfo uri line col = unsafePerformIO $ do
let (base,modns) = decomposeName uri let (base,modns) = decomposeName uri
putStrLn "Hover \{uri} base \{base} mod \{joinBy "." modns}" putStrLn "Hover \{uri} base \{base} mod \{modns}"
st <- readIORef state st <- readIORef state
if (st.baseDir /= base) if (st.baseDir /= base)
then resetState base then resetState base
@@ -119,8 +119,9 @@ errorToDiag (Postpone fc qn msg) = errorToDiag $ E fc "Postpone \{show qn} \{msg
checkFile : String → JSObject checkFile : String → JSObject
checkFile fn = unsafePerformIO $ do checkFile fn = unsafePerformIO $ do
let (base,modns) = decomposeName fn let (base,modName) = decomposeName fn
putStrLn "Checking \{fn} base \{base} mod \{joinBy "." modns}"
putStrLn "Checking \{fn} base \{base} mod \{modName}"
st <- readIORef state st <- readIORef state
if (st.baseDir /= base) if (st.baseDir /= base)
then resetState base then resetState base
@@ -128,7 +129,7 @@ checkFile fn = unsafePerformIO $ do
(Right (top, json)) <- (do (Right (top, json)) <- (do
modifyTop [ errors := Nil ] modifyTop [ errors := Nil ]
putStrLn "processModule" putStrLn "processModule"
_ <- processModule emptyFC lspFileSource Nil modns _ <- processModule emptyFC lspFileSource Nil modName
pure MkUnit pure MkUnit
-- pull out errors and infos -- pull out errors and infos
top <- getTop top <- getTop

View File

@@ -132,8 +132,8 @@ fcCol fc = fc.bnds.startCol
class HasFC a where class HasFC a where
getFC : a -> FC getFC : a -> FC
primNS : List String primNS : String
primNS = ("Prim" :: Nil) primNS = "Prim"
emptyFC : FC emptyFC : FC
emptyFC = MkFC "" (MkBounds 0 0 0 0) emptyFC = MkFC "" (MkBounds 0 0 0 0)
@@ -141,10 +141,9 @@ emptyFC = MkFC "" (MkBounds 0 0 0 0)
emptyFC' : String FC emptyFC' : String FC
emptyFC' fn = MkFC fn (MkBounds 0 0 0 0) emptyFC' fn = MkFC fn (MkBounds 0 0 0 0)
-- Error of a parse -- Using a String instead of List String for the module shaved about 16% of compile time...
data QName : U where data QName : U where
QN : List String -> String -> QName QN : String -> String -> QName
.baseName : QName String .baseName : QName String
(QN _ name).baseName = name (QN _ name).baseName = name
@@ -154,8 +153,8 @@ instance Eq QName where
QN ns n == QN ns' n' = if n == n' then ns == ns' else False QN ns n == QN ns' n' = if n == n' then ns == ns' else False
instance Show QName where instance Show QName where
show (QN Nil n) = n show (QN "" n) = n
show (QN ns n) = joinBy "." ns ++ "." ++ n show (QN ns n) = ns ++ "." ++ n
instance Ord QName where instance Ord QName where
compare (QN ns nm) (QN ns' nm') = if ns == ns' then compare nm nm' else compare ns ns' compare (QN ns nm) (QN ns' nm') = if ns == ns' then compare nm nm' else compare ns ns'

View File

@@ -157,7 +157,7 @@ compileTerm tm@(App _ _ _) = case funArgs tm of
applySucc Nil = pure $ CLam "x" $ CPrimOp "+" (CLit $ LInt 1) (CBnd 0) applySucc Nil = pure $ CLam "x" $ CPrimOp "+" (CLit $ LInt 1) (CBnd 0)
applySucc (t :: Nil) = pure $ CPrimOp "+" (CLit $ LInt 1) t applySucc (t :: Nil) = pure $ CPrimOp "+" (CLit $ LInt 1) t
applySucc _ = error emptyFC "overapplied Succ \{show tm}" applySucc _ = error emptyFC "overapplied Succ \{show tm}"
compileTerm (UU _) = pure $ CRef (QN Nil "U") compileTerm (UU _) = pure $ CRef (QN "" "U")
compileTerm (Pi _ nm icit rig t u) = do compileTerm (Pi _ nm icit rig t u) = do
t' <- compileTerm t t' <- compileTerm t
u' <- compileTerm u u' <- compileTerm u

View File

@@ -1549,7 +1549,7 @@ infer ctx tm@(RUpdateRec fc _ _) = do
infer ctx (RVar fc nm) = go 0 ctx.types infer ctx (RVar fc nm) = go 0 ctx.types
where where
entryNS : TopEntry String entryNS : TopEntry String
entryNS (MkEntry fc (QN ns _) _ _ _) = joinBy "." ns entryNS (MkEntry fc (QN ns _) _ _ _) = ns
go : Int -> List (String × Val) -> M (Tm × Val) go : Int -> List (String × Val) -> M (Tm × Val)
go i Nil = do go i Nil = do

View File

@@ -100,9 +100,9 @@ checkAlreadyDef fc nm = do
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}"
processDecl : List String -> Decl -> M Unit processDecl : String -> Decl -> M Unit
processTypeSig : List String FC List Name Raw M Unit processTypeSig : String FC List Name Raw M Unit
processTypeSig ns fc names tm = do processTypeSig ns fc names tm = do
log 1 $ \ _ => "-----" log 1 $ \ _ => "-----"
top <- getTop top <- getTop
@@ -112,7 +112,7 @@ processTypeSig ns fc names tm = do
ignore $ for names $ \nm => setDef (QN ns nm) fc ty Axiom Nil ignore $ for names $ \nm => setDef (QN ns nm) fc ty Axiom Nil
processPrimType : List Name FC Name Maybe Raw M Unit processPrimType : String FC Name Maybe Raw M Unit
processPrimType ns fc nm ty = do processPrimType ns fc nm ty = do
top <- getTop top <- getTop
ty' <- check (mkCtx fc) (maybe (RU fc) id ty) (VU fc) ty' <- check (mkCtx fc) (maybe (RU fc) id ty) (VU fc)
@@ -120,7 +120,7 @@ processPrimType ns fc nm ty = do
setDef (QN ns nm) fc ty' (PrimTCon arity) Nil setDef (QN ns nm) fc ty' (PrimTCon arity) Nil
processPrimFn : List String FC String List String Raw String M Unit processPrimFn : String FC String List String Raw String M Unit
processPrimFn ns fc nm used ty src = do processPrimFn ns fc nm used ty src = do
top <- getTop top <- getTop
ty <- check (mkCtx fc) ty (VU fc) ty <- check (mkCtx fc) ty (VU fc)
@@ -153,7 +153,7 @@ complexity (Lit _ _) = 0
complexity (Case _ sc (CaseCons _ _ t :: Nil)) = 1 + complexity sc + complexity t complexity (Case _ sc (CaseCons _ _ t :: Nil)) = 1 + complexity sc + complexity t
complexity _ = 100 complexity _ = 100
processDef : List String FC String List (Raw × Maybe Raw) M Unit processDef : String FC String List (Raw × Maybe Raw) M Unit
processDef ns fc nm clauses = do processDef ns fc nm clauses = do
log 1 $ \ _ => "-----" log 1 $ \ _ => "-----"
log 1 $ \ _ => "Def \{show nm}" log 1 $ \ _ => "Def \{show nm}"
@@ -194,7 +194,7 @@ processDef ns fc nm clauses = do
then setFlag (QN ns nm) fc Inline then setFlag (QN ns nm) fc Inline
else pure MkUnit else pure MkUnit
processCheck : List String FC Raw Raw M Unit processCheck : String FC Raw Raw M Unit
processCheck ns fc tm ty = do processCheck ns fc tm ty = do
log 1 $ \ _ => "----- DCheck" log 1 $ \ _ => "----- DCheck"
top <- getTop top <- getTop
@@ -209,7 +209,7 @@ processCheck ns fc tm ty = do
putStrLn " NF \{render 90 $ pprint Nil norm}" putStrLn " NF \{render 90 $ pprint Nil norm}"
processClass : List String FC (FC × String) Telescope List Decl M Unit processClass : String FC (FC × String) Telescope List Decl M Unit
processClass ns classFC (nameFC, nm) tele decls = do processClass ns classFC (nameFC, nm) tele decls = do
-- REVIEW maybe we can leverage Record for this -- REVIEW maybe we can leverage Record for this
-- a couple of catches, we don't want the dotted accessors and -- a couple of catches, we don't want the dotted accessors and
@@ -257,7 +257,7 @@ processClass ns classFC (nameFC, nm) tele decls = do
mkApp : Raw BindInfo × Raw Raw mkApp : Raw BindInfo × Raw Raw
mkApp acc (BI fc nm icit _, _) = RApp fc acc (RVar fc nm) icit mkApp acc (BI fc nm icit _, _) = RApp fc acc (RVar fc nm) icit
processInstance : List String FC Raw Maybe (List Decl) M Unit processInstance : String FC Raw Maybe (List Decl) M Unit
processInstance ns instfc ty decls = do processInstance ns instfc ty decls = do
log 1 $ \ _ => "-----" log 1 $ \ _ => "-----"
log 1 $ \ _ => "Instance \{render 90 $ pretty ty}" log 1 $ \ _ => "Instance \{render 90 $ pretty ty}"
@@ -372,7 +372,7 @@ processInstance ns instfc ty decls = do
apply x (y :: xs) = error instfc "expected pi type \{show x}" apply x (y :: xs) = error instfc "expected pi type \{show x}"
-- desugars to Data and processes it -- desugars to Data and processes it
processShortData : List String → FC → Raw → List Raw → M Unit processShortData : String → FC → Raw → List Raw → M Unit
processShortData ns fc lhs sigs = do processShortData ns fc lhs sigs = do
(nameFC, nm,args) <- getArgs lhs Nil (nameFC, nm,args) <- getArgs lhs Nil
let ty = foldr mkPi (RU fc) args let ty = foldr mkPi (RU fc) args
@@ -431,7 +431,7 @@ populateConInfo entries =
isSucc (MkEntry fc nm dty@(Pi _ _ _ _ (Ref _ a) (Ref _ b)) (DCon _ _ (Many :: Nil) hn) _) = a == b isSucc (MkEntry fc nm dty@(Pi _ _ _ _ (Ref _ a) (Ref _ b)) (DCon _ _ (Many :: Nil) hn) _) = a == b
isSucc _ = False isSucc _ = False
processData : List String FC FC × String Raw List Decl M Unit processData : String FC FC × String Raw List Decl M Unit
processData ns fc (nameFC, nm) ty cons = do processData ns fc (nameFC, nm) ty cons = do
log 1 $ \ _ => "-----" log 1 $ \ _ => "-----"
log 1 $ \ _ => "Data \{nm}" log 1 $ \ _ => "Data \{nm}"
@@ -487,7 +487,7 @@ processData ns fc (nameFC, nm) ty cons = do
checkDeclType _ = error fc "data type doesn't return U" checkDeclType _ = error fc "data type doesn't return U"
processRecord : List String FC FC × String Telescope Maybe (FC × Name) List Decl M Unit processRecord : String FC FC × String Telescope Maybe (FC × Name) List Decl M Unit
processRecord ns recordFC (nameFC, nm) tele cname decls = do processRecord ns recordFC (nameFC, nm) tele cname decls = do
log 1 $ \ _ => "-----" log 1 $ \ _ => "-----"
log 1 $ \ _ => "Record" log 1 $ \ _ => "Record"

View File

@@ -23,10 +23,11 @@ addPrimitives = do
top <- getTop top <- getTop
let mod = MkModCtx "" top.defs (MC emptyMap Nil 0 CheckAll) top.ops Nil top.errors let mod = MkModCtx "" top.defs (MC emptyMap Nil 0 CheckAll) top.ops Nil top.errors
let modules = updateMap primNS mod top.modules let modules = updateMap primNS mod top.modules
-- TODO - do we clear this? Try just modules := modules, but wait until this refactor is done.
modifyTop [ modules := modules modifyTop [ modules := modules
; imported := primNS :: Nil ; imported := primNS :: Nil
; hints := emptyMap ; hints := emptyMap
; ns := Nil ; ns := ""
; defs := emptyMap ; defs := emptyMap
] ]
pure mod pure mod
@@ -62,17 +63,17 @@ importHints (entry :: entries) = do
-- HACK this is returning src to help render errors.. -- HACK this is returning src to help render errors..
-- Maybe return module, put src and errors in module, add error for import with error, callers can sort out what they want to do? -- Maybe return module, put src and errors in module, add error for import with error, callers can sort out what they want to do?
-- The issue here is command line newt wants to report all errors (we can print that though?) LSP wants something more subtle -- The issue here is command line newt wants to report all errors (we can print that though?) LSP wants something more subtle
processModule : FC FileSource List String (stack : List 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
let name = joinBy "." modns
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 fn = joinBy "/" modns ++ ".newt" let fn = joinBy "/" parts ++ ".newt"
-- TODO now we can pass in the module name... -- TODO now we can pass in the module name...
(fn,src) <- repo.getFile importFC fn (fn,src) <- repo.getFile importFC fn
let (Right toks) = tokenise fn src let (Right toks) = tokenise fn src
@@ -82,21 +83,18 @@ processModule importFC repo stk modns = do
| Left (err, toks) => throwError err | Left (err, toks) => throwError err
log 1 $ \ _ => "scan imports for module \{modName}" log 1 $ \ _ => "scan imports for module \{modName}"
let (True) = modns == split modName "." let (True) = modns == modName
| _ => throwError $ E nameFC "module name \{show modName} doesn't match file name \{show fn}" | _ => throwError $ E nameFC "module name \{show modName} doesn't match file name \{show fn}"
let (Right (imports, ops, toks)) = partialParse fn parseImports ops toks let (Right (imports, ops, toks)) = partialParse fn parseImports ops toks
| Left (err, toks) => throwError err | Left (err, toks) => throwError err
let importNames = map importToName imports
imported <- for imports $ \case imported <- for imports $ \case
MkImport fc (nameFC, name') => do MkImport fc (nameFC, name') => do
let imp = split name' "." when (elem name' stk) $ \ _ => error nameFC "import loop \{modns} → \{name'}"
when (elem name' stk) $ \ _ => error nameFC "import loop \{show name} → \{show name'}" processModule nameFC repo (modns :: stk) name'
processModule nameFC repo (name :: stk) imp pure $ name'
pure $ imp processModule nameFC repo (modns :: stk) primNS
processModule nameFC repo (name :: stk) primNS
let imported = snoc imported primNS let imported = snoc imported primNS
putStrLn "module \{modName}" putStrLn "module \{modName}"
@@ -107,6 +105,7 @@ processModule importFC repo stk modns = do
top <- getTop top <- getTop
let freshMC = MC emptyMap Nil 0 CheckAll let freshMC = MC emptyMap Nil 0 CheckAll
-- NOW Print and drop errors here
-- set imported, mod, freshMC, ops before processing -- set imported, mod, freshMC, ops before processing
modifyTop [ imported := imported modifyTop [ imported := imported
; hints := emptyMap ; hints := emptyMap
@@ -125,7 +124,7 @@ processModule importFC repo stk modns = do
-- 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 importNames top.errors let mod = MkModCtx src top.defs top.metaCtx top.ops imported top.errors
let modules = updateMap modns mod top.modules let modules = updateMap modns mod top.modules
modifyTop [modules := modules] modifyTop [modules := modules]
@@ -134,11 +133,11 @@ processModule importFC repo stk modns = do
-- FIXME module context should hold errors, to report in replay -- FIXME module context should hold errors, to report in replay
pure mod pure mod
where where
tryProcessDecl : String List String Decl M Unit tryProcessDecl : String String Decl M Unit
tryProcessDecl src ns decl = do tryProcessDecl src ns decl = do
(Left err) <- tryError $ processDecl ns decl | _ => pure MkUnit (Left err) <- tryError $ processDecl ns decl | _ => pure MkUnit
addError err addError err
-- TODO clear dependents too. -- NOW TODO clear dependents too.
invalidateModule : List String -> M Unit invalidateModule : String -> M Unit
invalidateModule modname = modifyTop [modules $= deleteMap modname] invalidateModule modname = modifyTop [modules $= deleteMap modname]

View File

@@ -36,7 +36,8 @@ replQN = do
ident <- uident ident <- uident
rest <- many $ token Projection rest <- many $ token Projection
let name = joinBy "" (ident :: rest) let name = joinBy "" (ident :: rest)
pure $ uncurry QN $ unsnoc $ split1 name "." let (ns,nm) = unsnoc $ split1 name "."
pure $ QN (joinBy "." ns) nm
data ArgType = ArgNone | ArgString | ArgIdent | ArgOptInt | ArgQName data ArgType = ArgNone | ArgString | ArgIdent | ArgOptInt | ArgQName

View File

@@ -65,7 +65,7 @@ rewriteTailCalls nms tm = case tm of
-- the name of our trampoline -- the name of our trampoline
bouncer : QName bouncer : QName
bouncer = QN Nil "bouncer" bouncer = QN "" "bouncer"
doOptimize : List (QName × CExp) M (List (QName × CExp)) doOptimize : List (QName × CExp) M (List (QName × CExp))
doOptimize fns = do doOptimize fns = do

View File

@@ -34,7 +34,7 @@ lookupRaw raw top =
Just entry => Just entry Just entry => Just entry
Nothing => go top.imported Nothing => go top.imported
where where
go : List (List String) Maybe TopEntry go : List String Maybe TopEntry
go Nil = Nothing go Nil = Nothing
go (ns :: nss) = case lookupMap' ns top.modules of go (ns :: nss) = case lookupMap' ns top.modules of
Nothing => go nss Nothing => go nss
@@ -47,7 +47,7 @@ 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.defs}]"
emptyTop : TopContext emptyTop : TopContext
emptyTop = MkTop emptyMap Nil emptyMap Nil emptyMap (MC emptyMap Nil 0 CheckAll) 0 Nil emptyMap emptyTop = MkTop emptyMap Nil emptyMap "" emptyMap (MC emptyMap Nil 0 CheckAll) 0 Nil emptyMap
setFlag : QName FC EFlag M Unit setFlag : QName FC EFlag M Unit

View File

@@ -402,7 +402,7 @@ record ModContext where
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 ctxOps : Operators
modDeps : List (List String) modDeps : List String
modErrors : List Error modErrors : List Error
-- Top level context. -- Top level context.
@@ -421,15 +421,13 @@ HintTable = SortedMap QName (List (QName × Tm))
record TopContext where record TopContext where
constructor MkTop constructor MkTop
-- maybe we use a String instead of List String for the left of QN modules : SortedMap String ModContext
-- I'm putting a dummy entry in imported : List String
modules : SortedMap (List String) ModContext
imported : List (List String)
-- TCon name → function name × type -- TCon name → function name × type
hints : HintTable hints : HintTable
-- current module -- current module
ns : List String ns : String
defs : SortedMap QName TopEntry defs : SortedMap QName TopEntry
metaCtx : MetaContext metaCtx : MetaContext

View File

@@ -95,9 +95,9 @@ processFile fn = do
let modns = split modName "." let modns = split modName "."
base <- getBaseDir fn nameFC modns base <- getBaseDir fn nameFC modns
invalidateModule modns invalidateModule modName
let repo = dirFileSource base let repo = dirFileSource base
mod <- processModule emptyFC repo Nil modns mod <- processModule emptyFC repo Nil modName
top <- getTop top <- getTop
showErrors fn mod.modSource showErrors fn mod.modSource
@@ -122,7 +122,7 @@ cmdLine (fn :: args) = do
browseTop : QName M Unit browseTop : QName M Unit
browseTop qn@(QN ns x) = do browseTop qn@(QN ns x) = do
top <- getTop top <- getTop
let ns = snoc ns x let ns = ns ++ "." ++ x
let (Just mod) = lookupMap' ns top.modules let (Just mod) = lookupMap' ns top.modules
| _ => putStrLn "module \{show qn} not loaded" | _ => putStrLn "module \{show qn} not loaded"
go $ listValues mod.modDefs go $ listValues mod.modDefs