From 6fd459e61665e004f56b14403b8c5be516649f6d Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 24 Sep 2016 11:45:05 +0100 Subject: [PATCH] Fix the duplicate/redefined module error --- examples/failing/DuplicateModule.purs | 2 ++ examples/failing/DuplicateModule/M1.purs | 1 + purescript.cabal | 1 + src/Language/PureScript/AST/Declarations.hs | 7 ++++-- src/Language/PureScript/Errors.hs | 13 ++++------- src/Language/PureScript/Make.hs | 26 ++++++++++----------- src/Language/PureScript/Sugar/Names.hs | 15 +++++------- 7 files changed, 33 insertions(+), 32 deletions(-) create mode 100644 examples/failing/DuplicateModule.purs create mode 100644 examples/failing/DuplicateModule/M1.purs diff --git a/examples/failing/DuplicateModule.purs b/examples/failing/DuplicateModule.purs new file mode 100644 index 0000000000..5cd8a13e25 --- /dev/null +++ b/examples/failing/DuplicateModule.purs @@ -0,0 +1,2 @@ +-- @shouldFailWith DuplicateModule +module M1 where diff --git a/examples/failing/DuplicateModule/M1.purs b/examples/failing/DuplicateModule/M1.purs new file mode 100644 index 0000000000..5d99c370b0 --- /dev/null +++ b/examples/failing/DuplicateModule/M1.purs @@ -0,0 +1 @@ +module M1 where diff --git a/purescript.cabal b/purescript.cabal index 4c07045448..f2d4543228 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -60,6 +60,7 @@ extra-source-files: examples/passing/*.purs , examples/failing/ConflictingImports2/*.purs , examples/failing/ConflictingQualifiedImports/*.purs , examples/failing/ConflictingQualifiedImports2/*.purs + , examples/failing/DuplicateModule/*.purs , examples/failing/ExportConflictClass/*.purs , examples/failing/ExportConflictCtor/*.purs , examples/failing/ExportConflictType/*.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index b6e638b227..d28736e6a7 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -47,7 +47,6 @@ data SimpleErrorMessage | MultipleValueOpFixities (OpName 'ValueOpName) | MultipleTypeOpFixities (OpName 'TypeOpName) | OrphanTypeDeclaration Ident - | RedefinedModule ModuleName [SourceSpan] | RedefinedIdent Ident | OverlappingNamesInLet | UnknownName (Qualified Name) @@ -59,7 +58,7 @@ data SimpleErrorMessage | ScopeShadowing Name (Maybe ModuleName) [ModuleName] | DeclConflict Name Name | ExportConflict (Qualified Name) (Qualified Name) - | DuplicateModuleName ModuleName + | DuplicateModule ModuleName [SourceSpan] | DuplicateTypeArgument String | InvalidDoBind | InvalidDoLet @@ -177,6 +176,10 @@ data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [Decla getModuleName :: Module -> ModuleName getModuleName (Module _ _ name _ _) = name +-- | Return a module's source span. +getModuleSourceSpan :: Module -> SourceSpan +getModuleSourceSpan (Module ss _ _ _ _) = ss + -- | -- Add an import declaration for a module if it does not already explicitly import it. -- diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6d0d71e781..e6266d2883 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -90,7 +90,6 @@ errorCode em = case unwrapErrorMessage em of MultipleValueOpFixities{} -> "MultipleValueOpFixities" MultipleTypeOpFixities{} -> "MultipleTypeOpFixities" OrphanTypeDeclaration{} -> "OrphanTypeDeclaration" - RedefinedModule{} -> "RedefinedModule" RedefinedIdent{} -> "RedefinedIdent" OverlappingNamesInLet -> "OverlappingNamesInLet" UnknownName{} -> "UnknownName" @@ -102,7 +101,7 @@ errorCode em = case unwrapErrorMessage em of ScopeShadowing{} -> "ScopeShadowing" DeclConflict{} -> "DeclConflict" ExportConflict{} -> "ExportConflict" - DuplicateModuleName{} -> "DuplicateModuleName" + DuplicateModule{} -> "DuplicateModule" DuplicateTypeArgument{} -> "DuplicateTypeArgument" InvalidDoBind -> "InvalidDoBind" InvalidDoLet -> "InvalidDoLet" @@ -486,10 +485,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS line $ "There are multiple fixity/precedence declarations for type operator " ++ markCode (showOp op) renderSimpleErrorMessage (OrphanTypeDeclaration nm) = line $ "The type declaration for " ++ markCode (showIdent nm) ++ " should be followed by its definition." - renderSimpleErrorMessage (RedefinedModule name filenames) = - paras [ line ("The module " ++ markCode (runModuleName name) ++ " has been defined multiple times:") - , indent . paras $ map (line . displaySourceSpan) filenames - ] renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " ++ markCode (showIdent name) ++ " has been defined multiple times" renderSimpleErrorMessage (UnknownName name) = @@ -519,8 +514,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS line $ "Declaration for " ++ printName (Qualified Nothing new) ++ " conflicts with an existing " ++ nameType existing ++ " of the same name." renderSimpleErrorMessage (ExportConflict new existing) = line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing - renderSimpleErrorMessage (DuplicateModuleName mn) = - line $ "Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times." + renderSimpleErrorMessage (DuplicateModule mn ss) = + paras [ line ("Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times:") + , indent . paras $ map (line . displaySourceSpan) ss + ] renderSimpleErrorMessage (CycleInDeclaration nm) = line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 5e68831aa0..99d46721ad 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -40,8 +40,9 @@ import Data.Aeson (encode, decode) import qualified Data.Aeson as Aeson import Data.ByteString.Builder (toLazyByteString, stringUtf8) import Data.Either (partitionEithers) +import Data.Function (on) import Data.Foldable (for_) -import Data.List (foldl', sort) +import Data.List (foldl', sortBy, groupBy) import Data.Maybe (fromMaybe, catMaybes) import Data.String (fromString) import Data.Time.Clock @@ -191,18 +192,17 @@ make ma@MakeActions{..} ms = do where checkModuleNamesAreUnique :: m () checkModuleNamesAreUnique = - case findDuplicate (map getModuleName ms) of - Nothing -> return () - Just mn -> throwError . errorMessage $ DuplicateModuleName mn - - -- Verify that a list of values has unique keys - findDuplicate :: (Ord a) => [a] -> Maybe a - findDuplicate = go . sort - where - go (x : y : xs) - | x == y = Just x - | otherwise = go (y : xs) - go _ = Nothing + for_ (findDuplicates getModuleName ms) $ \mss -> + throwError . flip foldMap mss $ \ms' -> + let mn = getModuleName (head ms') + in errorMessage $ DuplicateModule mn (map getModuleSourceSpan ms') + + -- Find all groups of duplicate values in a list based on a projection. + findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [[a]] + findDuplicates f xs = + case filter ((> 1) . length) . groupBy ((==) `on` f) . sortBy (compare `on` f) $ xs of + [] -> Nothing + xss -> Just xss -- Sort a list so its elements appear in the same order as in another list. inOrderOf :: (Ord a) => [a] -> [a] -> [a] diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 1ccd2837b1..2d2a483ad2 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -99,15 +99,12 @@ desugarImportsWithEnv externs modules = do exportedRefs f = M.fromList $ (, efModuleName) <$> mapMaybe f efExports updateEnv :: ([Module], Env) -> Module -> m ([Module], Env) - updateEnv (ms, env) m@(Module ss _ mn _ refs) = - case mn `M.lookup` env of - Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss] - Nothing -> do - members <- findExportable m - let env' = M.insert mn (ss, primImports, members) env - (m', imps) <- resolveImports env' m - exps <- maybe (return members) (resolveExports env' ss mn imps members) refs - return (m' : ms, M.insert mn (ss, imps, exps) env) + updateEnv (ms, env) m@(Module ss _ mn _ refs) = do + members <- findExportable m + let env' = M.insert mn (ss, primImports, members) env + (m', imps) <- resolveImports env' m + exps <- maybe (return members) (resolveExports env' ss mn imps members) refs + return (m' : ms, M.insert mn (ss, imps, exps) env) renameInModule' :: Env -> Module -> m Module renameInModule' env m@(Module _ _ mn _ _) =