@@ -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,21 @@ 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+ 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
140140
141141-- |
142142-- Rethrow an error with the name of the current module in the case of a failure
@@ -150,101 +150,101 @@ rethrowForModule (Module mn _ _) = flip catchError $ \e -> throwError ("Error in
150150--
151151renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module
152152renameInModule imports exports (Module mn decls exps) =
153− Module mn <$> (mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)) <*> pure exps
153+ Module mn <$> (mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)) <*> pure exps
154+ 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
154162 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
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
217217
218218-- |
219219-- Finds all exported declarations in a set of modules.
220220--
221221findExports :: [Module] -> Either String ExportEnvironment
222222findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) primExports
223− where
223+ where
224224
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
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
248248
249249-- |
250250-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
@@ -308,86 +308,86 @@ type ExplicitImports = [DeclarationRef]
308308--
309309findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports)
310310findImports = foldl findImports' M.empty
311− where
312− findImports' result (ImportDeclaration mn expl) = M.insert mn expl result
313− findImports' result _ = result
311+ where
312+ findImports' result (ImportDeclaration mn expl) = M.insert mn expl result
313+ findImports' result _ = result
314314
315315-- |
316316-- Constructs a local environment for a module.
317317--
318318resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
319319resolveImports 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
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
328328
329329-- |
330330-- Extends the local environment for a module by resolving an import of another module.
331331--
332332resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ExplicitImports -> Either String ImportEnvironment
333333resolveImport currentModule importModule exps imps i = case i of
334− Nothing -> importAll
335− Just expl -> foldM importExplicit imps expl
336− where
334+ Nothing -> importAll
335+ Just expl -> foldM importExplicit imps expl
336+ where
337337
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) ++ "'"
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) ++ "'"
393393