@@ -24,6 +24,7 @@ import Data.Generics.Extras (mkS, extS, everywhereWithContextM')
2424
2525import Control.Applicative (Applicative(..), (<$>), (<*>))
2626import Control.Monad (forM_, unless, foldM)
27+import Control.Monad.Error
2728
2829import qualified Data.Map as M
2930import qualified Data.Set as S
@@ -103,9 +104,9 @@ addValue env mn name = do
103104addExport :: (Ord s, Show s) => M.Map ModuleName (S.Set s) -> ModuleName -> s -> Either String (M.Map ModuleName (S.Set s))
104105addExport exports mn name = case M.lookup mn exports of
105106 Just s -> if S.member name s
106− then Left $ "Module '" ++ show mn ++ "' has multiple definitions for '" ++ show name ++ "'"
107− else Right $ M.insert mn (S.insert name s) exports
108− Nothing -> Right $ M.insert mn (S.singleton name) exports
107+ then throwError $ "Multiple definitions for '" ++ show name ++ "'"
108+ else return $ M.insert mn (S.insert name s) exports
109+ Nothing -> return $ M.insert mn (S.singleton name) exports
109110
110111-- |
111112-- Replaces all local names with qualified names within a set of modules.
@@ -117,7 +118,13 @@ desugarImports modules = do
117118 where
118119 renameInModule' exports m = do
119120 imports <- resolveImports exports m
120− renameInModule imports m
121+ rethrowForModule m (renameInModule imports m)
122+
123+-- |
124+-- Rethrow an error with the name of the current module in the case of a failure
125+--
126+rethrowForModule :: Module -> Either String a -> Either String a
127+rethrowForModule (Module mn _) = flip catchError $ \e -> throwError ("Error in module '" ++ (show mn) ++ "':\n" ++ e)
121128
122129-- |
123130-- Replaces all local names with qualified names within a module.
@@ -160,7 +167,7 @@ renameInModule imports (Module mn decls) =
160167 updateClassName = update "type class" importedTypeClasses
161168 updateValueName = update "value" importedValues
162169 updateDataConstructorName = update "data constructor" importedDataConstructors
163− update t get nm = maybe (Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'") return $ M.lookup nm (get imports)
170+ update t get nm = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show nm ++ "'") return $ M.lookup nm (get imports)
164171
165172-- |
166173-- Finds all exported declarations in a set of modules.
@@ -168,7 +175,7 @@ renameInModule imports (Module mn decls) =
168175findExports :: [Module] -> Either String ExportEnvironment
169176findExports = foldM addModule (ExportEnvironment M.empty M.empty M.empty)
170177 where
171− addModule env (Module mn ds) = foldM (addDecl mn) env ds
178+ addModule env m@(Module mn ds) = rethrowForModule m $ foldM (addDecl mn) env ds
172179 addDecl mn env (TypeClassDeclaration tcn _ ds) = do
173180 env' <- addTypeClass env mn tcn
174181 foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds
@@ -235,7 +242,7 @@ resolveImports env (Module currentModule decls) =
235242
236243 -- Find all exported data constructors for a given type
237244 allExportedDataConstructors :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName]
238− allExportedDataConstructors env mn name = fromMaybe (error $ "Unable to find exported data constructors for type " ++ show name ++ " in module " ++ show mn) $ do
245+ allExportedDataConstructors env mn name = fromMaybe (error $ "Unable to find exported data constructors for type " ++ show name) $ do
239246 s <- mn `M.lookup` exportedTypes env
240247 name `lookup` S.toList s
241248
@@ -243,8 +250,8 @@ resolveImports env (Module currentModule decls) =
243250 updateImports :: (Ord id, Show id) => ModuleName -> M.Map id (Qualified id) -> id -> Either String (M.Map id (Qualified id))
244251 updateImports mn m name = case M.lookup name m of
245252 Nothing -> return $ M.insert name (Qualified (Just mn) name) m
246− Just x@(Qualified (Just mn') _) -> Left $ "Module '" ++ show currentModule ++
253+ Just x@(Qualified (Just mn') _) -> throwError $
247254 if mn' == currentModule || mn == currentModule
248− then "' defines '" ++ show name ++ "' which conflicts with imported definition '" ++ show (Qualified (Just mn) name) ++ "'"
249− else "' has conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"
255+ then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"
256+ else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"
250257