e20d299 · rowtype-yoga/purescript-native

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

on golang help sign in

Delay errors about scope conflicts until they are unavoidable

e20d299Gary Burgess11 years ago

examples/failing/ConflictingExports.pursnew file+16

compare with golang

unifiedsplit

@@ -0,0 +1,16 @@

1+-- @shouldFailWith ScopeConflict

2+module A where

4+ thing :: Int

5+ thing = 1

7+module B where

9+ thing :: Int

10+ thing = 2

11+

12+-- Fails here because re-exporting forces any scope conflicts to be resolved

13+module Main (module A, module B) where

14+

15+ import A

16+ import B

examples/failing/ConflictingExports2.pursnew file+13

@@ -0,0 +1,13 @@

1+-- @shouldFailWith ScopeConflict

2+module A where

4+ thing :: Int

5+ thing = 1

7+-- Fails here because re-exporting forces any scope conflicts to be resolved

8+module Main (thing, module A) where

10+ import A

11+

12+ thing :: Int

13+ thing = 2

examples/failing/ConflictingImports.pursnew file+19

@@ -0,0 +1,19 @@

1+-- @shouldFailWith ScopeConflict

2+module A where

4+ thing :: Int

5+ thing = 1

7+module B where

9+ thing :: Int

10+ thing = 2

11+

12+module Main where

13+

14+ import A

15+ import B

16+

17+ -- Error due to referencing `thing` which is in scope as A.thing and B.thing

18+ what :: Int

19+ what = thing

examples/failing/ConflictingImports2.pursnew file+16

@@ -0,0 +1,16 @@

1+-- @shouldFailWith ScopeConflict

2+module A where

4+ thing :: Int

5+ thing = 1

7+module Main where

9+ import A

10+

11+ thing :: Int

12+ thing = 2

13+

14+ -- Error due to referencing `thing` which is in scope as A.thing and Main.thing

15+ what :: Int

16+ what = thing

examples/passing/NonConflictingExports.pursnew file+14

@@ -0,0 +1,14 @@

1+module A where

3+ thing :: Int

4+ thing = 1

6+-- No failure here as the export `thing` only refers to Main.thing

7+module Main (thing, main) where

9+ import A

10+

11+ thing :: Int

12+ thing = 2

13+

14+ main = Control.Monad.Eff.Console.log "Done"

examples/passing/PendingConflictingImports.pursnew file+17

@@ -0,0 +1,17 @@

1+module A where

3+ thing :: Int

4+ thing = 1

6+module B where

8+ thing :: Int

9+ thing = 2

10+

11+module Main where

12+

13+ -- No error as we never force `thing` to be resolved in `Main`

14+ import A

15+ import B

16+

17+ main = Control.Monad.Eff.Console.log "Done"

examples/passing/PendingConflictingImports2.pursnew file+14

@@ -0,0 +1,14 @@

1+module A where

3+ thing :: Int

4+ thing = 1

6+module Main where

8+ import A

10+ -- No error as we never force `thing` to be resolved in `Main`

11+ thing :: Int

12+ thing = 2

13+

14+ main = Control.Monad.Eff.Console.log "Done"

src/Language/PureScript/Errors.hs+5−10

@@ -67,8 +67,7 @@ data SimpleErrorMessage

67 | UnknownExportModule ModuleName

68 | UnknownImportDataConstructor ModuleName ProperName ProperName

69 | UnknownExportDataConstructor ProperName ProperName

70− | ConflictingImport String ModuleName

71− | ConflictingImports String ModuleName ModuleName

70+ | ScopeConflict String [ModuleName]

72 | ConflictingTypeDecls ProperName

71 | ConflictingTypeDecls ProperName

73 | ConflictingCtorDecls ProperName

72 | ConflictingCtorDecls ProperName

74 | TypeConflictsWithClass ProperName

73 | TypeConflictsWithClass ProperName

@@ -212,8 +211,7 @@ errorCode em = case unwrapErrorMessage em of

212 UnknownExportModule{} -> "UnknownExportModule"

211 UnknownExportModule{} -> "UnknownExportModule"

213 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"

212 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"

214 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"

213 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"

215− ConflictingImport{} -> "ConflictingImport"

214+ ScopeConflict{} -> "ScopeConflict"

216− ConflictingImports{} -> "ConflictingImports"

217 ConflictingTypeDecls{} -> "ConflictingTypeDecls"

215 ConflictingTypeDecls{} -> "ConflictingTypeDecls"

218 ConflictingCtorDecls{} -> "ConflictingCtorDecls"

