dd66f58 · rowtype-yoga/purescript-native

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

Merge pull request #1688 from purescript/lazy-conflicts

Delay errors about scope conflicts until they are unavoidable

commitdd66f5849322cd0cb80d454e949a240310786e5c authorGary Burgess <gary.burgess@gmail.com> dateSat 12 Dec 2015, 00:14 (11 years ago) parentf5548b1 6492c77

14 files changed+247−98

compare with golang

unifiedsplit

examples/failing/ConflictingExports.purs+16 examples/failing/ConflictingExports2.purs+13 examples/failing/ConflictingImports.purs+19 examples/failing/ConflictingImports2.purs+16 examples/failing/ConflictingQualifiedImports.purs+17 examples/failing/ConflictingQualifiedImports2.purs+15 examples/passing/NonConflictingExports.purs+14 examples/passing/PendingConflictingImports.purs+17 examples/passing/PendingConflictingImports2.purs+14 src/Language/PureScript/Errors.hs+5−10 src/Language/PureScript/Sugar/Names.hs+26−19 src/Language/PureScript/Sugar/Names/Env.hs+40−10 src/Language/PureScript/Sugar/Names/Exports.hs+19−22 src/Language/PureScript/Sugar/Names/Imports.hs+16−37

examples/failing/ConflictingExports.pursnew file+16

@@ -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/failing/ConflictingQualifiedImports.pursnew file+17

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

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 as X

15+ import B as X

16+

17+ foo = X.thing

examples/failing/ConflictingQualifiedImports2.pursnew file+15

@@ -0,0 +1,15 @@

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 (module X) where

13+

14+ import A as X

15+ import B as X

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

6767 | UnknownExportModule ModuleName

6868 | UnknownImportDataConstructor ModuleName ProperName ProperName

6969 | UnknownExportDataConstructor ProperName ProperName

70− | ConflictingImport String ModuleName

71− | ConflictingImports String ModuleName ModuleName

70+ | ScopeConflict String [ModuleName]

7271 | ConflictingTypeDecls ProperName

7372 | ConflictingCtorDecls ProperName

7473 | TypeConflictsWithClass ProperName

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

212211 UnknownExportModule{} -> "UnknownExportModule"

213212 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"

214213 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"

215− ConflictingImport{} -> "ConflictingImport"

216− ConflictingImports{} -> "ConflictingImports"

214+ ScopeConflict{} -> "ScopeConflict"

217215 ConflictingTypeDecls{} -> "ConflictingTypeDecls"

218216 ConflictingCtorDecls{} -> "ConflictingCtorDecls"

219217 TypeConflictsWithClass{} -> "TypeConflictsWithClass"

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

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

525523 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

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

527− renderSimpleErrorMessage (ConflictingImport nm mn) =

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

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

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

525+ renderSimpleErrorMessage (ScopeConflict nm ms) =

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

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

531528 ]

532− renderSimpleErrorMessage (ConflictingImports nm m1 m2) =

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

534529 renderSimpleErrorMessage (ConflictingTypeDecls nm) =

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

536531 renderSimpleErrorMessage (ConflictingCtorDecls nm) =

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

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

5050 ss = internalModuleSourceSpan "<Externs>"

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

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

5454 exps <- resolveExports env' efModuleName imps members efExports

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

5656 where

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

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

198198

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

201201

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

204204

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

207207

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

210210

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

212212 -- module of original definition.

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

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

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

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

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

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

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

232− -> (Qualified a -> Name)

233− -> Qualified a

234− -> Maybe SourceSpan

235− -> m (Qualified a)

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

229+ update

230+ :: (Ord a, Show a)

231+ => (Qualified a -> SimpleErrorMessage)

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

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

234+ -> (Qualified a -> Name)

235+ -> (a -> String)

236+ -> Qualified a

237+ -> Maybe SourceSpan

238+ -> m (Qualified a)

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

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

241+

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

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

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

241− -- re-exports.

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

243− case qn of

244− Qualified (Just mnNew) _ ->

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

246− _ -> return ()

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

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

247+ (Just options, _) -> do

248+ checkImportConflicts render options

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

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

247251 return $ Qualified (Just mnOrig) name

252+

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

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

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

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

253258 modExports <- getExports env mn''

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

260+

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

256262 -- unimported symbol.

