Skip to content

Commit 2da4825

Browse files
garybgaryb
committed
Merge pull request purescript#2129 from purescript/name-map
Use Map rather than list in Exports
2 parents 11f4898 + b7a6f2b commit 2da4825

File tree

6 files changed

+160
-145
lines changed

6 files changed

+160
-145
lines changed

‎src/Language/PureScript/Docs/Convert/ReExports.hs‎

Lines changed: 13 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@ module Language.PureScript.Docs.Convert.ReExports
44

55
import Prelude.Compat
66

7-
import Control.Arrow ((&&&), first, second)
7+
import Control.Arrow ((&&&), second)
88
import Control.Monad
99
import Control.Monad.Reader.Class (MonadReader, ask)
1010
import Control.Monad.State.Class (MonadState, gets, modify)
@@ -96,7 +96,7 @@ getReExports env mn =
9696
-- * Filters type class declarations to ensure that only re-exported type
9797
-- class members are listed.
9898
--
99-
collectDeclarations ::
99+
collectDeclarations :: forall m.
100100
(MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) =>
101101
P.Imports ->
102102
P.Exports ->
@@ -111,13 +111,20 @@ collectDeclarations imports exports = do
111111
(vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses
112112

113113
let filteredTypes = filterDataConstructors expCtors types
114-
let filteredClasses = filterTypeClassMembers (map fst expVals) classes
114+
let filteredClasses = filterTypeClassMembers (Map.keys expVals) classes
115115

116116
pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps]))
117117

118118
where
119+
120+
collect
121+
:: (Eq a, Show a)
122+
=> (P.ModuleName -> a -> m (P.ModuleName, [b]))
123+
-> [P.ImportRecord a]
124+
-> Map a P.ModuleName
125+
-> m (Map P.ModuleName [b])
119126
collect lookup' imps exps = do
120-
imps' <- traverse (findImport imps) exps
127+
imps' <- traverse (findImport imps) $ Map.toList exps
121128
Map.fromListWith (<>) <$> traverse (uncurry lookup') imps'
122129

123130
expVals = P.exportedValues exports
@@ -126,13 +133,13 @@ collectDeclarations imports exports = do
126133
expValOps = P.exportedValueOps exports
127134
impValOps = concat (Map.elems (P.importedValueOps imports))
128135

129-
expTypes = map (first fst) (P.exportedTypes exports)
136+
expTypes = Map.map snd (P.exportedTypes exports)
130137
impTypes = concat (Map.elems (P.importedTypes imports))
131138

132139
expTypeOps = P.exportedTypeOps exports
133140
impTypeOps = concat (Map.elems (P.importedTypeOps imports))
134141

135-
expCtors = concatMap (snd . fst) (P.exportedTypes exports)
142+
expCtors = concatMap fst (Map.elems (P.exportedTypes exports))
136143

137144
expTCs = P.exportedTypeClasses exports
138145
impTCs = concat (Map.elems (P.importedTypeClasses imports))

‎src/Language/PureScript/Linter/Imports.hs‎

Lines changed: 12 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -158,17 +158,17 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do
158158
-- that are implicitly exported and then re-exported.
159159
elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports
160160
elaborateUsed scope mne used =
161-
let classes = extractByQual mne (importedTypeClasses scope) TyClassName
162-
types = extractByQual mne (importedTypes scope) TyName
163-
dctors = extractByQual mne (importedDataConstructors scope) DctorName
164-
values = extractByQual mne (importedValues scope) IdentName
165-
in foldr go used (classes ++ types ++ dctors ++ values)
161+
foldr go used
162+
$ extractByQual mne (importedTypeClasses scope) TyClassName
163+
++ extractByQual mne (importedTypes scope) TyName
164+
++ extractByQual mne (importedDataConstructors scope) DctorName
165+
++ extractByQual mne (importedValues scope) IdentName
166166
where
167167
go :: (ModuleName, Qualified Name) -> UsedImports -> UsedImports
168168
go (q, name) = M.alter (Just . maybe [name] (name :)) q
169169

170170
extractByQual
171-
:: (Eq a)
171+
:: Eq a
172172
=> ModuleName
173173
-> M.Map (Qualified a) [ImportRecord a]
174174
-> (a -> Name)
@@ -257,21 +257,20 @@ lintImportDecl env mni qualifierName names declType allowImplicit =
257257

258258
dtys
259259
:: ModuleName
260-
-> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
261-
dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env
260+
-> M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)
261+
dtys mn = maybe M.empty exportedTypes $ envModuleExports <$> mn `M.lookup` env
262262

