@@ -20,6 +20,7 @@ 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)
@@ -97,11 +98,21 @@ addEmptyModule env name = M.insert name (Exports S.empty S.empty S.empty) env
9798-- |
9899-- Adds a type belonging to a module to the export environment.
99100--
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)
101+addType :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
102+addType env mn name = updateExportedModule env mn $ \m -> do
103+ types <- addExport (exportedTypes m) (name, [])
103104 return $ m { exportedTypes = types }
104105
106+-- |
107+-- Adds a data constructor belonging to a type and module to the export environment.
108+--
109+addDataConstructor :: ExportEnvironment -> ModuleName -> ProperName -> ProperName -> Either String ExportEnvironment
110+addDataConstructor env mn tcon dcon = updateExportedModule env mn $ \m -> do
111+ let types = exportedTypes m
112+ let dcons = fromMaybe (error $ "Type '" ++ show tcon ++ "' is missing from exportedTypes") (tcon `lookup` (S.toList types))
113+ let types' = S.insert (tcon, dcon : dcons) $ S.delete (tcon, dcons) types
114+ return $ m { exportedTypes = types' }
115+
105116-- |
106117-- Adds a class to the export environment.
107118--
@@ -197,16 +208,42 @@ renameInModule imports (Module mn decls exps) =
197208findExports :: [Module] -> Either String ExportEnvironment
198209findExports = foldM addModule M.empty
199210 where
200− addModule env m@(Module mn ds exps) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds
201− addDecl mn env (TypeClassDeclaration tcn _ ds) = do
211+
212+ -- Add all of the exported declarations from a module to the global export environment
213+ addModule :: ExportEnvironment -> Module -> Either String ExportEnvironment
214+ addModule env m@(Module mn ds exps) = rethrowForModule m $ foldM (addDecl mn exps) (addEmptyModule env mn) ds
215+
216+ -- Add a declaration from a module to the global export environment, ensuring it is exported
217+ -- from the module it resides within
218+ addDecl :: ModuleName -> Maybe [DeclarationRef] -> ExportEnvironment -> Declaration -> Either String ExportEnvironment
219+ addDecl mn exps env (TypeClassDeclaration tcn _ ds) | isExported (TypeClassRef tcn) exps = do
202220 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
221+ foldM (addClassMember mn exps) env' ds
222+ addDecl mn exps env (DataDeclaration tn _ dcs) | isExported (TypeRef tn Nothing) exps = do
223+ env' <- addType env mn tn
224+ foldM (\env'' -> addDataConstructor env'' mn tn) env' (map fst dcs)
225+ addDecl mn exps env (TypeSynonymDeclaration tn _ _) | isExported (TypeRef tn Nothing) exps = addType env mn tn
226+ addDecl mn exps env (ExternDataDeclaration tn _) | isExported (TypeRef tn Nothing) exps = addType env mn tn
227+ addDecl mn exps env (ValueDeclaration name _ _ _) | isExported (ValueRef name) exps = addValue env mn name
228+ addDecl mn exps env (ExternDeclaration _ name _ _) | isExported (ValueRef name) exps = addValue env mn name
229+ addDecl _ _ env _ = return env
230+
231+ -- Add a class member from a module to the global export environment, ensuring it is exported
232+ -- from the module it resides within
233+ addClassMember :: ModuleName -> Maybe [DeclarationRef] -> ExportEnvironment -> Declaration -> Either String ExportEnvironment
234+ addClassMember mn exps env (TypeDeclaration name _) | isExported (ValueRef name) exps = addValue env mn name
235+ addClassMember mn exps env _ = return env
236+
237+ -- Check whether a declaration is exported from a module. When checking if a type is exported
238+ -- the specific data constructors are ignored, only the export for the type constructor is
239+ -- tested for.
240+ isExported :: DeclarationRef -> Maybe [DeclarationRef] -> Bool
241+ isExported (TypeRef tn _) (Just exps) = any (typeMatches tn) exps
242+ where
243+ typeMatches tn (TypeRef tn' _) = tn == tn'
244+ typeMatches _ _ = False
245+ isExported dec (Just exps) = dec `elem` exps
246+ isExported dec Nothing = True
210247
211248-- |
212249-- Type representing a set of declarations being explicitly imported from a module