@@ -40,41 +40,41 @@ type ExportEnvironment = M.Map ModuleName Exports
4040-- The exported declarations from a module.
4141--
4242data Exports = Exports
43− -- |
44− -- The types exported from each module
45− --
46− { exportedTypes :: [(ProperName, [ProperName])]
47− -- |
48− -- The classes exported from each module
49− --
50− , exportedTypeClasses :: [ProperName]
51− -- |
52− -- The values exported from each module
53− , exportedValues :: [Ident]
54− --
55− } deriving (Show)
43+ -- |
44+ -- The types exported from each module
45+ --
46+ { exportedTypes :: [(ProperName, [ProperName])]
47+ -- |
48+ -- The classes exported from each module
49+ --
50+ , exportedTypeClasses :: [ProperName]
51+ -- |
52+ -- The values exported from each module
53+ , exportedValues :: [Ident]
54+ --
55+ } deriving (Show)
5656
5757-- |
5858-- An imported environment for a particular module. This also contains the module's own members.
5959--
6060data ImportEnvironment = ImportEnvironment
61− -- |
62− -- Local names for types within a module mapped to to their qualified names
63− --
64− { importedTypes :: M.Map ProperName (Qualified ProperName)
65− -- |
66− -- Local names for data constructors within a module mapped to to their qualified names
67− --
68− , importedDataConstructors :: M.Map ProperName (Qualified ProperName)
69− -- |
70− -- Local names for classes within a module mapped to to their qualified names
71− --
72− , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
73− -- |
74− -- Local names for values within a module mapped to to their qualified names
75− --
76− , importedValues :: M.Map Ident (Qualified Ident)
77− } deriving (Show)
61+ -- |
62+ -- Local names for types within a module mapped to to their qualified names
63+ --
64+ { importedTypes :: M.Map ProperName (Qualified ProperName)
65+ -- |
66+ -- Local names for data constructors within a module mapped to to their qualified names
67+ --
68+ , importedDataConstructors :: M.Map ProperName (Qualified ProperName)
69+ -- |
70+ -- Local names for classes within a module mapped to to their qualified names
71+ --
72+ , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
73+ -- |
74+ -- Local names for values within a module mapped to to their qualified names
75+ --
76+ , importedValues :: M.Map Ident (Qualified Ident)
77+ } deriving (Show)
7878
7979-- |
8080-- Updates the exports for a module from the global environment. If the module was not previously
@@ -82,9 +82,9 @@ data ImportEnvironment = ImportEnvironment
8282--
8383updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either String Exports) -> Either String ExportEnvironment
8484updateExportedModule env mn update = do
85− let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
86− exports' <- update exports
87− return $ M.insert mn exports' env
85+ let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
86+ exports' <- update exports
87+ return $ M.insert mn exports' env
8888
8989-- |
9090-- Adds an empty module to an ExportEnvironment.
@@ -97,24 +97,24 @@ addEmptyModule env name = M.insert name (Exports [] [] []) env
9797--
9898addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment
9999addType env mn name dctors = updateExportedModule env mn $ \m -> do
100− types <- addExport (exportedTypes m) (name, dctors)
101− return $ m { exportedTypes = types }
100+ types <- addExport (exportedTypes m) (name, dctors)
101+ return $ m { exportedTypes = types }
102102
103103-- |
104104-- Adds a class to the export environment.
105105--
106106addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
107107addTypeClass env mn name = updateExportedModule env mn $ \m -> do
108− classes <- addExport (exportedTypeClasses m) name
109− return $ m { exportedTypeClasses = classes }
108+ classes <- addExport (exportedTypeClasses m) name
109+ return $ m { exportedTypeClasses = classes }
110110
111111-- |
112112-- Adds a class to the export environment.
113113--
114114addValue :: ExportEnvironment -> ModuleName -> Ident -> Either String ExportEnvironment
115115addValue env mn name = updateExportedModule env mn $ \m -> do
116− values <- addExport (exportedValues m) name
117− return $ m { exportedValues = values }
116+ values <- addExport (exportedValues m) name
117+ return $ m { exportedValues = values }
118118
119119-- |
120120-- Adds an entry to a list of exports unless it is already present, in which case an error is
@@ -122,21 +122,34 @@ addValue env mn name = updateExportedModule env mn $ \m -> do
122122--
123123addExport :: (Eq a, Show a) => [a] -> a -> Either String [a]
124124addExport exports name =
125− if name `elem` exports
126− then throwError $ "Multiple definitions for '" ++ show name ++ "'"
127− else return $ name : exports
125+ if name `elem` exports
126+ then throwError $ "Multiple definitions for '" ++ show name ++ "'"
127+ else return $ name : exports
128128
129129-- |
130130-- Replaces all local names with qualified names within a set of modules.
131131--
132132desugarImports :: [Module] -> Either String [Module]
133133desugarImports modules = do
134− exports <- findExports modules
135− mapM (renameInModule' exports) modules
136− where
137− renameInModule' exports m = rethrowForModule m $ do
138− imports <- resolveImports exports m
139− renameInModule imports exports m
134+ unfilteredExports <- findExports modules
135+ exports <- foldM filterModuleExports unfilteredExports modules
136+ mapM (renameInModule' unfilteredExports exports) modules
137+ where
138+
139+ -- Filters the exports for a module in the global exports environment so that only explicitly
140+ -- exported members remain. If the module does not explicitly export anything, everything is
141+ -- exported.
142+ filterModuleExports :: ExportEnvironment -> Module -> Either String ExportEnvironment
143+ filterModuleExports env (Module mn _ (Just exps)) = filterExports mn exps env
144+ filterModuleExports env _ = return env
145+
146+ -- Rename and check all the names within a module. We tweak the global exports environment so
147+ -- the module has access to an unfiltered list of its own members.
148+ renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either String Module
149+ renameInModule' unfilteredExports exports m@(Module mn _ _) = rethrowForModule m $ do
150+ let exports' = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
151+ imports <- resolveImports exports' m
152+ renameInModule imports exports' m
140153
141154-- |
142155-- Rethrow an error with the name of the current module in the case of a failure
@@ -150,101 +163,98 @@ rethrowForModule (Module mn _ _) = flip catchError $ \e -> throwError ("Error in
150163--
151164renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module
152165renameInModule imports exports (Module mn decls exps) =
153− Module mn <$> (mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)) <*> pure exps
166+ Module mn <$> (mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)) <*> pure exps
167+ where
168+ updateDecl (TypeInstanceDeclaration name cs cn ts ds) =
169+ TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds
170+ updateDecl d = return d
171+
172+ updateVars :: Declaration -> Either String Declaration
173+ updateVars (ValueDeclaration name [] Nothing val) =
174+ ValueDeclaration name [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
154175 where
155− updateDecl (TypeInstanceDeclaration name cs cn ts ds) =
156− TypeInstanceDeclaration name <$> 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 name'@(Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName name')
165− bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) = (,) bound <$> (Var <$> updateValueName name')
166− bindFunctionArgs bound other = return (bound, other)
167− bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)
168− bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)
169− updateVars (ValueDeclaration name _ _ _) = error $ "Binders should have been desugared in " ++ show name
170− updateVars other = return other
171− updateValue (Constructor name) = Constructor <$> updateDataConstructorName name
172− updateValue v = return v
173− updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b
174− updateBinder v = return v
175− updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name
176− updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys
177− updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t
178− updateType t = return t
179− updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
180−
181− updateTypeName (Qualified Nothing name) = update "type" importedTypes name
182− updateTypeName (Qualified (Just mn') name) = do
183− modExports <- getExports mn'
184− case name `lookup` exportedTypes modExports of
185− Nothing -> throwError $ "Unknown type '" ++ show (Qualified (Just mn') name) ++ "'"
186− _ -> return $ Qualified (Just mn') name
187−
188− updateDataConstructorName (Qualified Nothing name) = update "data constructor" importedDataConstructors name
189− updateDataConstructorName (Qualified (Just mn') name) = do
190− modExports <- getExports mn'
191− let allDcons = join $ snd `map` exportedTypes modExports
192− if name `elem` allDcons
193− then return $ Qualified (Just mn') name
194− else throwError $ "Unknown data constructor '" ++ show (Qualified (Just mn') name) ++ "'"
195−
196− updateClassName (Qualified Nothing name) = update "type class" importedTypeClasses name
197− updateClassName (Qualified (Just mn') name) = check "type class" exportedTypeClasses mn' name
198−
199− updateValueName (Qualified Nothing name) = update "value" importedValues name
200− updateValueName (Qualified (Just mn') name) = check "value" exportedValues mn' name
201−
202− -- Replace an unqualified name with a qualified
203− update :: (Ord a, Show a) => String -> (ImportEnvironment -> M.Map a (Qualified a)) -> a -> Either String (Qualified a)
204− update t get name = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'") return $ M.lookup name (get imports)
205−
206− -- Check that a qualified name is valid
207− check :: (Show a, Eq a) => String -> (Exports -> [a]) -> ModuleName -> a -> Either String (Qualified a)
208− check t get mn' name = do
209− modExports <- getExports mn'
210− if name `elem` get modExports
211− then return $ Qualified (Just mn') name
212− else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn') name) ++ "'"
213−
214− -- Gets the exports for a module, or an error message if the module doesn't exist
215− getExports :: ModuleName -> Either String Exports
216− getExports mn' = maybe (throwError $ "Unknown module '" ++ show mn' ++ "'") return $ M.lookup mn' exports
176+ bindFunctionArgs bound (Abs (Left arg) val') = return (arg : bound, Abs (Left arg) val')
177+ bindFunctionArgs bound (Var name'@(Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName name')
178+ bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) = (,) bound <$> (Var <$> updateValueName name')
179+ bindFunctionArgs bound other = return (bound, other)
180+ bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)
181+ bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)
182+ updateVars (ValueDeclaration name _ _ _) = error $ "Binders should have been desugared in " ++ show name
183+ updateVars other = return other
184+ updateValue (Constructor name) = Constructor <$> updateDataConstructorName name
185+ updateValue v = return v
186+ updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b
187+ updateBinder v = return v
188+ updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name
189+ updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys
190+ updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t
191+ updateType t = return t
192+ updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
193+
194+ updateTypeName (Qualified Nothing name) = update "type" importedTypes name
195+ updateTypeName (Qualified (Just mn') name) = do
196+ modExports <- getExports mn'
197+ case name `lookup` exportedTypes modExports of
198+ Nothing -> throwError $ "Unknown type '" ++ show (Qualified (Just mn') name) ++ "'"
199+ _ -> return $ Qualified (Just mn') name
200+
201+ updateDataConstructorName (Qualified Nothing name) = update "data constructor" importedDataConstructors name
202+ updateDataConstructorName (Qualified (Just mn') name) = do
203+ modExports <- getExports mn'
204+ let allDcons = join $ snd `map` exportedTypes modExports
205+ if name `elem` allDcons
206+ then return $ Qualified (Just mn') name
207+ else throwError $ "Unknown data constructor '" ++ show (Qualified (Just mn') name) ++ "'"
208+
209+ updateClassName (Qualified Nothing name) = update "type class" importedTypeClasses name
210+ updateClassName (Qualified (Just mn') name) = check "type class" exportedTypeClasses mn' name
211+
212+ updateValueName (Qualified Nothing name) = update "value" importedValues name
213+ updateValueName (Qualified (Just mn') name) = check "value" exportedValues mn' name
214+
215+ -- Replace an unqualified name with a qualified
216+ update :: (Ord a, Show a) => String -> (ImportEnvironment -> M.Map a (Qualified a)) -> a -> Either String (Qualified a)
217+ update t get name = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'") return $ M.lookup name (get imports)
218+
219+ -- Check that a qualified name is valid
220+ check :: (Show a, Eq a) => String -> (Exports -> [a]) -> ModuleName -> a -> Either String (Qualified a)
221+ check t get mn' name = do
222+ modExports <- getExports mn'
223+ if name `elem` get modExports
224+ then return $ Qualified (Just mn') name
225+ else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn') name) ++ "'"
226+
227+ -- Gets the exports for a module, or an error message if the module doesn't exist
228+ getExports :: ModuleName -> Either String Exports
229+ getExports mn' = maybe (throwError $ "Unknown module '" ++ show mn' ++ "'") return $ M.lookup mn' exports
217230
218231-- |
219232-- Finds all exported declarations in a set of modules.
220233--
221234findExports :: [Module] -> Either String ExportEnvironment
222235findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) primExports
223− where
236+ where
224237
225− -- The exported types from the Prim module
226− primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
227− where
228− mkTypeEntry (Qualified _ name) = (name, [])
229−
230− -- Add all of the exported declarations from a module to the global export environment
231− addModule :: ExportEnvironment -> Module -> Either String ExportEnvironment
232− addModule env m@(Module mn ds Nothing) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds
233− addModule env m@(Module mn ds (Just exps)) = rethrowForModule m $ do
234− env' <- foldM (addDecl mn) (addEmptyModule env mn) ds
235− filterExports mn exps env'
236−
237− -- Add a declaration from a module to the global export environment
238− addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either String ExportEnvironment
239− addDecl mn env (TypeClassDeclaration tcn _ ds) = do
240− env' <- addTypeClass env mn tcn
241− foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds
242− addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)
243− addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
244− addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
245− addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
246− addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
247− addDecl _ env _ = return env
238+ -- The exported types from the Prim module
239+ primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
240+ where
241+ mkTypeEntry (Qualified _ name) = (name, [])
242+
243+ -- Add all of the exported declarations from a module to the global export environment
244+ addModule :: ExportEnvironment -> Module -> Either String ExportEnvironment
245+ addModule env m@(Module mn ds _) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds
246+
247+ -- Add a declaration from a module to the global export environment
248+ addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either String ExportEnvironment
249+ addDecl mn env (TypeClassDeclaration tcn _ ds) = do
250+ env' <- addTypeClass env mn tcn
251+ foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds
252+ addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)
253+ addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
254+ addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
255+ addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
256+ addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
257+ addDecl _ env _ = return env
248258
249259-- |
250260-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
@@ -308,86 +318,84 @@ type ExplicitImports = [DeclarationRef]
308318--
309319findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports)
310320findImports = foldl findImports' M.empty
311− where
312− findImports' result (ImportDeclaration mn expl) = M.insert mn expl result
313− findImports' result _ = result
321+ where
322+ findImports' result (ImportDeclaration mn expl) = M.insert mn expl result
323+ findImports' result _ = result
314324
315325-- |
316326-- Constructs a local environment for a module.
317327--
318328resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
319329resolveImports env (Module currentModule decls _) =
320− foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
321− where
322− -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported
323− scope :: M.Map ModuleName (Maybe ExplicitImports)
324− scope = M.insert currentModule Nothing (findImports decls)
325− resolveImport' imp (mn, i) = do
326− m <- maybe (throwError $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env
327− resolveImport currentModule mn m imp i
330+ foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
331+ where
332+ -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported
333+ scope :: M.Map ModuleName (Maybe ExplicitImports)
334+ scope = M.insert currentModule Nothing (findImports decls)
335+ resolveImport' imp (mn, i) = do
336+ m <- maybe (throwError $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env
337+ resolveImport currentModule mn m imp i
328338
329339-- |
330340-- Extends the local environment for a module by resolving an import of another module.
331341--
332342resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ExplicitImports -> Either String ImportEnvironment
333−resolveImport currentModule importModule exps imps i = case i of
334− Nothing -> importAll
335− Just expl -> foldM importExplicit imps expl
336− where
343+resolveImport currentModule importModule exps imps = maybe importAll (foldM importExplicit imps)
344+ where
337345
338− -- Import everything from a module
339− importAll :: Either String ImportEnvironment
340− importAll = do
341− imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeRef name (Just dctors))) imps (exportedTypes exps)
342− imp'' <- foldM (\m name -> importExplicit m (ValueRef name)) imp' (exportedValues exps)
343− foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
344−
345− -- Import something explicitly
346− importExplicit :: ImportEnvironment -> DeclarationRef -> Either String ImportEnvironment
347− importExplicit imp (ValueRef name) = do
348− _ <- checkImportExists "value" values name
349− values' <- updateImports (importedValues imp) name
350− return $ imp { importedValues = values' }
351− importExplicit imp (TypeRef name dctors) = do
352− _ <- checkImportExists "type" types name
353− types' <- updateImports (importedTypes imp) name
354− let allDctors = allExportedDataConstructors name
355− dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
356− dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
357− return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
358− importExplicit imp (TypeClassRef name) = do
359− _ <- checkImportExists "type class" classes name
360− typeClasses' <- updateImports (importedTypeClasses imp) name
361− return $ imp { importedTypeClasses = typeClasses' }
362−
363− -- Find all exported data constructors for a given type
364− allExportedDataConstructors :: ProperName -> [ProperName]
365− allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
366−
367− -- Add something to the ImportEnvironment if it does not already exist there
368− updateImports :: (Ord a, Show a) => M.Map a (Qualified a) -> a -> Either String (M.Map a (Qualified a))
369− updateImports m name = case M.lookup name m of
370− Nothing -> return $ M.insert name (Qualified (Just importModule) name) m
371− Just (Qualified Nothing _) -> error "Invalid state in updateImports"
372− Just x@(Qualified (Just mn) _) -> throwError $
373− if mn == currentModule || importModule == currentModule
374− then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"
375− else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
376−
377− -- The available values, types, and classes in the module being imported
378− values = exportedValues exps
379− types = fst `map` exportedTypes exps
380− classes = exportedTypeClasses exps
381−
382− -- Ensure that an explicitly imported data constructor exists for the type it is being imported
383− -- from
384− checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName
385− checkDctorExists = checkImportExists "data constructor"
386−
387− -- Check that an explicitly imported item exists in the module it is being imported from
388− checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either String a
389− checkImportExists t exports item =
390− if item `elem` exports
391− then return item
392− else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'"
346+ -- Import everything from a module
347+ importAll :: Either String ImportEnvironment
348+ importAll = do
349+ imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeRef name (Just dctors))) imps (exportedTypes exps)
350+ imp'' <- foldM (\m name -> importExplicit m (ValueRef name)) imp' (exportedValues exps)
351+ foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
352+
353+ -- Import something explicitly
354+ importExplicit :: ImportEnvironment -> DeclarationRef -> Either String ImportEnvironment
355+ importExplicit imp (ValueRef name) = do
356+ _ <- checkImportExists "value" values name
357+ values' <- updateImports (importedValues imp) name
358+ return $ imp { importedValues = values' }
359+ importExplicit imp (TypeRef name dctors) = do
360+ _ <- checkImportExists "type" types name
361+ types' <- updateImports (importedTypes imp) name
362+ let allDctors = allExportedDataConstructors name
363+ dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
364+ dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
365+ return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
366+ importExplicit imp (TypeClassRef name) = do
367+ _ <- checkImportExists "type class" classes name
368+ typeClasses' <- updateImports (importedTypeClasses imp) name
369+ return $ imp { importedTypeClasses = typeClasses' }
370+
371+ -- Find all exported data constructors for a given type
372+ allExportedDataConstructors :: ProperName -> [ProperName]
373+ allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
374+
375+ -- Add something to the ImportEnvironment if it does not already exist there
376+ updateImports :: (Ord a, Show a) => M.Map a (Qualified a) -> a -> Either String (M.Map a (Qualified a))
377+ updateImports m name = case M.lookup name m of
378+ Nothing -> return $ M.insert name (Qualified (Just importModule) name) m
379+ Just (Qualified Nothing _) -> error "Invalid state in updateImports"
380+ Just x@(Qualified (Just mn) _) -> throwError $
381+ if mn == currentModule || importModule == currentModule
382+ then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"
383+ else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
384+
385+ -- The available values, types, and classes in the module being imported
386+ values = exportedValues exps
387+ types = fst `map` exportedTypes exps
388+ classes = exportedTypeClasses exps
389+
390+ -- Ensure that an explicitly imported data constructor exists for the type it is being imported
391+ -- from
392+ checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName
393+ checkDctorExists = checkImportExists "data constructor"
394+
395+ -- Check that an explicitly imported item exists in the module it is being imported from
396+ checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either String a
397+ checkImportExists t exports item =
398+ if item `elem` exports
399+ then return item
400+ else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'"
393401