list-tries 0.2 → 0.3
raw patch · 5 files changed
+473/−489 lines, 5 filesdep ~containersPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: containers
API changes (from Hackage documentation)
Files
- CHANGELOG.txt +12/−0
- Data/ListTrie/Base.hs +166/−147
- Data/ListTrie/Base/Map.hs +1/−46
- Data/ListTrie/Patricia/Base.hs +289/−278
- list-tries.cabal +5/−18
CHANGELOG.txt view
@@ -1,3 +1,15 @@+2010-09-09, 0.3:+ Fixed strictness of the strict versions of the following non-Patricia+ functions: insert, adjust, alter, union, difference, intersection,+ mapInKeys; as well as the Patricia versions of insert and adjust. Thanks to+ Brian Bloniarz for the bug report.++ Applied the static argument transformation throughout, improving+ performance.++ Dropped support for containers < 0.3; GHC 6.12 has been out long enough, and+ support for older versions is too crippled to make it worthwhile.+ 2010-04-06, 0.2: Dependency update, nothing more.
Data/ListTrie/Base.hs view
@@ -1,7 +1,7 @@ -- File created: 2008-11-13 21:13:55 {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies- , FlexibleContexts #-}+ , FlexibleContexts, Rank2Types #-} module Data.ListTrie.Base ( Trie(..)@@ -68,31 +68,35 @@ tMap :: Trie trie st map k => trie map k a -> CMap trie map k a tMap = snd . tParts -mapVal :: Trie trie st map k => trie map k a+mapVal :: Trie trie st map k => (forall x y. (x -> y) -> x -> y)+ -> trie map k a -> (st a -> st a) -> trie map k a-mapVal tr f = mkTrie (f . tVal $ tr) (tMap tr)+mapVal ($$) tr f = (mkTrie $$ (f . tVal $ tr)) (tMap tr) mapMap :: (Trie trie st map k1, Trie trie st map k2)- => trie map k1 a+ => (forall x y. (x -> y) -> x -> y)+ -> trie map k1 a -> (CMap trie map k1 a -> CMap trie map k2 a) -> trie map k2 a-mapMap tr f = mkTrie (tVal tr) (f . tMap $ tr)+mapMap ($$) tr f = (mkTrie $$ tVal tr) (f . tMap $ tr) -onVals :: Trie trie st map k => (st a -> st b -> st c)+onVals :: Trie trie st map k => (forall x y. (x -> y) -> x -> y)+ -> (st a -> st b -> st c) -> trie map k a -> trie map k b -> st c-onVals f a b = f (tVal a) (tVal b)+onVals ($$) f a b = f $$ tVal a $$ tVal b -onMaps :: Trie trie st map k => ( CMap trie map k a+onMaps :: Trie trie st map k => (forall x y. (x -> y) -> x -> y)+ -> ( CMap trie map k a -> CMap trie map k b -> CMap trie map k c ) -> trie map k a -> trie map k b -> CMap trie map k c-onMaps f a b = f (tMap a) (tMap b)+onMaps ($$) f a b = f $$ tMap a $$ tMap b ----------------------- @@ -119,22 +123,24 @@ -- O(min(m,s)) insertWith :: (Alt st a, Trie trie st map k) => (a -> a -> a) -> [k] -> a -> trie map k a -> trie map k a-insertWith = genericInsertWith (<$>)+insertWith = genericInsertWith ($) (<$>) -- O(min(m,s)) insertWith' :: (Alt st a, Boolable (st a), Trie trie st map k) => (a -> a -> a) -> [k] -> a -> trie map k a -> trie map k a-insertWith' = (seq <*>) .: genericInsertWith (<$!>)+insertWith' = (seq <*>) .: genericInsertWith ($!) (<$!>) genericInsertWith :: (Alt st a, Trie trie st map k)- => ((a -> a) -> st a -> st a)+ => (forall x y. (x -> y) -> x -> y)+ -> ((a -> a) -> st a -> st a) -> (a -> a -> a) -> [k] -> a -> trie map k a -> trie map k a-genericInsertWith (<$$>) f [] new tr =- mapVal tr $ \old -> (f new <$$> old) <|> pure new+genericInsertWith ($$) (<$$>) f = go+ where+ go [] new tr =+ mapVal ($$) tr $ \old -> (f new <$$> old) <|> pure new -genericInsertWith (<$$>) f (x:xs) val tr = mapMap tr $ \m ->- Map.insertWith (\_ old -> genericInsertWith (<$$>) f xs val old)- x (singleton xs val) m+ go (x:xs) val tr = mapMap ($$) tr $ \m ->+ Map.insertWith (\_ old -> go xs val old) x (singleton xs val) m -- O(min(m,s)) delete :: (Alt st a, Boolable (st a), Trie trie st map k)@@ -144,39 +150,43 @@ -- O(min(m,s)) adjust :: Trie trie st map k => (a -> a) -> [k] -> trie map k a -> trie map k a-adjust = genericAdjust fmap+adjust = genericAdjust ($) fmap -- O(min(m,s)) adjust' :: (Alt st a, Boolable (st a), Trie trie st map k) => (a -> a) -> [k] -> trie map k a -> trie map k a-adjust' = genericAdjust fmap'+adjust' = genericAdjust ($!) fmap' genericAdjust :: Trie trie st map k- => ((a -> a) -> st a -> st a)+ => (forall x y. (x -> y) -> x -> y)+ -> ((a -> a) -> st a -> st a) -> (a -> a) -> [k] -> trie map k a -> trie map k a-genericAdjust myFmap f [] tr = mapVal tr (myFmap f)-genericAdjust myFmap f (x:xs) tr =- mapMap tr $ \m -> Map.adjust (genericAdjust myFmap f xs) x m+genericAdjust ($$) (<$$>) f = go+ where+ go [] tr = mapVal ($$) tr (f <$$>)+ go (x:xs) tr = mapMap ($$) tr (Map.adjust (go xs) x) -- O(min(m,s)) updateLookup :: (Alt st a, Boolable (st a), Trie trie st map k) => (a -> st a) -> [k] -> trie map k a -> (st a, trie map k a)-updateLookup f [] tr =- let (v,m) = tParts tr- v' = if hasValue v then f (unwrap v) else v- in (v, mkTrie v' m)+updateLookup f = go+ where+ go [] tr =+ let (v,m) = tParts tr+ v' = if hasValue v then f (unwrap v) else v+ in (v, mkTrie v' m) -updateLookup f (x:xs) orig =- let m = tMap orig- in case Map.lookup x m of- Nothing -> (altEmpty, orig)- Just tr ->- let (ret, upd) = updateLookup f xs tr- in ( ret- , mkTrie (tVal orig) $ if null upd- then Map.delete x m- else Map.adjust (const upd) x m- )+ go (x:xs) orig =+ let m = tMap orig+ in case Map.lookup x m of+ Nothing -> (altEmpty, orig)+ Just tr ->+ let (ret, upd) = go xs tr+ in ( ret+ , mkTrie (tVal orig) $ if null upd+ then Map.delete x m+ else Map.adjust (const upd) x m+ ) -- O(min(m,s)) --@@ -185,32 +195,35 @@ -- the trie fall into an invalid state. alter :: (Alt st a, Boolable (st a), Trie trie st map k) => (st a -> st a) -> [k] -> trie map k a -> trie map k a-alter = genericAlter (flip const)+alter = genericAlter ($) (flip const) -- O(min(m,s)) alter' :: (Alt st a, Boolable (st a), Trie trie st map k) => (st a -> st a) -> [k] -> trie map k a -> trie map k a-alter' = genericAlter seq+alter' = genericAlter ($!) seq genericAlter :: (Alt st a, Boolable (st a), Trie trie st map k)- => (st a -> trie map k a -> trie map k a)+ => (forall x y. (x -> y) -> x -> y)+ -> (st a -> trie map k a -> trie map k a) -> (st a -> st a) -> [k] -> trie map k a -> trie map k a-genericAlter seeq f [] tr =- let (v,m) = tParts tr- v' = f v- in v' `seeq` mkTrie v' m+genericAlter ($$) seeq f = go+ where+ go [] tr =+ let (v,m) = tParts tr+ v' = f v+ in v' `seeq` mkTrie v' m -genericAlter seeq f (x:xs) tr = mapMap tr $ \m ->- Map.alter (\mold -> case mold of- Nothing ->- let v = f altEmpty- in if hasValue v- then Just (singleton xs (unwrap v))- else Nothing- Just old ->- let new = genericAlter seeq f xs old- in if null new then Nothing else Just new)- x m+ go (x:xs) tr = mapMap ($$) tr $ \m ->+ Map.alter (\mold -> case mold of+ Nothing ->+ let v = f altEmpty+ in if hasValue v+ then Just (singleton xs (unwrap v))+ else Nothing+ Just old ->+ let new = go xs old+ in if null new then Nothing else Just new)+ x m -- * Querying @@ -256,15 +269,17 @@ -> trie map k a -> trie map k b -> Bool-isSubmapOfBy f tr1 tr2 =- let (v1,m1) = tParts tr1- (v2,m2) = tParts tr2- hv1 = hasValue v1- hv2 = hasValue v2- in and [ not (hv1 && not hv2)- , (not hv1 && not hv2) || f (unwrap v1) (unwrap v2)- , Map.isSubmapOfBy (isSubmapOfBy f) m1 m2- ]+isSubmapOfBy f = go+ where+ go tr1 tr2 =+ let (v1,m1) = tParts tr1+ (v2,m2) = tParts tr2+ hv1 = hasValue v1+ hv2 = hasValue v2+ in and [ not (hv1 && not hv2)+ , (not hv1 && not hv2) || f (unwrap v1) (unwrap v2)+ , Map.isSubmapOfBy go m1 m2+ ] -- O(min(n1 m1,n2 m2)) isProperSubmapOfBy :: (Boolable (st a), Boolable (st b), Trie trie st map k)@@ -272,9 +287,9 @@ -> trie map k a -> trie map k b -> Bool-isProperSubmapOfBy = go False+isProperSubmapOfBy f = go False where- go proper f tr1 tr2 =+ go proper tr1 tr2 = let (v1,m1) = tParts tr1 (v2,m2) = tParts tr2 hv1 = hasValue v1@@ -288,7 +303,7 @@ , (not hv1 && not hv2) || f (unwrap v1) (unwrap v2) , if Map.null m1 then proper'- else Map.isSubmapOfBy (go proper' f) m1 m2+ else Map.isSubmapOfBy (go proper') m1 m2 ] @@ -297,56 +312,55 @@ -- O(min(n1 m1,n2 m2)) unionWith :: (Unionable st a, Trie trie st map k) => (a -> a -> a) -> trie map k a -> trie map k a -> trie map k a-unionWith f = genericUnionWith (unionVals f) (flip const)+unionWith f = genericUnionWith ($) (unionVals f) (flip const) -- O(min(n1 m1,n2 m2)) unionWith' :: (Unionable st a, Trie trie st map k) => (a -> a -> a) -> trie map k a -> trie map k a -> trie map k a-unionWith' f = genericUnionWith (unionVals' f) seq+unionWith' f = genericUnionWith ($!) (unionVals' f) seq genericUnionWith :: Trie trie st map k- => (st a -> st a -> st a)+ => (forall x y. (x -> y) -> x -> y)+ -> (st a -> st a -> st a) -> (st a -> trie map k a -> trie map k a) -> trie map k a -> trie map k a -> trie map k a-genericUnionWith valUnion seeq tr1 tr2 =- let v = onVals valUnion tr1 tr2- in v `seeq` (- mkTrie v $- onMaps (Map.unionWith (genericUnionWith valUnion seeq))- tr1 tr2)+genericUnionWith ($$) valUnion seeq = go+ where+ go tr1 tr2 =+ let v = onVals ($$) valUnion tr1 tr2+ in v `seeq` (mkTrie v $ onMaps ($$) (Map.unionWith go) tr1 tr2) -- O(min(n1 m1,n2 m2)) unionWithKey :: (Unionable st a, Trie trie st map k) => ([k] -> a -> a -> a) -> trie map k a -> trie map k a -> trie map k a-unionWithKey = genericUnionWithKey unionVals (flip const)+unionWithKey = genericUnionWithKey ($) unionVals (flip const) -- O(min(n1 m1,n2 m2)) unionWithKey' :: (Unionable st a, Trie trie st map k) => ([k] -> a -> a -> a) -> trie map k a -> trie map k a -> trie map k a-unionWithKey' = genericUnionWithKey unionVals' seq+unionWithKey' = genericUnionWithKey ($!) unionVals' seq genericUnionWithKey :: Trie trie st map k- => ((a -> a -> a) -> st a -> st a -> st a)+ => (forall x y. (x -> y) -> x -> y)+ -> ((a -> a -> a) -> st a -> st a -> st a) -> (st a -> trie map k a -> trie map k a) -> ([k] -> a -> a -> a) -> trie map k a -> trie map k a -> trie map k a-genericUnionWithKey = go DL.empty+genericUnionWithKey ($$) valUnion seeq f = go DL.empty where- go k valUnion seeq f tr1 tr2 =- let v = onVals (valUnion (f $ DL.toList k)) tr1 tr2- in v `seeq` (- mkTrie v $- onMaps (Map.unionWithKey $- \x -> go (k `DL.snoc` x) valUnion seeq f)- tr1 tr2)+ go k tr1 tr2 =+ let v = onVals ($$) (valUnion (f $ DL.toList k)) tr1 tr2+ in v `seeq` (mkTrie v $+ onMaps ($$) (Map.unionWithKey $ go . (k `DL.snoc`))+ tr1 tr2) -- O(sum(n)) unionsWith :: (Alt st a, Unionable st a, Trie trie st map k)@@ -374,18 +388,20 @@ -> trie map k a -> trie map k b -> trie map k a-differenceWith f tr1 tr2 =- let v = onVals (differenceVals f) tr1 tr2-- -- This would be lazy only in the case where the differing keys were at- -- []. (And even then most operations on the trie would force the- -- value.) For consistency with other keys and Patricia, just seq it for- -- that case as well.- in v `seq` mkTrie v $ onMaps (Map.differenceWith (g f)) tr1 tr2+differenceWith f = go where- g f' t1 t2 = let t' = differenceWith f' t1 t2- in if null t' then Nothing else Just t'+ go tr1 tr2 =+ let v = onVals ($!) (differenceVals f) tr1 tr2 + -- This would be lazy only in the case where the differing keys were at+ -- []. (And even then most operations on the trie would force the+ -- value.) For consistency with other keys and Patricia, just seq it for+ -- that case as well.+ in v `seq` mkTrie v $ onMaps ($!) (Map.differenceWith g) tr1 tr2++ g t1 t2 = let t' = go t1 t2+ in if null t' then Nothing else Just t'+ -- O(min(n1 m1,n2 m2)) differenceWithKey :: ( Boolable (st a), Differentiable st a b , Trie trie st map k@@ -394,26 +410,27 @@ -> trie map k a -> trie map k b -> trie map k a-differenceWithKey = go DL.empty+differenceWithKey f = go DL.empty where- go k f tr1 tr2 =- let v = onVals (differenceVals (f $ DL.toList k)) tr1 tr2+ go k tr1 tr2 =+ let v = onVals ($!) (differenceVals (f $ DL.toList k)) tr1 tr2 -- see comment in differenceWith for seq explanation- in v `seq` mkTrie v $ onMaps (Map.differenceWithKey (g k f)) tr1 tr2+ in v `seq` mkTrie v $+ onMaps ($!) (Map.differenceWithKey (g k)) tr1 tr2 - g k f x t1 t2 = let t' = go (k `DL.snoc` x) f t1 t2- in if null t' then Nothing else Just t'+ g k x t1 t2 = let t' = go (k `DL.snoc` x) t1 t2+ in if null t' then Nothing else Just t' -- O(min(n1 m1,n2 m2)) intersectionWith :: ( Boolable (st c), Intersectable st a b c- , Trie trie st map k- )+ , Trie trie st map k+ ) => (a -> b -> c) -> trie map k a -> trie map k b -> trie map k c-intersectionWith f = genericIntersectionWith (intersectionVals f) (flip const)+intersectionWith f = genericIntersectionWith ($) (intersectionVals f) (flip const) -- O(min(n1 m1,n2 m2)) intersectionWith' :: ( Boolable (st c), Intersectable st a b c@@ -423,22 +440,23 @@ -> trie map k a -> trie map k b -> trie map k c-intersectionWith' f = genericIntersectionWith (intersectionVals' f) seq+intersectionWith' f = genericIntersectionWith ($!) (intersectionVals' f) seq genericIntersectionWith :: (Boolable (st c), Trie trie st map k)- => (st a -> st b -> st c)+ => (forall x y. (x -> y) -> x -> y)+ -> (st a -> st b -> st c) -> (st c -> trie map k c -> trie map k c) -> trie map k a -> trie map k b -> trie map k c-genericIntersectionWith valIntersection seeq tr1 tr2 =- tr seeq- (onVals valIntersection tr1 tr2)- (onMaps (Map.filter (not.null) .:- Map.intersectionWith- (genericIntersectionWith valIntersection seeq))- tr1 tr2)+genericIntersectionWith ($$) valIntersection seeq = go where+ go tr1 tr2 =+ tr seeq+ (onVals ($$) valIntersection tr1 tr2)+ (onMaps ($$) (Map.filter (not.null) .: Map.intersectionWith go)+ tr1 tr2)+ tr seeq' v m = v `seeq'` (mkTrie v $ case Map.singletonView m of@@ -453,7 +471,8 @@ -> trie map k a -> trie map k b -> trie map k c-intersectionWithKey = genericIntersectionWithKey intersectionVals (flip const)+intersectionWithKey =+ genericIntersectionWithKey ($) intersectionVals (flip const) -- O(min(n1 m1,n2 m2)) intersectionWithKey' :: ( Boolable (st c), Intersectable st a b c@@ -463,26 +482,26 @@ -> trie map k a -> trie map k b -> trie map k c-intersectionWithKey' = genericIntersectionWithKey intersectionVals' seq+intersectionWithKey' = genericIntersectionWithKey ($!) intersectionVals' seq genericIntersectionWithKey :: (Boolable (st c), Trie trie st map k)- => ((a -> b -> c) -> st a -> st b -> st c)+ => (forall x y. (x -> y) -> x -> y)+ -> ((a -> b -> c) -> st a -> st b -> st c) -> (st c -> trie map k c -> trie map k c) -> ([k] -> a -> b -> c) -> trie map k a -> trie map k b -> trie map k c-genericIntersectionWithKey = go DL.empty+genericIntersectionWithKey ($$) valIntersection seeq f = go DL.empty where- go k valIntersection seeq f tr1 tr2 =- tr seeq- (onVals (valIntersection (f $ DL.toList k)) tr1 tr2)- (onMaps (Map.filter (not.null) .:- Map.intersectionWithKey- (\x -> go (k `DL.snoc` x) valIntersection seeq f))+ go k tr1 tr2 =+ tr+ (onVals ($$) (valIntersection (f $ DL.toList k)) tr1 tr2)+ (onMaps ($$) (Map.filter (not.null) .:+ Map.intersectionWithKey (go . (k `DL.snoc`))) tr1 tr2) - tr seeq v m =+ tr v m = v `seeq` (mkTrie v $ case Map.singletonView m of Just (_, child) | null child -> tMap child@@ -518,7 +537,7 @@ -> (k1 -> k2) -> trie map k1 a -> trie map k2 a-mapInKeysWith = genericMapInKeysWith unionWith+mapInKeysWith = genericMapInKeysWith ($) unionWith -- O(n m) mapInKeysWith' :: (Unionable st a, Trie trie st map k1, Trie trie st map k2)@@ -526,21 +545,21 @@ -> (k1 -> k2) -> trie map k1 a -> trie map k2 a-mapInKeysWith' = genericMapInKeysWith unionWith'+mapInKeysWith' = genericMapInKeysWith ($!) unionWith' genericMapInKeysWith :: ( Unionable st a , Trie trie st map k1, Trie trie st map k2 )- => (f -> trie map k2 a -> trie map k2 a -> trie map k2 a)+ => (forall x y. (x -> y) -> x -> y)+ -> (f -> trie map k2 a -> trie map k2 a -> trie map k2 a) -> f -> (k1 -> k2) -> trie map k1 a -> trie map k2 a-genericMapInKeysWith unionW j f tr =- mapMap tr $- Map.fromListWith (unionW j) .- map (f *** genericMapInKeysWith unionW j f) .- Map.toList+genericMapInKeysWith ($$) unionW j f = go+ where+ go tr = mapMap ($$) tr $+ Map.fromListWith (unionW j) . map (f *** go) . Map.toList -- * Folding @@ -610,13 +629,13 @@ -> (([k],a) -> DList ([k],a) -> DList ([k],a)) -> trie map k a -> [([k],a)]-genericToList f_ g_ = DL.toList . go DL.empty f_ g_+genericToList tolist add = DL.toList . go DL.empty where- go xs tolist add tr =+ go xs tr = let (v,m) = tParts tr xs' = DL.concat .- map (\(x,t) -> go (xs `DL.snoc` x) tolist add t) .+ map (\(x,t) -> go (xs `DL.snoc` x) t) . tolist $ m in if hasValue v then add (DL.toList xs, unwrap v) xs'@@ -663,15 +682,15 @@ -> (CMap trie map k a -> Maybe (k, trie map k a)) -> trie map k a -> (Maybe ([k], a), trie map k a)-minMaxView _ _ tr_ | null tr_ = (Nothing, tr_)-minMaxView f g tr_ = first Just (go f g tr_)+minMaxView _ _ tr_ | null tr_ = (Nothing, tr_)+minMaxView isWanted mapView tr_ = first Just (go tr_) where- go isWanted mapView tr =+ go tr = let (v,m) = tParts tr in if isWanted tr then (([], unwrap v), mkTrie altEmpty m) else let (k, tr') = fromJust (mapView m)- (minMax, tr'') = go isWanted mapView tr'+ (minMax, tr'') = go tr' in ( first (k:) minMax , mkTrie v $ if null tr'' then Map.delete k m@@ -693,14 +712,14 @@ -> (CMap trie map k a -> Maybe (k, trie map k a)) -> trie map k a -> Maybe ([k], a)-findMinMax _ _ tr_ | null tr_ = Nothing-findMinMax f g tr_ = Just (go f g DL.empty tr_)+findMinMax _ _ tr_ | null tr_ = Nothing+findMinMax isWanted mapView tr_ = Just (go DL.empty tr_) where- go isWanted mapView xs tr =+ go xs tr = if isWanted tr then (DL.toList xs, unwrap (tVal tr)) else let (k, tr') = fromJust . mapView . tMap $ tr- in go isWanted mapView (xs `DL.snoc` k) tr'+ in go (xs `DL.snoc` k) tr' -- O(m) deleteMin :: (Alt st a, Boolable (st a), Trie trie st map k, OrdMap map k)@@ -765,7 +784,7 @@ findSuccessor :: (Boolable (st a), Trie trie st map k, OrdMap map k) => [k] -> trie map k a -> Maybe ([k], a) findSuccessor _ tr | null tr = Nothing-findSuccessor xs_ tr_ = go xs_ tr_ +findSuccessor xs_ tr_ = go xs_ tr_ where go [] tr = do (k,t) <- fst . Map.minViewWithKey . tMap $ tr fmap (first (k:)) (findMin t)
Data/ListTrie/Base/Map.hs view
@@ -1,6 +1,6 @@ -- File created: 2008-11-07 17:30:16 -{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module Data.ListTrie.Base.Map ( Map(..), OrdMap(..)@@ -29,15 +29,6 @@ import Data.ListTrie.Util (both, (.:)) --- MIN_VERSION_containers is defined by Cabal-#ifdef MIN_VERSION_containers-# if !(MIN_VERSION_containers(0,3,0))-# define TOO_OLD_CONTAINERS-# endif-#else-#define TOO_OLD_CONTAINERS-#endif- -- | Minimal complete implementation: -- -- * 'eqCmp'@@ -406,13 +397,7 @@ mapAccumAsc = M.mapAccum mapAccumAscWithKey = M.mapAccumWithKey mapAccumDesc = mapAccumR-#ifdef TOO_OLD_CONTAINERS- mapAccumDescWithKey f z =- second M.fromList . mapAccumR (\a (k,v) -> second ((,) k) $ f a k v) z- . M.toAscList-#else mapAccumDescWithKey = M.mapAccumRWithKey-#endif newtype WrappedIntMap k v = IMap (IM.IntMap v) deriving (Eq,Ord) @@ -426,17 +411,10 @@ foldr1 f (IMap m) = foldr1 f m instance Traversable (WrappedIntMap k) where-#ifdef TOO_OLD_CONTAINERS- traverse = error "Data.ListTrie.Base.Map :: too old containers, no Traversable IntMap"- sequenceA = error "Data.ListTrie.Base.Map :: too old containers, no Traversable IntMap"- mapM = error "Data.ListTrie.Base.Map :: too old containers, no Traversable IntMap"- sequence = error "Data.ListTrie.Base.Map :: too old containers, no Traversable IntMap"-#else traverse f (IMap m) = pure IMap <*> traverse f m sequenceA (IMap m) = pure IMap <*> sequenceA m mapM f (IMap m) = liftM IMap (mapM f m) sequence (IMap m) = liftM IMap (sequence m)-#endif instance Enum k => Map WrappedIntMap k where eqCmp = const ((==) `on` fromEnum)@@ -457,26 +435,14 @@ unionWith f (IMap x) (IMap y) = IMap$ IM.unionWith f x y differenceWith f (IMap x) (IMap y) = IMap$ IM.differenceWith f x y--#ifdef TOO_OLD_CONTAINERS- intersectionWith =- error "Data.ListTrie.Base.Map :: too old containers, Data.IntMap.intersectionWith has restricted type"-#else intersectionWith f (IMap x) (IMap y) = IMap$ IM.intersectionWith f x y-#endif unionWithKey f (IMap x) (IMap y) = IMap$ IM.unionWithKey (f . toEnum) x y differenceWithKey f (IMap x) (IMap y) = IMap$ IM.differenceWithKey (f . toEnum) x y--#ifdef TOO_OLD_CONTAINERS- intersectionWithKey =- error "Data.ListTrie.Base.Map :: too old containers, Data.IntMap.intersectionWithKey has restricted type"-#else intersectionWithKey f (IMap x) (IMap y) = IMap$ IM.intersectionWithKey (f . toEnum) x y-#endif map f (IMap x) = IMap$ IM.map f x mapWithKey f (IMap x) = IMap$ IM.mapWithKey (f . toEnum) x@@ -520,17 +486,6 @@ mapAccumAscWithKey f z (IMap m) = second IMap $ IM.mapAccumWithKey (\a k -> f a (toEnum k)) z m -#ifdef TOO_OLD_CONTAINERS- mapAccumDesc f z (IMap m) =- second (IMap . IM.fromList)- . mapAccumR (\a (k,v) -> second ((,) k) $ f a v) z- . IM.toAscList $ m- mapAccumDescWithKey f z (IMap m) =- second (IMap . IM.fromList)- . mapAccumR (\a (k,v) -> second ((,) k) $ f a (toEnum k) v) z- . IM.toAscList $ m-#else mapAccumDesc f z (IMap m) = second IMap $ mapAccumR f z m mapAccumDescWithKey f z (IMap m) = second IMap $ IM.mapAccumRWithKey (\a k -> f a (toEnum k)) z m-#endif
Data/ListTrie/Patricia/Base.hs view
@@ -1,7 +1,8 @@ -- File created: 2008-12-28 17:20:14 {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies- , FlexibleContexts, ScopedTypeVariables #-}+ , FlexibleContexts, ScopedTypeVariables, Rank2Types+ , NoMonomorphismRestriction #-} module Data.ListTrie.Patricia.Base ( Trie(..)@@ -95,40 +96,43 @@ -- O(min(m,s)) insertWith :: (Alt st a, Boolable (st a), Trie trie st map k) => (a -> a -> a) -> [k] -> a -> trie map k a -> trie map k a-insertWith = genericInsertWith (<$>)+insertWith = genericInsertWith ($) (<$>) -- O(min(m,s)) insertWith' :: (Alt st a, Boolable (st a), Trie trie st map k) => (a -> a -> a) -> [k] -> a -> trie map k a -> trie map k a-insertWith' = (seq <*>) .: genericInsertWith (<$!>)+insertWith' = (seq <*>) .: genericInsertWith ($!) (<$!>) genericInsertWith :: (Alt st a, Boolable (st a), Trie trie st map k)- => ((a -> a) -> st a -> st a)+ => (forall x y. (x -> y) -> x -> y)+ -> ((a -> a) -> st a -> st a) -> (a -> a -> a) -> [k] -> a -> trie map k a -> trie map k a-genericInsertWith (<$$>) f k new tr =- let (old,prefix,m) = tParts tr- in case comparePrefixes (Map.eqCmp m) prefix k of- Same -> mkTrie ((f new <$$> old) <|> pure new) prefix m+genericInsertWith ($$) (<$$>) f = go+ where+ mkTrie' = ($$) mkTrie+ go k new tr =+ let (old,prefix,m) = tParts tr+ in case comparePrefixes (Map.eqCmp m) prefix k of+ Same -> mkTrie' ((f new <$$> old) <|> pure new) prefix m - PostFix (Left (p:pr)) -> mkTrie (pure new) k- (Map.singleton p (mkTrie old pr m))- PostFix (Right (x:xs)) ->- -- Minor optimization: instead of tryCompress we just check for- -- the case of an empty trie- if null tr- then singleton k new- else mkTrie old prefix $- Map.insertWith- (\_ oldt ->- genericInsertWith (<$$>) f xs new oldt)- x (singleton xs new) m+ PostFix (Left (p:pr)) ->+ mkTrie' (pure new) k+ (Map.singleton p (mkTrie old pr m))+ PostFix (Right (x:xs)) ->+ -- Minor optimization: instead of tryCompress we just check+ -- for the case of an empty trie+ if null tr+ then singleton k new+ else mkTrie old prefix $+ Map.insertWith (\_ oldt -> go xs new oldt)+ x (singleton xs new) m - DifferedAt pr' (p:pr) (x:xs) ->- mkTrie altEmpty pr' $ Map.doubleton x (singleton xs new)- p (mkTrie old pr m)+ DifferedAt pr' (p:pr) (x:xs) ->+ mkTrie altEmpty pr' $ Map.doubleton x (singleton xs new)+ p (mkTrie old pr m) - _ -> error- "Data.ListTrie.Patricia.Base.insertWith :: internal error"+ _ -> error+ "Data.ListTrie.Patricia.Base.insertWith :: internal error" -- O(min(m,s)) delete :: (Alt st a, Boolable (st a), Trie trie st map k)@@ -138,46 +142,51 @@ -- O(min(m,s)) adjust :: Trie trie st map k => (a -> a) -> [k] -> trie map k a -> trie map k a-adjust = genericAdjust fmap+adjust = genericAdjust ($) fmap -- O(min(m,s)) adjust' :: (Alt st a, Boolable (st a), Trie trie st map k) => (a -> a) -> [k] -> trie map k a -> trie map k a-adjust' = genericAdjust fmap'+adjust' = genericAdjust ($!) fmap' genericAdjust :: Trie trie st map k- => ((a -> a) -> st a -> st a)+ => (forall x y. (x -> y) -> x -> y)+ -> ((a -> a) -> st a -> st a) -> (a -> a) -> [k] -> trie map k a -> trie map k a-genericAdjust myFmap f k tr =- let (v,prefix,m) = tParts tr- in case comparePrefixes (Map.eqCmp m) prefix k of- Same -> mkTrie (myFmap f v) prefix m- PostFix (Right (x:xs)) ->- mkTrie v prefix $ Map.adjust (genericAdjust myFmap f xs) x m- _ -> tr+genericAdjust ($$) myFmap f = go+ where+ go k tr =+ let (v,prefix,m) = tParts tr+ in case comparePrefixes (Map.eqCmp m) prefix k of+ Same -> (mkTrie $$ myFmap f v) prefix m+ PostFix (Right (x:xs)) ->+ mkTrie v prefix $ Map.adjust (go xs) x m+ _ -> tr -- O(min(m,s)) updateLookup :: (Alt st a, Boolable (st a), Trie trie st map k) => (a -> st a) -> [k] -> trie map k a -> (st a, trie map k a)-updateLookup f k tr =- let (v,prefix,m) = tParts tr- in case comparePrefixes (Map.eqCmp m) prefix k of- Same -> let v' = if hasValue v- then f (unwrap v)- else v- in (v, safeMkTrie v' prefix m)- PostFix (Right (x:xs)) ->- case Map.lookup x m of- Nothing -> (altEmpty, tr)- Just tr' ->- let (ret, upd) = updateLookup f xs tr'- in ( ret- , safeMkTrie v prefix $- if null upd- then Map.delete x m- else Map.adjust (const upd) x m- )- _ -> (altEmpty, tr)+updateLookup f = go+ where+ go k tr =+ let (v,prefix,m) = tParts tr+ in case comparePrefixes (Map.eqCmp m) prefix k of+ Same -> let v' = if hasValue v+ then f (unwrap v)+ else v+ in (v, safeMkTrie v' prefix m)+ PostFix (Right (x:xs)) ->+ case Map.lookup x m of+ Nothing -> (altEmpty, tr)+ Just tr' ->+ let (ret, upd) = go xs tr'+ in ( ret+ , safeMkTrie v prefix $+ if null upd+ then Map.delete x m+ else Map.adjust (const upd) x m+ )+ _ -> (altEmpty, tr) -- O(min(m,s)) --@@ -201,48 +210,50 @@ genericAlter :: (Alt st a, Boolable (st a), Trie trie st map k) => (st a -> trie map k a -> trie map k a) -> (st a -> st a) -> [k] -> trie map k a -> trie map k a-genericAlter seeq f k tr =- let (v,prefix,m) = tParts tr- in case comparePrefixes (Map.eqCmp m) prefix k of- Same ->- let v' = f v- in -- We need to compress if the map was empty or a singleton- -- and the value was removed- if (Map.null m || isJust (Map.singletonView m))- && not (hasValue v')- then tryCompress (mkTrie v' prefix m)- else v' `seeq` mkTrie v' prefix m+genericAlter seeq f = go+ where+ go k tr =+ let (v,prefix,m) = tParts tr+ in case comparePrefixes (Map.eqCmp m) prefix k of+ Same ->+ let v' = f v+ in -- We need to compress if the map was empty or a+ -- singleton and the value was removed+ if (Map.null m || isJust (Map.singletonView m))+ && not (hasValue v')+ then tryCompress (mkTrie v' prefix m)+ else v' `seeq` mkTrie v' prefix m - PostFix (Right (x:xs)) ->- mkTrie v prefix $- Map.alter- (\mt -> case mt of- Nothing ->- let v' = f altEmpty- in if hasValue v'- then Just (singleton xs (unwrap v'))- else Nothing- Just t ->- let new = genericAlter seeq f xs t- in if null new then Nothing else Just new)- x m+ PostFix (Right (x:xs)) ->+ mkTrie v prefix $+ Map.alter+ (\mt ->+ case mt of+ Nothing ->+ let v' = f altEmpty+ in if hasValue v'+ then Just (singleton xs (unwrap v'))+ else Nothing+ Just t ->+ let new = go xs t+ in if null new then Nothing else Just new)+ x m - PostFix (Left (p:ps)) ->- let v' = f altEmpty- in if hasValue v'- then mkTrie v' k $ Map.singleton p (mkTrie v ps m)- else tr+ PostFix (Left (p:ps)) ->+ let v' = f altEmpty+ in if hasValue v'+ then mkTrie v' k $ Map.singleton p (mkTrie v ps m)+ else tr - DifferedAt pr (p:ps) (x:xs) ->- let v' = f altEmpty- in if hasValue v'- then mkTrie altEmpty pr $- Map.doubleton p (mkTrie v ps m)- x (mkTrie v' xs Map.empty)- else tr+ DifferedAt pr (p:ps) (x:xs) ->+ let v' = f altEmpty+ in if hasValue v'+ then mkTrie altEmpty pr $+ Map.doubleton p (mkTrie v ps m)+ x (mkTrie v' xs Map.empty)+ else tr - _ ->- error+ _ -> error "Data.ListTrie.Patricia.Base.genericAlter :: internal error" -- * Querying@@ -295,18 +306,20 @@ -> trie map k a -> trie map k b -> Bool-isSubmapOfBy f_ trl trr =- let (vl,prel,ml) = tParts trl- (vr,prer,mr) = tParts trr- in case comparePrefixes (Map.eqCmp ml) prel prer of- DifferedAt _ _ _ -> False-- -- Special case here: if the left trie is empty we return True.- PostFix (Right _) -> null trl- PostFix (Left xs) -> go f_ mr vl ml xs- Same -> same f_ vl vr ml mr+isSubmapOfBy f = go0 where- go f mr vl ml (x:xs) =+ go0 trl trr =+ let (vl,prel,ml) = tParts trl+ (vr,prer,mr) = tParts trr+ in case comparePrefixes (Map.eqCmp ml) prel prer of+ DifferedAt _ _ _ -> False++ -- Special case here: if the left trie is empty we return True.+ PostFix (Right _) -> null trl+ PostFix (Left xs) -> go mr vl ml xs+ Same -> same vl vr ml mr++ go mr vl ml (x:xs) = case Map.lookup x mr of Nothing -> False Just tr ->@@ -314,18 +327,18 @@ in case comparePrefixes (Map.eqCmp mr) xs pre of DifferedAt _ _ _ -> False PostFix (Right _) -> False- PostFix (Left ys) -> go f mr' vl ml ys- Same -> same f vl vr ml mr'+ PostFix (Left ys) -> go mr' vl ml ys+ Same -> same vl vr ml mr' - go _ _ _ _ [] =+ go _ _ _ [] = error "Data.ListTrie.Patricia.Base.isSubmapOfBy :: internal error" - same f vl vr ml mr =+ same vl vr ml mr = let hvl = hasValue vl hvr = hasValue vr in and [ not (hvl && not hvr)- , (not hvl && not hvr) || f_ (unwrap vl) (unwrap vr)- , Map.isSubmapOfBy (isSubmapOfBy f) ml mr+ , (not hvl && not hvr) || f (unwrap vl) (unwrap vr)+ , Map.isSubmapOfBy go0 ml mr ] -- O(min(n1 m1,n2 m2))@@ -334,9 +347,9 @@ -> trie map k a -> trie map k b -> Bool-isProperSubmapOfBy = f False+isProperSubmapOfBy g = f False where- f proper g trl trr =+ f proper trl trr = let (vl,prel,ml) = tParts trl (vr,prer,mr) = tParts trr in case comparePrefixes (Map.eqCmp ml) prel prer of@@ -347,10 +360,10 @@ -- Note that properness does not affect this: if we hit this -- case, we already know that the right trie is nonempty. PostFix (Right _) -> null trl- PostFix (Left xs) -> go proper g mr vl ml xs- Same -> same proper g vl vr ml mr+ PostFix (Left xs) -> go proper mr vl ml xs+ Same -> same proper vl vr ml mr - go proper g mr vl ml (x:xs) =+ go proper mr vl ml (x:xs) = case Map.lookup x mr of Nothing -> False Just tr ->@@ -358,13 +371,13 @@ in case comparePrefixes (Map.eqCmp mr) xs pre of DifferedAt _ _ _ -> False PostFix (Right _) -> False- PostFix (Left ys) -> go proper g mr' vl ml ys- Same -> same proper g vl vr ml mr'+ PostFix (Left ys) -> go proper mr' vl ml ys+ Same -> same proper vl vr ml mr' - go _ _ _ _ _ [] =+ go _ _ _ _ [] = error "Data.ListTrie.Patricia.Base.isProperSubmapOfBy :: internal error" - same proper g vl vr ml mr =+ same proper vl vr ml mr = let hvl = hasValue vl hvr = hasValue vr @@ -378,7 +391,7 @@ , (not hvl && not hvr) || g (unwrap vl) (unwrap vr) , if Map.null ml then proper'- else Map.isSubmapOfBy (f proper' g) ml mr+ else Map.isSubmapOfBy (f proper') ml mr ] -- * Combination@@ -390,52 +403,54 @@ -- O(min(n1 m1,n2 m2)) unionWith :: (Alt st a, Boolable (st a), Unionable st a, Trie trie st map k) => (a -> a -> a) -> trie map k a -> trie map k a -> trie map k a-unionWith f = genericUnionWith (unionVals f) (flip const)+unionWith f = genericUnionWith (flip const) (unionVals f) -- O(min(n1 m1,n2 m2)) unionWith' :: (Alt st a, Boolable (st a), Unionable st a, Trie trie st map k) => (a -> a -> a) -> trie map k a -> trie map k a -> trie map k a-unionWith' f = genericUnionWith (unionVals' f) seq+unionWith' f = genericUnionWith seq (unionVals' f) genericUnionWith :: (Alt st a, Boolable (st a), Trie trie st map k)- => (st a -> st a -> st a)- -> (st a -> trie map k a -> trie map k a)+ => (st a -> trie map k a -> trie map k a)+ -> (st a -> st a -> st a) -> trie map k a -> trie map k a -> trie map k a-genericUnionWith valUnion seeq tr1 tr2 =- let (v1,pre1,m1) = tParts tr1- (v2,pre2,m2) = tParts tr2- in case comparePrefixes (Map.eqCmp m1) pre1 pre2 of- Same ->- let v = valUnion v1 v2+genericUnionWith seeq = go+ where+ go valUnion tr1 tr2 =+ let (v1,pre1,m1) = tParts tr1+ (v2,pre2,m2) = tParts tr2+ in case comparePrefixes (Map.eqCmp m1) pre1 pre2 of+ Same ->+ let v = valUnion v1 v2 - -- safeMkTrie not needed: if pre1 is not null then m1 or v- -- won't be and hence the union won't be.- in v `seeq` (tryCompress.mkTrie v pre1 $- mapUnion valUnion seeq m1 m2)+ -- safeMkTrie not needed: if pre1 is not null then m1 or+ -- v won't be and hence the union won't be.+ in v `seeq` (tryCompress.mkTrie v pre1 $+ mapUnion valUnion m1 m2) - PostFix remainder ->- -- As above, mkTrie is fine- --- -- The flip is important to retain left-biasedness- tryCompress $- either- (mkTrie v2 pre2 . mapUnion (flip valUnion) seeq m2 .- decompress m1 v1)- (mkTrie v1 pre1 . mapUnion valUnion seeq m1 .- decompress m2 v2)- remainder+ PostFix remainder ->+ -- As above, mkTrie is fine+ --+ -- The flip is important to retain left-biasedness+ tryCompress $+ either+ (mkTrie v2 pre2 . mapUnion (flip valUnion) m2 .+ decompress m1 v1)+ (mkTrie v1 pre1 . mapUnion valUnion m1 .+ decompress m2 v2)+ remainder - DifferedAt pr (x:xs) (y:ys) ->- -- As above, mkTrie is fine- mkTrie altEmpty pr $ Map.doubleton x (mkTrie v1 xs m1)- y (mkTrie v2 ys m2)+ DifferedAt pr (x:xs) (y:ys) ->+ -- As above, mkTrie is fine+ mkTrie altEmpty pr $ Map.doubleton x (mkTrie v1 xs m1)+ y (mkTrie v2 ys m2) - _ -> can'tHappen- where- mapUnion = Map.unionWith .: genericUnionWith+ _ -> can'tHappen + mapUnion = Map.unionWith . go+ decompress m v (x:xs) = Map.singleton x (mkTrie v xs m) decompress _ _ [] = can'tHappen @@ -448,7 +463,7 @@ -> trie map k a -> trie map k a -> trie map k a-unionWithKey = genericUnionWithKey unionVals (flip const)+unionWithKey = genericUnionWithKey (flip const) unionVals -- O(min(n1 m1,n2 m2)) unionWithKey' :: ( Alt st a, Boolable (st a), Unionable st a@@ -458,18 +473,18 @@ -> trie map k a -> trie map k a -> trie map k a-unionWithKey' = genericUnionWithKey unionVals' seq+unionWithKey' = genericUnionWithKey seq unionVals' genericUnionWithKey :: (Alt st a, Boolable (st a), Trie trie st map k)- => ((a -> a -> a) -> st a -> st a -> st a)- -> (st a -> trie map k a -> trie map k a)+ => (st a -> trie map k a -> trie map k a)+ -> ((a -> a -> a) -> st a -> st a -> st a) -> ([k] -> a -> a -> a) -> trie map k a -> trie map k a -> trie map k a-genericUnionWithKey = go DL.empty+genericUnionWithKey seeq = go DL.empty where- go k valUnion seeq j tr1 tr2 =+ go k valUnion j tr1 tr2 = let (v1,pre1,m1) = tParts tr1 (v2,pre2,m2) = tParts tr2 in case comparePrefixes (Map.eqCmp m1) pre1 pre2 of@@ -478,14 +493,14 @@ v = valUnion (j k') v1 v2 in v `seeq` (tryCompress.mkTrie v pre1 $- mapUnion valUnion seeq j k pre1 m1 m2)+ mapUnion valUnion j k pre1 m1 m2) PostFix remainder -> tryCompress $ either- (mk v2 pre2 . mapUnion (flip.valUnion) seeq j k pre2 m2+ (mk v2 pre2 . mapUnion (flip.valUnion) j k pre2 m2 . decompress m1 v1)- (mk v1 pre1 . mapUnion valUnion seeq j k pre1 m1+ (mk v1 pre1 . mapUnion valUnion j k pre1 m1 . decompress m2 v2) remainder @@ -497,9 +512,9 @@ mk = mkTrie - mapUnion v s j k p =+ mapUnion v j k p = Map.unionWithKey $- \x -> go (k `DL.append` DL.fromList p `DL.snoc` x) v s j+ \x -> go (k `DL.append` DL.fromList p `DL.snoc` x) v j decompress m v (x:xs) = Map.singleton x (mkTrie v xs m) decompress _ _ [] = can'tHappen@@ -537,23 +552,24 @@ -> trie map k a -> trie map k b -> trie map k a-differenceWith j_ tr1 tr2 =- let (v1,pre1,m1) = tParts tr1- (v2,pre2,m2) = tParts tr2- in case comparePrefixes (Map.eqCmp m1) pre1 pre2 of- DifferedAt _ _ _ -> tr1- Same -> mk j_ v1 v2 pre1 m1 m2- PostFix (Left xs) -> goRight j_ tr1 m2 xs- PostFix (Right xs) -> goLeft j_ tr1 tr2 xs+differenceWith j = go where- mapDifference = Map.differenceWith . dw- dw j a b =+ go tr1 tr2 =+ let (v1,pre1,m1) = tParts tr1+ (v2,pre2,m2) = tParts tr2+ in case comparePrefixes (Map.eqCmp m1) pre1 pre2 of+ DifferedAt _ _ _ -> tr1+ Same -> mk v1 v2 pre1 m1 m2+ PostFix (Left xs) -> goRight tr1 m2 xs+ PostFix (Right xs) -> goLeft tr1 tr2 xs++ dw a b = let c = differenceWith j a b in if null c then Nothing else Just c - mk j v v' p m m' =+ mk v v' p m m' = let vd = differenceVals j v v'- in tryCompress.mkTrie vd p $ mapDifference j m m'+ in tryCompress.mkTrie vd p $ Map.differenceWith dw m m' -- See the comment in 'intersection' for a longish example of the idea -- behind this, which is basically that if we see two prefixes like "foo"@@ -563,7 +579,7 @@ -- -- We have two functions for the two tries because set difference is a -- noncommutative operation.- goRight j left rightMap (x:xs) =+ goRight left rightMap (x:xs) = let (v,pre,m) = tParts left in case Map.lookup x rightMap of Nothing -> left@@ -571,13 +587,13 @@ let (v',pre',m') = tParts right' in case comparePrefixes (Map.eqCmp m) xs pre' of DifferedAt _ _ _ -> left- Same -> mk j v v' pre m m'- PostFix (Left ys) -> goRight j left m' ys- PostFix (Right ys) -> goLeft j left right' ys+ Same -> mk v v' pre m m'+ PostFix (Left ys) -> goRight left m' ys+ PostFix (Right ys) -> goLeft left right' ys - goRight _ _ _ [] = can'tHappen+ goRight _ _ [] = can'tHappen - goLeft j left right (x:xs) =+ goLeft left right (x:xs) = tryCompress . mkTrie vl prel $ Map.update f x ml where (vl,prel,ml) = tParts left@@ -587,13 +603,13 @@ let (v,pre,m) = tParts left' in case comparePrefixes (Map.eqCmp m) pre xs of DifferedAt _ _ _ -> Just left'- Same -> tryNull $ mk j v vr pre m mr- PostFix (Left ys) -> tryNull $ goRight j left' mr ys- PostFix (Right ys) -> tryNull $ goLeft j left' right ys+ Same -> tryNull $ mk v vr pre m mr+ PostFix (Left ys) -> tryNull $ goRight left' mr ys+ PostFix (Right ys) -> tryNull $ goLeft left' right ys tryNull t = if null t then Nothing else Just t - goLeft _ _ _ [] = can'tHappen+ goLeft _ _ [] = can'tHappen can'tHappen = error "Data.ListTrie.Patricia.Base.differenceWith :: internal error"@@ -606,32 +622,30 @@ -> trie map k a -> trie map k b -> trie map k a-differenceWithKey = go DL.empty+differenceWithKey j = go DL.empty where- go k j_ tr1 tr2 =+ go k tr1 tr2 = let (v1,pre1,m1) = tParts tr1 (v2,pre2,m2) = tParts tr2 in case comparePrefixes (Map.eqCmp m1) pre1 pre2 of DifferedAt _ _ _ -> tr1- Same -> mk j_ k v1 v2 pre1 m1 m2- PostFix (Left xs) -> goRight (key k pre2) j_ tr1 m2 xs- PostFix (Right xs) -> goLeft (key k pre1) j_ tr1 tr2 xs-- mapDifference k j =- Map.differenceWithKey (\x -> dw (k `DL.snoc` x) j)+ Same -> mk k v1 v2 pre1 m1 m2+ PostFix (Left xs) -> goRight (key k pre2) tr1 m2 xs+ PostFix (Right xs) -> goLeft (key k pre1) tr1 tr2 xs key k p = k `DL.append` DL.fromList p - dw k j a b =- let c = go k j a b+ dw k a b =+ let c = go k a b in if null c then Nothing else Just c - mk j k v v' p m m' =+ mk k v v' p m m' = let k' = k `DL.append` DL.fromList p vd = differenceVals (j $ DL.toList k') v v'- in tryCompress.mkTrie vd p $ mapDifference k' j m m'+ in tryCompress.mkTrie vd p $+ Map.differenceWithKey (dw . (k' `DL.snoc`)) m m' - goRight k j left rightMap (x:xs) =+ goRight k left rightMap (x:xs) = let (vl,_,ml) = tParts left in case Map.lookup x rightMap of Nothing -> left@@ -640,15 +654,15 @@ k' = k `DL.snoc` x in case comparePrefixes (Map.eqCmp ml) xs pre of DifferedAt _ _ _ -> left- Same -> mk j k' vl vr pre ml mr+ Same -> mk k' vl vr pre ml mr PostFix (Left ys) -> goRight (key k' pre)- j left mr ys+ left mr ys PostFix (Right ys) -> goLeft (key k' xs)- j left right ys+ left right ys - goRight _ _ _ _ [] = can'tHappen+ goRight _ _ _ [] = can'tHappen - goLeft k j left right (x:xs) =+ goLeft k left right (x:xs) = tryCompress . mkTrie vl prel $ Map.update f x ml where (vl,prel,ml) = tParts left@@ -660,15 +674,15 @@ let (v,pre,m) = tParts left' in case comparePrefixes (Map.eqCmp m) pre xs of DifferedAt _ _ _ -> Just left'- Same -> tryNull $ mk j k' v vr pre m mr+ Same -> tryNull $ mk k' v vr pre m mr PostFix (Left ys) -> tryNull $ goRight (key k' xs)- j left' mr ys+ left' mr ys PostFix (Right ys) -> tryNull $ goLeft (key k' pre)- j left' right ys+ left' right ys tryNull t = if null t then Nothing else Just t - goLeft _ _ _ _ [] = can'tHappen+ goLeft _ _ _ [] = can'tHappen can'tHappen = error "Data.ListTrie.Patricia.Base.differenceWithKey :: internal error"@@ -682,7 +696,7 @@ -> trie map k a -> trie map k b -> trie map k c-intersectionWith f = genericIntersectionWith (intersectionVals f) (flip const)+intersectionWith f = genericIntersectionWith (flip const) (intersectionVals f) -- O(min(n1 m1,n2 m2)) intersectionWith' :: ( Alt st c, Boolable (st c)@@ -693,38 +707,40 @@ -> trie map k a -> trie map k b -> trie map k c-intersectionWith' f = genericIntersectionWith (intersectionVals' f) seq+intersectionWith' f = genericIntersectionWith seq (intersectionVals' f) genericIntersectionWith :: forall a b c k map st trie. ( Alt st c, Boolable (st c) , Trie trie st map k )- => (st a -> st b -> st c)- -> (st c -> trie map k c -> trie map k c)+ => (forall x. st x -> trie map k x -> trie map k x)+ -> (st a -> st b -> st c) -> trie map k a -> trie map k b -> trie map k c-genericIntersectionWith valIsect_ seeq_ trl trr =- let (vl,prel,ml) = tParts trl- (vr,prer,mr) = tParts trr- in case comparePrefixes (Map.eqCmp ml) prel prer of- DifferedAt _ _ _ -> empty- Same -> mk valIsect_ seeq_ vl vr prel ml mr- PostFix remainder ->- -- use the one with a longer prefix as the base for the- -- intersection, and descend into the map of the one with a- -- shorter prefix- either (go valIsect_ seeq_ mr vl ml (DL.fromList prel))- (go (flip valIsect_) seeq_ ml vr mr (DL.fromList prer))- remainder+genericIntersectionWith seeq = go0 where- mapIntersect valIsect seeq =+ go0 valIsect trl trr =+ let (vl,prel,ml) = tParts trl+ (vr,prer,mr) = tParts trr+ in case comparePrefixes (Map.eqCmp ml) prel prer of+ DifferedAt _ _ _ -> empty+ Same -> mk valIsect vl vr prel ml mr+ PostFix remainder ->+ -- use the one with a longer prefix as the base for the+ -- intersection, and descend into the map of the one with a+ -- shorter prefix+ either (go valIsect mr vl ml (DL.fromList prel))+ (go (flip valIsect) ml vr mr (DL.fromList prer))+ remainder++ mapIntersect valIsect = Map.filter (not.null) .:- Map.intersectionWith (genericIntersectionWith valIsect seeq)+ Map.intersectionWith (go0 valIsect) - mk valIsect seeq v v' p m m' =+ mk valIsect v v' p m m' = let vi = valIsect v v'- in vi `seeq` (tryCompress.mkTrie vi p $ mapIntersect valIsect seeq m m')+ in vi `seeq` (tryCompress.mkTrie vi p $ mapIntersect valIsect m m') -- Polymorphic recursion in 'go' (valIsect :: st a -> st b -> st c ---> st b -- -> st a -> st c) means that it has to be explicitly typed in order to@@ -780,14 +796,13 @@ -- and we'd still like "cat" so we keep the True from there. go :: (Alt st z, Boolable (st z), Trie trie st map k) => (st x -> st y -> st z)- -> (st z -> trie map k z -> trie map k z) -> CMap trie map k y -> st x -> CMap trie map k x -> DList k -> [k] -> trie map k z- go valIsect seeq ma v mb pre (x:xs) =+ go valIsect ma v mb pre (x:xs) = case Map.lookup x ma of Nothing -> empty Just tr ->@@ -795,14 +810,14 @@ in case comparePrefixes (Map.eqCmp ma) xs pre' of DifferedAt _ _ _ -> empty Same ->- mk valIsect seeq v v' (DL.toList pre) mb m'+ mk valIsect v v' (DL.toList pre) mb m' PostFix (Right ys) -> let nextPre = pre `DL.append` DL.fromList ys- in go (flip valIsect) seeq mb v' m' nextPre ys+ in go (flip valIsect) mb v' m' nextPre ys PostFix (Left ys) ->- go valIsect seeq m' v mb pre ys+ go valIsect m' v mb pre ys - go _ _ _ _ _ _ [] =+ go _ _ _ _ _ [] = error "Data.ListTrie.Patricia.Map.intersectionWith :: internal error" -- O(min(n1 m1,n2 m2))@@ -814,7 +829,7 @@ -> trie map k a -> trie map k b -> trie map k c-intersectionWithKey = genericIntersectionWithKey intersectionVals (flip const)+intersectionWithKey = genericIntersectionWithKey (flip const) intersectionVals -- O(min(n1 m1,n2 m2)) intersectionWithKey' :: ( Alt st c, Boolable (st c)@@ -825,51 +840,50 @@ -> trie map k a -> trie map k b -> trie map k c-intersectionWithKey' = genericIntersectionWithKey intersectionVals' seq+intersectionWithKey' = genericIntersectionWithKey seq intersectionVals' genericIntersectionWithKey :: forall a b c k map st trie. (Alt st c, Boolable (st c), Trie trie st map k)- => ((a -> b -> c) -> st a -> st b -> st c)- -> (st c -> trie map k c -> trie map k c)+ => (forall x. st x -> trie map k x -> trie map k x)+ -> ((a -> b -> c) -> st a -> st b -> st c) -> ([k] -> a -> b -> c) -> trie map k a -> trie map k b -> trie map k c-genericIntersectionWithKey = main DL.empty+genericIntersectionWithKey seeq = main DL.empty where- main k valIsect seeq j trl trr =+ main k valIsect j trl trr = let (vl,prel,ml) = tParts trl (vr,prer,mr) = tParts trr in case comparePrefixes (Map.eqCmp ml) prel prer of DifferedAt _ _ _ -> empty- Same -> mk k valIsect seeq j vl vr prel ml mr+ Same -> mk k valIsect j vl vr prel ml mr PostFix remainder -> let prel' = DL.fromList prel prer' = DL.fromList prer in either- (go k valIsect seeq j mr vl ml prel')- (go k (flipp valIsect) seeq (flip.j) ml vr mr prer')+ (go k valIsect j mr vl ml prel')+ (go k (flop valIsect) (flip.j) ml vr mr prer') remainder - mk k valIsect seeq j v v' p m m' =+ mk k valIsect j v v' p m m' = let k' = k `DL.append` DL.fromList p vi = valIsect (j $ DL.toList k') v v' in vi `seeq` (tryCompress.mkTrie vi p $- mapIntersect k' valIsect seeq j m m')+ mapIntersect k' valIsect j m m') - mapIntersect k valIsect seeq j =+ mapIntersect k valIsect j = Map.filter (not.null) .:- Map.intersectionWithKey (\x -> main (k `DL.snoc` x) valIsect seeq j)+ Map.intersectionWithKey (\x -> main (k `DL.snoc` x) valIsect j) - flipp :: ((x -> y -> z) -> st x -> st y -> st z)+ flop :: ((x -> y -> z) -> st x -> st y -> st z) -> ((y -> x -> z) -> st y -> st x -> st z)- flipp f = flip . f . flip+ flop f = flip . f . flip -- See intersectionWith: this explicit type is necessary go :: (Alt st z, Boolable (st z), Trie trie st map k) => DList k -> ((x -> y -> z) -> st x -> st y -> st z)- -> (st z -> trie map k z -> trie map k z) -> ([k] -> x -> y -> z) -> CMap trie map k y -> st x@@ -877,7 +891,7 @@ -> DList k -> [k] -> trie map k z- go k valIsect seeq j ma v mb pre (x:xs) =+ go k valIsect j ma v mb pre (x:xs) = case Map.lookup x ma of Nothing -> empty Just tr ->@@ -885,16 +899,14 @@ in case comparePrefixes (Map.eqCmp ma) xs pre' of DifferedAt _ _ _ -> empty Same ->- mk k valIsect seeq j v v' (DL.toList pre) mb m'+ mk k valIsect j v v' (DL.toList pre) mb m' PostFix (Right ys) -> let nextPre = pre `DL.append` DL.fromList ys- in go k (flipp valIsect) seeq (flip.j)- mb v' m' nextPre ys+ in go k (flop valIsect) (flip.j) mb v' m' nextPre ys PostFix (Left ys) ->- go k valIsect seeq j- m' v mb pre ys+ go k valIsect j m' v mb pre ys - go _ _ _ _ _ _ _ _ [] =+ go _ _ _ _ _ _ _ [] = error "Data.ListTrie.Patricia.Map.intersectionWithKey :: internal error" -- * Filtering@@ -955,14 +967,14 @@ -> (k1 -> k2) -> trie map k1 a -> trie map k2 a-genericMapInKeysWith seeq listSeq unionW j f tr =- let (v,p,m) = tParts tr- p' = map f p- in listSeq p' `seeq`- (mkTrie v p' $- Map.fromListWith (unionW j) .- map (f *** genericMapInKeysWith seeq listSeq unionW j f) .- Map.toList $ m)+genericMapInKeysWith seeq listSeq unionW j f = go+ where+ go tr =+ let (v,p,m) = tParts tr+ p' = map f p+ in listSeq p' `seeq`+ (mkTrie v p' $+ Map.fromListWith (unionW j) . map (f *** go) . Map.toList $ m) -- * Folding @@ -1032,14 +1044,14 @@ -> (([k],a) -> DList ([k],a) -> DList ([k],a)) -> trie map k a -> [([k],a)]-genericToList f_ g_ = DL.toList . go DL.empty f_ g_+genericToList tolist add = DL.toList . go DL.empty where- go l tolist add tr =+ go l tr = let (v,p,m) = tParts tr l' = l `DL.append` DL.fromList p xs = DL.concat .- map (\(x,t) -> go (l' `DL.snoc` x) tolist add t) .+ map (\(x,t) -> go (l' `DL.snoc` x) t) . tolist $ m in if hasValue v then add (DL.toList l', unwrap v) xs@@ -1087,16 +1099,16 @@ -> (CMap trie map k a -> Maybe (k, trie map k a)) -> trie map k a -> (Maybe ([k], a), trie map k a)-minMaxView _ _ tr_ | null tr_ = (Nothing, tr_)-minMaxView f g tr_ = first Just (go f g tr_)+minMaxView _ _ tr_ | null tr_ = (Nothing, tr_)+minMaxView isWanted mapView tr_ = first Just (go tr_) where- go isWanted mapView tr =+ go tr = let (v,pre,m) = tParts tr in if isWanted tr then ((pre, unwrap v), safeMkTrie altEmpty pre m) else let (k, tr') = fromJust (mapView m)- (minMax, tr'') = go isWanted mapView tr'+ (minMax, tr'') = go tr' in ( first (prepend pre k) minMax , mkTrie v pre $ if null tr'' then Map.delete k m@@ -1118,16 +1130,16 @@ -> (CMap trie map k a -> Maybe (k, trie map k a)) -> trie map k a -> Maybe ([k], a)-findMinMax _ _ tr_ | null tr_ = Nothing-findMinMax f g tr_ = Just (go f g DL.empty tr_)+findMinMax _ _ tr_ | null tr_ = Nothing+findMinMax isWanted mapView tr_ = Just (go DL.empty tr_) where- go isWanted mapView xs tr =+ go xs tr = let (v,pre,m) = tParts tr xs' = xs `DL.append` DL.fromList pre in if isWanted tr then (DL.toList xs', unwrap v) else let (k, tr') = fromJust . mapView $ m- in go isWanted mapView (xs' `DL.snoc` k) tr'+ in go (xs' `DL.snoc` k) tr' -- O(m) deleteMin :: (Alt st a, Boolable (st a), Trie trie st map k, OrdMap map k)@@ -1361,9 +1373,8 @@ Same -> EQ PostFix r -> either (const GT) (const LT) r DifferedAt _ (x:_) (y:_) -> ord x y- _ ->- error$ "Data.ListTrie.Patricia.Base.ordComparePrefixes :: " ++- "internal error"+ _ -> error+ "Data.ListTrie.Patricia.Base.ordComparePrefixes :: internal error" -- After modifying the trie, compress a trie node into the prefix if possible. --
list-tries.cabal view
@@ -1,7 +1,7 @@ Cabal-Version: >= 1.6 Name: list-tries-Version: 0.2+Version: 0.3 Homepage: http://iki.fi/matti.niemenmaa/list-tries/ Synopsis: Tries and Patricia tries: finite sets and maps for list keys Category: Data, Data Structures@@ -36,26 +36,13 @@ tests/*.hs tests/Tests/*.hs -Flag containers03- Description: Assume that containers has a version number of at least 0.3. If- false, some functionality cannot be implemented and is changed- to call 'error' instead. Defaults to True, as >= 0.3 is shipped- with GHC 6.12.- Default: True- Library Extensions: CPP - if flag(containers03)- Build-Depends: base >= 3 && < 4.3- , containers >= 0.3 && < 0.4- , dlist >= 0.4 && < 0.6- , binary >= 0.5 && < 0.6- else- Build-Depends: base >= 3 && < 4.3- , containers >= 0.2 && < 0.3- , dlist >= 0.4 && < 0.6- , binary >= 0.5 && < 0.6+ Build-Depends: base >= 3 && < 4.3+ , containers >= 0.3 && < 0.4+ , dlist >= 0.4 && < 0.6+ , binary >= 0.5 && < 0.6 Exposed-Modules: Data.ListTrie.Base.Map Data.ListTrie.Map