@@ -16,7 +16,7 @@ module Language.PureScript.Sugar.Names (
1616 desugarImports
1717) where
1818
19−import Data.Maybe (fromMaybe)
19+import Data.Maybe (fromMaybe, isJust)
2020import Data.Generics (extM, mkM, everywhereM)
2121import Data.Generics.Extras (mkS, extS, everywhereWithContextM')
2222
@@ -61,19 +61,19 @@ data ImportEnvironment = ImportEnvironment
6161 -- |
6262 -- Local names for types within a module mapped to to their qualified names
6363 --
64− { importedTypes :: M.Map ProperName (Qualified ProperName)
64+ { importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)
6565 -- |
6666 -- Local names for data constructors within a module mapped to to their qualified names
6767 --
68− , importedDataConstructors :: M.Map ProperName (Qualified ProperName)
68+ , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName)
6969 -- |
7070 -- Local names for classes within a module mapped to to their qualified names
7171 --
72− , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
72+ , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName)
7373 -- |
7474 -- Local names for values within a module mapped to to their qualified names
7575 --
76− , importedValues :: M.Map Ident (Qualified Ident)
76+ , importedValues :: M.Map (Qualified Ident) (Qualified Ident)
7777 } deriving (Show)
7878
7979-- |
@@ -207,38 +207,26 @@ renameInModule imports exports (Module mn decls exps) =
207207 updateType t = return t
208208 updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
209209
210− updateTypeName (Qualified Nothing name) = update "type" importedTypes name
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
216−
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) ++ "'"
224−
225− updateClassName (Qualified Nothing name) = update "type class" importedTypeClasses name
226− updateClassName (Qualified (Just mn') name) = check "type class" exportedTypeClasses mn' name
227−
228− updateValueName (Qualified Nothing name) = update "value" importedValues name
229− updateValueName (Qualified (Just mn') name) = check "value" exportedValues mn' name
230−
231− -- Replace an unqualified name with a qualified
232− update :: (Ord a, Show a) => String -> (ImportEnvironment -> M.Map a (Qualified a)) -> a -> Either String (Qualified a)
233− update t get name = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'") return $ M.lookup name (get imports)
234−
235− -- Check that a qualified name is valid
236− check :: (Show a, Eq a) => String -> (Exports -> [a]) -> ModuleName -> a -> Either String (Qualified a)
237− check t get mn' name = do
238− modExports <- getExports mn'
239− if name `elem` get modExports
240− then return $ Qualified (Just mn') name
241− else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn') name) ++ "'"
210+ updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))
211+ updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)
212+ updateValueName = update "value" importedValues (flip elem . exportedValues)
213+ updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
214+
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
218+ -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
219+ -> (Exports -> a -> Bool)
220+ -> (Qualified a)
221+ -> Either String (Qualified a)
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
225+ modExports <- getExports mn''
226+ if checkE modExports name
227+ then return qname
228+ else throwError $ "Unknown " ++ t ++ " '" ++ show (qname) ++ "'"
229+ _ -> throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'"
242230
243231 -- Gets the exports for a module, or an error message if the module doesn't exist
244232 getExports :: ModuleName -> Either String Exports
@@ -392,9 +380,9 @@ resolveImport currentModule importModule exps imps = maybe importAll (foldM impo
392380 allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
393381
394382 -- 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))
396− updateImports m name = case M.lookup name m of
397− Nothing -> return $ M.insert name (Qualified (Just importModule) name) m
383+ updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> Either String (M.Map (Qualified a) (Qualified a))
384+ updateImports m name = case M.lookup (Qualified Nothing name) m of
385+ Nothing -> return $ M.insert (Qualified Nothing name) (Qualified (Just importModule) name) m
398386 Just (Qualified Nothing _) -> error "Invalid state in updateImports"
399387 Just x@(Qualified (Just mn) _) -> throwError $
400388 if mn == currentModule || importModule == currentModule