263263
dctorsForType
264264
:: ModuleName
265265
-> ProperName 'TypeName
266266
-> [ProperName 'ConstructorName]
267-
dctorsForType mn tn =
268-
maybe [] (snd . fst) $ find ((== tn) . fst . fst) (dtys mn)
267+
dctorsForType mn tn = maybe [] fst $ tn `M.lookup` dtys mn
269268

270269
typeForDCtor
271270
:: ModuleName
272271
-> ProperName 'ConstructorName
273272
-> Maybe (ProperName 'TypeName)
274-
typeForDCtor mn pn = fst . fst <$> find (elem pn . snd . fst) (dtys mn)
273+
typeForDCtor mn pn = fst <$> find (elem pn . fst . snd) (M.toList (dtys mn))
275274

276275
findUsedRefs
277276
:: Env
@@ -310,8 +309,8 @@ findUsedRefs env mni qn names =
310309
findTypeForDctor mn dctor =
311310
case mn `M.lookup` env of
312311
Just (_, _, exps) ->
313-
case find (elem dctor . snd . fst) (exportedTypes exps) of
314-
Just ((ty, _), _) -> ty
312+
case find (elem dctor . fst . snd) (M.toList (exportedTypes exps)) of
313+
Just (ty, _) -> ty
315314
Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"
316315
Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"
317316

‎src/Language/PureScript/Sugar/Names.hs‎

Lines changed: 27 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,7 @@ module Language.PureScript.Sugar.Names
1010

1111
import Prelude.Compat
1212

13-
import Control.Arrow (first)
13+
import Control.Arrow (first, second)
1414
import Control.Monad
1515
import Control.Monad.Error.Class (MonadError(..))
1616
import Control.Monad.State.Lazy
@@ -72,28 +72,28 @@ desugarImportsWithEnv externs modules = do
7272
return $ M.insert efModuleName (ss, imps, exps) env
7373
where
7474

75-
exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
76-
exportedTypes = mapMaybe toExportedType efExports
75+
exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)
76+
exportedTypes = M.fromList $ mapMaybe toExportedType efExports
7777
where
78-
toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName)
78+
toExportedType (TypeRef tyCon dctors) = Just (tyCon, (fromMaybe (mapMaybe forTyCon efDeclarations) dctors, efModuleName))
7979
where
8080
forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName)
8181
forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn
8282
forTyCon _ = Nothing
8383
toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r
8484
toExportedType _ = Nothing
8585

