dependent-map 0.2.2.0 → 0.2.3.0
raw patch · 4 files changed
+309/−182 lines, 4 filesdep ~basedep ~dependent-sum
Dependency ranges changed: base, dependent-sum
Files
- dependent-map.cabal +4/−3
- src/Data/Dependent/Map.hs +196/−174
- src/Data/Dependent/Map/Internal.hs +45/−5
- src/Data/Dependent/Map/PtrEquality.hs +64/−0
dependent-map.cabal view
@@ -1,5 +1,5 @@ name: dependent-map-version: 0.2.2.0+version: 0.2.3.0 stability: provisional cabal-version: >= 1.6@@ -33,11 +33,12 @@ hs-source-dirs: src ghc-options: -fwarn-unused-imports -fwarn-unused-binds exposed-modules: Data.Dependent.Map- other-modules: Data.Dependent.Map.Internal+ other-modules: Data.Dependent.Map.Internal,+ Data.Dependent.Map.PtrEquality if impl(ghc < 7.8) other-modules: Data.Dependent.Map.Typeable build-depends: base >= 3 && < 5, containers,- dependent-sum >= 0.3.2 && < 0.4+ dependent-sum >= 0.3.2 if impl(ghc >= 7.2) && impl(ghc < 7.8) ghc-options: -trust base -trust dependent-sum
src/Data/Dependent/Map.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-} #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PolyKinds #-}@@ -42,6 +42,7 @@ , delete , adjust , adjustWithKey+ , adjustWithKey' , update , updateWithKey , updateLookupWithKey@@ -120,6 +121,8 @@ -- * Min\/Max , findMin , findMax+ , lookupMin+ , lookupMax , deleteMin , deleteMax , deleteFindMin@@ -153,6 +156,7 @@ #endif import Data.Some import Text.Read+import Data.Dependent.Map.PtrEquality instance (GCompare k) => Monoid (DMap k f) where mempty = empty@@ -236,11 +240,38 @@ where go :: DMap k f -> DMap k f go Tip = singleton kx x- go (Bin sz ky y l r) = case gcompare kx ky of- GLT -> balance ky y (go l) r- GGT -> balance ky y l (go r)- GEQ -> Bin sz kx x l r+ go t@(Bin sz ky y l r) = case gcompare kx ky of+ GLT -> let !l' = go l+ in if l' `ptrEq` l+ then t+ else balance ky y l' r+ GGT -> let !r' = go r+ in if r' `ptrEq` r+ then t+ else balance ky y l r'+ GEQ+ | kx `ptrEq` ky && x `ptrEq` y -> t+ | otherwise -> Bin sz kx x l r +-- | /O(log n)/. Insert a new key and value in the map if the key+-- is not already present. If the key is already present, @insertR@+-- does nothing.+insertR :: forall k f v. GCompare k => k v -> f v -> DMap k f -> DMap k f+insertR kx x = kx `seq` go+ where+ go :: DMap k f -> DMap k f+ go Tip = singleton kx x+ go t@(Bin sz ky y l r) = case gcompare kx ky of+ GLT -> let !l' = go l+ in if l' `ptrEq` l+ then t+ else balance ky y l' r+ GGT -> let !r' = go r+ in if r' `ptrEq` r+ then t+ else balance ky y l r'+ GEQ -> t+ -- | /O(log n)/. Insert with a function, combining new value and old value. -- @'insertWith' f key value mp@ -- will insert the entry @key :=> value@ into @mp@ if key does@@ -343,8 +374,28 @@ -- | /O(log n)/. Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. adjustWithKey :: GCompare k => (k v -> f v -> f v) -> k v -> DMap k f -> DMap k f-adjustWithKey f = updateWithKey (\k' x' -> Just (f k' x'))+adjustWithKey f0 !k0 = go f0 k0+ where+ go :: GCompare k => (k v -> f v -> f v) -> k v -> DMap k f -> DMap k f+ go _f _k Tip = Tip+ go f k (Bin sx kx x l r) =+ case gcompare k kx of+ GLT -> Bin sx kx x (go f k l) r+ GGT -> Bin sx kx x l (go f k r)+ GEQ -> Bin sx kx (f kx x) l r +-- | /O(log n)/. A strict version of 'adjustWithKey'.+adjustWithKey' :: GCompare k => (k v -> f v -> f v) -> k v -> DMap k f -> DMap k f+adjustWithKey' f0 !k0 = go f0 k0+ where+ go :: GCompare k => (k v -> f v -> f v) -> k v -> DMap k f -> DMap k f+ go _f _k Tip = Tip+ go f k (Bin sx kx x l r) =+ case gcompare k kx of+ GLT -> Bin sx kx x (go f k l) r+ GGT -> Bin sx kx x l (go f k r)+ GEQ -> let !x' = f kx x in Bin sx kx x' l r+ -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.@@ -440,12 +491,12 @@ where sizeL = size l --- | /O(log n)/. Update the element at /index/. Calls 'error' when an+-- | /O(log n)/. Update the element at /index/. Does nothing when an -- invalid index is used. updateAt :: (forall v. k v -> f v -> Maybe (f v)) -> Int -> DMap k f -> DMap k f updateAt f i0 t = i0 `seq` go i0 t where- go _ Tip = error "Map.updateAt: index out of range"+ go _ Tip = Tip go i (Bin sx kx x l r) = case compare i sizeL of LT -> balance kx x (go i l) r GT -> balance kx x l (go (i-sizeL-1) r)@@ -468,16 +519,34 @@ -- | /O(log n)/. The minimal key of the map. Calls 'error' is the map is empty. findMin :: DMap k f -> DSum k f-findMin (Bin _ kx x Tip _) = kx :=> x-findMin (Bin _ _ _ l _) = findMin l-findMin Tip = error "Map.findMin: empty map has no minimal element"+findMin m = case lookupMin m of+ Just x -> x+ Nothing -> error "Map.findMin: empty map has no minimal element" +lookupMin :: DMap k f -> Maybe (DSum k f)+lookupMin m = case m of+ Tip -> Nothing+ Bin _ kx x l _ -> Just $! go kx x l+ where+ go :: k v -> f v -> DMap k f -> DSum k f+ go kx x Tip = kx :=> x+ go _ _ (Bin _ kx x l _) = go kx x l+ -- | /O(log n)/. The maximal key of the map. Calls 'error' is the map is empty. findMax :: DMap k f -> DSum k f-findMax (Bin _ kx x _ Tip) = kx :=> x-findMax (Bin _ _ _ _ r) = findMax r-findMax Tip = error "Map.findMax: empty map has no maximal element"+findMax m = case lookupMax m of+ Just x -> x+ Nothing -> error "Map.findMax: empty map has no maximal element" +lookupMax :: DMap k f -> Maybe (DSum k f)+lookupMax m = case m of+ Tip -> Nothing+ Bin _ kx x _ r -> Just $! go kx x r+ where+ go :: k v -> f v -> DMap k f -> DSum k f+ go kx x Tip = kx :=> x+ go _ _ (Bin _ kx x _ r) = go kx x r+ -- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty. deleteMin :: DMap k f -> DMap k f deleteMin (Bin _ _ _ Tip r) = r@@ -510,18 +579,6 @@ go (Bin _ kx x l r) = balance kx x l (go r) go Tip = Tip --- | /O(log n)/. Retrieves the minimal (key :=> value) entry of the map, and--- the map stripped of that element, or 'Nothing' if passed an empty map.-minViewWithKey :: DMap k f -> Maybe (DSum k f, DMap k f)-minViewWithKey Tip = Nothing-minViewWithKey x = Just (deleteFindMin x)---- | /O(log n)/. Retrieves the maximal (key :=> value) entry of the map, and--- the map stripped of that element, or 'Nothing' if passed an empty map.-maxViewWithKey :: DMap k f -> Maybe (DSum k f, DMap k f)-maxViewWithKey Tip = Nothing-maxViewWithKey x = Just (deleteFindMax x)- {-------------------------------------------------------------------- Union. --------------------------------------------------------------------}@@ -538,161 +595,102 @@ unionsWithKey f ts = foldlStrict (unionWithKey f) empty ts --- | /O(n+m)/.+-- | /O(m*log(n\/m + 1)), m <= n/. -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. -- It prefers @t1@ when duplicate keys are encountered, -- i.e. (@'union' == 'unionWith' 'const'@).--- The implementation uses the efficient /hedge-union/ algorithm.--- Hedge-union is more efficient on (bigset \``union`\` smallset). union :: GCompare k => DMap k f -> DMap k f -> DMap k f-union Tip t2 = t2 union t1 Tip = t1-union t1 t2 = hedgeUnionL (const LT) (const GT) t1 t2---- left-biased hedge union-hedgeUnionL :: GCompare k- => (Some k -> Ordering) -> (Some k -> Ordering) -> DMap k f -> DMap k f- -> DMap k f-hedgeUnionL _ _ t1 Tip- = t1-hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)- = combine kx x (filterGt cmplo l) (filterLt cmphi r)-hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2- = combine kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2)) - (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))- where- cmpkx k = compare (This kx) k+union t1 (Bin _ kx x Tip Tip) = insertR kx x t1+union Tip t2 = t2+union (Bin _ kx x Tip Tip) t2 = insert kx x t2+union t1@(Bin _ k1 x1 l1 r1) t2 = case split k1 t2 of+ (l2, r2)+ | l1 `ptrEq` l1l2 && r1 `ptrEq` r1r2 -> t1+ | otherwise -> combine k1 x1 l1l2 r1r2+ where !l1l2 = l1 `union` l2+ !r1r2 = r1 `union` r2 {-------------------------------------------------------------------- Union with a combining function --------------------------------------------------------------------} -- | /O(n+m)/.--- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.--- Hedge-union is more efficient on (bigset \``union`\` smallset).+-- Union with a combining function. unionWithKey :: GCompare k => (forall v. k v -> f v -> f v -> f v) -> DMap k f -> DMap k f -> DMap k f-unionWithKey _ Tip t2 = t2 unionWithKey _ t1 Tip = t1-unionWithKey f t1 t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2--hedgeUnionWithKey :: forall k f. GCompare k- => (forall v. k v -> f v -> f v -> f v)- -> (Some k -> Ordering) -> (Some k -> Ordering)- -> DMap k f -> DMap k f- -> DMap k f-hedgeUnionWithKey _ _ _ t1 Tip- = t1-hedgeUnionWithKey _ cmplo cmphi Tip (Bin _ kx x l r)- = combine kx x (filterGt cmplo l) (filterLt cmphi r)-hedgeUnionWithKey f cmplo cmphi (Bin _ (kx :: k tx) x l r) t2- = combine kx newx (hedgeUnionWithKey f cmplo cmpkx l lt) - (hedgeUnionWithKey f cmpkx cmphi r gt)- where- cmpkx k = compare (This kx) k- lt = trim cmplo cmpkx t2- (found,gt) = trimLookupLo (This kx) cmphi t2- newx :: f tx- newx = case found of- Nothing -> x- Just (ky :=> y) -> case geq kx ky of- Just Refl -> f kx x y- Nothing -> error "DMap.union: inconsistent GEq instance"+unionWithKey _ Tip t2 = t2+unionWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of+ (l2, mx2, r2) -> case mx2 of+ Nothing -> combine k1 x1 l1l2 r1r2+ Just x2 -> combine k1 (f k1 x1 x2) l1l2 r1r2+ where !l1l2 = unionWithKey f l1 l2+ !r1r2 = unionWithKey f r1 r2 {-------------------------------------------------------------------- Difference --------------------------------------------------------------------} --- | /O(n+m)/. Difference of two maps. +-- | /O(m * log (n\/m + 1)), m <= n/. Difference of two maps. -- Return elements of the first map not existing in the second map.--- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. difference :: GCompare k => DMap k f -> DMap k g -> DMap k f difference Tip _ = Tip difference t1 Tip = t1-difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2--hedgeDiff :: GCompare k- => (Some k -> Ordering) -> (Some k -> Ordering) -> DMap k f -> DMap k g- -> DMap k f-hedgeDiff _ _ Tip _- = Tip-hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip - = combine kx x (filterGt cmplo l) (filterLt cmphi r)-hedgeDiff cmplo cmphi t (Bin _ kx _ l r) - = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l) - (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)- where- cmpkx k = compare (This kx) k +difference t1 (Bin _ k2 _x2 l2 r2) = case split k2 t1 of+ (l1, r1)+ | size t1 == size l1l2 + size r1r2 -> t1+ | otherwise -> merge l1l2 r1r2+ where+ !l1l2 = l1 `difference` l2+ !r1r2 = r1 `difference` r2 -- | /O(n+m)/. Difference with a combining function. When two equal keys are -- encountered, the combining function is applied to the key and both values. -- If it returns 'Nothing', the element is discarded (proper set difference). If -- it returns (@'Just' y@), the element is updated with a new value @y@. --- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. differenceWithKey :: GCompare k => (forall v. k v -> f v -> g v -> Maybe (f v)) -> DMap k f -> DMap k g -> DMap k f differenceWithKey _ Tip _ = Tip differenceWithKey _ t1 Tip = t1-differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2--hedgeDiffWithKey :: GCompare k- => (forall v. k v -> f v -> g v -> Maybe (f v))- -> (Some k -> Ordering) -> (Some k -> Ordering)- -> DMap k f -> DMap k g- -> DMap k f-hedgeDiffWithKey _ _ _ Tip _- = Tip-hedgeDiffWithKey _ cmplo cmphi (Bin _ kx x l r) Tip- = combine kx x (filterGt cmplo l) (filterLt cmphi r)-hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r) - = case found of- Nothing -> merge tl tr- Just (ky :=> y) -> - case geq kx ky of- Nothing -> error "DMap.difference: inconsistent GEq instance"- Just Refl ->- case f ky y x of- Nothing -> merge tl tr- Just z -> combine ky z tl tr- where- cmpkx k = compare (This kx) k - lt = trim cmplo cmpkx t- (found,gt) = trimLookupLo (This kx) cmphi t- tl = hedgeDiffWithKey f cmplo cmpkx lt l- tr = hedgeDiffWithKey f cmpkx cmphi gt r--+differenceWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of+ (l2, mx2, r2) -> case mx2 of+ Nothing -> combine k1 x1 l1l2 r1r2+ Just x2 -> case f k1 x1 x2 of+ Nothing -> merge l1l2 r1r2+ Just x1x2 -> combine k1 x1x2 l1l2 r1r2+ where !l1l2 = differenceWithKey f l1 l2+ !r1r2 = differenceWithKey f r1 r2 {-------------------------------------------------------------------- Intersection --------------------------------------------------------------------} --- | /O(n+m)/. Intersection of two maps.+-- | /O(m * log (n\/m + 1), m <= n/. Intersection of two maps. -- Return data in the first map for the keys existing in both maps. -- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@). intersection :: GCompare k => DMap k f -> DMap k f -> DMap k f-intersection m1 m2- = intersectionWithKey (\_ x _ -> x) m1 m2+intersection Tip _ = Tip+intersection _ Tip = Tip+intersection t1@(Bin s1 k1 x1 l1 r1) t2 =+ let !(l2, found, r2) = splitMember k1 t2+ !l1l2 = intersection l1 l2+ !r1r2 = intersection r1 r2+ in if found+ then if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1+ then t1+ else combine k1 x1 l1l2 r1r2+ else merge l1l2 r1r2 --- | /O(n+m)/. Intersection with a combining function.--- Intersection is more efficient on (bigset \``intersection`\` smallset).+-- | /O(m * log (n\/m + 1), m <= n/. Intersection with a combining function. intersectionWithKey :: GCompare k => (forall v. k v -> f v -> g v -> h v) -> DMap k f -> DMap k g -> DMap k h intersectionWithKey _ Tip _ = Tip intersectionWithKey _ _ Tip = Tip-intersectionWithKey f t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 x2 l2 r2) =- if s1 >= s2 then- let (lt,found,gt) = splitLookupWithKey k2 t1- tl = intersectionWithKey f lt l2- tr = intersectionWithKey f gt r2- in case found of- Just (k,x) -> combine k (f k x x2) tl tr- Nothing -> merge tl tr- else let (lt,found,gt) = splitLookup k1 t2- tl = intersectionWithKey f l1 lt- tr = intersectionWithKey f r1 gt- in case found of- Just x -> combine k1 (f k1 x1 x) tl tr- Nothing -> merge tl tr--+intersectionWithKey f (Bin s1 k1 x1 l1 r1) t2 =+ let !(l2, found, r2) = splitLookup k1 t2+ !l1l2 = intersectionWithKey f l1 l2+ !r1r2 = intersectionWithKey f r1 r2+ in case found of+ Nothing -> merge l1l2 r1r2+ Just x2 -> combine k1 (f k1 x1 x2) l1l2 r1r2 {-------------------------------------------------------------------- Submap@@ -747,21 +745,28 @@ filterWithKey p = go where go Tip = Tip- go (Bin _ kx x l r)- | p kx x = combine kx x (go l) (go r)- | otherwise = merge (go l) (go r)+ go t@(Bin _ kx x l r)+ | p kx x = if l' `ptrEq` l && r' `ptrEq` r+ then t+ else combine kx x l' r'+ | otherwise = merge l' r'+ where !l' = go l+ !r' = go r -- | /O(n)/. Partition the map according to a predicate. The first -- map contains all elements that satisfy the predicate, the second all -- elements that fail the predicate. See also 'split'. partitionWithKey :: GCompare k => (forall v. k v -> f v -> Bool) -> DMap k f -> (DMap k f, DMap k f)-partitionWithKey _ Tip = (Tip,Tip)-partitionWithKey p (Bin _ kx x l r)- | p kx x = (combine kx x l1 r1,merge l2 r2)- | otherwise = (merge l1 r1,combine kx x l2 r2)+partitionWithKey p0 m0 = toPair (go p0 m0) where- (l1,l2) = partitionWithKey p l- (r1,r2) = partitionWithKey p r+ go :: GCompare k => (forall v. k v -> f v -> Bool) -> DMap k f -> (DMap k f :*: DMap k f)+ go _ Tip = (Tip :*: Tip)+ go p (Bin _ kx x l r)+ | p kx x = (combine kx x l1 r1 :*: merge l2 r2)+ | otherwise = (merge l1 r1 :*: combine kx x l2 r2)+ where+ (l1 :*: l2) = go p l+ (r1 :*: r2) = go p r -- | /O(n)/. Map keys\/values and collect the 'Just' results. mapMaybeWithKey :: GCompare k => (forall v. k v -> f v -> Maybe (g v)) -> DMap k f -> DMap k g@@ -775,13 +780,18 @@ -- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. mapEitherWithKey :: GCompare k => (forall v. k v -> f v -> Either (g v) (h v)) -> DMap k f -> (DMap k g, DMap k h)-mapEitherWithKey _ Tip = (Tip, Tip)-mapEitherWithKey f (Bin _ kx x l r) = case f kx x of- Left y -> (combine kx y l1 r1, merge l2 r2)- Right z -> (merge l1 r1, combine kx z l2 r2)- where- (l1,l2) = mapEitherWithKey f l- (r1,r2) = mapEitherWithKey f r+mapEitherWithKey f0 = toPair . go f0+ where+ go :: GCompare k+ => (forall v. k v -> f v -> Either (g v) (h v))+ -> DMap k f -> (DMap k g :*: DMap k h)+ go _ Tip = (Tip :*: Tip)+ go f (Bin _ kx x l r) = case f kx x of+ Left y -> (combine kx y l1 r1 :*: merge l2 r2)+ Right z -> (merge l1 r1 :*: combine kx z l2 r2)+ where+ (l1,l2) = mapEitherWithKey f l+ (r1,r2) = mapEitherWithKey f r {-------------------------------------------------------------------- Mapping@@ -1019,7 +1029,6 @@ buildB :: DMap k f -> k v -> f v -> (DMap k f -> a -> b) -> DMap k f -> a -> b buildB l k x c r zs = c (bin k x l r) zs - {-------------------------------------------------------------------- Split --------------------------------------------------------------------}@@ -1028,37 +1037,50 @@ -- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@. -- Any key equal to @k@ is found in neither @map1@ nor @map2@. split :: forall k f v. GCompare k => k v -> DMap k f -> (DMap k f, DMap k f)-split k = go+split k = toPair . go where- go :: DMap k f -> (DMap k f, DMap k f)- go Tip = (Tip, Tip)+ go :: DMap k f -> (DMap k f :*: DMap k f)+ go Tip = (Tip :*: Tip) go (Bin _ kx x l r) = case gcompare k kx of- GLT -> let (lt,gt) = go l in (lt,combine kx x gt r)- GGT -> let (lt,gt) = go r in (combine kx x l lt,gt)- GEQ -> (l,r)+ GLT -> let !(lt :*: gt) = go l in (lt :*: combine kx x gt r)+ GGT -> let !(lt :*: gt) = go r in (combine kx x l lt :*: gt)+ GEQ -> (l :*: r)+{-# INLINABLE split #-} -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just -- like 'split' but also returns @'lookup' k map@. splitLookup :: forall k f v. GCompare k => k v -> DMap k f -> (DMap k f, Maybe (f v), DMap k f)-splitLookup k = go+splitLookup k = toTriple . go where- go :: DMap k f -> (DMap k f, Maybe (f v), DMap k f)- go Tip = (Tip,Nothing,Tip)+ go :: DMap k f -> Triple' (DMap k f) (Maybe (f v)) (DMap k f)+ go Tip = Triple' Tip Nothing Tip go (Bin _ kx x l r) = case gcompare k kx of- GLT -> let (lt,z,gt) = go l in (lt,z,combine kx x gt r)- GGT -> let (lt,z,gt) = go r in (combine kx x l lt,z,gt)- GEQ -> (l,Just x,r)+ GLT -> let !(Triple' lt z gt) = go l in Triple' lt z (combine kx x gt r)+ GGT -> let !(Triple' lt z gt) = go r in Triple' (combine kx x l lt) z gt+ GEQ -> Triple' l (Just x) r +-- | /O(log n)/. The expression (@'splitMember' k map@) splits a map just+-- like 'split' but also returns @'member' k map@.+splitMember :: forall k f v. GCompare k => k v -> DMap k f -> (DMap k f, Bool, DMap k f)+splitMember k = toTriple . go+ where+ go :: DMap k f -> Triple' (DMap k f) Bool (DMap k f)+ go Tip = Triple' Tip False Tip+ go (Bin _ kx x l r) = case gcompare k kx of+ GLT -> let !(Triple' lt z gt) = go l in Triple' lt z (combine kx x gt r)+ GGT -> let !(Triple' lt z gt) = go r in Triple' (combine kx x l lt) z gt+ GEQ -> Triple' l True r+ -- | /O(log n)/. splitLookupWithKey :: forall k f v. GCompare k => k v -> DMap k f -> (DMap k f, Maybe (k v, f v), DMap k f)-splitLookupWithKey k = go+splitLookupWithKey k = toTriple . go where- go :: DMap k f -> (DMap k f, Maybe (k v, f v), DMap k f)- go Tip = (Tip,Nothing,Tip)+ go :: DMap k f -> Triple' (DMap k f) (Maybe (k v, f v)) (DMap k f)+ go Tip = Triple' Tip Nothing Tip go (Bin _ kx x l r) = case gcompare k kx of- GLT -> let (lt,z,gt) = go l in (lt,z,combine kx x gt r)- GGT -> let (lt,z,gt) = go r in (combine kx x l lt,z,gt)- GEQ -> (l,Just (kx, x),r)+ GLT -> let !(Triple' lt z gt) = go l in Triple' lt z (combine kx x gt r)+ GGT -> let !(Triple' lt z gt) = go r in Triple' (combine kx x l lt) z gt+ GEQ -> Triple' l (Just (kx, x)) r {-------------------------------------------------------------------- Eq converts the tree to a list. In a lazy setting, this
src/Data/Dependent/Map/Internal.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-}@@ -182,11 +184,49 @@ -- > deleteFindMin Error: can not return the minimal element of an empty map deleteFindMin :: DMap k f -> (DSum k f, DMap k f)-deleteFindMin t - = case t of- Bin _ k x Tip r -> (k :=> x ,r)- Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)- Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)+deleteFindMin t = case minViewWithKey t of+ Nothing -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)+ Just p -> p++-- | A strict pair.+data (:*:) a b = !a :*: !b+infixr 1 :*:++-- | Convert a strict pair to a pair.+toPair :: a :*: b -> (a, b)+toPair (a :*: b) = (a, b)+{-# INLINE toPair #-}++data Triple' a b c = Triple' !a !b !c++-- | Convert a strict triple to a triple.+toTriple :: Triple' a b c -> (a, b, c)+toTriple (Triple' a b c) = (a, b, c)+{-# INLINE toTriple #-}++-- | /O(log n)/. Retrieves the minimal (key :=> value) entry of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+minViewWithKey :: forall k f . DMap k f -> Maybe (DSum k f, DMap k f)+minViewWithKey Tip = Nothing+minViewWithKey (Bin _ k0 x0 l0 r0) = Just $! toPair $ go k0 x0 l0 r0+ where+ go :: k v -> f v -> DMap k f -> DMap k f -> DSum k f :*: DMap k f+ go k x Tip r = (k :=> x) :*: r+ go k x (Bin _ kl xl ll lr) r =+ let !(km :*: l') = go kl xl ll lr+ in (km :*: balance k x l' r)++-- | /O(log n)/. Retrieves the maximal (key :=> value) entry of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+maxViewWithKey :: forall k f . DMap k f -> Maybe (DSum k f, DMap k f)+maxViewWithKey Tip = Nothing+maxViewWithKey (Bin _ k0 x0 l0 r0) = Just $! toPair $ go k0 x0 l0 r0+ where+ go :: k v -> f v -> DMap k f -> DMap k f -> DSum k f :*: DMap k f+ go k x l Tip = (k :=> x) :*: l+ go k x l (Bin _ kr xr rl rr) =+ let !(km :*: r') = go kr xr rl rr+ in (km :*: balance k x l r') -- | /O(log n)/. Delete and find the maximal element. --
+ src/Data/Dependent/Map/PtrEquality.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE MagicHash #-}+#endif++{-# OPTIONS_HADDOCK hide #-}++-- | Really unsafe pointer equality+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- This contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.++module Data.Dependent.Map.PtrEquality (ptrEq, hetPtrEq) where++#ifdef __GLASGOW_HASKELL__+import GHC.Exts ( reallyUnsafePtrEquality# )+import Unsafe.Coerce ( unsafeCoerce )+#if __GLASGOW_HASKELL__ < 707+import GHC.Exts ( (==#) )+#else+import GHC.Exts ( isTrue# )+#endif+#endif++-- | Checks if two pointers are equal. Yes means yes;+-- no means maybe. The values should be forced to at least+-- WHNF before comparison to get moderately reliable results.+ptrEq :: a -> a -> Bool++-- | Checks if two pointers are equal, without requiring+-- them to have the same type. The values should be forced+-- to at least WHNF before comparison to get moderately+-- reliable results.+hetPtrEq :: a -> b -> Bool++#ifdef __GLASGOW_HASKELL__+#if __GLASGOW_HASKELL__ < 707+ptrEq x y = reallyUnsafePtrEquality# x y ==# 1#+hetPtrEq x y = unsafeCoerce reallyUnsafePtrEquality# x y ==# 1#+#else+ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)+hetPtrEq x y = isTrue# (unsafeCoerce reallyUnsafePtrEquality# x y)+#endif++#else+-- Not GHC+ptrEq _ _ = False+hetPtrEq _ _ = False+#endif++{-# INLINE ptrEq #-}+{-# INLINE hetPtrEq #-}++infix 4 `ptrEq`+infix 4 `hetPtrEq`