@@ -14,6 +14,7 @@
1414{-# LANGUAGE FlexibleContexts #-}
1515{-# LANGUAGE ScopedTypeVariables #-}
1616{-# LANGUAGE TupleSections #-}
17+{-# LANGUAGE LambdaCase #-}
1718
1819module Language.PureScript.Sugar.Names.Imports
1920 ( resolveImports
@@ -24,9 +25,10 @@ module Language.PureScript.Sugar.Names.Imports
2425import Prelude ()
2526import Prelude.Compat
2627
27−import Data.List (find, delete)
28+import Data.List (find, delete, (\\))
2829import Data.Maybe (fromMaybe, isJust, isNothing, fromJust)
2930import Data.Foldable (traverse_, for_)
31+import Data.Traversable (for)
3032
3133import Control.Arrow (first)
3234import Control.Monad
@@ -64,33 +66,48 @@ findImports = foldM (go Nothing) M.empty
6466 checkImportRef (ModuleRef name) = throwError . errorMessage $ ImportHidingModule name
6567 checkImportRef _ = return ()
6668
69+type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
70+
6771-- |
6872-- Constructs a set of imports for a module.
6973--
70−resolveImports :: (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports
74+resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports
7175resolveImports env (Module _ _ currentModule decls _) =
7276 warnAndRethrow (addHint (ErrorInModule currentModule)) $ do
7377 imports <- findImports decls
7478
7579 for_ (M.toList imports) $ \(mn, imps) -> do
76− let unqual = filter (\(_, _, q) -> isJust q) (reverse imps)
7780
78− when (length imps > 1) $ for_ (selfCartesianSubset imps) $
79− \((_, t1, q1), (pos, t2, q2)) ->
80− when (t1 == t2 && q1 == q2) $
81− maybe id warnWithPosition pos $
82− tell . errorMessage $ DuplicateImport mn t2 q2
81+ -- Better ordering for the warnings: the list is in last-import-first
82+ -- order, but we want the first appearence of an import to be the primary,
83+ -- and warnings to appear for later imports
84+ let imps' = reverse imps
85+
86+ warned <- foldM (checkDuplicateImports mn) [] (selfCartesianSubset imps')
87+
88+ let unqual = filter (\(_, _, q) -> isJust q) (imps' \\ warned)
8389
84− when (length unqual > 1) $
85− case find (\(_, typ, _) -> typ == Implicit) unqual of
90+ warned' <- (warned ++) <$>
91+ if (length unqual < 2)
92+ then return []
93+ else case find (\(_, typ, _) -> typ == Implicit) unqual of
8694 Just i ->
87− for_ (delete i unqual) $ \(pos, typ, _) ->
88− maybe id warnWithPosition pos $
89− tell $ errorMessage $ RedundantUnqualifiedImport mn typ
95+ for (delete i unqual) $ \i'@(pos, typ, _) -> do
96+ warn pos $ RedundantUnqualifiedImport mn typ
97+ return i'
9098 Nothing ->
91− for_ (tail unqual) $ \(pos, _, _) ->
92− maybe id warnWithPosition pos $
93− tell $ errorMessage $ DuplicateSelectiveImport mn
99+ for (tail unqual) $ \i@(pos, _, _) -> do
100+ warn pos $ DuplicateSelectiveImport mn
101+ return i
102+
103+ for_ (imps' \\ warned') $ \(pos, typ, _) ->
104+ let (dupeRefs, dupeDctors) = findDuplicateRefs $ case typ of
105+ Explicit refs -> refs
106+ Hiding refs -> refs
107+ _ -> []
108+ in warnDupeRefs pos dupeRefs >> warnDupeDctors pos dupeDctors
109+
110+ return ()
94111
95112 let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports
96113 foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)
@@ -100,6 +117,31 @@ resolveImports env (Module _ _ currentModule decls _) =
100117 selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs
101118 selfCartesianSubset [] = []
102119
120+ checkDuplicateImports :: ModuleName -> [ImportDef] -> (ImportDef, ImportDef) -> m [ImportDef]
121+ checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) =
122+ if (t1 == t2 && q1 == q2)
123+ then do
124+ warn pos $ DuplicateImport mn t2 q2
125+ return $ (pos, t2, q2) : xs
126+ else return xs
127+
128+ warnDupeRefs :: Maybe SourceSpan -> [DeclarationRef] -> m ()
129+ warnDupeRefs pos = traverse_ $ \case
130+ TypeRef name _ -> warnDupe pos $ "type " ++ runProperName name
131+ ValueRef name -> warnDupe pos $ "value " ++ runIdent name
132+ TypeClassRef name -> warnDupe pos $ "class " ++ runProperName name
133+ ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name
134+ _ -> return ()
135+
136+ warnDupeDctors :: Maybe SourceSpan -> [ProperName] -> m ()
137+ warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName)
138+
139+ warnDupe :: Maybe SourceSpan -> String -> m ()
140+ warnDupe pos ref = warn pos $ DuplicateImportRef ref
141+
142+ warn :: Maybe SourceSpan -> SimpleErrorMessage -> m ()
143+ warn pos msg = maybe id warnWithPosition pos $ tell . errorMessage $ msg
144+
103145-- | Constructs a set of imports for a single module import.
104146resolveModuleImport ::
105147 forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>