summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/basicTypes/Module.hs8
-rw-r--r--compiler/ghci/Linker.hs3
-rw-r--r--compiler/iface/TcIface.hs2
-rw-r--r--compiler/main/DriverPipeline.hs3
-rw-r--r--compiler/main/GHC.hs9
-rw-r--r--compiler/main/GhcMake.hs35
-rw-r--r--compiler/main/HscTypes.hs50
-rw-r--r--compiler/main/InteractiveEval.hs19
-rw-r--r--compiler/typecheck/FamInst.hs3
-rw-r--r--compiler/utils/UniqDFM.hs21
10 files changed, 104 insertions, 49 deletions
diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs
index 5755c28501..aa886bb6d9 100644
--- a/compiler/basicTypes/Module.hs
+++ b/compiler/basicTypes/Module.hs
@@ -72,7 +72,7 @@ module Module
foldModuleEnv, extendModuleEnvWith, filterModuleEnv,
-- * ModuleName mappings
- ModuleNameEnv,
+ ModuleNameEnv, DModuleNameEnv,
-- * Sets of Modules
ModuleSet,
@@ -83,6 +83,7 @@ import Config
import Outputable
import Unique
import UniqFM
+import UniqDFM
import FastString
import Binary
import Util
@@ -600,3 +601,8 @@ UniqFM.
-- | A map keyed off of 'ModuleName's (actually, their 'Unique's)
type ModuleNameEnv elt = UniqFM elt
+
+
+-- | A map keyed off of 'ModuleName's (actually, their 'Unique's)
+-- Has deterministic folds and can be deterministically converted to a list
+type DModuleNameEnv elt = UniqDFM elt
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index 0f15ea2877..2df8840c1c 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -37,7 +37,6 @@ import Finder
import HscTypes
import Name
import NameEnv
-import UniqFM
import Module
import ListSetOps
import DynFlags
@@ -658,7 +657,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
-- This one is a build-system bug
get_linkable osuf mod_name -- A home-package module
- | Just mod_info <- lookupUFM hpt mod_name
+ | Just mod_info <- lookupHpt hpt mod_name
= adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
| otherwise
= do -- It's not in the HPT because we are in one shot mode,
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 12980475b2..694bbd7c92 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -189,7 +189,7 @@ tcHiBootIface hsc_src mod
-- And that's fine, because if M's ModInfo is in the HPT, then
-- it's been compiled once, and we don't need to check the boot iface
then do { hpt <- getHpt
- ; case lookupUFM hpt (moduleName mod) of
+ ; case lookupHpt hpt (moduleName mod) of
Just info | mi_boot (hm_iface info)
-> return (mkSelfBootInfo (hm_details info))
_ -> return NoSelfBoot }
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 586754fe1c..5d648e60f9 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -46,7 +46,6 @@ import Finder
import HscTypes hiding ( Hsc )
import Outputable
import Module
-import UniqFM ( eltsUFM )
import ErrUtils
import DynFlags
import Config
@@ -353,7 +352,7 @@ link' dflags batch_attempt_linking hpt
LinkStaticLib -> True
_ -> platformBinariesAreStaticLibs (targetPlatform dflags)
- home_mod_infos = eltsUFM hpt
+ home_mod_infos = eltsHpt hpt
-- the packages we depend on
pkg_deps = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 0105607ffb..40aa7dfa01 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -329,7 +329,6 @@ import StaticFlags
import SysTools
import Annotations
import Module
-import UniqFM
import Panic
import Platform
import Bag ( unitBag )
@@ -943,7 +942,7 @@ loadModule tcm = do
hsc_env ms 1 1 Nothing mb_linkable
source_modified
- modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info }
+ modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
return tcm
@@ -1058,7 +1057,7 @@ needsTemplateHaskell ms =
-- | Return @True@ <==> module is loaded.
isLoaded :: GhcMonad m => ModuleName -> m Bool
isLoaded m = withSession $ \hsc_env ->
- return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
+ return $! isJust (lookupHpt (hsc_HPT hsc_env) m)
-- | Return the bindings for the current interactive session.
getBindings :: GhcMonad m => m [TyThing]
@@ -1134,7 +1133,7 @@ getPackageModuleInfo _hsc_env _mdl = do
getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo hsc_env mdl =
- case lookupUFM (hsc_HPT hsc_env) (moduleName mdl) of
+ case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of
Nothing -> return Nothing
Just hmi -> do
let details = hm_details hmi
@@ -1419,7 +1418,7 @@ lookupModule mod_name Nothing = withSession $ \hsc_env -> do
lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
- case lookupUFM (hsc_HPT hsc_env) mod_name of
+ case lookupHpt (hsc_HPT hsc_env) mod_name of
Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
_not_a_home_module -> return Nothing
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index af78065bde..c02ad7a671 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -222,7 +222,7 @@ load how_much = do
-- Unload any modules which are going to be re-linked this time around.
let stable_linkables = [ linkable
| m <- stable_obj++stable_bco,
- Just hmi <- [lookupUFM pruned_hpt m],
+ Just hmi <- [lookupHpt pruned_hpt m],
Just linkable <- [hm_linkable hmi] ]
liftIO $ unload hsc_env stable_linkables
@@ -370,9 +370,9 @@ load how_much = do
-- there should be no Nothings where linkables should be, now
let just_linkables =
isNoLink (ghcLink dflags)
- || all (isJust.hm_linkable)
- (filter ((== HsSrcFile).mi_hsc_src.hm_iface)
- (eltsUFM hpt4))
+ || allHpt (isJust.hm_linkable)
+ (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)
+ hpt4)
ASSERT( just_linkables ) do
-- Link everything together
@@ -498,7 +498,7 @@ pruneHomePackageTable :: HomePackageTable
-> ([ModuleName],[ModuleName])
-> HomePackageTable
pruneHomePackageTable hpt summ (stable_obj, stable_bco)
- = mapUFM prune hpt
+ = mapHpt prune hpt
where prune hmi
| is_stable modl = hmi'
| otherwise = hmi'{ hm_details = emptyModDetails }
@@ -639,7 +639,7 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
&& same_as_prev t
| otherwise = False
where
- same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
+ same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of
Just hmi | Just l <- hm_linkable hmi
-> isObjectLinkable l && t == linkableTime l
_other -> True
@@ -655,7 +655,7 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
bco_ok ms
| gopt Opt_ForceRecomp (ms_hspp_opts ms) = False
- | otherwise = case lookupUFM hpt (ms_mod_name ms) of
+ | otherwise = case lookupHpt hpt (ms_mod_name ms) of
Just hmi | Just l <- hm_linkable hmi ->
not (isObjectLinkable l) &&
linkableTime l >= ms_hs_date ms
@@ -1060,12 +1060,13 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem
-- Prune the old HPT unless this is an hs-boot module.
unless (isBootSummary mod) $
atomicModifyIORef' old_hpt_var $ \old_hpt ->
- (delFromUFM old_hpt this_mod, ())
+ (delFromHpt old_hpt this_mod, ())
-- Update and fetch the global HscEnv.
lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do
- let hsc_env' = hsc_env { hsc_HPT = addToUFM (hsc_HPT hsc_env)
- this_mod mod_info }
+ let hsc_env' = hsc_env
+ { hsc_HPT = addToHpt (hsc_HPT hsc_env)
+ this_mod mod_info }
-- If this module is a loop finisher, now is the time to
-- re-typecheck the loop.
hsc_env'' <- case finish_loop of
@@ -1152,7 +1153,7 @@ upsweep old_hpt stable_mods cleanup sccs = do
let this_mod = ms_mod_name mod
-- Add new info to hsc_env
- hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
+ hpt1 = addToHpt (hsc_HPT hsc_env) this_mod mod_info
hsc_env1 = hsc_env { hsc_HPT = hpt1 }
-- Space-saving: delete the old HPT entry
@@ -1163,7 +1164,7 @@ upsweep old_hpt stable_mods cleanup sccs = do
-- would force the real module to be recompiled
-- every time.
old_hpt1 | isBootSummary mod = old_hpt
- | otherwise = delFromUFM old_hpt this_mod
+ | otherwise = delFromHpt old_hpt this_mod
done' = mod:done
@@ -1204,7 +1205,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
is_stable_obj = this_mod_name `elem` stable_obj
is_stable_bco = this_mod_name `elem` stable_bco
- old_hmi = lookupUFM old_hpt this_mod_name
+ old_hmi = lookupHpt old_hpt this_mod_name
-- We're using the dflags for this module now, obtained by
-- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
@@ -1360,9 +1361,9 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
-- Filter modules in the HPT
retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs keep_these hpt
- = listToUFM [ (mod, expectJust "retain" mb_mod_info)
+ = listToHpt [ (mod, expectJust "retain" mb_mod_info)
| mod <- keep_these
- , let mb_mod_info = lookupUFM hpt mod
+ , let mb_mod_info = lookupHpt hpt mod
, isJust mb_mod_info ]
-- ---------------------------------------------------------------------------
@@ -1423,14 +1424,14 @@ typecheckLoop dflags hsc_env mods = do
let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
mds <- initIfaceCheck new_hsc_env $
mapM (typecheckIface . hm_iface) hmis
- let new_hpt = addListToUFM old_hpt
+ let new_hpt = addListToHpt old_hpt
(zip mods [ hmi{ hm_details = details }
| (hmi,details) <- zip hmis mds ])
return new_hpt
return hsc_env{ hsc_HPT = new_hpt }
where
old_hpt = hsc_HPT hsc_env
- hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
+ hmis = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods
reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
reachableBackwards mod summaries
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 53e40413ef..79e5f694cf 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -37,6 +37,8 @@ module HscTypes (
-- * State relating to modules in this package
HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
+ lookupHpt, eltsHpt, filterHpt, allHpt, mapHpt, delFromHpt,
+ addToHpt, addListToHpt, lookupHptDirectly, listToHpt,
hptInstances, hptRules, hptVectInfo, pprHPT,
hptObjs,
@@ -176,8 +178,9 @@ import CoreSyn ( CoreRule, CoreVect )
import Maybes
import Outputable
import SrcLoc
--- import Unique
+import Unique
import UniqFM
+import UniqDFM
import UniqSupply
import FastString
import StringBuffer ( StringBuffer )
@@ -465,7 +468,7 @@ instance Outputable TargetId where
-}
-- | Helps us find information about modules in the home package
-type HomePackageTable = ModuleNameEnv HomeModInfo
+type HomePackageTable = DModuleNameEnv HomeModInfo
-- Domain = modules in the home package that have been fully compiled
-- "home" unit id cached here for convenience
@@ -475,7 +478,7 @@ type PackageIfaceTable = ModuleEnv ModIface
-- | Constructs an empty HomePackageTable
emptyHomePackageTable :: HomePackageTable
-emptyHomePackageTable = emptyUFM
+emptyHomePackageTable = emptyUDFM
-- | Constructs an empty PackageIfaceTable
emptyPackageIfaceTable :: PackageIfaceTable
@@ -483,16 +486,47 @@ emptyPackageIfaceTable = emptyModuleEnv
pprHPT :: HomePackageTable -> SDoc
-- A bit aribitrary for now
-pprHPT hpt = pprUFM hpt $ \hms ->
+pprHPT hpt = pprUDFM hpt $ \hms ->
vcat [ hang (ppr (mi_module (hm_iface hm)))
2 (ppr (md_types (hm_details hm)))
| hm <- hms ]
+lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo
+lookupHpt = lookupUDFM
+
+lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo
+lookupHptDirectly = lookupUDFM_Directly
+
+eltsHpt :: HomePackageTable -> [HomeModInfo]
+eltsHpt = eltsUDFM
+
+filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable
+filterHpt = filterUDFM
+
+allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool
+allHpt = allUDFM
+
+mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable
+mapHpt = mapUDFM
+
+delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable
+delFromHpt = delFromUDFM
+
+addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
+addToHpt = addToUDFM
+
+addListToHpt
+ :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
+addListToHpt = addListToUDFM
+
+listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable
+listToHpt = listToUDFM
+
lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo
-- The HPT is indexed by ModuleName, not Module,
-- we must check for a hit on the right Module
lookupHptByModule hpt mod
- = case lookupUFM hpt (moduleName mod) of
+ = case lookupHpt hpt (moduleName mod) of
Just hm | mi_module (hm_iface hm) == mod -> Just hm
_otherwise -> Nothing
@@ -575,7 +609,7 @@ hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False
hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env
hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
-hptAllThings extract hsc_env = concatMap extract (eltsUFM (hsc_HPT hsc_env))
+hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env))
-- | Get things from modules "below" this one (in the dependency sense)
-- C.f Inst.hptInstances
@@ -598,7 +632,7 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps
, mod /= moduleName gHC_PRIM
-- Look it up in the HPT
- , let things = case lookupUFM hpt mod of
+ , let things = case lookupHpt hpt mod of
Just info -> extract info
Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg []
msg = vcat [text "missing module" <+> ppr mod,
@@ -609,7 +643,7 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps
, thing <- things ]
hptObjs :: HomePackageTable -> [FilePath]
-hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt))
+hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsHpt hpt))
{-
************************************************************************
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 6ca5d24351..5d0d7e75f8 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -80,7 +80,6 @@ import MonadUtils
import Module
import PrelNames ( toDynName, pretendNameIsInScope )
import Panic
-import UniqFM
import Maybes
import ErrUtils
import SrcLoc
@@ -118,7 +117,7 @@ getHistoryModule = breakInfo_module . historyBreakInfo
getHistorySpan :: HscEnv -> History -> SrcSpan
getHistorySpan hsc_env History{..} =
let BreakInfo{..} = historyBreakInfo in
- case lookupUFM (hsc_HPT hsc_env) (moduleName breakInfo_module) of
+ case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of
Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number
_ -> panic "getHistorySpan"
@@ -137,7 +136,7 @@ getModBreaks hmi
findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
findEnclosingDecls hsc_env (BreakInfo modl ix) =
let hmi = expectJust "findEnclosingDecls" $
- lookupUFM (hsc_HPT hsc_env) (moduleName modl)
+ lookupHpt (hsc_HPT hsc_env) (moduleName modl)
mb = getModBreaks hmi
in modBreaks_decls mb ! ix
@@ -308,7 +307,8 @@ handleRunStatus step expr bindings final_ids status history
= do
hsc_env <- getSession
let hmi = expectJust "handleRunStatus" $
- lookupUFM (hsc_HPT hsc_env) (mkUniqueGrimily mod_uniq)
+ lookupHptDirectly (hsc_HPT hsc_env)
+ (mkUniqueGrimily mod_uniq)
modl = mi_module (hm_iface hmi)
breaks = getModBreaks hmi
@@ -338,7 +338,8 @@ handleRunStatus step expr bindings final_ids status history
resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
let hmi = expectJust "handleRunStatus" $
- lookupUFM (hsc_HPT hsc_env) (mkUniqueGrimily mod_uniq)
+ lookupHptDirectly (hsc_HPT hsc_env)
+ (mkUniqueGrimily mod_uniq)
modl = mi_module (hm_iface hmi)
bp | is_exception = Nothing
| otherwise = Just (BreakInfo modl ix)
@@ -509,7 +510,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
let
hmi = expectJust "bindLocalsAtBreakpoint" $
- lookupUFM (hsc_HPT hsc_env) (moduleName breakInfo_module)
+ lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module)
breaks = getModBreaks hmi
info = expectJust "bindLocalsAtBreakpoint2" $
IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
@@ -738,7 +739,7 @@ availsToGlobalRdrEnv mod_name avails
mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
mkTopLevEnv hpt modl
- = case lookupUFM hpt modl of
+ = case lookupHpt hpt modl of
Nothing -> Left "not a home module"
Just details ->
case mi_globals (hm_iface details) of
@@ -758,7 +759,7 @@ moduleIsInterpreted :: GhcMonad m => Module -> m Bool
moduleIsInterpreted modl = withSession $ \h ->
if moduleUnitId modl /= thisPackage (hsc_dflags h)
then return False
- else case lookupUFM (hsc_HPT h) (moduleName modl) of
+ else case lookupHpt (hsc_HPT h) (moduleName modl) of
Just details -> return (isJust (mi_globals (hm_iface details)))
_not_a_home_module -> return False
@@ -950,7 +951,7 @@ showModule mod_summary =
isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
isModuleInterpreted mod_summary = withSession $ \hsc_env ->
- case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
+ case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
Nothing -> panic "missing linkable"
Just mod_info -> return (not obj_linkable)
where
diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs
index 69a110061e..a789a7b1a6 100644
--- a/compiler/typecheck/FamInst.hs
+++ b/compiler/typecheck/FamInst.hs
@@ -27,7 +27,6 @@ import CoAxiom
import DynFlags
import Module
import Outputable
-import UniqFM
import Util
import RdrName
import DataCon ( dataConName )
@@ -161,7 +160,7 @@ checkFamInstConsistency famInstMods directlyImpMods
; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv
. md_fam_insts . hm_details
; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)
- | hmi <- eltsUFM hpt]
+ | hmi <- eltsHpt hpt]
; groups = map (dep_finsts . mi_deps . modIface)
directlyImpMods
; okPairs = listToSet $ concatMap allPairs groups
diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs
index 8bd19ad7ff..6e6292ec3c 100644
--- a/compiler/utils/UniqDFM.hs
+++ b/compiler/utils/UniqDFM.hs
@@ -28,6 +28,7 @@ module UniqDFM (
unitUDFM,
addToUDFM,
addToUDFM_C,
+ addListToUDFM,
delFromUDFM,
delListFromUDFM,
adjustUDFM,
@@ -35,7 +36,7 @@ module UniqDFM (
mapUDFM,
plusUDFM,
plusUDFM_C,
- lookupUDFM,
+ lookupUDFM, lookupUDFM_Directly,
elemUDFM,
foldUDFM,
eltsUDFM,
@@ -49,7 +50,8 @@ module UniqDFM (
listToUDFM,
udfmMinusUFM,
partitionUDFM,
- anyUDFM,
+ anyUDFM, allUDFM,
+ pprUDFM,
udfmToList,
udfmToUfm,
@@ -155,6 +157,9 @@ addToUDFM_Directly_C f (UDFM m i) u v =
where
tf (TaggedVal a j) (TaggedVal b _) = TaggedVal (f a b) j
+addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt
+addListToUDFM = foldl (\m (k, v) -> addToUDFM m k v)
+
addToUDFM_C
:: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
-> UniqDFM elt -- old
@@ -235,6 +240,9 @@ insertUDFMIntoLeft_C f udfml udfmr =
lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt
lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m
+lookupUDFM_Directly :: UniqDFM elt -> Unique -> Maybe elt
+lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m
+
elemUDFM :: Uniquable key => key -> UniqDFM elt -> Bool
elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m
@@ -349,6 +357,9 @@ mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i
anyUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool
anyUDFM p (UDFM m _i) = M.fold ((||) . p . taggedFst) False m
+allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool
+allUDFM p (UDFM m _i) = M.fold ((&&) . p . taggedFst) True m
+
instance Monoid (UniqDFM a) where
mempty = emptyUDFM
mappend = plusUDFM
@@ -368,3 +379,9 @@ pprUniqDFM ppr_elt ufm
= brackets $ fsep $ punctuate comma $
[ ppr uq <+> text ":->" <+> ppr_elt elt
| (uq, elt) <- udfmToList ufm ]
+
+pprUDFM :: UniqDFM a -- ^ The things to be pretty printed
+ -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements
+ -> SDoc -- ^ 'SDoc' where the things have been pretty
+ -- printed
+pprUDFM ufm pp = pp (eltsUDFM ufm)
View Lorry Controller Status