git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #249 from garyb/master
a6c9172Phil Freeman
examples/passing/ExportExplicit2.pursnew file+15
compare with golang
unifiedsplit
@@ -0,0 +1,15 @@
1+module M1 (bar) where
2+
3+ foo :: Number
4+ foo = 0
5+
6+ bar :: Number
7+ bar = foo
8+
9+module Main where
10+
11+ import M1
12+
13+ testBar = bar
14+
15+ main = Debug.Trace.trace "Done"
src/Language/PureScript/Sugar/Names.hs+213−205
@@ -40,41 +40,41 @@ type ExportEnvironment = M.Map ModuleName Exports
40-- The exported declarations from a module.
40-- The exported declarations from a module.
41--
41--
42data Exports = Exports
42data Exports = Exports
43− -- |
43+ -- |
44− -- The types exported from each module
44+ -- The types exported from each module
45− --
45+ --
46− { exportedTypes :: [(ProperName, [ProperName])]
46+ { exportedTypes :: [(ProperName, [ProperName])]
47− -- |
47+ -- |
48− -- The classes exported from each module
48+ -- The classes exported from each module
49− --
49+ --
50− , exportedTypeClasses :: [ProperName]
50+ , exportedTypeClasses :: [ProperName]
51− -- |
51+ -- |
52− -- The values exported from each module
52+ -- The values exported from each module
53− , exportedValues :: [Ident]
53+ , exportedValues :: [Ident]
54− --
54+ --
55− } deriving (Show)
55+ } deriving (Show)
56
56
57-- |
57-- |
58-- An imported environment for a particular module. This also contains the module's own members.
58-- An imported environment for a particular module. This also contains the module's own members.
59--
59--
60data ImportEnvironment = ImportEnvironment
60data ImportEnvironment = ImportEnvironment
61− -- |
61+ -- |
62− -- Local names for types within a module mapped to to their qualified names
62+ -- Local names for types within a module mapped to to their qualified names
63− --
63+ --
64− { importedTypes :: M.Map ProperName (Qualified ProperName)
64+ { importedTypes :: M.Map ProperName (Qualified ProperName)
65− -- |
65+ -- |
66− -- Local names for data constructors within a module mapped to to their qualified names
66+ -- Local names for data constructors within a module mapped to to their qualified names
67− --
67+ --
68− , importedDataConstructors :: M.Map ProperName (Qualified ProperName)
68+ , importedDataConstructors :: M.Map ProperName (Qualified ProperName)
69− -- |
69+ -- |
70− -- Local names for classes within a module mapped to to their qualified names
70+ -- Local names for classes within a module mapped to to their qualified names
71− --
71+ --
72− , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
72+ , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
73− -- |
73+ -- |
74− -- Local names for values within a module mapped to to their qualified names
74+ -- Local names for values within a module mapped to to their qualified names
75− --
75+ --
76− , importedValues :: M.Map Ident (Qualified Ident)
76+ , importedValues :: M.Map Ident (Qualified Ident)
77− } deriving (Show)
77+ } deriving (Show)
78
78
79-- |
79-- |
80-- Updates the exports for a module from the global environment. If the module was not previously
80-- Updates the exports for a module from the global environment. If the module was not previously
@@ -82,9 +82,9 @@ data ImportEnvironment = ImportEnvironment
82--
82--
83updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either String Exports) -> Either String ExportEnvironment
83updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either String Exports) -> Either String ExportEnvironment
84updateExportedModule env mn update = do
84updateExportedModule env mn update = do
85− let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
85+ let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
86− exports' <- update exports
86+ exports' <- update exports
87− return $ M.insert mn exports' env
87+ return $ M.insert mn exports' env
88
88
89-- |
89-- |
90-- Adds an empty module to an ExportEnvironment.
90-- Adds an empty module to an ExportEnvironment.
@@ -97,24 +97,24 @@ addEmptyModule env name = M.insert name (Exports [] [] []) env
97--
97--
98addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment
98addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment
99addType env mn name dctors = updateExportedModule env mn $ \m -> do
99addType env mn name dctors = updateExportedModule env mn $ \m -> do
100− types <- addExport (exportedTypes m) (name, dctors)
100+ types <- addExport (exportedTypes m) (name, dctors)
101− return $ m { exportedTypes = types }
101+ return $ m { exportedTypes = types }
102
102
103-- |
103-- |
104-- Adds a class to the export environment.
104-- Adds a class to the export environment.
105--
105--
106addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
106addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
107addTypeClass env mn name = updateExportedModule env mn $ \m -> do
107addTypeClass env mn name = updateExportedModule env mn $ \m -> do
108− classes <- addExport (exportedTypeClasses m) name
108+ classes <- addExport (exportedTypeClasses m) name
109− return $ m { exportedTypeClasses = classes }
109+ return $ m { exportedTypeClasses = classes }
110
110
111-- |
111-- |
112-- Adds a class to the export environment.
112-- Adds a class to the export environment.
113--
113--
114addValue :: ExportEnvironment -> ModuleName -> Ident -> Either String ExportEnvironment
114addValue :: ExportEnvironment -> ModuleName -> Ident -> Either String ExportEnvironment
115addValue env mn name = updateExportedModule env mn $ \m -> do
115addValue env mn name = updateExportedModule env mn $ \m -> do
116− values <- addExport (exportedValues m) name
116+ values <- addExport (exportedValues m) name
117− return $ m { exportedValues = values }
117+ return $ m { exportedValues = values }
118
118
119-- |
119-- |
120-- Adds an entry to a list of exports unless it is already present, in which case an error is
120-- 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
122--
122--
123addExport :: (Eq a, Show a) => [a] -> a -> Either String [a]
123addExport :: (Eq a, Show a) => [a] -> a -> Either String [a]
124addExport exports name =
124addExport exports name =
125− if name `elem` exports
125+ if name `elem` exports
126− then throwError $ "Multiple definitions for '" ++ show name ++ "'"
126+ then throwError $ "Multiple definitions for '" ++ show name ++ "'"
127− else return $ name : exports
127+ else return $ name : exports
128
128
129-- |
129-- |
130-- Replaces all local names with qualified names within a set of modules.
130-- Replaces all local names with qualified names within a set of modules.
131--
131--
132desugarImports :: [Module] -> Either String [Module]
132desugarImports :: [Module] -> Either String [Module]
133desugarImports modules = do
133desugarImports modules = do
134− exports <- findExports modules
134+ unfilteredExports <- findExports modules
135+ exports <- foldM filterModuleExports unfilteredExports modules
135− mapM (renameInModule' exports) modules
136+ mapM (renameInModule' unfilteredExports exports) modules
136− where
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
137− renameInModule' exports m = rethrowForModule m $ do
149+ renameInModule' unfilteredExports exports m@(Module mn _ _) = rethrowForModule m $ do
150+ let exports' = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
138− imports <- resolveImports exports m
151+ imports <- resolveImports exports' m
139− renameInModule imports exports m
152+ renameInModule imports exports' m
140
153
141-- |
154-- |
142-- Rethrow an error with the name of the current module in the case of a failure
155-- 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
150--
163--
151renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module
164renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module
152renameInModule imports exports (Module mn decls exps) =
165renameInModule 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
154 where
175 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')
176+ 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')
177+ 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')
178+ bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) = (,) bound <$> (Var <$> updateValueName name')
166− bindFunctionArgs bound other = return (bound, other)
179+ bindFunctionArgs bound other = return (bound, other)
167− bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)
180+ bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)
168− bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)
181+ bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)
169− updateVars (ValueDeclaration name _ _ _) = error $ "Binders should have been desugared in " ++ show name
182+ updateVars (ValueDeclaration name _ _ _) = error $ "Binders should have been desugared in " ++ show name
170− updateVars other = return other
183+ updateVars other = return other
171− updateValue (Constructor name) = Constructor <$> updateDataConstructorName name
184+ updateValue (Constructor name) = Constructor <$> updateDataConstructorName name
172− updateValue v = return v
185+ updateValue v = return v
173− updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b
186+ updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b
174− updateBinder v = return v
187+ updateBinder v = return v
175− updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name
188+ updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name
176− updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys
189+ updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys
177− updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t
190+ updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t
178− updateType t = return t
191+ updateType t = return t
179− updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
192+ updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
180−
193+
181− updateTypeName (Qualified Nothing name) = update "type" importedTypes name
194+ updateTypeName (Qualified Nothing name) = update "type" importedTypes name
182− updateTypeName (Qualified (Just mn') name) = do
195+ updateTypeName (Qualified (Just mn') name) = do
183− modExports <- getExports mn'
196+ modExports <- getExports mn'
184− case name `lookup` exportedTypes modExports of
197+ case name `lookup` exportedTypes modExports of
185− Nothing -> throwError $ "Unknown type '" ++ show (Qualified (Just mn') name) ++ "'"
198+ Nothing -> throwError $ "Unknown type '" ++ show (Qualified (Just mn') name) ++ "'"
186− _ -> return $ Qualified (Just mn') name
199+ _ -> return $ Qualified (Just mn') name
187−
200+
188− updateDataConstructorName (Qualified Nothing name) = update "data constructor" importedDataConstructors name
201+ updateDataConstructorName (Qualified Nothing name) = update "data constructor" importedDataConstructors name
189− updateDataConstructorName (Qualified (Just mn') name) = do
202+ updateDataConstructorName (Qualified (Just mn') name) = do
190− modExports <- getExports mn'
203+ modExports <- getExports mn'
191− let allDcons = join $ snd `map` exportedTypes modExports
204+ let allDcons = join $ snd `map` exportedTypes modExports
192− if name `elem` allDcons
205+ if name `elem` allDcons
193− then return $ Qualified (Just mn') name
206+ then return $ Qualified (Just mn') name
194− else throwError $ "Unknown data constructor '" ++ show (Qualified (Just mn') name) ++ "'"
207+ else throwError $ "Unknown data constructor '" ++ show (Qualified (Just mn') name) ++ "'"
195−
208+
196− updateClassName (Qualified Nothing name) = update "type class" importedTypeClasses name
209+ updateClassName (Qualified Nothing name) = update "type class" importedTypeClasses name
197− updateClassName (Qualified (Just mn') name) = check "type class" exportedTypeClasses mn' name
210+ updateClassName (Qualified (Just mn') name) = check "type class" exportedTypeClasses mn' name
198−
211+
199− updateValueName (Qualified Nothing name) = update "value" importedValues name
212+ updateValueName (Qualified Nothing name) = update "value" importedValues name
200− updateValueName (Qualified (Just mn') name) = check "value" exportedValues mn' name
213+ updateValueName (Qualified (Just mn') name) = check "value" exportedValues mn' name
201−
214+
202− -- Replace an unqualified name with a qualified
215+ -- 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)
216+ 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)
217+ update t get name = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'") return $ M.lookup name (get imports)
205−
218+
206− -- Check that a qualified name is valid
219+ -- Check that a qualified name is valid
207− check :: (Show a, Eq a) => String -> (Exports -> [a]) -> ModuleName -> a -> Either String (Qualified a)
220+ check :: (Show a, Eq a) => String -> (Exports -> [a]) -> ModuleName -> a -> Either String (Qualified a)
208− check t get mn' name = do
221+ check t get mn' name = do
209− modExports <- getExports mn'
222+ modExports <- getExports mn'
210− if name `elem` get modExports
223+ if name `elem` get modExports
211− then return $ Qualified (Just mn') name
224+ then return $ Qualified (Just mn') name
212− else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn') name) ++ "'"
225+ else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn') name) ++ "'"
213−
226+
214− -- Gets the exports for a module, or an error message if the module doesn't exist
227+ -- Gets the exports for a module, or an error message if the module doesn't exist
215− getExports :: ModuleName -> Either String Exports
228+ getExports :: ModuleName -> Either String Exports
216− getExports mn' = maybe (throwError $ "Unknown module '" ++ show mn' ++ "'") return $ M.lookup mn' exports
229+ getExports mn' = maybe (throwError $ "Unknown module '" ++ show mn' ++ "'") return $ M.lookup mn' exports
217
230
218-- |
231-- |
219-- Finds all exported declarations in a set of modules.
232-- Finds all exported declarations in a set of modules.
220--
233--
221findExports :: [Module] -> Either String ExportEnvironment
234findExports :: [Module] -> Either String ExportEnvironment
222findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) primExports
235findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) primExports
223− where
236+ where
224
237
225− -- The exported types from the Prim module
238+ -- The exported types from the Prim module
226− primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
239+ primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
227− where
240+ where
228− mkTypeEntry (Qualified _ name) = (name, [])
241+ mkTypeEntry (Qualified _ name) = (name, [])
229−
242+
230− -- Add all of the exported declarations from a module to the global export environment
243+ -- Add all of the exported declarations from a module to the global export environment
231− addModule :: ExportEnvironment -> Module -> Either String ExportEnvironment
244+ 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
245+ addModule env m@(Module mn ds _) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds
234− env' <- foldM (addDecl mn) (addEmptyModule env mn) ds
246+
235− filterExports mn exps env'
236−
237− -- Add a declaration from a module to the global export environment
247+ -- Add a declaration from a module to the global export environment
238− addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either String ExportEnvironment
248+ addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either String ExportEnvironment
239− addDecl mn env (TypeClassDeclaration tcn _ ds) = do
249+ addDecl mn env (TypeClassDeclaration tcn _ ds) = do
240− env' <- addTypeClass env mn tcn
250+ env' <- addTypeClass env mn tcn
241− foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds
251+ foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds
242− addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)
252+ addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)
243− addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
253+ addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
244− addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
254+ addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
245− addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
255+ addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
246− addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
256+ addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
247− addDecl _ env _ = return env
257+ addDecl _ env _ = return env
248
258
249-- |
259-- |
250-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
260-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
@@ -308,86 +318,84 @@ type ExplicitImports = [DeclarationRef]
308--
318--
309findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports)
319findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports)
310findImports = foldl findImports' M.empty
320findImports = foldl findImports' M.empty
311− where
321+ where
312− findImports' result (ImportDeclaration mn expl) = M.insert mn expl result
322+ findImports' result (ImportDeclaration mn expl) = M.insert mn expl result
313− findImports' result _ = result
323+ findImports' result _ = result
314
324
315-- |
325-- |
316-- Constructs a local environment for a module.
326-- Constructs a local environment for a module.
317--
327--
318resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
328resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
319resolveImports env (Module currentModule decls _) =
329resolveImports env (Module currentModule decls _) =
320− foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
330+ foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
321− where
331+ where
322− -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported
332+ -- 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)
333+ scope :: M.Map ModuleName (Maybe ExplicitImports)
324− scope = M.insert currentModule Nothing (findImports decls)
334+ scope = M.insert currentModule Nothing (findImports decls)
325− resolveImport' imp (mn, i) = do
335+ resolveImport' imp (mn, i) = do
326− m <- maybe (throwError $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env
336+ m <- maybe (throwError $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env
327− resolveImport currentModule mn m imp i
337+ resolveImport currentModule mn m imp i
328
338
329-- |
339-- |
330-- Extends the local environment for a module by resolving an import of another module.
340-- Extends the local environment for a module by resolving an import of another module.
331--
341--
332resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ExplicitImports -> Either String ImportEnvironment
342resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ExplicitImports -> Either String ImportEnvironment
333−resolveImport currentModule importModule exps imps i = case i of
343+resolveImport currentModule importModule exps imps = maybe importAll (foldM importExplicit imps)
334− Nothing -> importAll
335− Just expl -> foldM importExplicit imps expl
336− where
344+ where
337
345
338− -- Import everything from a module
346+ -- Import everything from a module
339− importAll :: Either String ImportEnvironment
347+ importAll :: Either String ImportEnvironment
340− importAll = do
348+ importAll = do
341− imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeRef name (Just dctors))) imps (exportedTypes exps)
349+ 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)
350+ imp'' <- foldM (\m name -> importExplicit m (ValueRef name)) imp' (exportedValues exps)
343− foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
351+ foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
344−
352+
345− -- Import something explicitly
353+ -- Import something explicitly
346− importExplicit :: ImportEnvironment -> DeclarationRef -> Either String ImportEnvironment
354+ importExplicit :: ImportEnvironment -> DeclarationRef -> Either String ImportEnvironment
347− importExplicit imp (ValueRef name) = do
355+ importExplicit imp (ValueRef name) = do
348− _ <- checkImportExists "value" values name
356+ _ <- checkImportExists "value" values name
349− values' <- updateImports (importedValues imp) name
357+ values' <- updateImports (importedValues imp) name
350− return $ imp { importedValues = values' }
358+ return $ imp { importedValues = values' }
351− importExplicit imp (TypeRef name dctors) = do
359+ importExplicit imp (TypeRef name dctors) = do
352− _ <- checkImportExists "type" types name
360+ _ <- checkImportExists "type" types name
353− types' <- updateImports (importedTypes imp) name
361+ types' <- updateImports (importedTypes imp) name
354− let allDctors = allExportedDataConstructors name
362+ let allDctors = allExportedDataConstructors name
355− dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
363+ dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
356− dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
364+ dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
357− return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
365+ return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
358− importExplicit imp (TypeClassRef name) = do
366+ importExplicit imp (TypeClassRef name) = do
359− _ <- checkImportExists "type class" classes name
367+ _ <- checkImportExists "type class" classes name
360− typeClasses' <- updateImports (importedTypeClasses imp) name
368+ typeClasses' <- updateImports (importedTypeClasses imp) name
361− return $ imp { importedTypeClasses = typeClasses' }
369+ return $ imp { importedTypeClasses = typeClasses' }
362−
370+
363− -- Find all exported data constructors for a given type
371+ -- Find all exported data constructors for a given type
364− allExportedDataConstructors :: ProperName -> [ProperName]
372+ allExportedDataConstructors :: ProperName -> [ProperName]
365− allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
373+ allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
366−
374+
367− -- Add something to the ImportEnvironment if it does not already exist there
375+ -- 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))
376+ 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
377+ updateImports m name = case M.lookup name m of
370− Nothing -> return $ M.insert name (Qualified (Just importModule) name) m
378+ Nothing -> return $ M.insert name (Qualified (Just importModule) name) m
371− Just (Qualified Nothing _) -> error "Invalid state in updateImports"
379+ Just (Qualified Nothing _) -> error "Invalid state in updateImports"
372− Just x@(Qualified (Just mn) _) -> throwError $
380+ Just x@(Qualified (Just mn) _) -> throwError $
373− if mn == currentModule || importModule == currentModule
381+ if mn == currentModule || importModule == currentModule
374− then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"
382+ 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) ++ "'"
383+ else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
376−
384+
377− -- The available values, types, and classes in the module being imported
385+ -- The available values, types, and classes in the module being imported
378− values = exportedValues exps
386+ values = exportedValues exps
379− types = fst `map` exportedTypes exps
387+ types = fst `map` exportedTypes exps
380− classes = exportedTypeClasses exps
388+ classes = exportedTypeClasses exps
381−
389+
382− -- Ensure that an explicitly imported data constructor exists for the type it is being imported
390+ -- Ensure that an explicitly imported data constructor exists for the type it is being imported
383− -- from
391+ -- from
384− checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName
392+ checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName
385− checkDctorExists = checkImportExists "data constructor"
393+ checkDctorExists = checkImportExists "data constructor"
386−
394+
387− -- Check that an explicitly imported item exists in the module it is being imported from
395+ -- 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
396+ checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either String a
389− checkImportExists t exports item =
397+ checkImportExists t exports item =
390− if item `elem` exports
398+ if item `elem` exports
391− then return item
399+ then return item
392− else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'"
400+ else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'"
393
401