216 ConflictingCtorDecls{} -> "ConflictingCtorDecls"

219 TypeConflictsWithClass{} -> "TypeConflictsWithClass"

217 TypeConflictsWithClass{} -> "TypeConflictsWithClass"

@@ -524,13 +522,10 @@ prettyPrintSingleError full level e = do

524 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon

522 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon

525 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

523 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

526 line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared."

524 line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared."

527− renderSimpleErrorMessage (ConflictingImport nm mn) =

525+ renderSimpleErrorMessage (ScopeConflict nm ms) =

528− paras [ line $ "Cannot declare " ++ show nm ++ ", since another declaration of that name was imported from module " ++ runModuleName mn

526+ paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:"

529− , line $ "Consider hiding " ++ show nm ++ " when importing " ++ runModuleName mn ++ ":"

530− , indent . line $ "import " ++ runModuleName mn ++ " hiding (" ++ nm ++ ")"

527+ , indent $ paras $ map (line . runModuleName) ms

531 ]

528 ]

532− renderSimpleErrorMessage (ConflictingImports nm m1 m2) =

533− line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2

534 renderSimpleErrorMessage (ConflictingTypeDecls nm) =

529 renderSimpleErrorMessage (ConflictingTypeDecls nm) =

535 line $ "Conflicting type declarations for " ++ runProperName nm

530 line $ "Conflicting type declarations for " ++ runProperName nm

536 renderSimpleErrorMessage (ConflictingCtorDecls nm) =

531 renderSimpleErrorMessage (ConflictingCtorDecls nm) =

src/Language/PureScript/Sugar/Names.hs+26−19

@@ -50,7 +50,7 @@ desugarImports externs modules = do

50 ss = internalModuleSourceSpan "<Externs>"

51 env' = M.insert efModuleName (ss, nullImports, members) env

52 fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, mt, qmn)])

53− imps <- foldM (resolveModuleImport efModuleName env') nullImports (map fromEFImport efImports)

53+ imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports)

54 exps <- resolveExports env' efModuleName imps members efExports

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

56 where

@@ -197,16 +197,16 @@ renameInModule env imports (Module ss coms mn decls exps) =

197 updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts)

198

199 updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

200− updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TypeName

200+ updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TypeName (("type " ++) . runProperName)

201

202 updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

203− updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName

203+ updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName)

204

205 updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

206− updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) ClassName

206+ updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) ClassName (("class " ++) . runProperName)

207

208 updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

209− updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName

209+ updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent)

210

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

212 -- module of original definition.

@@ -226,25 +226,30 @@ renameInModule env imports (Module ss coms mn decls exps) =

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

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

228 -- (e.g. M.Map -> Data.Map.Map).

229+ update

230+ :: (Ord a, Show a)

229− update :: (Ord a) => (Qualified a -> SimpleErrorMessage)

231+ => (Qualified a -> SimpleErrorMessage)

230− -> M.Map (Qualified a) (Qualified a, ModuleName)

232+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]

231− -> (Exports -> a -> Maybe (Qualified a))

233+ -> (Exports -> a -> Maybe (Qualified a))

232− -> (Qualified a -> Name)

234+ -> (Qualified a -> Name)

235+ -> (a -> String)

233− -> Qualified a

236+ -> Qualified a

234− -> Maybe SourceSpan

237+ -> Maybe SourceSpan

235− -> m (Qualified a)

238+ -> m (Qualified a)

