purescript · garyb · Sep 24, 2016 · Sep 24, 2016 · garyb · Sep 24, 2016
diff --git a/examples/failing/DuplicateModule.purs 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
@@ -0,0 +1 @@
+module M1 where
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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 _ _) =
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1,2 @@
		-- @shouldFailWith DuplicateModule
		module M1 where