@@ -16,7 +16,7 @@ module Language.PureScript.Sugar.Names (
16 desugarImports
16 desugarImports
19−import Data.Maybe (fromMaybe)
19+import Data.Maybe (fromMaybe, isJust)
20import Data.Generics (extM, mkM, everywhereM)
20import Data.Generics (extM, mkM, everywhereM)
21import Data.Generics.Extras (mkS, extS, everywhereWithContextM')
21import Data.Generics.Extras (mkS, extS, everywhereWithContextM')
@@ -61,19 +61,19 @@ data ImportEnvironment = ImportEnvironment
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
64− { importedTypes :: M.Map ProperName (Qualified ProperName)
64+ { importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)
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
68− , importedDataConstructors :: M.Map ProperName (Qualified ProperName)
68+ , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName)
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
72− , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
72+ , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName)
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
76− , importedValues :: M.Map Ident (Qualified Ident)
76+ , importedValues :: M.Map (Qualified Ident) (Qualified Ident)
77 } deriving (Show)
77 } deriving (Show)
@@ -207,38 +207,26 @@ renameInModule imports exports (Module mn decls exps) =
207 updateType t = return t
207 updateType t = return t
208 updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
208 updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
210− updateTypeName (Qualified Nothing name) = update "type" importedTypes name
210+ updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))
211− updateTypeName (Qualified (Just mn') name) = do
212− modExports <- getExports mn'
213− case name `lookup` exportedTypes modExports of
214− Nothing -> throwError $ "Unknown type '" ++ show (Qualified (Just mn') name) ++ "'"
215− _ -> return $ Qualified (Just mn') name
217− updateDataConstructorName (Qualified Nothing name) = update "data constructor" importedDataConstructors name
218− updateDataConstructorName (Qualified (Just mn') name) = do
219− modExports <- getExports mn'
220− let allDcons = join $ snd `map` exportedTypes modExports
221− if name `elem` allDcons
222− then return $ Qualified (Just mn') name
223− else throwError $ "Unknown data constructor '" ++ show (Qualified (Just mn') name) ++ "'"
225− updateClassName (Qualified Nothing name) = update "type class" importedTypeClasses name
211+ updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)
226− updateClassName (Qualified (Just mn') name) = check "type class" exportedTypeClasses mn' name
228− updateValueName (Qualified Nothing name) = update "value" importedValues name
212+ updateValueName = update "value" importedValues (flip elem . exportedValues)
229− updateValueName (Qualified (Just mn') name) = check "value" exportedValues mn' name
213+ updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
231− -- Replace an unqualified name with a qualified
215+ -- Update names so unqualified references become qualified, and locally qualified references
216+ -- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)
217+ update :: (Ord a, Show a) => String
232− update :: (Ord a, Show a) => String -> (ImportEnvironment -> M.Map a (Qualified a)) -> a -> Either String (Qualified a)
218+ -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
233− update t get name = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'") return $ M.lookup name (get imports)
219+ -> (Exports -> a -> Bool)
234−
220+ -> (Qualified a)
235− -- Check that a qualified name is valid
236− check :: (Show a, Eq a) => String -> (Exports -> [a]) -> ModuleName -> a -> Either String (Qualified a)
221+ -> Either String (Qualified a)
237− check t get mn' name = do
222+ update t getI checkE qname@(Qualified mn' name) = case (M.lookup qname (getI imports), mn') of
223+ (Just qname', _) -> return qname'
224+ (Nothing, Just mn'') -> do
238− modExports <- getExports mn'
225+ modExports <- getExports mn''
239− if name `elem` get modExports
226+ if checkE modExports name
240− then return $ Qualified (Just mn') name
227+ then return qname
228+ else throwError $ "Unknown " ++ t ++ " '" ++ show (qname) ++ "'"
241− else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn') name) ++ "'"
229+ _ -> throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'"
243 -- Gets the exports for a module, or an error message if the module doesn't exist
231 -- Gets the exports for a module, or an error message if the module doesn't exist
244 getExports :: ModuleName -> Either String Exports
232 getExports :: ModuleName -> Either String Exports
@@ -392,9 +380,9 @@ resolveImport currentModule importModule exps imps = maybe importAll (foldM impo
392 allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
380 allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
394 -- Add something to the ImportEnvironment if it does not already exist there
382 -- Add something to the ImportEnvironment if it does not already exist there
395− updateImports :: (Ord a, Show a) => M.Map a (Qualified a) -> a -> Either String (M.Map a (Qualified a))
383+ updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> Either String (M.Map (Qualified a) (Qualified a))
396− updateImports m name = case M.lookup name m of
384+ updateImports m name = case M.lookup (Qualified Nothing name) m of
397− Nothing -> return $ M.insert name (Qualified (Just importModule) name) m
385+ Nothing -> return $ M.insert (Qualified Nothing name) (Qualified (Just importModule) name) m
398 Just (Qualified Nothing _) -> error "Invalid state in updateImports"
386 Just (Qualified Nothing _) -> error "Invalid state in updateImports"
399 Just x@(Qualified (Just mn) _) -> throwError $
387 Just x@(Qualified (Just mn) _) -> throwError $
400 if mn == currentModule || importModule == currentModule
388 if mn == currentModule || importModule == currentModule