@@ -26,35 +26,69 @@ import Language.PureScript.Names
26import Language.PureScript.Types
26import Language.PureScript.Types
27import Language.PureScript.Values
27import Language.PureScript.Values
30+-- The global export environment - every declaration exported from every module
29data ExportEnvironment = ExportEnvironment
32data ExportEnvironment = ExportEnvironment
34+ -- The types exported from each module
30 { exportedTypes :: M.Map ModuleName (S.Set ProperName)
36 { exportedTypes :: M.Map ModuleName (S.Set ProperName)
38+ -- The data constructors exported from each module, grouped by type constructor
31− , exportedDataConstructors :: M.Map ModuleName (S.Set ProperName)
40+ , exportedDataConstructors :: M.Map ModuleName (S.Set (ProperName, [ProperName]))
42+ -- The classes exported from each module
32 , exportedTypeClasses :: M.Map ModuleName (S.Set ProperName)
44 , exportedTypeClasses :: M.Map ModuleName (S.Set ProperName)
33 } deriving (Show)
45 } deriving (Show)
48+-- An imported environment for a particular module. This also contains the module's own members.
35data ImportEnvironment = ImportEnvironment
50data ImportEnvironment = ImportEnvironment
52+ -- Local names for types within a module mapped to to their qualified names
36 { importedTypes :: M.Map ProperName (Qualified ProperName)
54 { importedTypes :: M.Map ProperName (Qualified ProperName)
56+ -- Local names for data constructors within a module mapped to to their qualified names
37 , importedDataConstructors :: M.Map ProperName (Qualified ProperName)
58 , importedDataConstructors :: M.Map ProperName (Qualified ProperName)
60+ -- Local names for classes within a module mapped to to their qualified names
38 , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
62 , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
39 } deriving (Show)
63 } deriving (Show)
41−nullEnv = ExportEnvironment M.empty M.empty M.empty
65+-- |
42−
66+-- Adds a type belonging to a module to the export environment.
43addType :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
68addType :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
44addType env mn name = do
69addType env mn name = do
45 types <- addExport (exportedTypes env) mn name
70 types <- addExport (exportedTypes env) mn name
46 return $ env { exportedTypes = types }
71 return $ env { exportedTypes = types }
74+-- Adds a group of data constructors with their associated type constructor the export environment.
48−addDataConstructor :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
76+addDataConstructors :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment
49−addDataConstructor env mn name = do
77+addDataConstructors env mn tcon dcons = do
50− dataConstructors <- addExport (exportedDataConstructors env) mn name
78+ dataConstructors <- addExport (exportedDataConstructors env) mn (tcon, dcons)
51 return $ env { exportedDataConstructors = dataConstructors }
79 return $ env { exportedDataConstructors = dataConstructors }
82+-- Adds a class to the export environment.
53addTypeclass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
84addTypeclass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
54addTypeclass env mn name = do
85addTypeclass env mn name = do
55 classes <- addExport (exportedTypeClasses env) mn name
86 classes <- addExport (exportedTypeClasses env) mn name
56 return $ env { exportedTypeClasses = classes }
87 return $ env { exportedTypeClasses = classes }
90+-- Adds an export to a map of exports of that type.
58addExport :: (Ord s, Show s) => M.Map ModuleName (S.Set s) -> ModuleName -> s -> Either String (M.Map ModuleName (S.Set s))
92addExport :: (Ord s, Show s) => M.Map ModuleName (S.Set s) -> ModuleName -> s -> Either String (M.Map ModuleName (S.Set s))
59addExport exports mn name = case M.lookup mn exports of
93addExport exports mn name = case M.lookup mn exports of
60 Just s -> if S.member name s
94 Just s -> if S.member name s
@@ -62,6 +96,9 @@ addExport exports mn name = case M.lookup mn exports of
62 else Right $ M.insert mn (S.insert name s) exports
96 else Right $ M.insert mn (S.insert name s) exports
63 Nothing -> Right $ M.insert mn (S.singleton name) exports
97 Nothing -> Right $ M.insert mn (S.singleton name) exports
100+-- Replaces all local names with qualified names within a set of modules.
65rename :: [Module] -> Either String [Module]
102rename :: [Module] -> Either String [Module]
66rename modules = do
103rename modules = do
67 exports <- findExports modules
104 exports <- findExports modules
@@ -71,14 +108,17 @@ rename modules = do
71 imports <- resolveImports exports m
108 imports <- resolveImports exports m
72 renameInModule imports m
109 renameInModule imports m
112+-- Replaces all local names with qualified names within a module.
74renameInModule :: ImportEnvironment -> Module -> Either String Module
114renameInModule :: ImportEnvironment -> Module -> Either String Module
75renameInModule imports (Module mn decls) =
115renameInModule imports (Module mn decls) =
76 Module mn <$> mapM updateDecl decls >>= everywhereM ((mkM updateType) `extM` updateValue `extM` updateBinder)
116 Module mn <$> mapM updateDecl decls >>= everywhereM ((mkM updateType) `extM` updateValue `extM` updateBinder)
78 updateDecl (TypeInstanceDeclaration cs (Qualified Nothing cn) ts ds) = do
118 updateDecl (TypeInstanceDeclaration cs (Qualified Nothing cn) ts ds) = do
79− cn' <- updateClassName cn
119+ cn' <- updateClassName cn
80− cs' <- updateConstraints cs
120+ cs' <- updateConstraints cs
81− return $ TypeInstanceDeclaration cs' cn' ts ds
121+ return $ TypeInstanceDeclaration cs' cn' ts ds
82 updateDecl d = return d
122 updateDecl d = return d
83 updateValue (Constructor (Qualified Nothing nm)) = liftM Constructor $ updateDataConstructorName nm
123 updateValue (Constructor (Qualified Nothing nm)) = liftM Constructor $ updateDataConstructorName nm
84 updateValue v = return v
124 updateValue v = return v
@@ -93,42 +133,72 @@ renameInModule imports (Module mn decls) =
93 updateType t = return t
133 updateType t = return t
94 updateConstraints = mapM updateConstraint
134 updateConstraints = mapM updateConstraint
95 updateConstraint (Qualified Nothing nm, ts) = do
135 updateConstraint (Qualified Nothing nm, ts) = do
96− nm' <- updateClassName nm
136+ nm' <- updateClassName nm
97− return (nm', ts)
137+ return (nm', ts)
98 updateConstraint other = return other
138 updateConstraint other = return other
99 updateTypeName = update "type" importedTypes
139 updateTypeName = update "type" importedTypes
100 updateClassName = update "typeclass" importedTypeClasses
140 updateClassName = update "typeclass" importedTypeClasses
101 updateDataConstructorName = update "data constructor" importedDataConstructors
141 updateDataConstructorName = update "data constructor" importedDataConstructors
102 update t get nm = maybe (Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'") return $ M.lookup nm (get imports)
142 update t get nm = maybe (Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'") return $ M.lookup nm (get imports)
145+-- Finds all exported declarations in a set of modules.
104findExports :: [Module] -> Either String ExportEnvironment
147findExports :: [Module] -> Either String ExportEnvironment
105−findExports = foldM addModule nullEnv
148+findExports = foldM addModule (ExportEnvironment M.empty M.empty M.empty)
107 addModule env (Module mn ds) = foldM (addDecl mn) env ds
150 addModule env (Module mn ds) = foldM (addDecl mn) env ds
108 addDecl mn env (TypeClassDeclaration tcn _ _) = addTypeclass env mn tcn
151 addDecl mn env (TypeClassDeclaration tcn _ _) = addTypeclass env mn tcn
109 addDecl mn env (DataDeclaration tn _ dcs) = do
152 addDecl mn env (DataDeclaration tn _ dcs) = do
110− env' <- foldM (`addDataConstructor` mn) env (map fst dcs)
153+ env' <- addDataConstructors env mn tn (map fst dcs)
111− addType env' mn tn
154+ addType env' mn tn
112 addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn
155 addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn
113 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn
156 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn
114 addDecl _ env _ = return env
157 addDecl _ env _ = return env
160+-- Type representing a set of declarations being explicitly imported from a module
162+type ExplicitImports = [Either Ident ProperName]
165+-- Finds the imports within a module, mapping the imported module name to an optional set of
166+-- explicitly imported declarations.
116−findImports :: [Declaration] -> [ModuleName]
168+findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports)
117−findImports decls = [ mn | (ImportDeclaration mn Nothing) <- decls ]
169+findImports = foldl findImports' M.empty
171+ findImports' result (ImportDeclaration mn Nothing) = M.insert mn Nothing result
172+ findImports' result (ImportDeclaration mn (Just expl)) = M.insert mn (Just expl) result
173+ findImports' result _ = result
176+-- Constructs a local environment for a module.
119resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
178resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
120resolveImports env (Module currentModule decls) = do
179resolveImports env (Module currentModule decls) = do
121− types <- resolve exportedTypes
180+ types <- resolve exportedTypes (resolveDefs filterTypes)
122− dataConstructors <- resolve exportedDataConstructors
181+ dataConstructors <- resolve exportedDataConstructors resolveDcons
123− typeClasses <- resolve exportedTypeClasses
182+ typeClasses <- resolve exportedTypeClasses (resolveDefs filterClasses)
124 return $ ImportEnvironment types dataConstructors typeClasses
183 return $ ImportEnvironment types dataConstructors typeClasses
126− scope = currentModule : findImports decls
185+ scope = M.insert currentModule Nothing (findImports decls)
127− resolve get = foldM resolveDefs M.empty (M.toList $ get env)
186+ resolve get f = foldM f M.empty (M.toList $ get env)
187+ resolveDefs filt result (mn, names) = case M.lookup mn scope of
128− resolveDefs result (mn, names) | mn `elem` scope = foldM (resolveDef mn) result (S.toList names)
188+ Just Nothing -> foldM (resolveDef mn) result (S.toList names)
129− resolveDefs result _ = return result
189+ Just (Just expl) -> foldM (resolveDef mn) result (S.toList (S.intersection names (foldl filt S.empty expl)))
190+ Nothing -> Right result
130 resolveDef mn result name = case M.lookup name result of
191 resolveDef mn result name = case M.lookup name result of
131 Nothing -> return $ M.insert name (Qualified (Just mn) name) result
192 Nothing -> return $ M.insert name (Qualified (Just mn) name) result
132− Just x@(Qualified (Just mn') _) -> Left $ "Module '" ++ show currentModule ++ if mn' == currentModule
193+ Just x@(Qualified (Just mn') _) -> Left $ "Module '" ++ show currentModule ++
194+ if mn' == currentModule || mn == currentModule
133 then "' defines '" ++ show name ++ "' which conflicts with imported definition '" ++ show (Qualified (Just mn) name) ++ "'"
195 then "' defines '" ++ show name ++ "' which conflicts with imported definition '" ++ show (Qualified (Just mn) name) ++ "'"
134 else "' has conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"
196 else "' has conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"
197+ resolveDcons result (mn, tcons) = case M.lookup mn scope of
198+ Just Nothing -> foldM (\result (tcon, dcons) -> foldM (resolveDef mn) result dcons) result (S.toList tcons)
200+ let selectedTcons = filter (\(tcon, _) -> any (either (const False) ((==) tcon)) expl) (S.toList tcons) in
201+ foldM (\result (tcon, dcons) -> foldM (resolveDef mn) result dcons) result selectedTcons
202+ Nothing -> Right result
203+ filterTypes result = either (const result) (`S.insert` result)
204+ filterClasses result _ = result