@@ -25,7 +25,6 @@ import Language.PureScript.Declarations
2525import Language.PureScript.Names
2626import Language.PureScript.Types
2727import Language.PureScript.Values
28−import Debug.Trace
2928
3029data ExportEnvironment = ExportEnvironment
3130 { exportedTypes :: M.Map ModuleName (S.Set ProperName)
@@ -41,28 +40,34 @@ data ImportEnvironment = ImportEnvironment
4140
4241nullEnv = ExportEnvironment M.empty M.empty M.empty
4342
44−addType :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment
45−addType env mn id = env { exportedTypes = M.insertWith addExport mn (S.singleton id) (exportedTypes env) }
43+addType :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
44+addType env mn name = do
45+ types <- addExport (exportedTypes env) mn name
46+ return $ env { exportedTypes = types }
4647
47−addDataConstructor :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment
48−addDataConstructor env mn id = env { exportedDataConstructors = M.insertWith addExport mn (S.singleton id) (exportedDataConstructors env) }
48+addDataConstructor :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
49+addDataConstructor env mn name = do
50+ dataConstructors <- addExport (exportedDataConstructors env) mn name
51+ return $ env { exportedDataConstructors = dataConstructors }
4952
50−addTypeclass :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment
51−addTypeclass env mn id = env { exportedTypeClasses = M.insertWith addExport mn (S.singleton id) (exportedTypeClasses env) }
53+addTypeclass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
54+addTypeclass env mn name = do
55+ classes <- addExport (exportedTypeClasses env) mn name
56+ return $ env { exportedTypeClasses = classes }
5257
53−-- TODO: do this properly with Either
54−addExport :: (Ord s, Show s) => S.Set s -> S.Set s -> S.Set s
55−addExport new old =
56− if null overlap
57− then new `S.union` old
58− else error $ show (head overlap) ++ " has already been defined"
59− where overlap = S.toList $ S.intersection new old
58+addExport :: (Ord s, Show s) => M.Map ModuleName (S.Set s) -> ModuleName -> s -> Either String (M.Map ModuleName (S.Set s))
59+addExport exports mn name = case M.lookup mn exports of
60+ Just s -> if S.member name s
61+ then Left $ "Module '" ++ show mn ++ "' has multiple definitions for '" ++ (show name) ++ "'"
62+ else Right $ M.insert mn (S.insert name s) exports
63+ Nothing -> Right $ M.insert mn (S.singleton name) exports
6064
6165rename :: [Module] -> Either String [Module]
62−rename modules = mapM renameInModule' modules
66+rename modules = do
67+ exports <- findExports modules
68+ mapM (renameInModule' exports) modules
6369 where
64− exports = findExports modules
65− renameInModule' m = do
70+ renameInModule' exports m = do
6671 imports <- resolveImports exports m
6772 renameInModule imports m
6873
@@ -96,15 +101,17 @@ renameInModule imports (Module mn decls) =
96101 updateDataConstructorName = update "data constructor" importedDataConstructors
97102 update t get nm = maybe (Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'") return $ M.lookup nm (get imports)
98103
99−findExports :: [Module] -> ExportEnvironment
100−findExports = foldl addModule nullEnv
104+findExports :: [Module] -> Either String ExportEnvironment
105+findExports = foldM addModule nullEnv
101106 where
102− addModule env (Module mn ds) = foldl (addDecl mn) env ds
107+ addModule env (Module mn ds) = foldM (addDecl mn) env ds
103108 addDecl mn env (TypeClassDeclaration tcn _ _) = addTypeclass env mn tcn
104− addDecl mn env (DataDeclaration tn _ dcs) = addType (foldl (`addDataConstructor` mn) env (map fst dcs)) mn tn
109+ addDecl mn env (DataDeclaration tn _ dcs) = do
110+ env' <- foldM (`addDataConstructor` mn) env (map fst dcs)
111+ addType env' mn tn
105112 addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn
106113 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn
107− addDecl _ env _ = env
114+ addDecl _ env _ = return env
108115
109116findImports :: [Declaration] -> [ModuleName]
110117findImports decls = [ mn | (ImportDeclaration mn Nothing) <- decls ]