2da4825 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge pull request #2129 from purescript/name-map

2da4825Gary Burgess10 years ago

src/Language/PureScript/Docs/Convert/ReExports.hs+13−6

compare with golang

unifiedsplit

@@ -4,7 +4,7 @@ module Language.PureScript.Docs.Convert.ReExports

5import Prelude.Compat

7−import Control.Arrow ((&&&), first, second)

7+import Control.Arrow ((&&&), second)

8import Control.Monad

9import Control.Monad.Reader.Class (MonadReader, ask)

10import Control.Monad.State.Class (MonadState, gets, modify)

@@ -96,7 +96,7 @@ getReExports env mn =

96-- * Filters type class declarations to ensure that only re-exported type

97-- class members are listed.

98--

99−collectDeclarations ::

99+collectDeclarations :: forall m.

100 (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) =>

101 P.Imports ->

102 P.Exports ->

@@ -111,13 +111,20 @@ collectDeclarations imports exports = do

111 (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses

112

113 let filteredTypes = filterDataConstructors expCtors types

114− let filteredClasses = filterTypeClassMembers (map fst expVals) classes

114+ let filteredClasses = filterTypeClassMembers (Map.keys expVals) classes

115

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

117

118 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])

119 collect lookup' imps exps = do

126 collect lookup' imps exps = do

120− imps' <- traverse (findImport imps) exps

127+ imps' <- traverse (findImport imps) $ Map.toList exps

121 Map.fromListWith (<>) <$> traverse (uncurry lookup') imps'

128 Map.fromListWith (<>) <$> traverse (uncurry lookup') imps'

122

129

123 expVals = P.exportedValues exports

130 expVals = P.exportedValues exports

@@ -126,13 +133,13 @@ collectDeclarations imports exports = do

126 expValOps = P.exportedValueOps exports

133 expValOps = P.exportedValueOps exports

127 impValOps = concat (Map.elems (P.importedValueOps imports))

134 impValOps = concat (Map.elems (P.importedValueOps imports))

128

135

129− expTypes = map (first fst) (P.exportedTypes exports)

136+ expTypes = Map.map snd (P.exportedTypes exports)

130 impTypes = concat (Map.elems (P.importedTypes imports))

137 impTypes = concat (Map.elems (P.importedTypes imports))

131

138

132 expTypeOps = P.exportedTypeOps exports

139 expTypeOps = P.exportedTypeOps exports

133 impTypeOps = concat (Map.elems (P.importedTypeOps imports))

140 impTypeOps = concat (Map.elems (P.importedTypeOps imports))

134

141

135− expCtors = concatMap (snd . fst) (P.exportedTypes exports)

142+ expCtors = concatMap fst (Map.elems (P.exportedTypes exports))

136

143

137 expTCs = P.exportedTypeClasses exports

144 expTCs = P.exportedTypeClasses exports

138 impTCs = concat (Map.elems (P.importedTypeClasses imports))

145 impTCs = concat (Map.elems (P.importedTypeClasses imports))

src/Language/PureScript/Linter/Imports.hs+12−13

@@ -158,17 +158,17 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do

158 -- that are implicitly exported and then re-exported.

159 elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports

160 elaborateUsed scope mne used =

161+ foldr go used

161− let classes = extractByQual mne (importedTypeClasses scope) TyClassName

162+ $ extractByQual mne (importedTypeClasses scope) TyClassName

162− types = extractByQual mne (importedTypes scope) TyName

163+ ++ extractByQual mne (importedTypes scope) TyName

163− dctors = extractByQual mne (importedDataConstructors scope) DctorName

164+ ++ extractByQual mne (importedDataConstructors scope) DctorName

164− values = extractByQual mne (importedValues scope) IdentName

165+ ++ extractByQual mne (importedValues scope) IdentName

165− in foldr go used (classes ++ types ++ dctors ++ values)

166 where

167 go :: (ModuleName, Qualified Name) -> UsedImports -> UsedImports

168 go (q, name) = M.alter (Just . maybe [name] (name :)) q

169

170 extractByQual

171− :: (Eq a)

171+ :: Eq a

172 => ModuleName

173 -> M.Map (Qualified a) [ImportRecord a]

174 -> (a -> Name)

@@ -257,21 +257,20 @@ lintImportDecl env mni qualifierName names declType allowImplicit =

257

258 dtys

259 :: ModuleName

260− -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

260+ -> M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)

261− dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env

261+ dtys mn = maybe M.empty exportedTypes $ envModuleExports <$> mn `M.lookup` env

262

263 dctorsForType

264 :: ModuleName

265 -> ProperName 'TypeName

266 -> [ProperName 'ConstructorName]

267− dctorsForType mn tn =

267+ dctorsForType mn tn = maybe [] fst $ tn `M.lookup` dtys mn

268− maybe [] (snd . fst) $ find ((== tn) . fst . fst) (dtys mn)

269

268

270 typeForDCtor

269 typeForDCtor

271 :: ModuleName

270 :: ModuleName

272 -> ProperName 'ConstructorName

271 -> ProperName 'ConstructorName

273 -> Maybe (ProperName 'TypeName)

272 -> 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))

275

274

276findUsedRefs

275findUsedRefs

277 :: Env

276 :: Env

@@ -310,8 +309,8 @@ findUsedRefs env mni qn names =

310 findTypeForDctor mn dctor =

309 findTypeForDctor mn dctor =

311 case mn `M.lookup` env of

310 case mn `M.lookup` env of

312 Just (_, _, exps) ->

311 Just (_, _, exps) ->

313− case find (elem dctor . snd . fst) (exportedTypes exps) of

312+ case find (elem dctor . fst . snd) (M.toList (exportedTypes exps)) of

314− Just ((ty, _), _) -> ty

313+ Just (ty, _) -> ty

315 Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"

314 Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"

316 Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"

315 Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"

317

316

src/Language/PureScript/Sugar/Names.hs+27−21

@@ -10,7 +10,7 @@ module Language.PureScript.Sugar.Names

11import Prelude.Compat

13−import Control.Arrow (first)

13+import Control.Arrow (first, second)

14import Control.Monad

15import Control.Monad.Error.Class (MonadError(..))

16import Control.Monad.State.Lazy

@@ -72,10 +72,10 @@ desugarImportsWithEnv externs modules = do

72 return $ M.insert efModuleName (ss, imps, exps) env

73 where

75− exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

75+ exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)