257263 _ -> throwError . errorMessage $ unknown qname

264+

258265 where

259266 positioned err = case pos of

260267 Nothing -> err

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

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

11{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

34module Language.PureScript.Sugar.Names.Env

45 ( Imports(..)

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

1415 , exportTypeClass

1516 , exportValue

1617 , getExports

18+ , checkImportConflicts

1719 ) where

1820

21+import Data.Function (on)

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

1923import qualified Data.Map as M

2024

2125import Control.Monad

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

2327

2428import Language.PureScript.AST

29+import Language.PureScript.Crash

2530import Language.PureScript.Names

2631import Language.PureScript.Environment

2732import Language.PureScript.Errors

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

3439 -- |

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

3641 --

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

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

3843 -- |

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

4045 --

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

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

4247 -- |

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

4449 --

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

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

4651 -- |

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

4853 --

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

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

5055 -- |

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

5257 --

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

132137--

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

134139exportType exps name dctors mn = do

135− let exTypes = exportedTypes exps

140+ let exTypes' = exportedTypes exps

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

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

137143 let exClasses = exportedTypeClasses exps

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

144+

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

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

140147 forM_ dctors $ \dctor -> do

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

142149 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' }

144151

145152-- |

146153-- 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

149156exportTypeClass exps name mn = do

150157 let exTypes = exportedTypes exps

151158 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

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

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

155162 return $ exps { exportedTypeClasses = classes }

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

168175--

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

170177addExport what name mn exports =

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

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

172179 then throwConflictError what name

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

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

174181

175182-- |

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

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

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

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

183190getExports 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+19−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−

141{-# LANGUAGE FlexibleContexts #-}

152{-# LANGUAGE RankNTypes #-}

163{-# LANGUAGE ScopedTypeVariables #-}

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

11097 let isPseudo = isPseudoModule name

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

11299 throwError . errorMessage . UnknownExportModule $ name

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

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

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

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

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

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

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

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

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

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

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

120107 elaborateModuleExports result _ = return result

121108

122109 -- 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

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

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

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

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

111+ extract

112+ :: (Ord a)

113+ => Bool

114+ -> ModuleName

115+ -> (a -> String)

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

117+ -> m [Qualified a]

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

119+ where

120+ go = filterM $ \(name', options) -> do

121+ let isMatch = if useQual then eqQual name name' else any (eqQual name . fst) options

122+ when (isMatch && length options > 1) $ checkImportConflicts render options

123+ return isMatch

127124

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

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

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

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

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

137134 -- 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

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

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

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

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

9999 return ()

100100

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

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

104104

105105 where

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

159159resolveModuleImport

160160 :: forall m

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

162− => ModuleName

163− -> Env

162+ => Env

164163 -> Imports

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

166165 -> m Imports

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

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

168167 where

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

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

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

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

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

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

174173 where

175174 positioned err = case pos of

176175 Nothing -> err

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

183182 :: forall m

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

185184 => ModuleName

186− -> ModuleName

187185 -> Exports

188186 -> Imports

189187 -> Maybe ModuleName

190188 -> ImportDeclarationType

191189 -> m Imports

192−resolveImport currentModule importModule exps imps impQual = resolveByType

190+resolveImport importModule exps imps impQual = resolveByType

193191 where

194192

195193 resolveByType :: ImportDeclarationType -> m Imports

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

262260 importExplicit imp (PositionedDeclarationRef pos _ r) =

263261 warnAndRethrowWithPosition pos $ importExplicit imp r

264262 importExplicit imp (ValueRef name) = do

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

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

266264 return $ imp { importedValues = values' }

267265 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

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

270268 exportedDctors = allExportedDataConstructors name

271269 dctorNames :: [ProperName]

272270 dctorNames = fst `map` exportedDctors

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

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

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

277275 importExplicit imp (TypeClassRef name) = do

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

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

279277 return $ imp { importedTypeClasses = typeClasses' }

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

281279

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

286284 Nothing -> internalError "Invalid state in allExportedDataConstructors"

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

288286

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

287+ -- Add something to an import resolution list

290288 updateImports

291289 :: (Ord a)

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

293− -> (a -> String)

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

294291 -> [(a, ModuleName)]

295292 -> a

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

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

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

303− in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) 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"

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

294+ updateImports imps' exps' name =

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

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

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