@@ -26,7 +26,7 @@ import Control.Monad.Error.Class (MonadError(..))
2626import Control.Monad.Writer.Class (MonadWriter(..))
2727
2828import Data.Function (on)
29−import Data.List (groupBy, sortBy, nub, delete)
29+import Data.List (groupBy, sortBy, delete)
3030import Data.Maybe (fromJust, mapMaybe)
3131import qualified Data.Map as M
3232import qualified Data.Set as S
@@ -92,7 +92,9 @@ data Imports = Imports
9292 --
9393 , importedValueOps :: ImportMap (OpName 'ValueOpName)
9494 -- |
95− -- The modules that have been imported into the current scope.
95+ -- The name of modules that have been imported into the current scope that
96+ -- can be re-exported. If a module is imported with `as` qualification, the
97+ -- `as` name appears here, otherwise the original name.
9698 --
9799 , importedModules :: S.Set ModuleName
98100 -- |
@@ -114,37 +116,34 @@ nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.
114116data Exports = Exports
115117 {
116118 -- |
117− -- The types exported from each module along with the module they originally
118− -- came from.
119+ -- The exported types along with the module they originally came from.
119120 --
120− exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
121+ exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)
121122 -- |
122− -- The type operators exported from each module along with the module they
123− -- originally came from.
123+ -- The exported type operators along with the module they originally came
124+ -- from.
124125 --
125− , exportedTypeOps :: [(OpName 'TypeOpName, ModuleName)]
126+ , exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName
126127 -- |
127− -- The classes exported from each module along with the module they originally
128− -- came from.
128+ -- The exported classes along with the module they originally came from.
129129 --
130− , exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]
130+ , exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName
131131 -- |
132− -- The values exported from each module along with the module they originally
133− -- came from.
132+ -- The exported values along with the module they originally came from.
134133 --
135− , exportedValues :: [(Ident, ModuleName)]
134+ , exportedValues :: M.Map Ident ModuleName
136135 -- |
137− -- The value operators exported from each module along with the module they
138− -- originally came from.
136+ -- The exported value operators along with the module they originally came
137+ -- from.
139138 --
140− , exportedValueOps :: [(OpName 'ValueOpName, ModuleName)]
139+ , exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName
141140 } deriving (Show, Read)
142141
143142-- |
144143-- An empty 'Exports' value.
145144--
146145nullExports :: Exports
147−nullExports = Exports [] [] [] [] []
146+nullExports = Exports M.empty M.empty M.empty M.empty M.empty
148147
149148-- |
150149-- The imports and exports for a collection of modules. The 'SourceSpan' is used
@@ -177,11 +176,11 @@ envModuleExports (_, _, exps) = exps
177176primExports :: Exports
178177primExports =
179178 nullExports
180− { exportedTypes = mkTypeEntry `map` M.keys primTypes
181− , exportedTypeClasses = mkClassEntry `map` M.keys primClasses
179+ { exportedTypes = M.fromList $ mkTypeEntry `map` M.keys primTypes
180+ , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys primClasses
182181 }
183182 where
184− mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn)
183+ mkTypeEntry (Qualified mn name) = (name, ([], fromJust mn))
185184 mkClassEntry (Qualified mn name) = (name, fromJust mn)
186185
187186-- | Environment which only contains the Prim module.
@@ -202,20 +201,21 @@ exportType
202201 -> ModuleName
203202 -> m Exports
204203exportType exps name dctors mn = do
205− let exTypes' = exportedTypes exps
206− let exTypes = filter ((/= mn) . snd) exTypes'
207− let exDctors = (snd . fst) `concatMap` exTypes
204+ let exTypes = exportedTypes exps
208205 let exClasses = exportedTypeClasses exps
209− when (any ((== name) . fst . fst) exTypes) $
210− throwConflictError ConflictingTypeDecls name
211− when (any ((== coerceProperName name) . fst) exClasses) $
206+ case name `M.lookup` exTypes of
207+ Just (_, mn') | mn /= mn' -> throwConflictError ConflictingTypeDecls name
208+ _ -> return ()
209+ when (coerceProperName name `M.member` exClasses) $
212210 throwConflictError TypeConflictsWithClass name
213211 forM_ dctors $ \dctor -> do
214− when (dctor `elem` exDctors) $
212+ when (dctorExists (coerceProperName dctor) `any` exTypes) $
215213 throwConflictError ConflictingCtorDecls dctor
216− when (any ((== coerceProperName dctor) . fst) exClasses) $
214+ when (coerceProperName dctor `M.member` exClasses) $
217215 throwConflictError CtorConflictsWithClass dctor
218− return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }
216+ return $ exps { exportedTypes = M.insert name (dctors, mn) exTypes }
217+ where
218+ dctorExists dctor (dctors', mn') = mn /= mn' && elem dctor dctors'
219219
220220-- |
221221-- Safely adds a type operator to some exports, returning an error if a
@@ -242,10 +242,9 @@ exportTypeClass
242242 -> m Exports
243243exportTypeClass exps name mn = do
244244 let exTypes = exportedTypes exps
245− let exDctors = (snd . fst) `concatMap` exTypes
246− when (any ((== coerceProperName name) . fst . fst) exTypes) $
245+ when (coerceProperName name `M.member` exTypes) $
247246 throwConflictError ClassConflictsWithType name
248− when (coerceProperName name `elem` exDctors) $
247+ when ((elem (coerceProperName name) . fst) `any` exTypes) $
249248 throwConflictError ClassConflictsWithCtor name
250249 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)
251250 return $ exps { exportedTypeClasses = classes }
@@ -282,16 +281,19 @@ exportValueOp exps op mn = do
282281-- case an error is returned.
283282--
284283addExport
285− :: (MonadError MultipleErrors m, Eq a)
284+ :: (MonadError MultipleErrors m, Ord a)
286285 => (a -> SimpleErrorMessage)
287286 -> a
288287 -> ModuleName
289− -> [(a, ModuleName)]
290− -> m [(a, ModuleName)]
288+ -> M.Map a ModuleName
289+ -> m (M.Map a ModuleName)
291290addExport what name mn exports =
292− if any (\(name', mn') -> name == name' && mn /= mn') exports
293− then throwConflictError what name
294− else return $ nub $ (name, mn) : exports
291+ case M.lookup name exports of
292+ Just mn'
293+ | mn == mn' -> return exports
294+ | otherwise -> throwConflictError what name
295+ Nothing ->
296+ return $ M.insert name mn exports
295297
296298-- |
297299-- Raises an error for when there is more than one definition for something.