@@ -17,13 +17,10 @@ module Language.PureScript.Sugar.Names (
1717) where
1818
1919import Data.Maybe (fromMaybe)
20−import Data.Data
2120import Data.Generics (extM, mkM, everywhereM)
2221import Data.Generics.Extras (mkS, extS, everywhereWithContextM')
23−import Data.List (find)
2422
2523import Control.Applicative (Applicative(..), (<$>), (<*>))
26−import Control.Monad (foldM)
2724import Control.Monad.Error
2825
2926import qualified Data.Map as M
@@ -163,9 +160,9 @@ renameInModule imports exports (Module mn decls exps) =
163160 updateVars (ValueDeclaration name [] Nothing val) =
164161 ValueDeclaration name [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
165162 where
166− bindFunctionArgs bound (Abs (Left arg) val) = return (arg : bound, Abs (Left arg) val)
167− bindFunctionArgs bound (Var name@(Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName name)
168− bindFunctionArgs bound (Var name@(Qualified (Just _) _)) = (,) bound <$> (Var <$> updateValueName name)
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')
169166 bindFunctionArgs bound other = return (bound, other)
170167 bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)
171168 bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)
@@ -182,25 +179,25 @@ renameInModule imports exports (Module mn decls exps) =
182179 updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
183180
184181 updateTypeName (Qualified Nothing name) = update "type" importedTypes name
185− updateTypeName (Qualified (Just mn) name) = do
186− modExports <- getExports mn
182+ updateTypeName (Qualified (Just mn') name) = do
183+ modExports <- getExports mn'
187184 case name `lookup` exportedTypes modExports of
188− Nothing -> throwError $ "Unknown type '" ++ show (Qualified (Just mn) name) ++ "'"
189− _ -> return $ Qualified (Just mn) name
185+ Nothing -> throwError $ "Unknown type '" ++ show (Qualified (Just mn') name) ++ "'"
186+ _ -> return $ Qualified (Just mn') name
190187
191188 updateDataConstructorName (Qualified Nothing name) = update "data constructor" importedDataConstructors name
192− updateDataConstructorName (Qualified (Just mn) name) = do
193− modExports <- getExports mn
189+ updateDataConstructorName (Qualified (Just mn') name) = do
190+ modExports <- getExports mn'
194191 let allDcons = join $ snd `map` exportedTypes modExports
195192 if name `elem` allDcons
196− then return $ Qualified (Just mn) name
197− else throwError $ "Unknown data constructor '" ++ show (Qualified (Just mn) name) ++ "'"
198−
193+ then return $ Qualified (Just mn') name
194+ else throwError $ "Unknown data constructor '" ++ show (Qualified (Just mn') name) ++ "'"
195+
199196 updateClassName (Qualified Nothing name) = update "type class" importedTypeClasses name
200− updateClassName (Qualified (Just mn) name) = check "type class" exportedTypeClasses mn name
201−
197+ updateClassName (Qualified (Just mn') name) = check "type class" exportedTypeClasses mn' name
198+
202199 updateValueName (Qualified Nothing name) = update "value" importedValues name
203− updateValueName (Qualified (Just mn) name) = check "value" exportedValues mn name
200+ updateValueName (Qualified (Just mn') name) = check "value" exportedValues mn' name
204201
205202 -- Replace an unqualified name with a qualified
206203 update :: (Ord a, Show a) => String -> (ImportEnvironment -> M.Map a (Qualified a)) -> a -> Either String (Qualified a)
@@ -208,15 +205,15 @@ renameInModule imports exports (Module mn decls exps) =
208205
209206 -- Check that a qualified name is valid
210207 check :: (Show a, Eq a) => String -> (Exports -> [a]) -> ModuleName -> a -> Either String (Qualified a)
211− check t get mn name = do
212− modExports <- getExports mn
208+ check t get mn' name = do
209+ modExports <- getExports mn'
213210 if name `elem` get modExports
214− then return $ Qualified (Just mn) name
215− else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn) name) ++ "'"
211+ then return $ Qualified (Just mn') name
212+ else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn') name) ++ "'"
216213
217214 -- Gets the exports for a module, or an error message if the module doesn't exist
218215 getExports :: ModuleName -> Either String Exports
219− getExports mn = maybe (throwError $ "Unknown module '" ++ show mn ++ "'") return $ M.lookup mn exports
216+ getExports mn' = maybe (throwError $ "Unknown module '" ++ show mn' ++ "'") return $ M.lookup mn' exports
220217
221218-- |
222219-- Finds all exported declarations in a set of modules.
@@ -256,13 +253,13 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri
256253filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either String ExportEnvironment
257254filterExports mn exps env = do
258255 let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
259− moduleExports' <- filterModule exps moduleExports
256+ moduleExports' <- filterModule moduleExports
260257 return $ M.insert mn moduleExports' env
261258 where
262259
263260 -- Filter the exports for the specific module
264− filterModule :: [DeclarationRef] -> Exports -> Either String Exports
265− filterModule exps exported = do
261+ filterModule :: Exports -> Either String Exports
262+ filterModule exported = do
266263 types <- foldM (filterTypes $ exportedTypes exported) [] exps
267264 values <- foldM (filterValues $ exportedValues exported) [] exps
268265 classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps
@@ -271,34 +268,34 @@ filterExports mn exps env = do
271268 -- Ensure the exported types and data constructors exist in the module and add them to the set of
272269 -- exports
273270 filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either String [(ProperName, [ProperName])]
274− filterTypes exps result (TypeRef name expDcons) = do
275− dcons <- maybe (throwError $ "Cannot export undefined type '" ++ show name ++ "'") return $ name `lookup` exps
271+ filterTypes expTys result (TypeRef name expDcons) = do
272+ dcons <- maybe (throwError $ "Cannot export undefined type '" ++ show name ++ "'") return $ name `lookup` expTys
276273 dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
277274 return $ (name, dcons') : result
278− filterTypes exps result _ = return result
275+ filterTypes _ result _ = return result
279276
280277 -- Ensure the exported data constructors exists for a type and add them to the list of exports
281278 filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either String [ProperName]
282− filterDcons tcon exps result name =
283− if name `elem` exps
279+ filterDcons tcon exps' result name =
280+ if name `elem` exps'
284281 then return $ name : result
285282 else throwError $ "Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'"
286283
287284 -- Ensure the exported classes exist in the module and add them to the set of exports
288285 filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either String [ProperName]
289− filterClasses exps result (TypeClassRef name) =
290− if name `elem` exps
286+ filterClasses exps' result (TypeClassRef name) =
287+ if name `elem` exps'
291288 then return $ name : result
292289 else throwError $ "Cannot export undefined type class '" ++ show name ++ "'"
293− filterClasses exps result _ = return result
290+ filterClasses _ result _ = return result
294291
295292 -- Ensure the exported values exist in the module and add them to the set of exports
296293 filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either String [Ident]
297− filterValues exps result (ValueRef name) =
298− if name `elem` exps
294+ filterValues exps' result (ValueRef name) =
295+ if name `elem` exps'
299296 then return $ name : result
300297 else throwError $ "Cannot export undefined value '" ++ show name ++ "'"
301− filterValues exps result _ = return result
298+ filterValues _ result _ = return result
302299
303300-- |
304301-- Type representing a set of declarations being explicitly imported from a module
@@ -333,53 +330,54 @@ resolveImports env (Module currentModule decls _) =
333330-- Extends the local environment for a module by resolving an import of another module.
334331--
335332resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ExplicitImports -> Either String ImportEnvironment
336−resolveImport currentModule importModule exp imp i = case i of
337− Nothing -> importAll imp
338− (Just expl) -> foldM importExplicit imp expl
333+resolveImport currentModule importModule exps imps i = case i of
334+ Nothing -> importAll
335+ Just expl -> foldM importExplicit imps expl
339336 where
340337
341338 -- Import everything from a module
342− importAll :: ImportEnvironment -> Either String ImportEnvironment
343− importAll imp = do
344− imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeRef name (Just dctors))) imp (exportedTypes exp)
345− imp'' <- foldM (\m name -> importExplicit m (ValueRef name)) imp' (exportedValues exp)
346− foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exp)
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)
347344
348345 -- Import something explicitly
349346 importExplicit :: ImportEnvironment -> DeclarationRef -> Either String ImportEnvironment
350347 importExplicit imp (ValueRef name) = do
351− checkImportExists "value" values name
348+ _ <- checkImportExists "value" values name
352349 values' <- updateImports (importedValues imp) name
353350 return $ imp { importedValues = values' }
354351 importExplicit imp (TypeRef name dctors) = do
355− checkImportExists "type" types name
352+ _ <- checkImportExists "type" types name
356353 types' <- updateImports (importedTypes imp) name
357354 let allDctors = allExportedDataConstructors name
358355 dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
359356 dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
360357 return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
361358 importExplicit imp (TypeClassRef name) = do
362− checkImportExists "type class" classes name
359+ _ <- checkImportExists "type class" classes name
363360 typeClasses' <- updateImports (importedTypeClasses imp) name
364361 return $ imp { importedTypeClasses = typeClasses' }
365362
366363 -- Find all exported data constructors for a given type
367364 allExportedDataConstructors :: ProperName -> [ProperName]
368− allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exp
365+ allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
369366
370367 -- Add something to the ImportEnvironment if it does not already exist there
371368 updateImports :: (Ord a, Show a) => M.Map a (Qualified a) -> a -> Either String (M.Map a (Qualified a))
372369 updateImports m name = case M.lookup name m of
373370 Nothing -> return $ M.insert name (Qualified (Just importModule) name) m
371+ Just (Qualified Nothing _) -> error "Invalid state in updateImports"
374372 Just x@(Qualified (Just mn) _) -> throwError $
375373 if mn == currentModule || importModule == currentModule
376374 then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"
377375 else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
378376
379377 -- The available values, types, and classes in the module being imported
380− values = exportedValues exp
381− types = fst `map` exportedTypes exp
382− classes = exportedTypeClasses exp
378+ values = exportedValues exps
379+ types = fst `map` exportedTypes exps
380+ classes = exportedTypeClasses exps
383381
384382 -- Ensure that an explicitly imported data constructor exists for the type it is being imported
385383 -- from