diff --git a/src/Juvix/Compiler/Concrete/Data/NameSpace.hs b/src/Juvix/Compiler/Concrete/Data/NameSpace.hs index 3ab2c14fd7..a6ec52b425 100644 --- a/src/Juvix/Compiler/Concrete/Data/NameSpace.hs +++ b/src/Juvix/Compiler/Concrete/Data/NameSpace.hs @@ -36,6 +36,12 @@ type family NameSpaceEntryType s = res | res -> s where NameSpaceEntryType 'NameSpaceModules = ModuleSymbolEntry NameSpaceEntryType 'NameSpaceFixities = FixitySymbolEntry +nameSpaceElemName :: (IsString str) => NameSpace -> str +nameSpaceElemName = \case + NameSpaceSymbols -> "symbol" + NameSpaceModules -> "module" + NameSpaceFixities -> "fixity" + entryName :: forall ns. (SingI ns) => Lens' (NameSpaceEntryType ns) S.Name entryName = case sing :: SNameSpace ns of SNameSpaceSymbols -> \f -> \case diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs index cdbeb9468b..aa25882f5b 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs @@ -925,18 +925,17 @@ exportScope Scope {..} = do err :: NonEmpty (NameSpaceEntryType ns) -> Sem r a err es = - throw - ( ErrMultipleExport - ( MultipleExportConflict - _scopePath - s - ( case sing :: SNameSpace ns of - SNameSpaceSymbols -> ExportEntriesSymbols es - SNameSpaceModules -> ExportEntriesModules es - SNameSpaceFixities -> ExportEntriesFixities es - ) - ) - ) + throw $ + ErrMultipleExport + MultipleExportConflict + { _multipleExportModule = _scopePath, + _multipleExportSymbol = s, + _multipleExportNameSpace = fromSing (sing :: SNameSpace ns), + _multipleExportEntries = case sing :: SNameSpace ns of + SNameSpaceSymbols -> ExportEntriesSymbols es + SNameSpaceModules -> ExportEntriesModules es + SNameSpaceFixities -> ExportEntriesFixities es + } getLocalModules :: (Member (State ScoperState) r) => ExportInfo -> Sem r (HashMap S.NameId ScopedModule) getLocalModules ExportInfo {..} = do diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs index 9b6333e066..dff090e783 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs @@ -279,6 +279,7 @@ data ExportEntries data MultipleExportConflict = MultipleExportConflict { _multipleExportModule :: S.AbsModulePath, _multipleExportSymbol :: Symbol, + _multipleExportNameSpace :: NameSpace, _multipleExportEntries :: ExportEntries } deriving stock (Show) @@ -297,10 +298,21 @@ instance ToGenericError MultipleExportConflict where opts' = fromGenericOptions opts i = getLoc _multipleExportModule msg = - "The symbol" + "The" + <+> nameSpaceElemName _multipleExportNameSpace <+> ppCode opts' _multipleExportSymbol <+> "is exported multiple times in the module" <+> ppCode opts' _multipleExportModule + <> hardline + <> itemize + ( case _multipleExportEntries of + ExportEntriesSymbols s -> ppEntry <$> s + ExportEntriesModules s -> ppEntry <$> s + ExportEntriesFixities s -> ppEntry <$> s + ) + where + ppEntry :: (HasLoc e) => e -> Doc CodeAnn + ppEntry e = "Defined in" <+> annotate (AnnKind KNameTopModule) (pretty (getLoc e)) data NotInScope = NotInScope { _notInScopeSymbol :: Symbol, diff --git a/src/Juvix/Compiler/Store/Scoped/Data/SymbolEntry.hs b/src/Juvix/Compiler/Store/Scoped/Data/SymbolEntry.hs index de1435bd21..bb57683c45 100644 --- a/src/Juvix/Compiler/Store/Scoped/Data/SymbolEntry.hs +++ b/src/Juvix/Compiler/Store/Scoped/Data/SymbolEntry.hs @@ -85,6 +85,9 @@ instance HasNameKind ModuleSymbolEntry where instance HasLoc ModuleSymbolEntry where getLoc (ModuleSymbolEntry s) = s ^. S.nameDefined +instance HasLoc FixitySymbolEntry where + getLoc (FixitySymbolEntry s) = s ^. S.nameDefined + symbolEntryNameId :: SymbolEntry -> NameId symbolEntryNameId = (^. symbolEntry . S.nameId)