236− update unknown imps getE toName qname@(Qualified mn' name) pos = positioned $

239+ update unknown imps getE toName render qname@(Qualified mn' name) pos = positioned $

237 case (M.lookup qname imps, mn') of

240 case (M.lookup qname imps, mn') of

241+

238 -- We found the name in our imports, so we return the name for it,

242 -- We found the name in our imports, so we return the name for it,

239 -- qualifying with the name of the module it was originally defined in

243 -- qualifying with the name of the module it was originally defined in

240 -- rather than the module we're importing from, to handle the case of

244 -- rather than the module we're importing from, to handle the case of

241− -- re-exports.

245+ -- re-exports. If there are multiple options for the name to resolve to

246+ -- in scope, we throw an error.

242− (Just (qn, mnOrig), _) -> do

247+ (Just options, _) -> do

243− case qn of

248+ checkImportConflicts render options

244− Qualified (Just mnNew) _ ->

249+ let (Qualified (Just mnNew) _, mnOrig) = head options

245− modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result

250+ modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result

246− _ -> return ()

247 return $ Qualified (Just mnOrig) name

251 return $ Qualified (Just mnOrig) name

252+

248 -- If the name wasn't found in our imports but was qualified then we need

253 -- If the name wasn't found in our imports but was qualified then we need

249 -- to check whether it's a failed import from a "pseudo" module (created

254 -- to check whether it's a failed import from a "pseudo" module (created

250 -- by qualified importing). If that's not the case, then we just need to

255 -- by qualified importing). If that's not the case, then we just need to

@@ -252,9 +257,11 @@ renameInModule env imports (Module ss coms mn decls exps) =

252 (Nothing, Just mn'') -> do

257 (Nothing, Just mn'') -> do

253 modExports <- getExports env mn''

258 modExports <- getExports env mn''

254 maybe (throwError . errorMessage $ unknown qname) return (getE modExports name)

259 maybe (throwError . errorMessage $ unknown qname) return (getE modExports name)

260+

255 -- If neither of the above cases are true then it's an undefined or

261 -- If neither of the above cases are true then it's an undefined or

256 -- unimported symbol.

262 -- unimported symbol.

257 _ -> throwError . errorMessage $ unknown qname

263 _ -> throwError . errorMessage $ unknown qname

264+

258 where

265 where

259 positioned err = case pos of

266 positioned err = case pos of

260 Nothing -> err

267 Nothing -> err

src/Language/PureScript/Sugar/Names/Env.hs+40−10

@@ -1,4 +1,5 @@

1{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3module Language.PureScript.Sugar.Names.Env

4module Language.PureScript.Sugar.Names.Env

4 ( Imports(..)

5 ( Imports(..)

@@ -14,14 +15,18 @@ module Language.PureScript.Sugar.Names.Env

14 , exportTypeClass

15 , exportTypeClass

15 , exportValue

16 , exportValue

16 , getExports

17 , getExports

18+ , checkImportConflicts

17 ) where

19 ) where

21+import Data.Function (on)

22+import Data.List (groupBy, sortBy, nub)

19import qualified Data.Map as M

23import qualified Data.Map as M

21import Control.Monad

25import Control.Monad

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

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

24import Language.PureScript.AST

28import Language.PureScript.AST

29+import Language.PureScript.Crash

25import Language.PureScript.Names

30import Language.PureScript.Names

26import Language.PureScript.Environment

31import Language.PureScript.Environment

27import Language.PureScript.Errors

32import Language.PureScript.Errors

@@ -34,19 +39,19 @@ data Imports = Imports

34 -- |

39 -- |

35 -- Local names for types within a module mapped to to their qualified names

40 -- Local names for types within a module mapped to to their qualified names

36 --

41 --

37− importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)

42+ importedTypes :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

38 -- |

43 -- |

39 -- Local names for data constructors within a module mapped to to their qualified names

44 -- Local names for data constructors within a module mapped to to their qualified names

40 --

45 --

41− , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)

46+ , importedDataConstructors :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

42 -- |

47 -- |

43 -- Local names for classes within a module mapped to to their qualified names

48 -- Local names for classes within a module mapped to to their qualified names

44 --

49 --

45− , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)

50+ , importedTypeClasses :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

46 -- |

51 -- |

47 -- Local names for values within a module mapped to to their qualified names

52 -- Local names for values within a module mapped to to their qualified names

48 --

53 --

49− , importedValues :: M.Map (Qualified Ident) (Qualified Ident, ModuleName)

54+ , importedValues :: M.Map (Qualified Ident) [(Qualified Ident, ModuleName)]

50 -- |

55 -- |

51 -- The list of modules that have been imported into the current scope.

56 -- The list of modules that have been imported into the current scope.

52 --

57 --

@@ -132,15 +137,17 @@ primEnv = M.singleton

132--

137--

133exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports

138exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports

134exportType exps name dctors mn = do

139exportType exps name dctors mn = do

135− let exTypes = exportedTypes exps

140+ let exTypes' = exportedTypes exps

141+ let exTypes = filter ((/= mn) . snd) exTypes'

136 let exDctors = (snd . fst) `concatMap` exTypes

142 let exDctors = (snd . fst) `concatMap` exTypes

137 let exClasses = exportedTypeClasses exps

143 let exClasses = exportedTypeClasses exps

144+

138− when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ConflictingTypeDecls name

145+ when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name

139 when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name

146 when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name

140 forM_ dctors $ \dctor -> do

147 forM_ dctors $ \dctor -> do

