From 6aed2927090bcf0057923c556154c7c2c013d612 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Tue, 24 Sep 2024 20:12:06 +0200 Subject: [PATCH] group typechecking tables --- .../Compiler/Core/Translation/FromInternal.hs | 15 ++-- src/Juvix/Compiler/Internal/Data/InfoTable.hs | 9 +-- .../Compiler/Internal/Translation/Extra.hs | 1 - .../Internal/Translation/FromInternal.hs | 21 +---- .../Analysis/TypeChecking/Data/Context.hs | 20 ++--- .../Analysis/TypeChecking/Data/Inference.hs | 11 ++- .../TypeChecking/Data/ResultBuilder.hs | 79 +++++++++---------- src/Juvix/Compiler/Pipeline/Artifacts.hs | 22 ++---- src/Juvix/Compiler/Pipeline/Artifacts/Base.hs | 9 +-- src/Juvix/Compiler/Pipeline/Run.hs | 23 +----- .../Store/Internal/Data/TypeCheckingTables.hs | 50 ++++++++++++ src/Juvix/Compiler/Store/Internal/Language.hs | 36 ++++++--- .../Compiler/Store/Scoped/Data/InfoTable.hs | 34 ++++---- src/Juvix/Prelude/Base/Foundation.hs | 6 ++ 14 files changed, 172 insertions(+), 164 deletions(-) create mode 100644 src/Juvix/Compiler/Store/Internal/Data/TypeCheckingTables.hs diff --git a/src/Juvix/Compiler/Core/Translation/FromInternal.hs b/src/Juvix/Compiler/Core/Translation/FromInternal.hs index d5ea219095..233010d4f6 100644 --- a/src/Juvix/Compiler/Core/Translation/FromInternal.hs +++ b/src/Juvix/Compiler/Core/Translation/FromInternal.hs @@ -55,7 +55,10 @@ computeImplicitArgs = \case False : computeImplicitArgs _functionRight _ -> [] -fromInternal :: (Members '[NameIdGen, Reader Store.ModuleTable, Error JuvixError] k) => Internal.InternalTypedResult -> Sem k CoreResult +fromInternal :: + (Members '[NameIdGen, Reader Store.ModuleTable, Error JuvixError] k) => + InternalTyped.InternalTypedResult -> + Sem k CoreResult fromInternal i = mapError (JuvixError . ErrBadScope) $ do importTab <- asks Store.getInternalModuleTable coreImportsTab <- asks Store.computeCombinedCoreInfoTable @@ -65,10 +68,11 @@ fromInternal i = mapError (JuvixError . ErrBadScope) $ do _moduleInfoTable = mempty, _moduleImportsTable = coreImportsTab } + tabs = i ^. InternalTyped.resultTypeCheckingTables res <- execInfoTableBuilder md - . runReader (i ^. InternalTyped.resultFunctions) - . runReader (i ^. InternalTyped.resultIdenTypes) + . runReader (tabs ^. InternalTyped.typeCheckingTablesFunctionsTable) + . runReader (tabs ^. InternalTyped.typeCheckingTablesTypesTable) $ do when (isNothing (coreImportsTab ^. infoLiteralIntToNat)) @@ -101,11 +105,12 @@ fromInternalExpression importTab res exp = do let mtab = res ^. coreResultInternalTypedResult . InternalTyped.resultInternalModule . Internal.internalModuleInfoTable <> Internal.computeCombinedInfoTable importTab + tabs = res ^. coreResultInternalTypedResult . InternalTyped.resultTypeCheckingTables fmap snd . runReader mtab . runInfoTableBuilder (res ^. coreResultModule) - . runReader (res ^. coreResultInternalTypedResult . InternalTyped.resultFunctions) - . runReader (res ^. coreResultInternalTypedResult . InternalTyped.resultIdenTypes) + . runReader (tabs ^. InternalTyped.typeCheckingTablesFunctionsTable) + . runReader (tabs ^. InternalTyped.typeCheckingTablesTypesTable) $ fromTopIndex (goExpression exp) goModule :: diff --git a/src/Juvix/Compiler/Internal/Data/InfoTable.hs b/src/Juvix/Compiler/Internal/Data/InfoTable.hs index 68a88e20a3..fe591a0227 100644 --- a/src/Juvix/Compiler/Internal/Data/InfoTable.hs +++ b/src/Juvix/Compiler/Internal/Data/InfoTable.hs @@ -80,17 +80,14 @@ letFunctionDefs e = LetFunDef f -> pure f LetMutualBlock (MutualBlockLet fs) -> fs -computeInternalModule :: InstanceTable -> CoercionTable -> TypesTable -> FunctionsTable -> Module -> InternalModule -computeInternalModule instTab coeTab tysTab funsTab m@Module {..} = +computeInternalModule :: TypeCheckingTables -> Module -> InternalModule +computeInternalModule tabs m@Module {..} = InternalModule { _internalModuleId = _moduleId, _internalModuleName = _moduleName, _internalModuleImports = _moduleBody ^. moduleImports, _internalModuleInfoTable = computeInternalModuleInfoTable m, - _internalModuleTypesTable = tysTab, - _internalModuleFunctionsTable = funsTab, - _internalModuleInstanceTable = instTab, - _internalModuleCoercionTable = coeTab + _internalModuleTypeCheckingTables = tabs } computeInternalModuleInfoTable :: Module -> InfoTable diff --git a/src/Juvix/Compiler/Internal/Translation/Extra.hs b/src/Juvix/Compiler/Internal/Translation/Extra.hs index 982756db85..19caf8b5f6 100644 --- a/src/Juvix/Compiler/Internal/Translation/Extra.hs +++ b/src/Juvix/Compiler/Internal/Translation/Extra.hs @@ -7,7 +7,6 @@ where import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Internal.Extra import Juvix.Compiler.Internal.Translation -import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context import Juvix.Prelude unfoldPolyApplication :: (Member (Reader TypesTable) r) => Application -> Sem r (Expression, [Expression]) diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal.hs index f1e8d9d1b1..b522cfd2c7 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromInternal.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromInternal.hs @@ -34,34 +34,19 @@ typeCheckingNew a = do stable = Scoped.computeCombinedInfoTable stab <> res ^. Internal.resultScoper . resultScopedModule . scopedModuleInfoTable - importCtx = - ImportContext - { _importContextTypesTable = computeTypesTable itab, - _importContextFunctionsTable = computeFunctionsTable itab, - _importContextInstances = computeInstanceTable itab, - _importContextCoercions = computeCoercionTable itab - } + importCtx = ImportContext (computeTypeCheckingTables itab) fmap (res,) . runReader table . runReader (stable ^. Scoped.infoBuiltins) . runResultBuilder importCtx . mapError (JuvixError @TypeCheckerError) $ checkTopModule (res ^. Internal.resultModule) - let md = - computeInternalModule - (bst ^. resultBuilderStateInstanceTable) - (bst ^. resultBuilderStateCoercionTable) - (bst ^. resultBuilderStateTypesTable) - (bst ^. resultBuilderStateFunctionsTable) - checkedModule + let md = computeInternalModule (bst ^. resultBuilderStateTables) checkedModule return InternalTypedResult { _resultInternal = res, _resultModule = checkedModule, _resultInternalModule = md, _resultTermination = termin, - _resultIdenTypes = bst ^. resultBuilderStateCombinedTypesTable, - _resultFunctions = bst ^. resultBuilderStateCombinedFunctionsTable, - _resultInstances = bst ^. resultBuilderStateCombinedInstanceTable, - _resultCoercions = bst ^. resultBuilderStateCombinedCoercionTable + _resultTypeCheckingTables = bst ^. resultBuilderStateCombinedTables } diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Context.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Context.hs index 51a491592e..1dcef1d8be 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Context.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Context.hs @@ -1,7 +1,6 @@ module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context ( module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context, - module Juvix.Compiler.Store.Internal.Data.FunctionsTable, - module Juvix.Compiler.Store.Internal.Data.TypesTable, + module Juvix.Compiler.Store.Internal.Data.TypeCheckingTables, module Juvix.Compiler.Internal.Data.InfoTable, ) where @@ -10,10 +9,7 @@ import Juvix.Compiler.Internal.Data.InfoTable import Juvix.Compiler.Internal.Language import Juvix.Compiler.Internal.Translation.FromConcrete.Data.Context qualified as Internal import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker (TerminationState) -import Juvix.Compiler.Store.Internal.Data.CoercionInfo -import Juvix.Compiler.Store.Internal.Data.FunctionsTable -import Juvix.Compiler.Store.Internal.Data.InstanceInfo -import Juvix.Compiler.Store.Internal.Data.TypesTable +import Juvix.Compiler.Store.Internal.Data.TypeCheckingTables import Juvix.Prelude data InternalTypedResult = InternalTypedResult @@ -21,17 +17,11 @@ data InternalTypedResult = InternalTypedResult _resultModule :: Module, _resultInternalModule :: InternalModule, _resultTermination :: TerminationState, - _resultIdenTypes :: TypesTable, - _resultFunctions :: FunctionsTable, - _resultInstances :: InstanceTable, - _resultCoercions :: CoercionTable + _resultTypeCheckingTables :: TypeCheckingTables } -data ImportContext = ImportContext - { _importContextTypesTable :: TypesTable, - _importContextFunctionsTable :: FunctionsTable, - _importContextInstances :: InstanceTable, - _importContextCoercions :: CoercionTable +newtype ImportContext = ImportContext + { _importContextTables :: TypeCheckingTables } makeLenses ''InternalTypedResult diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Inference.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Inference.hs index 070063751b..b9b61a98ed 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Inference.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Inference.hs @@ -617,10 +617,13 @@ strongNormalize'' ty = do ftab <- ask let importCtx = ImportContext - { _importContextCoercions = mempty, - _importContextInstances = mempty, - _importContextTypesTable = mempty, - _importContextFunctionsTable = ftab + { _importContextTables = + TypeCheckingTables + { _typeCheckingTablesCoercionTable = mempty, + _typeCheckingTablesInstanceTable = mempty, + _typeCheckingTablesTypesTable = mempty, + _typeCheckingTablesFunctionsTable = ftab + } } fmap snd . runResultBuilder importCtx diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/ResultBuilder.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/ResultBuilder.hs index 42b50a6bbb..ea35c7a3a6 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/ResultBuilder.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/ResultBuilder.hs @@ -15,22 +15,17 @@ data ResultBuilder :: Effect where AddCoercionInfo :: CoercionInfo -> ResultBuilder m () LookupFunctionDef :: FunctionName -> ResultBuilder m (Maybe Expression) LookupIdenType :: NameId -> ResultBuilder m (Maybe Expression) - LookupInstanceInfo :: Name -> ResultBuilder m (Maybe [InstanceInfo]) - LookupCoercionInfo :: Name -> ResultBuilder m (Maybe [CoercionInfo]) GetCombinedInstanceTable :: ResultBuilder m InstanceTable GetCombinedCoercionTable :: ResultBuilder m CoercionTable makeSem ''ResultBuilder +typeCheckingTablesFromImportContext :: ImportContext -> TypeCheckingTables +typeCheckingTablesFromImportContext = (^. importContextTables) + data ResultBuilderState = ResultBuilderState - { _resultBuilderStateTypesTable :: TypesTable, - _resultBuilderStateFunctionsTable :: FunctionsTable, - _resultBuilderStateInstanceTable :: InstanceTable, - _resultBuilderStateCoercionTable :: CoercionTable, - _resultBuilderStateCombinedTypesTable :: TypesTable, - _resultBuilderStateCombinedFunctionsTable :: FunctionsTable, - _resultBuilderStateCombinedInstanceTable :: InstanceTable, - _resultBuilderStateCombinedCoercionTable :: CoercionTable + { _resultBuilderStateTables :: TypeCheckingTables, + _resultBuilderStateCombinedTables :: TypeCheckingTables } makeLenses ''ResultBuilderState @@ -38,14 +33,8 @@ makeLenses ''ResultBuilderState initResultBuilderState :: ImportContext -> ResultBuilderState initResultBuilderState ctx = ResultBuilderState - { _resultBuilderStateFunctionsTable = mempty, - _resultBuilderStateTypesTable = mempty, - _resultBuilderStateInstanceTable = mempty, - _resultBuilderStateCoercionTable = mempty, - _resultBuilderStateCombinedFunctionsTable = ctx ^. importContextFunctionsTable, - _resultBuilderStateCombinedTypesTable = ctx ^. importContextTypesTable, - _resultBuilderStateCombinedInstanceTable = ctx ^. importContextInstances, - _resultBuilderStateCombinedCoercionTable = ctx ^. importContextCoercions + { _resultBuilderStateTables = mempty, + _resultBuilderStateCombinedTables = typeCheckingTablesFromImportContext ctx } runResultBuilder' :: @@ -53,35 +42,41 @@ runResultBuilder' :: Sem (ResultBuilder ': r) a -> Sem r (ResultBuilderState, a) runResultBuilder' inis = reinterpret (runState inis) $ \case - AddFunctionDef name def -> do - modify' (over (resultBuilderStateFunctionsTable . functionsTable) (HashMap.insert name def)) - modify' (over (resultBuilderStateCombinedFunctionsTable . functionsTable) (HashMap.insert name def)) - AddIdenType nid ty -> do - modify' (over (resultBuilderStateTypesTable . typesTable) (HashMap.insert nid ty)) - modify' (over (resultBuilderStateCombinedTypesTable . typesTable) (HashMap.insert nid ty)) - AddIdenTypes itab -> do - modify' (over (resultBuilderStateTypesTable . typesTable) (HashMap.union (itab ^. typesTable))) - modify' (over (resultBuilderStateCombinedTypesTable . typesTable) (HashMap.union (itab ^. typesTable))) + AddFunctionDef name def -> + overBothTables (set (typeCheckingTablesFunctionsTable . functionsTable . at name) (Just def)) + AddIdenType nid ty -> + overBothTables (set (typeCheckingTablesTypesTable . typesTable . at nid) (Just ty)) + AddIdenTypes itab -> + overBothTables (over (typeCheckingTablesTypesTable . typesTable) (HashMap.union (itab ^. typesTable))) AddInstanceInfo ii -> do - modify' (over (resultBuilderStateInstanceTable) (flip updateInstanceTable ii)) - modify' (over (resultBuilderStateCombinedInstanceTable) (flip updateInstanceTable ii)) - AddCoercionInfo ii -> do - modify' (over (resultBuilderStateCoercionTable) (flip updateCoercionTable ii)) - modify' (over (resultBuilderStateCombinedCoercionTable) (flip updateCoercionTable ii)) + overBothTables (over typeCheckingTablesInstanceTable (`updateInstanceTable` ii)) + AddCoercionInfo ii -> + overBothTables (over typeCheckingTablesCoercionTable (`updateCoercionTable` ii)) LookupFunctionDef name -> - gets (^. resultBuilderStateCombinedFunctionsTable . functionsTable . at name) + gets (^. resultBuilderStateCombinedTables . typeCheckingTablesFunctionsTable . functionsTable . at name) LookupIdenType nid -> - gets (^. resultBuilderStateCombinedTypesTable . typesTable . at nid) - LookupInstanceInfo name -> do - tab <- gets (^. resultBuilderStateCombinedInstanceTable) - return $ lookupInstanceTable tab name - LookupCoercionInfo name -> do - tab <- gets (^. resultBuilderStateCombinedCoercionTable) - return $ lookupCoercionTable tab name + gets (^. resultBuilderStateCombinedTables . typeCheckingTablesTypesTable . typesTable . at nid) GetCombinedInstanceTable -> - gets (^. resultBuilderStateCombinedInstanceTable) + gets (^. resultBuilderStateCombinedTables . typeCheckingTablesInstanceTable) GetCombinedCoercionTable -> - gets (^. resultBuilderStateCombinedCoercionTable) + gets (^. resultBuilderStateCombinedTables . typeCheckingTablesCoercionTable) + where + overBothTables :: (Members '[State ResultBuilderState] r') => (TypeCheckingTables -> TypeCheckingTables) -> Sem r' () + overBothTables f = modify $ \res -> + res + { _resultBuilderStateTables = f (res ^. resultBuilderStateTables), + _resultBuilderStateCombinedTables = f (res ^. resultBuilderStateCombinedTables) + } + +lookupInstanceInfo :: (Members '[ResultBuilder] r) => Name -> Sem r (Maybe [InstanceInfo]) +lookupInstanceInfo name = do + tab <- getCombinedInstanceTable + return $ lookupInstanceTable tab name + +lookupCoercionInfo :: (Members '[ResultBuilder] r) => Name -> Sem r (Maybe [CoercionInfo]) +lookupCoercionInfo name = do + tab <- getCombinedCoercionTable + return $ lookupCoercionTable tab name runResultBuilder :: ImportContext -> Sem (ResultBuilder ': r) a -> Sem r (ResultBuilderState, a) runResultBuilder ctx a = diff --git a/src/Juvix/Compiler/Pipeline/Artifacts.hs b/src/Juvix/Compiler/Pipeline/Artifacts.hs index 317ca7c6c5..b98fed10fb 100644 --- a/src/Juvix/Compiler/Pipeline/Artifacts.hs +++ b/src/Juvix/Compiler/Pipeline/Artifacts.hs @@ -69,10 +69,10 @@ runNameIdGenArtifacts :: runNameIdGenArtifacts = runStateLikeArtifacts runNameIdGen artifactNameIdState readerFunctionsTableArtifacts :: (Members '[State Artifacts] r) => Sem (Reader FunctionsTable ': r) a -> Sem r a -readerFunctionsTableArtifacts = runReaderArtifacts artifactFunctions +readerFunctionsTableArtifacts = runReaderArtifacts (artifactTypeCheckingTables . typeCheckingTablesFunctionsTable) readerTypesTableArtifacts :: (Members '[State Artifacts] r) => Sem (Reader TypesTable ': r) a -> Sem r a -readerTypesTableArtifacts = runReaderArtifacts artifactTypes +readerTypesTableArtifacts = runReaderArtifacts (artifactTypeCheckingTables . typeCheckingTablesTypesTable) runTerminationArtifacts :: (Members '[Error JuvixError, State Artifacts] r) => Sem (Termination ': r) a -> Sem r a runTerminationArtifacts = runStateLikeArtifacts runTermination artifactTerminationState @@ -99,20 +99,8 @@ runStateLikeArtifacts runner l m = do runResultBuilderArtifacts :: forall r a. (Members '[State Artifacts] r) => Sem (ResultBuilder ': r) a -> Sem r a runResultBuilderArtifacts m = do - ftab <- gets (^. artifactFunctions) - ttab <- gets (^. artifactTypes) - itab <- gets (^. artifactInstances) - ctab <- gets (^. artifactCoercions) - let importCtx = - ImportContext - { _importContextCoercions = ctab, - _importContextInstances = itab, - _importContextFunctionsTable = ftab, - _importContextTypesTable = ttab - } + tabs <- gets (^. artifactTypeCheckingTables) + let importCtx = ImportContext tabs (s, a) <- runResultBuilder importCtx m - modify' (set artifactFunctions (s ^. resultBuilderStateCombinedFunctionsTable)) - modify' (set artifactTypes (s ^. resultBuilderStateCombinedTypesTable)) - modify' (set artifactInstances (s ^. resultBuilderStateCombinedInstanceTable)) - modify' (set artifactCoercions (s ^. resultBuilderStateCombinedCoercionTable)) + modify' (set artifactTypeCheckingTables (s ^. resultBuilderStateCombinedTables)) return a diff --git a/src/Juvix/Compiler/Pipeline/Artifacts/Base.hs b/src/Juvix/Compiler/Pipeline/Artifacts/Base.hs index afa20b3391..79fb679758 100644 --- a/src/Juvix/Compiler/Pipeline/Artifacts/Base.hs +++ b/src/Juvix/Compiler/Pipeline/Artifacts/Base.hs @@ -6,10 +6,8 @@ import Juvix.Compiler.Concrete.Translation.FromSource.Data.ParserState import Juvix.Compiler.Core.Data.Module qualified as Core 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.Loader.PathResolver.Data -import Juvix.Compiler.Store.Internal.Data.CoercionInfo -import Juvix.Compiler.Store.Internal.Data.InstanceInfo +import Juvix.Compiler.Store.Internal.Data.TypeCheckingTables import Juvix.Compiler.Store.Language qualified as Store import Juvix.Prelude @@ -27,10 +25,7 @@ data Artifacts = Artifacts -- Concrete -> Internal _artifactTerminationState :: TerminationState, -- Typechecking - _artifactTypes :: TypesTable, - _artifactFunctions :: FunctionsTable, - _artifactInstances :: InstanceTable, - _artifactCoercions :: CoercionTable, + _artifactTypeCheckingTables :: TypeCheckingTables, -- | This includes the InfoTable from all type checked modules _artifactInternalTypedTable :: Internal.InfoTable, -- Core diff --git a/src/Juvix/Compiler/Pipeline/Run.hs b/src/Juvix/Compiler/Pipeline/Run.hs index e70f99d2d0..b73424f7d9 100644 --- a/src/Juvix/Compiler/Pipeline/Run.hs +++ b/src/Juvix/Compiler/Pipeline/Run.hs @@ -246,17 +246,8 @@ runReplPipelineIOEither' lockMode entry = do _pipelineResult ^. Core.coreResultInternalTypedResult - typesTable :: Typed.TypesTable - typesTable = typedResult ^. Typed.resultIdenTypes - - functionsTable :: Typed.FunctionsTable - functionsTable = typedResult ^. Typed.resultFunctions - - instanceTable :: Typed.InstanceTable - instanceTable = typedResult ^. Typed.resultInstances - - coercionTable :: Typed.CoercionTable - coercionTable = typedResult ^. Typed.resultCoercions + typesTable :: Typed.TypeCheckingTables + typesTable = typedResult ^. Typed.resultTypeCheckingTables typedTable :: Internal.InfoTable typedTable = typedResult ^. Typed.resultInternalModule . Typed.internalModuleInfoTable @@ -289,10 +280,7 @@ runReplPipelineIOEither' lockMode entry = do _artifactCoreModule = coreModule, _artifactScopeTable = resultScoperTable, _artifactScopeExports = scopedResult ^. Scoped.resultExports, - _artifactTypes = typesTable, - _artifactFunctions = functionsTable, - _artifactInstances = instanceTable, - _artifactCoercions = coercionTable, + _artifactTypeCheckingTables = typesTable, _artifactScoperState = scopedResult ^. Scoped.resultScoperState, _artifactResolver = art ^. artifactResolver, _artifactNameIdState = art ^. artifactNameIdState, @@ -308,10 +296,7 @@ runReplPipelineIOEither' lockMode entry = do _artifactTerminationState = iniTerminationState, _artifactResolver = iniResolverState, _artifactNameIdState = genNameIdState defaultModuleId, - _artifactTypes = mempty, - _artifactFunctions = mempty, - _artifactInstances = mempty, - _artifactCoercions = mempty, + _artifactTypeCheckingTables = mempty, _artifactCoreModule = Core.emptyModule, _artifactScopeTable = mempty, _artifactScopeExports = mempty, diff --git a/src/Juvix/Compiler/Store/Internal/Data/TypeCheckingTables.hs b/src/Juvix/Compiler/Store/Internal/Data/TypeCheckingTables.hs new file mode 100644 index 0000000000..010d95ac70 --- /dev/null +++ b/src/Juvix/Compiler/Store/Internal/Data/TypeCheckingTables.hs @@ -0,0 +1,50 @@ +module Juvix.Compiler.Store.Internal.Data.TypeCheckingTables + ( module Juvix.Compiler.Store.Internal.Data.TypeCheckingTables, + module Juvix.Compiler.Store.Internal.Data.CoercionInfo, + module Juvix.Compiler.Store.Internal.Data.FunctionsTable, + module Juvix.Compiler.Store.Internal.Data.InstanceInfo, + module Juvix.Compiler.Store.Internal.Data.TypesTable, + ) +where + +import Juvix.Compiler.Store.Internal.Data.CoercionInfo +import Juvix.Compiler.Store.Internal.Data.FunctionsTable +import Juvix.Compiler.Store.Internal.Data.InstanceInfo +import Juvix.Compiler.Store.Internal.Data.TypesTable +import Juvix.Extra.Serialize +import Juvix.Prelude + +data TypeCheckingTables = TypeCheckingTables + { _typeCheckingTablesTypesTable :: TypesTable, + _typeCheckingTablesFunctionsTable :: FunctionsTable, + _typeCheckingTablesInstanceTable :: InstanceTable, + _typeCheckingTablesCoercionTable :: CoercionTable + } + deriving stock (Generic) + +makeLenses ''TypeCheckingTables + +instance Serialize TypeCheckingTables + +instance NFData TypeCheckingTables + +instance Monoid TypeCheckingTables where + mempty = + TypeCheckingTables + { _typeCheckingTablesTypesTable = mempty, + _typeCheckingTablesFunctionsTable = mempty, + _typeCheckingTablesInstanceTable = mempty, + _typeCheckingTablesCoercionTable = mempty + } + +instance Semigroup TypeCheckingTables where + a <> b = + TypeCheckingTables + { _typeCheckingTablesTypesTable = mappendField' typeCheckingTablesTypesTable, + _typeCheckingTablesFunctionsTable = mappendField' typeCheckingTablesFunctionsTable, + _typeCheckingTablesInstanceTable = mappendField' typeCheckingTablesInstanceTable, + _typeCheckingTablesCoercionTable = mappendField' typeCheckingTablesCoercionTable + } + where + mappendField' :: (Semigroup f) => Lens' TypeCheckingTables f -> f + mappendField' = mappendField a b diff --git a/src/Juvix/Compiler/Store/Internal/Language.hs b/src/Juvix/Compiler/Store/Internal/Language.hs index 74a0a12e19..1c9e5ff204 100644 --- a/src/Juvix/Compiler/Store/Internal/Language.hs +++ b/src/Juvix/Compiler/Store/Internal/Language.hs @@ -1,6 +1,7 @@ module Juvix.Compiler.Store.Internal.Language ( module Juvix.Compiler.Store.Internal.Data.InfoTable, module Juvix.Compiler.Store.Internal.Language, + module Juvix.Compiler.Store.Internal.Data.TypeCheckingTables, ) where @@ -10,7 +11,7 @@ import Juvix.Compiler.Store.Internal.Data.CoercionInfo import Juvix.Compiler.Store.Internal.Data.FunctionsTable import Juvix.Compiler.Store.Internal.Data.InfoTable import Juvix.Compiler.Store.Internal.Data.InstanceInfo -import Juvix.Compiler.Store.Internal.Data.TypesTable +import Juvix.Compiler.Store.Internal.Data.TypeCheckingTables import Juvix.Extra.Serialize import Juvix.Prelude @@ -19,10 +20,7 @@ data InternalModule = InternalModule _internalModuleName :: Name, _internalModuleImports :: [Import], _internalModuleInfoTable :: InfoTable, - _internalModuleInstanceTable :: InstanceTable, - _internalModuleCoercionTable :: CoercionTable, - _internalModuleTypesTable :: TypesTable, - _internalModuleFunctionsTable :: FunctionsTable + _internalModuleTypeCheckingTables :: TypeCheckingTables } deriving stock (Generic) @@ -52,14 +50,26 @@ insertInternalModule tab sm = over internalModuleTable (HashMap.insert (sm ^. in computeCombinedInfoTable :: InternalModuleTable -> InfoTable computeCombinedInfoTable = mconcatMap (^. internalModuleInfoTable) . HashMap.elems . (^. internalModuleTable) -computeTypesTable :: InternalModuleTable -> TypesTable -computeTypesTable = mconcatMap (^. internalModuleTypesTable) . (^. internalModuleTable) +computeTypeCheckingTables :: InternalModuleTable -> TypeCheckingTables +computeTypeCheckingTables itab = + TypeCheckingTables + { _typeCheckingTablesTypesTable = computeTypesTable, + _typeCheckingTablesInstanceTable = computeInstanceTable, + _typeCheckingTablesFunctionsTable = computeFunctionsTable, + _typeCheckingTablesCoercionTable = computeCoercionTable + } + where + computeTypesTable :: TypesTable + computeTypesTable = mconcatMap (^. internalModuleTypeCheckingTables . typeCheckingTablesTypesTable) (itab ^. internalModuleTable) -computeFunctionsTable :: InternalModuleTable -> FunctionsTable -computeFunctionsTable = mconcatMap (^. internalModuleFunctionsTable) . (^. internalModuleTable) + computeFunctionsTable :: FunctionsTable + computeFunctionsTable = + mconcatMap + (^. internalModuleTypeCheckingTables . typeCheckingTablesFunctionsTable) + (itab ^. internalModuleTable) -computeInstanceTable :: InternalModuleTable -> InstanceTable -computeInstanceTable = mconcatMap (^. internalModuleInstanceTable) . (^. internalModuleTable) + computeInstanceTable :: InstanceTable + computeInstanceTable = mconcatMap (^. internalModuleTypeCheckingTables . typeCheckingTablesInstanceTable) (itab ^. internalModuleTable) -computeCoercionTable :: InternalModuleTable -> CoercionTable -computeCoercionTable = mconcatMap (^. internalModuleCoercionTable) . (^. internalModuleTable) + computeCoercionTable :: CoercionTable + computeCoercionTable = mconcatMap (^. internalModuleTypeCheckingTables . typeCheckingTablesCoercionTable) (itab ^. internalModuleTable) diff --git a/src/Juvix/Compiler/Store/Scoped/Data/InfoTable.hs b/src/Juvix/Compiler/Store/Scoped/Data/InfoTable.hs index 81b0abb048..93ff39ed79 100644 --- a/src/Juvix/Compiler/Store/Scoped/Data/InfoTable.hs +++ b/src/Juvix/Compiler/Store/Scoped/Data/InfoTable.hs @@ -41,26 +41,26 @@ makeLenses ''InfoTable instance Semigroup InfoTable where tab1 <> tab2 = InfoTable - { _infoFixities = mappendField infoFixities, - _infoPrecedenceGraph = appendFieldWith combinePrecedenceGraphs infoPrecedenceGraph, - _infoConstructorSigs = mappendField infoConstructorSigs, - _infoNameSigs = mappendField infoNameSigs, - _infoParsedConstructorSigs = mappendField infoParsedConstructorSigs, - _infoParsedNameSigs = mappendField infoParsedNameSigs, - _infoBuiltins = mappendField infoBuiltins, - _infoRecords = mappendField infoRecords, - _infoFunctions = mappendField infoFunctions, - _infoInductives = mappendField infoInductives, - _infoConstructors = mappendField infoConstructors, - _infoAxioms = mappendField infoAxioms, - _infoScoperAlias = mappendField infoScoperAlias + { _infoFixities = mappendField' infoFixities, + _infoPrecedenceGraph = appendFieldWith' combinePrecedenceGraphs infoPrecedenceGraph, + _infoConstructorSigs = mappendField' infoConstructorSigs, + _infoNameSigs = mappendField' infoNameSigs, + _infoParsedConstructorSigs = mappendField' infoParsedConstructorSigs, + _infoParsedNameSigs = mappendField' infoParsedNameSigs, + _infoBuiltins = mappendField' infoBuiltins, + _infoRecords = mappendField' infoRecords, + _infoFunctions = mappendField' infoFunctions, + _infoInductives = mappendField' infoInductives, + _infoConstructors = mappendField' infoConstructors, + _infoAxioms = mappendField' infoAxioms, + _infoScoperAlias = mappendField' infoScoperAlias } where - mappendField :: (Semigroup f) => Lens' InfoTable f -> f - mappendField = appendFieldWith (<>) + mappendField' :: (Semigroup f) => Lens' InfoTable f -> f + mappendField' = appendFieldWith' (<>) - appendFieldWith :: (f -> f -> f) -> Lens' InfoTable f -> f - appendFieldWith joinfun l = joinfun (tab1 ^. l) (tab2 ^. l) + appendFieldWith' :: (f -> f -> f) -> Lens' InfoTable f -> f + appendFieldWith' = appendFieldWith tab1 tab2 instance Monoid InfoTable where mempty = diff --git a/src/Juvix/Prelude/Base/Foundation.hs b/src/Juvix/Prelude/Base/Foundation.hs index 32eb62e85e..23dc232e1e 100644 --- a/src/Juvix/Prelude/Base/Foundation.hs +++ b/src/Juvix/Prelude/Base/Foundation.hs @@ -760,3 +760,9 @@ zipWithNextLoop l = NonEmpty.reverse (go [] l) go acc = \case lastA :| [] -> (lastA, h) :| acc x :| y : as -> go ((x, y) : acc) (y :| as) + +mappendField :: (Semigroup f) => t -> t -> Lens' t f -> f +mappendField t1 t2 = appendFieldWith t1 t2 (<>) + +appendFieldWith :: t -> t -> (f -> f -> f) -> Lens' t f -> f +appendFieldWith t1 t2 joinfun l = joinfun (t1 ^. l) (t2 ^. l)