aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorpanne <unknown>2005-01-15 18:44:48 +0000
committerpanne <unknown>2005-01-15 18:44:48 +0000
commit914ccdce1b9923f7fc8f75b3bdb188192291ac9b (patch)
tree975e0562f4810a89fa7fcc181885f99bd5f5f3c7 /src
parente8f54f255a7295fc0da368390706b1ae5d90268c (diff)
[haddock @ 2005-01-15 18:44:45 by panne]
Make Haddock compile again after the recent base package changed. The Map/Set legacy hell has been factored out, so that all modules can simply use the new non-deprecated interfaces. Probably a lot of things can be improved by a little bit of Map/Set/List algebra, this can be done later if needed. Small note: Currently the list of instances in HTML code is reversed. This will hopefully be fixed later.
Diffstat (limited to 'src')
-rw-r--r--src/HaddockDB.hs2
-rw-r--r--src/HaddockDevHelp.hs7
-rw-r--r--src/HaddockHH.hs13
-rw-r--r--src/HaddockHH2.hs14
-rw-r--r--src/HaddockHtml.hs24
-rw-r--r--src/HaddockRename.hs12
-rw-r--r--src/HaddockTypes.hs17
-rw-r--r--src/HaddockUtil.hs10
-rw-r--r--src/Main.hs180
-rw-r--r--src/Map.hs64
-rw-r--r--src/Set.hs36
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