@@ -17,6 +17,7 @@ module Language.PureScript.Sugar.Names (
1717) where
1818
1919import Control.Applicative ((<$>))
20+import Control.Monad (foldM)
2021import Data.Generics (extM, mkM, everywhereM)
2122import qualified Data.Map as M
2223import qualified Data.Set as S
@@ -45,10 +46,16 @@ addTypeclass :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironme
4546addTypeclass env mn id = env { exportedTypeClasses = M.insertWith S.union mn (S.singleton id) (exportedTypeClasses env) }
4647
4748rename :: [Module] -> Either String [Module]
48−rename modules = trace (show $ findExports modules) $ mapM (renameInModule $ findExports modules) modules
49+rename modules = mapM renameInModule' modules
50+ where
51+ exports = findExports modules
52+ renameInModule' m = do
53+ imports <- resolveImports exports m
54+ renameInModule imports m
4955
50−renameInModule :: ExportEnvironment -> Module -> Either String Module
51−renameInModule exports m@(Module mn decls) = Module mn <$> mapM updateDecl decls >>= everywhereM (mkM updateType) >>= everywhereM (mkM updateValue) >>= everywhereM (mkM updateBinder)
56+renameInModule :: ImportEnvironment -> Module -> Either String Module
57+renameInModule imports (Module mn decls) =
58+ Module mn <$> mapM updateDecl decls >>= everywhereM (mkM updateType) >>= everywhereM (mkM updateValue) >>= everywhereM (mkM updateBinder)
5259 where
5360 updateDecl (TypeInstanceDeclaration cs (Qualified Nothing cn) ts ds) = do
5461 cn' <- updateClassName cn
@@ -76,7 +83,6 @@ renameInModule exports m@(Module mn decls) = Module mn <$> mapM updateDecl decls
7683 maybe (err "typeclass" nm mn) return $ M.lookup nm (importedTypeClasses imports)
7784 updateDataConstructorName nm =
7885 maybe (err "data constructor" nm mn) return $ M.lookup nm (importedDataConstructors imports)
79− imports = resolveImports exports m
8086 err t nm mn = Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'"
8187
8288findExports :: [Module] -> ExportEnvironment
@@ -90,12 +96,18 @@ findExports = foldl addModule nullEnv
9096findImports :: [Declaration] -> [ModuleName]
9197findImports decls = [ mn | (ImportDeclaration mn Nothing) <- decls ]
9298
93−resolveImports :: ExportEnvironment -> Module -> ImportEnvironment
94−resolveImports env (Module mn decls) = ImportEnvironment (resolve scope $ exportedDataConstructors env)
95− (resolve scope $ exportedTypeClasses env)
99+resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
100+resolveImports env (Module currentModule decls) = do
101+ dataConstructors <- resolve exportedDataConstructors
102+ typeClasses <- resolve exportedTypeClasses
103+ return $ ImportEnvironment dataConstructors typeClasses
96104 where
97− scope = (mn : findImports decls)
98− resolve imns = M.foldlWithKey (resolveDefs imns) M.empty
99− resolveDefs imns result mn ids | mn `elem` imns = S.foldl (resolveDef mn) result ids
100− resolveDefs imns result mn ids = result
101− resolveDef mn result id = M.insert id (Qualified (Just mn) id) result
105+ scope = (currentModule : findImports decls)
106+ resolve get = foldM resolveDefs M.empty (M.toList $ get env)
107+ resolveDefs result (mn, names) | mn `elem` scope = foldM (resolveDef mn) result (S.toList names)
108+ resolveDefs result _ = return result
109+ resolveDef mn result name = case M.lookup name result of
110+ Nothing -> return $ M.insert name (Qualified (Just mn) name) result
111+ Just x@(Qualified (Just mn') _) -> if mn' == currentModule
112+ then Left $ "Module '" ++ show currentModule ++ "' defines '" ++ show name ++ "' which conflicts with imported definition '" ++ show (Qualified (Just mn) name) ++ "'"
113+ else Left $ "Module '" ++ show currentModule ++ "' has conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"