-intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
-intersectsUFM t1 t2 = isNullUFM (intersectUFM_C (\ _ _ -> error "urk") t1 t2)
-
-intersectUFM_C f EmptyUFM _ = EmptyUFM
-intersectUFM_C f _ EmptyUFM = EmptyUFM
-intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
- where
- intersect_trees (LeafUFM i a) t2 =
- case lookUp t2 i of
- Nothing -> EmptyUFM
- Just b -> mkLeafUFM i (f a b)
-
- intersect_trees t1 (LeafUFM i a) =
- case lookUp t1 i of
- Nothing -> EmptyUFM
- Just b -> mkLeafUFM i (f b a)
-
- intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
- = intersect_branches
- (ask_about_common_ancestor
- (NodeUFMData j p)
- (NodeUFMData j' p'))
- where
- -- Given a disjoint j,j' (p >^ p' && p' >^ p):
- --
- -- j j'
- -- / \ + / \ ==> EmptyUFM
- -- t1 t2 t1' t2'
- --
- -- Fast, Ehh !
- --
- intersect_branches (NewRoot nd _) = EmptyUFM
-
- -- Now, if j == j':
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 x t1' t2 x t2'
- --
- intersect_branches (SameRoot)
- = mkSSNodeUFM (NodeUFMData j p)
- (intersect_trees t1 t1')
- (intersect_trees t2 t2')
- -- Now the 4 different other ways; all like this:
- --
- -- Given j >^ j' (and, say, j > j')
- --
- -- j j' t2 + j'
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1' t2'
- --
- -- This does cut down the search space quite a bit.
-
- intersect_branches (LeftRoot Leftt)
- = intersect_trees t1 right_t
- intersect_branches (LeftRoot Rightt)
- = intersect_trees t2 right_t
- intersect_branches (RightRoot Leftt)
- = intersect_trees left_t t1'
- intersect_branches (RightRoot Rightt)
- = intersect_trees left_t t2'
-
- intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
-\end{code}
-
-Now the usual set of `collection' operators, like map, fold, etc.
-
-\begin{code}
-foldUFM f a (NodeUFM _ _ t1 t2) = foldUFM f (foldUFM f a t2) t1
-foldUFM f a (LeafUFM _ obj) = f obj a
-foldUFM f a EmptyUFM = a
-\end{code}
-
-\begin{code}
-mapUFM fn EmptyUFM = EmptyUFM
-mapUFM fn fm = map_tree fn fm
-
-filterUFM fn EmptyUFM = EmptyUFM
-filterUFM fn fm = filter_tree pred fm
- where
- pred (i::FastInt) e = fn e
-
-filterUFM_Directly fn EmptyUFM = EmptyUFM
-filterUFM_Directly fn fm = filter_tree pred fm
- where
- pred i e = fn (mkUniqueGrimily (iBox i)) e
-\end{code}
-
-Note, this takes a long time, O(n), but
-because we dont want to do this very often, we put up with this.
-O'rable, but how often do we look at the size of
-a finite map?
-
-\begin{code}
-sizeUFM EmptyUFM = 0
-sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
-sizeUFM (LeafUFM _ _) = 1
-
-isNullUFM EmptyUFM = True
-isNullUFM _ = False
-
--- hashing is used in VarSet.uniqAway, and should be fast
--- We use a cheap and cheerful method for now
-hashUFM EmptyUFM = 0
-hashUFM (NodeUFM n _ _ _) = iBox n
-hashUFM (LeafUFM n _) = iBox n
-\end{code}
-
-looking up in a hurry is the {\em whole point} of this binary tree lark.
-Lookup up a binary tree is easy (and fast).
-
-\begin{code}
-elemUFM key fm = maybeToBool (lookupUFM fm key)
-elemUFM_Directly key fm = maybeToBool (lookupUFM_Directly fm key)
-
-lookupUFM fm key = lookUp fm (getKey# (getUnique key))
-lookupUFM_Directly fm key = lookUp fm (getKey# key)
-
-lookupWithDefaultUFM fm deflt key
- = case lookUp fm (getKey# (getUnique key)) of
- Nothing -> deflt
- Just elt -> elt
-
-lookupWithDefaultUFM_Directly fm deflt key
- = case lookUp fm (getKey# key) of
- Nothing -> deflt
- Just elt -> elt
-
-lookUp EmptyUFM _ = Nothing
-lookUp fm i = lookup_tree fm
- where
- lookup_tree :: UniqFM a -> Maybe a
-
- lookup_tree (LeafUFM j b)
- | j ==# i = Just b
- | otherwise = Nothing
- lookup_tree (NodeUFM j p t1 t2)
- | j ># i = lookup_tree t1
- | otherwise = lookup_tree t2
-
- lookup_tree EmptyUFM = panic "lookup Failed"
-\end{code}
-
-folds are *wonderful* things.
-
-\begin{code}
-eltsUFM fm = foldUFM (:) [] fm
-
-ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily (iBox iu), elt) : rest) [] fm
-
-keysUFM fm = fold_tree (\ iu elt rest -> mkUniqueGrimily (iBox iu) : rest) [] fm
-
-fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
-fold_tree f a (LeafUFM iu obj) = f iu obj a
-fold_tree f a EmptyUFM = a
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{The @UniqFM@ type, and its functions}
-%* *
-%************************************************************************
-
-You should always use these to build the tree.
-There are 4 versions of mkNodeUFM, depending on
-the strictness of the two sub-tree arguments.
-The strictness is used *both* to prune out
-empty trees, *and* to improve performance,
-stoping needless thunks lying around.
-The rule of thumb (from experence with these trees)
-is make thunks strict, but data structures lazy.
-If in doubt, use mkSSNodeUFM, which has the `strongest'
-functionality, but may do a few needless evaluations.
-
-\begin{code}
-mkLeafUFM :: FastInt -> a -> UniqFM a
-mkLeafUFM i a = LeafUFM i a
-
--- The *ONLY* ways of building a NodeUFM.
-
-mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
-mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
-mkSSNodeUFM (NodeUFMData j p) t1 t2
- = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
- NodeUFM j p t1 t2
-
-mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
-mkSLNodeUFM (NodeUFMData j p) t1 t2
- = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
- NodeUFM j p t1 t2
-
-mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
-mkLSNodeUFM (NodeUFMData j p) t1 t2
- = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
- NodeUFM j p t1 t2
-
-mkLLNodeUFM (NodeUFMData j p) t1 t2
- = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
- NodeUFM j p t1 t2
-
-correctNodeUFM
- :: Int
- -> Int
- -> UniqFM a
- -> UniqFM a
- -> Bool
-
-correctNodeUFM j p t1 t2
- = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
- where
- correct low high _ (LeafUFM i _)
- = low <= iBox i && iBox i <= high
- correct low high above_p (NodeUFM j p _ _)
- = low <= iBox j && iBox j <= high && above_p > iBox p
- correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
-\end{code}
-
-Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
-and if necessary do $\lambda$ lifting on our functions that are bound.
-
-\begin{code}
-insert_ele
- :: (a -> a -> a) -- old -> new -> result
- -> UniqFM a
- -> FastInt
- -> a
- -> UniqFM a
-
-insert_ele f EmptyUFM i new = mkLeafUFM i new
-
-insert_ele f (LeafUFM j old) i new
- | j ># i =
- mkLLNodeUFM (getCommonNodeUFMData
- (indexToRoot i)
- (indexToRoot j))
- (mkLeafUFM i new)
- (mkLeafUFM j old)
- | j ==# i = mkLeafUFM j (f old new)
- | otherwise =
- mkLLNodeUFM (getCommonNodeUFMData
- (indexToRoot i)
- (indexToRoot j))
- (mkLeafUFM j old)
- (mkLeafUFM i new)
-
-insert_ele f n@(NodeUFM j p t1 t2) i a
- | i <# j
- = if (i >=# (j -# p))
- then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
- else mkLLNodeUFM (getCommonNodeUFMData
- (indexToRoot i)
- ((NodeUFMData j p)))
- (mkLeafUFM i a)
- n
- | otherwise
- = if (i <=# ((j -# _ILIT(1)) +# p))
- then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
- else mkLLNodeUFM (getCommonNodeUFMData
- (indexToRoot i)
- ((NodeUFMData j p)))
- n
- (mkLeafUFM i a)
-\end{code}
+newtype UniqFM ele = UFM (M.IntMap ele)
+
+emptyUFM = UFM M.empty
+isNullUFM (UFM m) = M.null m
+unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v)
+unitDirectlyUFM u v = UFM (M.singleton (getKey u) v)
+listToUFM = foldl (\m (k, v) -> addToUFM m k v) emptyUFM
+listToUFM_Directly = foldl (\m (u, v) -> addToUFM_Directly m u v) emptyUFM
+listToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) emptyUFM
+
+addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m)
+addListToUFM = foldl (\m (k, v) -> addToUFM m k v)
+addListToUFM_Directly = foldl (\m (k, v) -> addToUFM_Directly m k v)
+addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m)
+
+-- Arguments of combining function of M.insertWith and addToUFM_C are flipped.
+addToUFM_C f (UFM m) k v =
+ UFM (M.insertWith (flip f) (getKey $ getUnique k) v m)
+addToUFM_Acc exi new (UFM m) k v =
+ UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m)
+addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v)
+
+delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)
+delListFromUFM = foldl delFromUFM
+delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
+
+-- M.union is left-biased, plusUFM should be right-biased.
+plusUFM (UFM x) (UFM y) = UFM (M.union y x)
+plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)
+minusUFM (UFM x) (UFM y) = UFM (M.difference x y)
+intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y)
+#if __GLASGOW_HASKELL__ >= 611
+intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)
+#else
+-- In GHC 6.10, intersectionWith is (a -> b -> a) instead of (a -> b -> c),
+-- so we need to jump through some hoops to get the more general type.
+intersectUFM_C f (UFM x) (UFM y) = UFM z
+ where z = let x' = M.map Left x
+ f' (Left a) b = Right (f a b)
+ f' (Right _) _ = panic "intersectUFM_C: f': Right"
+ z' = M.intersectionWith f' x' y
+ fromRight (Right a) = a
+ fromRight _ = panic "intersectUFM_C: Left"
+ in M.map fromRight z'
+#endif