76− exportedTypes = mapMaybe toExportedType efExports

76+ exportedTypes = M.fromList $ mapMaybe toExportedType efExports

77 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))

79 where

80 forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName)

81 forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn

@@ -83,17 +83,17 @@ desugarImportsWithEnv externs modules = do

83 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

84 toExportedType _ = Nothing

86− exportedTypeOps :: [(OpName 'TypeOpName, ModuleName)]

86+ exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName

87− exportedTypeOps = (, efModuleName) <$> mapMaybe getTypeOpRef efExports

87+ exportedTypeOps = M.fromList $ (, efModuleName) <$> mapMaybe getTypeOpRef efExports

89− exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

89+ exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName

90− exportedTypeClasses = (, efModuleName) <$> mapMaybe getTypeClassRef efExports

90+ exportedTypeClasses = M.fromList $ (, efModuleName) <$> mapMaybe getTypeClassRef efExports

92− exportedValues :: [(Ident, ModuleName)]

92+ exportedValues :: M.Map Ident ModuleName

93− exportedValues = (, efModuleName) <$> mapMaybe getValueRef efExports

93+ exportedValues = M.fromList $ (, efModuleName) <$> mapMaybe getValueRef efExports

95− exportedValueOps :: [(OpName 'ValueOpName, ModuleName)]

95+ exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName

96− exportedValueOps = (, efModuleName) <$> mapMaybe getValueOpRef efExports

96+ exportedValueOps = M.fromList $ (, efModuleName) <$> mapMaybe getValueOpRef efExports

98 updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)

99 updateEnv (ms, env) m@(Module ss _ mn _ refs) =

@@ -122,7 +122,7 @@ desugarImportsWithEnv externs modules = do

122elaborateExports :: Exports -> Module -> Module

123elaborateExports exps (Module ss coms mn decls refs) =

124 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 ++

126 map TypeOpRef (my exportedTypeOps) ++

127 map TypeClassRef (my exportedTypeClasses) ++

128 map ValueRef (my exportedValues) ++

@@ -131,8 +131,14 @@ elaborateExports exps (Module ss coms mn decls refs) =

131 where

132 -- Extracts a list of values from the exports and filters out any values that

133 -- are re-exports from other modules.

134− my :: (Exports -> [(a, ModuleName)]) -> [a]

134+ my :: (Exports -> M.Map a ModuleName) -> [a]

135− my f = fst `map` filter ((== mn) . snd) (f exps)

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

136

142

137-- |

143-- |

138-- Replaces all local names with qualified names within a module and checks that all existing

144-- 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) =

294

300

295 -- Used when performing an update to qualify values and classes with their

301 -- Used when performing an update to qualify values and classes with their

296 -- module of original definition.

302 -- module of original definition.

297− resolve :: (Eq a) => [(a, ModuleName)] -> a -> Maybe (Qualified a)

303+ resolve :: Ord a => M.Map a ModuleName -> a -> Maybe (Qualified a)

298− resolve as name = mkQualified name <$> name `lookup` as

304+ resolve as name = mkQualified name <$> name `M.lookup` as

299

305

300 -- Used when performing an update to qualify types with their module of

306 -- Used when performing an update to qualify types with their module of

301 -- original definition.

307 -- original definition.

302 resolveType

308 resolveType

303− :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

309+ :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)

304 -> ProperName 'TypeName

310 -> ProperName 'TypeName

305 -> Maybe (Qualified (ProperName 'TypeName))

311 -> Maybe (Qualified (ProperName 'TypeName))

306 resolveType tys name =

312 resolveType tys name =

307− mkQualified name . snd <$> find ((== name) . fst . fst) tys

313+ mkQualified name . snd <$> M.lookup name tys

308

314

309 -- Used when performing an update to qualify data constructors with their

315 -- Used when performing an update to qualify data constructors with their

310 -- module of original definition.

316 -- module of original definition.

311 resolveDctor

317 resolveDctor

312− :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

318+ :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)

313 -> ProperName 'ConstructorName

319 -> ProperName 'ConstructorName

314 -> Maybe (Qualified (ProperName 'ConstructorName))

320 -> Maybe (Qualified (ProperName 'ConstructorName))

315 resolveDctor tys name =

321 resolveDctor tys name =

316− mkQualified name . snd <$> find (elem name . snd . fst) tys

322+ mkQualified name . snd <$> find (elem name . fst) tys

317

323

318 -- Update names so unqualified references become qualified, and locally

324 -- Update names so unqualified references become qualified, and locally

319 -- qualified references are replaced with their canoncial qualified names

325 -- qualified references are replaced with their canoncial qualified names

src/Language/PureScript/Sugar/Names/Env.hs+41−39

@@ -26,7 +26,7 @@ import Control.Monad.Error.Class (MonadError(..))

26import Control.Monad.Writer.Class (MonadWriter(..))

28import Data.Function (on)

29−import Data.List (groupBy, sortBy, nub, delete)

29+import Data.List (groupBy, sortBy, delete)

30import Data.Maybe (fromJust, mapMaybe)

31import qualified Data.Map as M

32import qualified Data.Set as S

@@ -92,7 +92,9 @@ data Imports = Imports

92 --

93 , importedValueOps :: ImportMap (OpName 'ValueOpName)

94 -- |

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.

96 --

98 --

97 , importedModules :: S.Set ModuleName

99 , importedModules :: S.Set ModuleName

98 -- |

100 -- |

@@ -114,37 +116,34 @@ nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.

114data Exports = Exports

116data Exports = Exports

115 {

117 {

116 -- |

118 -- |

117− -- The types exported from each module along with the module they originally

119+ -- The exported types along with the module they originally came from.

118− -- came from.

119 --

120 --

120− exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

121+ exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)

121 -- |

122 -- |

122− -- The type operators exported from each module along with the module they

123+ -- The exported type operators along with the module they originally came

123− -- originally came from.

124+ -- from.

124 --

125 --

125− , exportedTypeOps :: [(OpName 'TypeOpName, ModuleName)]

126+ , exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName

126 -- |

127 -- |

127− -- The classes exported from each module along with the module they originally

128+ -- The exported classes along with the module they originally came from.

128− -- came from.

129 --

130− , exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

130+ , exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName

131 -- |

132− -- The values exported from each module along with the module they originally

132+ -- The exported values along with the module they originally came from.

133− -- came from.

134 --

133 --

135− , exportedValues :: [(Ident, ModuleName)]

134+ , exportedValues :: M.Map Ident ModuleName

136 -- |

135 -- |

137− -- The value operators exported from each module along with the module they

136+ -- The exported value operators along with the module they originally came

138− -- originally came from.

137+ -- from.

139 --

138 --

140− , exportedValueOps :: [(OpName 'ValueOpName, ModuleName)]

139+ , exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName

141 } deriving (Show, Read)

140 } deriving (Show, Read)

142

141

143-- |

142-- |

144-- An empty 'Exports' value.

143-- An empty 'Exports' value.

145--

144--

146nullExports :: Exports

145nullExports :: Exports

147−nullExports = Exports [] [] [] [] []

146+nullExports = Exports M.empty M.empty M.empty M.empty M.empty

148

147

149-- |

148-- |

150-- The imports and exports for a collection of modules. The 'SourceSpan' is used

149-- The imports and exports for a collection of modules. The 'SourceSpan' is used

@@ -177,11 +176,11 @@ envModuleExports (_, _, exps) = exps

177primExports :: Exports

176primExports :: Exports

178primExports =

177primExports =

179 nullExports

178 nullExports

180− { exportedTypes = mkTypeEntry `map` M.keys primTypes

179+ { exportedTypes = M.fromList $ mkTypeEntry `map` M.keys primTypes

181− , exportedTypeClasses = mkClassEntry `map` M.keys primClasses

180+ , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys primClasses

182 }

181 }

183 where

182 where

184− mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn)

183+ mkTypeEntry (Qualified mn name) = (name, ([], fromJust mn))

185 mkClassEntry (Qualified mn name) = (name, fromJust mn)

184 mkClassEntry (Qualified mn name) = (name, fromJust mn)

186

185

187-- | Environment which only contains the Prim module.

186-- | Environment which only contains the Prim module.

@@ -202,20 +201,21 @@ exportType

202 -> ModuleName

201 -> ModuleName

203 -> m Exports

202 -> m Exports

204exportType exps name dctors mn = do

203exportType exps name dctors mn = do

205− let exTypes' = exportedTypes exps

204+ let exTypes = exportedTypes exps

206− let exTypes = filter ((/= mn) . snd) exTypes'

207− let exDctors = (snd . fst) `concatMap` exTypes

208 let exClasses = exportedTypeClasses exps

205 let exClasses = exportedTypeClasses exps

209− when (any ((== name) . fst . fst) exTypes) $

206+ case name `M.lookup` exTypes of

210− throwConflictError ConflictingTypeDecls name

207+ Just (_, mn') | mn /= mn' -> throwConflictError ConflictingTypeDecls name

208+ _ -> return ()

211− when (any ((== coerceProperName name) . fst) exClasses) $

209+ when (coerceProperName name `M.member` exClasses) $

212 throwConflictError TypeConflictsWithClass name

210 throwConflictError TypeConflictsWithClass name

213 forM_ dctors $ \dctor -> do

211 forM_ dctors $ \dctor -> do

214− when (dctor `elem` exDctors) $

212+ when (dctorExists (coerceProperName dctor) `any` exTypes) $

215 throwConflictError ConflictingCtorDecls dctor

213 throwConflictError ConflictingCtorDecls dctor

216− when (any ((== coerceProperName dctor) . fst) exClasses) $

214+ when (coerceProperName dctor `M.member` exClasses) $

217 throwConflictError CtorConflictsWithClass dctor

215 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'

219

220-- |

221-- Safely adds a type operator to some exports, returning an error if a

@@ -242,10 +242,9 @@ exportTypeClass

242 -> m Exports

243exportTypeClass exps name mn = do

244 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) $

247 throwConflictError ClassConflictsWithType name

246 throwConflictError ClassConflictsWithType name

248− when (coerceProperName name `elem` exDctors) $

247+ when ((elem (coerceProperName name) . fst) `any` exTypes) $

249 throwConflictError ClassConflictsWithCtor name

248 throwConflictError ClassConflictsWithCtor name

250 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)

249 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)

251 return $ exps { exportedTypeClasses = classes }

250 return $ exps { exportedTypeClasses = classes }

@@ -282,16 +281,19 @@ exportValueOp exps op mn = do

282-- case an error is returned.

281-- case an error is returned.

283--

282--

284addExport

283addExport

285− :: (MonadError MultipleErrors m, Eq a)

284+ :: (MonadError MultipleErrors m, Ord a)

286 => (a -> SimpleErrorMessage)

285 => (a -> SimpleErrorMessage)

287 -> a

286 -> a

288 -> ModuleName

287 -> ModuleName

289− -> [(a, ModuleName)]

288+ -> M.Map a ModuleName

290− -> m [(a, ModuleName)]

289+ -> m (M.Map a ModuleName)

291addExport what name mn exports =

290addExport what name mn exports =

292− if any (\(name', mn') -> name == name' && mn /= mn') exports

291+ case M.lookup name exports of

292+ Just mn'

293+ | mn == mn' -> return exports

293− then throwConflictError what name

294+ | otherwise -> throwConflictError what name

295+ Nothing ->

294− else return $ nub $ (name, mn) : exports

296+ return $ M.insert name mn exports

295

297

296-- |

298-- |

297-- Raises an error for when there is more than one definition for something.

299-- Raises an error for when there is more than one definition for something.

src/Language/PureScript/Sugar/Names/Exports.hs+36−32

@@ -10,7 +10,7 @@ import Control.Monad.Writer.Class (MonadWriter(..))

10import Control.Monad.Error.Class (MonadError(..))

12import Data.Foldable (traverse_)

13−import Data.List (find, intersect)

13+import Data.List (intersect)

14import Data.Maybe (fromMaybe, mapMaybe)

15import qualified Data.Map as M

@@ -76,11 +76,11 @@ resolveExports env ss mn imps exps refs =

76 elaborateModuleExports result (PositionedDeclarationRef pos _ r) =

77 warnAndRethrowWithPosition pos $ elaborateModuleExports result r

78 elaborateModuleExports result (ModuleRef name) | name == mn = do

79− let types' = exportedTypes result ++ exportedTypes exps

79+ let types' = exportedTypes result `M.union` exportedTypes exps

80− let typeOps' = exportedTypeOps result ++ exportedTypeOps exps

80+ let typeOps' = exportedTypeOps result `M.union` exportedTypeOps exps

81− let classes' = exportedTypeClasses result ++ exportedTypeClasses exps

81+ let classes' = exportedTypeClasses result `M.union` exportedTypeClasses exps

82− let values' = exportedValues result ++ exportedValues exps

82+ let values' = exportedValues result `M.union` exportedValues exps

83− let valueOps' = exportedValueOps result ++ exportedValueOps exps

83+ let valueOps' = exportedValueOps result `M.union` exportedValueOps exps

84 return result

85 { exportedTypes = types'

86 , exportedTypeOps = typeOps'

@@ -155,11 +155,12 @@ resolveExports env ss mn imps exps refs =

155 go

156 :: Qualified (ProperName 'TypeName)

157 -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)

158+ go (Qualified (Just mn'') name) =

158− go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do

159+ fromMaybe (internalError "Missing value in resolveTypeExports") $ do

159− exps' <- envModuleExports <$> mn'' `M.lookup` env

160+ exps' <- envModuleExports <$> mn'' `M.lookup` env

160− ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')

161+ (dctors', mnOrig) <- name `M.lookup` exportedTypes exps'

161− let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mn'' then Just dctor else Nothing) dctors

162+ let relevantDctors = mapMaybe (disqualifyFor (Just mn'')) dctors

162− return ((name, relevantDctors `intersect` dctors'), mnOrig)

163+ return ((name, relevantDctors `intersect` dctors'), mnOrig)

163 go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports"

164 go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports"

164

165

165 -- Looks up an imported type operator and re-qualifies it with the original

166 -- Looks up an imported type operator and re-qualifies it with the original

@@ -194,10 +195,14 @@ resolveExports env ss mn imps exps refs =

194 . fromMaybe (internalError "Missing value in resolveValueOp")

195 . fromMaybe (internalError "Missing value in resolveValueOp")

195 $ resolve exportedValueOps op

196 $ resolve exportedValueOps op

196

197

198+ resolve

199+ :: Ord a

197− resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a)

200+ => (Exports -> M.Map a ModuleName)

201+ -> Qualified a

202+ -> Maybe (Qualified a)

198 resolve f (Qualified (Just mn'') a) = do

203 resolve f (Qualified (Just mn'') a) = do

199 exps' <- envModuleExports <$> mn'' `M.lookup` env

204 exps' <- envModuleExports <$> mn'' `M.lookup` env

200− mn''' <- snd <$> find ((== a) . fst) (f exps')

205+ mn''' <- a `M.lookup` f exps'

201 return $ Qualified (Just mn''') a

206 return $ Qualified (Just mn''') a

202 resolve _ _ = internalError "Unqualified value in resolve"

207 resolve _ _ = internalError "Unqualified value in resolve"

203

208

@@ -219,11 +224,11 @@ filterModule

219 -> [DeclarationRef]

224 -> [DeclarationRef]

220 -> m Exports

225 -> m Exports

221filterModule mn exps refs = do

226filterModule mn exps refs = do

222− types <- foldM filterTypes [] refs

227+ types <- foldM filterTypes M.empty refs

223− typeOps <- foldM (filterExport TyOpName getTypeOpRef exportedTypeOps) [] refs

228+ typeOps <- foldM (filterExport TyOpName getTypeOpRef exportedTypeOps) M.empty refs

224− classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) [] refs

229+ classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) M.empty refs

225− values <- foldM (filterExport IdentName getValueRef exportedValues) [] refs

230+ values <- foldM (filterExport IdentName getValueRef exportedValues) M.empty refs

226− valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) [] refs

231+ valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) M.empty refs

227 return Exports

232 return Exports

228 { exportedTypes = types

233 { exportedTypes = types

229 , exportedTypeOps = typeOps

234 , exportedTypeOps = typeOps

@@ -235,21 +240,19 @@ filterModule mn exps refs = do

235 where

240 where

236

241

237 filterTypes

242 filterTypes

238− :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

243+ :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)

239 -> DeclarationRef

244 -> DeclarationRef

240− -> m [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

245+ -> m (M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName))

241 filterTypes result (PositionedDeclarationRef pos _ r) =

246 filterTypes result (PositionedDeclarationRef pos _ r) =

242 rethrowWithPosition pos $ filterTypes result r

247 rethrowWithPosition pos $ filterTypes result r

243 filterTypes result (TypeRef name expDcons) =

248 filterTypes result (TypeRef name expDcons) =

244− case matchType `find` exportedTypes exps of

249+ case name `M.lookup` exportedTypes exps of

245 Nothing -> throwError . errorMessage . UnknownExport $ TyName name

250 Nothing -> throwError . errorMessage . UnknownExport $ TyName name

246− Just ((_, dcons), _) -> do

251+ Just (dcons, _) -> do

247 let expDcons' = fromMaybe dcons expDcons

252 let expDcons' = fromMaybe dcons expDcons

248 traverse_ (checkDcon name dcons) expDcons'

253 traverse_ (checkDcon name dcons) expDcons'

249− return $ ((name, expDcons'), mn) : result

254+ return $ M.insert name (expDcons', mn) result

250 where

255 where

251− -- Finds a type declaration by matching its name and defining module

252− matchType ((name', _), mn') = name == name' && mn == mn'

253 -- Ensures a data constructor is exportable for a given type. Takes a type

256 -- Ensures a data constructor is exportable for a given type. Takes a type

254 -- name, a list of exportable data constructors for the type, and the name of

257 -- name, a list of exportable data constructors for the type, and the name of

255 -- the data constructor to check.

258 -- the data constructor to check.

@@ -264,18 +267,19 @@ filterModule mn exps refs = do

264 filterTypes result _ = return result

267 filterTypes result _ = return result

265

268

266 filterExport

269 filterExport

267− :: Eq a

270+ :: Ord a

268 => (a -> Name)

271 => (a -> Name)

269 -> (DeclarationRef -> Maybe a)

272 -> (DeclarationRef -> Maybe a)

270− -> (Exports -> [(a, ModuleName)])

273+ -> (Exports -> M.Map a ModuleName)

271− -> [(a, ModuleName)]

274+ -> M.Map a ModuleName

272 -> DeclarationRef

275 -> DeclarationRef

273− -> m [(a, ModuleName)]

276+ -> m (M.Map a ModuleName)

274 filterExport toName get fromExps result (PositionedDeclarationRef pos _ r) =

277 filterExport toName get fromExps result (PositionedDeclarationRef pos _ r) =

275 rethrowWithPosition pos $ filterExport toName get fromExps result r

278 rethrowWithPosition pos $ filterExport toName get fromExps result r

276 filterExport toName get fromExps result ref

279 filterExport toName get fromExps result ref

277 | Just name <- get ref =

280 | Just name <- get ref =

278− if (name, mn) `elem` fromExps exps

281+ case name `M.lookup` fromExps exps of

279− then return $ (name, mn) : result

282+ -- TODO: I'm not sure if we actually need to check mn == mn' here -gb

283+ Just mn' | mn == mn' -> return $ M.insert name mn result

280− else throwError . errorMessage . UnknownExport $ toName name

284+ _ -> throwError . errorMessage . UnknownExport $ toName name

281 filterExport _ _ _ result _ = return result

285 filterExport _ _ _ result _ = return result

src/Language/PureScript/Sugar/Names/Imports.hs+31−34

@@ -7,12 +7,10 @@ module Language.PureScript.Sugar.Names.Imports

8import Prelude.Compat

10−import Control.Arrow (first)

11import Control.Monad

10import Control.Monad

12import Control.Monad.Error.Class (MonadError(..))

11import Control.Monad.Error.Class (MonadError(..))

14import Data.Foldable (for_, traverse_)

13import Data.Foldable (for_, traverse_)

15−import Data.List (find)

16import Data.Maybe (fromMaybe)

14import Data.Maybe (fromMaybe)

17import qualified Data.Map as M

15import qualified Data.Map as M

18import qualified Data.Set as S

16import qualified Data.Set as S

@@ -118,30 +116,30 @@ resolveImport importModule exps imps impQual = resolveByType

118 check (PositionedDeclarationRef pos _ r) =

116 check (PositionedDeclarationRef pos _ r) =

119 rethrowWithPosition pos $ check r

117 rethrowWithPosition pos $ check r

120 check (ValueRef name) =

118 check (ValueRef name) =

121− checkImportExists IdentName (fst `map` exportedValues exps) name

119+ checkImportExists IdentName (exportedValues exps) name

122 check (ValueOpRef op) =

120 check (ValueOpRef op) =

123− checkImportExists ValOpName (fst `map` exportedValueOps exps) op

121+ checkImportExists ValOpName (exportedValueOps exps) op

124 check (TypeRef name dctors) = do

122 check (TypeRef name dctors) = do

125− checkImportExists TyName ((fst . fst) `map` exportedTypes exps) name

123+ checkImportExists TyName (exportedTypes exps) name

126− let allDctors = fst `map` allExportedDataConstructors name

124+ let (allDctors, _) = allExportedDataConstructors name

127 for_ dctors $ traverse_ (checkDctorExists name allDctors)

125 for_ dctors $ traverse_ (checkDctorExists name allDctors)

128 check (TypeOpRef name) =

126 check (TypeOpRef name) =

129− checkImportExists TyOpName (fst `map` exportedTypeOps exps) name

127+ checkImportExists TyOpName (exportedTypeOps exps) name

130 check (TypeClassRef name) =

128 check (TypeClassRef name) =

131− checkImportExists TyClassName (fst `map` exportedTypeClasses exps) name

129+ checkImportExists TyClassName (exportedTypeClasses exps) name

132 check (ModuleRef name) | isHiding =

130 check (ModuleRef name) | isHiding =

133 throwError . errorMessage $ ImportHidingModule name

131 throwError . errorMessage $ ImportHidingModule name

134 check r = internalError $ "Invalid argument to checkRefs: " ++ show r

132 check r = internalError $ "Invalid argument to checkRefs: " ++ show r

135

133

136 -- Check that an explicitly imported item exists in the module it is being imported from

134 -- Check that an explicitly imported item exists in the module it is being imported from

137 checkImportExists

135 checkImportExists

138− :: Eq a

136+ :: Ord a

139 => (a -> Name)

137 => (a -> Name)

140− -> [a]

138+ -> M.Map a b

141 -> a

139 -> a

142 -> m ()

140 -> m ()

143 checkImportExists toName exports item

141 checkImportExists toName exports item

144− = when (item `notElem` exports)

142+ = when (item `M.notMember` exports)

145 . throwError . errorMessage

143 . throwError . errorMessage

146 $ UnknownImport importModule (toName item)

144 $ UnknownImport importModule (toName item)

147

145

@@ -177,35 +175,34 @@ resolveImport importModule exps imps impQual = resolveByType

177 -- Import all symbols

175 -- Import all symbols

178 importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports

176 importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports

179 importAll importer =

177 importAll importer =

180− foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)

178+ foldM (\m (name, (dctors, _)) -> importer m (TypeRef name (Just dctors))) imps (M.toList (exportedTypes exps))

181− >>= flip (foldM (\m (name, _) -> importer m (TypeOpRef name))) (exportedTypeOps exps)

179+ >>= flip (foldM (\m (name, _) -> importer m (TypeOpRef name))) (M.toList (exportedTypeOps exps))

182− >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (exportedValues exps)

180+ >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (M.toList (exportedValues exps))

183− >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (exportedValueOps exps)

181+ >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (M.toList (exportedValueOps exps))

184− >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (exportedTypeClasses exps)

182+ >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (M.toList (exportedTypeClasses exps))

185

183

186 importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports

184 importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports

187 importRef prov imp (PositionedDeclarationRef pos _ r) =

185 importRef prov imp (PositionedDeclarationRef pos _ r) =

188 rethrowWithPosition pos $ importRef prov imp r

186 rethrowWithPosition pos $ importRef prov imp r

189 importRef prov imp (ValueRef name) = do

187 importRef prov imp (ValueRef name) = do

190− let values' = updateImports (importedValues imp) (exportedValues exps) name prov

188+ let values' = updateImports (importedValues imp) (exportedValues exps) id name prov

191 return $ imp { importedValues = values' }

189 return $ imp { importedValues = values' }

192 importRef prov imp (ValueOpRef name) = do

190 importRef prov imp (ValueOpRef name) = do

193− let valueOps' = updateImports (importedValueOps imp) (exportedValueOps exps) name prov

191+ let valueOps' = updateImports (importedValueOps imp) (exportedValueOps exps) id name prov

194 return $ imp { importedValueOps = valueOps' }

192 return $ imp { importedValueOps = valueOps' }

195 importRef prov imp (TypeRef name dctors) = do

193 importRef prov imp (TypeRef name dctors) = do

196− let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name prov

194+ let types' = updateImports (importedTypes imp) (exportedTypes exps) snd name prov

195+ let (dctorNames, mn) = allExportedDataConstructors name

197− let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)]

196+ dctorLookup :: M.Map (ProperName 'ConstructorName) ModuleName

198− exportedDctors = allExportedDataConstructors name

197+ dctorLookup = M.fromList $ map (, mn) dctorNames

199− dctorNames :: [ProperName 'ConstructorName]

200− dctorNames = fst `map` exportedDctors

201− maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

198+ traverse_ (traverse_ $ checkDctorExists name dctorNames) dctors

202− let dctors' = foldl (\m d -> updateImports m exportedDctors d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors)

199+ let dctors' = foldl (\m d -> updateImports m dctorLookup id d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors)

203 return $ imp { importedTypes = types', importedDataConstructors = dctors' }

200 return $ imp { importedTypes = types', importedDataConstructors = dctors' }

204 importRef prov imp (TypeOpRef name) = do

201 importRef prov imp (TypeOpRef name) = do

205− let ops' = updateImports (importedTypeOps imp) (exportedTypeOps exps) name prov

202+ let ops' = updateImports (importedTypeOps imp) (exportedTypeOps exps) id name prov

206 return $ imp { importedTypeOps = ops' }

203 return $ imp { importedTypeOps = ops' }

207 importRef prov imp (TypeClassRef name) = do

204 importRef prov imp (TypeClassRef name) = do

208− let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov

205+ let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) id name prov

209 return $ imp { importedTypeClasses = typeClasses' }

206 return $ imp { importedTypeClasses = typeClasses' }

210 importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef"

207 importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef"

211 importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef"

208 importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef"

@@ -213,23 +210,23 @@ resolveImport importModule exps imps impQual = resolveByType

213 -- Find all exported data constructors for a given type

210 -- Find all exported data constructors for a given type

214 allExportedDataConstructors

211 allExportedDataConstructors

215 :: ProperName 'TypeName

212 :: ProperName 'TypeName

216− -> [(ProperName 'ConstructorName, ModuleName)]

213+ -> ([ProperName 'ConstructorName], ModuleName)

217 allExportedDataConstructors name =

214 allExportedDataConstructors name =

218− case find ((== name) . fst . fst) (exportedTypes exps) of

219− Nothing -> internalError "Invalid state in allExportedDataConstructors"

215+ fromMaybe (internalError "Invalid state in allExportedDataConstructors")

220− Just ((_, dctors), mn) -> map (, mn) dctors

216+ $ name `M.lookup` exportedTypes exps

221

217

222 -- Add something to an import resolution list

218 -- Add something to an import resolution list

223 updateImports

219 updateImports

224 :: (Ord a)

220 :: (Ord a)

225 => M.Map (Qualified a) [ImportRecord a]

221 => M.Map (Qualified a) [ImportRecord a]

222+ -> M.Map a b

226− -> [(a, ModuleName)]

223+ -> (b -> ModuleName)

227 -> a

224 -> a

228 -> ImportProvenance

225 -> ImportProvenance

229 -> M.Map (Qualified a) [ImportRecord a]

226 -> M.Map (Qualified a) [ImportRecord a]

230− updateImports imps' exps' name prov =

227+ updateImports imps' exps' expName name prov =

231 let

228 let

232− mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')

229+ mnOrig = maybe (internalError "Invalid state in updateImports") expName (name `M.lookup` exps')

233 rec = ImportRecord (Qualified (Just importModule) name) mnOrig prov

230 rec = ImportRecord (Qualified (Just importModule) name) mnOrig prov

234 in

231 in

235 M.alter

232 M.alter