86-
exportedTypeOps :: [(OpName 'TypeOpName, ModuleName)]
87-
exportedTypeOps = (, efModuleName) <$> mapMaybe getTypeOpRef efExports
86+
exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName
87+
exportedTypeOps = M.fromList $ (, efModuleName) <$> mapMaybe getTypeOpRef efExports
8888

89-
exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]
90-
exportedTypeClasses = (, efModuleName) <$> mapMaybe getTypeClassRef efExports
89+
exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName
90+
exportedTypeClasses = M.fromList $ (, efModuleName) <$> mapMaybe getTypeClassRef efExports
9191

92-
exportedValues :: [(Ident, ModuleName)]
93-
exportedValues = (, efModuleName) <$> mapMaybe getValueRef efExports
92+
exportedValues :: M.Map Ident ModuleName
93+
exportedValues = M.fromList $ (, efModuleName) <$> mapMaybe getValueRef efExports
9494

95-
exportedValueOps :: [(OpName 'ValueOpName, ModuleName)]
96-
exportedValueOps = (, efModuleName) <$> mapMaybe getValueOpRef efExports
95+
exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName
96+
exportedValueOps = M.fromList $ (, efModuleName) <$> mapMaybe getValueOpRef efExports
9797

9898
updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)
9999
updateEnv (ms, env) m@(Module ss _ mn _ refs) =
@@ -122,7 +122,7 @@ desugarImportsWithEnv externs modules = do
122122
elaborateExports :: Exports -> Module -> Module
123123
elaborateExports exps (Module ss coms mn decls refs) =
124124
Module ss coms mn decls $
125-
Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (my exportedTypes) ++
125+
Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) myTypes ++
126126
map TypeOpRef (my exportedTypeOps) ++
127127
map TypeClassRef (my exportedTypeClasses) ++
128128
map ValueRef (my exportedValues) ++
@@ -131,8 +131,14 @@ elaborateExports exps (Module ss coms mn decls refs) =
131131
where
132132
-- Extracts a list of values from the exports and filters out any values that
133133
-- are re-exports from other modules.
134-
my :: (Exports -> [(a, ModuleName)]) -> [a]
135-
my f = fst `map` filter ((== mn) . snd) (f exps)
134+
my :: (Exports -> M.Map a ModuleName) -> [a]
135+
my = map fst <$> filt (== mn)
136+
137+
myTypes :: [(ProperName 'TypeName, [ProperName 'ConstructorName])]
138+
myTypes = second fst <$> filt ((== mn) . snd) exportedTypes
139+
140+
filt :: (b -> Bool) -> (Exports -> M.Map a b) -> [(a, b)]
141+
filt predicate f = M.toList $ predicate `M.filter` f exps
136142

137143
-- |
138144
-- Replaces all local names with qualified names within a module and checks that all existing
@@ -294,26 +300,26 @@ renameInModule env imports (Module ss coms mn decls exps) =
294300

295301
-- Used when performing an update to qualify values and classes with their
296302
-- module of original definition.
297-
resolve :: (Eq a) => [(a, ModuleName)] -> a -> Maybe (Qualified a)
298-
resolve as name = mkQualified name <$> name `lookup` as
303+
resolve :: Ord a => M.Map a ModuleName -> a -> Maybe (Qualified a)
304+
resolve as name = mkQualified name <$> name `M.lookup` as
299305

300306
-- Used when performing an update to qualify types with their module of
301307
-- original definition.
302308
resolveType
303-
:: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
309+
:: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)
304310
-> ProperName 'TypeName
305311
-> Maybe (Qualified (ProperName 'TypeName))
306312
resolveType tys name =
307-
mkQualified name . snd <$> find ((== name) . fst . fst) tys
313+
mkQualified name . snd <$> M.lookup name tys
308314

309315
-- Used when performing an update to qualify data constructors with their
310316
-- module of original definition.
311317
resolveDctor
312-
:: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
318+
:: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)
313319
-> ProperName 'ConstructorName
314320
-> Maybe (Qualified (ProperName 'ConstructorName))
315321
resolveDctor tys name =
316-
mkQualified name . snd <$> find (elem name . snd . fst) tys
322+
mkQualified name . snd <$> find (elem name . fst) tys
317323

318324
-- Update names so unqualified references become qualified, and locally
319325
-- qualified references are replaced with their canoncial qualified names

‎src/Language/PureScript/Sugar/Names/Env.hs‎

Lines changed: 41 additions & 39 deletions
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,7 @@ import Control.Monad.Error.Class (MonadError(..))
2626
import Control.Monad.Writer.Class (MonadWriter(..))
2727

2828
import Data.Function (on)
29-
import Data.List (groupBy, sortBy, nub, delete)
29+
import Data.List (groupBy, sortBy, delete)
3030
import Data.Maybe (fromJust, mapMaybe)
3131
import qualified Data.Map as M
3232
import 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.
114116
data 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
--
146145
nullExports :: 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
177176
primExports :: Exports
178177
primExports =
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
204203
exportType 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
243243
exportTypeClass 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
--
284283
addExport
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)
291290
addExport 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.

0 commit comments

Comments
 (0)