@@ -116,15 +116,15 @@ desugarImports modules = do
116 exports <- findExports modules
116 exports <- findExports modules
117 mapM (renameInModule' exports) modules
117 mapM (renameInModule' exports) modules
119− renameInModule' exports m@(Module mn _) = do
119+ renameInModule' exports m = rethrowForModule m $ do
120 imports <- resolveImports exports m
120 imports <- resolveImports exports m
121− rethrowForModule m (renameInModule imports m)
121+ renameInModule imports m
124-- Rethrow an error with the name of the current module in the case of a failure
124-- Rethrow an error with the name of the current module in the case of a failure
126rethrowForModule :: Module -> Either String a -> Either String a
126rethrowForModule :: Module -> Either String a -> Either String a
127−rethrowForModule (Module mn _) = flip catchError $ \e -> throwError ("Error in module '" ++ (show mn) ++ "':\n" ++ e)
127+rethrowForModule (Module mn _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)
130-- Replaces all local names with qualified names within a module.
130-- Replaces all local names with qualified names within a module.
@@ -220,25 +220,21 @@ resolveImports env (Module currentModule decls) =
220 -- Import something explicitly
220 -- Import something explicitly
221 importExplicit :: ModuleName -> ImportEnvironment -> ImportType -> Either String ImportEnvironment
221 importExplicit :: ModuleName -> ImportEnvironment -> ImportType -> Either String ImportEnvironment
222 importExplicit mn imp (NameImport name) = do
222 importExplicit mn imp (NameImport name) = do
223+ checkValueExists env mn name
223 values' <- updateImports mn (importedValues imp) name
224 values' <- updateImports mn (importedValues imp) name
224 return $ imp { importedValues = values' }
225 return $ imp { importedValues = values' }
225 importExplicit mn imp (TypeImport name dctors) = do
226 importExplicit mn imp (TypeImport name dctors) = do
226− allDctors <- allExportedDataConstructors env mn name
227+ checkTypeExists env mn name
227 types' <- updateImports mn (importedTypes imp) name
228 types' <- updateImports mn (importedTypes imp) name
229+ let allDctors = allExportedDataConstructors env mn name
228− dctors' <- maybe (return allDctors) (check "data constructor" allDctors) dctors
230+ dctors' <- maybe (return allDctors) (mapM $ checkDctorExists mn allDctors) dctors
229 dctors'' <- foldM (updateImports mn) (importedDataConstructors imp) dctors'
231 dctors'' <- foldM (updateImports mn) (importedDataConstructors imp) dctors'
230 return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
232 return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
231 importExplicit mn imp (TypeClassImport name) = do
233 importExplicit mn imp (TypeClassImport name) = do
234+ checkClassExists env mn name
232 typeClasses' <- updateImports mn (importedTypeClasses imp) name
235 typeClasses' <- updateImports mn (importedTypeClasses imp) name
233 return $ imp { importedTypeClasses = typeClasses' }
236 return $ imp { importedTypeClasses = typeClasses' }
235− -- Check that each item in a list of explicit imports does actually exist
236− check :: (Show a, Eq a) => String -> [a] -> [a] -> Either String [a]
237− check t all selected = case selected \\ all of
238− [] -> return selected
239− (unknown:[]) -> throwError $ "Unknown " ++ t ++ " '" ++ show unknown ++ "'"
240− unknowns -> throwError $ "Unknown " ++ t ++ "s '" ++ (intercalate "', '" (show `map` unknowns)) ++ "'"
242 -- Import everything from a module
238 -- Import everything from a module
243 importAll :: ImportEnvironment -> ModuleName -> ExportEnvironment -> Either String ImportEnvironment
239 importAll :: ImportEnvironment -> ModuleName -> ExportEnvironment -> Either String ImportEnvironment
244 importAll imp mn env = do
240 importAll imp mn env = do
@@ -250,8 +246,8 @@ resolveImports env (Module currentModule decls) =
250 (S.toList . fromMaybe S.empty $ mn `M.lookup` exportedTypeClasses env)
246 (S.toList . fromMaybe S.empty $ mn `M.lookup` exportedTypeClasses env)
252 -- Find all exported data constructors for a given type
248 -- Find all exported data constructors for a given type
253− allExportedDataConstructors :: ExportEnvironment -> ModuleName -> ProperName -> Either String [ProperName]
249+ allExportedDataConstructors :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName]
254− allExportedDataConstructors env mn name = maybe (throwError $ "Unable to find exported data constructors for type " ++ show name) return $ do
250+ allExportedDataConstructors env mn name = fromMaybe [] $ do
255 s <- mn `M.lookup` exportedTypes env
251 s <- mn `M.lookup` exportedTypes env
256 name `lookup` S.toList s
252 name `lookup` S.toList s
@@ -264,3 +260,30 @@ resolveImports env (Module currentModule decls) =
264 then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"
260 then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"
265 else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"
261 else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"
263+ -- Ensure that an explicitly imported value exists in the module it is being imported from
264+ checkValueExists :: ExportEnvironment -> ModuleName -> Ident -> Either String Ident
265+ checkValueExists env mn = checkImportExists "value" mn values
266+ where values = S.toList $ fromMaybe S.empty $ mn `M.lookup` exportedValues env
268+ -- Ensure that an explicitly imported type exists in the module it is being imported from
269+ checkTypeExists :: ExportEnvironment -> ModuleName -> ProperName -> Either String ProperName
270+ checkTypeExists env mn = checkImportExists "type" mn types
271+ where types = fst `map` S.toList (fromMaybe S.empty $ mn `M.lookup` exportedTypes env)
273+ -- Ensure that an explicitly imported class exists in the module it is being imported from
274+ checkClassExists :: ExportEnvironment -> ModuleName -> ProperName -> Either String ProperName
275+ checkClassExists env mn = checkImportExists "type class" mn classes
276+ where classes = S.toList $ fromMaybe S.empty $ mn `M.lookup` exportedTypeClasses env
278+ -- Ensure that an explicitly imported data constructor exists for the type it is being imported
280+ checkDctorExists :: ModuleName -> [ProperName] -> ProperName -> Either String ProperName
281+ checkDctorExists = checkImportExists "data constructor"
283+ -- Check that an explicitly imported item exists in the module it is being imported from
284+ checkImportExists :: (Show a, Eq a) => String -> ModuleName -> [a] -> a -> Either String a
285+ checkImportExists t mn exports item =
286+ if item `elem` exports
288+ else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just mn) item) ++ "'"