diff options
| -rw-r--r-- | src/HaddockDB.hs | 2 | ||||
| -rw-r--r-- | src/HaddockDevHelp.hs | 7 | ||||
| -rw-r--r-- | src/HaddockHH.hs | 13 | ||||
| -rw-r--r-- | src/HaddockHH2.hs | 14 | ||||
| -rw-r--r-- | src/HaddockHtml.hs | 24 | ||||
| -rw-r--r-- | src/HaddockRename.hs | 12 | ||||
| -rw-r--r-- | src/HaddockTypes.hs | 17 | ||||
| -rw-r--r-- | src/HaddockUtil.hs | 10 | ||||
| -rw-r--r-- | src/Main.hs | 180 | ||||
| -rw-r--r-- | src/Map.hs | 64 | ||||
| -rw-r--r-- | src/Set.hs | 36 |
11 files changed, 229 insertions, 150 deletions
diff --git a/src/HaddockDB.hs b/src/HaddockDB.hs index 8c4c99bd..a9d92250 100644 --- a/src/HaddockDB.hs +++ b/src/HaddockDB.hs @@ -13,10 +13,8 @@ import HsSyn #if __GLASGOW_HASKELL__ < 503 import Pretty -import FiniteMap #else import Text.PrettyPrint -import Data.FiniteMap #endif ----------------------------------------------------------------------------- diff --git a/src/HaddockDevHelp.hs b/src/HaddockDevHelp.hs index fcb26099..9c1964cf 100644 --- a/src/HaddockDevHelp.hs +++ b/src/HaddockDevHelp.hs @@ -1,13 +1,12 @@ module HaddockDevHelp(ppDevHelpFile) where import HsSyn hiding(Doc) +import qualified Map #if __GLASGOW_HASKELL__ < 503 import Pretty -import FiniteMap #else import Text.PrettyPrint -import Data.FiniteMap import Data.Char #endif @@ -61,10 +60,10 @@ ppDevHelpFile odir doctitle maybe_package ifaces = do -- reconstruct the module name index :: [(HsName, [Module])] - index = fmToList (foldr getIfaceIndex emptyFM ifaces) + index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces) getIfaceIndex (mdl,iface) fm = - addListToFM_C (++) fm [(name, [mdl]) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl'] + Map.unionWith (++) (Map.fromListWith (++) [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm ppList [] = empty ppList ((name,refs):mdls) = diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs index 8ad4dfe2..fb63c872 100644 --- a/src/HaddockHH.hs +++ b/src/HaddockHH.hs @@ -4,17 +4,16 @@ import HsSyn hiding(Doc) #if __GLASGOW_HASKELL__ < 503 import Pretty -import FiniteMap #else import Text.PrettyPrint -import Data.FiniteMap -import Data.Char +import Data.Char ( toUpper ) #endif import Maybe ( fromMaybe ) import HaddockModuleTree import HaddockUtil import HaddockTypes +import qualified Map ppHHContents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO () @@ -98,10 +97,10 @@ ppHHIndex odir maybe_package ifaces = do package = fromMaybe "pkg" maybe_package index :: [(HsName, [Module])] - index = fmToList (foldr getIfaceIndex emptyFM ifaces) + index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces) getIfaceIndex (mdl,iface) fm = - addListToFM_C (++) fm [(name, [mdl]) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl'] + foldl (\m (k,e) -> Map.insertWith (++) k e m) fm [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl'] ppList [] = empty ppList ((name,refs):mdls) = @@ -166,7 +165,7 @@ ppHHProject odir doctitle maybe_package ifaces pkg_paths = do ppLibFile fname = text (toPath fname) chars :: [Char] - chars = keysFM (foldr getIfaceIndex emptyFM ifaces) + chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces)) getIfaceIndex (mdl,iface) fm = - addListToFM fm [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl'] + Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm diff --git a/src/HaddockHH2.hs b/src/HaddockHH2.hs index 2555e523..bdd37386 100644 --- a/src/HaddockHH2.hs +++ b/src/HaddockHH2.hs @@ -4,18 +4,16 @@ import HsSyn hiding(Doc) #if __GLASGOW_HASKELL__ < 503 import Pretty -import FiniteMap #else import Text.PrettyPrint -import Data.FiniteMap -import Data.List -import Data.Char +import Data.Char ( toUpper ) #endif import Maybe ( fromMaybe ) import HaddockModuleTree import HaddockUtil import HaddockTypes +import qualified Map ppHH2Contents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO () ppHH2Contents odir doctitle maybe_package tree = do @@ -88,10 +86,10 @@ ppHH2Index odir maybe_package ifaces = do package = fromMaybe "pkg" maybe_package index :: [(HsName, [Module])] - index = fmToList (foldr getIfaceIndex emptyFM ifaces) + index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces) getIfaceIndex (mdl,iface) fm = - addListToFM_C (++) fm [(name, [mdl]) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl'] + Map.unionWith (++) (Map.fromListWith (++) [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm ppList [] = empty ppList ((name,mdls):vs) = @@ -146,10 +144,10 @@ ppHH2Files odir maybe_package ifaces pkg_paths = do ppLibFile fname = text "<File Url=\""<>text (toPath fname)<>text "\"/>" chars :: [Char] - chars = keysFM (foldr getIfaceIndex emptyFM ifaces) + chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces)) getIfaceIndex (mdl,iface) fm = - addListToFM fm [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl'] + Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm ----------------------------------------------------------------------------------- diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index 07c33bee..528dc47b 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -19,6 +19,8 @@ import HaddockHH import HaddockHH2 import HaddockDevHelp import HsSyn +import Map ( Map ) +import qualified Map import Maybe ( fromJust, isJust, mapMaybe ) import List ( sortBy ) @@ -32,12 +34,6 @@ import Control.Exception ( handle, bracket ) import Binary ( openBinaryFile ) import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf ) -#if __GLASGOW_HASKELL__ < 503 -import FiniteMap -#else -import Data.FiniteMap -#endif - import Html import qualified Html @@ -381,26 +377,26 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_ur index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c] - index :: [(String, FiniteMap HsQName [(Module,Bool)])] - index = sortBy cmp (fmToList full_index) + index :: [(String, Map HsQName [(Module,Bool)])] + index = sortBy cmp (Map.toAscList full_index) where cmp (n1,_) (n2,_) = n1 `compare` n2 -- for each name (a plain string), we have a number of original HsNames that -- it can refer to, and for each of those we have a list of modules -- that export that entity. Each of the modules exports the entity -- in a visible or invisible way (hence the Bool). - full_index :: FiniteMap String (FiniteMap HsQName [(Module,Bool)]) - full_index = addListToFM_C (plusFM_C (++)) emptyFM + full_index :: Map String (Map HsQName [(Module,Bool)]) + full_index = Map.fromListWith (\l r -> Map.unionWith (++) r l) (concat (map getIfaceIndex ifaces)) getIfaceIndex (mdl,iface) = [ (hsNameStr nm, - listToFM [(orig, [(mdl, not (nm `elemFM` iface_reexported iface))])]) - | (nm, orig) <- fmToList (iface_env iface) ] + Map.fromList [(orig, [(mdl, not (nm `Map.member` iface_reexported iface))])]) + | (nm, orig) <- Map.toAscList (iface_env iface) ] - indexElt :: (String, FiniteMap HsQName [(Module,Bool)]) -> HtmlTable + indexElt :: (String, Map HsQName [(Module,Bool)]) -> HtmlTable indexElt (str, entities) = - case fmToList entities of + case Map.toAscList entities of [(nm,entries)] -> tda [ theclass "indexentry" ] << toHtml str <-> indexLinks (unQual nm) entries diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs index 13e30f9c..429ad992 100644 --- a/src/HaddockRename.hs +++ b/src/HaddockRename.hs @@ -15,12 +15,8 @@ module HaddockRename ( import HaddockTypes import HsSyn - -#if __GLASGOW_HASKELL__ < 503 -import FiniteMap -#else -import Data.FiniteMap -#endif +import Map ( Map ) +import qualified Map import Monad @@ -58,8 +54,8 @@ lookupRn and_then name = do Nothing -> do outRn name; return (and_then name) Just maps_to -> return (and_then maps_to) -runRnFM :: FiniteMap HsQName HsQName -> RnM a -> (a,[HsQName]) -runRnFM env rn = unRn rn (lookupFM env) +runRnFM :: Map HsQName HsQName -> RnM a -> (a,[HsQName]) +runRnFM env rn = unRn rn (flip Map.lookup env) runRn :: (n -> Maybe HsQName) -> GenRnM n a -> (a,[n]) runRn lkp rn = unRn rn lkp diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs index 15c98f2d..82ce5a08 100644 --- a/src/HaddockTypes.hs +++ b/src/HaddockTypes.hs @@ -12,18 +12,13 @@ module HaddockTypes ( DocOption(..), InstHead, ) where -#if __GLASGOW_HASKELL__ < 503 -import FiniteMap -#else -import Data.FiniteMap -#endif - import HsSyn +import Map -- --------------------------------------------------------------------------- -- Describing a module interface -type NameEnv = FiniteMap HsName HsQName +type NameEnv = Map HsName HsQName data Interface = Interface { @@ -35,7 +30,7 @@ data Interface iface_env :: NameEnv, -- ^ environment mapping names to *original* names - iface_import_env :: FiniteMap HsQName HsQName, + iface_import_env :: Map HsQName HsQName, iface_reexported :: NameEnv, -- ^ For names exported by this module, but not @@ -45,7 +40,7 @@ data Interface -- location of documentation for the name in another -- module. - iface_sub :: FiniteMap HsName [HsName], + iface_sub :: Map HsName [HsName], -- ^ maps names to "subordinate" names -- (eg. tycon to constrs & fields, class to methods) @@ -56,7 +51,7 @@ data Interface -- ^ the exports used to construct the documentation -- (with orig names, not import names) - iface_decls :: FiniteMap HsName HsDecl, + iface_decls :: Map HsName HsDecl, -- ^ decls from this module (only) -- restricted to only those bits exported. -- the map key is the "main name" of the decl. @@ -100,6 +95,6 @@ data ExportItem | ExportModule -- a cross-reference to another module Module -type ModuleMap = FiniteMap Module Interface +type ModuleMap = Map Module Interface type InstHead = (HsContext,HsAsst) diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index bf326b82..3b8f3a13 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -30,6 +30,8 @@ import HaddockParse import HaddockTypes import HsSyn +import Map ( Map ) +import qualified Map import List ( intersect, isSuffixOf, intersperse ) import Maybe @@ -40,11 +42,9 @@ import Monad import Char ( isAlpha, isSpace, toUpper, ord ) #if __GLASGOW_HASKELL__ < 503 -import FiniteMap import IOExts import URI ( escapeString, unreserved ) #else -import Data.FiniteMap import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) import Network.URI ( escapeString, unreserved ) @@ -385,7 +385,7 @@ isPathSeparator ch = moduleHtmlFile :: String -> FilePath moduleHtmlFile mdl = - case lookupFM html_xrefs (Module mdl) of + case Map.lookup (Module mdl) html_xrefs of Nothing -> mdl ++ ".html" Just fp0 -> pathJoin [fp0, mdl ++ ".html"] @@ -460,11 +460,11 @@ escapeStr str = escapeString str unreserved -- being I'm going to use a write-once global variable. {-# NOINLINE html_xrefs_ref #-} -html_xrefs_ref :: IORef (FiniteMap Module FilePath) +html_xrefs_ref :: IORef (Map Module FilePath) html_xrefs_ref = unsafePerformIO (newIORef (error "module_map")) {-# NOINLINE html_xrefs #-} -html_xrefs :: FiniteMap Module FilePath +html_xrefs :: Map Module FilePath html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) ----------------------------------------------------------------------------- diff --git a/src/Main.hs b/src/Main.hs index dab996ea..92319d3e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -17,6 +17,9 @@ import HaddockUtil import Digraph import Binary +import Map ( Map ) +import qualified Map +import Set import HsParser import HsParseMonad import HsSyn @@ -32,14 +35,10 @@ import IO #if __GLASGOW_HASKELL__ < 503 import MonadWriter -import FiniteMap -import Set import GetOpt import IOExts #else import Control.Monad.Writer -import Data.FiniteMap -import Data.Set import System.Console.GetOpt import Data.IORef --import Debug.Trace @@ -241,12 +240,12 @@ run flags files = do let ((mdl,iface),msgs) = runWriter $ mkInterface no_implicit_prelude verbose ifaces file package hsmod - new_ifaces = addToFM ifaces mdl iface + new_ifaces = Map.insert mdl iface ifaces mapM (hPutStrLn stderr) msgs loop new_ifaces mdls - module_map <- loop (listToFM read_ifaces) sorted_mod_files - let mod_ifaces = fmToList module_map + module_map <- loop (Map.fromList read_ifaces) sorted_mod_files + let mod_ifaces = Map.toAscList module_map these_mod_ifaces0 = [ (mdl, iface) | (mdl, iface) <- mod_ifaces, @@ -258,8 +257,8 @@ run flags files = do let these_mod_ifaces = attachInstances these_mod_ifaces0 when (Flag_Debug `elem` flags) $ do - mapM_ putStrLn (map show [ (mdl, fmToList (iface_env i), - fmToList (iface_sub i)) + mapM_ putStrLn (map show [ (mdl, Map.toAscList (iface_env i), + Map.toAscList (iface_sub i)) | (mdl, i) <- these_mod_ifaces ]) when (Flag_Html `elem` flags) $ do @@ -282,7 +281,7 @@ parseIfaceOption s = updateHTMLXRefs :: [FilePath] -> [[(Module,Interface)]] -> IO () updateHTMLXRefs paths ifaces_s = - writeIORef html_xrefs_ref (listToFM mapping) + writeIORef html_xrefs_ref (Map.fromList mapping) where mapping = [ (mdl, fpath) | (fpath, ifaces) <- zip paths ifaces_s, @@ -347,8 +346,8 @@ mkInterface no_implicit_prelude verbose mod_map filename package qual_local_names = map (Qual mdl) locally_defined_names unqual_local_names = map UnQual locally_defined_names - local_orig_env = listToFM (zip unqual_local_names qual_local_names ++ - zip qual_local_names qual_local_names) + local_orig_env = Map.fromList (zip unqual_local_names qual_local_names ++ + zip qual_local_names qual_local_names) -- both qualified and unqualifed names are in scope for local things implicit_imps @@ -364,7 +363,7 @@ mkInterface no_implicit_prelude verbose mod_map filename package imported_orig_env <- buildOrigEnv mdl verbose mod_map implicit_imps let - orig_env = imported_orig_env `plusFM` local_orig_env + orig_env = local_orig_env `Map.union` imported_orig_env -- convert names in source code to original, fully qualified, names (orig_exports, missing_names1) @@ -381,24 +380,23 @@ mkInterface no_implicit_prelude verbose mod_map filename package let -- build the import env, which maps original names to import names - local_import_env = listToFM (zip qual_local_names qual_local_names) + local_import_env = Map.fromList (zip qual_local_names qual_local_names) -- find the names exported by this module that other modules should *not* -- link to (and point them to where they should). reexports = getReExports mdl exported_names exported_visible_names import_env - import_env = local_import_env `plusFM` - buildImportEnv mod_map mdl exported_visible_names - implicit_imps + import_env = buildImportEnv mod_map mdl exported_visible_names implicit_imps + `Map.union` local_import_env --- trace (show (fmToList orig_env)) $ do --- trace (show (fmToList import_env)) $ do +-- trace (show (Map.toAscList orig_env)) $ do +-- trace (show (Map.toAscList import_env)) $ do let final_decls = orig_decls - decl_map :: FiniteMap HsName HsDecl - decl_map = listToFM [ (n,d) | d <- final_decls, n <- declBinders d ] + decl_map :: Map HsName HsDecl + decl_map = Map.fromList [ (n,d) | d <- final_decls, n <- declBinders d ] instances = [ d | d@HsInstDecl{} <- final_decls ] ++ [ d | decl <- orig_decls, d <- derivedInstances mdl decl] @@ -419,7 +417,7 @@ mkInterface no_implicit_prelude verbose mod_map filename package (renamed_export_list, _missing_names3) = runRnFM import_env (renameExportItems pruned_export_list) - name_env = listToFM [ (nameOfQName n, n) | n <- exported_names ] + name_env = Map.fromList [ (nameOfQName n, n) | n <- exported_names ] let (orig_module_doc, missing_names4) @@ -487,10 +485,10 @@ derivedInstances mdl decl = case decl of where targs = map stripDocs (targsConstrs cons) -- a type variable is simple if it occurs as a data constructor argument - simple_tvars = map HsTyVar $ setToList $ mkSet $ [tv | HsTyVar tv <- targs] + simple_tvars = map HsTyVar $ Set.elems $ Set.fromList $ [tv | HsTyVar tv <- targs] -- a type variable is complex if it occurs inside a data constructor -- argument, except where the argument is identical to the lhs. - complex_tvars = map HsTyVar $ setToList $ unionManySets $ map tvarsType $ + complex_tvars = map HsTyVar $ Set.elems $ Set.unions $ map tvarsType $ filter (/= lhs) $ filter (not . isVar) targs isVar (HsTyVar _) = True isVar _ = False @@ -526,13 +524,13 @@ derivedInstances mdl decl = case decl of stripDocs t = t -- collect the type variables occurring free in a type - tvarsType (HsForAllType (Just tvs) _ t) = foldl delFromSet (tvarsType t) tvs + tvarsType (HsForAllType (Just tvs) _ t) = foldl (flip Set.delete) (tvarsType t) tvs tvarsType (HsForAllType Nothing _ t) = tvarsType t - tvarsType (HsTyFun t1 t2) = tvarsType t1 `union` tvarsType t2 - tvarsType (HsTyTuple _ ts) = unionManySets (map tvarsType ts) - tvarsType (HsTyApp t1 t2) = tvarsType t1 `union` tvarsType t2 - tvarsType (HsTyVar tv) = unitSet tv - tvarsType (HsTyCon _) = emptySet + tvarsType (HsTyFun t1 t2) = tvarsType t1 `Set.union` tvarsType t2 + tvarsType (HsTyTuple _ ts) = Set.unions (map tvarsType ts) + tvarsType (HsTyApp t1 t2) = tvarsType t1 `Set.union` tvarsType t2 + tvarsType (HsTyVar tv) = Set.singleton tv + tvarsType (HsTyCon _) = Set.empty tvarsType (HsTyDoc t _) = tvarsType t tvarsType (HsTyIP _ t) = tvarsType t @@ -548,8 +546,8 @@ mkExportItems :: ModuleMap -> Module -- this module -> [HsQName] -- exported names (orig) - -> FiniteMap HsName HsDecl -- maps local names to declarations - -> FiniteMap HsName [HsName] -- sub-map for this module + -> Map HsName HsDecl -- maps local names to declarations + -> Map HsName [HsName] -- sub-map for this module -> [HsDecl] -- decls in the current module -> [DocOption] -> Maybe [HsExportSpec] @@ -596,13 +594,13 @@ mkExportItems mod_map this_mod exported_names decl_map sub_map decls all_subs_qnames = map (Qual mdl) all_subs - all_subs | mdl == this_mod = lookupWithDefaultFM sub_map [] x + all_subs | mdl == this_mod = Map.findWithDefault [] x sub_map | otherwise = all_subs_of_qname mod_map t fullContentsOf m | m == this_mod = return (fullContentsOfThisModule this_mod decls) | otherwise = - case lookupFM mod_map m of + case Map.lookup m mod_map of Just iface | OptHide `elem` iface_options iface -> return (iface_orig_exports iface) @@ -613,10 +611,10 @@ mkExportItems mod_map this_mod exported_names decl_map sub_map decls findDecl (UnQual _) = Nothing -- must be a name we couldn't resolve findDecl (Qual m n) - | m == this_mod = lookupFM decl_map n + | m == this_mod = Map.lookup n decl_map | otherwise = - case lookupFM mod_map m of - Just iface -> lookupFM (iface_decls iface) n + case Map.lookup m mod_map of + Just iface -> Map.lookup n (iface_decls iface) Nothing -> Nothing fullContentsOfThisModule :: Module -> [HsDecl] -> [ExportItem] @@ -698,18 +696,18 @@ pruneExportItems items = filter has_doc items -- ----------------------------------------------------------------------------- -- Make a sub-name map for this module -mkSubNames :: [HsDecl] -> FiniteMap HsName [HsName] +mkSubNames :: [HsDecl] -> Map HsName [HsName] mkSubNames decls = - listToFM [ (n, subs) | d <- decls, - Just n <- [declMainBinder d], - subs@(_:_) <- [declSubBinders d] ] + Map.fromList [ (n, subs) | d <- decls, + Just n <- [declMainBinder d], + subs@(_:_) <- [declSubBinders d] ] -- ----------------------------------------------------------------------------- -- Gather a list of original names exported from this module exportedNames :: Module -> ModuleMap -> [HsName] - -> FiniteMap HsQName HsQName - -> FiniteMap HsName [HsName] + -> Map HsQName HsQName + -> Map HsName [HsName] -> Maybe [HsExportSpec] -> [DocOption] -> ErrMsgM ([HsQName], [HsQName]) @@ -727,25 +725,25 @@ exportedNames mdl mod_map local_names orig_env sub_map maybe_exps opts all_local_names = map (Qual mdl) local_names all_local_names_pr = (all_local_names,all_local_names) - in_scope = eltsFM orig_env + in_scope = Set.fromList (Map.elems orig_env) extract e = case e of HsEVar x -> return [x] HsEAbs t -> return [t] HsEThingAll t@(Qual m x) -> - return (t : filter (`elem` in_scope) (map (Qual m) all_subs)) + return (t : filter (`Set.member` in_scope) (map (Qual m) all_subs)) where - all_subs | m == mdl = lookupWithDefaultFM sub_map [] x + all_subs | m == mdl = Map.findWithDefault [] x sub_map | otherwise = all_subs_of_qname mod_map t HsEThingWith t cs -> return (t : cs) HsEModuleContents m | m == mdl -> return (map (Qual mdl) local_names) | otherwise -> - case lookupFM mod_map m of + case Map.lookup m mod_map of Just iface -> - return (filter (`elem` in_scope) (eltsFM (iface_env iface))) + return (filter (`Set.member` in_scope) (Map.elems (iface_env iface))) Nothing -> do tell (exportModuleMissingErr mdl m) return [] @@ -759,10 +757,10 @@ exportedNames mdl mod_map local_names orig_env sub_map maybe_exps opts HsEModuleContents m | m == mdl -> return (map (Qual mdl) local_names) | otherwise -> - case lookupFM mod_map m of + case Map.lookup m mod_map of Just iface | OptHide `elem` iface_options iface -> - return (filter (`elem` in_scope) (eltsFM (iface_env iface))) + return (filter (`Set.member` in_scope) (Map.elems (iface_env iface))) | otherwise -> return [] Nothing -> return [] -- we already emitted a warning above @@ -778,9 +776,9 @@ exportedNames mdl mod_map local_names orig_env sub_map maybe_exps opts is_documented_here (Qual m n) | m == mdl = True -- well, it's not documented anywhere else! | otherwise = - case lookupFM mod_map m of + case Map.lookup m mod_map of Nothing -> False - Just iface -> isJust (lookupFM (iface_decls iface) n) + Just iface -> isJust (Map.lookup n (iface_decls iface)) exportModuleMissingErr this mdl = ["Warning: in export list of " ++ show this @@ -791,8 +789,8 @@ exportModuleMissingErr this mdl -- class). all_subs_of_qname :: ModuleMap -> HsQName -> [HsName] all_subs_of_qname mod_map (Qual mdl nm) = - case lookupFM mod_map mdl of - Just iface -> lookupWithDefaultFM (iface_sub iface) [] nm + case Map.lookup mdl mod_map of + Just iface -> Map.findWithDefault [] nm (iface_sub iface) Nothing -> [] all_subs_of_qname _ n@(UnQual _) = error $ "Main.all_subs_of_qname: unexpected unqual'd name:" ++ show n @@ -806,17 +804,17 @@ all_subs_of_qname _ n@(UnQual _) = getReExports :: Module -> [HsQName] -- all exported names -> [HsQName] -- exported names which are documented here - -> FiniteMap HsQName HsQName - -> FiniteMap HsName HsQName + -> Map HsQName HsQName + -> Map HsName HsQName getReExports mdl exported exported_visible import_env - = listToFM (concat invisible_names) + = Map.fromList (concat invisible_names) where invisible_names = [ get_name n | n <- exported, n `notElem` exported_visible ] get_name (UnQual _) = [] get_name n@(Qual m un) = - case lookupFM import_env n of + case Map.lookup n import_env of Nothing -> [] Just n' -> [(un,n')] @@ -827,23 +825,23 @@ getReExports mdl exported exported_visible import_env -- fully-qualified "original" names. buildOrigEnv :: Module -> Bool -> ModuleMap -> [HsImportDecl] - -> ErrMsgM (FiniteMap HsQName HsQName) + -> ErrMsgM (Map HsQName HsQName) buildOrigEnv this_mdl verbose mod_map imp_decls = do maps <- mapM build imp_decls - return (foldr plusFM emptyFM maps) + return (Map.unions maps) where build imp_decl@(HsImportDecl _ mdl qual maybe_as _) - = case lookupFM mod_map mdl of + = case Map.lookup mdl mod_map of Nothing -> do when verbose $ -- only emit missing module messages when -v is on. Otherwise -- we get a ton of spurious messages about missing "Prelude". tell ["Warning: " ++ show this_mdl ++ ": imported module not found: " ++ show mdl] - return emptyFM + return Map.empty Just iface -> - return (listToFM (concat (map orig_map - (processImportDecl mod_map imp_decl)))) + return (Map.fromList (concat (map orig_map + (processImportDecl mod_map imp_decl)))) where -- bring both qualified and unqualified names into scope, unless @@ -864,9 +862,9 @@ buildOrigEnv this_mdl verbose mod_map imp_decls buildImportEnv :: ModuleMap -> Module -> [HsQName] -- a list of names exported from here *with docs* -> [HsImportDecl] -- the import decls - -> FiniteMap HsQName HsQName + -> Map HsQName HsQName buildImportEnv mod_map this_mod exported_names imp_decls - = foldr (plusFM_C best_name) emptyFM (map build imp_decls) + = foldr (flip (Map.unionWith best_name)) Map.empty (map build imp_decls) where -- choose qualified results over unqualified ones. In the future -- we might make more intelligent decisions about which name to @@ -876,9 +874,9 @@ buildImportEnv mod_map this_mod exported_names imp_decls best_name n _ = n build imp_decl@(HsImportDecl _ mdl _ _ _) = - case lookupFM mod_map mdl of - Nothing -> emptyFM - Just iface -> listToFM (map import_map imported_names) + case Map.lookup mdl mod_map of + Nothing -> Map.empty + Just iface -> Map.fromList (map import_map imported_names) where imported_names = processImportDecl mod_map imp_decl reexport_env = iface_reexported iface @@ -890,7 +888,7 @@ buildImportEnv mod_map this_mod exported_names imp_decls | qnm `elem` exported_names = Qual this_mod nm -- re-exported from the other module, but not documented there: -- find the right place using the iface_reexported environment. - | Just new_qnm <- lookupFM reexport_env nm = new_qnm + | Just new_qnm <- Map.lookup nm reexport_env = new_qnm -- if the destination is hidden, we have nowhere to link to | OptHide `elem` iface_options iface = UnQual nm -- otherwise, it's documented in the other module @@ -899,14 +897,14 @@ buildImportEnv mod_map this_mod exported_names imp_decls processImportDecl :: ModuleMap -> HsImportDecl -> [(HsName,HsQName)] processImportDecl mod_map (HsImportDecl _ mdl is_qualified maybe_as imp_specs) - = case lookupFM mod_map mdl of + = case Map.lookup mdl mod_map of Nothing -> [] Just iface -> imported_names where env = iface_env iface sub = iface_sub iface - all_names = fmToList env + all_names = Map.toAscList env imported_names :: [(HsName,HsQName)] imported_names @@ -931,8 +929,8 @@ processImportDecl mod_map (HsImportDecl _ mdl is_qualified maybe_as imp_specs) sub_names :: HsName -> [HsName] sub_names nm = - case lookupFM env nm of - Just qnm -> filter (`elemFM` env) (all_subs_of_qname mod_map qnm) + case Map.lookup nm env of + Just qnm -> filter (`Map.member` env) (all_subs_of_qname mod_map qnm) _ -> [] -- ----------------------------------------------------------------------------- @@ -1070,7 +1068,7 @@ attachInstances mod_ifaces (mapM renameInstHead insts)) attach_export (ExportDecl nm decl _) = - ExportDecl nm decl (case lookupFM inst_map nm of + ExportDecl nm decl (case Map.lookup nm inst_map of Nothing -> [] Just instheads -> rename_insts instheads) attach_export other_export = @@ -1078,11 +1076,11 @@ attachInstances mod_ifaces collectInstances :: [(Module,Interface)] - -> FiniteMap HsQName [InstHead] -- maps class/type names to instances + -> Map HsQName [InstHead] -- maps class/type names to instances collectInstances mod_ifaces - = addListToFM_C (++) emptyFM class_inst_pairs `plusFM` - addListToFM_C (++) emptyFM ty_inst_pairs + = Map.fromListWith (++) ty_inst_pairs `Map.union` + Map.fromListWith (++) class_inst_pairs where all_instances = concat (map (iface_insts.snd) mod_ifaces) @@ -1153,9 +1151,9 @@ from_interface :: (Module,Interface) -> StoredInterface from_interface (mdl,iface) = (mdl, toDescription iface,iface_package iface, OptHide `elem` iface_options iface, - fmToList (iface_env iface), - fmToList (iface_reexported iface), - fmToList (iface_sub iface) + Map.toAscList (iface_env iface), + Map.toAscList (iface_reexported iface), + Map.toAscList (iface_sub iface) ) to_interface :: StoredInterface -> (Module,Interface) @@ -1163,14 +1161,14 @@ to_interface (mdl,descriptionOpt,package, hide, env, reexported, sub) = (mdl, Interface { iface_filename = "", iface_package = package, - iface_env = listToFM env, - iface_import_env = emptyFM, - iface_sub = listToFM sub, - iface_reexported = listToFM reexported, + iface_env = Map.fromList env, + iface_import_env = Map.empty, + iface_sub = Map.fromList sub, + iface_reexported = Map.fromList reexported, iface_exports = [], iface_orig_exports = [], iface_insts = [], - iface_decls = emptyFM, + iface_decls = Map.empty, iface_info = toModuleInfo descriptionOpt, iface_doc = Nothing, iface_options = if hide then [OptHide] else [] @@ -1181,14 +1179,14 @@ nullVersion_to_interface (mdl, package, hide, env, reexported, sub) = (mdl, Interface { iface_filename = "", iface_package = package, - iface_env = listToFM env, - iface_import_env = emptyFM, - iface_sub = listToFM sub, - iface_reexported = listToFM reexported, + iface_env = Map.fromList env, + iface_import_env = Map.empty, + iface_sub = Map.fromList sub, + iface_reexported = Map.fromList reexported, iface_exports = [], iface_orig_exports = [], iface_insts = [], - iface_decls = emptyFM, + iface_decls = Map.empty, iface_info = emptyModuleInfo, iface_doc = Nothing, iface_options = if hide then [OptHide] else [] diff --git a/src/Map.hs b/src/Map.hs new file mode 100644 index 00000000..4209798b --- /dev/null +++ b/src/Map.hs @@ -0,0 +1,64 @@ +module Map ( + Map, + member, lookup, findWithDefault, + empty, + insert, insertWith, + union, unionWith, unions, + elems, + fromList, fromListWith, + toAscList +) where + +import Prelude hiding ( lookup ) +import qualified Set + +#if __GLASGOW_HASKELL__ < 503 +import FiniteMap +#elif __GLASGOW_HASKELL__ < 603 +import Data.FiniteMap +#else +import Data.Map +#endif + +#if __GLASGOW_HASKELL__ < 603 +type Map k a = FiniteMap k a + +member :: Ord k => k -> Map k a -> Bool +member = elemFM + +lookup :: Ord k => k -> Map k a -> Maybe a +lookup = flip lookupFM + +findWithDefault :: Ord k => a -> k -> Map k a -> a +findWithDefault a k m = lookupWithDefaultFM m a k + +empty :: Map k a +empty = emptyFM + +insert :: Ord k => k -> a -> Map k a -> Map k a +insert k a m = addToFM m k a + +insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a +insertWith c k a m = addToFM_C c m k a + +union :: Ord k => Map k a -> Map k a -> Map k a +union = flip plusFM + +unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a +unionWith c l r = plusFM_C c r l + +unions :: Ord k => [Map k a] -> Map k a +unions = foldr plusFM emptyFM + +elems :: Map k a -> [a] +elems = eltsFM + +fromList :: Ord k => [(k,a)] -> Map k a +fromList = listToFM + +fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a +fromListWith = flip addListToFM_C emptyFM + +toAscList :: Map k a -> [(k,a)] +toAscList = fmToList +#endif diff --git a/src/Set.hs b/src/Set.hs new file mode 100644 index 00000000..271828e8 --- /dev/null +++ b/src/Set.hs @@ -0,0 +1,36 @@ +module Set ( + Set, + member, + empty, singleton, delete, + union, unions, + elems, fromList +) where + +#if __GLASGOW_HASKELL__ < 503 +import Set +#else +import Data.Set +#endif + +#if __GLASGOW_HASKELL__ < 603 +member :: Ord a => a -> Set a -> Bool +member = elementOf + +empty :: Set a +empty = emptySet + +singleton :: a -> Set a +singleton = unitSet + +delete :: Ord a => a -> Set a -> Set a +delete = flip delFromSet + +unions :: Ord a => [Set a] -> Set a +unions = unionManySets + +elems :: Set a -> [a] +elems = setToList + +fromList :: Ord a => [a] -> Set a +fromList = mkSet +#endif |