diff --git a/CHANGELOG.txt b/CHANGELOG.txt --- a/CHANGELOG.txt +++ b/CHANGELOG.txt @@ -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. diff --git a/Data/ListTrie/Base.hs b/Data/ListTrie/Base.hs --- a/Data/ListTrie/Base.hs +++ b/Data/ListTrie/Base.hs @@ -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) diff --git a/Data/ListTrie/Base/Map.hs b/Data/ListTrie/Base/Map.hs --- a/Data/ListTrie/Base/Map.hs +++ b/Data/ListTrie/Base/Map.hs @@ -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 diff --git a/Data/ListTrie/Patricia/Base.hs b/Data/ListTrie/Patricia/Base.hs --- a/Data/ListTrie/Patricia/Base.hs +++ b/Data/ListTrie/Patricia/Base.hs @@ -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. -- diff --git a/list-tries.cabal b/list-tries.cabal --- a/list-tries.cabal +++ b/list-tries.cabal @@ -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