@@ -1,7 +1,6 @@
11-----------------------------------------------------------------------------
22--
33-- Module : Language.PureScript.Sugar.Names
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
54-- License : MIT (http://opensource.org/licenses/MIT)
65--
76-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
@@ -12,244 +11,75 @@
1211--
1312-----------------------------------------------------------------------------
1413
14+{-# LANGUAGE CPP #-}
1515{-# LANGUAGE FlexibleContexts #-}
1616{-# LANGUAGE ScopedTypeVariables #-}
17−{-# LANGUAGE PatternGuards #-}
18−{-# LANGUAGE CPP #-}
1917
20−module Language.PureScript.Sugar.Names (
21− desugarImports
22−) where
18+module Language.PureScript.Sugar.Names (desugarImports) where
2319
24−import Data.List (find, nub, (\\))
25−import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
20+import Data.List (find, nub)
21+import Data.Maybe (fromMaybe, mapMaybe)
2622
2723#if __GLASGOW_HASKELL__ < 710
2824import Control.Applicative (Applicative(..), (<$>), (<*>))
2925#endif
3026import Control.Monad
3127import Control.Monad.Error.Class (MonadError(..))
32−import Control.Monad.Writer (MonadWriter(..), censor)
28+import Control.Monad.Writer (MonadWriter(..))
3329
3430import qualified Data.Map as M
3531
3632import Language.PureScript.AST
3733import Language.PureScript.Names
3834import Language.PureScript.Types
39−import Language.PureScript.Environment
4035import Language.PureScript.Errors
4136import Language.PureScript.Traversals
42−
43−import qualified Language.PureScript.Constants as C
44−
45−-- |
46−-- The global export environment - every declaration exported from every module.
47−--
48−type ExportEnvironment = M.Map ModuleName Exports
49−
50−-- |
51−-- The exported declarations from a module.
52−--
53−data Exports = Exports
54− {
55− -- |
56− -- The filename of the module these exports are for
57− --
58− moduleSourceSpan :: SourceSpan
59− -- |
60− -- The types exported from each module
61− --
62− , exportedTypes :: [(ProperName, [ProperName])]
63− -- |
64− -- The classes exported from each module
65− --
66− , exportedTypeClasses :: [ProperName]
67− -- |
68− -- The values exported from each module
69− --
70− , exportedValues :: [Ident]
71− -- |
72− -- The modules exported from each module
73− --
74− , exportedModules :: [ModuleName]
75− } deriving (Show)
76−
77−-- |
78−-- An imported environment for a particular module. This also contains the module's own members.
79−--
80−data ImportEnvironment = ImportEnvironment
81− {
82− -- |
83− -- Local names for types within a module mapped to to their qualified names
84− --
85− importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)
86− -- |
87− -- Local names for data constructors within a module mapped to to their qualified names
88− --
89− , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName)
90− -- |
91− -- Local names for classes within a module mapped to to their qualified names
92− --
93− , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName)
94− -- |
95− -- Local names for values within a module mapped to to their qualified names
96− --
97− , importedValues :: M.Map (Qualified Ident) (Qualified Ident)
98− } deriving (Show)
99−
100−-- |
101−-- Updates the exports for a module from the global environment. If the module was not previously
102−-- present in the global environment, it is created.
103−--
104−updateExportedModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> (Exports -> m Exports) -> m ExportEnvironment
105−updateExportedModule env mn update = do
106− let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
107− exports' <- update exports
108− return $ M.insert mn exports' env
109−
110−-- |
111−-- Adds an empty module to an ExportEnvironment.
112−--
113−addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> SourceSpan -> m ExportEnvironment
114−addEmptyModule env name ss =
115− case name `M.lookup` env of
116− Just m -> throwError . errorMessage $ RedefinedModule name [moduleSourceSpan m, ss]
117− Nothing -> return $ M.insert name (Exports ss [] [] [] []) env
118−
119−-- |
120−-- Adds a type belonging to a module to the export environment.
121−--
122−addType :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> m ExportEnvironment
123−addType env mn name dctors = updateExportedModule env mn $ \m -> do
124− let exTypes = exportedTypes m
125− let exDctors = snd `concatMap` exTypes
126− let exClasses = exportedTypeClasses m
127− when (any ((== name) . fst) exTypes) $ throwConflictError ConflictingTypeDecls name
128− when (name `elem` exClasses) $ throwConflictError TypeConflictsWithClass name
129− forM_ dctors $ \dctor -> do
130− when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor
131− when (dctor `elem` exClasses) $ throwConflictError CtorConflictsWithClass dctor
132− return $ m { exportedTypes = (name, dctors) : exTypes }
133−
134−-- |
135−-- Adds a class to the export environment.
136−--
137−addTypeClass :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment
138−addTypeClass env mn name = updateExportedModule env mn $ \m -> do
139− let exTypes = exportedTypes m
140− let exDctors = snd `concatMap` exTypes
141− when (any ((== name) . fst) exTypes) $ throwConflictError ClassConflictsWithType name
142− when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name
143− classes <- addExport DuplicateClassExport (exportedTypeClasses m) name
144− return $ m { exportedTypeClasses = classes }
145−
146−-- |
147−-- Adds a class to the export environment.
148−--
149−addValue :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment
150−addValue env mn name = updateExportedModule env mn $ \m -> do
151− values <- addExport DuplicateValueExport (exportedValues m) name
152− return $ m { exportedValues = values }
153−
154−-- |
155−-- Adds an entry to a list of exports unless it is already present, in which case an error is
156−-- returned.
157−--
158−addExport :: (Applicative m, MonadError MultipleErrors m, Eq a, Show a) => (a -> SimpleErrorMessage) -> [a] -> a -> m [a]
159−addExport what exports name =
160− if name `elem` exports
161− then throwConflictError what name
162− else return $ name : exports
37+import Language.PureScript.Sugar.Names.Env
38+import Language.PureScript.Sugar.Names.Imports
39+import Language.PureScript.Sugar.Names.Exports
16340
16441-- |
165−-- Replaces all local names with qualified names within a set of modules.
42+-- Replaces all local names with qualified names within a list of modules. The
43+-- modules should be topologically sorted beforehand.
16644--
16745desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]
16846desugarImports modules = do
169− unfilteredExports <- findExports modules
170− exports <- foldM filterModuleExports unfilteredExports modules
171− let modules' = moduleReexports <$> modules
172− mapM (renameInModule' unfilteredExports exports) modules'
47+ env <- foldM updateEnv initEnv modules
48+ mapM (renameInModule' env) modules
17349 where
174− moduleReexports :: Module -> Module
175− moduleReexports (Module ss coms mn decls exps) =
176− let importedMods = catMaybes findImports'
177− in (Module ss coms mn (decls ++ (concatMap reexports importedMods)) exps)
178− where
179− imports :: [Declaration]
180− imports = filter isImportDecl decls
181− findImports' :: [Maybe (Declaration, Module)]
182− findImports' = go <$> modules
183− where
184− go :: Module -> Maybe (Declaration, Module)
185− go m@(Module _ _ mn' _ (Just exps'))
186− | any isModExport exps', Just d <- find ((== mn') . importedModName) imports = Just (d, m)
187− where
188− importedModName :: Declaration -> ModuleName
189− importedModName (ImportDeclaration imn _ _) = imn
190− importedModName (PositionedDeclaration _ _ d) = importedModName d
191− importedModName _ = error "Not an import decl"
192− go _ = Nothing
193− reexports :: (Declaration, Module) -> [Declaration]
194− reexports (ImportDeclaration _ (Hiding refs) _, (Module ss' coms' mn' ds' (Just exps'))) =
195− case nonHiddenRefs of
196− [] -> []
197− _ -> reexports (ImportDeclaration mn' Implicit Nothing, Module ss' coms' mn' ds' (Just nonHiddenRefs))
198− where
199− nonHiddenRefs :: [DeclarationRef]
200− nonHiddenRefs = filter isModExport exps' \\ filter isModExport refs
201− reexports (ImportDeclaration _ ty qual, Module _ _ _ _ (Just exps')) =
202− let ty' = case ty of
203− Explicit _ -> Explicit []
204− _ -> ty
205− in (\m -> ImportDeclaration m ty' qual) <$> (catMaybes $ go <$> exps')
206− where
207− go :: DeclarationRef -> Maybe ModuleName
208− go (ModuleRef mn') = Just mn'
209− go _ = Nothing
210− reexports (PositionedDeclaration _ _ d, m@(Module _ _ _ _ (Just _))) = reexports (d, m)
211− reexports _ = []
212−
213− isModExport :: DeclarationRef -> Bool
214− isModExport (ModuleRef _) = True
215− isModExport _ = False
216−
217− -- Filters the exports for a module in the global exports environment so that only explicitly
218− -- exported members remain. If the module does not explicitly export anything, everything is
219− -- exported.
220− filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment
221− filterModuleExports env (Module _ _ mn _ (Just exps))
222− | any isSelfModuleExport exps, Just exps' <- M.lookup mn env =
223− let moduleNames = filter (/= mn) $ (\(ModuleRef mn') -> mn') <$> filter isModExport exps
224− in return $ M.insert mn (exps' {exportedModules = moduleNames}) env
225− where
226− isSelfModuleExport :: DeclarationRef -> Bool
227− isSelfModuleExport (ModuleRef mn') | mn' == mn = True
228− isSelfModuleExport (PositionedDeclarationRef _ _ ref) = isSelfModuleExport ref
229− isSelfModuleExport _ = False
230− filterModuleExports env (Module _ _ mn _ (Just exps)) = filterExports mn exps env
231− filterModuleExports env _ = return env
232−
233− -- Rename and check all the names within a module. We tweak the global exports environment so
234− -- the module has access to an unfiltered list of its own members.
235− renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module
236− renameInModule' unfilteredExports exports m@(Module _ _ mn _ _) =
50+ updateEnv :: Env -> Module -> m Env
51+ updateEnv env m@(Module ss _ mn _ refs) =
52+ case mn `M.lookup` env of
53+ Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss]
54+ Nothing -> do
55+ members <- findExportable m
56+ let env' = M.insert mn (ss, nullImports, members) env
57+ imps <- resolveImports env' m
58+ exps <- maybe (return members) (resolveExports env' mn imps members) refs
59+ return $ M.insert mn (ss, imps, exps) env
60+
61+ renameInModule' :: Env -> Module -> m Module
62+ renameInModule' env m@(Module _ _ mn _ _) =
23763 rethrow (onErrorMessages (ErrorInModule mn)) $ do
238− let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
239− let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports
240− imports <- resolveImports env m
241− elaborateImports <$> renameInModule imports env (elaborateExports exps m)
64+ let (_, imps, exps) = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn env
65+ elaborateImports <$> renameInModule env imps (elaborateExports exps m)
24266
24367-- |
244−-- Make all exports for a module explicit. This may still effect modules that have an exports list,
245−-- as it will also make all data constructor exports explicit.
68+-- Make all exports for a module explicit. This may still effect modules that
69+-- have an exports list, as it will also make all data constructor exports
70+-- explicit.
24671--
24772elaborateExports :: Exports -> Module -> Module
248−elaborateExports exps (Module ss coms mn decls _) = Module ss coms mn decls (Just $
249− map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++
250− map TypeClassRef (exportedTypeClasses exps) ++
251− map ValueRef (exportedValues exps) ++
252− map ModuleRef (exportedModules exps))
73+elaborateExports exps (Module ss coms mn decls _) =
74+ Module ss coms mn decls $
75+ Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (my exportedTypes) ++
76+ map TypeClassRef (my exportedTypeClasses) ++
77+ map ValueRef (my exportedValues)
78+ where
79+ -- Extracts a list of values from the exports and filters out any values that
80+ -- are re-exports from other modules.
81+ my :: (Exports -> [(a, ModuleName)]) -> [a]
82+ my f = fst `map` filter ((== mn) . snd) (f exps)
25383
25484-- |
25585-- Add `import X ()` for any modules where there are only fully qualified references to members.
@@ -272,14 +102,15 @@ elaborateImports (Module ss coms mn decls exps) = Module ss coms mn decls' exps
272102-- Replaces all local names with qualified names within a module and checks that all existing
273103-- qualified names are valid.
274104--
275−renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module
276−renameInModule imports exports (Module ss coms mn decls exps) =
105+renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> Imports -> Module -> m Module
106+renameInModule env imports (Module ss coms mn decls exps) =
277107 Module ss coms mn <$> parU decls go <*> pure exps
278108 where
279109 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
280110
281111 updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)
282− updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d)
112+ updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =
113+ return ((Just pos, bound), d)
283114 updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
284115 (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)
285116 updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
@@ -297,30 +128,37 @@ renameInModule imports exports (Module ss coms mn decls exps) =
297128 updateDecl s d = return (s, d)
298129
299130 updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)
300− updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v)
301− updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
131+ updateValue (_, bound) v@(PositionedValue pos' _ _) =
132+ return ((Just pos', bound), v)
133+ updateValue (pos, bound) (Abs (Left arg) val') =
134+ return ((pos, arg : bound), Abs (Left arg) val')
302135 updateValue (pos, bound) (Let ds val') = do
303− let args = mapMaybe letBoundVariable ds
304− unless (length (nub args) == length args) $
305− maybe id rethrowWithPosition pos $
306− throwError . errorMessage $ OverlappingNamesInLet
307− return ((pos, args ++ bound), Let ds val')
308− where
136+ let args = mapMaybe letBoundVariable ds
137+ unless (length (nub args) == length args) $
138+ maybe id rethrowWithPosition pos $
139+ throwError . errorMessage $ OverlappingNamesInLet
140+ return ((pos, args ++ bound), Let ds val')
309141 updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
310142 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
311143 updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =
312144 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
313− updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)
314− updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
145+ updateValue s@(pos, _) (Constructor name) =
146+ (,) s <$> (Constructor <$> updateDataConstructorName name pos)
147+ updateValue s@(pos, _) (TypedValue check val ty) =
148+ (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
315149 updateValue s v = return (s, v)
316150
317151 updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)
318− updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v)
319− updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
320− updateBinder s v = return (s, v)
152+ updateBinder (_, bound) v@(PositionedBinder pos _ _) =
153+ return ((Just pos, bound), v)
154+ updateBinder s@(pos, _) (ConstructorBinder name b) =
155+ (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
156+ updateBinder s v =
157+ return (s, v)
321158
322159 updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)
323− updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)
160+ updateCase (pos, bound) c@(CaseAlternative bs _) =
161+ return ((pos, concatMap binderNames bs ++ bound), c)
324162
325163 letBoundVariable :: Declaration -> Maybe Ident
326164 letBoundVariable (ValueDeclaration ident _ _ _) = Just ident
@@ -328,298 +166,78 @@ renameInModule imports exports (Module ss coms mn decls exps) =
328166 letBoundVariable _ = Nothing
329167
330168 updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type
331− updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)
169+ updateTypesEverywhere pos = everywhereOnTypesM updateType
332170 where
333− updateType :: Maybe SourceSpan -> Type -> m Type
334− updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
335− updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
336− updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
337− updateType _ t = return t
171+ updateType :: Type -> m Type
172+ updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
173+ updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
174+ updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
175+ updateType t = return t
338176
177+ updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]
339178 updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)
340179
341− updateTypeName = update UnknownType importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))
342− updateClassName = update UnknownTypeClass importedTypeClasses (flip elem . exportedTypeClasses)
343− updateValueName = update UnknownValue importedValues (flip elem . exportedValues)
344− updateDataConstructorName = update (flip UnknownDataConstructor Nothing) importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
180+ updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
181+ updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes)
182+
183+ updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
184+ updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes)
185+
186+ updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
187+ updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses)
188+
189+ updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)
190+ updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues)
191+
192+ -- Used when performing an update to qualify values and classes with their
193+ -- module of original definition.
194+ resolve :: (Eq a) => [(a, ModuleName)] -> a -> Maybe (Qualified a)
195+ resolve as name = mkQualified name <$> name `lookup` as
196+
197+ -- Used when performing an update to qualify types with their module of
198+ -- original definition.
199+ resolveType :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)
200+ resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys
345201
346− -- Update names so unqualified references become qualified, and locally qualified references
347− -- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)
202+ -- Used when performing an update to qualify data constructors with their
203+ -- module of original definition.
204+ resolveDctor :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)
205+ resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys
206+
207+ -- Update names so unqualified references become qualified, and locally
208+ -- qualified references are replaced with their canoncial qualified names
209+ -- (e.g. M.Map -> Data.Map.Map).
348210 update :: (Ord a, Show a) => (Qualified a -> SimpleErrorMessage)
349− -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
350− -> (Exports -> a -> Bool)
211+ -> M.Map (Qualified a) (Qualified a, ModuleName)
212+ -> (Exports -> a -> Maybe (Qualified a))
351213 -> Qualified a
352214 -> Maybe SourceSpan
353215 -> m (Qualified a)
354− update unknown getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of
355− (Just qname', _) -> return qname'
356− (Nothing, Just mn'') -> do
357− when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname
358− modExports <- getExports mn''
359− if checkE modExports name
360− then return qname
361− else throwError . errorMessage $ unknown qname
362− _ -> throwError . errorMessage $ unknown qname
216+ update unknown imps getE qname@(Qualified mn' name) pos = positioned $
217+ case (M.lookup qname imps, mn') of
218+ -- We found the name in our imports, so we return the name for it,
219+ -- qualifying with the name of the module it was originally defined in
220+ -- rather than the module we're importing from, to handle the case of
221+ -- re-exports.
222+ (Just (_, mnOrig), _) -> return $ Qualified (Just mnOrig) name
223+ -- If the name wasn't found in our imports but was qualified then we need
224+ -- to check whether it's a failed import from a "pseudo" module (created
225+ -- by qualified importing). If that's not the case, then we just need to
226+ -- check it refers to a symbol in another module.
227+ (Nothing, Just mn'') -> do
228+ when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname
229+ modExports <- getExports mn''
230+ maybe (throwError . errorMessage $ unknown qname) return (getE modExports name)
231+ -- If neither of the above cases are true then it's an undefined or
232+ -- unimported symbol.
233+ _ -> throwError . errorMessage $ unknown qname
363234 where
364235 isExplicitQualModule :: ModuleName -> Bool
365− isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')
366− imports' = getI imports
236+ isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imps)
367237 positioned err = case pos of
368238 Nothing -> err
369239 Just pos' -> rethrowWithPosition pos' err
370240
371241 -- Gets the exports for a module, or an error message if the module doesn't exist
372242 getExports :: ModuleName -> m Exports
373− getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') return $ M.lookup mn' exports
374−
375−-- |
376−-- Finds all exported declarations in a set of modules.
377−--
378−findExports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m ExportEnvironment
379−findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports
380− where
381−
382− -- The exported types from the Prim module
383− primExports = Exports (internalModuleSourceSpan "<Prim>") (mkTypeEntry `map` M.keys primTypes) [] [] []
384− where
385− mkTypeEntry (Qualified _ name) = (name, [])
386−
387− -- Add all of the exported declarations from a module to the global export environment
388− addModule :: ExportEnvironment -> Module -> m ExportEnvironment
389− addModule env (Module ss _ mn ds _) = do
390− env' <- addEmptyModule env mn ss
391− rethrow (onErrorMessages (ErrorInModule mn)) $ foldM (addDecl mn) env' ds
392−
393− -- Add a declaration from a module to the global export environment
394− addDecl :: ModuleName -> ExportEnvironment -> Declaration -> m ExportEnvironment
395− addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do
396− env' <- addTypeClass env mn tcn
397− foldM go env' ds
398− where
399− go env'' (TypeDeclaration name _) = addValue env'' mn name
400− go env'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go env'' d
401− go _ _ = error "Invalid declaration in TypeClassDeclaration"
402− addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)
403− addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
404− addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
405− addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
406− addDecl mn env (ExternDeclaration name _) = addValue env mn name
407− addDecl mn env (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ addDecl mn env d
408− addDecl _ env _ = return env
409−
410−-- |
411−-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
412−-- environment.
413−--
414−filterExports :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> ExportEnvironment -> m ExportEnvironment
415−filterExports mn exps env = do
416− let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
417− moduleExports' <- rethrow (onErrorMessages (ErrorInModule mn)) $ filterModule moduleExports
418− return $ M.insert mn moduleExports' env
419− where
420−
421− -- Filter the exports for the specific module
422− filterModule :: Exports -> m Exports
423− filterModule exported = do
424− types' <- foldM (filterTypes $ exportedTypes exported) [] exps
425− values <- foldM (filterValues $ exportedValues exported) [] exps
426− classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps
427− modules <- foldM (filterModules $ exportedModules exported) [] exps
428− return exported { exportedTypes = types', exportedTypeClasses = classes, exportedValues = values, exportedModules = modules }
429−
430− -- Ensure the exported types and data constructors exist in the module and add them to the set of
431− -- exports
432− filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> m [(ProperName, [ProperName])]
433− filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r
434− filterTypes expTys result (TypeRef name expDcons) = do
435− dcons <- maybe (throwError . errorMessage . UnknownExportType $ name) return $ name `lookup` expTys
436− dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
437− return $ (name, dcons') : result
438− filterTypes _ result _ = return result
439−
440− -- Ensure the exported data constructors exists for a type and add them to the list of exports
441− filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> m [ProperName]
442− filterDcons tcon exps' result name =
443− if name `elem` exps'
444− then return $ name : result
445− else throwError . errorMessage $ UnknownExportDataConstructor tcon name
446−
447− -- Ensure the exported classes exist in the module and add them to the set of exports
448− filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> m [ProperName]
449− filterClasses exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterClasses exps' result r
450− filterClasses exps' result (TypeClassRef name) =
451− if name `elem` exps'
452− then return $ name : result
453− else throwError . errorMessage . UnknownExportTypeClass $ name
454− filterClasses _ result _ = return result
455−
456− -- Ensure the exported values exist in the module and add them to the set of exports
457− filterValues :: [Ident] -> [Ident] -> DeclarationRef -> m [Ident]
458− filterValues exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterValues exps' result r
459− filterValues exps' result (ValueRef name) =
460− if name `elem` exps'
461− then return $ name : result
462− else throwError . errorMessage . UnknownExportValue $ name
463− filterValues _ result _ = return result
464−
465− -- Add the exported modules to the set of exports
466− filterModules :: [ModuleName] -> [ModuleName] -> DeclarationRef -> m [ModuleName]
467− filterModules exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterModules exps' result r
468− filterModules _ result (ModuleRef name) = return $ name : result
469− filterModules _ result _ = return result
470−
471−-- |
472−-- Finds the imports within a module, mapping the imported module name to an optional set of
473−-- explicitly imported declarations.
474−--
475−findImports :: [Declaration] -> M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]
476−findImports = foldl (findImports' Nothing) M.empty
477− where
478− findImports' pos result (ImportDeclaration mn typ qual) =
479− case mn `M.lookup` result of
480− Just is -> M.insert mn ((pos, typ, qual):is) result
481− Nothing -> M.insert mn [(pos, typ, qual)] result
482− findImports' _ result (PositionedDeclaration pos _ d) = findImports' (Just pos) result d
483− findImports' _ result _ = result
484−
485−-- |
486−-- Constructs a local environment for a module.
487−--
488−resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ExportEnvironment -> Module -> m ImportEnvironment
489−resolveImports env (Module _ _ currentModule decls _) =
490− censor (onErrorMessages (ErrorInModule currentModule)) $
491− foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
492− where
493−
494− -- A Map from module name to the source position for the import, the list of imports from that
495− -- module (where Nothing indicates everything is to be imported), and optionally a qualified name
496− -- for the module
497− scope :: M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]
498− scope = M.insert currentModule [(Nothing, Implicit, Nothing)] (findImports decls)
499−
500− resolveImport' :: ImportEnvironment -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) -> m ImportEnvironment
501− resolveImport' ie (mn, imps) = foldM go ie imps
502− where
503− go :: ImportEnvironment -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m ImportEnvironment
504− go ie' (pos, typ, impQual) = do
505− modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) return $ mn `M.lookup` env
506− positioned $ resolveImport currentModule mn modExports ie' impQual typ
507− where
508− positioned err = case pos of
509− Nothing -> err
510− Just pos' -> rethrowWithPosition pos' err
511−
512−-- |
513−-- Extends the local environment for a module by resolving an import of another module.
514−--
515−resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> m ImportEnvironment
516−resolveImport currentModule importModule exps imps impQual =
517− resolveByType
518− where
519−
520− resolveByType :: ImportDeclarationType -> m ImportEnvironment
521− resolveByType Implicit = importAll importExplicit
522− resolveByType (Explicit explImports) = checkedRefs explImports >> foldM importExplicit imps explImports
523− resolveByType (Hiding hiddenImports) = checkedRefs hiddenImports >> importAll (importNonHidden hiddenImports)
524−
525− importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> m ImportEnvironment
526− importNonHidden hidden m ref =
527− if isHidden hidden ref
528− then return m
529− else importExplicit m ref
530−
531− isHidden :: [DeclarationRef] -> DeclarationRef -> Bool
532− isHidden hidden ref@(TypeRef _ _) =
533− let
534− checkTypeRef _ True _ = True
535− checkTypeRef r acc (PositionedDeclarationRef _ _ h) = checkTypeRef r acc h
536− checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc
537− checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'
538− checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'
539− checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef
540− checkTypeRef _ acc _ = acc
541− in foldl (checkTypeRef ref) False hidden
542− isHidden hidden ref = ref `elem` hidden
543−
544− -- Import all symbols
545− importAll :: (ImportEnvironment -> DeclarationRef -> m ImportEnvironment) -> m ImportEnvironment
546− importAll importer = do
547− imp' <- foldM (\m (name, dctors) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)
548− imp'' <- foldM (\m name -> importer m (ValueRef name)) imp' (exportedValues exps)
549− foldM (\m name -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
550−
551− -- Import something explicitly
552− importExplicit :: ImportEnvironment -> DeclarationRef -> m ImportEnvironment
553− importExplicit imp (PositionedDeclarationRef pos _ r) =
554− rethrowWithPosition pos . warnWithPosition pos $ importExplicit imp r
555− importExplicit imp (ValueRef name) = do
556− values' <- updateImports (importedValues imp) name
557− return $ imp { importedValues = values' }
558− importExplicit imp (TypeRef name dctors) = do
559− types' <- updateImports (importedTypes imp) name
560− let allDctors = allExportedDataConstructors name
561− maybe (return ()) (mapM_ $ checkDctorExists name allDctors) dctors
562− when (null allDctors && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name
563− dctors' <- foldM updateImports (importedDataConstructors imp) (fromMaybe allDctors dctors)
564− return $ imp { importedTypes = types', importedDataConstructors = dctors' }
565− importExplicit imp (TypeClassRef name) = do
566− typeClasses' <- updateImports (importedTypeClasses imp) name
567− return $ imp { importedTypeClasses = typeClasses' }
568− importExplicit _ _ = error "Invalid argument to importExplicit"
569−
570− -- Check if DeclarationRef points to an existent symbol
571− checkedRefs :: [DeclarationRef] -> m ()
572− checkedRefs = mapM_ check
573− where
574− check (PositionedDeclarationRef pos _ r) =
575− rethrowWithPosition pos $ check r
576− check (ValueRef name) =
577− checkImportExists UnknownImportValue values name
578− check (TypeRef name dctors) = do
579− checkImportExists UnknownImportType availableTypes name
580− let allDctors = allExportedDataConstructors name
581− maybe (return ()) (mapM_ $ checkDctorExists name allDctors) dctors
582− check (TypeClassRef name) =
583− checkImportExists UnknownImportTypeClass classes name
584− check (ModuleRef name) =
585− checkImportExists (const UnknownModule) (exportedModules exps) name
586− check _ = error "Invalid argument to checkRefIsValid"
587−
588− -- Find all exported data constructors for a given type
589− allExportedDataConstructors :: ProperName -> [ProperName]
590− allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
591−
592− -- Add something to the ImportEnvironment if it does not already exist there
593− updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> m (M.Map (Qualified a) (Qualified a))
594− updateImports m name = case M.lookup (Qualified impQual name) m of
595− Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m
596− Just (Qualified Nothing _) -> error "Invalid state in updateImports"
597− Just (Qualified (Just mn) _)
598− | mn == importModule -> return m
599− | otherwise -> throwError . errorMessage $ err
600− where
601− err = if currentModule `elem` [mn, importModule]
602− then ConflictingImport (show name) importModule
603− else ConflictingImports (show name) mn importModule
604−
605−
606− -- The available values, types, and classes in the module being imported
607− values = exportedValues exps
608− availableTypes = fst `map` exportedTypes exps
609− classes = exportedTypeClasses exps
610−
611− -- Ensure that an explicitly imported data constructor exists for the type it is being imported
612− -- from
613− checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m ()
614− checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)
615−
616− -- Check that an explicitly imported item exists in the module it is being imported from
617− checkImportExists :: (Eq a, Show a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()
618− checkImportExists unknown exports item =
619− when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item
620−
621−-- |
622−-- Raises an error for when there is more than one definition for something.
623−--
624−throwConflictError :: (Applicative m, MonadError MultipleErrors m, Show a) => (a -> SimpleErrorMessage) -> a -> m b
625−throwConflictError conflict = throwError . errorMessage . conflict
243+ getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') (return . envModuleExports) $ M.lookup mn' env