@@ -16,7 +16,7 @@ import Control.Monad.Error.Class (MonadError(..))
16import Control.Monad.State.Lazy
16import Control.Monad.State.Lazy
17import Control.Monad.Writer (MonadWriter(..), censor)
17import Control.Monad.Writer (MonadWriter(..), censor)
19−import Data.List (find, nub)
19+import Data.List (nub)
20import Data.Maybe (fromMaybe, mapMaybe)
20import Data.Maybe (fromMaybe, mapMaybe)
21import qualified Data.Map as M
21import qualified Data.Map as M
22import qualified Data.Set as S
22import qualified Data.Set as S
@@ -65,9 +65,9 @@ desugarImportsWithEnv externs modules = do
65 externsEnv env ExternsFile{..} = do
65 externsEnv env ExternsFile{..} = do
66 let members = Exports{..}
66 let members = Exports{..}
67 ss = internalModuleSourceSpan "<Externs>"
67 ss = internalModuleSourceSpan "<Externs>"
68− env' = M.insert efModuleName (ss, nullImports, members) env
68+ env' = M.insert efModuleName (ss, primImports, members) env
69 fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)])
69 fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)])
70− imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports)
70+ imps <- foldM (resolveModuleImport env') primImports (map fromEFImport efImports)
71 exps <- resolveExports env' ss efModuleName imps members efExports
71 exps <- resolveExports env' ss efModuleName imps members efExports
72 return $ M.insert efModuleName (ss, imps, exps) env
72 return $ M.insert efModuleName (ss, imps, exps) env
@@ -101,7 +101,7 @@ desugarImportsWithEnv externs modules = do
101 Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss]
101 Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss]
102 Nothing -> do
102 Nothing -> do
103 members <- findExportable m
103 members <- findExportable m
104− let env' = M.insert mn (ss, nullImports, members) env
104+ let env' = M.insert mn (ss, primImports, members) env
105 (m', imps) <- resolveImports env' m
105 (m', imps) <- resolveImports env' m
106 exps <- maybe (return members) (resolveExports env' ss mn imps members) refs
106 exps <- maybe (return members) (resolveExports env' ss mn imps members) refs
107 return (m' : ms, M.insert mn (ss, imps, exps) env)
107 return (m' : ms, M.insert mn (ss, imps, exps) env)
@@ -110,7 +110,7 @@ desugarImportsWithEnv externs modules = do
110 renameInModule' env m@(Module _ _ mn _ _) =
110 renameInModule' env m@(Module _ _ mn _ _) =
111 warnAndRethrow (addHint (ErrorInModule mn)) $ do
111 warnAndRethrow (addHint (ErrorInModule mn)) $ do
112 let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env
112 let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env
113− (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m)
113+ (m', used) <- flip runStateT M.empty $ renameInModule imps (elaborateExports exps m)
114 lintImports m' env used
114 lintImports m' env used
115 return m'
115 return m'
@@ -147,11 +147,10 @@ elaborateExports exps (Module ss coms mn decls refs) =
147renameInModule
147renameInModule
148 :: forall m
148 :: forall m
149 . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m)
149 . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m)
151− -> Imports
150+ => Imports
152 -> Module
151 -> Module
153 -> m Module
152 -> m Module
154−renameInModule env imports (Module ss coms mn decls exps) =
153+renameInModule imports (Module ss coms mn decls exps) =
155 Module ss coms mn <$> parU decls go <*> pure exps
154 Module ss coms mn <$> parU decls go <*> pure exps
@@ -219,10 +218,9 @@ renameInModule env imports (Module ss coms mn decls exps) =
219 (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
218 (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
220 updateBinder s@(pos, _) (OpBinder op) =
219 updateBinder s@(pos, _) (OpBinder op) =
221 (,) s <$> (OpBinder <$> updateValueOpName op pos)
220 (,) s <$> (OpBinder <$> updateValueOpName op pos)
222− updateBinder s (TypedBinder t b) = do
221+ updateBinder s@(pos, _) (TypedBinder t b) = do
223− (s'@ (span', _), b') <- updateBinder s b
224− t' <- updateTypesEverywhere span' t
222+ t' <- updateTypesEverywhere pos t
225− return (s', TypedBinder t' b')
223+ return (s, TypedBinder t' b)
226 updateBinder s v =
224 updateBinder s v =
227 return (s, v)
225 return (s, v)
@@ -244,82 +242,51 @@ renameInModule env imports (Module ss coms mn decls exps) =
244 updateType :: Type -> m Type
242 updateType :: Type -> m Type
245 updateType (TypeOp name) = TypeOp <$> updateTypeOpName name pos
243 updateType (TypeOp name) = TypeOp <$> updateTypeOpName name pos
246 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
244 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
247− updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
245+ updateType (ConstrainedType cs t) = ConstrainedType <$> traverse updateInConstraint cs <*> pure t
248 updateType t = return t
246 updateType t = return t
247+ updateInConstraint :: Constraint -> m Constraint
248+ updateInConstraint (Constraint name ts info) =
249+ Constraint <$> updateClassName name pos <*> pure ts <*> pure info
250 updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]
251 updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]
251− updateConstraints pos = traverse (\(Constraint name ts info) ->
252+ updateConstraints pos = traverse $ \(Constraint name ts info) ->
252− Constraint <$> updateClassName name pos
254+ <$> updateClassName name pos
253− <*> traverse (updateTypesEverywhere pos) ts
255+ <*> traverse (updateTypesEverywhere pos) ts
254− <*> pure info)
256+ <*> pure info
256 updateTypeName
258 updateTypeName
257 :: Qualified (ProperName 'TypeName)
259 :: Qualified (ProperName 'TypeName)
258 -> Maybe SourceSpan
260 -> Maybe SourceSpan
259 -> m (Qualified (ProperName 'TypeName))
261 -> m (Qualified (ProperName 'TypeName))
261− update (importedTypes imports) (resolveType . exportedTypes) TyName
262+ updateTypeName = update (importedTypes imports) TyName
263 updateTypeOpName
264 updateTypeOpName
264 :: Qualified (OpName 'TypeOpName)
265 :: Qualified (OpName 'TypeOpName)
265 -> Maybe SourceSpan
266 -> Maybe SourceSpan
266 -> m (Qualified (OpName 'TypeOpName))
267 -> m (Qualified (OpName 'TypeOpName))
268− update (importedTypeOps imports) (resolve . exportedTypeOps) TyOpName
268+ updateTypeOpName = update (importedTypeOps imports) TyOpName
270 updateDataConstructorName
270 updateDataConstructorName
271 :: Qualified (ProperName 'ConstructorName)
271 :: Qualified (ProperName 'ConstructorName)
272 -> Maybe SourceSpan
272 -> Maybe SourceSpan
273 -> m (Qualified (ProperName 'ConstructorName))
273 -> m (Qualified (ProperName 'ConstructorName))
274− updateDataConstructorName =
276− (importedDataConstructors imports)
274+ updateDataConstructorName = update (importedDataConstructors imports) DctorName
277− (resolveDctor . exportedTypes)
280 updateClassName
276 updateClassName
281 :: Qualified (ProperName 'ClassName)
277 :: Qualified (ProperName 'ClassName)
282 -> Maybe SourceSpan
278 -> Maybe SourceSpan
283 -> m (Qualified (ProperName 'ClassName))
279 -> m (Qualified (ProperName 'ClassName))
286− (importedTypeClasses imports)
280+ updateClassName = update (importedTypeClasses imports) TyClassName
287− (resolve . exportedTypeClasses)
290 updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)
282 updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)
292− update (importedValues imports) (resolve . exportedValues) IdentName
283+ updateValueName = update (importedValues imports) IdentName
294 updateValueOpName
285 updateValueOpName
295 :: Qualified (OpName 'ValueOpName)
286 :: Qualified (OpName 'ValueOpName)
296 -> Maybe SourceSpan
287 -> Maybe SourceSpan
297 -> m (Qualified (OpName 'ValueOpName))
288 -> m (Qualified (OpName 'ValueOpName))
299− update (importedValueOps imports) (resolve . exportedValueOps) ValOpName
289+ updateValueOpName = update (importedValueOps imports) ValOpName
301− -- Used when performing an update to qualify values and classes with their
302− -- module of original definition.
303− resolve :: Ord a => M.Map a ModuleName -> a -> Maybe (Qualified a)
304− resolve as name = mkQualified name <$> name `M.lookup` as
306− -- Used when performing an update to qualify types with their module of
307− -- original definition.
309− :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)
310− -> ProperName 'TypeName
311− -> Maybe (Qualified (ProperName 'TypeName))
312− resolveType tys name =
313− mkQualified name . snd <$> M.lookup name tys
315− -- Used when performing an update to qualify data constructors with their
316− -- module of original definition.
318− :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)
319− -> ProperName 'ConstructorName
320− -> Maybe (Qualified (ProperName 'ConstructorName))
321− resolveDctor tys name =
322− mkQualified name . snd <$> find (elem name . fst) tys
324 -- Update names so unqualified references become qualified, and locally
291 -- Update names so unqualified references become qualified, and locally
325 -- qualified references are replaced with their canoncial qualified names
292 -- qualified references are replaced with their canoncial qualified names
@@ -327,12 +294,11 @@ renameInModule env imports (Module ss coms mn decls exps) =
328 :: (Ord a, Show a)
295 :: (Ord a, Show a)
329 => M.Map (Qualified a) [ImportRecord a]
296 => M.Map (Qualified a) [ImportRecord a]
330− -> (Exports -> a -> Maybe (Qualified a))
331 -> (a -> Name)
297 -> (a -> Name)
332 -> Qualified a
298 -> Qualified a
333 -> Maybe SourceSpan
299 -> Maybe SourceSpan
334 -> m (Qualified a)
300 -> m (Qualified a)
335− update imps getE toName qname@(Qualified mn' name) pos = positioned $
301+ update imps toName qname@(Qualified mn' name) pos = positioned $
336 case (M.lookup qname imps, mn') of
302 case (M.lookup qname imps, mn') of
338 -- We found the name in our imports, so we return the name for it,
304 -- We found the name in our imports, so we return the name for it,
@@ -354,13 +320,9 @@ renameInModule env imports (Module ss coms mn decls exps) =
354 -- by qualified importing). If that's not the case, then we just need to
320 -- by qualified importing). If that's not the case, then we just need to
355 -- check it refers to a symbol in another module.
321 -- check it refers to a symbol in another module.
356 (Nothing, Just mn'') ->
322 (Nothing, Just mn'') ->
357− case M.lookup mn'' env of
323+ if mn'' `S.member` importedQualModules imports || mn'' `S.member` importedModules imports
358− Nothing
324+ then throwUnknown
359− | mn'' `S.member` importedVirtualModules imports -> throwUnknown
361− throwError . errorMessage .
362− UnknownName . Qualified Nothing $ ModName mn''
325+ else throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn''
363− Just env' -> maybe throwUnknown return (getE (envModuleExports env') name)
365 -- If neither of the above cases are true then it's an undefined or
327 -- If neither of the above cases are true then it's an undefined or
366 -- unimported symbol.
328 -- unimported symbol.