TrieMap 0.0.1.0 → 0.0.1.1
raw patch · 8 files changed
+278/−203 lines, 8 filesdep ~containerssetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: containers
API changes (from Hackage documentation)
Files
- Setup.hs +0/−2
- Setup.lhs +3/−0
- TrieMap.cabal +2/−2
- TrieMap.hs +49/−37
- TrieMap/MapTypes.hs +29/−7
- TrieMap/RadixTrie.hs +126/−109
- TrieMap/Reflection.hs +7/−1
- TrieMap/TrieAlgebraic.hs +62/−45
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
TrieMap.cabal view
@@ -1,5 +1,5 @@ name: TrieMap-version: 0.0.1.0+version: 0.0.1.1 license: BSD3 license-file: LICENSE maintainer: wasserman.louis@gmail.com@@ -21,7 +21,7 @@ build-type: Simple build-depends:- base >= 4 && <= 5, containers+ base >= 4 && <= 5, containers == 0.2.0.1 exposed-modules: TrieMap TrieMap.Algebraic
TrieMap.hs view
@@ -157,6 +157,7 @@ import Control.Monad import Data.Monoid import Data.Traversable+import TrieMap.MapTypes import TrieMap.Applicative import TrieMap.Algebraic import TrieMap.TrieAlgebraic@@ -175,7 +176,7 @@ import qualified Prelude as Prelude -- | A 'TrieMap' is a size-tracking wrapper around a generalized trie map.-data TrieMap k m a = TrieMap {sizeMap :: Int, trieMap :: m a}+data TrieMap k m a = TrieMap {sizeMap :: Int, trieMap :: m (Elem a)} instance (Eq k, Eq a, Algebraic k, TrieKey (Alg k) m) => Eq (TrieMap k m a) where (==) = (==) `on` assocs@@ -187,26 +188,26 @@ show m = "fromList " ++ show (assocs m) instance (Algebraic k, Algebraic a, TrieKey (Alg k) m) => Algebraic (TrieMap k m a) where- type Alg (TrieMap k m a) = (Int, [(Alg k, Alg a)])- toAlg (TrieMap n m) = (n, build (\ c n -> foldWithKeyAlg (\ k a -> c (k, toAlg a)) n m))- fromAlg (n, xs) = TrieMap n $ fromDistAscListAlg [(k, fromAlg a) | (k, a) <- xs]+ type Alg (TrieMap k m a) = ([(Alg k, Alg a)], Int)+ toAlg (TrieMap n m) = (build (\ c n -> foldWithKeyAlg (\ k a -> c (k, toAlg a)) n m), n)+ fromAlg (xs, n) = TrieMap n $ fromDistAscListAlg [(k, fromAlg a) | (k, a) <- xs] instance Functor m => Functor (TrieMap k m) where- fmap f (TrieMap n m) = TrieMap n (fmap f m)+ fmap f (TrieMap n m) = TrieMap n (fmap (fmap f) m) instance Foldable m => Foldable (TrieMap k m) where- foldr f z = foldr f z . trieMap- foldl f z = foldl f z . trieMap- foldMap f = foldMap f . trieMap+ foldr f z = foldr (\ (Elem x) z -> f x z) z . trieMap+ foldl f z = foldl (\ z (Elem x) -> f z x) z . trieMap+ foldMap f = foldMap (f . getElem) . trieMap instance Traversable m => Traversable (TrieMap k m) where- traverse f (TrieMap n m) = TrieMap n <$> traverse f m+ traverse f (TrieMap n m) = TrieMap n <$> traverse (traverse f) m instance (Algebraic k, TrieKey (Alg k) m) => Monoid (TrieMap k m a) where mempty = empty mappend = union -mkTrieMap :: (Algebraic k, TrieKey (Alg k) m) => m a -> TrieMap k m a+mkTrieMap :: (Algebraic k, TrieKey (Alg k) m) => m (Elem a) -> TrieMap k m a mkTrieMap m = TrieMap (sizeAlg m) m -- | Lookup the value of a key in the map.@@ -214,7 +215,7 @@ -- The function will return the corresponding value as @('Just' value)@, -- or 'Nothing' if the key isn't in the map. lookup :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> Maybe a-lookup k = lookupAlg (toAlg k) . trieMap+lookup k = fmap getElem . lookupAlg (toAlg k) . trieMap -- | Is the key a member of the map? See also 'notMember'. --@@ -249,7 +250,7 @@ -- -- > singleton 1 'a' == fromList [(1, 'a')] singleton :: (Algebraic k, TrieKey (Alg k) m) => k -> a -> TrieMap k m a-singleton k v = TrieMap 1 (insertAlg (toAlg k) v emptyAlg)+singleton k v = TrieMap 1 (insertAlg (toAlg k) (Elem v) emptyAlg) -- | Find the value at a key. -- Calls 'error' when the element can not be found.@@ -293,7 +294,7 @@ -- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")] -- > fromListWithKey f [] == empty fromListWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> [(k, a)] -> TrieMap k m a-fromListWithKey f xs = mkTrieMap $ fromListAlg (f . fromAlg) [(toAlg k, v) | (k, v) <- xs]+fromListWithKey f xs = mkTrieMap $ fromListAlg (\ k (Elem v1) (Elem v2) -> Elem (f (fromAlg k) v1 v2)) [(toAlg k, Elem v) | (k, v) <- xs] -- | /O(n)/. Build a map from an ascending list in linear time. -- /The precondition (input list is ascending) is not checked./@@ -317,14 +318,15 @@ -- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2 -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")] fromAscListWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> [(k, a)] -> TrieMap k m a-fromAscListWithKey f xs = mkTrieMap $ fromAscListAlg (f . fromAlg) [(toAlg k, v) | (k, v) <- xs]+fromAscListWithKey f xs = mkTrieMap $ fromAscListAlg g [(toAlg k, Elem v) | (k, v) <- xs] where+ g k (Elem v1) (Elem v2) = Elem (f (fromAlg k) v1 v2) -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time. -- /The precondition is not checked./ -- -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] fromDistinctAscList :: (Algebraic k, TrieKey (Alg k) m) => [(k, a)] -> TrieMap k m a-fromDistinctAscList xs = TrieMap (length xs) $ fromDistAscListAlg [(toAlg k, v) | (k, v) <- xs]+fromDistinctAscList xs = TrieMap (length xs) $ fromDistAscListAlg [(toAlg k, Elem v) | (k, v) <- xs] -- | Insert a new key and value in the map. -- If the key is already present in the map, the associated value is@@ -368,8 +370,9 @@ -- is a pair where the first element is equal to (@'lookup' k map@) -- and the second element equal to (@'insertWithKey' f k x map@). insertLookupWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> k -> a -> TrieMap k m a -> (Maybe a, TrieMap k m a)-insertLookupWithKey f k v (TrieMap n m) = case alterLookupAlg (\ v' -> (v', Just $ maybe v (f k v) v')) (toAlg k) m of+insertLookupWithKey f k v (TrieMap n m) = case alterLookupAlg g (toAlg k) m of (old, m') -> (old, TrieMap (if isJust old then n else n + 1) m')+ where g v' = (fmap getElem v', Just $ Elem $ maybe v (f k v . getElem) v') -- | The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is@@ -404,8 +407,9 @@ -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") updateLookupWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Maybe a) -> k -> TrieMap k m a -> (Maybe a, TrieMap k m a) updateLookupWithKey f k (TrieMap n m) = - case alterLookupAlg (\ v -> let v' = v >>= f k in ((isNothing v' && isJust v, maybe v Just v'), v')) (toAlg k) m of+ case alterLookupAlg g (toAlg k) m of ((del, res), m') -> (res, TrieMap (if del then n - 1 else n) m')+ where g v = let v' = v >>= f k . getElem in ((isNothing v' && isJust v, maybe (fmap getElem v) Just v'), fmap Elem v') -- | Delete a key and its value from the map. When the key is not -- a member of the map, the original map is returned.@@ -439,7 +443,8 @@ alterLookup :: (Algebraic k, TrieKey (Alg k) m) => (Maybe a -> Maybe a) -> k -> TrieMap k m a -> (Maybe a, TrieMap k m a) alterLookup f k (TrieMap n m) = case alterLookupAlg g (toAlg k) m of ((old, delta), m') -> (old, TrieMap (n + delta) m')- where g v = let fv = f v in ((v, just1 fv - just1 v), fv)+ where g Nothing = let fv = f Nothing in ((Nothing, just1 fv), fmap Elem fv)+ g (Just (Elem v)) = let fv = f (Just v) in ((Just v, just1 fv - 1), fmap Elem fv) just1 = maybe 0 (const 1) -- | /O(n)/. Map a function over all values in the map.@@ -458,7 +463,7 @@ -- | Essentially equivalent to 'traverse' with a function that takes both the key and the value as arguments. mapAppWithKey :: (Algebraic k, TrieKey (Alg k) m, Applicative f) => (k -> a -> f b) -> TrieMap k m a -> f (TrieMap k m b)-mapAppWithKey f (TrieMap n m) = TrieMap n <$> mapAppAlg (f . fromAlg) m+mapAppWithKey f (TrieMap n m) = TrieMap n <$> mapAppAlg (\ k (Elem v) -> Elem <$> f (fromAlg k) v) m -- | Equivalent to 'traverse'. mapApp :: (Algebraic k, TrieKey (Alg k) m, Applicative f) => (a -> f b) -> TrieMap k m a -> f (TrieMap k m b)@@ -469,7 +474,7 @@ -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" mapMaybeWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Maybe b) -> TrieMap k m a -> TrieMap k m b-mapMaybeWithKey f = mkTrieMap . mapMaybeAlg (f . fromAlg) . trieMap+mapMaybeWithKey f = mkTrieMap . mapMaybeAlg (\ k (Elem v) -> Elem <$> f (fromAlg k) v) . trieMap -- | /O(n)/. Map values and collect the 'Just' results. --@@ -499,7 +504,7 @@ -- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) mapEitherWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Either b c) -> TrieMap k m a -> (TrieMap k m b, TrieMap k m c) mapEitherWithKey f (TrieMap _ m) = (mkTrieMap mL, mkTrieMap mR)- where (mL, mR) = mapEitherAlg (f . fromAlg) m+ where (mL, mR) = mapEitherAlg (\ k (Elem v) -> either (Left . Elem) (Right . Elem) (f (fromAlg k) v)) m -- | -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.@@ -626,11 +631,11 @@ -- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" -- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)" foldWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> b -> b) -> b -> TrieMap k m a -> b-foldWithKey f z = foldWithKeyAlg (f . fromAlg) z . trieMap+foldWithKey f z = foldWithKeyAlg (\ k (Elem v) -> f (fromAlg k) v) z . trieMap -- | /O(n+m)/. Union with a combining function that may discard some elements. unionMaybeWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a-unionMaybeWithKey f = mkTrieMap .: unionMaybeAlg (f . fromAlg) `on` trieMap+unionMaybeWithKey f = mkTrieMap .: unionMaybeAlg (\ k (Elem v1) (Elem v2) -> Elem <$> f (fromAlg k) v1 v2) `on` trieMap -- | /O(n+m)/. -- Union with a combining function. @@ -666,7 +671,7 @@ unionsWith = unionsWithKey . const unionsWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> [TrieMap k m a] -> TrieMap k m a-unionsWithKey f = mkTrieMap . foldl' (unionMaybeAlg (\ k x y -> Just (f (fromAlg k) x y))) emptyAlg +unionsWithKey f = mkTrieMap . foldl' (unionMaybeAlg (\ k (Elem x) (Elem y) -> Just $ Elem $ f (fromAlg k) x y)) emptyAlg . Prelude.map trieMap -- | O(n+m). Symmetric difference. Equivalent to @'unionMaybeWith' (\ _ _ -> Nothing)@.@@ -676,7 +681,8 @@ -- | /O(n+m)/. Intersection of two maps with a combining function that may discard some elements. intersectionMaybeWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> b -> Maybe c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c-intersectionMaybeWithKey f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $ intersectAlg (f . fromAlg) m1 m2+intersectionMaybeWithKey f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $ + intersectAlg (\ k (Elem a) (Elem b) -> Elem <$> f (fromAlg k) a b) m1 m2 -- | /O(n+m)/. Intersection with a combining function. --@@ -712,7 +718,8 @@ -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) -- > == singleton 3 "3:b|B" differenceWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> b -> Maybe a) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m a-differenceWithKey f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $ differenceAlg (f . fromAlg) m1 m2+differenceWithKey f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $ + differenceAlg (\ k (Elem x) (Elem y) -> Elem <$> f (fromAlg k) x y) m1 m2 -- | /O(n+m)/. Difference with a combining function. -- When two equal keys are@@ -724,7 +731,7 @@ -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) -- > == singleton 3 "b:B" differenceWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> b -> Maybe a) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m a-differenceWith f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $ differenceAlg (const f) m1 m2+differenceWith = differenceWithKey . const -- | /O(n+m)/. Difference of two maps. -- Return elements of the first map not existing in the second map.@@ -802,7 +809,8 @@ -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMin :: (Algebraic k, TrieKey (Alg k) m) => (a -> Maybe a) -> TrieMap k m a -> TrieMap k m a updateMin f (TrieMap n m) = TrieMap (if del then n-1 else n) m'- where (del, m') = updateMinAlg (const (checkNothing . f)) m+ where (del, m') = updateMinAlg (const (checkNothing . g)) m+ g (Elem x) = Elem <$> f x -- | Update the value at the maximal key. --@@ -810,7 +818,8 @@ -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMax :: (Algebraic k, TrieKey (Alg k) m) => (a -> Maybe a) -> TrieMap k m a -> TrieMap k m a updateMax f (TrieMap n m) = TrieMap (if del then n-1 else n) m'- where (del, m') = updateMaxAlg (const (checkNothing . f)) m+ where (del, m') = updateMaxAlg (const (checkNothing . g)) m+ g (Elem x) = Elem <$> f x -- | Update the value at the minimal key. --@@ -818,7 +827,8 @@ -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMinWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a updateMinWithKey f (TrieMap n m) = TrieMap (if del then n-1 else n) m'- where (del, m') = updateMinAlg (checkNothing .: f . fromAlg) m+ where (del, m') = updateMinAlg (checkNothing .: g) m+ g k (Elem v) = Elem <$> f (fromAlg k) v -- | Update the value at the maximal key. --@@ -826,7 +836,8 @@ -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMaxWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a updateMaxWithKey f (TrieMap n m) = TrieMap (if del then n-1 else n) m'- where (del, m') = updateMaxAlg (checkNothing .: f . fromAlg) m+ where (del, m') = updateMaxAlg (checkNothing .: g) m+ g k (Elem v) = Elem <$> f (fromAlg k) v -- | Retrieves the value associated with the minimal key of the -- map, and the map stripped of that element, or 'Nothing' if passed an@@ -836,7 +847,7 @@ -- > minView empty == Nothing minView :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe (a, TrieMap k m a) minView (TrieMap n m) = do- (~(_, v), m') <- getMinAlg m+ (~(_, Elem v), m') <- getMinAlg m return (v, TrieMap (n-1) m') -- | Retrieves the value associated with the maximal key of the@@ -846,7 +857,7 @@ -- > maxView empty == Nothing maxView :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe (a, TrieMap k m a) maxView (TrieMap n m) = do- (~(_, v), m') <- getMaxAlg m+ (~(_, Elem v), m') <- getMaxAlg m return (v, TrieMap (n-1) m') -- | Retrieves the minimal (key,value) pair of the map, and@@ -856,7 +867,7 @@ -- > minViewWithKey empty == Nothing minViewWithKey :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe ((k, a), TrieMap k m a) minViewWithKey (TrieMap n m) = do- (~(k, v), m') <- getMinAlg m+ (~(k, Elem v), m') <- getMinAlg m return ((fromAlg k, v), TrieMap (n-1) m') -- | Retrieves the maximal (key,value) pair of the map, and@@ -866,7 +877,7 @@ -- > maxViewWithKey empty == Nothing maxViewWithKey :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe ((k, a), TrieMap k m a) maxViewWithKey (TrieMap n m) = do- ~(~(k, v), m') <- getMaxAlg m+ ~(~(k, Elem v), m') <- getMaxAlg m return ((fromAlg k, v), TrieMap (n-1) m') -- | /O(n+m)/.@@ -893,7 +904,8 @@ -} isSubmapOfBy :: (Algebraic k, TrieKey (Alg k) m) => (a -> b -> Bool) -> TrieMap k m a -> TrieMap k m b -> Bool-isSubmapOfBy (<=) (TrieMap n1 m1) (TrieMap n2 m2) = (Prelude.<=) n1 n2 && isSubmapAlg (<=) m1 m2+isSubmapOfBy (<=) (TrieMap n1 m1) (TrieMap n2 m2) = (Prelude.<=) n1 n2 && isSubmapAlg (<<=) m1 m2+ where Elem x <<= Elem y = x <= y -- | The expression (@'split' k map@) is a pair @(map1,map2)@ where -- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.@@ -917,7 +929,7 @@ -- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty) -- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty) splitLookup :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> (TrieMap k m a, Maybe a, TrieMap k m a)-splitLookup k (TrieMap n m) = case splitLookupAlg (\ v -> (Nothing, Just v, Nothing)) (toAlg k) m of+splitLookup k (TrieMap n m) = case splitLookupAlg (\ (Elem v) -> (Nothing, Just v, Nothing)) (toAlg k) m of (mL, v, mR) -> (mkTrieMap mL, v, mkTrieMap mR) -- TODO: Somehow, avoid the mkTrieMap call. Is this possible? I don't think so, without a sophisticated range-mconcat operation -- with monoids or some crazy shit like that.
TrieMap/MapTypes.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeOperators, FlexibleContexts, StandaloneDeriving #-}+{-# LANGUAGE IncoherentInstances, TypeOperators, FlexibleContexts, StandaloneDeriving #-} module TrieMap.MapTypes where @@ -6,6 +6,7 @@ import Data.Traversable import Control.Applicative import Prelude hiding (foldl, foldr)+import qualified Data.IntMap as IMap -- | 'ProdMap' is used to hold a map on the product of two key types. newtype ProdMap m1 m2 v = PMap {unPMap :: m1 (m2 v)} deriving (Eq, Ord)@@ -13,15 +14,33 @@ -- | 'UnionMap' is used to hold a map on the sum of two key types. data UnionMap m1 m2 v = m1 v :+: m2 v deriving (Eq, Ord) -data Edge k m v = Edge [k] (Maybe v) (m (Edge k m v))+data Edge k m v = Edge {-# UNPACK #-} !Int [k] (Maybe v) (m (Edge k m v)) type MEdge k m v = Maybe (Edge k m v) -- | 'RadixTrie' is used to hold a map on a list of keys. newtype RadixTrie k m v = Radix {unRad :: MEdge k m v} +newtype Elem a = Elem {getElem :: a} deriving (Eq, Ord)++instance Functor Elem where+ fmap f (Elem x) = Elem (f x)++instance Foldable Elem where+ foldr f z (Elem a) = a `f` z+ foldl f z (Elem a) = z `f` a++instance Traversable Elem where+ traverse f (Elem x) = Elem <$> f x+ infixr 5 `ProdMap` infixr 5 :+: +class Sized a where+ getSize :: a -> Int++instance Sized (Elem a) where+ getSize _ = 1+ instance (Functor m1, Functor m2) => Functor (ProdMap m1 m2) where fmap f (PMap m) = PMap (fmap (fmap f) m) @@ -43,22 +62,25 @@ traverse f (m1 :+: m2) = liftA2 (:+:) (traverse f m1) (traverse f m2) instance Functor m => Functor (Edge k m) where- fmap f (Edge ks v ts) = Edge ks (fmap f v) (fmap (fmap f) ts)+ fmap f (Edge n ks v ts) = Edge n ks (fmap f v) (fmap (fmap f) ts) instance Functor m => Functor (RadixTrie k m) where fmap f (Radix e) = Radix (fmap (fmap f) e) instance Foldable m => Foldable (Edge k m) where- foldr f z (Edge _ v ts) = foldr (flip (foldr f)) (foldr f z v) ts- foldl f z (Edge _ v ts) = foldl f (foldl (foldl f) z ts) v+ foldr f z (Edge _ _ v ts) = foldr (flip (foldr f)) (foldr f z v) ts+ foldl f z (Edge _ _ v ts) = foldl f (foldl (foldl f) z ts) v instance Foldable m => Foldable (RadixTrie k m) where foldr f z (Radix e) = foldr (flip (foldr f)) z e foldl f z (Radix e) = foldl (foldl f) z e instance Traversable m => Traversable (Edge k m) where- traverse f (Edge ks v ts) = - liftA2 (Edge ks) (traverse f v) (traverse (traverse f) ts)+ traverse f (Edge n ks v ts) = + liftA2 (Edge n ks) (traverse f v) (traverse (traverse f) ts) instance Traversable m => Traversable (RadixTrie k m) where traverse f (Radix e) = Radix <$> traverse (traverse f) e++instance Traversable IMap.IntMap where+ traverse f m = IMap.fromDistinctAscList <$> traverse (\ (k, v) -> ((,) k) <$> f v) (IMap.assocs m)
TrieMap/RadixTrie.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, StandaloneDeriving, PatternGuards #-}+{-# LANGUAGE IncoherentInstances, MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, StandaloneDeriving, PatternGuards #-} module TrieMap.RadixTrie (RadixTrie) where @@ -19,10 +19,10 @@ import Prelude hiding (null, foldr, all) instance (Eq k, Eq v, TrieKey k m) => Eq (Edge k m v) where- Edge ks1 v1 ts1 == Edge ks2 v2 ts2 = ks1 == ks2 && v1 == v2 && assocsAlg ts1 == assocsAlg ts2+ Edge n1 ks1 v1 ts1 == Edge n2 ks2 v2 ts2 = n1 == n2 && ks1 == ks2 && v1 == v2 && assocsAlg ts1 == assocsAlg ts2 instance (Ord k, Ord v, TrieKey k m) => Ord (Edge k m v) where- Edge ks1 v1 ts1 `compare` Edge ks2 v2 ts2 = + Edge _ ks1 v1 ts1 `compare` Edge _ ks2 v2 ts2 = compare ks1 ks2 `mappend` compare v1 v2 `mappend` comparing assocsAlg ts1 ts2 deriving instance (Eq k, Eq v, TrieKey k m) => Eq (RadixTrie k m v)@@ -30,11 +30,15 @@ deriving instance (Show k, Show v, Functor m, Show (m String)) => Show (RadixTrie k m v) instance (Show k, Show v, Functor m, Show (m String)) => Show (Edge k m v) where- show (Edge k v ts) = "Edge " ++ show k ++ " " ++ show v ++ " " ++ show (fmap show ts)+ show (Edge _ k v ts) = "Edge " ++ show k ++ " " ++ show v ++ " " ++ show (fmap show ts) +instance Sized (Edge k m v) where+ getSize (Edge n _ _ _) = n+ instance (Ord k, TrieKey k m) => TrieKey [k] (RadixTrie k m) where emptyAlg = Radix Nothing nullAlg = isNothing . unRad+ sizeAlg (Radix e) = maybe 0 getSize e getSingleAlg (Radix e) = e >>= getSingleEdge guardNullAlg (Radix e) = do e <- guardNullEdge =<< e return (Radix (Just e))@@ -63,7 +67,8 @@ fromAscListAlg f xs = Radix (edgeFromAscList f xs) fromDistAscListAlg = fromAscListAlg (\ _ v _ -> v) - isSubmapAlg (<=) (Radix e1) (Radix e2) = isSubmapAlg (isSubmapEdge (<=)) e1 e2+ isSubmapAlg (<=) (Radix e1) (Radix e2) = isSubmapAlg subEdge e1 e2 -- hehe, using the Maybe instance here!+ where subEdge = isSubmapEdge (==) (<=) lookupAlg $! isSubmapAlg subEdge valid (Radix e) = maybe True validEdge e @@ -74,52 +79,58 @@ -- sizeEdge :: Edge k m v -> Int -- sizeEdge (Edge n _ _ _) = n --- edge :: TrieKey k m => [k] -> Maybe v -> m (Edge k m v) -> Edge k m v--- edge ks v ts = Edge (maybe id (const (+1)) v $ foldl' (\ n e -> n + sizeEdge e) 0 ts) ks v ts+{-# INLINE edge #-}+edge :: (Sized v, TrieKey k m) => [k] -> Maybe v -> m (Edge k m v) -> Edge k m v+edge ks v ts = Edge (getSize v + getSize ts) ks v ts lookupEdge :: TrieKey k m => (k -> k -> Bool) -> [k] -> Edge k m v -> Maybe v-lookupEdge (==) ks (Edge ls v ts) = procEdge ks ls where+lookupEdge (==) ks (Edge _ ls v ts) = procEdge ks ls where procEdge (k:ks) (l:ls)- | k == l = procEdge ks ls+ | k == l = procEdge ks ls procEdge (k:ks) [] = lookupAlg k ts >>= lookupEdge (==) ks procEdge [] [] = v procEdge _ _ = Nothing -edgeFromList :: (Eq k, TrieKey k m) => ([k] -> v -> v -> v) -> [([k], v)] -> MEdge k m v-edgeFromList f xs = guardNullEdge $ Edge [] v0 $ mapMaybeAlg (\ k -> edgeFromList (f . (k:))) $ fromListAlg (const (flip (++))) ys+edgeFromList :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> v) -> [([k], v)] -> MEdge k m v+edgeFromList f xs = guardNullEdge $ edge [] v0 $ mapMaybeAlg (\ k (Elem xs)-> edgeFromList (f . (k:)) xs) $ + fromListAlg (\ _ (Elem xs) (Elem ys) -> Elem (ys ++ xs)) ys where part ([], v) (v0, ys) = (Just $ maybe v (flip (f []) v) v0, ys)- part (k:ks, v) (v0, ys) = (v0, (k, [(ks, v)]):ys)+ part (k:ks, v) (v0, ys) = (v0, (k, Elem [(ks, v)]):ys) (v0, ys) = foldr part (Nothing, []) xs -edgeFromAscList :: (Eq k, TrieKey k m) => ([k] -> v -> v -> v) -> [([k], v)] -> MEdge k m v+edgeFromAscList :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> v) -> [([k], v)] -> MEdge k m v edgeFromAscList _ [] = Nothing-edgeFromAscList f xs = Just $ case groupHead f xs of- (Nothing, [(k, ~(Edge ks v ts))])- -> Edge (k:ks) v ts- (ans, xs') -> Edge [] ans (fromDistAscListAlg xs')+edgeFromAscList f (x:xs) = Just $ edgeFromAscList' f x xs -groupHead :: (Eq k, TrieKey k m) => ([k] -> v -> v -> v) -> [([k], v)] -> (Maybe v, [(k, Edge k m v)])+edgeFromAscList' :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> v) -> ([k], v) -> [([k], v)] -> Edge k m v+edgeFromAscList' f (ks, v) [] = Edge (getSize v) ks (Just v) emptyAlg+edgeFromAscList' f x xs = case groupHead f (x:xs) of+ (Nothing, [(k, ~(Edge n ks v ts))])+ -> Edge n (k:ks) v ts+ (ans, xs') -> edge [] ans (fromDistAscListAlg xs')++groupHead :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> v) -> [([k], v)] -> (Maybe v, [(k, Edge k m v)]) groupHead f (([], v):xs) = case groupHead f xs of (v', ans) -> (Just $ maybe v (f [] v) v', ans)-groupHead f ((k:ks, v):xs) = (Nothing, groupHead' k (Seq.singleton (ks, v)) xs) where- groupHead' k0 xs ((k:ks, v):ys)- | k == k0 = groupHead' k0 (xs |> (ks, v)) ys- | otherwise = (k0, fromJust $ edgeFromAscList (f . (k0:)) (toList xs)):groupHead' k (Seq.singleton (ks, v)) ys- groupHead' k0 xs [] = [(k0, fromJust $ edgeFromAscList (f . (k0:)) (toList xs))]- groupHead' _ _ _ = error "Violation of ascending invariant!"+groupHead f ((k:ks, v):xs) = (Nothing, groupHead' k (ks, v) Seq.empty xs) where+ groupHead' k0 x xs ((k:ks, v):ys)+ | k == k0 = groupHead' k0 x (xs |> (ks, v)) ys+ | otherwise = (k0, edgeFromAscList' (f . (k0:)) x (toList xs)):groupHead' k (ks, v) Seq.empty ys+ groupHead' k0 x xs [] = [(k0, edgeFromAscList' (f . (k0:)) x (toList xs))]+ groupHead' _ _ _ _ = error "Violation of ascending invariant!" groupHead _ [] = (Nothing, []) {-guardNullEdge $ Edge [] v0 $ mapMaybeAlg (\ k -> edgeFromAscList (f . (k:))) $ fromAscListAlg (const (flip (++))) ys where part ([], v) (v0, ys) = (Just $ maybe v (flip (f []) v) v0, ys) part (k:ks, v) (v0, ys) = (v0, (k, [(ks, v)]):ys) (v0, ys) = foldr part (Nothing, []) xs-} -maybeSingleEdge :: TrieKey k m => [k] -> Maybe v -> MEdge k m v-maybeSingleEdge ks = fmap (\ v -> Edge ks (Just v) emptyAlg)+maybeSingleEdge :: Sized v => TrieKey k m => [k] -> Maybe v -> MEdge k m v+maybeSingleEdge ks = fmap (\ v -> Edge (getSize v) ks (Just v) emptyAlg) getSingleEdge :: (TrieKey k m) => Edge k m v -> Maybe ([k], v)-getSingleEdge (Edge ks (Just v) ts)+getSingleEdge (Edge _ ks (Just v) ts) | nullAlg ts = Just (ks, v)-getSingleEdge (Edge ks Nothing ts) = do+getSingleEdge (Edge _ ks Nothing ts) = do (x, e') <- getSingleAlg ts (xs, v) <- getSingleEdge e' return (ks ++ x:xs, v) @@ -127,158 +138,164 @@ {-# INLINE guardNullEdge #-} guardNullEdge :: TrieKey k m => Edge k m v -> MEdge k m v-guardNullEdge (Edge ks Nothing ts)+guardNullEdge (Edge n ks Nothing ts) | nullAlg ts = Nothing- | Just (x, Edge xs v ts') <- getSingleAlg ts- = Just (Edge (ks ++ x:xs) v ts')+ | Just (x, Edge n' xs v ts') <- getSingleAlg ts+ = Just (Edge n' (ks ++ x:xs) v ts') guardNullEdge e = Just e -alterLookupEdge :: (TrieKey k m) => (k -> k -> Bool) ->+alterLookupEdge :: (TrieKey k m, Sized v) => (k -> k -> Bool) -> (Maybe v -> (a, Maybe v)) -> [k] -> Edge k m v -> (a, MEdge k m v)-alterLookupEdge (==) f ks0 e@(Edge ls0 v ts) = procEdge 0 ks0 ls0 where+alterLookupEdge (==) f ks0 e@(Edge n0 ls0 v ts) = procEdge 0 ks0 ls0 where procEdge i _ _ | i `seq` False = undefined procEdge i (k:ks) (l:ls) | k == l = procEdge (i+1) ks ls- | otherwise = fmap (Just . g) $ f Nothing+ | otherwise = fmap (Just . g) (f Nothing) where g Nothing = e- g (Just v') = Edge (take i ks0) Nothing $- fromListAlg' [(k, Edge ks (Just v') emptyAlg), (l, Edge ls v ts)]+ g (Just v') = let nV = getSize v' in Edge (n0 + nV) (take i ks0) Nothing $+ fromListAlg' [(k, Edge nV ks (Just v') emptyAlg), (l, Edge n0 ls v ts)] procEdge i (k:ks) [] = proc (alterLookupAlg g k ts) where g Nothing = maybeSingleEdge ks <$> f Nothing g (Just e') = alterLookupEdge (==) f ks e'- proc = fmap (guardNullEdge . Edge ls0 v)+ proc = fmap (guardNullEdge . edge ls0 v) procEdge i [] (l:ls) = fmap (Just . g) $ f Nothing where g Nothing = e- g (Just v') = Edge ks0 (Just v') $ insertAlg l (Edge ls v ts) emptyAlg- procEdge i [] [] = (ans, guardNullEdge (Edge ks0 fv ts))+ g (Just v') = Edge (getSize v' + n0) ks0 (Just v') $ insertAlg l (Edge n0 ls v ts) emptyAlg+ procEdge i [] [] = (ans, guardNullEdge (Edge (getSize fv - getSize v + n0) ks0 fv ts)) where (ans, fv) = f v foldWithKeyEdge :: TrieKey k m => ([k] -> v -> x -> x) -> x -> Edge k m v -> x-foldWithKeyEdge f z (Edge ks v ts) =+foldWithKeyEdge f z (Edge _ ks v ts) = foldr (f ks) (foldWithKeyAlg (\ x -> flip (foldWithKeyEdge (\ xs -> f (ks ++ x:xs)))) z ts) v -mapMaybeEdge :: (TrieKey k m) => ([k] -> v -> Maybe w) -> Edge k m v -> MEdge k m w-mapMaybeEdge f (Edge ks v ts) = guardNullEdge $- Edge ks (join $ traverse (f ks) v) (mapMaybeAlg (\ x -> mapMaybeEdge (\ xs -> f (ks ++ x:xs))) ts)+mapMaybeEdge :: (TrieKey k m, Sized w) => ([k] -> v -> Maybe w) -> Edge k m v -> MEdge k m w+mapMaybeEdge f (Edge _ ks v ts) = guardNullEdge $+ edge ks (join $ traverse (f ks) v) (mapMaybeAlg (\ x -> mapMaybeEdge (\ xs -> f (ks ++ x:xs))) ts) -mapEitherEdge :: TrieKey k m => ([k] -> a -> Either b c) -> Edge k m a -> (MEdge k m b, MEdge k m c)-mapEitherEdge f (Edge ks v ts) =- (guardNullEdge $ Edge ks vL tsL, guardNullEdge $ Edge ks vR tsR) +mapEitherEdge :: (TrieKey k m, Sized b, Sized c) => ([k] -> a -> Either b c) -> Edge k m a -> (MEdge k m b, MEdge k m c)+mapEitherEdge f (Edge _ ks v ts) =+ (guardNullEdge $ edge ks vL tsL, guardNullEdge $ edge ks vR tsR) where (vL, vR) = case fmap (f ks) v of Nothing -> (Nothing, Nothing) Just (Left v) -> (Just v, Nothing) Just (Right v) -> (Nothing, Just v)- ts' = mapWithKeyAlg (\ x -> mapEitherEdge (\ xs -> f (ks ++ x:xs))) ts- tsL = mapMaybeAlg (const fst) ts'- tsR = mapMaybeAlg (const snd) ts'+ ts' = mapWithKeyAlg (\ x -> Elem . mapEitherEdge (\ xs -> f (ks ++ x:xs))) ts+ tsL = mapMaybeAlg (\ _ (Elem (tsL, _)) -> tsL) ts'+ tsR = mapMaybeAlg (\ _ (Elem (_, tsR)) -> tsR) ts' -mapAppEdge :: (Applicative f, TrieKey k m) => ([k] -> v -> f w) -> Edge k m v -> f (Edge k m w)-mapAppEdge f (Edge ks v ts) = liftA2 (Edge ks) (traverse (f ks) v) (mapAppAlg (\ x -> mapAppEdge (\ xs -> f (ks ++ x:xs))) ts)+mapAppEdge :: (Applicative f, TrieKey k m, Sized w) => ([k] -> v -> f w) -> Edge k m v -> f (Edge k m w)+mapAppEdge f (Edge _ ks v ts) = liftA2 (edge ks) (traverse (f ks) v) (mapAppAlg (\ x -> mapAppEdge (\ xs -> f (ks ++ x:xs))) ts) -unionMaybeEdge :: (Eq k, TrieKey k m) => ([k] -> v -> v -> Maybe v) -> Edge k m v -> Edge k m v -> MEdge k m v-unionMaybeEdge f (Edge ks0 vK tsK) (Edge ls0 vL tsL) = procEdge 0 ks0 ls0 where+unionMaybeEdge :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> Maybe v) -> Edge k m v -> Edge k m v -> MEdge k m v+unionMaybeEdge f (Edge nK ks0 vK tsK) (Edge nL ls0 vL tsL) = procEdge 0 ks0 ls0 where procEdge i _ _ | i `seq` False = undefined procEdge i (k:ks) (l:ls) | k == l = procEdge (i+1) ks ls- | otherwise = Just $ Edge (take i ks0) Nothing $ fromListAlg' [(k, Edge ks vK tsK), (l, Edge ls vL tsL)]- procEdge _ [] (l:ls) = guardNullEdge $ Edge ks0 vK $ alterAlg g l tsK- where g Nothing = Just (Edge ls vL tsL)- g (Just e') = unionMaybeEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge ls vL tsL)- procEdge _ (k:ks) [] = guardNullEdge $ Edge ls0 vL $ alterAlg g k tsL - where g Nothing = Just $ Edge ks vK tsK- g (Just e') = unionMaybeEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge ks vK tsK) e'- procEdge _ [] [] = guardNullEdge $ Edge ks0 (unionMaybe (f ks0) vK vL) $+ | otherwise = Just $ Edge (nK + nL) (take i ks0) Nothing $ fromListAlg' [(k, Edge nK ks vK tsK), (l, Edge nL ls vL tsL)]+ procEdge _ [] (l:ls) = guardNullEdge $ edge ks0 vK $ alterAlg g l tsK+ where g Nothing = Just (Edge nL ls vL tsL)+ g (Just e') = unionMaybeEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge nL ls vL tsL)+ procEdge _ (k:ks) [] = guardNullEdge $ edge ls0 vL $ alterAlg g k tsL + where g Nothing = Just $ Edge nK ks vK tsK+ g (Just e') = unionMaybeEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge nK ks vK tsK) e'+ procEdge _ [] [] = guardNullEdge $ edge ks0 (unionMaybe (f ks0) vK vL) $ unionMaybeAlg (\ x -> unionMaybeEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL -intersectEdge :: (Eq k, TrieKey k m) => ([k] -> a -> b -> Maybe c) -> Edge k m a -> Edge k m b -> MEdge k m c-intersectEdge f (Edge ks0 vK tsK) (Edge ls0 vL tsL) = procEdge ks0 ls0 where+intersectEdge :: (Eq k, TrieKey k m, Sized c) => ([k] -> a -> b -> Maybe c) -> Edge k m a -> Edge k m b -> MEdge k m c+intersectEdge f (Edge nK ks0 vK tsK) (Edge nL ls0 vL tsL) = procEdge ks0 ls0 where procEdge (k:ks) (l:ls) | k == l = procEdge ks ls | otherwise = Nothing procEdge (k:ks) [] = do e' <- lookupAlg k tsL- Edge xs vX tsX <- intersectEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge ks vK tsK) e'- return (Edge (ls0 ++ k:xs) vX tsX)+ Edge nX xs vX tsX <- intersectEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge nK ks vK tsK) e'+ return (Edge nX (ls0 ++ k:xs) vX tsX) procEdge [] (l:ls) = do e' <- lookupAlg l tsK- Edge xs vX tsX <- intersectEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge ls vL tsL)- return (Edge (ks0 ++ l:xs) vX tsX)- procEdge [] [] = guardNullEdge $ Edge ks0 (intersectMaybe (f ks0) vK vL) $+ Edge nX xs vX tsX <- intersectEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge nL ls vL tsL)+ return (Edge nX (ks0 ++ l:xs) vX tsX)+ procEdge [] [] = guardNullEdge $ edge ks0 (intersectMaybe (f ks0) vK vL) $ intersectAlg (\ x -> intersectEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL -differenceEdge :: (Eq k, TrieKey k m) => ([k] -> v -> w -> Maybe v) -> Edge k m v -> Edge k m w -> MEdge k m v-differenceEdge f e@(Edge ks0 vK tsK) (Edge ls0 vL tsL) = procEdge ks0 ls0 where+{-# SPECIALIZE differenceEdge :: (Eq k, TrieKey k m) => ([k] -> Elem v -> w -> Maybe (Elem v)) -> + Edge k m (Elem v) -> Edge k m w -> MEdge k m (Elem v) #-}+differenceEdge :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> w -> Maybe v) -> Edge k m v -> Edge k m w -> MEdge k m v+differenceEdge f e@(Edge nK ks0 vK tsK) (Edge nL ls0 vL tsL) = procEdge ks0 ls0 where procEdge (k:ks) (l:ls) | k == l = procEdge ks ls procEdge (k:ks) [] | Just e' <- lookupAlg k tsL- = do Edge xs vX tsX <- differenceEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge ks vK tsK) e'- return (Edge (ls0 ++ k:xs) vX tsX)- procEdge [] (l:ls) = guardNullEdge $ Edge ks0 vK $ alterAlg g l tsK+ = do Edge nX xs vX tsX <- differenceEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge nK ks vK tsK) e'+ return (Edge nX (ls0 ++ k:xs) vX tsX)+ procEdge [] (l:ls) = guardNullEdge $ edge ks0 vK $ alterAlg g l tsK where g Nothing = Nothing- g (Just e') = differenceEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge ls vL tsL)- procEdge [] [] = guardNullEdge $ Edge ks0 (differenceMaybe (f ks0) vK vL) $+ g (Just e') = differenceEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge nL ls vL tsL)+ procEdge [] [] = guardNullEdge $ edge ks0 (differenceMaybe (f ks0) vK vL) $ differenceAlg (\ x -> differenceEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL procEdge _ _ = Just e -getMinEdge :: TrieKey k m => Edge k m v -> (([k], v), MEdge k m v)-getMinEdge (Edge ks (Just v) ts) = ((ks, v), guardNullEdge $ Edge ks Nothing ts)-getMinEdge (Edge ks _ ts) +{-# SPECIALIZE getMinEdge :: TrieKey k m => Edge k m (Elem v) -> (([k], Elem v), MEdge k m (Elem v)) #-}+getMinEdge :: (Sized v, TrieKey k m) => Edge k m v -> (([k], v), MEdge k m v)+getMinEdge (Edge nK ks (Just v) ts) = ((ks, v), guardNullEdge $ Edge (nK - getSize v) ks Nothing ts)+getMinEdge (Edge nK ks _ ts) | Just ((l, e), ts') <- getMinAlg ts, ((ls, v), e') <- getMinEdge e- = ((ks ++ l:ls, v), guardNullEdge $ Edge ks Nothing $ maybe ts' (\ e' -> snd $ updateMinAlg (\ _ _ -> (False, Just e')) ts) e')+ = ((ks ++ l:ls, v), guardNullEdge $ edge ks Nothing $ maybe ts' (\ e' -> snd $ updateMinAlg (\ _ _ -> (False, Just e')) ts) e') getMinEdge _ = error "Uncompacted edge" -getMaxEdge :: TrieKey k m => Edge k m v -> (([k], v), MEdge k m v)-getMaxEdge (Edge ks v0 ts)+getMaxEdge :: (Sized v, TrieKey k m) => Edge k m v -> (([k], v), MEdge k m v)+getMaxEdge (Edge nK ks v0 ts) | Just ((l, e), ts') <- getMaxAlg ts, ((ls, v), e') <- getMaxEdge e- = ((ks ++ l:ls, v), guardNullEdge $ Edge ks v0 $ maybe ts' (\ e' -> snd $ updateMaxAlg (\ _ _ -> (False, Just e')) ts) e')-getMaxEdge (Edge ks (Just v) ts) = ((ks, v), guardNullEdge $ Edge ks Nothing ts)+ = ((ks ++ l:ls, v), guardNullEdge $ edge ks v0 $ maybe ts' (\ e' -> snd $ updateMaxAlg (\ _ _ -> (False, Just e')) ts) e')+getMaxEdge (Edge nK ks (Just v) ts) = ((ks, v), guardNullEdge $ Edge (nK - getSize v) ks Nothing ts) getMaxEdge _ = error "Uncompacted edge" -updateMinEdge :: TrieKey k m => ([k] -> v -> (Bool, Maybe v)) -> Edge k m v -> (Bool, MEdge k m v)-updateMinEdge f (Edge ks (Just v) ts) = fmap (\ v' -> guardNullEdge $ Edge ks v' ts) (f ks v)-updateMinEdge f (Edge ks Nothing ts)- = fmap (guardNullEdge . Edge ks Nothing) $ updateMinAlg (\ l -> updateMinEdge (\ ls -> f (ks ++ l:ls))) ts+updateMinEdge :: (TrieKey k m, Sized v) => ([k] -> v -> (Bool, Maybe v)) -> Edge k m v -> (Bool, MEdge k m v)+updateMinEdge f (Edge _ ks (Just v) ts) = fmap (\ v' -> guardNullEdge $ edge ks v' ts) (f ks v)+updateMinEdge f (Edge _ ks Nothing ts)+ = fmap (guardNullEdge . edge ks Nothing) $ updateMinAlg (\ l -> updateMinEdge (\ ls -> f (ks ++ l:ls))) ts -updateMaxEdge :: TrieKey k m => ([k] -> v -> (Bool, Maybe v)) -> Edge k m v -> (Bool, MEdge k m v)-updateMaxEdge f (Edge ks (Just v) ts)- | nullAlg ts = fmap (\ v' -> guardNullEdge $ Edge ks v' ts) (f ks v)-updateMaxEdge f (Edge ks v ts) = - fmap (guardNullEdge . Edge ks v) $ updateMaxAlg (\ l -> updateMaxEdge (\ ls -> f (ks ++ l:ls))) ts+updateMaxEdge :: (TrieKey k m, Sized v) => ([k] -> v -> (Bool, Maybe v)) -> Edge k m v -> (Bool, MEdge k m v)+updateMaxEdge f (Edge _ ks (Just v) ts)+ | nullAlg ts = fmap (\ v' -> guardNullEdge $ edge ks v' ts) (f ks v)+updateMaxEdge f (Edge _ ks v ts) = + fmap (guardNullEdge . edge ks v) $ updateMaxAlg (\ l -> updateMaxEdge (\ ls -> f (ks ++ l:ls))) ts -isSubmapEdge :: TrieKey k m => (a -> b -> Bool) -> Edge k m a -> Edge k m b -> Bool-isSubmapEdge (<=) (Edge ks vK tsK) (Edge ls vL tsL) = procEdge ks ls where+isSubmapEdge :: TrieKey k m => (k -> k -> Bool) -> (a -> b -> Bool) -> (k -> m (Edge k m b) -> MEdge k m b) -> (m (Edge k m a) -> m (Edge k m b) -> Bool) -> + Edge k m a -> Edge k m b -> Bool+isSubmapEdge (==) (<=) lookup (<<=) (Edge nK ks vK tsK) (Edge nL ls vL tsL) = procEdge ks ls where procEdge (k:ks) (l:ls) | k == l = procEdge ks ls procEdge (k:ks) []- | Just e <- lookupAlg k tsL- = isSubmapEdge (<=) (Edge ks vK tsK) e+ | Just e <- lookup k tsL+ = isSubmapEdge (==) (<=) lookup (<<=) (Edge nK ks vK tsK) e procEdge [] [] - | Nothing <- vK = isSubmapAlg (isSubmapEdge (<=)) tsK tsL+ | Nothing <- vK = tsK <<= tsL | Just x <- vK, Just y <- vL, x <= y- = isSubmapAlg (isSubmapEdge (<=)) tsK tsL+ = tsK <<= tsL procEdge _ _ = False validEdge :: TrieKey k m => Edge k m v -> Bool-validEdge (Edge _ Nothing m)+validEdge (Edge _ _ Nothing m) | nullAlg m = False | Just{} <- getSingleAlg m = False-validEdge (Edge _ _ m)+validEdge (Edge _ _ _ m) = valid m && all validEdge m -splitEdge :: (Ord k, TrieKey k m) => (a -> (Maybe a, Maybe b, Maybe a)) -> [k] -> Edge k m a -> (MEdge k m a, Maybe b, MEdge k m a)-splitEdge f ks0 (Edge ls0 v ts) = procEdge ks0 ls0 where+splitEdge :: (Ord k, TrieKey k m, Sized a) => (a -> (Maybe a, Maybe b, Maybe a)) -> [k] -> Edge k m a -> (MEdge k m a, Maybe b, MEdge k m a)+splitEdge f ks0 e@(Edge nL ls0 v ts) = procEdge ks0 ls0 where+ answerLess = (Nothing, Nothing, Just e) -- if ks0 < ls0+ answerMore = (Just e, Nothing, Nothing) -- if ks0 > ls0 procEdge (k:ks) (l:ls) = case compare k l of- LT -> (Nothing, Nothing, Just (Edge ls0 v ts))+ LT -> answerLess EQ -> procEdge ks ls- GT -> (Just (Edge ks0 v ts), Nothing, Nothing)+ GT -> answerMore procEdge (k:ks) [] = case splitLookupAlg (splitEdge f ks) k ts of- (tsL, ans, tsR) -> (guardNullEdge $ Edge ls0 Nothing tsL, ans, guardNullEdge $ Edge ls0 v tsR)- procEdge [] (l:ls) = (Nothing, Nothing, Just $ Edge ls0 v ts)+ (tsL, ans, tsR) -> (guardNullEdge $ edge ls0 Nothing tsL, ans, guardNullEdge $ edge ls0 v tsR)+ procEdge [] (l:ls) = answerLess procEdge [] [] | Just v <- v, (vL, ans, vR) <- f v- = (fmap (\ v' -> Edge ls0 (Just v') emptyAlg) vL, ans, - guardNullEdge $ Edge ls0 vR ts)- | otherwise = (Nothing, Nothing, Just (Edge ls0 v ts))+ = (fmap (\ v' -> edge ls0 (Just v') emptyAlg) vL, ans, + guardNullEdge $ edge ls0 vR ts)+ | otherwise = answerLess -- all children of e match ks0 initially but are longer, and v is Nothing
TrieMap/Reflection.hs view
@@ -3,12 +3,18 @@ module TrieMap.Reflection where -- import TrieMap.Fixpoint+import TrieMap.MapTypes import TrieMap.TrieAlgebraic import TrieMap.Algebraic import TrieMap.Applicative import TrieMap.RadixTrie() import qualified TrieMap.TrieAlgebraic as TA +instance Algebraic v => Algebraic (Elem v) where+ type Alg (Elem v) = Alg v+ toAlg (Elem v) = toAlg v+ fromAlg v = Elem (fromAlg v)+ instance Algebraic (m1 (m2 v)) => Algebraic (ProdMap m1 m2 v) where type Alg (ProdMap m1 m2 v) = Alg (m1 (m2 v)) toAlg (PMap m) = toAlg m@@ -19,7 +25,7 @@ toAlg (m1 :+: m2) = (toAlg m1, toAlg m2) fromAlg (m1, m2) = fromAlg m1 :+: fromAlg m2 -instance (Ord k, Algebraic k, Algebraic v, TrieKey k m) => Algebraic (RadixTrie k m v) where+instance (Ord k, Algebraic k, Sized v, Algebraic v, TrieKey k m) => Algebraic (RadixTrie k m v) where type Alg (RadixTrie k m v) = Alg [([k], v)] toAlg m = toAlg (build (\ c n -> foldWithKeyAlg (curry c) n m)) fromAlg = fromDistAscListAlg . fromAlg
TrieMap/TrieAlgebraic.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, PatternGuards #-}+{-# LANGUAGE FlexibleInstances, TypeOperators, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, PatternGuards, IncoherentInstances #-} module TrieMap.TrieAlgebraic (TrieKey (..), ProdMap (..), UnionMap(..), RadixTrie(..), Edge (..), Ordered (..), unionMaybe, intersectMaybe, differenceMaybe, mapWithKeyAlg, assocsAlg, insertAlg, alterAlg, fromListAlg') where @@ -35,36 +35,40 @@ -- | TrieKey defines a bijection between map types and algebraic key types. class (Eq a, Foldable m, Traversable m) => TrieKey a m | a -> m, m -> a where- emptyAlg :: m v- nullAlg :: m v -> Bool- sizeAlg :: m v -> Int- getSingleAlg :: m v -> Maybe (a, v)- guardNullAlg :: m v -> Maybe (m v)- {-# SPECIALIZE alterAlg :: (Maybe v -> Id (b, Maybe v)) -> a -> m v -> Id (b, m v) #-}- alterLookupAlg :: (Maybe v -> (b, Maybe v)) -> a -> m v -> (b, m v)- lookupAlg :: a -> m v -> Maybe v- foldWithKeyAlg :: (a -> v -> x -> x) -> x -> m v -> x- mapAppAlg :: Applicative f => (a -> v -> f w) -> m v -> f (m w)- mapMaybeAlg :: (a -> v -> Maybe w) -> m v -> m w- mapEitherAlg :: (a -> v -> Either x y) -> m v -> (m x, m y)- unionMaybeAlg :: (a -> v -> v -> Maybe v) -> m v -> m v -> m v- intersectAlg :: (a -> v -> w -> Maybe x) -> m v -> m w -> m x- differenceAlg :: (a -> v -> w -> Maybe v) -> m v -> m w -> m v- fromDistAscListAlg :: [(a, v)] -> m v- fromAscListAlg :: (a -> v -> v -> v) -> [(a, v)] -> m v- fromListAlg :: (a -> v -> v -> v) -> [(a, v)] -> m v- getMinAlg :: m v -> Maybe ((a, v), m v)- getMaxAlg :: m v -> Maybe ((a, v), m v)- updateMinAlg :: (a -> v -> (Bool, Maybe v)) -> m v -> (Bool, m v)- updateMaxAlg :: (a -> v -> (Bool, Maybe v)) -> m v -> (Bool, m v)- valid :: m v -> Bool- isSubmapAlg :: (v -> w -> Bool) -> m v -> m w -> Bool- splitLookupAlg :: (v -> (Maybe v, Maybe x, Maybe v)) -> a -> m v -> (m v, Maybe x, m v)+ emptyAlg :: Sized v => m v+ nullAlg :: Sized v => m v -> Bool+ sizeAlg :: Sized v => m v -> Int+ getSingleAlg :: Sized v => m v -> Maybe (a, v)+ guardNullAlg :: Sized v => m v -> Maybe (m v)+-- {-# SPECIALIZE alterAlg :: Sized v => (Maybe v -> Id (b, Maybe v)) -> a -> m v -> Id (b, m v) #-}+ alterLookupAlg :: Sized v => (Maybe v -> (b, Maybe v)) -> a -> m v -> (b, m v)+ lookupAlg :: Sized v => a -> m v -> Maybe v+ foldWithKeyAlg :: Sized v => (a -> v -> x -> x) -> x -> m v -> x+ mapAppAlg :: (Applicative f, Sized v, Sized w) => (a -> v -> f w) -> m v -> f (m w)+ mapMaybeAlg :: (Sized v, Sized w) => (a -> v -> Maybe w) -> m v -> m w+ mapEitherAlg :: (Sized v, Sized x, Sized y) => (a -> v -> Either x y) -> m v -> (m x, m y)+ unionMaybeAlg :: Sized v => (a -> v -> v -> Maybe v) -> m v -> m v -> m v+ intersectAlg :: (Sized v, Sized w, Sized x) => (a -> v -> w -> Maybe x) -> m v -> m w -> m x+ differenceAlg :: (Sized v, Sized w) => (a -> v -> w -> Maybe v) -> m v -> m w -> m v+ fromDistAscListAlg :: Sized v => [(a, v)] -> m v+ fromAscListAlg :: Sized v => (a -> v -> v -> v) -> [(a, v)] -> m v+ fromListAlg :: Sized v => (a -> v -> v -> v) -> [(a, v)] -> m v+ getMinAlg :: Sized v => m v -> Maybe ((a, v), m v)+ getMaxAlg :: Sized v => m v -> Maybe ((a, v), m v)+ updateMinAlg :: Sized v => (a -> v -> (Bool, Maybe v)) -> m v -> (Bool, m v)+ updateMaxAlg :: Sized v => (a -> v -> (Bool, Maybe v)) -> m v -> (Bool, m v)+ valid :: Sized v => m v -> Bool+ isSubmapAlg :: (Sized v, Sized w) => (v -> w -> Bool) -> m v -> m w -> Bool+ splitLookupAlg :: (Sized v) => (v -> (Maybe v, Maybe x, Maybe v)) -> a -> m v -> (m v, Maybe x, m v) lookupAlg k = fst . alterLookupAlg (\ v -> (v, v)) k guardNullAlg m | nullAlg m = Nothing | otherwise = Just m+ getSingleAlg m = do+ ((k, v), m') <- getMinAlg m+ guard (nullAlg m')+ return (k, v) fromListAlg f = foldr (\ (k, v) -> alterAlg (Just . maybe v (f k v)) k) emptyAlg fromAscListAlg _ [] = emptyAlg fromAscListAlg f ((k, v):xs) = fromDistAscListAlg (distinct k v xs) where@@ -79,28 +83,36 @@ updateMaxAlg f m = maybe (False, m) (\ ((k, v), m') -> maybe m' (\ v' -> insertAlg k v' m) <$> f k v) (getMaxAlg m) valid = (`seq` True) -fromListAlg' :: TrieKey k m => [(k, v)] -> m v+instance (TrieKey k m, Sized a) => Sized (m a) where+ {-# SPECIALIZE instance (Sized a, TrieKey k1 m1, TrieKey k2 m2) => Sized (ProdMap m1 m2 a) #-}+ {-# SPECIALIZE instance (Sized a, TrieKey k1 m1, TrieKey k2 m2) => Sized (UnionMap m1 m2 a) #-}+ {-# SPECIALIZE instance Sized a => Sized (Maybe a) #-}+ {-# SPECIALIZE instance Sized a => Sized (IntMap a) #-}+ {-# SPECIALIZE instance (Ord k, Sized a) => Sized (Map k a) #-}+ getSize = sizeAlg++fromListAlg' :: (Sized v, TrieKey k m) => [(k, v)] -> m v fromListAlg' = fromListAlg (const const) -singletonAlg :: TrieKey k m => k -> v -> m v+singletonAlg :: (Sized v, TrieKey k m) => k -> v -> m v singletonAlg k v = insertAlg k v emptyAlg -mapWithKeyAlg :: TrieKey k m => (k -> v -> w) -> m v -> m w+mapWithKeyAlg :: (Sized v, Sized w, TrieKey k m) => (k -> v -> w) -> m v -> m w mapWithKeyAlg f m = unId (mapAppAlg (\ k v -> Id (f k v)) m) -- mapMaybeWithKeyAlg :: TrieKey k m => (k -> v -> Maybe w) -> m v -> m w -- mapMaybeWithKeyAlg f m = unId (mapAppMaybeAlg (\ k v -> Id (f k v)) m) -insertAlg :: TrieKey k m => k -> v -> m v -> m v+insertAlg :: (Sized v, TrieKey k m) => k -> v -> m v -> m v insertAlg k v = alterAlg (const (Just v)) k -alterAlg :: TrieKey k m => (Maybe v -> Maybe v) -> k -> m v -> m v+alterAlg :: (Sized v, TrieKey k m) => (Maybe v -> Maybe v) -> k -> m v -> m v alterAlg f k = snd . alterLookupAlg (\ x -> ((), f x)) k -- alterLookupAlg :: TrieKey k m => (Maybe a -> (b, Maybe a)) -> k -> m a -> (b, m a) -- alterLookupAlg f = unId .: alterAppAlg (Id . f) -foldrAlg :: TrieKey k m => (a -> b -> b) -> b -> m a -> b+foldrAlg :: (Sized a, TrieKey k m) => (a -> b -> b) -> b -> m a -> b foldrAlg = foldWithKeyAlg . const unionMaybe :: (a -> a -> Maybe a) -> Maybe a -> Maybe a -> Maybe a@@ -126,13 +138,13 @@ filterRight _ _ = Nothing {-# INLINE assocsAlg #-}-assocsAlg :: TrieKey k m => m a -> [(k, a)]+assocsAlg :: (Sized a, TrieKey k m) => m a -> [(k, a)] assocsAlg m = build (\ c n -> foldWithKeyAlg (\ k v xs -> (k,v) `c` xs) n m) instance (Eq a1, Eq a2, TrieKey a1 m1, TrieKey a2 m2) => TrieKey (a1, a2) (m1 `ProdMap` m2) where emptyAlg = PMap emptyAlg nullAlg (PMap m) = nullAlg m- sizeAlg (PMap m) = foldl' (\ n m -> n + sizeAlg m) 0 m+ sizeAlg (PMap m) = sizeAlg m getSingleAlg (PMap m) = do (k1, m') <- getSingleAlg m (k2, v) <- getSingleAlg m' return ((k1, k2), v)@@ -144,16 +156,16 @@ PMap <$> mapAppAlg (\ k1 -> mapAppAlg (\ k2 -> f (k1, k2))) m mapMaybeAlg f (PMap m) = PMap $ mapMaybeAlg (\ k1 -> guardNullAlg . mapMaybeAlg (\ k2 -> f (k1, k2))) m- mapEitherAlg f (PMap m) = (PMap (fmap fst m'), PMap (fmap snd m'))- where m' = mapWithKeyAlg (\ k1 -> mapEitherAlg (\ k2 -> f (k1, k2))) m+ mapEitherAlg f (PMap m) = (PMap (fmap (\ (Elem (mL, _)) -> mL) m'), PMap (fmap (\ (Elem (_, mR)) -> mR) m'))+ where m' = mapWithKeyAlg (\ k1 -> Elem . mapEitherAlg (\ k2 -> f (k1, k2))) m unionMaybeAlg f (PMap m1) (PMap m2) = PMap (unionMaybeAlg (\ k1 -> guardNullAlg .: unionMaybeAlg (\ k2 -> f (k1, k2))) m1 m2) intersectAlg f (PMap m1) (PMap m2) = PMap (intersectAlg (\ k1 -> guardNullAlg .: intersectAlg (\ k2 -> f (k1, k2))) m1 m2) differenceAlg f (PMap m1) (PMap m2) = PMap (differenceAlg (\ k1 -> guardNullAlg .: differenceAlg (\ k2 -> f (k1, k2))) m1 m2)- fromListAlg f xs = PMap $ mapWithKeyAlg (\ k1 -> fromListAlg (\ k2 -> f (k1, k2))) $- fromListAlg (const (++)) [(k1, [(k2, v)]) | ((k1, k2), v) <- xs]+ fromListAlg f xs = PMap $ mapWithKeyAlg (\ k1 (Elem xs) -> fromListAlg (\ k2 -> f (k1, k2)) xs) $+ fromListAlg (\ _ (Elem x) (Elem y) -> Elem (x ++ y)) [(k1, Elem [(k2, v)]) | ((k1, k2), v) <- xs] fromDistAscListAlg xs = PMap $ fromDistAscListAlg [(k1, fromDistAscListAlg ys) | (k1, ys) <- breakFst xs] fromAscListAlg f xs = PMap $ fromDistAscListAlg [(k1, fromAscListAlg (\ k2 -> f (k1, k2)) ys) | (k1, ys) <- breakFst xs] getMinAlg (PMap m) = do@@ -195,9 +207,9 @@ (Nothing, Just (k, v)) -> Just (Right k, v) _ -> Nothing alterLookupAlg f (Left k) (m1 :+: m2) = - fmap (:+: m2) $ alterLookupAlg f k m1+ (:+: m2) <$> alterLookupAlg f k m1 alterLookupAlg f (Right k) (m1 :+: m2) =- fmap (m1 :+:) $ alterLookupAlg f k m2+ (m1 :+:) <$> alterLookupAlg f k m2 lookupAlg k (m1 :+: m2) = either (`lookupAlg` m1) (`lookupAlg` m2) k foldWithKeyAlg f z (m1 :+: m2) = foldWithKeyAlg (f . Left) (foldWithKeyAlg (f . Right) z m2) m1 mapAppAlg f (m1 :+: m2) = @@ -250,7 +262,7 @@ instance TrieKey Int IntMap where emptyAlg = IMap.empty nullAlg = IMap.null- sizeAlg = IMap.size+ sizeAlg = foldl' (\ n x -> n + getSize x) 0 getSingleAlg m | IMap.size m == 1, [(k, v)] <- IMap.toList m = Just (k, v)@@ -290,7 +302,7 @@ instance Ord k => TrieKey (Ordered k) (Map k) where emptyAlg = Map.empty nullAlg = Map.null- sizeAlg = Map.size+ sizeAlg = foldl' (\ n x -> n + getSize x) 0 getSingleAlg m | Map.size m == 1, (k, v) <- Map.findMin m = Just (Ord k, v)@@ -331,7 +343,7 @@ instance TrieKey () Maybe where emptyAlg = Nothing nullAlg = isNothing- sizeAlg = maybe 0 (const 1)+ sizeAlg = maybe 0 getSize getSingleAlg = fmap ((,) ()) lookupAlg _ = id alterLookupAlg f _ = f@@ -348,6 +360,7 @@ fromListAlg _ [] = Nothing fromListAlg f ((_, v):xs) = Just (foldr (f () . snd) v xs) fromAscListAlg = fromListAlg+ fromDistAscListAlg = fmap snd . listToMaybe getMinAlg = fmap g where g v = (((), v), Nothing) getMaxAlg = fmap g where@@ -357,8 +370,12 @@ isSubmapAlg _ Nothing _ = True isSubmapAlg _ _ Nothing = False isSubmapAlg (<=) (Just x) (Just y) = x <= y- splitLookupAlg f _ (Just v) = f v- splitLookupAlg _ _ _ = (Nothing, Nothing, Nothing)+ splitLookupAlg f _ = maybe (Nothing, Nothing, Nothing) f first :: (a -> c) -> (a, b) -> (c, b) first f (x, y) = (f x, y)++{-# RULES+ "sizeAlg/Map/Elem" forall (m :: Map k (Elem v)) . sizeAlg m = Map.size m;+ "sizeAlg/IMap/Elem" forall (m :: IntMap (Elem v)) . sizeAlg m = IMap.size m;+ #-}