141 when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

148 when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

142 when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor

149 when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor

143− return $ exps { exportedTypes = ((name, dctors), mn) : exTypes }

150+ return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }

144

151

145-- |

152-- |

146-- Safely adds a class to some exports, returning an error if a conflict occurs.

153-- Safely adds a class to some exports, returning an error if a conflict occurs.

@@ -149,7 +156,7 @@ exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName -> Mod

149exportTypeClass exps name mn = do

156exportTypeClass exps name mn = do

150 let exTypes = exportedTypes exps

157 let exTypes = exportedTypes exps

151 let exDctors = (snd . fst) `concatMap` exTypes

158 let exDctors = (snd . fst) `concatMap` exTypes

152− when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ClassConflictsWithType name

159+ when (any ((== name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name

153 when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

160 when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

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

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

155 return $ exps { exportedTypeClasses = classes }

162 return $ exps { exportedTypeClasses = classes }

@@ -168,9 +175,9 @@ exportValue exps name mn = do

168--

175--

169addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]

176addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]

170addExport what name mn exports =

177addExport what name mn exports =

171− if any ((== name) . fst) exports

178+ if any (\(name', mn') -> name == name' && mn /= mn') exports

172 then throwConflictError what name

179 then throwConflictError what name

173− else return $ (name, mn) : exports

180+ else return $ nub $ (name, mn) : exports

174

181

175-- |

182-- |

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

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

@@ -181,3 +188,26 @@ throwConflictError conflict = throwError . errorMessage . conflict

181-- Gets the exports for a module, or an error message if the module doesn't exist

188-- Gets the exports for a module, or an error message if the module doesn't exist

182getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports

189getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports

183getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env

190getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env

191+

192+-- |

193+-- When reading a value from the imports, check that there are no conflicts in

194+-- scope.

195+--

196+checkImportConflicts

197+ :: forall m a

198+ . (MonadError MultipleErrors m, Ord a)

199+ => (a -> String)

200+ -> [(Qualified a, ModuleName)]

201+ -> m ()

202+checkImportConflicts render xs =

203+ let byOrig = groupBy ((==) `on` snd) . sortBy (compare `on` snd) $ xs

204+ in

205+ if length byOrig > 1

206+ then throwError . errorMessage $ ScopeConflict (render' (fst . head $ xs)) (map (getQual . fst . head) byOrig)

207+ else return ()

208+ where

209+ getQual :: Qualified a -> ModuleName

210+ getQual (Qualified (Just mn) _) = mn

211+ getQual _ = internalError "unexpected unqualified name in checkImportConflicts"

212+ render' :: Qualified a -> String

213+ render' (Qualified _ a) = render a

src/Language/PureScript/Sugar/Names/Exports.hs+20−22

@@ -1,16 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Sugar.Names.Exports

4−-- License : MIT (http://opensource.org/licenses/MIT)

5−--

6−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

7−-- Stability : experimental

8−-- Portability :

9−--

10−-- |

11−--

12−-----------------------------------------------------------------------------

13−

14{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

15{-# LANGUAGE RankNTypes #-}

2{-# LANGUAGE RankNTypes #-}

16{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

@@ -110,20 +97,31 @@ resolveExports env mn imps exps refs =

110 let isPseudo = isPseudoModule name

97 let isPseudo = isPseudoModule name

111 when (not isPseudo && not (isImportedModule name)) $

98 when (not isPseudo && not (isImportedModule name)) $

112 throwError . errorMessage . UnknownExportModule $ name

99 throwError . errorMessage . UnknownExportModule $ name

113− let reTypes = extract isPseudo name (importedTypes imps)

100+ reTypes <- extract isPseudo name (("type " ++) . runProperName) (importedTypes imps)

114− let reDctors = extract isPseudo name (importedDataConstructors imps)

101+ reDctors <- extract isPseudo name (("data constructor " ++) . runProperName) (importedDataConstructors imps)

115− let reClasses = extract isPseudo name (importedTypeClasses imps)

102+ reClasses <- extract isPseudo name (("class " ++) . runProperName) (importedTypeClasses imps)

116− let reValues = extract isPseudo name (importedValues imps)

103+ reValues <- extract isPseudo name (("value " ++) . runIdent) (importedValues imps)

117 result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)

104 result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)

118 result'' <- foldM (uncurry . exportTypeClass) result' (map resolveClass reClasses)

105 result'' <- foldM (uncurry . exportTypeClass) result' (map resolveClass reClasses)

119 foldM (uncurry . exportValue) result'' (map resolveValue reValues)

106 foldM (uncurry . exportValue) result'' (map resolveValue reValues)

120 elaborateModuleExports result _ = return result

107 elaborateModuleExports result _ = return result

121

108

122 -- Extracts a list of values for a module based on a lookup table. If the

109 -- Extracts a list of values for a module based on a lookup table. If the

123− -- boolean is true the values are filtered by the qualification of the

110+ -- boolean is true the values are filtered by the qualification

111+ extract

112+ :: (Ord a)

113+ => Bool

114+ -> ModuleName

115+ -> (a -> String)

124− extract :: Bool -> ModuleName -> M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]

116+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]

125− extract True name = map fst . M.elems . M.filterWithKey (\k _ -> eqQual name k)

117+ -> m [Qualified a]

126− extract False name = map fst . M.elems . M.filter (eqQual name . fst)

118+ extract useQual name render = fmap (map (fst . head . snd)) . go useQual . M.toList

119+ where

120+ go True = filterM (return . eqQual name . fst)

121+ go False = filterM $ \(_, options) -> do

122+ let isMatch = any (eqQual name . fst) options

123+ when (length options > 1) $ checkImportConflicts render options

124+ return isMatch

127

125

128 -- Check whether a module name refers to a "pseudo module" that came into

126 -- Check whether a module name refers to a "pseudo module" that came into

129 -- existence in an import scope due to importing one or more modules as

127 -- existence in an import scope due to importing one or more modules as

@@ -135,7 +133,7 @@ resolveExports env mn imps exps refs =

135 -- function to either extract the keys or values. We test the keys to see if a

133 -- function to either extract the keys or values. We test the keys to see if a

136 -- value being re-exported belongs to a qualified module, and we test the

134 -- value being re-exported belongs to a qualified module, and we test the

137 -- values if that fails to see whether the value has been imported at all.

135 -- values if that fails to see whether the value has been imported at all.

138− testQuals :: (forall a. M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]) -> ModuleName -> Bool

136+ testQuals :: (forall a b. M.Map (Qualified a) b -> [Qualified a]) -> ModuleName -> Bool

139 testQuals f mn' = any (eqQual mn') (f (importedTypes imps))

137 testQuals f mn' = any (eqQual mn') (f (importedTypes imps))

