@@ -0,0 +1,303 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Sugar.Names
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Sugar.Names (
16+ desugarImports
17+) where
18+
19+import Data.Maybe (fromMaybe)
20+import Data.Data
21+import Data.Generics (extM, mkM, everywhereM)
22+import Data.Generics.Extras (mkS, extS, everywhereWithContextM')
23+
24+import Control.Applicative (Applicative(..), (<$>), (<*>))
25+import Control.Monad (foldM)
26+import Control.Monad.Error
27+
28+import qualified Data.Map as M
29+import qualified Data.Set as S
30+
31+import Language.PureScript.Declarations
32+import Language.PureScript.Names
33+import Language.PureScript.Types
34+import Language.PureScript.Values
35+
36+-- |
37+-- The global export environment - every declaration exported from every module.
38+--
39+type ExportEnvironment = M.Map ModuleName Exports
40+
41+-- |
42+-- The exported declarations from a module.
43+--
44+data Exports = Exports
45+ -- |
46+ -- The types exported from each module
47+ --
48+ { exportedTypes :: S.Set (ProperName, [ProperName])
49+ -- |
50+ -- The classes exported from each module
51+ --
52+ , exportedTypeClasses :: S.Set ProperName
53+ -- |
54+ -- The values exported from each module
55+ , exportedValues :: S.Set Ident
56+ --
57+ } deriving (Show)
58+
59+-- |
60+-- An imported environment for a particular module. This also contains the module's own members.
61+--
62+data ImportEnvironment = ImportEnvironment
63+ -- |
64+ -- Local names for types within a module mapped to to their qualified names
65+ --
66+ { importedTypes :: M.Map ProperName (Qualified ProperName)
67+ -- |
68+ -- Local names for data constructors within a module mapped to to their qualified names
69+ --
70+ , importedDataConstructors :: M.Map ProperName (Qualified ProperName)
71+ -- |
72+ -- Local names for classes within a module mapped to to their qualified names
73+ --
74+ , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
75+ -- |
76+ -- Local names for values within a module mapped to to their qualified names
77+ --
78+ , importedValues :: M.Map Ident (Qualified Ident)
79+ } deriving (Show)
80+
81+-- |
82+-- Updates the exports for a module from the global environment. If the module was not previously
83+-- present in the global environment, it is created.
84+--
85+updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either String Exports) -> Either String ExportEnvironment
86+updateExportedModule env mn update = do
87+ let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
88+ exports' <- update exports
89+ return $ M.insert mn exports' env
90+
91+-- |
92+-- Adds an empty module to an ExportEnvironment.
93+--
94+addEmptyModule :: ExportEnvironment -> ModuleName -> ExportEnvironment
95+addEmptyModule env name = M.insert name (Exports S.empty S.empty S.empty) env
96+
97+-- |
98+-- Adds a type belonging to a module to the export environment.
99+--
100+addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment
101+addType env mn name dctors = updateExportedModule env mn $ \m -> do
102+ types <- addExport (exportedTypes m) (name, dctors)
103+ return $ m { exportedTypes = types }
104+
105+-- |
106+-- Adds a class to the export environment.
107+--
108+addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
109+addTypeClass env mn name = updateExportedModule env mn $ \m -> do
110+ classes <- addExport (exportedTypeClasses m) name
111+ return $ m { exportedTypeClasses = classes }
112+
113+-- |
114+-- Adds a class to the export environment.
115+--
116+addValue :: ExportEnvironment -> ModuleName -> Ident -> Either String ExportEnvironment
117+addValue env mn name = updateExportedModule env mn $ \m -> do
118+ values <- addExport (exportedValues m) name
119+ return $ m { exportedValues = values }
120+
121+-- |
122+-- Adds an export to a map of exports of that type.
123+--
124+addExport :: (Ord s, Show s) => S.Set s -> s -> Either String (S.Set s)
125+addExport exports name =
126+ if S.member name exports
127+ then throwError $ "Multiple definitions for '" ++ show name ++ "'"
128+ else return $ S.insert name exports
129+
130+-- |
131+-- Replaces all local names with qualified names within a set of modules.
132+--
133+desugarImports :: [Module] -> Either String [Module]
134+desugarImports modules = do
135+ exports <- findExports modules
136+ mapM (renameInModule' exports) modules
137+ where
138+ renameInModule' exports m = rethrowForModule m $ do
139+ imports <- resolveImports exports m
140+ renameInModule imports m
141+
142+-- |
143+-- Rethrow an error with the name of the current module in the case of a failure
144+--
145+rethrowForModule :: Module -> Either String a -> Either String a
146+rethrowForModule (Module mn _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)
147+
148+-- |
149+-- Replaces all local names with qualified names within a module.
150+--
151+renameInModule :: ImportEnvironment -> Module -> Either String Module
152+renameInModule imports (Module mn decls) =
153+ Module mn <$> mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)
154+ where
155+ updateDecl (TypeInstanceDeclaration cs (Qualified Nothing cn) ts ds) =
156+ TypeInstanceDeclaration <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds
157+ updateDecl d = return d
158+
159+ updateVars :: Declaration -> Either String Declaration
160+ updateVars (ValueDeclaration name [] Nothing val) =
161+ ValueDeclaration name [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
162+ where
163+ bindFunctionArgs bound (Abs (Left arg) val) = return (arg : bound, Abs (Left arg) val)
164+ bindFunctionArgs bound (Var (Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName ident)
165+ bindFunctionArgs bound other = return (bound, other)
166+ bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)
167+ bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)
168+ updateVars (ValueDeclaration name _ _ _) = error $ "Binders should have been desugared in " ++ show name
169+ updateVars other = return other
170+
171+ updateValue (Constructor (Qualified Nothing nm)) =
172+ Constructor <$> updateDataConstructorName nm
173+ updateValue v = return v
174+
175+ updateBinder (ConstructorBinder (Qualified Nothing nm) b) =
176+ ConstructorBinder <$> updateDataConstructorName nm <*> pure b
177+ updateBinder v = return v
178+ updateType (TypeConstructor (Qualified Nothing nm)) =
179+ TypeConstructor <$> updateTypeName nm
180+ updateType (SaturatedTypeSynonym (Qualified Nothing nm) tys) =
181+ SaturatedTypeSynonym <$> updateTypeName nm <*> mapM updateType tys
182+ updateType (ConstrainedType cs t) =
183+ ConstrainedType <$> updateConstraints cs <*> pure t
184+ updateType t = return t
185+ updateConstraints = mapM updateConstraint
186+ updateConstraint (Qualified Nothing nm, ts) = (,) <$> updateClassName nm <*> pure ts
187+ updateConstraint other = return other
188+ updateTypeName = update "type" importedTypes
189+ updateClassName = update "type class" importedTypeClasses
190+ updateValueName = update "value" importedValues
191+ updateDataConstructorName = update "data constructor" importedDataConstructors
192+ update t get nm = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show nm ++ "'") return $ M.lookup nm (get imports)
193+
194+-- |
195+-- Finds all exported declarations in a set of modules.
196+--
197+findExports :: [Module] -> Either String ExportEnvironment
198+findExports = foldM addModule M.empty
199+ where
200+ addModule env m@(Module mn ds) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds
201+ addDecl mn env (TypeClassDeclaration tcn _ ds) = do
202+ env' <- addTypeClass env mn tcn
203+ foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds
204+ addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)
205+ addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
206+ addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
207+ addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
208+ addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
209+ addDecl _ env _ = return env
210+
211+-- |
212+-- Type representing a set of declarations being explicitly imported from a module
213+--
214+type ExplicitImports = [ImportType]
215+
216+-- |
217+-- Finds the imports within a module, mapping the imported module name to an optional set of
218+-- explicitly imported declarations.
219+--
220+findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports)
221+findImports = foldl findImports' M.empty
222+ where
223+ findImports' result (ImportDeclaration mn expl) = M.insert mn expl result
224+ findImports' result _ = result
225+
226+-- |
227+-- Constructs a local environment for a module.
228+--
229+resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
230+resolveImports env (Module currentModule decls) =
231+ foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
232+ where
233+ -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported
234+ scope :: M.Map ModuleName (Maybe ExplicitImports)
235+ scope = M.insert currentModule Nothing (findImports decls)
236+ resolveImport' imp (mn, i) = do
237+ m <- maybe (throwError $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env
238+ resolveImport currentModule mn m imp i
239+
240+-- |
241+-- Extends the local environment for a module by resolving an import of another module.
242+--
243+resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ExplicitImports -> Either String ImportEnvironment
244+resolveImport currentModule importModule exp imp i = case i of
245+ Nothing -> importAll imp
246+ (Just expl) -> foldM importExplicit imp expl
247+ where
248+
249+ -- Import everything from a module
250+ importAll :: ImportEnvironment -> Either String ImportEnvironment
251+ importAll imp = do
252+ imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeImport name (Just dctors))) imp (S.toList $ exportedTypes exp)
253+ imp'' <- foldM (\m name -> importExplicit m (NameImport name)) imp' (S.toList $ exportedValues exp)
254+ foldM (\m name -> importExplicit m (TypeClassImport name)) imp'' (S.toList $ exportedTypeClasses exp)
255+
256+ -- Import something explicitly
257+ importExplicit :: ImportEnvironment -> ImportType -> Either String ImportEnvironment
258+ importExplicit imp (NameImport name) = do
259+ checkImportExists "value" values name
260+ values' <- updateImports (importedValues imp) name
261+ return $ imp { importedValues = values' }
262+ importExplicit imp (TypeImport name dctors) = do
263+ checkImportExists "type" types name
264+ types' <- updateImports (importedTypes imp) name
265+ let allDctors = allExportedDataConstructors name
266+ dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
267+ dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
268+ return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
269+ importExplicit imp (TypeClassImport name) = do
270+ checkImportExists "type class" classes name
271+ typeClasses' <- updateImports (importedTypeClasses imp) name
272+ return $ imp { importedTypeClasses = typeClasses' }
273+
274+ -- Find all exported data constructors for a given type
275+ allExportedDataConstructors :: ProperName -> [ProperName]
276+ allExportedDataConstructors name = fromMaybe [] $ name `lookup` S.toList (exportedTypes exp)
277+
278+ -- Add something to the ImportEnvironment if it does not already exist there
279+ updateImports :: (Ord id, Show id) => M.Map id (Qualified id) -> id -> Either String (M.Map id (Qualified id))
280+ updateImports m name = case M.lookup name m of
281+ Nothing -> return $ M.insert name (Qualified (Just importModule) name) m
282+ Just x@(Qualified (Just mn) _) -> throwError $
283+ if mn == currentModule || importModule == currentModule
284+ then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"
285+ else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
286+
287+ -- The available values, types, and classes in the module being imported
288+ values = exportedValues exp
289+ types = fst `S.map` exportedTypes exp
290+ classes = exportedTypeClasses exp
291+
292+ -- Ensure that an explicitly imported data constructor exists for the type it is being imported
293+ -- from
294+ checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName
295+ checkDctorExists names = checkImportExists "data constructor" (S.fromList names)
296+
297+ -- Check that an explicitly imported item exists in the module it is being imported from
298+ checkImportExists :: (Show a, Ord a, Eq a) => String -> S.Set a -> a -> Either String a
299+ checkImportExists t exports item =
300+ if item `S.member` exports
301+ then return item
302+ else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'"
303+