From 71161ffecd9d9b4446f2585b835120dfb157a9bf Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Fri, 1 Nov 2024 15:42:18 +0100 Subject: [PATCH] Fix package-base interaction (#3139) - Fixes #3009 - Fixes #2877 - TODO think if this makes https://github.com/anoma/juvix/issues/2985 slightly easier to fix --- app/Commands/Format.hs | 6 +- app/Commands/Repl.hs | 8 +- app/GlobalOptions.hs | 10 +- .../Backend/Html/Translation/FromTyped.hs | 4 +- .../Concrete/Translation/FromParsed.hs | 6 +- .../FromParsed/Analysis/Scoping.hs | 126 +++++++++--------- src/Juvix/Compiler/Pipeline.hs | 6 +- src/Juvix/Compiler/Pipeline/Driver.hs | 6 +- src/Juvix/Compiler/Pipeline/EntryPoint.hs | 15 ++- src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs | 20 +-- .../Compiler/Pipeline/Loader/PathResolver.hs | 24 ++-- .../Loader/PathResolver/PackageInfo.hs | 5 +- src/Juvix/Compiler/Pipeline/Package.hs | 2 + src/Juvix/Compiler/Pipeline/Package/Base.hs | 33 ++++- .../Pipeline/Package/Loader/EvalEff/IO.hs | 24 ++-- .../Pipeline/Package/Loader/PathResolver.hs | 2 +- src/Juvix/Compiler/Pipeline/Repl.hs | 10 +- src/Juvix/Compiler/Pipeline/Root.hs | 29 ++-- src/Juvix/Compiler/Pipeline/Root/Base.hs | 17 ++- src/Juvix/Extra/Strings.hs | 3 + src/Juvix/Formatter.hs | 4 +- test/Base.hs | 4 +- test/Repl/Positive.hs | 11 +- 23 files changed, 223 insertions(+), 152 deletions(-) diff --git a/app/Commands/Format.hs b/app/Commands/Format.hs index e89195623..55d7bab95 100644 --- a/app/Commands/Format.hs +++ b/app/Commands/Format.hs @@ -52,10 +52,10 @@ formatProject :: (Members '[App, EmbedIO, TaggedLock, Logger, Files, Output FormattedFileInfo] r) => Sem r FormatResult formatProject = silenceProgressLog . runPipelineOptions . runPipelineSetup $ do - pkg <- askPackage res :: [(ImportNode, PipelineResult ModuleInfo)] <- processProject - res' :: [(ImportNode, SourceCode)] <- runReader pkg . forM res $ \(node, nfo) -> do - src <- formatModuleInfo node nfo + res' :: [(ImportNode, SourceCode)] <- forM res $ \(node, nfo) -> do + pkgId :: PackageId <- (^. entryPointPackageId) <$> ask + src <- runReader pkgId (formatModuleInfo node nfo) return (node, src) formatProjectSourceCode res' diff --git a/app/Commands/Repl.hs b/app/Commands/Repl.hs index 1ad4d6e9c..8b35def49 100644 --- a/app/Commands/Repl.hs +++ b/app/Commands/Repl.hs @@ -190,7 +190,7 @@ replCommand opts input_ = catchAll $ do compileString :: Repl (Maybe Core.Node) compileString = do - (artifacts, res) <- liftIO $ compileReplInputIO' ctx (strip (pack s)) + (artifacts, res) <- compileReplInputIO' ctx (strip (pack s)) res' <- replFromEither res State.modify (over (replStateContext . _Just) (set replContextArtifacts artifacts)) return res' @@ -199,7 +199,7 @@ core :: String -> Repl () core input_ = do ctx <- replGetContext opts <- Reader.asks (^. replOptions) - compileRes <- liftIO (compileReplInputIO' ctx (strip (pack input_))) >>= replFromEither . snd + compileRes <- compileReplInputIO' ctx (strip (pack input_)) >>= replFromEither . snd whenJust compileRes (renderOutLn . Core.ppOut opts) dev :: String -> Repl () @@ -484,7 +484,7 @@ replTabComplete = Prefix (wordCompleter optsCompleter) defaultMatcher printRoot :: String -> Repl () printRoot _ = do r <- State.gets (^. replStateRoot . rootRootDir) - liftIO $ putStrLn (pack (toFilePath r)) + putStrLn (pack (toFilePath r)) runCommand :: (Members '[EmbedIO, App, TaggedLock] r) => ReplOptions -> Sem r () runCommand opts = do @@ -570,7 +570,7 @@ replExpressionUpToTyped txt = do $ expressionUpToTyped P.replPath txt replFromEither x -compileReplInputIO' :: ReplContext -> Text -> IO (Artifacts, (Either JuvixError (Maybe Core.Node))) +compileReplInputIO' :: (MonadIO m) => ReplContext -> Text -> m (Artifacts, (Either JuvixError (Maybe Core.Node))) compileReplInputIO' ctx txt = runM . runState (ctx ^. replContextArtifacts) diff --git a/app/GlobalOptions.hs b/app/GlobalOptions.hs index b7d67ac2b..fa17a693f 100644 --- a/app/GlobalOptions.hs +++ b/app/GlobalOptions.hs @@ -8,7 +8,7 @@ import CommonOptions import Juvix.Compiler.Core.Options qualified as Core import Juvix.Compiler.Internal.Pretty.Options qualified as Internal import Juvix.Compiler.Pipeline -import Juvix.Compiler.Pipeline.Root +import Juvix.Compiler.Pipeline.EntryPoint.IO import Juvix.Data.Effect.TaggedLock import Juvix.Data.Error.GenericError qualified as E import Juvix.Data.Field @@ -197,9 +197,7 @@ entryPointFromGlobalOptions :: Sem r EntryPoint entryPointFromGlobalOptions root mainFile opts = do mabsBuildDir :: Maybe (Path Abs Dir) <- liftIO (mapM (prepathToAbsDir cwd) optBuildDir) - pkg <- readPackageRootIO root - let def :: EntryPoint - def = defaultEntryPoint pkg root mainFile + def <- defaultEntryPointIO (root ^. rootRootDir) mainFile return def { _entryPointNoTermination = opts ^. globalNoTermination, @@ -220,9 +218,7 @@ entryPointFromGlobalOptions root mainFile opts = do entryPointFromGlobalOptionsNoFile :: (Members '[EmbedIO, TaggedLock] r, MonadIO (Sem r)) => Root -> GlobalOptions -> Sem r EntryPoint entryPointFromGlobalOptionsNoFile root opts = do mabsBuildDir :: Maybe (Path Abs Dir) <- mapM (prepathToAbsDir cwd) optBuildDir - pkg <- readPackageRootIO root - let def :: EntryPoint - def = defaultEntryPointNoFile pkg root + def <- defaultEntryPointIO (root ^. rootRootDir) Nothing return def { _entryPointNoTermination = opts ^. globalNoTermination, diff --git a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs index 0880b2d49..a562666aa 100644 --- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs +++ b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs @@ -251,8 +251,8 @@ topTemplate rightMenu' content' = do packageHeader :: Sem r Html packageHeader = do - pkgName' <- toHtml <$> asks (^. entryPointPackage . packageName) - version' <- toHtml <$> asks (^. entryPointPackage . packageVersion . to prettySemVer) + pkgName' <- toHtml <$> asks (^. entryPointPackageId . packageIdName) + version' <- toHtml <$> asks (^. entryPointPackageId . packageIdVersion . to prettySemVer) return $ Html.div ! Attr.id "package-header" diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs index d9eaa1604..beae4e818 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs @@ -18,7 +18,7 @@ import Juvix.Prelude fromParsed :: ( Members '[ HighlightBuilder, - Reader Package, + Reader PackageId, Reader ModuleTable, Reader Parsed.ParserResult, Error JuvixError, @@ -28,7 +28,7 @@ fromParsed :: ) => Sem r ScoperResult fromParsed = do - e <- ask + pkg <- ask tab <- ask r <- ask - scopeCheck e (getScopedModuleTable tab) r + scopeCheck pkg (getScopedModuleTable tab) r diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs index d9dd7b276..73336a582 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs @@ -32,7 +32,7 @@ import Juvix.Prelude scopeCheck :: (Members '[HighlightBuilder, Error JuvixError, NameIdGen] r) => - Package -> + PackageId -> ScopedModuleTable -> Parser.ParserResult -> Sem r ScoperResult @@ -56,7 +56,7 @@ iniScoperState tab = } scopeCheck' :: - (Members '[HighlightBuilder, Error ScoperError, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Error ScoperError, NameIdGen, Reader PackageId] r) => ScopedModuleTable -> Parser.ParserResult -> Module 'Parsed 'ModuleTop -> @@ -91,9 +91,9 @@ scopeCheck' importTab pr m = do scopeCheckRepl :: forall r a b. - (Members '[Error JuvixError, NameIdGen, Reader Package, State Scope, State ScoperState] r) => + (Members '[Error JuvixError, NameIdGen, Reader PackageId, State Scope, State ScoperState] r) => ( forall r'. - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader BindingStrategy, Reader Package] r') => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader BindingStrategy, Reader PackageId] r') => a -> Sem r' b ) -> @@ -121,7 +121,7 @@ scopeCheckRepl check importTab tab a = -- TODO refactor to have less code duplication scopeCheckExpressionAtoms :: forall r. - (Members '[Error JuvixError, NameIdGen, Reader Package, State Scope, State ScoperState] r) => + (Members '[Error JuvixError, NameIdGen, Reader PackageId, State Scope, State ScoperState] r) => ScopedModuleTable -> InfoTable -> ExpressionAtoms 'Parsed -> @@ -130,7 +130,7 @@ scopeCheckExpressionAtoms = scopeCheckRepl checkExpressionAtoms scopeCheckExpression :: forall r. - (Members '[Error JuvixError, NameIdGen, Reader Package, State Scope, State ScoperState] r) => + (Members '[Error JuvixError, NameIdGen, Reader PackageId, State Scope, State ScoperState] r) => ScopedModuleTable -> InfoTable -> ExpressionAtoms 'Parsed -> @@ -139,7 +139,7 @@ scopeCheckExpression = scopeCheckRepl checkParseExpressionAtoms scopeCheckImport :: forall r. - (Members '[Error JuvixError, NameIdGen, Reader Package, State Scope, State ScoperState] r) => + (Members '[Error JuvixError, NameIdGen, Reader PackageId, State Scope, State ScoperState] r) => ScopedModuleTable -> InfoTable -> Import 'Parsed -> @@ -158,7 +158,7 @@ freshVariable = freshSymbol KNameLocal KNameLocal checkProjectionDef :: forall r. - (Members '[Error ScoperError, InfoTableBuilder, Reader Package, Reader ScopeParameters, Reader InfoTable, Reader BindingStrategy, State Scope, State ScoperState, NameIdGen, State ScoperSyntax] r) => + (Members '[Error ScoperError, InfoTableBuilder, Reader PackageId, Reader ScopeParameters, Reader InfoTable, Reader BindingStrategy, State Scope, State ScoperState, NameIdGen, State ScoperSyntax] r) => ProjectionDef 'Parsed -> Sem r (ProjectionDef 'Scoped) checkProjectionDef p = do @@ -482,7 +482,7 @@ checkImport :: Reader InfoTable, NameIdGen, Reader BindingStrategy, - Reader Package + Reader PackageId ] r ) => @@ -504,7 +504,7 @@ checkImportPublic :: NameIdGen, HighlightBuilder, Reader BindingStrategy, - Reader Package + Reader PackageId ] r ) => @@ -928,19 +928,19 @@ checkFixityInfo ParsedFixityInfo {..} = do _fixityFieldsBraces } -getModuleId :: forall r. (Member (Reader Package) r) => TopModulePathKey -> Sem r ModuleId +getModuleId :: forall r. (Member (Reader PackageId) r) => TopModulePathKey -> Sem r ModuleId getModuleId path = do - p <- ask + pkg <- ask return ModuleId { _moduleIdPath = path, - _moduleIdPackage = p ^. packageName, - _moduleIdPackageVersion = show (p ^. packageVersion) + _moduleIdPackage = pkg ^. packageIdName, + _moduleIdPackageVersion = show (pkg ^. packageIdVersion) } checkFixitySyntaxDef :: forall r. - (Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, State ScoperSyntax, NameIdGen, InfoTableBuilder, Reader InfoTable, Reader Package] r) => + (Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, State ScoperSyntax, NameIdGen, InfoTableBuilder, Reader InfoTable, Reader PackageId] r) => FixitySyntaxDef 'Parsed -> Sem r (FixitySyntaxDef 'Scoped) checkFixitySyntaxDef FixitySyntaxDef {..} = topBindings $ do @@ -1074,7 +1074,7 @@ resolveIteratorSyntaxDef s@IteratorSyntaxDef {..} = do checkFunctionDef :: forall r. - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package, State ScoperSyntax, Reader BindingStrategy] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId, State ScoperSyntax, Reader BindingStrategy] r) => FunctionDef 'Parsed -> Sem r (FunctionDef 'Scoped) checkFunctionDef FunctionDef {..} = do @@ -1146,7 +1146,7 @@ checkFunctionDef FunctionDef {..} = do checkInductiveParameters :: forall r. - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => InductiveParameters 'Parsed -> Sem r (InductiveParameters 'Scoped) checkInductiveParameters params = do @@ -1162,7 +1162,7 @@ checkInductiveParameters params = do checkInductiveDef :: forall r. - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package, State ScoperSyntax, Reader BindingStrategy] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId, State ScoperSyntax, Reader BindingStrategy] r) => InductiveDef 'Parsed -> Sem r (InductiveDef 'Scoped) checkInductiveDef InductiveDef {..} = do @@ -1286,7 +1286,7 @@ localBindings = runReader BindingLocal checkTopModule :: forall r. - (Members '[HighlightBuilder, Error ScoperError, Reader ScopeParameters, State ScoperState, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Error ScoperError, Reader ScopeParameters, State ScoperState, Reader InfoTable, NameIdGen, Reader PackageId] r) => Module 'Parsed 'ModuleTop -> Sem r (Module 'Scoped 'ModuleTop, ScopedModule, Scope) checkTopModule m@Module {..} = checkedModule @@ -1405,7 +1405,7 @@ syntaxBlock m = checkModuleBody :: forall r. - (Members '[HighlightBuilder, InfoTableBuilder, Reader InfoTable, Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, NameIdGen, Reader Package, Reader BindingStrategy] r) => + (Members '[HighlightBuilder, InfoTableBuilder, Reader InfoTable, Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, NameIdGen, Reader PackageId, Reader BindingStrategy] r) => [Statement 'Parsed] -> Sem r (ExportInfo, [Statement 'Scoped]) checkModuleBody body = do @@ -1448,7 +1448,7 @@ checkModuleBody body = do checkSections :: forall r. - (Members '[HighlightBuilder, Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, State ScoperSyntax, Reader Package] r) => + (Members '[HighlightBuilder, Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, State ScoperSyntax, Reader PackageId] r) => StatementSections 'Parsed -> Sem r (StatementSections 'Scoped) checkSections sec = topBindings helper @@ -1639,7 +1639,7 @@ checkSections sec = topBindings helper defineInductiveModule headConstr i = do runReader (getLoc (i ^. inductiveName)) genModule where - genModule :: forall s'. (Members '[Reader Interval, Reader Package, State Scope] s') => Sem s' (Module 'Parsed 'ModuleLocal) + genModule :: forall s'. (Members '[Reader Interval, Reader PackageId, State Scope] s') => Sem s' (Module 'Parsed 'ModuleLocal) genModule = do _moduleKw <- G.kw G.kwModule _moduleKwEnd <- G.kw G.kwEnd @@ -1778,7 +1778,7 @@ mkSections = \case StatementOpenModule o -> Right (NonDefinitionOpenModule o) reserveLocalModuleSymbol :: - (Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package, Reader BindingStrategy] r) => + (Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId, Reader BindingStrategy] r) => Symbol -> Sem r S.Symbol reserveLocalModuleSymbol = @@ -1796,7 +1796,7 @@ checkLocalModule :: Reader InfoTable, NameIdGen, Reader BindingStrategy, - Reader Package + Reader PackageId ] r ) => @@ -1842,7 +1842,7 @@ checkLocalModule md@Module {..} = do registerName _modulePath' return m where - inheritScope :: (Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package, Reader BindingStrategy] r') => Sem r' () + inheritScope :: (Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId, Reader BindingStrategy] r') => Sem r' () inheritScope = do absPath <- (S.<.> _modulePath) <$> gets (^. scopePath) modify (set scopePath absPath) @@ -2088,7 +2088,7 @@ filterExportInfo pub openModif = alterEntries . filterScope Nothing -> id checkAxiomDef :: - (Members '[HighlightBuilder, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, Error ScoperError, State Scope, State ScoperState, NameIdGen, State ScoperSyntax, Reader BindingStrategy, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, Error ScoperError, State Scope, State ScoperState, NameIdGen, State ScoperSyntax, Reader BindingStrategy, Reader PackageId] r) => AxiomDef 'Parsed -> Sem r (AxiomDef 'Scoped) checkAxiomDef AxiomDef {..} = do @@ -2104,7 +2104,7 @@ entryToSymbol sentry csym = set S.nameConcrete csym (sentry ^. nsEntry) checkFunction :: forall r. - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => Function 'Parsed -> Sem r (Function 'Scoped) checkFunction f = do @@ -2123,7 +2123,7 @@ checkFunction f = do -- | for now functions defined in let clauses cannot be infix operators checkLetStatements :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => NonEmpty (LetStatement 'Parsed) -> Sem r (NonEmpty (LetStatement 'Scoped)) checkLetStatements = @@ -2241,7 +2241,7 @@ checkListPattern l = do checkList :: forall r. - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => List 'Parsed -> Sem r (List 'Scoped) checkList l = do @@ -2252,7 +2252,7 @@ checkList l = do checkLet :: forall r. - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => Let 'Parsed -> Sem r (Let 'Scoped) checkLet Let {..} = @@ -2278,7 +2278,7 @@ checkRhsExpression :: InfoTableBuilder, Reader InfoTable, NameIdGen, - Reader Package + Reader PackageId ] r ) => @@ -2304,7 +2304,7 @@ checkSideIfBranch :: InfoTableBuilder, Reader InfoTable, NameIdGen, - Reader Package + Reader PackageId ] r ) => @@ -2335,7 +2335,7 @@ checkSideIfs :: InfoTableBuilder, Reader InfoTable, NameIdGen, - Reader Package + Reader PackageId ] r ) => @@ -2352,7 +2352,7 @@ checkSideIfs SideIfs {..} = do checkCaseBranchRhs :: forall r. - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => CaseBranchRhs 'Parsed -> Sem r (CaseBranchRhs 'Scoped) checkCaseBranchRhs = \case @@ -2361,7 +2361,7 @@ checkCaseBranchRhs = \case checkCaseBranch :: forall r. - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => CaseBranch 'Parsed -> Sem r (CaseBranch 'Scoped) checkCaseBranch CaseBranch {..} = withLocalScope $ do @@ -2375,7 +2375,7 @@ checkCaseBranch CaseBranch {..} = withLocalScope $ do } checkDoBind :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => DoBind 'Parsed -> Sem r (DoBind 'Scoped) checkDoBind DoBind {..} = do @@ -2391,7 +2391,7 @@ checkDoBind DoBind {..} = do } checkDoLet :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => DoLet 'Parsed -> Sem r (DoLet 'Scoped) checkDoLet DoLet {..} = do @@ -2404,7 +2404,7 @@ checkDoLet DoLet {..} = do } checkDoStatement :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => DoStatement 'Parsed -> Sem r (DoStatement 'Scoped) checkDoStatement = \case @@ -2413,7 +2413,7 @@ checkDoStatement = \case DoStatementLet b -> DoStatementLet <$> checkDoLet b checkDo :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => Do 'Parsed -> Sem r (Do 'Scoped) checkDo Do {..} = do @@ -2426,7 +2426,7 @@ checkDo Do {..} = do } checkCase :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => Case 'Parsed -> Sem r (Case 'Scoped) checkCase Case {..} = do @@ -2442,7 +2442,7 @@ checkCase Case {..} = do checkIfBranch :: forall r k. - (SingI k, Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (SingI k, Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => IfBranch 'Parsed k -> Sem r (IfBranch 'Scoped k) checkIfBranch IfBranch {..} = withLocalScope $ do @@ -2458,7 +2458,7 @@ checkIfBranch IfBranch {..} = withLocalScope $ do } checkIf :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => If 'Parsed -> Sem r (If 'Scoped) checkIf If {..} = do @@ -2472,7 +2472,7 @@ checkIf If {..} = do } checkLambda :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => Lambda 'Parsed -> Sem r (Lambda 'Scoped) checkLambda Lambda {..} = do @@ -2485,7 +2485,7 @@ checkLambda Lambda {..} = do } checkLambdaClause :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => LambdaClause 'Parsed -> Sem r (LambdaClause 'Scoped) checkLambdaClause LambdaClause {..} = withLocalScope $ do @@ -2675,7 +2675,7 @@ checkScopedIden :: checkScopedIden n = checkName n >>= entryToScopedIden n checkExpressionAtom :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => ExpressionAtom 'Parsed -> Sem r (NonEmpty (ExpressionAtom 'Scoped)) checkExpressionAtom e = case e of @@ -2706,7 +2706,7 @@ reserveNamedArgumentName a = case a of checkNamedApplicationNew :: forall r. - (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => NamedApplicationNew 'Parsed -> Sem r (NamedApplicationNew 'Scoped) checkNamedApplicationNew napp = do @@ -2759,7 +2759,7 @@ checkNamedApplicationNew napp = do scopePun = checkScopedIden . NameUnqualified checkNamedArgumentNew :: - (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => HashMap Symbol ScopedIden -> NamedArgumentNew 'Parsed -> Sem r (NamedArgumentNew 'Scoped) @@ -2778,7 +2778,7 @@ checkNamedArgumentItemPun puns NamedArgumentPun {..} = } checkNamedArgumentFunctionDef :: - (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => NamedArgumentFunctionDef 'Parsed -> Sem r (NamedArgumentFunctionDef 'Scoped) checkNamedArgumentFunctionDef NamedArgumentFunctionDef {..} = do @@ -2788,7 +2788,7 @@ checkNamedArgumentFunctionDef NamedArgumentFunctionDef {..} = do { _namedArgumentFunctionDef = def } -checkRecordUpdate :: forall r. (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => RecordUpdate 'Parsed -> Sem r (RecordUpdate 'Scoped) +checkRecordUpdate :: forall r. (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => RecordUpdate 'Parsed -> Sem r (RecordUpdate 'Scoped) checkRecordUpdate RecordUpdate {..} = do tyName' <- getNameOfKind KNameInductive _recordUpdateTypeName info <- getRecordInfo tyName' @@ -2818,7 +2818,7 @@ checkRecordUpdate RecordUpdate {..} = do return (_nameItemImplicit, v) checkUpdateField :: - (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => RecordNameSignature 'Parsed -> RecordUpdateField 'Parsed -> Sem r (RecordUpdateField 'Scoped) @@ -2868,7 +2868,7 @@ getNameSignatureParsed s = do lookupNameSignature s' = gets (^. scoperNameSignatures . at s') checkIterator :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => Iterator 'Parsed -> Sem r (Iterator 'Scoped) checkIterator iter = do @@ -2911,7 +2911,7 @@ checkIterator iter = do return Iterator {..} checkInitializer :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => Initializer 'Parsed -> Sem r (Initializer 'Scoped) checkInitializer ini = do @@ -2924,7 +2924,7 @@ checkInitializer ini = do } checkRange :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => Range 'Parsed -> Sem r (Range 'Scoped) checkRange rng = do @@ -2949,7 +2949,7 @@ checkHole h = do } checkParens :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => ExpressionAtoms 'Parsed -> Sem r Expression checkParens e@(ExpressionAtoms as _) = case as of @@ -2965,13 +2965,13 @@ checkParens e@(ExpressionAtoms as _) = case as of checkExpressionAtoms :: forall r. - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => ExpressionAtoms 'Parsed -> Sem r (ExpressionAtoms 'Scoped) checkExpressionAtoms (ExpressionAtoms l i) = (`ExpressionAtoms` i) <$> sconcatMap checkExpressionAtom l checkJudoc :: - (Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => Judoc 'Parsed -> Sem r (Judoc 'Scoped) checkJudoc (Judoc groups) = @@ -2980,7 +2980,7 @@ checkJudoc (Judoc groups) = $ Judoc <$> mapM checkJudocGroup groups checkJudocGroup :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => JudocGroup 'Parsed -> Sem r (JudocGroup 'Scoped) checkJudocGroup = \case @@ -2988,26 +2988,26 @@ checkJudocGroup = \case JudocGroupLines l -> JudocGroupLines <$> mapM checkJudocBlock l checkJudocBlock :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => JudocBlock 'Parsed -> Sem r (JudocBlock 'Scoped) checkJudocBlock = \case JudocLines l -> JudocLines <$> mapM checkJudocLine l checkJudocBlockParagraph :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => JudocBlockParagraph 'Parsed -> Sem r (JudocBlockParagraph 'Scoped) checkJudocBlockParagraph = traverseOf judocBlockParagraphBlocks (mapM checkJudocBlock) checkJudocLine :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => JudocLine 'Parsed -> Sem r (JudocLine 'Scoped) checkJudocLine (JudocLine delim atoms) = JudocLine delim <$> mapM (mapM checkJudocAtom) atoms checkJudocAtom :: - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => JudocAtom 'Parsed -> Sem r (JudocAtom 'Scoped) checkJudocAtom = \case @@ -3016,7 +3016,7 @@ checkJudocAtom = \case checkParseExpressionAtoms :: forall r. - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => ExpressionAtoms 'Parsed -> Sem r Expression checkParseExpressionAtoms = checkExpressionAtoms >=> parseExpressionAtoms @@ -3028,7 +3028,7 @@ checkParsePatternAtom :: checkParsePatternAtom = checkPatternAtom >=> parsePatternAtom checkSyntaxDef :: - (Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package, State ScoperSyntax] r) => + (Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId, State ScoperSyntax] r) => SyntaxDef 'Parsed -> Sem r (SyntaxDef 'Scoped) checkSyntaxDef = \case diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index c76f29f97..57c3323fa 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -117,11 +117,11 @@ upToScopingEntry :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Error JuvixError, NameIdGen] r) => Sem r Scoper.ScoperResult upToScopingEntry = do - pkg <- asks (^. entryPointPackage) + pkg <- asks (^. entryPointPackageId) runReader pkg (upToScoping) upToScoping :: - (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader Package, Reader Store.ModuleTable, Error JuvixError, NameIdGen] r) => + (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader PackageId, Reader Store.ModuleTable, Error JuvixError, NameIdGen] r) => Sem r Scoper.ScoperResult upToScoping = Scoper.fromParsed @@ -129,7 +129,7 @@ upToInternal :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Error JuvixError, NameIdGen, Termination] r) => Sem r Internal.InternalResult upToInternal = do - pkg <- asks (^. entryPointPackage) + pkg <- asks (^. entryPointPackageId) runReader pkg upToScoping >>= Internal.fromConcrete upToInternalTyped :: diff --git a/src/Juvix/Compiler/Pipeline/Driver.hs b/src/Juvix/Compiler/Pipeline/Driver.hs index 139e9477b..3fcb3a508 100644 --- a/src/Juvix/Compiler/Pipeline/Driver.hs +++ b/src/Juvix/Compiler/Pipeline/Driver.hs @@ -301,7 +301,7 @@ processRecursiveUpToTyped = do let imports = HashMap.keys (_pipelineResultImports ^. Store.moduleTable) ms <- forM imports $ \imp -> withPathFile imp goImport - let pkg = entry ^. entryPointPackage + let pkg = entry ^. entryPointPackageId mid <- runReader pkg (getModuleId (_pipelineResult ^. Parser.resultModule . modulePath . to topModulePathKey)) a <- evalTopNameIdGen mid @@ -361,7 +361,7 @@ processFileUpTo :: processFileUpTo a = do entry <- ask res <- processFileUpToParsing entry - let pkg = entry ^. entryPointPackage + let pkg = entry ^. entryPointPackageId mid <- runReader pkg (getModuleId (res ^. pipelineResult . Parser.resultModule . modulePath . to topModulePathKey)) a' <- evalTopNameIdGen mid @@ -416,7 +416,7 @@ processFileToStoredCore :: Sem r (PipelineResult Core.CoreResult) processFileToStoredCore entry = runReader entry $ do res <- processFileUpToParsing entry - let pkg = entry ^. entryPointPackage + let pkg = entry ^. entryPointPackageId mid <- runReader pkg (getModuleId (res ^. pipelineResult . Parser.resultModule . modulePath . to topModulePathKey)) r <- evalTopNameIdGen mid diff --git a/src/Juvix/Compiler/Pipeline/EntryPoint.hs b/src/Juvix/Compiler/Pipeline/EntryPoint.hs index cd0cf26bc..cf23d9892 100644 --- a/src/Juvix/Compiler/Pipeline/EntryPoint.hs +++ b/src/Juvix/Compiler/Pipeline/EntryPoint.hs @@ -27,8 +27,8 @@ data EntryPoint = EntryPoint _entryPointNoPositivity :: Bool, _entryPointNoCoverage :: Bool, _entryPointNoStdlib :: Bool, - _entryPointPackage :: Package, - _entryPointPackageType :: PackageType, + _entryPointSomeRoot :: SomeRoot, + _entryPointPackageId :: PackageId, _entryPointStdin :: Maybe Text, _entryPointTarget :: Maybe Target, _entryPointDebug :: Bool, @@ -53,13 +53,13 @@ getEntryPointTarget e = fromMaybe defaultTarget (e ^. entryPointTarget) -- TODO is having a default target a good idea? defaultTarget = TargetCore -defaultEntryPoint :: Package -> Root -> Maybe (Path Abs File) -> EntryPoint +defaultEntryPoint :: PackageId -> Root -> Maybe (Path Abs File) -> EntryPoint defaultEntryPoint pkg root mainFile = (defaultEntryPointNoFile pkg root) { _entryPointModulePath = mainFile } -defaultEntryPointNoFile :: Package -> Root -> EntryPoint +defaultEntryPointNoFile :: PackageId -> Root -> EntryPoint defaultEntryPointNoFile pkg root = EntryPoint { _entryPointRoot = root ^. rootRootDir, @@ -70,8 +70,8 @@ defaultEntryPointNoFile pkg root = _entryPointNoCoverage = False, _entryPointNoStdlib = False, _entryPointStdin = Nothing, - _entryPointPackage = pkg, - _entryPointPackageType = root ^. rootPackageType, + _entryPointSomeRoot = root ^. rootSomeRoot, + _entryPointPackageId = pkg, _entryPointGenericOptions = defaultGenericOptions, _entryPointTarget = Nothing, _entryPointDebug = False, @@ -86,6 +86,9 @@ defaultEntryPointNoFile pkg root = _entryPointIsabelleOnlyTypes = False } +entryPointPackageType :: Lens' EntryPoint PackageType +entryPointPackageType = entryPointSomeRoot . someRootType + defaultUnrollLimit :: Int defaultUnrollLimit = 140 diff --git a/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs b/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs index 5852c0562..df7aac034 100644 --- a/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs +++ b/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs @@ -5,14 +5,14 @@ import Juvix.Compiler.Pipeline.Root import Juvix.Data.Effect.TaggedLock import Juvix.Prelude -defaultEntryPointIO :: (Members '[EmbedIO, TaggedLock, EmbedIO] r) => Path Abs Dir -> Path Abs File -> Sem r EntryPoint +defaultEntryPointIO :: forall r. (Members '[EmbedIO, TaggedLock, EmbedIO] r) => Path Abs Dir -> Maybe (Path Abs File) -> Sem r EntryPoint defaultEntryPointIO cwd mainFile = do - root <- findRootAndChangeDir (Just (parent mainFile)) Nothing cwd - pkg <- readPackageRootIO root - return (defaultEntryPoint pkg root (Just mainFile)) - -defaultEntryPointNoFileIO :: (Members '[EmbedIO, TaggedLock, EmbedIO] r) => Path Abs Dir -> Sem r EntryPoint -defaultEntryPointNoFileIO cwd = do - root <- findRootAndChangeDir Nothing Nothing cwd - pkg <- readPackageRootIO root - return (defaultEntryPointNoFile pkg root) + root <- findRootAndChangeDir (parent <$> mainFile) Nothing cwd + let pkgIdFromPackageFile :: Sem r PackageId + pkgIdFromPackageFile = (^. packageId) <$> readPackageRootIO root + pkgId <- case root ^. rootSomeRoot . someRootType of + GlobalStdlib -> pkgIdFromPackageFile + GlobalPackageDescription -> pkgIdFromPackageFile + LocalPackage -> pkgIdFromPackageFile + GlobalPackageBase -> return packageBaseId + return (defaultEntryPoint pkgId root mainFile) diff --git a/src/Juvix/Compiler/Pipeline/Loader/PathResolver.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver.hs index 6791445d9..8f0b8cb5c 100644 --- a/src/Juvix/Compiler/Pipeline/Loader/PathResolver.hs +++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver.hs @@ -28,7 +28,7 @@ import Juvix.Compiler.Pipeline.Loader.PathResolver.Paths import Juvix.Compiler.Pipeline.Lockfile import Juvix.Compiler.Pipeline.Package import Juvix.Compiler.Pipeline.Package.Loader.EvalEff -import Juvix.Compiler.Pipeline.Root.Base (PackageType (..)) +import Juvix.Compiler.Pipeline.Root.Base hiding (rootBuildDir) import Juvix.Data.SHA256 qualified as SHA256 import Juvix.Extra.Files import Juvix.Extra.PackageFiles @@ -39,14 +39,12 @@ import Juvix.Prelude mkPackage :: forall r. (Members '[Files, Error JuvixError, Reader ResolverEnv, DependencyResolver, EvalFileEff] r) => - Maybe EntryPoint -> + Maybe BuildDir -> Path Abs Dir -> Sem r Package -mkPackage mpackageEntry _packageRoot = do - let buildDirDep = case mpackageEntry of - Just packageEntry -> rootedBuildDir _packageRoot (packageEntry ^. entryPointBuildDir) - Nothing -> DefaultBuildDir - maybe (readPackage _packageRoot buildDirDep) (return . (^. entryPointPackage)) mpackageEntry +mkPackage mpackageBuildDir _packageRoot = do + let buildDirDep = fromMaybe DefaultBuildDir mpackageBuildDir + readPackage _packageRoot buildDirDep findPackageJuvixFiles :: (Members '[Files] r) => Path Abs Dir -> Sem r [Path Rel File] findPackageJuvixFiles pkgRoot = map (fromJust . stripProperPrefix pkgRoot) <$> walkDirRelAccum juvixAccum pkgRoot [] @@ -182,7 +180,13 @@ registerDependencies' conf = do LocalPackage -> do lockfile <- addRootDependency conf e (e ^. entryPointRoot) whenM shouldWriteLockfile $ do - packageFileChecksum <- SHA256.digestFile (e ^. entryPointPackage . packageFile) + let root :: Path Abs Dir = e ^. entryPointSomeRoot . someRootDir + packagePath :: Path Abs File <- do + let packageDotJuvix = mkPackagePath root + juvixDotYaml = mkPackageFilePath root + x <- findM fileExists' [packageDotJuvix, juvixDotYaml] + return (fromMaybe (error ("No package file found in " <> show root)) x) + packageFileChecksum <- SHA256.digestFile packagePath lockfilePath' <- lockfilePath writeLockfile lockfilePath' packageFileChecksum lockfile where @@ -216,7 +220,7 @@ addRootDependency conf e root = do checkRemoteDependency resolvedDependency let p = resolvedDependency ^. resolvedDependencyPath withEnvInitialRoot p $ do - pkg <- mkPackage (Just e) p + pkg <- mkPackage (Just (e ^. entryPointBuildDir)) p shouldUpdateLockfile' <- shouldUpdateLockfile pkg when shouldUpdateLockfile' setShouldUpdateLockfile let resolvedPkg :: Package @@ -245,7 +249,7 @@ addDependency me d = do case cached of Just cachedDep -> return cachedDep Nothing -> withEnvRoot p $ do - pkg <- mkPackage me p + pkg <- mkPackage ((^. entryPointBuildDir) <$> me) p addDependency' pkg me resolvedDependency addPackageRelativeFiles :: (Member (State ResolverState) r) => PackageInfo -> Sem r () diff --git a/src/Juvix/Compiler/Pipeline/Loader/PathResolver/PackageInfo.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/PackageInfo.hs index 977954760..3d2a785ba 100644 --- a/src/Juvix/Compiler/Pipeline/Loader/PathResolver/PackageInfo.hs +++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/PackageInfo.hs @@ -9,6 +9,7 @@ import Data.Versions import Juvix.Compiler.Concrete.Translation.ImportScanner.Base import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Data.CodeAnn +import Juvix.Extra.Strings qualified as Str import Juvix.Prelude data PackageLike @@ -46,11 +47,11 @@ packageLikeName :: SimpleGetter PackageLike Text packageLikeName = to $ \case PackageReal r -> r ^. packageName PackageGlobalStdlib -> "global-stdlib" - PackageBase -> "package-base" + PackageBase -> Str.packageBase PackageType -> "package-type" PackageDotJuvix -> "package-dot-juvix" --- | TODO perhaps we could versions for the non-real packages +-- | FIXME all PackageLike should have versions packageLikeVersion :: SimpleGetter PackageLike (Maybe SemVer) packageLikeVersion = to $ \case PackageReal pkg -> Just (pkg ^. packageVersion) diff --git a/src/Juvix/Compiler/Pipeline/Package.hs b/src/Juvix/Compiler/Pipeline/Package.hs index 232d18507..e34304893 100644 --- a/src/Juvix/Compiler/Pipeline/Package.hs +++ b/src/Juvix/Compiler/Pipeline/Package.hs @@ -92,6 +92,8 @@ readYamlPackage :: BuildDir -> Sem r Package readYamlPackage root buildDir = mapError (JuvixError @PackageLoaderError) $ do + exi <- fileExists' yamlPath + unless exi (error ("The yaml file " <> show yamlPath <> " does not exist")) bs <- readFileBS' yamlPath mLockfile <- mayReadLockfile root if diff --git a/src/Juvix/Compiler/Pipeline/Package/Base.hs b/src/Juvix/Compiler/Pipeline/Package/Base.hs index a19349d17..4ea8bbea9 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Base.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Base.hs @@ -7,10 +7,11 @@ where import Data.Aeson import Data.Aeson.BetterErrors import Data.Kind qualified as GHC -import Data.Versions +import Data.Versions hiding (Lens') import Juvix.Compiler.Pipeline.Lockfile import Juvix.Compiler.Pipeline.Package.Dependency import Juvix.Extra.Paths +import Juvix.Extra.Strings qualified as Str import Juvix.Prelude data BuildDir @@ -43,6 +44,12 @@ type family PackageLockfileType s = res | res -> s where PackageLockfileType 'Raw = Maybe () PackageLockfileType 'Processed = Maybe LockfileInfo +data PackageId = PackageId + { _packageIdName :: Text, + _packageIdVersion :: SemVer + } + deriving stock (Show, Eq) + data Package' (s :: IsProcessed) = Package { _packageName :: NameType s, _packageVersion :: VersionType s, @@ -55,6 +62,7 @@ data Package' (s :: IsProcessed) = Package deriving stock (Generic) makeLenses ''Package' +makeLenses ''PackageId type Package = Package' 'Processed @@ -68,6 +76,22 @@ deriving stock instance Show RawPackage deriving stock instance Show Package +packageId :: Lens' Package PackageId +packageId (g :: PackageId -> f PackageId) pkg = + let pkgId = + PackageId + { _packageIdName = pkg ^. packageName, + _packageIdVersion = pkg ^. packageVersion + } + in toPackage <$> g pkgId + where + toPackage :: PackageId -> Package + toPackage pkgid = + pkg + { _packageName = pkgid ^. packageIdName, + _packageVersion = pkgid ^. packageIdVersion + } + rawPackageOptions :: Options rawPackageOptions = defaultOptions @@ -159,6 +183,13 @@ globalPackage p = _packageLockfile = Nothing } +packageBaseId :: PackageId +packageBaseId = + PackageId + { _packageIdName = Str.packageBase, + _packageIdVersion = defaultVersion + } + mkPackageFilePath :: Path Abs Dir -> Path Abs File mkPackageFilePath = ( juvixYamlFile) diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs b/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs index 3593681f9..ad936a49f 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs @@ -130,7 +130,6 @@ loadPackage' packagePath = do . runProcessIO . runFilesIO . evalTopNameIdGen defaultModuleId - . runReader packageEntryPoint . ignoreLog . mapError (JuvixError @GitProcessError) . runGitProcess @@ -153,23 +152,24 @@ loadPackage' packagePath = do packageEntryPoint :: EntryPoint packageEntryPoint = defaultEntryPoint rootPkg root (Just packagePath) where + sroot :: SomeRoot + sroot = + SomeRoot + { _someRootDir = rootPath, + _someRootType = GlobalPackageDescription + } + root :: Root root = Root - { _rootRootDir = rootPath, - _rootPackageType = GlobalPackageDescription, + { _rootSomeRoot = sroot, _rootInvokeDir = rootPath, _rootBuildDir = DefaultBuildDir } - rootPkg :: Package + rootPkg :: PackageId rootPkg = - Package - { _packageVersion = defaultVersion, - _packageName = "Package", - _packageMain = Nothing, - _packageLockfile = Nothing, - _packageFile = packagePath, - _packageDependencies = [], - _packageBuildDir = Nothing + PackageId + { _packageIdVersion = defaultVersion, + _packageIdName = "Package" } diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs b/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs index d10ff648b..9b71c9ba9 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs @@ -30,7 +30,7 @@ makeLenses ''RootInfoFiles -- package and global standard library (currently under global-package/.juvix-build) runPackagePathResolver :: forall r a. - (Members '[TaggedLock, Error JuvixError, Files, EvalFileEff, Reader EntryPoint] r) => + (Members '[TaggedLock, Error JuvixError, Files, EvalFileEff] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r a diff --git a/src/Juvix/Compiler/Pipeline/Repl.hs b/src/Juvix/Compiler/Pipeline/Repl.hs index b084be9ae..e96814649 100644 --- a/src/Juvix/Compiler/Pipeline/Repl.hs +++ b/src/Juvix/Compiler/Pipeline/Repl.hs @@ -37,7 +37,7 @@ upToInternalExpression :: upToInternalExpression p = do scopeTable <- gets (^. artifactScopeTable) mtab <- gets (^. artifactModuleTable) - pkg <- asks (^. entryPointPackage) + pkg <- asks (^. entryPointPackageId) runScoperScopeArtifacts . runStateArtifacts artifactScoperState . runReader pkg @@ -63,7 +63,7 @@ expressionUpToAtomsScoped :: expressionUpToAtomsScoped fp txt = do scopeTable <- gets (^. artifactScopeTable) mtab <- gets (^. artifactModuleTable) - pkg <- asks (^. entryPointPackage) + pkg <- asks (^. entryPointPackageId) runScoperScopeArtifacts . runStateArtifacts artifactScoperState . runNameIdGenArtifacts @@ -78,7 +78,7 @@ scopeCheckExpression :: scopeCheckExpression p = do scopeTable <- gets (^. artifactScopeTable) mtab <- gets (^. artifactModuleTable) - pkg <- asks (^. entryPointPackage) + pkg <- asks (^. entryPointPackageId) runNameIdGenArtifacts . runScoperScopeArtifacts . runStateArtifacts artifactScoperState @@ -129,7 +129,7 @@ registerImport i = do modify' (appendArtifactsModuleTable mtab') scopeTable <- gets (^. artifactScopeTable) mtab'' <- gets (^. artifactModuleTable) - pkg <- asks (^. entryPointPackage) + pkg <- asks (^. entryPointPackageId) void . runNameIdGenArtifacts . runScoperScopeArtifacts @@ -164,7 +164,7 @@ compileReplInputIO fp txt = do runError . runConcurrent . runReader defaultPipelineOptions - . runLoggerIO defaultLoggerOptions + . runLoggerIO replLoggerOptions . runReader defaultNumThreads . evalInternet hasInternet . ignoreHighlightBuilder diff --git a/src/Juvix/Compiler/Pipeline/Root.hs b/src/Juvix/Compiler/Pipeline/Root.hs index 2a9ce8f40..5ca871b01 100644 --- a/src/Juvix/Compiler/Pipeline/Root.hs +++ b/src/Juvix/Compiler/Pipeline/Root.hs @@ -50,22 +50,35 @@ findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do Nothing -> do let cwd = fromMaybe _rootInvokeDir minputFileDir packageBaseRootDir <- runFilesIO globalPackageBaseRoot - (_rootRootDir, _rootPackageType) <- + _rootSomeRoot <- if | isPathPrefix packageBaseRootDir cwd -> - return (packageBaseRootDir, GlobalPackageBase) + return + SomeRoot + { _someRootDir = packageBaseRootDir, + _someRootType = GlobalPackageBase + } | otherwise -> do r <- runFilesIO globalRoot - return (r, GlobalStdlib) + return + SomeRoot + { _someRootDir = r, + _someRootType = GlobalStdlib + } let _rootBuildDir = getBuildDir mbuildDir return Root {..} Just pkgPath -> do packageDescriptionRootDir <- runFilesIO globalPackageDescriptionRoot - let _rootRootDir = parent pkgPath - _rootPackageType - | isPathPrefix packageDescriptionRootDir _rootRootDir = GlobalPackageDescription - | otherwise = LocalPackage - _rootBuildDir = getBuildDir mbuildDir + let _rootBuildDir = getBuildDir mbuildDir + rootdir = parent pkgPath + _rootSomeRoot = + SomeRoot + { _someRootDir = rootdir, + _someRootType = + if + | isPathPrefix packageDescriptionRootDir rootdir -> GlobalPackageDescription + | otherwise -> LocalPackage + } return Root {..} getBuildDir :: Maybe (Path Abs Dir) -> BuildDir diff --git a/src/Juvix/Compiler/Pipeline/Root/Base.hs b/src/Juvix/Compiler/Pipeline/Root/Base.hs index 8946107dd..5427a382c 100644 --- a/src/Juvix/Compiler/Pipeline/Root/Base.hs +++ b/src/Juvix/Compiler/Pipeline/Root/Base.hs @@ -11,10 +11,23 @@ data PackageType deriving stock (Eq, Show) data Root = Root - { _rootRootDir :: Path Abs Dir, - _rootPackageType :: PackageType, + { _rootSomeRoot :: SomeRoot, _rootBuildDir :: BuildDir, _rootInvokeDir :: Path Abs Dir } +-- | TODO think of a better name +data SomeRoot = SomeRoot + { _someRootDir :: Path Abs Dir, + _someRootType :: PackageType + } + deriving stock (Eq, Show) + makeLenses ''Root +makeLenses ''SomeRoot + +rootRootDir :: Lens' Root (Path Abs Dir) +rootRootDir = rootSomeRoot . someRootDir + +rootPackageType :: Lens' Root PackageType +rootPackageType = rootSomeRoot . someRootType diff --git a/src/Juvix/Extra/Strings.hs b/src/Juvix/Extra/Strings.hs index 52e156431..96602606f 100644 --- a/src/Juvix/Extra/Strings.hs +++ b/src/Juvix/Extra/Strings.hs @@ -1184,5 +1184,8 @@ rustMemory = "Memory" rustContinue :: (IsString s) => s rustContinue = "continue" +packageBase :: (IsString s) => s +packageBase = "package-base" + rustReturn :: (IsString s) => s rustReturn = "return" diff --git a/src/Juvix/Formatter.hs b/src/Juvix/Formatter.hs index 249b538ab..e96c5b16e 100644 --- a/src/Juvix/Formatter.hs +++ b/src/Juvix/Formatter.hs @@ -109,7 +109,7 @@ formatModuleInfo :: '[ PathResolver, Error JuvixError, Files, - Reader Package + Reader PackageId ] r ) => @@ -120,7 +120,7 @@ formatModuleInfo node moduleInfo = withResolverRoot (node ^. importNodePackageRoot) . ignoreHighlightBuilder $ do - pkg :: Package <- ask + pkg :: PackageId <- ask parseRes :: ParserResult <- runTopModuleNameChecker $ fromSource Nothing (Just (node ^. importNodeAbsFile)) diff --git a/test/Base.hs b/test/Base.hs index 68eaded81..86c315a1f 100644 --- a/test/Base.hs +++ b/test/Base.hs @@ -108,10 +108,10 @@ testRunIO e = testDefaultEntryPointIO :: (MonadIO m) => Path Abs Dir -> Path Abs File -> m EntryPoint testDefaultEntryPointIO cwd mainFile = testTaggedLockedToIO $ - defaultEntryPointIO cwd mainFile + defaultEntryPointIO cwd (Just mainFile) testDefaultEntryPointNoFileIO :: Path Abs Dir -> IO EntryPoint -testDefaultEntryPointNoFileIO cwd = testTaggedLockedToIO (defaultEntryPointNoFileIO cwd) +testDefaultEntryPointNoFileIO cwd = testTaggedLockedToIO (defaultEntryPointIO cwd Nothing) testRunIOEither :: EntryPoint -> diff --git a/test/Repl/Positive.hs b/test/Repl/Positive.hs index e703c6b66..c4904fa79 100644 --- a/test/Repl/Positive.hs +++ b/test/Repl/Positive.hs @@ -22,15 +22,20 @@ loadPrelude :: Path Abs Dir -> IO (Artifacts, EntryPoint) loadPrelude rootDir = runTaggedLockIO' $ do runReader rootDir writeStdlib pkg <- readPackageRootIO root - let ep = defaultEntryPoint pkg root (Just (rootDir preludePath)) + let ep = defaultEntryPoint (pkg ^. packageId) root (Just (rootDir preludePath)) artif <- runReplPipelineIO ep return (artif, ep) where + sroot :: SomeRoot + sroot = + SomeRoot + { _someRootDir = rootDir, + _someRootType = LocalPackage + } root :: Root root = Root - { _rootRootDir = rootDir, - _rootPackageType = LocalPackage, + { _rootSomeRoot = sroot, _rootInvokeDir = rootDir, _rootBuildDir = DefaultBuildDir }