140 || any (eqQual mn') (f (importedDataConstructors imps))

138 || any (eqQual mn') (f (importedDataConstructors imps))

141 || any (eqQual mn') (f (importedTypeClasses imps))

139 || any (eqQual mn') (f (importedTypeClasses imps))

src/Language/PureScript/Sugar/Names/Imports.hs+16−37

@@ -99,7 +99,7 @@ resolveImports env (Module ss coms currentModule decls exps) =

99 return ()

100

101 let scope = M.insert currentModule [(Nothing, Implicit True, Nothing)] imports

102− resolved <- foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)

102+ resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope)

103 return (Module ss coms currentModule decls' exps, resolved)

104

105 where

@@ -159,18 +159,17 @@ resolveImports env (Module ss coms currentModule decls exps) =

159resolveModuleImport

160 :: forall m

161 . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

162− => ModuleName

163− -> Env

162+ => Env

164 -> Imports

163 -> Imports

165 -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

164 -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

166 -> m Imports

165 -> m Imports

167−resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps

166+resolveModuleImport env ie (mn, imps) = foldM go ie imps

168 where

167 where

169 go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports

168 go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports

170 go ie' (pos, typ, impQual) = do

169 go ie' (pos, typ, impQual) = do

171 modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env

170 modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env

172 let ie'' = ie' { importedModules = mn : importedModules ie' }

171 let ie'' = ie' { importedModules = mn : importedModules ie' }

173− positioned $ resolveImport currentModule mn modExports ie'' impQual typ

172+ positioned $ resolveImport mn modExports ie'' impQual typ

174 where

173 where

175 positioned err = case pos of

174 positioned err = case pos of

176 Nothing -> err

175 Nothing -> err

@@ -183,13 +182,12 @@ resolveImport

183 :: forall m

182 :: forall m

184 . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

183 . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

185 => ModuleName

184 => ModuleName

186− -> ModuleName

187 -> Exports

185 -> Exports

188 -> Imports

186 -> Imports

189 -> Maybe ModuleName

187 -> Maybe ModuleName

190 -> ImportDeclarationType

188 -> ImportDeclarationType

191 -> m Imports

189 -> m Imports

192−resolveImport currentModule importModule exps imps impQual = resolveByType

190+resolveImport importModule exps imps impQual = resolveByType

193 where

191 where

194

192

195 resolveByType :: ImportDeclarationType -> m Imports

193 resolveByType :: ImportDeclarationType -> m Imports

@@ -262,20 +260,20 @@ resolveImport currentModule importModule exps imps impQual = resolveByType

262 importExplicit imp (PositionedDeclarationRef pos _ r) =

260 importExplicit imp (PositionedDeclarationRef pos _ r) =

263 warnAndRethrowWithPosition pos $ importExplicit imp r

261 warnAndRethrowWithPosition pos $ importExplicit imp r

264 importExplicit imp (ValueRef name) = do

262 importExplicit imp (ValueRef name) = do

265− values' <- updateImports (importedValues imp) showIdent (exportedValues exps) name

263+ let values' = updateImports (importedValues imp) (exportedValues exps) name

266 return $ imp { importedValues = values' }

264 return $ imp { importedValues = values' }

267 importExplicit imp (TypeRef name dctors) = do

265 importExplicit imp (TypeRef name dctors) = do

268− types' <- updateImports (importedTypes imp) runProperName (first fst `map` exportedTypes exps) name

266+ let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name

269 let exportedDctors :: [(ProperName, ModuleName)]

267 let exportedDctors :: [(ProperName, ModuleName)]

270 exportedDctors = allExportedDataConstructors name

268 exportedDctors = allExportedDataConstructors name

271 dctorNames :: [ProperName]

269 dctorNames :: [ProperName]

272 dctorNames = fst `map` exportedDctors

270 dctorNames = fst `map` exportedDctors

273 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

271 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

274 when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

272 when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

275− dctors' <- foldM (\m -> updateImports m runProperName exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)

273+ let dctors' = foldl (\m -> updateImports m exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)

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

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

277 importExplicit imp (TypeClassRef name) = do

275 importExplicit imp (TypeClassRef name) = do

278− typeClasses' <- updateImports (importedTypeClasses imp) runProperName (exportedTypeClasses exps) name

276+ let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name

279 return $ imp { importedTypeClasses = typeClasses' }

277 return $ imp { importedTypeClasses = typeClasses' }

280 importExplicit _ _ = internalError "Invalid argument to importExplicit"

278 importExplicit _ _ = internalError "Invalid argument to importExplicit"

281

279

@@ -286,33 +284,14 @@ resolveImport currentModule importModule exps imps impQual = resolveByType

286 Nothing -> internalError "Invalid state in allExportedDataConstructors"

284 Nothing -> internalError "Invalid state in allExportedDataConstructors"

287 Just ((_, dctors), mn) -> map (, mn) dctors

285 Just ((_, dctors), mn) -> map (, mn) dctors

288

286

289− -- Add something to the Imports if it does not already exist there

287+ -- Add something to an import resolution list

290 updateImports

288 updateImports

291 :: (Ord a)

289 :: (Ord a)

292− => M.Map (Qualified a) (Qualified a, ModuleName)

290+ => M.Map (Qualified a) [(Qualified a, ModuleName)]

293− -> (a -> String)

294 -> [(a, ModuleName)]

291 -> [(a, ModuleName)]

295 -> a

292 -> a

296− -> m (M.Map (Qualified a) (Qualified a, ModuleName))

293+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]

297− updateImports imps' render exps' name = case M.lookup (Qualified impQual name) imps' of

294+ updateImports imps' exps' name =

298−

299− -- If the name is not already present add it to the list, after looking up

300− -- where it was originally defined

301− Nothing ->

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

295+ let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')

296+ currNames = fromMaybe [] (M.lookup (Qualified impQual name) imps')

303− in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) imps'

297+ in M.insert (Qualified impQual name) ((Qualified (Just importModule) name, mnOrig) : currNames) imps'

304−

305− -- If the name already is present check whether it's a duplicate import

306− -- before rejecting it. For example, if module A defines X, and module B

307− -- re-exports A, importing A and B in C should not result in a "conflicting

308− -- import for `x`" error

309− Just (Qualified (Just mn) _, mnOrig)

310− | mnOrig == fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') -> return imps'

311− | otherwise -> throwError . errorMessage $ err

312− where

313− err = if currentModule `elem` [mn, importModule]

314− then ConflictingImport (render name) importModule

315− else ConflictingImports (render name) mn importModule

316−

317− Just (Qualified Nothing _, _) ->

318− internalError "Invalid state in updateImports"