@@ -20,18 +20,19 @@ import Data.Maybe (fromMaybe)
2020import Data.Data
2121import Data.Generics (extM, mkM, everywhereM)
2222import Data.Generics.Extras (mkS, extS, everywhereWithContextM')
23+import Data.List (find)
2324
2425import Control.Applicative (Applicative(..), (<$>), (<*>))
2526import Control.Monad (foldM)
2627import Control.Monad.Error
2728
2829import qualified Data.Map as M
29−import qualified Data.Set as S
3030
3131import Language.PureScript.Declarations
3232import Language.PureScript.Names
3333import Language.PureScript.Types
3434import Language.PureScript.Values
35+import Language.PureScript.Prim
3536
3637-- |
3738-- The global export environment - every declaration exported from every module.
@@ -45,14 +46,14 @@ data Exports = Exports
4546 -- |
4647 -- The types exported from each module
4748 --
48− { exportedTypes :: S.Set (ProperName, [ProperName])
49+ { exportedTypes :: [(ProperName, [ProperName])]
4950 -- |
5051 -- The classes exported from each module
5152 --
52− , exportedTypeClasses :: S.Set ProperName
53+ , exportedTypeClasses :: [ProperName]
5354 -- |
5455 -- The values exported from each module
55− , exportedValues :: S.Set Ident
56+ , exportedValues :: [Ident]
5657 --
5758 } deriving (Show)
5859
@@ -92,7 +93,7 @@ updateExportedModule env mn update = do
9293-- Adds an empty module to an ExportEnvironment.
9394--
9495addEmptyModule :: ExportEnvironment -> ModuleName -> ExportEnvironment
95−addEmptyModule env name = M.insert name (Exports S.empty S.empty S.empty) env
96+addEmptyModule env name = M.insert name (Exports [] [] []) env
9697
9798-- |
9899-- Adds a type belonging to a module to the export environment.
@@ -119,13 +120,14 @@ addValue env mn name = updateExportedModule env mn $ \m -> do
119120 return $ m { exportedValues = values }
120121
121122-- |
122−-- Adds an export to a map of exports of that type.
123+-- Adds an entry to a list of exports unless it is already present, in which case an error is
124+-- returned.
123125--
124−addExport :: (Ord s, Show s) => S.Set s -> s -> Either String (S.Set s)
126+addExport :: (Eq a, Show a) => [a] -> a -> Either String [a]
125127addExport exports name =
126− if S.member name exports
128+ if name `elem` exports
127129 then throwError $ "Multiple definitions for '" ++ show name ++ "'"
128− else return $ S.insert name exports
130+ else return $ name : exports
129131
130132-- |
131133-- Replaces all local names with qualified names within a set of modules.
@@ -137,22 +139,23 @@ desugarImports modules = do
137139 where
138140 renameInModule' exports m = rethrowForModule m $ do
139141 imports <- resolveImports exports m
140− renameInModule imports m
142+ renameInModule imports exports m
141143
142144-- |
143145-- Rethrow an error with the name of the current module in the case of a failure
144146--
145147rethrowForModule :: Module -> Either String a -> Either String a
146−rethrowForModule (Module mn _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)
148+rethrowForModule (Module mn _ _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)
147149
148150-- |
149−-- Replaces all local names with qualified names within a module.
151+-- Replaces all local names with qualified names within a module and checks that all existing
152+-- qualified names are valid.
150153--
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+renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module
155+renameInModule imports exports (Module mn decls exps) =
156+ Module mn <$> (mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)) <*> pure exps
154157 where
155− updateDecl (TypeInstanceDeclaration name cs (Qualified Nothing cn) ts ds) =
158+ updateDecl (TypeInstanceDeclaration name cs cn ts ds) =
156159 TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds
157160 updateDecl d = return d
158161
@@ -161,43 +164,81 @@ renameInModule imports (Module mn decls) =
161164 ValueDeclaration name [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
162165 where
163166 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)
167+ bindFunctionArgs bound (Var name@(Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName name)
168+ bindFunctionArgs bound (Var name@(Qualified (Just _) _)) = (,) bound <$> (Var <$> updateValueName name)
165169 bindFunctionArgs bound other = return (bound, other)
166170 bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)
167171 bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)
168172 updateVars (ValueDeclaration name _ _ _) = error $ "Binders should have been desugared in " ++ show name
169173 updateVars other = return other
170−
171− updateValue (Constructor (Qualified Nothing nm)) =
172− Constructor <$> updateDataConstructorName nm
174+ updateValue (Constructor name) = Constructor <$> updateDataConstructorName name
173175 updateValue v = return v
174−
175− updateBinder (ConstructorBinder (Qualified Nothing nm) b) =
176− ConstructorBinder <$> updateDataConstructorName nm <*> pure b
176+ updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b
177177 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
178+ updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name
179+ updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys
180+ updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t
184181 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)
182+ updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
183+
184+ updateTypeName (Qualified Nothing name) = update "type" importedTypes name
185+ updateTypeName (Qualified (Just mn) name) = do
186+ modExports <- getExports mn
187+ case name `lookup` exportedTypes modExports of
188+ Nothing -> throwError $ "Unknown type '" ++ show (Qualified (Just mn) name) ++ "'"
189+ _ -> return $ Qualified (Just mn) name
190+
191+ updateDataConstructorName (Qualified Nothing name) = update "data constructor" importedDataConstructors name
192+ updateDataConstructorName (Qualified (Just mn) name) = do
193+ modExports <- getExports mn
194+ let allDcons = join $ snd `map` exportedTypes modExports
195+ if name `elem` allDcons
196+ then return $ Qualified (Just mn) name
197+ else throwError $ "Unknown data constructor '" ++ show (Qualified (Just mn) name) ++ "'"
198+
199+ updateClassName (Qualified Nothing name) = update "type class" importedTypeClasses name
200+ updateClassName (Qualified (Just mn) name) = check "type class" exportedTypeClasses mn name
201+
202+ updateValueName (Qualified Nothing name) = update "value" importedValues name
203+ updateValueName (Qualified (Just mn) name) = check "value" exportedValues mn name
204+
205+ -- Replace an unqualified name with a qualified
206+ update :: (Ord a, Show a) => String -> (ImportEnvironment -> M.Map a (Qualified a)) -> a -> Either String (Qualified a)
207+ update t get name = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'") return $ M.lookup name (get imports)
208+
209+ -- Check that a qualified name is valid
210+ check :: (Show a, Eq a) => String -> (Exports -> [a]) -> ModuleName -> a -> Either String (Qualified a)
211+ check t get mn name = do
212+ modExports <- getExports mn
213+ if name `elem` get modExports
214+ then return $ Qualified (Just mn) name
215+ else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn) name) ++ "'"
216+
217+ -- Gets the exports for a module, or an error message if the module doesn't exist
218+ getExports :: ModuleName -> Either String Exports
219+ getExports mn = maybe (throwError $ "Unknown module '" ++ show mn ++ "'") return $ M.lookup mn exports
193220
194221-- |
195222-- Finds all exported declarations in a set of modules.
196223--
197224findExports :: [Module] -> Either String ExportEnvironment
198−findExports = foldM addModule M.empty
225+findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) primExports
199226 where
200− addModule env m@(Module mn ds) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds
227+
228+ -- The exported types from the Prim module
229+ primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
230+ where
231+ mkTypeEntry (Qualified _ name) = (name, [])
232+
233+ -- Add all of the exported declarations from a module to the global export environment
234+ addModule :: ExportEnvironment -> Module -> Either String ExportEnvironment
235+ addModule env m@(Module mn ds Nothing) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds
236+ addModule env m@(Module mn ds (Just exps)) = rethrowForModule m $ do
237+ env' <- foldM (addDecl mn) (addEmptyModule env mn) ds
238+ filterExports mn exps env'
239+
240+ -- Add a declaration from a module to the global export environment
241+ addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either String ExportEnvironment
201242 addDecl mn env (TypeClassDeclaration tcn _ ds) = do
202243 env' <- addTypeClass env mn tcn
203244 foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds
@@ -208,10 +249,61 @@ findExports = foldM addModule M.empty
208249 addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
209250 addDecl _ env _ = return env
210251
252+-- |
253+-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
254+-- environment.
255+--
256+filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either String ExportEnvironment
257+filterExports mn exps env = do
258+ let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
259+ moduleExports' <- filterModule exps moduleExports
260+ return $ M.insert mn moduleExports' env
261+ where
262+
263+ -- Filter the exports for the specific module
264+ filterModule :: [DeclarationRef] -> Exports -> Either String Exports
265+ filterModule exps exported = do
266+ types <- foldM (filterTypes $ exportedTypes exported) [] exps
267+ values <- foldM (filterValues $ exportedValues exported) [] exps
268+ classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps
269+ return exported { exportedTypes = types, exportedTypeClasses = classes, exportedValues = values }
270+
271+ -- Ensure the exported types and data constructors exist in the module and add them to the set of
272+ -- exports
273+ filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either String [(ProperName, [ProperName])]
274+ filterTypes exps result (TypeRef name expDcons) = do
275+ dcons <- maybe (throwError $ "Cannot export undefined type '" ++ show name ++ "'") return $ name `lookup` exps
276+ dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
277+ return $ (name, dcons') : result
278+ filterTypes exps result _ = return result
279+
280+ -- Ensure the exported data constructors exists for a type and add them to the list of exports
281+ filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either String [ProperName]
282+ filterDcons tcon exps result name =
283+ if name `elem` exps
284+ then return $ name : result
285+ else throwError $ "Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'"
286+
287+ -- Ensure the exported classes exist in the module and add them to the set of exports
288+ filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either String [ProperName]
289+ filterClasses exps result (TypeClassRef name) =
290+ if name `elem` exps
291+ then return $ name : result
292+ else throwError $ "Cannot export undefined type class '" ++ show name ++ "'"
293+ filterClasses exps result _ = return result
294+
295+ -- Ensure the exported values exist in the module and add them to the set of exports
296+ filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either String [Ident]
297+ filterValues exps result (ValueRef name) =
298+ if name `elem` exps
299+ then return $ name : result
300+ else throwError $ "Cannot export undefined value '" ++ show name ++ "'"
301+ filterValues exps result _ = return result
302+
211303-- |
212304-- Type representing a set of declarations being explicitly imported from a module
213305--
214−type ExplicitImports = [ImportType]
306+type ExplicitImports = [DeclarationRef]
215307
216308-- |
217309-- Finds the imports within a module, mapping the imported module name to an optional set of
@@ -227,7 +319,7 @@ findImports = foldl findImports' M.empty
227319-- Constructs a local environment for a module.
228320--
229321resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
230−resolveImports env (Module currentModule decls) =
322+resolveImports env (Module currentModule decls _) =
231323 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
232324 where
233325 -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported
@@ -249,34 +341,34 @@ resolveImport currentModule importModule exp imp i = case i of
249341 -- Import everything from a module
250342 importAll :: ImportEnvironment -> Either String ImportEnvironment
251343 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)
344+ imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeRef name (Just dctors))) imp (exportedTypes exp)
345+ imp'' <- foldM (\m name -> importExplicit m (ValueRef name)) imp' (exportedValues exp)
346+ foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exp)
255347
256348 -- Import something explicitly
257− importExplicit :: ImportEnvironment -> ImportType -> Either String ImportEnvironment
258− importExplicit imp (NameImport name) = do
349+ importExplicit :: ImportEnvironment -> DeclarationRef -> Either String ImportEnvironment
350+ importExplicit imp (ValueRef name) = do
259351 checkImportExists "value" values name
260352 values' <- updateImports (importedValues imp) name
261353 return $ imp { importedValues = values' }
262− importExplicit imp (TypeImport name dctors) = do
354+ importExplicit imp (TypeRef name dctors) = do
263355 checkImportExists "type" types name
264356 types' <- updateImports (importedTypes imp) name
265357 let allDctors = allExportedDataConstructors name
266358 dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
267359 dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
268360 return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
269− importExplicit imp (TypeClassImport name) = do
361+ importExplicit imp (TypeClassRef name) = do
270362 checkImportExists "type class" classes name
271363 typeClasses' <- updateImports (importedTypeClasses imp) name
272364 return $ imp { importedTypeClasses = typeClasses' }
273365
274366 -- Find all exported data constructors for a given type
275367 allExportedDataConstructors :: ProperName -> [ProperName]
276− allExportedDataConstructors name = fromMaybe [] $ name `lookup` S.toList (exportedTypes exp)
368+ allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exp
277369
278370 -- 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))
371+ updateImports :: (Ord a, Show a) => M.Map a (Qualified a) -> a -> Either String (M.Map a (Qualified a))
280372 updateImports m name = case M.lookup name m of
281373 Nothing -> return $ M.insert name (Qualified (Just importModule) name) m
282374 Just x@(Qualified (Just mn) _) -> throwError $
@@ -286,18 +378,18 @@ resolveImport currentModule importModule exp imp i = case i of
286378
287379 -- The available values, types, and classes in the module being imported
288380 values = exportedValues exp
289− types = fst `S.map` exportedTypes exp
381+ types = fst `map` exportedTypes exp
290382 classes = exportedTypeClasses exp
291383
292384 -- Ensure that an explicitly imported data constructor exists for the type it is being imported
293385 -- from
294386 checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName
295− checkDctorExists names = checkImportExists "data constructor" (S.fromList names)
387+ checkDctorExists = checkImportExists "data constructor"
296388
297389 -- 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
390+ checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either String a
299391 checkImportExists t exports item =
300− if item `S.member` exports
392+ if item `elem` exports
301393 then return item
302394 else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'"
303395