diff --git a/app/Commands/Dev/Termination/CallGraph.hs b/app/Commands/Dev/Termination/CallGraph.hs index f6f92e045a..899b872d48 100644 --- a/app/Commands/Dev/Termination/CallGraph.hs +++ b/app/Commands/Dev/Termination/CallGraph.hs @@ -6,7 +6,7 @@ import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Internal.Pretty qualified as Internal import Juvix.Compiler.Internal.Translation.FromConcrete.Data.Context qualified as Internal import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination qualified as Termination -import Juvix.Compiler.Store.Language qualified as Stored +import Juvix.Compiler.Store.Extra qualified as Stored import Juvix.Prelude.Pretty runCommand :: (Members '[Embed IO, TaggedLock, App] r) => CallGraphOptions -> Sem r () diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs index 363d186d04..e59bd10fc1 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs @@ -10,6 +10,7 @@ import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as Parsed import Juvix.Compiler.Pipeline.EntryPoint +import Juvix.Compiler.Store.Extra import Juvix.Compiler.Store.Language import Juvix.Prelude diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs index 49e6a8c5c9..96c4e1c8b8 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs @@ -77,15 +77,16 @@ scopeCheck' importTab pr m = do ScopeParameters { _scopeImportedModules = importTab ^. scopedModuleTable } - mkResult :: (ScoperState, (Module 'Scoped 'ModuleTop, ScopedModule)) -> ScoperResult - mkResult (scoperSt, (md, sm)) = + mkResult :: (ScoperState, (Module 'Scoped 'ModuleTop, ScopedModule, Scope)) -> ScoperResult + mkResult (scoperSt, (md, sm, sc)) = let exp = createExportsTable (sm ^. scopedModuleExportInfo) in ScoperResult { _resultParserResult = pr, _resultModule = md, _resultScopedModule = sm, _resultExports = exp, - _resultScoperState = scoperSt + _resultScoperState = scoperSt, + _resultScope = sc } -- TODO refactor to have less code duplication @@ -1033,7 +1034,7 @@ checkTopModule :: forall r. (Members '[Error ScoperError, Reader ScopeParameters, State ScoperState, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => Module 'Parsed 'ModuleTop -> - Sem r (Module 'Scoped 'ModuleTop, ScopedModule) + Sem r (Module 'Scoped 'ModuleTop, ScopedModule, Scope) checkTopModule m@Module {..} = checkedModule where freshTopModulePath :: @@ -1061,9 +1062,9 @@ checkTopModule m@Module {..} = checkedModule iniScope :: Scope iniScope = emptyScope (getTopModulePath m) - checkedModule :: Sem r (Module 'Scoped 'ModuleTop, ScopedModule) + checkedModule :: Sem r (Module 'Scoped 'ModuleTop, ScopedModule, Scope) checkedModule = do - (tab, (e, body', path', doc')) <- evalState iniScope $ runInfoTableBuilder mempty $ do + (sc, (tab, (e, body', path', doc'))) <- runState iniScope $ runInfoTableBuilder mempty $ do path' <- freshTopModulePath withTopScope $ do (e, body') <- topBindings (checkModuleBody _moduleBody) @@ -1093,7 +1094,7 @@ checkTopModule m@Module {..} = checkedModule _scopedModuleLocalModules = localModules, _scopedModuleInfoTable = tab } - return (md, smd) + return (md, smd, sc) withTopScope :: (Members '[State Scope] r) => Sem r a -> Sem r a withTopScope ma = do diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Data/Context.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Data/Context.hs index 9f0c35be41..cc0df0e123 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Data/Context.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Data/Context.hs @@ -12,7 +12,8 @@ data ScoperResult = ScoperResult _resultModule :: Module 'Scoped 'ModuleTop, _resultScopedModule :: ScopedModule, _resultExports :: HashSet NameId, - _resultScoperState :: ScoperState + _resultScoperState :: ScoperState, + _resultScope :: Scope } makeLenses ''ScoperResult diff --git a/src/Juvix/Compiler/Core/Translation/FromInternal.hs b/src/Juvix/Compiler/Core/Translation/FromInternal.hs index cb5fbbf382..85054051f0 100644 --- a/src/Juvix/Compiler/Core/Translation/FromInternal.hs +++ b/src/Juvix/Compiler/Core/Translation/FromInternal.hs @@ -19,7 +19,7 @@ import Juvix.Compiler.Internal.Pretty (ppTrace) import Juvix.Compiler.Internal.Pretty qualified as Internal import Juvix.Compiler.Internal.Translation.Extra qualified as Internal import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking qualified as InternalTyped -import Juvix.Compiler.Store.Extra (computeCombinedCoreInfoTable) +import Juvix.Compiler.Store.Extra qualified as Store import Juvix.Compiler.Store.Language qualified as Store import Juvix.Data.Loc qualified as Loc import Juvix.Data.PPOutput @@ -50,7 +50,7 @@ mkIdentIndex = show . (^. Internal.nameId) fromInternal :: (Members '[NameIdGen, Reader Store.ModuleTable] k) => Internal.InternalTypedResult -> Sem k CoreResult fromInternal i = do importTab <- asks Store.getInternalModuleTable - coreImportsTab <- asks computeCombinedCoreInfoTable + coreImportsTab <- asks Store.computeCombinedCoreInfoTable let md = Module { _moduleId = i ^. InternalTyped.resultInternalModule . Internal.internalModuleId, diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal.hs index 1de4265355..33cbe8244b 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromInternal.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromInternal.hs @@ -15,6 +15,7 @@ import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Che import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking import Juvix.Compiler.Pipeline.Artifacts import Juvix.Compiler.Pipeline.EntryPoint +import Juvix.Compiler.Store.Extra import Juvix.Compiler.Store.Language import Juvix.Data.Effect.NameIdGen import Juvix.Prelude hiding (fromEither) diff --git a/src/Juvix/Compiler/Pipeline/Artifacts.hs b/src/Juvix/Compiler/Pipeline/Artifacts.hs index 471a3d90ad..4de9d7629c 100644 --- a/src/Juvix/Compiler/Pipeline/Artifacts.hs +++ b/src/Juvix/Compiler/Pipeline/Artifacts.hs @@ -13,13 +13,24 @@ import Juvix.Compiler.Builtins import Juvix.Compiler.Concrete.Data.InfoTableBuilder qualified as Scoped import Juvix.Compiler.Concrete.Data.Scope qualified as S import Juvix.Compiler.Core.Data.InfoTableBuilder qualified as Core +import Juvix.Compiler.Core.Data.Module qualified as Core import Juvix.Compiler.Internal.Language qualified as Internal import Juvix.Compiler.Internal.Translation.FromConcrete qualified as Internal import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context import Juvix.Compiler.Pipeline.Artifacts.Base +import Juvix.Compiler.Store.Extra +import Juvix.Compiler.Store.Language import Juvix.Prelude +appendArtifactsModuleTable :: ModuleTable -> Artifacts -> Artifacts +appendArtifactsModuleTable mtab = + over artifactInternalTypedTable (computeCombinedInfoTable importTab <>) + . over (artifactCoreModule . Core.moduleImportsTable) (computeCombinedCoreInfoTable mtab <>) + where + importTab :: Internal.InternalModuleTable + importTab = getInternalModuleTable mtab + -- | It only reads the Artifacts. It does not modify the table in it. extendedTableReplArtifacts :: forall r. (Members '[State Artifacts] r) => Internal.Expression -> Sem r Internal.InfoTable extendedTableReplArtifacts e = Internal.extendWithReplExpression e <$> gets (^. artifactInternalTypedTable) diff --git a/src/Juvix/Compiler/Pipeline/Driver.hs b/src/Juvix/Compiler/Pipeline/Driver.hs index 871c6077be..80f54dcfb5 100644 --- a/src/Juvix/Compiler/Pipeline/Driver.hs +++ b/src/Juvix/Compiler/Pipeline/Driver.hs @@ -21,6 +21,7 @@ import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Da import Juvix.Compiler.Pipeline import Juvix.Compiler.Pipeline.Loader.PathResolver import Juvix.Compiler.Store.Core.Extra +import Juvix.Compiler.Store.Extra qualified as Store import Juvix.Compiler.Store.Language qualified as Store import Juvix.Compiler.Store.Options qualified as StoredModule import Juvix.Compiler.Store.Options qualified as StoredOptions diff --git a/src/Juvix/Compiler/Pipeline/Repl.hs b/src/Juvix/Compiler/Pipeline/Repl.hs index d472e07f9c..665d652869 100644 --- a/src/Juvix/Compiler/Pipeline/Repl.hs +++ b/src/Juvix/Compiler/Pipeline/Repl.hs @@ -16,7 +16,7 @@ import Juvix.Compiler.Pipeline.Loader.PathResolver.Error import Juvix.Compiler.Pipeline.Package.Loader.Error import Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO import Juvix.Compiler.Pipeline.Result -import Juvix.Compiler.Store.Language qualified as Store +import Juvix.Compiler.Store.Extra qualified as Store import Juvix.Data.Effect.Git import Juvix.Data.Effect.Process (runProcessIO) import Juvix.Data.Effect.TaggedLock @@ -113,8 +113,8 @@ registerImport :: registerImport i = do e <- ask PipelineResult mi mtab <- Driver.processImport e i - modify' (over artifactModuleTable (Store.insertModule (i ^. importModulePath) mi)) - modify' (over artifactModuleTable (mtab <>)) + let mtab' = Store.insertModule (i ^. importModulePath) mi mtab + modify' (appendArtifactsModuleTable mtab') fromInternalExpression :: (Members '[State Artifacts] r) => Internal.Expression -> Sem r Core.Node fromInternalExpression exp = do diff --git a/src/Juvix/Compiler/Pipeline/Run.hs b/src/Juvix/Compiler/Pipeline/Run.hs index bd167b10e6..577ab28aa6 100644 --- a/src/Juvix/Compiler/Pipeline/Run.hs +++ b/src/Juvix/Compiler/Pipeline/Run.hs @@ -181,22 +181,23 @@ runReplPipelineIOEither' lockMode entry = do resultScoperTable :: InfoTable resultScoperTable = Scoped.getCombinedInfoTable (scopedResult ^. Scoped.resultScopedModule) in Right $ - Artifacts - { _artifactMainModuleScope = Nothing, - _artifactParsing = parserResult ^. P.resultParserState, - _artifactInternalTypedTable = typedTable, - _artifactTerminationState = typedResult ^. Typed.resultTermination, - _artifactCoreModule = coreModule, - _artifactScopeTable = resultScoperTable, - _artifactScopeExports = scopedResult ^. Scoped.resultExports, - _artifactTypes = typesTable, - _artifactFunctions = functionsTable, - _artifactScoperState = scopedResult ^. Scoped.resultScoperState, - _artifactResolver = art ^. artifactResolver, - _artifactBuiltins = art ^. artifactBuiltins, - _artifactNameIdState = art ^. artifactNameIdState, - _artifactModuleTable = _pipelineResultImports - } + appendArtifactsModuleTable _pipelineResultImports $ + Artifacts + { _artifactMainModuleScope = Just $ scopedResult ^. Scoped.resultScope, + _artifactParsing = parserResult ^. P.resultParserState, + _artifactInternalTypedTable = typedTable, + _artifactTerminationState = typedResult ^. Typed.resultTermination, + _artifactCoreModule = coreModule, + _artifactScopeTable = resultScoperTable, + _artifactScopeExports = scopedResult ^. Scoped.resultExports, + _artifactTypes = typesTable, + _artifactFunctions = functionsTable, + _artifactScoperState = scopedResult ^. Scoped.resultScoperState, + _artifactResolver = art ^. artifactResolver, + _artifactBuiltins = art ^. artifactBuiltins, + _artifactNameIdState = art ^. artifactNameIdState, + _artifactModuleTable = mempty + } where initialArtifacts :: Artifacts initialArtifacts = @@ -204,10 +205,10 @@ runReplPipelineIOEither' lockMode entry = do { _artifactParsing = mempty, _artifactMainModuleScope = Nothing, _artifactInternalTypedTable = mempty, - _artifactTypes = mempty, _artifactTerminationState = iniTerminationState, _artifactResolver = iniResolverState, _artifactNameIdState = genNameIdState defaultModuleId, + _artifactTypes = mempty, _artifactFunctions = mempty, _artifactCoreModule = Core.emptyModule, _artifactScopeTable = mempty, diff --git a/src/Juvix/Compiler/Store/Extra.hs b/src/Juvix/Compiler/Store/Extra.hs index c4d0d1559a..c2e008c8e8 100644 --- a/src/Juvix/Compiler/Store/Extra.hs +++ b/src/Juvix/Compiler/Store/Extra.hs @@ -1,11 +1,39 @@ module Juvix.Compiler.Store.Extra where import Data.HashMap.Strict qualified as HashMap +import Juvix.Compiler.Concrete.Data.ScopedName qualified as S +import Juvix.Compiler.Concrete.Language (TopModulePath) import Juvix.Compiler.Core.Data.InfoTable qualified as Core import Juvix.Compiler.Store.Core.Extra +import Juvix.Compiler.Store.Internal.Language import Juvix.Compiler.Store.Language +import Juvix.Compiler.Store.Scoped.Language import Juvix.Prelude +getModulePath :: ModuleInfo -> TopModulePath +getModulePath mi = mi ^. moduleInfoScopedModule . scopedModulePath . S.nameConcrete + +getModuleId :: ModuleInfo -> ModuleId +getModuleId mi = mi ^. moduleInfoScopedModule . scopedModuleId + +getScopedModuleTable :: ModuleTable -> ScopedModuleTable +getScopedModuleTable mtab = + ScopedModuleTable $ fmap (^. moduleInfoScopedModule) (mtab ^. moduleTable) + +getInternalModuleTable :: ModuleTable -> InternalModuleTable +getInternalModuleTable mtab = + InternalModuleTable $ + HashMap.fromList (map (\mi -> (mi ^. moduleInfoInternalModule . internalModuleName, mi ^. moduleInfoInternalModule)) (HashMap.elems (mtab ^. moduleTable))) + +mkModuleTable :: [ModuleInfo] -> ModuleTable +mkModuleTable = ModuleTable . HashMap.fromList . map (\mi -> (getModulePath mi, mi)) + +lookupModule :: ModuleTable -> TopModulePath -> ModuleInfo +lookupModule mtab n = fromJust $ HashMap.lookup n (mtab ^. moduleTable) + +insertModule :: TopModulePath -> ModuleInfo -> ModuleTable -> ModuleTable +insertModule p mi = over moduleTable (HashMap.insert p mi) + computeCombinedCoreInfoTable :: ModuleTable -> Core.InfoTable computeCombinedCoreInfoTable mtab = mconcatMap (toCore . (^. moduleInfoCoreTable)) (HashMap.elems (mtab ^. moduleTable)) diff --git a/src/Juvix/Compiler/Store/Language.hs b/src/Juvix/Compiler/Store/Language.hs index bd979f7ff0..669fa7296a 100644 --- a/src/Juvix/Compiler/Store/Language.hs +++ b/src/Juvix/Compiler/Store/Language.hs @@ -1,7 +1,5 @@ module Juvix.Compiler.Store.Language where -import Data.HashMap.Strict qualified as HashMap -import Juvix.Compiler.Concrete.Data.ScopedName qualified as S import Juvix.Compiler.Concrete.Language (TopModulePath) import Juvix.Compiler.Store.Core.Data.InfoTable qualified as Core import Juvix.Compiler.Store.Internal.Language @@ -29,27 +27,3 @@ newtype ModuleTable = ModuleTable makeLenses ''ModuleInfo makeLenses ''ModuleTable - -getModulePath :: ModuleInfo -> TopModulePath -getModulePath mi = mi ^. moduleInfoScopedModule . scopedModulePath . S.nameConcrete - -getModuleId :: ModuleInfo -> ModuleId -getModuleId mi = mi ^. moduleInfoScopedModule . scopedModuleId - -getScopedModuleTable :: ModuleTable -> ScopedModuleTable -getScopedModuleTable mtab = - ScopedModuleTable $ fmap (^. moduleInfoScopedModule) (mtab ^. moduleTable) - -getInternalModuleTable :: ModuleTable -> InternalModuleTable -getInternalModuleTable mtab = - InternalModuleTable $ - HashMap.fromList (map (\mi -> (mi ^. moduleInfoInternalModule . internalModuleName, mi ^. moduleInfoInternalModule)) (HashMap.elems (mtab ^. moduleTable))) - -mkModuleTable :: [ModuleInfo] -> ModuleTable -mkModuleTable = ModuleTable . HashMap.fromList . map (\mi -> (getModulePath mi, mi)) - -lookupModule :: ModuleTable -> TopModulePath -> ModuleInfo -lookupModule mtab n = fromJust $ HashMap.lookup n (mtab ^. moduleTable) - -insertModule :: TopModulePath -> ModuleInfo -> ModuleTable -> ModuleTable -insertModule p mi = over moduleTable (HashMap.insert p mi)