summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLouisWasserman <>2009-09-07 20:59:52 (GMT)
committerLuite Stegeman <luite@luite.com>2009-09-07 20:59:52 (GMT)
commit3418bbd3d64591c612c7a437b1f51584a97ab455 (patch)
tree2b35e408a28a4d7282deec955b64ccdab35caf8b
parent07d2b1d779a0c9bca6b17f14172ade18c3c6bded (diff)
version 0.0.1.20.0.1.2
-rw-r--r--TrieMap.cabal4
-rw-r--r--TrieMap.hs271
-rw-r--r--TrieMap/Algebraic.hs405
-rw-r--r--TrieMap/Applicative.hs6
-rw-r--r--TrieMap/MapTypes.hs150
-rw-r--r--TrieMap/RadixTrie.hs495
-rw-r--r--TrieMap/Reflection.hs44
-rw-r--r--TrieMap/TrieAlgebraic.hs837
8 files changed, 1554 insertions, 658 deletions
diff --git a/TrieMap.cabal b/TrieMap.cabal
index 5312deb..ab56554 100644
--- a/TrieMap.cabal
+++ b/TrieMap.cabal
@@ -1,5 +1,5 @@
name: TrieMap
-version: 0.0.1.1
+version: 0.0.1.2
license: BSD3
license-file: LICENSE
maintainer: wasserman.louis@gmail.com
@@ -21,7 +21,7 @@ description: Generalized trie implementation that automatically infers map types
build-type: Simple
build-depends:
- base >= 4 && <= 5, containers == 0.2.0.1
+ base >= 4 && <= 5, containers == 0.2.0.1, bytestring
exposed-modules:
TrieMap
TrieMap.Algebraic
diff --git a/TrieMap.hs b/TrieMap.hs
index 474555e..db36022 100644
--- a/TrieMap.hs
+++ b/TrieMap.hs
@@ -1,10 +1,10 @@
-{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
+{-# LANGUAGE TypeOperators, UndecidableInstances, FlexibleContexts, TypeFamilies #-}
-- | We will use the following terminology:
--
-- An /algebraic/ type is a type isomorphic to an algebraic type, as defined in the package description. This isomorphism is
--- declared via the type class 'Algebraic', where @'Alg' k@ is algebraic. It is assumed for purposes of ordering that
--- this isomorphism is order- and equality-preserving. We also require that if @k@ is algebraic, @'Alg' k ~ k@.
+-- declared via the type class 'Algebraic', where @'AlgRep' k@ is algebraic. It is assumed for purposes of ordering that
+-- this isomorphism is order- and equality-preserving. We also require that if @k@ is algebraic, @'AlgRep' k ~ k@.
--
-- These methods will automatically infer the correct type of a 'TrieMap' on any given argument. For example,
--
@@ -12,23 +12,23 @@
--
-- returns a variable of type
--
--- @'TrieMap' ('String', 'Double', 'Bool') ('RadixTrie' 'Int' 'Data.IntMap.IntMap' \``ProdMap`\` 'UnionMap' 'Maybe' ('Data.Map.Map' 'Double') \``ProdMap`\` 'UnionMap' 'Maybe' 'Maybe') 'String'@
+-- @'TrieMap' ('String', 'Double', 'Bool') ('ProdMap' ('ConstMap' ('RadixTrie' 'Int' 'IntMap')) ('ProdMap' ('ConstMap' ('UnionMap' ('ConstMap' 'Maybe') 'IdMap' ('Ordered' 'Double') ('Map' 'Double'))) 'IdMap') (('Const' () :+: 'Id') '()') ('UnionMap' ('ConstMap' 'Maybe') 'IdMap' () 'Maybe')) 'String'@
--
-- The inference was done entirely automatically. Note also:
--
--- * @'Alg' 'Char' ~ 'Int'@: the 'Algebraic' instance for 'Char' maps characters to their ASCII representations, so an 'IntMap' can be used.
+-- * @'AlgRep' 'Char' ~ 'Int'@: the 'Algebraic' instance for 'Char' maps characters to their ASCII representations, so an 'IntMap' can be used.
--
--- * @'Alg' ('Maybe' a) ~ 'Either' () ('Alg' a)@; a 'TrieMap' on a 'Maybe' key type simply gets a space for one extra (possible) value.
+-- * @'AlgRep' ('Maybe' a) ~ 'Either' () ('AlgRep' a)@; a 'TrieMap' on a 'Maybe' key type simply gets a space for one extra (possible) value.
--
--- * @'Alg' 'Double' ~ 'Ordered' 'Double'@; the 'Algebraic' instance for 'Double' tells "TrieMap" to just use a regular 'Data.Map.Map'
+-- * @'AlgRep' 'Double' ~ 'Ordered' 'Double'@; the 'Algebraic' instance for 'Double' tells "TrieMap" to just use a regular 'Data.Map.Map'
-- and the default ordering for 'Double's.
--
--- * @'Alg' 'Bool' ~ 'Either' () ()@, so a 'TrieMap' on a 'Bool' takes the form of -- essentially -- a pair of 'Maybe's.
+-- * @'AlgRep' 'Bool' ~ 'Either' () ()@, so a 'TrieMap' on a 'Bool' takes the form of -- essentially -- a pair of 'Maybe's.
--
--- * @'Alg' (a, b, c) ~ ('Alg' a, ('Alg' b, 'Alg' c))@, so tuple types get handled by a sequence of map products.
+-- * @'AlgRep' (a, b, c) ~ ('AlgRep' a, ('AlgRep' b, 'AlgRep' c))@, so tuple types get handled by a sequence of map products.
--
-- (If you plan to use these maps in type arguments, it is strongly suggested that you either reproduce the context
--- @('Algebraic' k, 'TrieKey' ('Alg' k) m) => TrieMap k m a@, or you create a type alias!)
+-- @('Algebraic' k, 'TrieKey' ('AlgRep' k) m) => TrieMap k m a@, or you create a type alias!)
--
-- The following is a general attempt to describe the runtime of operations supported by 'TrieMap's.
@@ -46,10 +46,13 @@
module TrieMap (
-- * Map type
TrieMap,
- TrieKey,
Algebraic (..),
+ AlgebraicT (..),
+ TrieKey,
+ TrieKeyT,
+ EqT,
-- * Map instances
- ProdMap, UnionMap, RadixTrie,
+ ProdMap, (:*:)(..), CProdMap, UnionMap, (:+:)(..), CUnionMap, RadixTrie, ConstMap, Const(..), IdMap, Id(..), CompMap, O, o, unO, FixMap, Fix(..),
-- * Operators
(!),
(\\),
@@ -101,8 +104,7 @@ module TrieMap (
-- ** Map
map,
mapWithKey,
- mapApp,
- mapAppWithKey,
+ traverseWithKey,
mapMaybe,
mapMaybeWithKey,
mapEither,
@@ -153,6 +155,7 @@ module TrieMap (
maxView,
minViewWithKey,
maxViewWithKey) where
+-- module TrieMap where
import Control.Monad
import Data.Monoid
@@ -163,7 +166,7 @@ import TrieMap.Algebraic
import TrieMap.TrieAlgebraic
import TrieMap.RadixTrie
import TrieMap.Reflection
-import Control.Applicative hiding (Alternative(..))
+import Control.Applicative hiding (Alternative(..), Const)
import Data.Maybe hiding (mapMaybe)
import Data.Map (Map)
import Data.IntMap (IntMap)
@@ -178,63 +181,83 @@ 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 (Elem a)}
-instance (Eq k, Eq a, Algebraic k, TrieKey (Alg k) m) => Eq (TrieMap k m a) where
+instance (Eq k, Eq a, Algebraic k, TrieKey (AlgRep k) m) => Eq (TrieMap k m a) where
(==) = (==) `on` assocs
-instance (Ord k, Ord a, Algebraic k, TrieKey (Alg k) m) => Ord (TrieMap k m a) where
+instance (Ord k, Ord a, Algebraic k, TrieKey (AlgRep k) m) => Ord (TrieMap k m a) where
compare = compare `on` assocs
-instance (Show k, Show a, Algebraic k, TrieKey (Alg k) m) => Show (TrieMap k m a) where
+instance (Show k, Show a, Algebraic k, TrieKey (AlgRep k) m) => Show (TrieMap k m a) where
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) = ([(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 (Algebraic k, Algebraic a, TrieKey (AlgRep k) m) => Algebraic (TrieMap k m a) where
+-- type AlgRep (TrieMap k m a) = ([(AlgRep k, AlgRep 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 SAlgebraicT m => AlgebraicT (TrieMap k m) where
+ type AlgRepT (TrieMap k m) = SAlgRepT m :*: Const Int
+ toAlgT (TrieMap n m) = fmap getElem (toSAlgT m) :*: Const n
+ fromAlgT (m :*: Const n) = TrieMap n (fromSAlgT (fmap Elem m))
+
+instance Algebraic (m (Elem a)) => Algebraic (TrieMap k m a) where
+ type AlgRep (TrieMap k m a) = AlgRep (m (Elem a), Int)
+ toAlg (TrieMap n m) = toAlg (m, n)
+ fromAlg = uncurry (flip TrieMap) . fromAlg
+{-
+instance (Algebraic (AlgRep k), Algebraic k, TrieKey (AlgRep k) m) => AlgebraicT (TrieMap k m) where
+ type AlgRepT (TrieMap k m) = AlgRepT ([] `O` ((,) (AlgRep k)))
+ toAlgT (TrieMap _ m) = toAlgT (o (fmap (fmap getElem) (assocsAlg m)))
+ fromAlgT = mkTrieMap . fromDistAscListAlg . fmap (fmap Elem) . unO . fromAlgT
-instance Functor m => Functor (TrieMap k m) where
- fmap f (TrieMap n m) = TrieMap n (fmap (fmap f) m)
+instance (Algebraic (AlgRep k), Algebraic k, TrieKey (AlgRep k) m, Algebraic a) => Algebraic (TrieMap k m a) where
+ type AlgRep (TrieMap k m a) = AlgRep (AlgWrap (TrieMap k m) a)
+ toAlg = toAlg . AlgWrap
+ fromAlg = unAlgWrap . fromAlg-}
-instance Foldable m => Foldable (TrieMap k m) where
- 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 (traverse f) m
+instance TrieKey k' m => Functor (TrieMap k m) where
+ fmap = fmapDefault
-instance (Algebraic k, TrieKey (Alg k) m) => Monoid (TrieMap k m a) where
+instance TrieKey k' m => Foldable (TrieMap k m) where
+ foldr f z = foldWithKeyAlg (\ _ (Elem x) z -> f x z) z . trieMap
+
+instance TrieKey k' m => Traversable (TrieMap k m) where
+ traverse f (TrieMap n m) = TrieMap n <$> mapAppAlg (\ _ (Elem v) -> Elem <$> f v) m
+
+instance (Algebraic k, TrieKey (AlgRep k) m) => Monoid (TrieMap k m a) where
mempty = empty
mappend = union
+ mconcat = unions
-mkTrieMap :: (Algebraic k, TrieKey (Alg k) m) => m (Elem a) -> TrieMap k m a
+mkTrieMap :: (Algebraic k, TrieKey (AlgRep k) m) => m (Elem a) -> TrieMap k m a
mkTrieMap m = TrieMap (sizeAlg m) m
-- | Lookup the value of a key in the map.
--
-- 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 :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> Maybe a
lookup k = fmap getElem . lookupAlg (toAlg k) . trieMap
-- | Is the key a member of the map? See also 'notMember'.
--
-- > member 5 (fromList [(5,'a'), (3,'b')]) == True
-- > member 1 (fromList [(5,'a'), (3,'b')]) == False
-member :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> Bool
+member :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> Bool
member = isJust .: lookup
-- | Is the key not a member of the map? See also 'member'.
--
-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False
-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True
-notMember :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> Bool
+notMember :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> Bool
notMember = not .: member
-- | Find the value at a key.
-- Calls 'error' when the element can not be found.
-find :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> a
+find :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> a
find = findWithDefault $ error "TrieMap.find: element not in the map"
-- | The expression @('findWithDefault' def k map)@ returns
@@ -243,13 +266,13 @@ find = findWithDefault $ error "TrieMap.find: element not in the map"
--
-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'
-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'
-findWithDefault :: (Algebraic k, TrieKey (Alg k) m) => a -> k -> TrieMap k m a -> a
+findWithDefault :: (Algebraic k, TrieKey (AlgRep k) m) => a -> k -> TrieMap k m a -> a
findWithDefault v = fromMaybe v .: lookup
-- | /O(1)/. A map with a single element.
--
-- > singleton 1 'a' == fromList [(1, 'a')]
-singleton :: (Algebraic k, TrieKey (Alg k) m) => k -> a -> TrieMap k m a
+singleton :: (Algebraic k, TrieKey (AlgRep k) m) => k -> a -> TrieMap k m a
singleton k v = TrieMap 1 (insertAlg (toAlg k) (Elem v) emptyAlg)
-- | Find the value at a key.
@@ -257,18 +280,18 @@ singleton k v = TrieMap 1 (insertAlg (toAlg k) (Elem v) emptyAlg)
--
-- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map
-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'
-(!) :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> k -> a
+(!) :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> k -> a
m ! k = fromMaybe (error "element not in the map") (lookup k m)
-empty :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a
+empty :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a
empty = TrieMap 0 emptyAlg
-- | Check if the specified map is empty.
-null :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Bool
+null :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Bool
null = nullAlg . trieMap
-- | Returns the size of the specified map.
-size :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Int
+size :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Int
size = sizeMap
-- | Build a map from a list of key\/value pairs. See also 'fromAscList'.
@@ -278,14 +301,14 @@ size = sizeMap
-- > fromList [] == empty
-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
-fromList :: (Algebraic k, TrieKey (Alg k) m) => [(k, a)] -> TrieMap k m a
+fromList :: (Algebraic k, TrieKey (AlgRep k) m) => [(k, a)] -> TrieMap k m a
fromList = fromListWith const
-- | Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
--
-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]
-- > fromListWith (++) [] == empty
-fromListWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> a -> a) -> [(k, a)] -> TrieMap k m a
+fromListWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> [(k, a)] -> TrieMap k m a
fromListWith = fromListWithKey . const
-- | Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
@@ -293,7 +316,7 @@ fromListWith = fromListWithKey . const
-- > let f k a1 a2 = (show k) ++ a1 ++ a2
-- > 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 :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> [(k, a)] -> TrieMap k m a
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.
@@ -301,14 +324,14 @@ fromListWithKey f xs = mkTrieMap $ fromListAlg (\ k (Elem v1) (Elem v2) -> Elem
--
-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
-fromAscList :: (Algebraic k, TrieKey (Alg k) m) => [(k, a)] -> TrieMap k m a
+fromAscList :: (Algebraic k, TrieKey (AlgRep k) m) => [(k, a)] -> TrieMap k m a
fromAscList = fromAscListWith const
-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
-- /The precondition (input list is ascending) is not checked./
--
-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
-fromAscListWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> a -> a) -> [(k, a)] -> TrieMap k m a
+fromAscListWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> [(k, a)] -> TrieMap k m a
fromAscListWith = fromAscListWithKey . const
-- | /O(n)/. Build a map from an ascending list in linear time with a
@@ -317,7 +340,7 @@ fromAscListWith = fromAscListWithKey . const
--
-- > 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 :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> [(k, a)] -> TrieMap k m a
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)
@@ -325,7 +348,7 @@ fromAscListWithKey f xs = mkTrieMap $ fromAscListAlg g [(toAlg k, Elem v) | (k,
-- /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 :: (Algebraic k, TrieKey (AlgRep k) m) => [(k, a)] -> TrieMap k m a
fromDistinctAscList xs = TrieMap (length xs) $ fromDistAscListAlg [(toAlg k, Elem v) | (k, v) <- xs]
-- | Insert a new key and value in the map.
@@ -336,7 +359,7 @@ fromDistinctAscList xs = TrieMap (length xs) $ fromDistAscListAlg [(toAlg k, Ele
-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]
-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]
-- > insert 5 'x' empty == singleton 5 'x'
-insert :: (Algebraic k, TrieKey (Alg k) m) => k -> a -> TrieMap k m a -> TrieMap k m a
+insert :: (Algebraic k, TrieKey (AlgRep k) m) => k -> a -> TrieMap k m a -> TrieMap k m a
insert = insertWith const
-- | Insert with a function, combining new value and old value.
@@ -348,7 +371,7 @@ insert = insertWith const
-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]
-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
-- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"
-insertWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> a -> a) -> k -> a -> TrieMap k m a -> TrieMap k m a
+insertWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> k -> a -> TrieMap k m a -> TrieMap k m a
insertWith = insertWithKey . const
-- | Insert with a function, combining key, new value and old value.
@@ -362,14 +385,14 @@ insertWith = insertWithKey . const
-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]
-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"
-insertWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> k -> a -> TrieMap k m a -> TrieMap k m a
+insertWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> k -> a -> TrieMap k m a -> TrieMap k m a
insertWithKey f k = snd .: insertLookupWithKey f k
-- | Combines insert operation with old value retrieval.
-- The expression (@'insertLookupWithKey' f k x map@)
-- 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 :: (Algebraic k, TrieKey (AlgRep 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 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')
@@ -382,7 +405,7 @@ insertLookupWithKey f k v (TrieMap n m) = case alterLookupAlg g (toAlg k) m of
-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-update :: (Algebraic k, TrieKey (Alg k) m) => (a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
+update :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
update = updateWithKey . const
-- | The expression (@'updateWithKey' f k map@) updates the
@@ -394,7 +417,7 @@ update = updateWithKey . const
-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-updateWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
+updateWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
updateWithKey f = snd .: updateLookupWithKey f
-- | Lookup and update. See also 'updateWithKey'.
@@ -405,7 +428,7 @@ updateWithKey f = snd .: updateLookupWithKey f
-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])
-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])
-- > 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 :: (Algebraic k, TrieKey (AlgRep 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 g (toAlg k) m of
((del, res), m') -> (res, TrieMap (if del then n - 1 else n) m')
@@ -419,7 +442,7 @@ updateLookupWithKey f k (TrieMap n m) =
-- > delete 5 empty == empty
--
-- 'delete' is equivalent to @'alter' ('const' 'Nothing')@.
-delete :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> TrieMap k m a
+delete :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> TrieMap k m a
delete = alter (const Nothing)
-- | The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
@@ -433,14 +456,14 @@ delete = alter (const Nothing)
-- > let f _ = Just "c"
-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]
-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]
-alter :: (Algebraic k, TrieKey (Alg k) m) => (Maybe a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
+alter :: (Algebraic k, TrieKey (AlgRep k) m) => (Maybe a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
alter f k = snd . alterLookup f k
-- | The expression (@'alterLookup' f k map@) alters the value @x@ at @k@, or absence thereof, and returns the old value.
-- 'alterLookup' can be used to insert, delete, or update a value in a 'Map'.
--
-- In short : @alterLookup f k m = (lookup k m, alter f k m)@.
-alterLookup :: (Algebraic k, TrieKey (Alg k) m) => (Maybe a -> Maybe a) -> k -> TrieMap k m a -> (Maybe a, TrieMap k m a)
+alterLookup :: (Algebraic k, TrieKey (AlgRep 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 Nothing = let fv = f Nothing in ((Nothing, just1 fv), fmap Elem fv)
@@ -451,36 +474,32 @@ alterLookup f k (TrieMap n m) = case alterLookupAlg g (toAlg k) m of
--
-- > let f key x = (show key) ++ ":" ++ x
-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
-mapWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> b) -> TrieMap k m a -> TrieMap k m b
-mapWithKey f = unId . mapAppWithKey (Id .: f)
+mapWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> b) -> TrieMap k m a -> TrieMap k m b
+mapWithKey f = unId . traverseWithKey (Id .: f)
-- | /O(n)/. Map a function over all values in the map.
--
-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
-map :: (Algebraic k, TrieKey (Alg k) m) => (a -> b) -> TrieMap k m a -> TrieMap k m b
-map = fmap
+map :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> b) -> TrieMap k m a -> TrieMap k m b
+map = mapWithKey . const
-- | 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) =>
+traverseWithKey :: (Algebraic k, TrieKey (AlgRep 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 (\ 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)
-mapApp = traverse
+traverseWithKey f (TrieMap n m) = TrieMap n <$> mapAppAlg (\ k (Elem v) -> Elem <$> f (fromAlg k) v) m
-- | /O(n)/. Map keys\/values and collect the 'Just' results.
--
-- > 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 :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Maybe b) -> TrieMap k m a -> TrieMap k m b
mapMaybeWithKey f = mkTrieMap . mapMaybeAlg (\ k (Elem v) -> Elem <$> f (fromAlg k) v) . trieMap
-- | /O(n)/. Map values and collect the 'Just' results.
--
-- > let f x = if x == "a" then Just "new a" else Nothing
-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"
-mapMaybe :: (Algebraic k, TrieKey (Alg k) m) => (a -> Maybe b) -> TrieMap k m a -> TrieMap k m b
+mapMaybe :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Maybe b) -> TrieMap k m a -> TrieMap k m b
mapMaybe = mapMaybeWithKey . const
-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
@@ -491,7 +510,7 @@ mapMaybe = mapMaybeWithKey . const
-- >
-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
-mapEither :: (Algebraic k, TrieKey (Alg k) m) => (a -> Either b c) -> TrieMap k m a -> (TrieMap k m b, TrieMap k m c)
+mapEither :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Either b c) -> TrieMap k m a -> (TrieMap k m b, TrieMap k m c)
mapEither = mapEitherWithKey . const
-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
@@ -502,9 +521,11 @@ mapEither = mapEitherWithKey . const
-- >
-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
-- > == (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 :: (Algebraic k, TrieKey (AlgRep 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 (\ k (Elem v) -> either (Left . Elem) (Right . Elem) (f (fromAlg k) v)) m
+ where (mL, mR) = mapEitherAlg (\ k (Elem v) ->
+ either (\ k -> (Just (Elem k), Nothing)) (\ k -> (Nothing, Just (Elem k))) (f (fromAlg k) v))
+ m
-- |
-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
@@ -516,7 +537,7 @@ mapEitherWithKey f (TrieMap _ m) = (mkTrieMap mL, mkTrieMap mR)
-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")]
-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"
-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"
-mapKeys :: (Algebraic k1, Algebraic k2, TrieKey (Alg k1) m1, TrieKey (Alg k2) m2) =>
+mapKeys :: (Algebraic k1, Algebraic k2, TrieKey (AlgRep k1) m1, TrieKey (AlgRep k2) m2) =>
(k1 -> k2) -> TrieMap k1 m1 a -> TrieMap k2 m2 a
mapKeys = mapKeysWith const
@@ -529,7 +550,7 @@ mapKeys = mapKeysWith const
--
-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"
-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"
-mapKeysWith :: (Algebraic k1, Algebraic k2, TrieKey (Alg k1) m1, TrieKey (Alg k2) m2) =>
+mapKeysWith :: (Algebraic k1, Algebraic k2, TrieKey (AlgRep k1) m1, TrieKey (AlgRep k2) m2) =>
(a -> a -> a) -> (k1 -> k2) -> TrieMap k1 m1 a -> TrieMap k2 m2 a
mapKeysWith f g m = fromListWith f [(g k, v) | (k, v) <- assocs m]
@@ -550,14 +571,14 @@ mapKeysWith f g m = fromListWith f [(g k, v) | (k, v) <- assocs m]
-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]
-- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True
-- > valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) == False
-mapKeysMonotonic :: (Algebraic k1, Algebraic k2, TrieKey (Alg k1) m1, TrieKey (Alg k2) m2) =>
+mapKeysMonotonic :: (Algebraic k1, Algebraic k2, TrieKey (AlgRep k1) m1, TrieKey (AlgRep k2) m2) =>
(k1 -> k2) -> TrieMap k1 m1 a -> TrieMap k2 m2 a
mapKeysMonotonic f (TrieMap n m) = TrieMap n $ fromDistAscListAlg [(toAlg (f (fromAlg k)), v) | (k, v) <- assocsAlg m]
-- | /O(n)/. Filter all keys\/values that satisfy the predicate.
--
-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-filterWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Bool) -> TrieMap k m a -> TrieMap k m a
+filterWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Bool) -> TrieMap k m a -> TrieMap k m a
filterWithKey p = mapMaybeWithKey (\ k v -> if p k v then Just v else Nothing)
-- | /O(n)/. Filter all values that satisfy the predicate.
@@ -565,7 +586,7 @@ filterWithKey p = mapMaybeWithKey (\ k v -> if p k v then Just v else Nothing)
-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty
-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty
-filter :: (Algebraic k, TrieKey (Alg k) m) => (a -> Bool) -> TrieMap k m a -> TrieMap k m a
+filter :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Bool) -> TrieMap k m a -> TrieMap k m a
filter = filterWithKey . const
-- | /O(n)/. Partition the map according to a predicate. The first
@@ -575,7 +596,7 @@ filter = filterWithKey . const
-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
-partition :: (Algebraic k, TrieKey (Alg k) m) => (a -> Bool) -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
+partition :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Bool) -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
partition = partitionWithKey . const
-- | /O(n)/. Partition the map according to a predicate. The first
@@ -585,7 +606,7 @@ partition = partitionWithKey . const
-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")
-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
-partitionWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Bool) -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
+partitionWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Bool) -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
partitionWithKey p = mapEitherWithKey (\ k v -> (if p k v then Left else Right) v)
{-# INLINE assocs #-}
@@ -593,14 +614,14 @@ partitionWithKey p = mapEitherWithKey (\ k v -> (if p k v then Left else Right)
--
-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
-- > assocs empty == []
-assocs :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> [(k, a)]
+assocs :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> [(k, a)]
assocs m = build (\ c n -> foldWithKey (curry c) n m)
-- | /O(n)/. Return all keys of the map in ascending order.
--
-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]
-- > keys empty == []
-keys :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> [k]
+keys :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> [k]
keys m = Prelude.map fst (assocs m)
-- | /O(n)/.
@@ -608,7 +629,7 @@ keys m = Prelude.map fst (assocs m)
--
-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]
-- > elems empty == []
-elems :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> [a]
+elems :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> [a]
elems = toList
-- | /O(n)/. Fold the values in the map, such that
@@ -630,11 +651,11 @@ fold = foldr
--
-- > 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 :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> b -> b) -> b -> TrieMap k m a -> b
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 :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
unionMaybeWithKey f = mkTrieMap .: unionMaybeAlg (\ k (Elem v1) (Elem v2) -> Elem <$> f (fromAlg k) v1 v2) `on` trieMap
-- | /O(n+m)/.
@@ -642,17 +663,17 @@ unionMaybeWithKey f = mkTrieMap .: unionMaybeAlg (\ k (Elem v1) (Elem v2) -> Ele
--
-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value
-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
-unionWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
+unionWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
unionWithKey f = unionMaybeWithKey (\ k x y -> Just (f k x y))
-- | /O(n+m)/. Union with a combining function.
--
-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]
-unionWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> a -> a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
+unionWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
unionWith = unionWithKey . const
-- | /O(n+m)/. Union with a combining function that may discard some elements.
-unionMaybeWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
+unionMaybeWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
unionMaybeWith = unionMaybeWithKey . const
-- | /O(n+m)/.
@@ -661,25 +682,25 @@ unionMaybeWith = unionMaybeWithKey . const
-- i.e. (@'union' == 'unionWith' 'const'@).
--
-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]
-union :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> TrieMap k m a -> TrieMap k m a
+union :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m a -> TrieMap k m a
union = unionWith const
-unions :: (Algebraic k, TrieKey (Alg k) m) => [TrieMap k m a] -> TrieMap k m a
+unions :: (Algebraic k, TrieKey (AlgRep k) m) => [TrieMap k m a] -> TrieMap k m a
unions = unionsWith const
-unionsWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> a -> a) -> [TrieMap k m a] -> TrieMap k m a
+unionsWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> [TrieMap k m a] -> TrieMap k m a
unionsWith = unionsWithKey . const
-unionsWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> [TrieMap k m a] -> TrieMap k m a
+unionsWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> [TrieMap k m a] -> TrieMap k m a
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)@.
-symDifference :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> TrieMap k m a -> TrieMap k m a
+symDifference :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m a -> TrieMap k m a
symDifference = unionMaybeWith (\ _ _ -> Nothing)
-- | /O(n+m)/. Intersection of two maps with a combining function that may discard some elements.
-intersectionMaybeWithKey :: (Algebraic k, TrieKey (Alg k) m) =>
+intersectionMaybeWithKey :: (Algebraic k, TrieKey (AlgRep 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 (\ k (Elem a) (Elem b) -> Elem <$> f (fromAlg k) a b) m1 m2
@@ -688,17 +709,17 @@ intersectionMaybeWithKey f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $
--
-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar
-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"
-intersectionWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> b -> c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
+intersectionWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> b -> c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
intersectionWithKey f = intersectionMaybeWithKey (\ k x y -> Just (f k x y))
-- | /O(n+m)/. Intersection with a combining function.
--
-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
-intersectionWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> b -> c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
+intersectionWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> b -> c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
intersectionWith f = intersectionMaybeWith (Just .: f)
-- | /O(n+m)/. Intersection of two maps with a combining function that may discard some elements.
-intersectionMaybeWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> b -> Maybe c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
+intersectionMaybeWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> b -> Maybe c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
intersectionMaybeWith = intersectionMaybeWithKey . const
-- | /O(n+m)/. Intersection of two maps.
@@ -706,7 +727,7 @@ intersectionMaybeWith = intersectionMaybeWithKey . const
-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
--
-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"
-intersection :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
+intersection :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
intersection = intersectionWith const
-- | /O(n+m)/. Difference with a combining function. When two equal keys are
@@ -717,7 +738,7 @@ intersection = intersectionWith const
-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing
-- > 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 :: (Algebraic k, TrieKey (AlgRep 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 (\ k (Elem x) (Elem y) -> Elem <$> f (fromAlg k) x y) m1 m2
@@ -730,67 +751,67 @@ differenceWithKey f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $
-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing
-- > 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 :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> b -> Maybe a) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m a
differenceWith = differenceWithKey . const
-- | /O(n+m)/. Difference of two maps.
-- Return elements of the first map not existing in the second map.
--
-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"
-difference :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
+difference :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
difference = differenceWith (\ _ _ -> Nothing)
-- | Same as 'difference'.
-(\\) :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
+(\\) :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
(\\) = difference
-- | The minimal key of the map. Calls 'error' if the map is empty.
--
-- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")
-- > findMin empty Error: empty map has no minimal element
-findMin :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> (k, a)
+findMin :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> (k, a)
findMin = fromMaybe (error "empty map has no minimal element") . getMin
-- | The minimal key of the map, if any. Returns 'Nothing' if the map is empty.
--
-- > getMin (fromList [(5,"a"), (3,"b")]) == Just (3,"b")
-- > getMin empty == Nothing
-getMin :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe (k, a)
+getMin :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe (k, a)
getMin = fst <.> minViewWithKey
-- | The maximal key of the map. Calls 'error' is the map is empty.
--
-- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")
-- > findMax empty Error: empty map has no maximal element
-findMax :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> (k, a)
+findMax :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> (k, a)
findMax = fromMaybe (error "empty map has no maximal element") . getMax
-- | The maximal key of the map, if any. Returns 'Nothing' if the map is empty.
--
-- > getMax (fromList [(5,"a"), (3,"b")]) == Just (5,"a")
-- > getMax empty == Nothing
-getMax :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe (k, a)
+getMax :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe (k, a)
getMax = fst <.> maxViewWithKey
-- | Delete the minimal key. Returns an empty map if the map is empty.
--
-- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]
-- > deleteMin empty == empty
-deleteMin :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> TrieMap k m a
+deleteMin :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m a
deleteMin m0@(TrieMap n m) = maybe m0 (TrieMap (n-1) . snd) $ getMinAlg m
-- | Delete the maximal key. Returns an empty map if the map is empty.
--
-- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]
-- > deleteMax empty == empty
-deleteMax :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> TrieMap k m a
+deleteMax :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m a
deleteMax m0@(TrieMap n m) = maybe m0 (TrieMap (n-1) . snd) $ getMaxAlg m
-- | Delete and find the minimal element.
--
-- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")])
-- > deleteFindMin Error: can not return the minimal element of an empty map
-deleteFindMin :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> ((k, a), TrieMap k m a)
+deleteFindMin :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> ((k, a), TrieMap k m a)
deleteFindMin = fromMaybe (error "cannot return the minimal element of an empty map") . minViewWithKey
checkNothing :: Maybe a -> (Bool, Maybe a)
@@ -800,14 +821,14 @@ checkNothing x = (isNothing x, x)
--
-- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])
-- > deleteFindMax empty Error: can not return the maximal element of an empty map
-deleteFindMax :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> ((k, a), TrieMap k m a)
+deleteFindMax :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> ((k, a), TrieMap k m a)
deleteFindMax = fromMaybe (error "cannot return the maximal element of an empty map") . maxViewWithKey
-- | Update the value at the minimal key.
--
-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]
-- > 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 :: (Algebraic k, TrieKey (AlgRep 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 . g)) m
g (Elem x) = Elem <$> f x
@@ -816,7 +837,7 @@ updateMin f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
--
-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]
-- > 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 :: (Algebraic k, TrieKey (AlgRep 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 . g)) m
g (Elem x) = Elem <$> f x
@@ -825,7 +846,7 @@ updateMax f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
--
-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]
-- > 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 :: (Algebraic k, TrieKey (AlgRep 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 .: g) m
g k (Elem v) = Elem <$> f (fromAlg k) v
@@ -834,7 +855,7 @@ updateMinWithKey f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
--
-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]
-- > 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 :: (Algebraic k, TrieKey (AlgRep 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 .: g) m
g k (Elem v) = Elem <$> f (fromAlg k) v
@@ -845,7 +866,7 @@ updateMaxWithKey f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
--
-- > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")
-- > minView empty == Nothing
-minView :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe (a, TrieMap k m a)
+minView :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe (a, TrieMap k m a)
minView (TrieMap n m) = do
(~(_, Elem v), m') <- getMinAlg m
return (v, TrieMap (n-1) m')
@@ -855,7 +876,7 @@ minView (TrieMap n m) = do
--
-- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")
-- > maxView empty == Nothing
-maxView :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe (a, TrieMap k m a)
+maxView :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe (a, TrieMap k m a)
maxView (TrieMap n m) = do
(~(_, Elem v), m') <- getMaxAlg m
return (v, TrieMap (n-1) m')
@@ -865,7 +886,7 @@ maxView (TrieMap n m) = do
--
-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")
-- > minViewWithKey empty == Nothing
-minViewWithKey :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe ((k, a), TrieMap k m a)
+minViewWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe ((k, a), TrieMap k m a)
minViewWithKey (TrieMap n m) = do
(~(k, Elem v), m') <- getMinAlg m
return ((fromAlg k, v), TrieMap (n-1) m')
@@ -875,7 +896,7 @@ minViewWithKey (TrieMap n m) = do
--
-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")
-- > maxViewWithKey empty == Nothing
-maxViewWithKey :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe ((k, a), TrieMap k m a)
+maxViewWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe ((k, a), TrieMap k m a)
maxViewWithKey (TrieMap n m) = do
~(~(k, Elem v), m') <- getMaxAlg m
return ((fromAlg k, v), TrieMap (n-1) m')
@@ -883,7 +904,7 @@ maxViewWithKey (TrieMap n m) = do
-- | /O(n+m)/.
-- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
--
-isSubmapOf :: (Algebraic k, TrieKey (Alg k) m, Eq a) => TrieMap k m a -> TrieMap k m a -> Bool
+isSubmapOf :: (Algebraic k, TrieKey (AlgRep k) m, Eq a) => TrieMap k m a -> TrieMap k m a -> Bool
isSubmapOf = isSubmapOfBy (==)
{- | /O(n+m)/.
@@ -903,7 +924,7 @@ isSubmapOf = isSubmapOfBy (==)
> isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
-}
-isSubmapOfBy :: (Algebraic k, TrieKey (Alg k) m) => (a -> b -> Bool) -> TrieMap k m a -> TrieMap k m b -> Bool
+isSubmapOfBy :: (Algebraic k, TrieKey (AlgRep 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
where Elem x <<= Elem y = x <= y
@@ -916,7 +937,7 @@ isSubmapOfBy (<=) (TrieMap n1 m1) (TrieMap n2 m2) = (Prelude.<=) n1 n2 && isSubm
-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)
-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)
-split :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
+split :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
split k m = case splitLookup k m of
(mL, _, mR) -> (mL, mR)
@@ -928,8 +949,6 @@ split k m = case splitLookup k m of
-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")
-- > 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 :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> (TrieMap k m a, Maybe a, TrieMap k m a)
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. \ No newline at end of file
+ (mL, v, mR) -> (mkTrieMap mL, v, mkTrieMap mR) \ No newline at end of file
diff --git a/TrieMap/Algebraic.hs b/TrieMap/Algebraic.hs
index 10b23ee..7f0095b 100644
--- a/TrieMap/Algebraic.hs
+++ b/TrieMap/Algebraic.hs
@@ -1,9 +1,14 @@
-{-# LANGUAGE UndecidableInstances, TypeFamilies, TypeSynonymInstances #-}
+{-# LANGUAGE TypeOperators, FlexibleContexts, UndecidableInstances, TypeFamilies, TypeSynonymInstances #-}
-module TrieMap.Algebraic (Algebraic(..), Ordered(..)) where
+module TrieMap.Algebraic (Algebraic(..), AlgebraicT(..), SAlgebraicT(..), Ordered(..), AlgWrap (..)) where
+import Control.Arrow
+import Data.Bits
+import Data.ByteString (ByteString, pack, unpack)
import Data.Char
import Data.Maybe
+import Data.List (unfoldr)
+import Data.Word
import Data.IntSet (IntSet)
import Data.Set(Set)
import qualified Data.IntSet as ISet
@@ -16,107 +21,397 @@ import qualified Data.Foldable as Fold
import GHC.Exts (build)
import TrieMap.TrieAlgebraic
+import TrieMap.MapTypes
+
+newtype AlgWrap t a = AlgWrap {unAlgWrap :: t a}
-- | 'Algebraic' refers to a type with an algebraic representation, armed with methods to convert in each direction.
-- 'toAlg' and 'fromAlg' should preserve equality and ordering.
class Algebraic k where
- -- | @'Alg' k@ is a fully decomposed representation of k into algebraic pieces.
- type Alg k
- toAlg :: k -> Alg k
- fromAlg :: Alg k -> k
+ -- | @'AlgRep' k@ is a fully decomposed representation of k into algebraic pieces.
+ type AlgRep k
+ toAlg :: k -> AlgRep k
+ fromAlg :: AlgRep k -> k
+
+class Functor (AlgRepT t) => AlgebraicT t where
+ type AlgRepT t :: * -> *
+ toAlgT :: t a -> AlgRepT t a
+ fromAlgT :: AlgRepT t a -> t a
+
+class Functor (SAlgRepT t) => SAlgebraicT t where
+ type SAlgRepT t :: * -> *
+ toSAlgT :: Sized a => t a -> SAlgRepT t a
+ fromSAlgT :: Sized a => SAlgRepT t a -> t a
+
+instance AlgebraicT Id where
+ type AlgRepT Id = Id
+ toAlgT = id
+ fromAlgT = id
+
+instance (AlgebraicT t, Algebraic a) => Algebraic (AlgWrap t a) where
+ type AlgRep (AlgWrap t a) = AlgRepT t (AlgRep a)
+ toAlg = fmap toAlg . toAlgT . unAlgWrap
+ fromAlg = AlgWrap . fromAlgT . fmap fromAlg
+
+instance (AlgebraicT f, AlgebraicT g) => AlgebraicT (f `O` g) where
+ type AlgRepT (f `O` g) = AlgRepT f `O` AlgRepT g
+ toAlgT (O x) = O (fmap (\ (App y) -> App (toAlgT y)) (toAlgT x))
+ fromAlgT (O x) = O (fromAlgT (fmap (\ (App y) -> App (fromAlgT y)) x))
+
+instance (Algebraic (f (g a)), Functor f) => Algebraic ((f `O` g) a) where
+ type AlgRep ((f `O` g) a) = AlgRep (f (g a))
+ toAlg = toAlg . unO
+ fromAlg = o . fromAlg
+
+instance (AlgebraicT f, AlgebraicT g) => AlgebraicT (f :*: g) where
+ type AlgRepT (f :*: g) = AlgRepT f :*: AlgRepT g
+ toAlgT (a :*: b) = toAlgT a :*: toAlgT b
+ fromAlgT (a :*: b) = fromAlgT a :*: fromAlgT b
+
+instance (AlgebraicT f, AlgebraicT g, Algebraic a) => Algebraic ((f :*: g) a) where
+ type AlgRep ((f :*: g) a) = (AlgRepT f :*: AlgRepT g) (AlgRep a)
+ toAlg (a :*: b) = fmap toAlg (toAlgT a :*: toAlgT b)
+ fromAlg (a :*: b) = fromAlgT (fmap fromAlg a) :*: fromAlgT (fmap fromAlg b)
+
+instance (AlgebraicT f, AlgebraicT g) => AlgebraicT (f :+: g) where
+ type AlgRepT (f :+: g) = AlgRepT f :+: AlgRepT g
+ toAlgT (A a) = A (toAlgT a)
+ toAlgT (B b) = B (toAlgT b)
+ fromAlgT (A a) = A (fromAlgT a)
+ fromAlgT (B b) = B (fromAlgT b)
+
+instance (AlgebraicT f, AlgebraicT g, Algebraic a) => Algebraic ((f :+: g) a) where
+ type AlgRep ((f :+: g) a) = AlgRep (AlgWrap (f :+: g) a)
+ toAlg = toAlg . AlgWrap
+ fromAlg = unAlgWrap . fromAlg
+
+instance AlgebraicT f => Algebraic (Fix f) where
+ type AlgRep (Fix f) = Fix (AlgRepT f)
+ toAlg (Fix x) = Fix (fmap toAlg (toAlgT x))
+ fromAlg (Fix x) = Fix (fromAlgT (fmap fromAlg x))
+
+instance Algebraic a => AlgebraicT (Const a) where
+ type AlgRepT (Const a) = Const (AlgRep a)
+ toAlgT (Const a) = Const (toAlg a)
+ fromAlgT (Const a) = Const (fromAlg a)
+
+instance Algebraic a => Algebraic (Const a b) where
+ type AlgRep (Const a b) = Const (AlgRep a) b
+ toAlg (Const a) = Const (toAlg a)
+ fromAlg (Const a) = fromAlg (Const a)
+
+instance Algebraic a => AlgebraicT ((,) a) where
+ type AlgRepT ((,) a) = (,) (AlgRep a)
+ toAlgT = first toAlg
+ fromAlgT = first fromAlg
+
+instance (Algebraic a, Algebraic b) => Algebraic (a, b) where
+ type AlgRep (a, b) = AlgRep (AlgWrap ((,) a) b)
+ toAlg = toAlg . AlgWrap
+ fromAlg = unAlgWrap . fromAlg
-instance (Algebraic k1, Algebraic k2) => Algebraic (k1, k2) where
- type Alg (k1, k2) = (Alg k1, Alg k2)
- toAlg (k1, k2) = (toAlg k1, toAlg k2)
- fromAlg (k1, k2) = (fromAlg k1, fromAlg k2)
+instance (Algebraic a, Algebraic b) => AlgebraicT ((,,) a b) where
+ type AlgRepT ((,,) a b) = (,) (AlgRep (a, b))
+ toAlgT (a, b, c) = (toAlg (a, b), c)
+ fromAlgT (ab, c) = case fromAlg ab of
+ (a, b) -> (a, b, c)
instance (Algebraic a, Algebraic b, Algebraic c) => Algebraic (a, b, c) where
- type Alg (a, b, c) = (Alg a, (Alg b, Alg c))
- toAlg (a, b, c) = toAlg (a, (b, c))
- fromAlg x = case fromAlg x of
- (a, (b, c)) -> (a, b, c)
+ type AlgRep (a, b, c) = AlgRep (AlgWrap ((,,) a b) c)
+ toAlg = toAlg . AlgWrap
+ fromAlg = unAlgWrap . fromAlg
+
+instance (Algebraic a, Algebraic b, Algebraic c) => AlgebraicT ((,,,) a b c) where
+ type AlgRepT ((,,,) a b c) = (,) (AlgRep (a, b, c))
+ toAlgT (a, b, c, d) = (toAlg (a, b, c), d)
+ fromAlgT (abc, d) = case fromAlg abc of
+ (a, b, c) -> (a, b, c, d)
instance (Algebraic a, Algebraic b, Algebraic c, Algebraic d) => Algebraic (a, b, c, d) where
- type Alg (a, b, c, d) = (Alg a, (Alg b, (Alg c, Alg d)))
- toAlg (a, b, c, d) = toAlg (a, (b, (c, d)))
- fromAlg x = case fromAlg x of
- (a, (b, (c, d))) -> (a, b, c, d)
-
-instance (Algebraic a, Algebraic b, Algebraic c, Algebraic d, Algebraic e) => Algebraic (a, b, c, d, e) where
- type Alg (a, b, c, d, e) = (Alg a, (Alg b, (Alg c, (Alg d, Alg e))))
- toAlg (a, b, c, d, e) = toAlg (a, (b, (c, (d, e))))
- fromAlg x = case fromAlg x of
- (a, (b, (c, (d, e)))) -> (a, b, c, d, e)
-
-instance (Algebraic k1, Algebraic k2) => Algebraic (Either k1 k2) where
- type Alg (Either k1 k2) = Either (Alg k1) (Alg k2)
- toAlg = either (Left . toAlg) (Right . toAlg)
- fromAlg = either (Left . fromAlg) (Right . fromAlg)
+ type AlgRep (a, b, c, d) = AlgRep (AlgWrap ((,,,) a b c) d)
+ toAlg = toAlg . AlgWrap
+ fromAlg = unAlgWrap . fromAlg
+
+instance Algebraic a => AlgebraicT (Either a) where
+ type AlgRepT (Either a) = Either (AlgRep a)
+ toAlgT = either (Left . toAlg) Right
+ fromAlgT = either (Left . fromAlg) Right
+
+instance (Algebraic a, Algebraic b) => Algebraic (Either a b) where
+ type AlgRep (Either a b) = AlgRep (AlgWrap (Either a) b)
+ toAlg = toAlg . AlgWrap
+ fromAlg = unAlgWrap . fromAlg
+
+instance AlgebraicT [] where
+ type AlgRepT [] = []
+ toAlgT = id
+ fromAlgT = id
instance Algebraic k => Algebraic [k] where
- type Alg [k] = [Alg k]
+ type AlgRep [k] = [AlgRep k]
toAlg = map toAlg
fromAlg = map fromAlg
instance Algebraic () where
- type Alg () = ()
+ type AlgRep () = ()
toAlg = id
fromAlg = id
+instance AlgebraicT Maybe where
+ type AlgRepT Maybe = Either ()
+ toAlgT = maybe (Left ()) Right
+ fromAlgT = either (const Nothing) Just
+
+instance SAlgebraicT Maybe where
+ type SAlgRepT Maybe = AlgRepT Maybe
+ toSAlgT = toAlgT
+ fromSAlgT = fromAlgT
+
instance Algebraic a => Algebraic (Maybe a) where
- type Alg (Maybe a) = Either () (Alg a)
- toAlg Nothing = Left ()
- toAlg (Just a) = Right (toAlg a)
- fromAlg (Left _) = Nothing
- fromAlg (Right a) = Just (fromAlg a)
+ type AlgRep (Maybe a) = AlgRep (AlgWrap Maybe a)
+ toAlg = toAlg . AlgWrap
+ fromAlg = unAlgWrap . fromAlg
instance Algebraic Bool where
- type Alg Bool = Alg (Maybe ())
+ type AlgRep Bool = AlgRep (Maybe ())
toAlg b = toAlg $ if b then Just () else Nothing
fromAlg = maybe False (const True) . fromAlg'
- where fromAlg' = fromAlg :: Alg (Maybe ()) -> Maybe ()
+ where fromAlg' = fromAlg :: AlgRep (Maybe ()) -> Maybe ()
instance Algebraic Int where
- type Alg Int = Int
+ type AlgRep Int = Int
toAlg = id
fromAlg = id
instance Algebraic Char where
- type Alg Char = Int
+ type AlgRep Char = Int
toAlg = ord
fromAlg = chr
instance Algebraic Float where
- type Alg Float = Ordered Float
+ type AlgRep Float = Ordered Float
toAlg = Ord
fromAlg = unOrd
instance Algebraic Double where
- type Alg Double = Ordered Double
+ type AlgRep Double = Ordered Double
toAlg = Ord
fromAlg = unOrd
instance Algebraic Rational where
- type Alg Rational = Ordered Rational
+ type AlgRep Rational = Ordered Rational
toAlg = Ord
fromAlg = unOrd
+instance Algebraic a => Algebraic (Ordered a) where
+ type AlgRep (Ordered a) = AlgRep a
+ toAlg = toAlg . unOrd
+ fromAlg = Ord . fromAlg
+
instance (Algebraic k, Algebraic v) => Algebraic (Map k v) where
- type Alg (Map k v) = [(Alg k, Alg v)]
- toAlg m = build (\ c n -> Map.foldWithKey (\ k v -> c (toAlg k, toAlg v)) n m)
- fromAlg xs = Map.fromDistinctAscList [(fromAlg k, fromAlg v) | (k, v) <- xs]
+ type AlgRep (Map k v) = AlgRep (AlgWrap (Map k) v)
+ toAlg = toAlg . AlgWrap
+ fromAlg = unAlgWrap . fromAlg
+
+instance Algebraic k => AlgebraicT (Map k) where
+ type AlgRepT (Map k) = [] `O` ((,) k)
+ toAlgT = o . Map.assocs
+ fromAlgT = Map.fromDistinctAscList . unO
+
+instance Algebraic k => SAlgebraicT (Map k) where
+ type SAlgRepT (Map k) = [] `O` ((,) k)
+ toSAlgT = o . Map.assocs
+ fromSAlgT = Map.fromDistinctAscList . unO
instance Algebraic v => Algebraic (IntMap v) where
- type Alg (IntMap v) = [(Int, Alg v)]
- toAlg m = build (\ c n -> IMap.foldWithKey (\ k v -> c (k, toAlg v)) n m)
- fromAlg xs = IMap.fromDistinctAscList [(k, fromAlg v) | (k, v) <- xs]
+ type AlgRep (IntMap v) = AlgRep (AlgWrap IntMap v)
+ toAlg = toAlg . AlgWrap
+ fromAlg = unAlgWrap . fromAlg
+
+instance AlgebraicT IntMap where
+ type AlgRepT IntMap = AlgRepT ([] `O` ((,) Int))
+ toAlgT = toAlgT . o . IMap.assocs
+ fromAlgT = IMap.fromDistinctAscList . unO . fromAlgT
+
+instance SAlgebraicT IntMap where
+ type SAlgRepT IntMap = AlgRepT ([] `O` ((,) Int))
+ toSAlgT = toAlgT . o . IMap.assocs
+ fromSAlgT = IMap.fromDistinctAscList . unO . fromAlgT
instance Algebraic a => Algebraic (Set a) where
- type Alg (Set a) = [Alg a]
- toAlg s = build (\ c n -> Fold.foldr (c . toAlg) n s)
- fromAlg = Set.fromDistinctAscList . map fromAlg
+ type AlgRep (Set a) = AlgRep (AlgWrap Set a)
+ toAlg = toAlg . AlgWrap
+ fromAlg = unAlgWrap . fromAlg
+
+instance AlgebraicT Set where
+ type AlgRepT Set = AlgRepT []
+ toAlgT = toAlgT . Fold.toList
+ fromAlgT = Set.fromDistinctAscList . fromAlgT
instance Algebraic IntSet where
- type Alg IntSet = [Int]
- toAlg = ISet.toList
- fromAlg = ISet.fromDistinctAscList \ No newline at end of file
+ type AlgRep IntSet = AlgRep [Int]
+ toAlg = toAlg . ISet.toList
+ fromAlg = ISet.fromDistinctAscList . fromAlg
+
+{-# RULES
+ "map/id" forall xs . map id xs = xs;
+ #-}
+
+instance SAlgebraicT m => SAlgebraicT (ConstMap m k m') where
+ type SAlgRepT (ConstMap m k m') = SAlgRepT m
+ toSAlgT (ConstMap m) = toSAlgT m
+ fromSAlgT = ConstMap . fromSAlgT
+
+instance Algebraic (m a) => Algebraic (ConstMap m k m' a) where
+ type AlgRep (ConstMap m k m' a) = AlgRep (m a)
+ toAlg (ConstMap m) = toAlg m
+ fromAlg = ConstMap . fromAlg
+
+instance SAlgebraicT m => SAlgebraicT (IdMap k m) where
+ type SAlgRepT (IdMap k m) = SAlgRepT m
+ toSAlgT (IdMap m) = toSAlgT m
+ fromSAlgT = IdMap . fromSAlgT
+
+instance Algebraic (m a) => Algebraic (IdMap k m a) where
+ type AlgRep (IdMap k m a) = AlgRep (m a)
+ toAlg (IdMap m) = toAlg m
+ fromAlg = IdMap . fromAlg
+
+instance (SAlgebraicT (t1 k m), SAlgebraicT (t2 k m), TrieKey k m, TrieKeyT f2 t2) => SAlgebraicT (ProdMap t1 t2 k m) where
+ type SAlgRepT (ProdMap t1 t2 k m) = (SAlgRepT (t1 k m) `O` SAlgRepT (t2 k m))
+ toSAlgT (PMap m) = O (fmap (App . toSAlgT) (toSAlgT m))
+ fromSAlgT (O m) = PMap (fromSAlgT (fmap (\ (App x) -> fromSAlgT x) m))
+
+instance Algebraic (t1 k m (t2 k m a)) => Algebraic (ProdMap t1 t2 k m a) where
+ type AlgRep (ProdMap t1 t2 k m a) = AlgRep (t1 k m (t2 k m a))
+ toAlg (PMap m) = toAlg m
+ fromAlg = PMap . fromAlg
+
+instance (SAlgebraicT m1, SAlgebraicT m2, TrieKey k2 m2) => SAlgebraicT (CProdMap m1 k2 m2) where
+ type SAlgRepT (CProdMap m1 k2 m2) = SAlgRepT m1 `O` SAlgRepT m2
+ toSAlgT (CPMap m) = O (fmap (App . toSAlgT) (toSAlgT m))
+ fromSAlgT (O m) = CPMap (fromSAlgT (fmap (fromSAlgT . unApp) m))
+
+instance (Algebraic (m1 (m2 a))) => Algebraic (CProdMap m1 k2 m2 a) where
+ type AlgRep (CProdMap m1 k2 m2 a) = AlgRep (m1 (m2 a))
+ toAlg (CPMap m) = toAlg m
+ fromAlg = CPMap . fromAlg
+
+{-
+instance Algebraic (t1 k m (t2 k m a)) => Algebraic (ProdMap t1 t2 k m a) where
+ type AlgRep (ProdMap t1 t2 k m a) = AlgRep (t1 k m (t2 k m a))
+ toAlg = toAlg . unPMap
+ fromAlg = PMap . fromAlg-}
+
+instance (SAlgebraicT (t1 k m), SAlgebraicT (t2 k m)) => SAlgebraicT (UnionMap t1 t2 k m) where
+ type SAlgRepT (UnionMap t1 t2 k m) = SAlgRepT (t1 k m) :*: SAlgRepT (t2 k m)
+ toSAlgT (UMap m1 m2) = toSAlgT m1 :*: toSAlgT m2
+ fromSAlgT (m1 :*: m2) = UMap (fromSAlgT m1) (fromSAlgT m2)
+
+instance (Algebraic (t1 k m a), Algebraic (t2 k m a)) => Algebraic (UnionMap t1 t2 k m a) where
+ type AlgRep (UnionMap t1 t2 k m a) = AlgRep (t1 k m a, t2 k m a)
+ toAlg (UMap m1 m2) = toAlg (m1, m2)
+ fromAlg = uncurry UMap . fromAlg
+
+instance (SAlgebraicT m1, SAlgebraicT m2) => SAlgebraicT (CUnionMap m1 k2 m2) where
+ type SAlgRepT (CUnionMap m1 k2 m2) = SAlgRepT m1 :*: SAlgRepT m2
+ toSAlgT (CUMap m1 m2) = toSAlgT m1 :*: toSAlgT m2
+ fromSAlgT (m1 :*: m2) = CUMap (fromSAlgT m1) (fromSAlgT m2)
+
+instance (Algebraic (m1 a), Algebraic (m2 a)) => Algebraic (CUnionMap m1 k2 m2 a) where
+ type AlgRep (CUnionMap m1 k2 m2 a) = AlgRep (m1 a, m2 a)
+ toAlg (CUMap m1 m2) = toAlg (m1, m2)
+ fromAlg = uncurry CUMap . fromAlg
+
+-- instance (Algebraic (t1 k m a), Algebraic (t2 k m a)) => Algebraic (UnionMap t1 t2 k m a) where
+-- type AlgRep (UnionMap t1 t2 k m a) = AlgRep (t1 k m a, t2 k m a)
+-- toAlg (UMap m1 m2) = toAlg (m1, m2)
+-- fromAlg = uncurry UMap . fromAlg
+
+instance SAlgebraicT f => SAlgebraicT (App f) where
+ type SAlgRepT (App f) = SAlgRepT f
+ toSAlgT = toSAlgT . unApp
+ fromSAlgT = App . fromSAlgT
+
+instance AlgebraicT f => AlgebraicT (App f) where
+ type AlgRepT (App f) = AlgRepT f
+ toAlgT = toAlgT . unApp
+ fromAlgT = App . fromAlgT
+
+instance Algebraic (f a) => Algebraic (App f a) where
+ type AlgRep (App f a) = AlgRep (f a)
+ toAlg = toAlg . unApp
+ fromAlg = App . fromAlg
+
+instance SAlgebraicT (t1 (App f2 k) (App (t2 k m))) => SAlgebraicT (CompMap t1 f2 t2 k m) where
+ type SAlgRepT (CompMap t1 f2 t2 k m) = SAlgRepT (t1 (App f2 k) (App (t2 k m)))
+ toSAlgT (CompMap m) = toSAlgT m
+ fromSAlgT = CompMap . fromSAlgT
+
+instance Algebraic (t1 (App f2 k) (App (t2 k m)) a) => Algebraic (CompMap t1 f2 t2 k m a) where
+ type AlgRep (CompMap t1 f2 t2 k m a) = AlgRep (t1 (App f2 k) (App (t2 k m)) a)
+ toAlg (CompMap m) = toAlg m
+ fromAlg = CompMap . fromAlg
+
+-- instance (AlgebraicT (t1 (App f2 k) (App (t2 k m))), Algebraic a) => Algebraic (CompMap t1 f2 t2 k m a) where
+-- type AlgRep (CompMap t1 f2 t2 k m a) = AlgRep (AlgWrap (CompMap t1 f2 t2 k m) a)
+-- toAlg = toAlg . AlgWrap
+-- fromAlg = unAlgWrap . fromAlg
+
+-- newtype f t a = FixMap (t (Fix f) (FixMap f t) a)
+
+instance (TrieKeyT f t) => SAlgebraicT (FixMap f t) where
+ type SAlgRepT (FixMap f t) = [] `O` ((,) (Fix f))
+ toSAlgT m = o (assocsAlg m)
+ fromSAlgT = fromDistAscListAlg . unO
+
+instance (TrieKeyT f t, AlgebraicT f, Sized a, Algebraic a) => Algebraic (FixMap f t a) where
+ type AlgRep (FixMap f t a) = AlgRep [(Fix f, a)]
+ toAlg = toAlg . assocsAlg
+ fromAlg = fromDistAscListAlg . fromAlg
+
+-- instance (AlgebraicT f, TrieKeyT f t, Sized a, Algebraic a) => Algebraic (FixMap f t a) where
+-- type AlgRep (FixMap f t a) = AlgRep [(Fix f, a)]
+-- toAlg = toAlg . assocsAlg
+-- fromAlg = fromDistAscListAlg . fromAlg
+
+instance Algebraic Word8 where
+ type AlgRep Word8 = Int
+ toAlg = fromIntegral
+ fromAlg = fromIntegral
+
+instance Algebraic Word16 where
+ type AlgRep Word16 = Int
+ toAlg = fromIntegral
+ fromAlg = fromIntegral
+
+instance Algebraic Word32 where
+ type AlgRep Word32 = Int
+ toAlg = fromIntegral
+ fromAlg = fromIntegral
+
+instance Algebraic Integer where
+ type AlgRep Integer = AlgRep [Word8]
+ toAlg = toAlg . unroll
+ fromAlg = roll . fromAlg
+
+instance Algebraic ByteString where
+ type AlgRep ByteString = AlgRep [Word8]
+ toAlg = toAlg . unpack
+ fromAlg = pack . fromAlg
+
+unroll :: Integer -> [Word8]
+unroll = unfoldr step
+ where
+ step 0 = Nothing
+ step i = Just (fromIntegral i, i `shiftR` 8)
+
+roll :: [Word8] -> Integer
+roll = foldr unstep 0
+ where
+ unstep b a = a `shiftL` 8 .|. fromIntegral b
+
+
+{-# RULES
+ "toAlg/fromAlg" forall x . toAlg (fromAlg x) = x;
+ #-} \ No newline at end of file
diff --git a/TrieMap/Applicative.hs b/TrieMap/Applicative.hs
index 74291f4..5aaddc1 100644
--- a/TrieMap/Applicative.hs
+++ b/TrieMap/Applicative.hs
@@ -4,11 +4,7 @@ import Control.Monad
import Control.Applicative
import Data.Traversable (sequenceA)
import GHC.Exts (build)
-
-newtype Id a = Id {unId :: a}
-
-instance Functor Id where
- fmap f (Id x) = Id (f x)
+import TrieMap.MapTypes
instance Applicative Id where
pure = return
diff --git a/TrieMap/MapTypes.hs b/TrieMap/MapTypes.hs
index b5b829b..d9ef27f 100644
--- a/TrieMap/MapTypes.hs
+++ b/TrieMap/MapTypes.hs
@@ -1,18 +1,34 @@
-{-# LANGUAGE IncoherentInstances, TypeOperators, FlexibleContexts, StandaloneDeriving #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances, KindSignatures, StandaloneDeriving, GeneralizedNewtypeDeriving, IncoherentInstances, TypeOperators, FlexibleContexts, StandaloneDeriving, ExistentialQuantification #-}
module TrieMap.MapTypes where
import Data.Foldable
import Data.Traversable
-import Control.Applicative
+import Control.Applicative hiding (Const)
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)
+data (f :*: g) a = f a :*: g a deriving (Eq, Ord, Show)
+data (f :+: g) a = A (f a) | B (g a) deriving (Eq, Ord, Show)
+newtype Const a b = Const {unConst :: a} deriving (Eq, Ord, Show)
+newtype Id a = Id {unId :: a} deriving (Eq, Ord, Show)
+newtype Fix f = Fix (f (Fix f))
+newtype FixMap f t a = FixMap (t (Fix f) (FixMap f t) a)
+
+newtype O f g a = O (f (App g a))
+newtype App f a = App {unApp :: f a}
+
+o :: Functor f => f (g a) -> (f `O` g) a
+o = O . fmap App
+
+unO :: Functor f => (f `O` g) a -> f (g a)
+unO (O x) = fmap unApp x
--- | '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)
+-- | 'ProdMap' is used to hold a map on the product of two key types.
+newtype ProdMap t1 t2 k (m :: * -> *) a = PMap {unPMap :: t1 k m (t2 k m a)}
+data UnionMap t1 t2 k (m :: * -> *) a = UMap (t1 k m a) (t2 k m a)
+newtype CProdMap m1 k2 m2 a = CPMap {unCPMap :: m1 (m2 a)}
+data CUnionMap m1 k2 m2 a = CUMap (m1 a) (m2 a)
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)
@@ -20,6 +36,14 @@ 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 IdMap k m a = IdMap {unIdMap :: m a}
+
+newtype ConstMap (m :: * -> *) k (x :: * -> *) a = ConstMap {unConstMap :: m a}
+
+newtype CompMap t1 f2 (t2 :: * -> (* -> *) -> * -> *) k (m :: * -> *) a = CompMap (t1 (App f2 k) (App (t2 k m)) a)
+
+-- newtype FixMap (m :: (* -> *) -> * -> *) a = FixMap (m (FixMap m) a)
+
newtype Elem a = Elem {getElem :: a} deriving (Eq, Ord)
instance Functor Elem where
@@ -34,6 +58,8 @@ instance Traversable Elem where
infixr 5 `ProdMap`
infixr 5 :+:
+infixr 8 :*:
+infixr 9 `O`
class Sized a where
getSize :: a -> Int
@@ -41,46 +67,100 @@ class Sized a where
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)
+instance Functor m => Functor (Edge k m) where
+ fmap f (Edge n ks v ts) = Edge n ks (fmap f v) (fmap (fmap f) ts)
+raverse f (Radix e) = Radix <$> traverse (traverse f) e
-instance (Foldable m1, Foldable m2) => Foldable (ProdMap m1 m2) where
- foldr f z (PMap m) = foldr (flip (foldr f)) z m
- foldl f z (PMap m) = foldl (foldl f) z m
+instance (Functor f, Functor g) => Functor (f :*: g) where
+ fmap f (a :*: b) = fmap f a :*: fmap f b
-instance (Traversable m1, Traversable m2) => Traversable (ProdMap m1 m2) where
- traverse f (PMap m) = PMap <$> traverse (traverse f) m
+instance (Foldable f, Foldable g) => Foldable (f :*: g) where
+ foldr f z (a :*: b) = foldr f (foldr f z b) a
+ foldl f z (a :*: b) = foldl f (foldl f z a) b
-instance (Functor m1, Functor m2) => Functor (UnionMap m1 m2) where
- fmap f (m1 :+: m2) = fmap f m1 :+: fmap f m2
+instance (Traversable f, Traversable g) => Traversable (f :*: g) where
+ traverse f (a :*: b) = liftA2 (:*:) (traverse f a) (traverse f b)
-instance (Foldable m1, Foldable m2) => Foldable (UnionMap m1 m2) where
- foldr f z (m1 :+: m2) = foldr f (foldr f z m2) m1
- foldl f z (m1 :+: m2) = foldl f (foldl f z m1) m2
+instance (Functor f, Functor g) => Functor (f :+: g) where
+ fmap f (A a) = A (fmap f a)
+ fmap f (B b) = B (fmap f b)
-instance (Traversable m1, Traversable m2) => Traversable (UnionMap m1 m2) where
- traverse f (m1 :+: m2) = liftA2 (:+:) (traverse f m1) (traverse f m2)
+instance (Foldable f, Foldable g) => Foldable (f :+: g) where
+ foldr f z (A a) = foldr f z a
+ foldr f z (B b) = foldr f z b
+ foldl f z (A a) = foldl f z a
+ foldl f z (B b) = foldl f z b
-instance Functor m => Functor (Edge k m) where
- fmap f (Edge n ks v ts) = Edge n ks (fmap f v) (fmap (fmap f) ts)
+instance (Traversable f, Traversable g) => Traversable (f :+: g) where
+ traverse f (A a) = A <$> traverse f a
+ traverse f (B b) = B <$> traverse f b
+
+instance Functor (Const a) where
+ fmap f (Const x) = Const x
+
+instance Foldable (Const a) where
+ foldr f z _ = z
+ foldl f z _ = z
+
+instance Traversable (Const a) where
+ traverse f (Const x) = pure (Const x)
+
+instance Functor Id where
+ fmap f (Id a) = Id (f a)
+
+instance Foldable Id where
+ foldr f z (Id a) = a `f` z
+ foldl f z (Id a) = z `f` a
+
+instance Traversable Id where
+ traverse f (Id a) = Id <$> f a
+
+class EqT f where
+ eq :: Eq a => f a -> f a -> Bool
+
+instance EqT f => Eq (Fix f) where
+ Fix x == Fix y = x `eq` y
+
+instance (EqT f, EqT g) => EqT (f :*: g) where
+ (a :*: x) `eq` (b :*: y) = a `eq` b && x `eq` y
+
+instance (EqT f, EqT g) => EqT (f :+: g) where
+ A a `eq` A b = a `eq` b
+ B x `eq` B y = x `eq` y
+ _ `eq` _ = False
+
+instance Eq a => EqT (Const a) where
+ Const a `eq` Const b = a == b
+
+instance EqT Id where
+ Id a `eq` Id b = a == b
+
+instance EqT [] where
+ eq = (==)
+
+instance EqT Maybe where
+ eq = (==)
+
+instance Eq a => EqT ((,) a) where
+ eq = (==)
+
+instance Eq a => EqT (Either a) where
+ eq = (==)
-instance Functor m => Functor (RadixTrie k m) where
- fmap f (Radix e) = Radix (fmap (fmap f) e)
+instance EqT f => EqT (App f) where
+ App a `eq` App b = a `eq` b
-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
+instance (EqT f, Eq a) => Eq (App f a) where
+ (==) = eq
-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 (EqT f, EqT g) => EqT (f `O` g) where
+ O a `eq` O b = a `eq` b
-instance Traversable m => Traversable (Edge k m) where
- traverse f (Edge n ks v ts) =
- liftA2 (Edge n ks) (traverse f v) (traverse (traverse f) ts)
+instance (EqT f, EqT g, Eq a) => Eq ((f `O` g) a) where
+ (==) = eq
-instance Traversable m => Traversable (RadixTrie k m) where
- traverse f (Radix e) = Radix <$> traverse (traverse f) e
+instance (Functor f, Functor g) => Functor (f `O` g) where
+ fmap f (O x) = O (fmap (\ (App x) -> App (fmap f x)) x)
instance Traversable IMap.IntMap where
traverse f m = IMap.fromDistinctAscList <$> traverse (\ (k, v) -> ((,) k) <$> f v) (IMap.assocs m) \ No newline at end of file
diff --git a/TrieMap/RadixTrie.hs b/TrieMap/RadixTrie.hs
index 1ea5b6b..2ab4432 100644
--- a/TrieMap/RadixTrie.hs
+++ b/TrieMap/RadixTrie.hs
@@ -1,301 +1,274 @@
-{-# LANGUAGE IncoherentInstances, MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, StandaloneDeriving, PatternGuards #-}
+{-# LANGUAGE IncoherentInstances, PatternGuards, MultiParamTypeClasses, UndecidableInstances #-}
-module TrieMap.RadixTrie (RadixTrie) where
+module TrieMap.RadixTrie where
+
+import Control.Applicative
-import Control.Applicative hiding (Alternative(..))
-import Control.Monad
-import Data.Foldable
-import Data.Traversable
-import Data.Monoid
import Data.Maybe
-import Data.Ord
+import Data.Monoid
+import Data.Foldable
import Data.Sequence (Seq, (|>))
import qualified Data.Sequence as Seq
+import Data.Traversable
+import TrieMap.Algebraic
+import TrieMap.Applicative
import TrieMap.MapTypes
import TrieMap.TrieAlgebraic
-import TrieMap.Applicative
-
-import Prelude hiding (null, foldr, all)
-
-instance (Eq k, Eq v, TrieKey k m) => Eq (Edge k m v) where
- 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 =
- 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)
-deriving instance (Ord k, Ord v, TrieKey k m) => Ord (RadixTrie k m v)
-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)
-
-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))
- lookupAlg ks = unRad >=> lookupEdge (==) ks
--- sizeAlg (Radix e) = maybe 0 sizeEdge e
- alterLookupAlg f k = fmap Radix .
- maybe (fmap (maybeSingleEdge k) $ f Nothing)
- (alterLookupEdge (==) f k) . unRad
- foldWithKeyAlg f z = foldr (flip (foldWithKeyEdge f)) z . unRad
- mapMaybeAlg f (Radix e) = Radix (e >>= mapMaybeEdge f)
- mapEitherAlg f (Radix Nothing) = (emptyAlg, emptyAlg)
- mapEitherAlg f (Radix (Just e)) = (Radix e1, Radix e2)
- where (e1, e2) = mapEitherEdge f e
--- mapMaybeAlg f (Radix e) = (Radix . join) <$> traverse (mapAppMaybeEdge f) e
- mapAppAlg f = fmap Radix . traverse (mapAppEdge f) . unRad
- unionMaybeAlg f (Radix e1) (Radix e2) = Radix (unionMaybe (unionMaybeEdge f) e1 e2)
- intersectAlg f (Radix e1) (Radix e2) = Radix (intersectMaybe (intersectEdge f) e1 e2)
- differenceAlg f (Radix e1) (Radix e2) = Radix (differenceMaybe (differenceEdge f) e1 e2)
-
- getMinAlg (Radix e) = fmap (fmap Radix . getMinEdge) e
- getMaxAlg (Radix e) = fmap (fmap Radix . getMaxEdge) e
--- updateMinAlg f (Radix e) = Radix $ e >>= updateMinEdge f
--- updateMaxAlg f (Radix e) = Radix $ e >>= updateMaxEdge f
-
- fromListAlg f xs = Radix (edgeFromList f xs)
- fromAscListAlg f xs = Radix (edgeFromAscList f xs)
- fromDistAscListAlg = fromAscListAlg (\ _ v _ -> v)
-
- 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
-
- splitLookupAlg _ _ (Radix Nothing) = (Radix Nothing, Nothing, Radix Nothing)
- splitLookupAlg f k (Radix (Just e)) = case splitEdge f k e of
+import Prelude hiding (foldr)
+
+instance Sized (Edge k m a) where
+ getSize (Edge s _ _ _) = s
+
+instance TrieKeyT [] RadixTrie where
+ compareKeyT (a:as) (b:bs) = compareKey a b `mappend` compareKeyT as bs
+ compareKeyT [] (_:_) = LT
+ compareKeyT (_:_) [] = GT
+ compareKeyT [] [] = EQ
+ emptyT = Radix Nothing
+ nullT (Radix m) = isNothing m
+ sizeT (Radix m) = getSize m
+ getSingleT (Radix m) = m >>= getSingleEdge
+ guardNullT (Radix m) = m >>= guardNullEdge >>= return . Radix . Just
+ alterLookupT f ks (Radix Nothing) = (Radix . single ks) <$> f Nothing
+ alterLookupT f ks (Radix (Just e)) = Radix <$> alterLookupEdge f ks e
+ lookupT ks (Radix m) = m >>= lookupEdge ks
+ foldWithKeyT f z (Radix m) = foldr (foldEdge f) z m
+ mapAppT f (Radix m) = Radix <$> traverse (mapAppEdge f) m
+ mapMaybeT f (Radix m) = Radix (m >>= mapMaybeEdge f)
+ mapEitherT f (Radix m) = radBoth (maybe (Nothing, Nothing) (mapEitherEdge f) m)
+ where radBoth (e1, e2) = (Radix e1, Radix e2)
+ fromDistAscListT = fromAscListT (\ _ x _ -> x)
+ fromAscListT _ [] = Radix Nothing
+ fromAscListT f (x:xs) = Radix (Just (groupAscHeads' f x xs))
+ fromListT f xs = Radix (groupHeads f xs)
+ splitLookupT _ _ (Radix Nothing) = (emptyT, Nothing, emptyT)
+ splitLookupT f k (Radix (Just e)) = case splitLookupEdge f k e of
(eL, ans, eR) -> (Radix eL, ans, Radix eR)
-
--- sizeEdge :: Edge k m v -> Int
--- sizeEdge (Edge n _ _ _) = n
-
-{-# INLINE edge #-}
-edge :: (Sized v, TrieKey k m) => [k] -> Maybe v -> m (Edge k m v) -> Edge k m v
+ isSubmapT (<=) (Radix m1) (Radix m2) = isSubmapAlg (isSubEdge (<=)) m1 m2
+ getMinT (Radix m) = fmap (Radix <$>) (m >>= getMinEdge)
+ getMaxT (Radix m) = fmap (Radix <$>) (m >>= getMaxEdge)
+ updateMinT _ (Radix Nothing) = (False, Radix Nothing)
+ updateMinT f (Radix (Just e)) = Radix <$> updateMinEdge f e
+ updateMaxT _ (Radix Nothing) = (False, Radix Nothing)
+ updateMaxT f (Radix (Just e)) = Radix <$> updateMaxEdge f e
+ unionT f (Radix m1) (Radix m2) = Radix (unionMaybe (unionEdge f) m1 m2)
+ intersectT f (Radix m1) (Radix m2) = Radix (intersectMaybe (intersectEdge f) m1 m2)
+ differenceT f (Radix m1) (Radix m2) = Radix (differenceMaybe (differenceEdge f) m1 m2)
+
+instance TrieKey k m => TrieKey [k] (RadixTrie k m) where
+ compareKey = compareKeyT
+ emptyAlg = emptyT
+ nullAlg = nullT
+ getSingleAlg = getSingleT
+ guardNullAlg = guardNullT
+ sizeAlg = sizeT
+ lookupAlg = lookupT
+ alterLookupAlg = alterLookupT
+ mapAppAlg = mapAppT
+ mapMaybeAlg = mapMaybeT
+ mapEitherAlg = mapEitherT
+ foldWithKeyAlg = foldWithKeyT
+ unionMaybeAlg = unionT
+ intersectAlg = intersectT
+ differenceAlg = differenceT
+ getMinAlg = getMinT
+ getMaxAlg = getMaxT
+ updateMinAlg = updateMinT
+ updateMaxAlg = updateMaxT
+ isSubmapAlg = isSubmapT
+ splitLookupAlg = splitLookupT
+
+single :: (Sized a, TrieKey k m) => [k] -> Maybe a -> MEdge k m a
+single ks = fmap (\ v -> Edge (getSize v) ks (Just v) emptyAlg)
+
+edge :: (Sized a, TrieKey k m) => [k] -> Maybe a -> m (Edge k m a) -> Edge k m a
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
- procEdge (k:ks) (l:ls)
- | k == l = procEdge ks ls
- procEdge (k:ks) [] = lookupAlg k ts >>= lookupEdge (==) ks
- procEdge [] [] = v
- procEdge _ _ = Nothing
-
-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, Elem [(ks, v)]):ys)
- (v0, ys) = foldr part (Nothing, []) xs
-
-edgeFromAscList :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> v) -> [([k], v)] -> MEdge k m v
-edgeFromAscList _ [] = Nothing
-edgeFromAscList f (x:xs) = Just $ edgeFromAscList' f x xs
-
-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 (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 :: 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 :: TrieKey k m => Edge k m a -> Maybe ([k], a)
getSingleEdge (Edge _ ks (Just v) ts)
| nullAlg ts = Just (ks, v)
getSingleEdge (Edge _ ks Nothing ts) = do
- (x, e') <- getSingleAlg ts
- (xs, v) <- getSingleEdge e'
- return (ks ++ x:xs, v)
+ (l, e') <- getSingleAlg ts
+ (ls, v) <- getSingleEdge e'
+ return (ks ++ l:ls, v)
getSingleEdge _ = Nothing
-{-# INLINE guardNullEdge #-}
-guardNullEdge :: TrieKey k m => Edge k m v -> MEdge k m v
-guardNullEdge (Edge n ks Nothing ts)
+guardNullEdge :: TrieKey k m => Edge k m a -> MEdge k m a
+guardNullEdge (Edge s ks Nothing ts)
| nullAlg ts = Nothing
- | Just (x, Edge n' xs v ts') <- getSingleAlg ts
- = Just (Edge n' (ks ++ x:xs) v ts')
+ | Just (l, Edge _ ls v ts') <- getSingleAlg ts
+ = Just (Edge s (ks ++ l:ls) v ts')
guardNullEdge e = Just e
-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 n0 ls0 v ts) = procEdge 0 ks0 ls0 where
+alterLookupEdge :: (Eq k, TrieKey k m, Sized a) => (Maybe a -> (b, Maybe a)) -> [k] -> Edge k m a -> (b, MEdge k m a)
+alterLookupEdge f ks0 e@(Edge s ls0 v0 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)
- where g Nothing = e
- 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)
- procEdge i [] (l:ls) = fmap (Just . g) $ f Nothing
- where g Nothing = e
- 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) =
- foldr (f ks) (foldWithKeyAlg (\ x -> flip (foldWithKeyEdge (\ xs -> f (ks ++ x:xs)))) z ts) v
-
-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, 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 -> Elem . mapEitherEdge (\ xs -> f (ks ++ x:xs))) ts
- tsL = mapMaybeAlg (\ _ (Elem (tsL, _)) -> tsL) ts'
- tsR = mapMaybeAlg (\ _ (Elem (_, tsR)) -> tsR) ts'
+ | otherwise = breakEdge <$> f Nothing where
+ breakEdge Nothing = Just e
+ breakEdge (Just v) = let sV = getSize v in
+ Just (Edge (sV + s) (take i ls0) Nothing
+ (fromListAlg (\ _ v _ -> v) [(k, Edge sV ks (Just v) emptyAlg), (l, Edge s ls v0 ts)]))
+ procEdge _ [] (l:ls) = splitEdge <$> f Nothing where
+ splitEdge Nothing = Just e
+ splitEdge (Just v) = let sV = getSize v in
+ Just (Edge (sV + s) ks0 (Just v) (singletonAlg l (Edge s ls v0 ts)))
+ procEdge _(k:ks) [] = (guardNullEdge . edge ls0 v0) <$> alterLookupAlg g k ts where
+ g Nothing = fmap (\ v -> Edge (getSize v) ks (Just v) emptyAlg) <$> f Nothing
+ g (Just e) = alterLookupEdge f ks e
+ procEdge _ [] [] = fmap (\ v -> guardNullEdge $ edge ls0 v ts) (f v0)
+
+lookupEdge :: (Eq k, TrieKey k m) => [k] -> Edge k m a -> Maybe a
+lookupEdge ks (Edge _ ls v ts) = procEdge ks ls where
+ procEdge (k:ks) (l:ls)
+ | k == l = procEdge ks ls
+ procEdge (k:ks) [] = lookupAlg k ts >>= lookupEdge ks
+ procEdge [] [] = v
+ procEdge _ _ = Nothing
-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)
+foldEdge :: TrieKey k m => ([k] -> a -> b -> b) -> Edge k m a -> b -> b
+foldEdge f (Edge _ ks v ts) z = foldr (f ks) (foldWithKeyAlg (\ l -> foldEdge (\ ls -> f (ks ++ l:ls))) z ts) v
+
+mapAppEdge :: (TrieKey k m, Applicative f, Sized b) => ([k] -> a -> f b) -> Edge k m a -> f (Edge k m b)
+mapAppEdge f (Edge _ ks v ts) = edge ks <$> traverse (f ks) v <*> mapAppAlg (\ l -> mapAppEdge (\ ls -> f (ks ++ l:ls))) ts
+
+mapMaybeEdge :: (TrieKey k m, Sized b) => ([k] -> a -> Maybe b) -> Edge k m a -> MEdge k m b
+mapMaybeEdge f (Edge _ ks v ts) =
+ guardNullEdge (edge ks (v >>= f ks) (mapMaybeAlg (\ l -> mapMaybeEdge (\ ls -> f (ks ++ l:ls))) ts))
+
+mapEitherEdge :: (TrieKey k m, Sized b, Sized c) => ([k] -> a -> (Maybe b, Maybe c)) -> Edge k m a ->
+ (MEdge k m b, MEdge k m c)
+mapEitherEdge f (Edge _ ks v ts) = guardBoth (edge ks vL tsL, edge ks vR tsR)
+ where (vL, vR) = maybe (Nothing, Nothing) (f ks) v
+ ts' = mapEitherAlg (\ l -> mapEitherEdge (\ ls -> f (ks ++ l:ls))) ts
+ (tsL, tsR) = mapEitherAlg (\ l -> mapEitherEdge (\ ls -> f (ks ++ l:ls))) ts
+ guardBoth (e1, e2) = (guardNullEdge e1, guardNullEdge e2)
+
+groupAscHeads' :: (Eq k, TrieKey k m, Sized a) => ([k] -> a -> a -> a) -> ([k], a) -> [([k], a)] -> Edge k m a
+groupAscHeads' f (ks, v) [] = Edge (getSize v) ks (Just v) emptyAlg
+groupAscHeads' f x xs = group0 Nothing (x:xs) where
+ group0 v0 (([], v):xs) = group0 (Just (maybe v (f [] v) v0)) xs
+ group0 (Just v0) [] = Edge (getSize v0) [] (Just v0) emptyAlg
+ group0 v0 ((k:ks, v):xs) = group1 Seq.empty k (ks, v) Seq.empty xs where
+ group1 ts k vk vs ((l:ls, v):xs)
+ | k == l = group1 ts k vk (vs |> (ls, v)) xs
+ | otherwise = group1 (ts |> (k, groupAscHeads' (f . (k:)) vk (toList vs))) l (ls, v) Seq.empty xs
+ group1 ts k v vs []
+ | Nothing <- v0, Seq.null ts, Edge s xs vX tsX <- groupAscHeads' (f . (k:)) v (toList vs)
+ = Edge s (k:xs) vX tsX
+ | otherwise
+ = edge [] v0 (fromDistAscListAlg (toList ts ++ [(k, groupAscHeads' (f . (k:)) v (toList vs))]))
+
+groupHeads :: (Eq k, TrieKey k m, Sized a) => ([k] -> a -> a -> a) -> [([k], a)] -> MEdge k m a
+groupHeads _ [] = Nothing
+groupHeads f xs = guardNullEdge $ edge [] v0 (mapMaybeAlg (\ k (Elem xs) -> groupHeads (f . (k:)) xs) $
+ fromListAlg (\ _ (Elem x) (Elem y) -> Elem (x ++ y)) [(k, Elem [(ks, v)]) | (k, ks, v) <- ts])
+ where (v0, ts) = let proc ([], v) (v0, ts) = (Just (maybe v (f [] v) v0), ts)
+ proc (k:ks, v) (v0, ts) = (v0, (k, ks, v):ts)
+ in foldr proc (Nothing, []) xs
+
+mapEdge :: (Sized b, TrieKey k m) => ([k] -> a -> b) -> Edge k m a -> Edge k m b
+mapEdge f (Edge _ ks v ts) = edge ks (fmap (f ks) v) (mapWithKeyAlg (\ l -> mapEdge (\ ls -> f (ks ++ l:ls))) ts)
+
+splitLookupEdge :: (Sized a, 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)
+splitLookupEdge f ks e@(Edge s ls v ts) = procEdge ks ls where
+ procEdge (k:ks) (l:ls) = case compareKey k l of
+ LT -> (Nothing, Nothing, Just e)
+ GT -> (Just e, Nothing, Nothing)
+ EQ -> procEdge ks ls
+ procEdge (k:ks) [] = case splitLookupAlg g k ts of
+ (tsL, ans, tsR) -> (guardNullEdge (edge ls v tsL), ans, guardNullEdge (edge ls Nothing tsR))
+ where g = splitLookupEdge f ks
+ procEdge [] (l:ls) = (Nothing, Nothing, Just e)
+ procEdge [] [] = case v of
+ Nothing -> (Nothing, Nothing, Just e)
+ Just v -> case f v of
+ (vL, ans, vR) -> (single ls vL, ans, guardNullEdge (edge ls vR ts))
+
+isSubEdge :: (TrieKey k m, Sized a, Sized b) => (a -> b -> Bool) -> Edge k m a -> Edge k m b -> Bool
+isSubEdge (<=) (Edge sK ks vK tsK) (Edge _ 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
+ = isSubEdge (<=) (Edge sK ks vK tsK) e'
+ procEdge [] [] = isSubmapAlg (<=) vK vL && isSubmapAlg (isSubEdge (<=)) tsK tsL
+
+getMinEdge :: (TrieKey k m, Sized a) => Edge k m a -> Maybe (([k], a), MEdge k m a)
+getMinEdge (Edge s ks (Just v) ts) = Just ((ks, v), guardNullEdge (Edge (s - getSize v) ks Nothing ts))
+getMinEdge (Edge _ ks Nothing ts) = do
+ ((l, e'), ts') <- getMinAlg ts
+ ((ls, v), e'') <- getMinEdge e'
+ return ((ks ++ l:ls, v), fmap (edge ks Nothing) (maybe (guardNullAlg ts')
+ (\ e'' -> Just $ snd $ updateMinAlg (\ _ _ -> (False, Just e'')) ts) e''))
+
+getMaxEdge :: (TrieKey k m, Sized a) => Edge k m a -> Maybe (([k], a), MEdge k m a)
+getMaxEdge (Edge _ ks v0 ts)
+ | nullAlg ts = maybe Nothing (\ v -> Just ((ks, v), Nothing)) v0
+ | otherwise = do
+ ((l, e'), ts') <- getMaxAlg ts
+ ((ls, v), e'') <- getMaxEdge e'
+ return ((ks ++ l:ls, v), fmap (edge ks Nothing) (maybe (guardNullAlg ts')
+ (\ e'' -> Just $ snd $ updateMaxAlg (\ _ _ -> (False, Just e'')) ts) e''))
+
+updateMinEdge :: (TrieKey k m, Sized a) => ([k] -> a -> (Bool, Maybe a)) -> Edge k m a -> (Bool, MEdge k m a)
+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 g ts) where
+ g l = updateMinEdge (\ ls -> f (ks ++ l:ls))
+
+updateMaxEdge :: (TrieKey k m, Sized a) => ([k] -> a -> (Bool, Maybe a)) -> Edge k m a -> (Bool, MEdge k m a)
+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) (updateMinAlg g ts) where
+ g l = updateMinEdge (\ ls -> f (ks ++ l:ls))
-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
+unionEdge :: (TrieKey k m, Sized a) => ([k] -> a -> a -> Maybe a) -> Edge k m a -> Edge k m a -> MEdge k m a
+unionEdge f (Edge sK ks0 vK tsK) (Edge sL 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 (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, 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
+ | otherwise = Just (Edge (sK + sL) (take i ks0) Nothing
+ (insertAlg k (Edge sK ks vK tsK) $ singletonAlg l (Edge sL ls vL tsL)))
+ procEdge _ (k:ks) [] = guardNullEdge $ edge ls0 vL $ alterAlg g k tsL where
+ g Nothing = Just (Edge sK ks vK tsK)
+ g (Just e) = unionEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge sK ks vK tsK) e
+ procEdge _ [] (l:ls) = guardNullEdge $ edge ks0 vK $ alterAlg g l tsK where
+ g Nothing = Just (Edge sL ls vL tsL)
+ g (Just e) = unionEdge (\ ls' -> f (ks0 ++ l:ls')) e (Edge sL ls vL tsL)
+ procEdge _ [] [] = guardNullEdge $ edge ks0 (unionMaybe (f ks0) vK vL) $
+ unionMaybeAlg (\ x -> unionEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL
+
+intersectEdge :: (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 sK ks0 vK tsK) (Edge sL 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 nX xs vX tsX <- intersectEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge nK ks vK tsK) e'
- return (Edge nX (ls0 ++ k:xs) vX tsX)
+ Edge sX xs vX tsX <- intersectEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge sK ks vK tsK) e'
+ return (Edge sX (ls0 ++ k:xs) vX tsX)
procEdge [] (l:ls) = do
e' <- lookupAlg l tsK
- 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
+ Edge sX xs vX tsX <- intersectEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge sL ls vL tsL)
+ return (Edge sX (ks0 ++ l:xs) vX tsX)
+ procEdge [] [] = guardNullEdge $ edge ks0 (intersectMaybe (f ks0) vK vL)
+ (intersectAlg (\ x -> intersectEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL)
-{-# 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
+differenceEdge :: (TrieKey k m, Sized a) => ([k] -> a -> b -> Maybe a) -> Edge k m a -> Edge k m b -> MEdge k m a
+differenceEdge f e@(Edge sK ks0 vK tsK) (Edge sL 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 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 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
-
-{-# 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')
-getMinEdge _ = error "Uncompacted edge"
-
-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 nK ks (Just v) ts) = ((ks, v), guardNullEdge $ Edge (nK - getSize v) ks Nothing ts)
-getMaxEdge _ = error "Uncompacted edge"
-
-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, 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 => (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 <- lookup k tsL
- = isSubmapEdge (==) (<=) lookup (<<=) (Edge nK ks vK tsK) e
- procEdge [] []
- | Nothing <- vK = tsK <<= tsL
- | Just x <- vK, Just y <- vL, x <= y
- = tsK <<= tsL
- procEdge _ _ = False
-validEdge :: TrieKey k m => Edge k m v -> Bool
-validEdge (Edge _ _ Nothing m)
- | nullAlg m = False
- | Just{} <- getSingleAlg m
- = False
-validEdge (Edge _ _ _ m)
- = valid m && all validEdge m
-
-
-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 -> answerLess
- EQ -> procEdge ks ls
- 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) = 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 = answerLess -- all children of e match ks0 initially but are longer, and v is Nothing
- \ No newline at end of file
+ = do Edge sX xs vX tsX <- differenceEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge sK ks vK tsK) e'
+ return (Edge sX (ls0 ++ k:xs) vX tsX)
+ procEdge [] (l:ls) = guardNullEdge $ edge ks0 vK (alterAlg (>>= g) l tsK) where
+ g e = differenceEdge (\ ls' -> f (ks0 ++ l:ls')) e (Edge sL ls vL tsL)
+ procEdge [] [] = guardNullEdge $ edge ks0 (intersectMaybe (f ks0) vK vL) $
+ intersectAlg (\ x -> intersectEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL
+ procEdge _ _ = Just e \ No newline at end of file
diff --git a/TrieMap/Reflection.hs b/TrieMap/Reflection.hs
index 1118c6d..a07c552 100644
--- a/TrieMap/Reflection.hs
+++ b/TrieMap/Reflection.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances #-}
+{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances #-}
module TrieMap.Reflection where
@@ -11,21 +11,37 @@ import TrieMap.RadixTrie()
import qualified TrieMap.TrieAlgebraic as TA
instance Algebraic v => Algebraic (Elem v) where
- type Alg (Elem v) = Alg v
+ type AlgRep (Elem v) = AlgRep 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
- fromAlg = PMap . fromAlg
+-- instance Algebraic (t1 k (m2 v)) => Algebraic (ProdMap m1 m2 v) where
+-- type AlgRep (ProdMap m1 m2 v) = AlgRep (m1 (m2 v))
+-- toAlg (PMap m) = toAlg m
+-- fromAlg = PMap . fromAlg
+--
+-- instance (Ord k, Algebraic k, Sized v, Algebraic v, TrieKey k m) => Algebraic (RadixTrie k m v) where
+-- type AlgRep (RadixTrie k m v) = AlgRep [([k], v)]
+-- toAlg m = toAlg (build (\ c n -> foldWithKeyAlg (curry c) n m))
+-- fromAlg = fromDistAscListAlg . fromAlg
-instance (Algebraic (m1 v), Algebraic (m2 v)) => Algebraic (UnionMap m1 m2 v) where
- type Alg (UnionMap m1 m2 v) = (Alg (m1 v), Alg (m2 v))
- toAlg (m1 :+: m2) = (toAlg m1, toAlg m2)
- fromAlg (m1, m2) = fromAlg m1 :+: fromAlg m2
+instance (Algebraic k, TrieKey k m) => SAlgebraicT (RadixTrie k m) where
+ type SAlgRepT (RadixTrie k m) = AlgRepT ([] `O` ((,) [k]))
+ toSAlgT = toAlgT . o . assocsAlg
+ fromSAlgT = fromDistAscListAlg . unO . fromAlgT
-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 \ No newline at end of file
+-- instance (AlgebraicT m, Algebraic k) => SAlgebraicT (Edge k m) where
+-- type SAlgRepT (Edge k m) = AlgRepT (O Fix (O ((:*:) (Const Int :*: Co{--}nst [k] :*: AlgRepT m)) (O Const Maybe)))
+
+
+instance (AlgebraicT m, Algebraic k, Algebraic a) => Algebraic (Edge k m a) where
+ type AlgRep (Edge k m a) = Fix (AlgRepT (Const (Int, [k], Maybe a)) :*: AlgRepT m)
+ toAlg (Edge s ks v ts) = Fix (toAlgT (Const (s, ks, v)) :*: fmap toAlg (toAlgT ts))
+ fromAlg (Fix (a :*: b)) = case (fromAlgT a, fmap fromAlg b) of
+ (Const (s, ks, v), ts) ->
+ Edge s ks v (fromAlgT ts)
+
+instance (AlgebraicT m, Algebraic k, Algebraic a) => Algebraic (RadixTrie k m a) where
+ type AlgRep (RadixTrie k m a) = AlgRep (Maybe (Edge k m a))
+ toAlg (Radix e) = toAlg e
+ fromAlg = Radix . fromAlg \ No newline at end of file
diff --git a/TrieMap/TrieAlgebraic.hs b/TrieMap/TrieAlgebraic.hs
index b235b02..b2893aa 100644
--- a/TrieMap/TrieAlgebraic.hs
+++ b/TrieMap/TrieAlgebraic.hs
@@ -1,7 +1,7 @@
-{-# 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
+{-# LANGUAGE TypeFamilies, FlexibleInstances, TypeOperators, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, PatternGuards, IncoherentInstances, TypeOperators #-}
+module TrieMap.TrieAlgebraic where
+import Control.Arrow ((***))
import Data.Traversable
import Data.Foldable
import Data.Either
@@ -15,8 +15,7 @@ import qualified Data.IntMap as IMap
import qualified Data.Map as Map
import Control.Monad
-import Control.Applicative hiding (Alternative(..))
-
+import Control.Applicative hiding (Alternative(..), Const(..))
import GHC.Exts (build)
import TrieMap.Applicative
@@ -33,33 +32,77 @@ instance Show k => Show (Ordered k) where
instance Functor Ordered where
fmap f (Ord x) = Ord (f x)
+type L a = Fix (Const () :+: (Const a :*: Id))
+
+class EqT f => TrieKeyT f t | f -> t, t -> f where
+ compareKeyT :: TrieKey k m => f k -> f k -> Ordering
+ emptyT :: (Sized a, TrieKey k m) => t k m a
+ nullT :: (Sized a, TrieKey k m) => t k m a -> Bool
+ guardNullT :: (Sized a, TrieKey k m) => t k m a -> Maybe (t k m a)
+ sizeT :: (Sized a, TrieKey k m) => t k m a -> Int
+ getSingleT :: (Sized a, TrieKey k m) => t k m a -> Maybe (f k, a)
+ alterLookupT :: (Sized a, TrieKey k m) =>
+ (Maybe a -> (b, Maybe a)) -> f k -> t k m a -> (b, t k m a)
+ lookupT :: (Sized a, TrieKey k m) => f k -> t k m a -> Maybe a
+ foldWithKeyT :: (TrieKey k m) => (f k -> a -> b -> b) -> b -> t k m a -> b
+ mapAppT :: (Applicative g, Sized a, Sized b, TrieKey k m) =>
+ (f k -> a -> g b) -> t k m a -> g (t k m b)
+ mapMaybeT :: (Sized a, Sized b, TrieKey k m) =>
+ (f k -> a -> Maybe b) -> t k m a -> t k m b
+ mapEitherT :: (Sized a, Sized b, Sized c, TrieKey k m) =>
+ (f k -> a -> (Maybe b, Maybe c)) -> t k m a -> (t k m b, t k m c)
+ unionT :: (Sized a, TrieKey k m) => (f k -> a -> a -> Maybe a) -> t k m a -> t k m a -> t k m a
+ intersectT :: (Sized a, Sized b, Sized c, TrieKey k m) =>
+ (f k -> a -> b -> Maybe c) -> t k m a -> t k m b -> t k m c
+ differenceT :: (Sized a, Sized b, TrieKey k m) => (f k -> a -> b -> Maybe a) -> t k m a -> t k m b -> t k m a
+ fromDistAscListT :: (Sized a, TrieKey k m) => [(f k, a)] -> t k m a
+ fromAscListT :: (Sized a, TrieKey k m) => (f k -> a -> a -> a) -> [(f k, a)] -> t k m a
+ fromListT :: (Sized a, TrieKey k m) => (f k -> a -> a -> a) -> [(f k, a)] -> t k m a
+ getMinT :: (Sized a, TrieKey k m) => t k m a -> Maybe ((f k, a), t k m a)
+ getMaxT :: (Sized a, TrieKey k m) => t k m a -> Maybe ((f k, a), t k m a)
+ updateMinT :: (Sized a, TrieKey k m) => (f k -> a -> (Bool, Maybe a)) -> t k m a -> (Bool, t k m a)
+ updateMaxT :: (Sized a, TrieKey k m) => (f k -> a -> (Bool, Maybe a)) -> t k m a -> (Bool, t k m a)
+ isSubmapT :: (Sized a, Sized b, TrieKey k m) => (a -> b -> Bool) -> t k m a -> t k m b -> Bool
+ splitLookupT :: (Sized a, TrieKey k m) => (a -> (Maybe a, Maybe b, Maybe a)) -> f k -> t k m a -> (t k m a, Maybe b, t k m a)
+
+ guardNullT m
+ | nullT m = Nothing
+ | otherwise = Just m
+
+eqKey :: TrieKey k m => k -> k -> Bool
+eqKey a b = compareKey a b == EQ
+
+eqKeyT :: (TrieKey k m, TrieKeyT f t) => f k -> f k -> Bool
+eqKeyT a b = compareKeyT a b == EQ
+
-- | 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 :: 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)
+class Eq k => TrieKey k m | k -> m, m -> k where
+ compareKey :: k -> k -> Ordering
+ emptyAlg :: Sized a => m a
+ nullAlg :: Sized a => m a -> Bool
+ sizeAlg :: Sized a => m a -> Int
+ getSingleAlg :: Sized a => m a -> Maybe (k, a)
+ guardNullAlg :: Sized a => m a -> Maybe (m a)
-- {-# 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)
+ alterLookupAlg :: Sized a => (Maybe a -> (b, Maybe a)) -> k -> m a -> (b, m a)
+ lookupAlg :: Sized a => k -> m a -> Maybe a
+ foldWithKeyAlg :: (k -> a -> b -> b) -> b -> m a -> b
+ mapAppAlg :: (Applicative f, Sized a, Sized b) => (k -> a -> f b) -> m a -> f (m b)
+ mapMaybeAlg :: (Sized a, Sized b) => (k -> a -> Maybe b) -> m a -> m b
+ mapEitherAlg :: (Sized a, Sized b, Sized c) => (k -> a -> (Maybe b, Maybe c)) -> m a -> (m b, m c)
+ unionMaybeAlg :: Sized a => (k -> a -> a -> Maybe a) -> m a -> m a -> m a
+ intersectAlg :: (Sized a, Sized b, Sized c) => (k -> a -> b -> Maybe c) -> m a -> m b -> m c
+ differenceAlg :: (Sized a, Sized b) => (k -> a -> b -> Maybe a) -> m a -> m b -> m a
+ fromDistAscListAlg :: Sized a => [(k, a)] -> m a
+ fromAscListAlg :: Sized a => (k -> a -> a -> a) -> [(k, a)] -> m a
+ fromListAlg :: Sized a => (k -> a -> a -> a) -> [(k, a)] -> m a
+ getMinAlg :: Sized a => m a -> Maybe ((k, a), m a)
+ getMaxAlg :: Sized a => m a -> Maybe ((k, a), m a)
+ updateMinAlg :: Sized a => (k -> a -> (Bool, Maybe a)) -> m a -> (Bool, m a)
+ updateMaxAlg :: Sized a => (k -> a -> (Bool, Maybe a)) -> m a -> (Bool, m a)
+ valid :: Sized a => m a -> Bool
+ isSubmapAlg :: (Sized a, Sized b) => (a -> b -> Bool) -> m a -> m b -> Bool
+ splitLookupAlg :: (Sized a) => (a -> (Maybe a, Maybe b, Maybe a)) -> k -> m a -> (m a, Maybe b, m a)
lookupAlg k = fst . alterLookupAlg (\ v -> (v, v)) k
guardNullAlg m
@@ -73,24 +116,52 @@ class (Eq a, Foldable m, Traversable m) => TrieKey a m | a -> m, m -> a where
fromAscListAlg _ [] = emptyAlg
fromAscListAlg f ((k, v):xs) = fromDistAscListAlg (distinct k v xs) where
distinct k v ((k', v'):xs)
- | k == k' = distinct k (f k v v') xs
+ | k `eqKey` k' = distinct k (f k v v') xs
| otherwise = (k, v):distinct k' v' xs
distinct k v [] = [(k, v)]
fromDistAscListAlg = fromListAlg'
- sizeAlg = foldl' (\ n _ -> n + 1) 0
+ sizeAlg = foldWithKeyAlg (\ _ x n -> n + getSize x) 0
updateMinAlg f m = maybe (False, m) (\ ((k, v), m') -> maybe m' (\ v' -> insertAlg k v' m) <$> f k v) (getMinAlg m)
updateMaxAlg f m = maybe (False, m) (\ ((k, v), m') -> maybe m' (\ v' -> insertAlg k v' m) <$> f k v) (getMaxAlg m)
valid = (`seq` True)
-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) #-}
+instance TrieKeyT f t => TrieKey (Fix f) (FixMap f t) where
+ compareKey (Fix a) (Fix b) = compareKeyT a b
+ emptyAlg = FixMap emptyT
+ nullAlg (FixMap m) = nullT m
+ sizeAlg (FixMap m) = sizeT m
+ getSingleAlg (FixMap m) = do
+ (k, v) <- getSingleT m
+ return (Fix k, v)
+ lookupAlg (Fix k) (FixMap m) = lookupT k m
+ alterLookupAlg f (Fix k) (FixMap m) = FixMap <$> alterLookupT f k m
+ foldWithKeyAlg f z (FixMap m) = foldWithKeyT (f . Fix) z m
+ mapAppAlg f (FixMap m) = FixMap <$> mapAppT (f . Fix) m
+ mapMaybeAlg f (FixMap m) = FixMap (mapMaybeT (f . Fix) m)
+ mapEitherAlg f (FixMap m) = case mapEitherT (f . Fix) m of
+ (mL, mR) -> (FixMap mL, FixMap mR)
+ unionMaybeAlg f (FixMap m1) (FixMap m2) = FixMap (unionT (f . Fix) m1 m2)
+ intersectAlg f (FixMap m1) (FixMap m2) = FixMap (intersectT (f . Fix) m1 m2)
+ differenceAlg f (FixMap m1) (FixMap m2) = FixMap (differenceT (f . Fix) m1 m2)
+ getMinAlg (FixMap m) = do
+ (~(k, v), m') <- getMinT m
+ return ((Fix k, v), FixMap m')
+ getMaxAlg (FixMap m) = do
+ (~(k, v), m') <- getMaxT m
+ return ((Fix k, v), FixMap m')
+ updateMinAlg f (FixMap m) = FixMap <$> updateMinT (f . Fix) m
+ updateMaxAlg f (FixMap m) = FixMap <$> updateMaxT (f . Fix) m
+ isSubmapAlg (<=) (FixMap m1) (FixMap m2) = isSubmapT (<=) m1 m2
+ splitLookupAlg f (Fix k) (FixMap m) = case splitLookupT f k m of
+ (mL, ans, mR) -> (FixMap mL, ans, FixMap mR)
+
+instance (Sized a, TrieKey k m) => Sized (m a) where
getSize = sizeAlg
+instance (Sized a, TrieKey k m, TrieKeyT f t) => Sized (t k m a) where
+ getSize = sizeT
+
fromListAlg' :: (Sized v, TrieKey k m) => [(k, v)] -> m v
fromListAlg' = fromListAlg (const const)
@@ -100,15 +171,30 @@ singletonAlg k v = insertAlg k v emptyAlg
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)
+mapWithKeyT :: (Sized v, Sized w, TrieKeyT f t, TrieKey k m) => (f k -> v -> w) -> t k m v -> t k m w
+mapWithKeyT f m = unId (mapAppT (\ k v -> Id (f k v)) m)
+
+mapAlg :: (Sized v, Sized w, TrieKey k m) => (v -> w) -> m v -> m w
+mapAlg = mapWithKeyAlg . const
+
+mapT :: (Sized v, Sized w, TrieKeyT f t, TrieKey k m) => (v -> w) -> t k m v -> t k m w
+mapT = mapWithKeyT . const
+
-- 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 :: (Sized v, TrieKey k m) => k -> v -> m v -> m v
insertAlg k v = alterAlg (const (Just v)) k
+insertT :: (Sized v, TrieKey k m, TrieKeyT f t) => f k -> v -> t k m v -> t k m v
+insertT k v = alterT (const (Just v)) k
+
alterAlg :: (Sized v, TrieKey k m) => (Maybe v -> Maybe v) -> k -> m v -> m v
alterAlg f k = snd . alterLookupAlg (\ x -> ((), f x)) k
+alterT :: (Sized v, TrieKey k m, TrieKeyT f t) => (Maybe v -> Maybe v) -> f k -> t k m v -> t k m v
+alterT f k = snd . alterLookupT (\ 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)
@@ -138,131 +224,480 @@ filterRight _ (Right x) = Just x
filterRight _ _ = Nothing
{-# INLINE assocsAlg #-}
-assocsAlg :: (Sized a, TrieKey k m) => m a -> [(k, a)]
+assocsAlg :: (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) = sizeAlg m
- getSingleAlg (PMap m) = do (k1, m') <- getSingleAlg m
- (k2, v) <- getSingleAlg m'
- return ((k1, k2), v)
- alterLookupAlg f (k1, k2) (PMap m) = PMap <$> alterLookupAlg g k1 m
- where g = fmap guardNullAlg . alterLookupAlg f k2 . fromMaybe emptyAlg
- lookupAlg (k1, k2) (PMap m) = lookupAlg k1 m >>= lookupAlg k2
- foldWithKeyAlg f z (PMap m) = foldWithKeyAlg (\ k1 -> flip (foldWithKeyAlg (\ k2 -> f (k1, k2)))) z m
- mapAppAlg f (PMap m) =
- 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 (\ (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 (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
- ((k1, m'), m1') <- getMinAlg m
- ((k2, v), m2') <- getMinAlg m'
- return (((k1, k2), v), PMap (maybe m1' (\ m2' -> insertAlg k1 m2' m) (guardNullAlg m2')))
- getMaxAlg (PMap m) = do
- ((k1, m'), m1') <- getMaxAlg m
- ((k2, v), m2') <- getMaxAlg m'
- return (((k1, k2), v), PMap (maybe m1' (\ m2' -> insertAlg k1 m2' m) (guardNullAlg m2')))
- updateMinAlg f (PMap m) =
- PMap <$> updateMinAlg (\ k1 -> guardNullAlg <.> updateMinAlg (\ k2 -> f (k1, k2))) m
- updateMaxAlg f (PMap m) =
- PMap <$> updateMaxAlg (\ k1 -> guardNullAlg <.> updateMaxAlg (\ k2 -> f (k1, k2))) m
- isSubmapAlg (<=) (PMap m1) (PMap m2) =
- isSubmapAlg (isSubmapAlg (<=)) m1 m2
-
- splitLookupAlg f (k1, k2) (PMap m) = case splitLookupAlg g k1 m of
+instance (TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKeyT (f1 :*: f2) (t1 `ProdMap` t2) where
+ compareKeyT (a :*: x) (b :*: y) = compareKeyT a b `mappend` compareKeyT x y
+ emptyT = PMap emptyT
+ nullT (PMap m) = nullT m
+ sizeT (PMap m) = sizeT m
+ getSingleT (PMap m) = do
+ (k1, m') <- getSingleT m
+ (k2, v) <- getSingleT m'
+ return (k1 :*: k2, v)
+ lookupT (k1 :*: k2) (PMap m) = lookupT k1 m >>= lookupT k2
+ alterLookupT f (k1 :*: k2) (PMap m) = PMap <$> alterLookupT g k1 m where
+ g = fmap guardNullT . alterLookupT f k2 . fromMaybe emptyT
+ foldWithKeyT f z (PMap m) = foldWithKeyT (\ k1 -> flip (foldWithKeyT (\ k2 -> f (k1 :*: k2)))) z m
+ mapAppT f (PMap m) = PMap <$> mapAppT (\ k1 -> mapAppT (\ k2 -> f (k1 :*: k2))) m
+ mapMaybeT f (PMap m) = PMap (mapMaybeT (\ k1 -> guardNullT . mapMaybeT (\ k2 -> f (k1 :*: k2))) m)
+ mapEitherT f (PMap m) = (PMap *** PMap) (mapEitherT (\ k1 -> (guardNullT *** guardNullT) . mapEitherT (\ k2 -> f (k1 :*: k2))) m)
+ unionT f (PMap m1) (PMap m2) = PMap (unionT (\ k1 -> guardNullT .: unionT (\ k2 -> f (k1 :*: k2))) m1 m2)
+ intersectT f (PMap m1) (PMap m2) = PMap (intersectT (\ k1 -> guardNullT .: intersectT (\ k2 -> f (k1 :*: k2))) m1 m2)
+ differenceT f (PMap m1) (PMap m2) = PMap (differenceT (\ k1 -> guardNullT .: differenceT (\ k2 -> f (k1 :*: k2))) m1 m2)
+ fromListT f xs = PMap $ mapWithKeyT (\ k1 (Elem xs) -> fromListT (\ k2 -> f (k1 :*: k2)) xs) $
+ fromListT (\ _ (Elem x) (Elem y) -> Elem (x ++ y)) [(k1, Elem [(k2, v)]) | ((k1 :*: k2), v) <- xs]
+ fromDistAscListT xs = PMap $ fromDistAscListT [(k1, fromDistAscListT ys) | (k1, ys) <- breakFst eqKeyT xs]
+ fromAscListT f xs = PMap $ fromDistAscListT [(k1, fromAscListT (\ k2 -> f (k1 :*: k2)) ys) | (k1, ys) <- breakFst eqKeyT xs]
+ getMinT (PMap m) = do
+ ((k1, m'), m1') <- getMinT m
+ ((k2, v), m2') <- getMinT m'
+ return ((k1 :*: k2, v), PMap (maybe m1' (\ m2' -> insertT k1 m2' m) (guardNullT m2')))
+ getMaxT (PMap m) = do
+ ((k1, m'), m1') <- getMaxT m
+ ((k2, v), m2') <- getMaxT m'
+ return ((k1 :*: k2, v), PMap (maybe m1' (\ m2' -> insertT k1 m2' m) (guardNullT m2')))
+ updateMinT f (PMap m) =
+ PMap <$> updateMinT (\ k1 -> guardNullT <.> updateMinT (\ k2 -> f (k1 :*: k2))) m
+ updateMaxT f (PMap m) =
+ PMap <$> updateMaxT (\ k1 -> guardNullT <.> updateMaxT (\ k2 -> f (k1 :*: k2))) m
+ isSubmapT (<=) (PMap m1) (PMap m2) =
+ isSubmapT (isSubmapT (<=)) m1 m2
+ splitLookupT f (k1 :*: k2) (PMap m) = case splitLookupT g k1 m of
(mL, ans, mR) -> (PMap mL, ans, PMap mR)
- where g m' = case splitLookupAlg f k2 m' of
- (mL, ans, mR) -> (guardNullAlg mL, ans, guardNullAlg mR)
-
- valid (PMap m) = valid m && all valid m && not (any nullAlg m)
-
-breakFst :: (Eq k1, Eq k2) => [((k1, k2), v)] -> [(k1, [(k2, v)])]
-breakFst [] = []
-breakFst (((k1, k2), x):xs) = breakFst' k1 (Seq.singleton (k2, x)) xs where
- breakFst' k xs (((k', k2), x):xss)
- | k == k' = breakFst' k ((Seq.|>) xs (k2, x)) xss
+ where g m' = case splitLookupT f k2 m' of
+ (mL, ans, mR) -> (guardNullT mL, ans, guardNullT mR)
+
+instance (Eq (f1 k), Eq (f2 k), TrieKey k m, TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKey ((f1 :*: f2) k) (ProdMap t1 t2 k m) where
+ compareKey = compareKeyT
+ emptyAlg = emptyT
+ nullAlg = nullT
+ getSingleAlg = getSingleT
+ guardNullAlg = guardNullT
+ sizeAlg = sizeT
+ lookupAlg = lookupT
+ alterLookupAlg = alterLookupT
+ mapAppAlg = mapAppT
+ mapMaybeAlg = mapMaybeT
+ mapEitherAlg = mapEitherT
+ foldWithKeyAlg = foldWithKeyT
+ unionMaybeAlg = unionT
+ intersectAlg = intersectT
+ differenceAlg = differenceT
+ getMinAlg = getMinT
+ getMaxAlg = getMaxT
+ updateMinAlg = updateMinT
+ updateMaxAlg = updateMaxT
+ isSubmapAlg = isSubmapT
+ splitLookupAlg = splitLookupT
+
+breakFst :: (f1 k -> f1 k -> Bool) -> [((f1 :*: f2) k, v)] -> [(f1 k, [(f2 k, v)])]
+breakFst _ [] = []
+breakFst eq (((k1 :*: k2), x):xs) = breakFst' k1 (Seq.singleton (k2, x)) xs where
+ breakFst' k xs (((k' :*: k2), x):xss)
+ | k `eq` k' = breakFst' k ((Seq.|>) xs (k2, x)) xss
| otherwise = (k, toList xs):breakFst' k' (Seq.singleton (k2, x)) xss
breakFst' k xs [] = [(k, toList xs)]
-instance (TrieKey a1 m1, TrieKey a2 m2) => TrieKey (Either a1 a2) (m1 `UnionMap` m2) where
- emptyAlg = emptyAlg :+: emptyAlg
- nullAlg (m1 :+: m2) = nullAlg m1 && nullAlg m2
- sizeAlg (m1 :+: m2) = sizeAlg m1 + sizeAlg m2
- getSingleAlg (m1 :+: m2) = case (getSingleAlg m1, getSingleAlg m2) of
+instance (TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKeyT (f1 :+: f2) (UnionMap t1 t2) where
+ compareKeyT (A a) (A b) = compareKeyT a b
+ compareKeyT (B x) (B y) = compareKeyT x y
+ compareKeyT A{} B{} = LT
+ compareKeyT B{} A{} = GT
+ emptyT = UMap emptyT emptyT
+ nullT (UMap m1 m2) = nullT m1 && nullT m2
+ getSingleT (UMap m1 m2) = case (getSingleT m1, getSingleT m2) of
+ (Just (k, v), Nothing) -> Just (A k, v)
+ (Nothing, Just (k, v)) -> Just (B k, v)
+ _ -> Nothing
+ sizeT (UMap m1 m2) = sizeT m1 + sizeT m2
+ lookupT (A k) (UMap m1 _) = lookupT k m1
+ lookupT (B k) (UMap _ m2) = lookupT k m2
+ alterLookupT f (A k) (UMap m1 m2) = (`UMap` m2) <$> alterLookupT f k m1
+ alterLookupT f (B k) (UMap m1 m2) = UMap m1 <$> alterLookupT f k m2
+ foldWithKeyT f z (UMap m1 m2) = foldWithKeyT (f . A) (foldWithKeyT (f . B) z m2) m1
+ mapAppT f (UMap m1 m2) = UMap <$> mapAppT (f . A) m1 <*> mapAppT (f . B) m2
+ mapMaybeT f (UMap m1 m2) = UMap (mapMaybeT (f . A) m1) (mapMaybeT (f . B) m2)
+ mapEitherT f (UMap m1 m2) = (UMap m1L m2L, UMap m1R m2R)
+ where (m1L, m1R) = mapEitherT (f . A) m1
+ (m2L, m2R) = mapEitherT (f . B) m2
+ unionT f (UMap m11 m12) (UMap m21 m22) =
+ UMap (unionT (f . A) m11 m21) (unionT (f . B) m12 m22)
+ intersectT f (UMap m11 m12) (UMap m21 m22) =
+ UMap (intersectT (f . A) m11 m21) (intersectT (f . B) m12 m22)
+ differenceT f (UMap m11 m12) (UMap m21 m22) =
+ UMap (differenceT (f . A) m11 m21) (differenceT (f . B) m12 m22)
+ getMinT (UMap m1 m2)
+ | Just ~(~(k, v), m1') <- getMinT m1
+ = Just ((A k, v), UMap m1' m2)
+ | Just ~(~(k, v), m2') <- getMinT m2
+ = Just ((B k, v), UMap m1 m2')
+ | otherwise = Nothing
+ getMaxT (UMap m1 m2)
+ | Just ~(~(k, v), m2') <- getMaxT m2
+ = Just ((B k, v), UMap m1 m2')
+ | Just ~(~(k, v), m1') <- getMaxT m1
+ = Just ((A k, v), UMap m1' m2)
+ | otherwise = Nothing
+ updateMinT f (UMap m1 m2)
+ | nullT m1 = UMap m1 <$> updateMinT (f . B) m2
+ | otherwise = (`UMap` m2) <$> updateMinT (f . A) m1
+ updateMaxT f (UMap m1 m2)
+ | nullT m2 = (`UMap` m2) <$> updateMaxT (f . A) m1
+ | otherwise = UMap m1 <$> updateMaxT (f . B) m2
+ fromDistAscListT xs = UMap (fromDistAscListT ys) (fromDistAscListT zs)
+ where (ys, zs) = partitionEithers' (map pullEither xs)
+ fromAscListT f xs = UMap (fromAscListT (f . A) ys) (fromAscListT (f . B) zs)
+ where (ys, zs) = partitionEithers' (map pullEither xs)
+ fromListT f xs = UMap (fromListT (f . A) ys) (fromListT (f . B) zs)
+ where (ys, zs) = partitionEithers' (map pullEither xs)
+ isSubmapT (<=) (UMap m11 m12) (UMap m21 m22) = isSubmapT (<=) m11 m21 && isSubmapT (<=) m12 m22
+ splitLookupT f (A k) (UMap m1 m2) = case splitLookupT f k m1 of
+ (m1L, ans, m1R) -> (UMap m1L emptyT, ans, UMap m1R m2)
+ splitLookupT f (B k) (UMap m1 m2) = case splitLookupT f k m2 of
+ (m2L, ans, m2R) -> (UMap m1 m2L, ans, UMap emptyT m2R)
+
+instance (Eq (f1 k), Eq (f2 k), TrieKey k m, TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKey ((f1 :+: f2) k) (UnionMap t1 t2 k m) where
+ compareKey = compareKeyT
+ emptyAlg = emptyT
+ nullAlg = nullT
+ getSingleAlg = getSingleT
+ guardNullAlg = guardNullT
+ sizeAlg = sizeT
+ lookupAlg = lookupT
+ alterLookupAlg = alterLookupT
+ mapAppAlg = mapAppT
+ mapMaybeAlg = mapMaybeT
+ mapEitherAlg = mapEitherT
+ foldWithKeyAlg = foldWithKeyT
+ unionMaybeAlg = unionT
+ intersectAlg = intersectT
+ differenceAlg = differenceT
+ getMinAlg = getMinT
+ getMaxAlg = getMaxT
+ updateMinAlg = updateMinT
+ updateMaxAlg = updateMaxT
+ isSubmapAlg = isSubmapT
+ splitLookupAlg = splitLookupT
+
+instance TrieKey k m => TrieKeyT ((,) k) (CProdMap m) where
+ compareKeyT (a, x) (b, y) = compareKey a b `mappend` compareKey x y
+ emptyT = CPMap emptyAlg
+ nullT (CPMap m) = nullAlg m
+ getSingleT (CPMap m) = do
+ (k1, m') <- getSingleAlg m
+ (k2, v) <- getSingleAlg m'
+ return ((k1, k2), v)
+ guardNullT (CPMap m) = CPMap <$> guardNullAlg m
+ sizeT (CPMap m) = sizeAlg m
+ lookupT (k1, k2) (CPMap m) = lookupAlg k1 m >>= lookupAlg k2
+ alterLookupT f (k1, k2) (CPMap m) = CPMap <$> alterLookupAlg g k1 m where
+ g = guardNullAlg <.> alterLookupAlg f k2 . fromMaybe emptyAlg
+ foldWithKeyT f z (CPMap m) = foldWithKeyAlg (\ k1 -> flip $ foldWithKeyAlg (\ k2 -> f (k1, k2))) z m
+ mapAppT f (CPMap m) = CPMap <$> mapAppAlg (\ k1 -> mapAppAlg (\ k2 -> f (k1, k2))) m
+ mapMaybeT f (CPMap m) = CPMap (mapMaybeAlg (\ k1 -> guardNullAlg . mapMaybeAlg (\ k2 -> f (k1, k2))) m)
+ mapEitherT f (CPMap m) = (CPMap *** CPMap) (mapEitherAlg (\ k1 -> (guardNullAlg *** guardNullAlg) . mapEitherAlg (\ k2 -> f (k1, k2))) m)
+ unionT f (CPMap m1) (CPMap m2) =
+ CPMap (unionMaybeAlg (\ k1 -> guardNullAlg .: unionMaybeAlg (\ k2 -> f (k1, k2))) m1 m2)
+ intersectT f (CPMap m1) (CPMap m2) =
+ CPMap (intersectAlg (\ k1 -> guardNullAlg .: intersectAlg (\ k2 -> f (k1, k2))) m1 m2)
+ differenceT f (CPMap m1) (CPMap m2) =
+ CPMap (differenceAlg (\ k1 -> guardNullAlg .: differenceAlg (\ k2 -> f (k1, k2))) m1 m2)
+ getMinT (CPMap m) = do
+ ((k1, m1), m') <- getMinAlg m
+ ((k2, v), m1') <- getMinAlg m1
+ return (((k1, k2), v), CPMap $ maybe m' (\ m1' -> snd $ updateMinAlg (\ _ _ -> (False, Just m1')) m) (guardNullAlg m1'))
+ getMaxT (CPMap m) = do
+ ((k1, m1), m') <- getMaxAlg m
+ ((k2, v), m1') <- getMaxAlg m1
+ return (((k1, k2), v), CPMap $ maybe m' (\ m1' -> snd $ updateMaxAlg (\ _ _ -> (False, Just m1')) m) (guardNullAlg m1'))
+ updateMinT f (CPMap m) =
+ CPMap <$> updateMinAlg (\ k1 -> guardNullAlg <.> updateMinAlg (\ k2 -> f (k1, k2))) m
+ updateMaxT f (CPMap m) =
+ CPMap <$> updateMaxAlg (\ k1 -> guardNullAlg <.> updateMaxAlg (\ k2 -> f (k1, k2))) m
+ isSubmapT (<=) (CPMap m1) (CPMap m2) = isSubmapAlg (isSubmapAlg (<=)) m1 m2
+ splitLookupT f (k1, k2) (CPMap m) = case splitLookupAlg g k1 m of
+ (mL, ans, mR) -> (CPMap mL, ans, CPMap mR)
+ where g m = case splitLookupAlg f k2 m of
+ (mL, ans, mR) -> (guardNullAlg mL, ans, guardNullAlg mR)
+ fromDistAscListT xs = CPMap (fromDistAscListAlg [(k1, fromDistAscListAlg ys) | (k1, ys) <- breakFst' (==) xs])
+ fromAscListT f xs = CPMap (fromDistAscListAlg [(k1, fromAscListAlg (\ k2 -> f (k1, k2)) ys) | (k1, ys) <- breakFst' (==) xs])
+ fromListT f xs = CPMap (mapWithKeyAlg (\ k1 (Elem ys) -> fromListAlg (\ k2 -> f (k1, k2)) ys) $
+ fromListAlg (\ _ (Elem ys) (Elem zs) -> Elem (ys ++ zs)) [(k1, Elem [(k2, v)]) | ((k1, k2), v) <- xs])
+
+breakFst' :: (k1 -> k1 -> Bool) -> [((k1, k2), v)] -> [(k1, [(k2, v)])]
+breakFst' _ [] = []
+breakFst' eq (((k1, k2), x):xs) = breakFst'' k1 (Seq.singleton (k2, x)) xs where
+ breakFst'' k xs (((k', k2), x):xss)
+ | k `eq` k' = breakFst'' k ((Seq.|>) xs (k2, x)) xss
+ | otherwise = (k, toList xs):breakFst'' k' (Seq.singleton (k2, x)) xss
+ breakFst'' k xs [] = [(k, toList xs)]
+
+instance (TrieKey k1 m1, TrieKey k2 m2) => TrieKey (k1, k2) (CProdMap m1 k2 m2) where
+ compareKey = compareKeyT
+ emptyAlg = emptyT
+ nullAlg = nullT
+ getSingleAlg = getSingleT
+ guardNullAlg = guardNullT
+ sizeAlg = sizeT
+ lookupAlg = lookupT
+ alterLookupAlg = alterLookupT
+ mapAppAlg = mapAppT
+ mapMaybeAlg = mapMaybeT
+ mapEitherAlg = mapEitherT
+ foldWithKeyAlg = foldWithKeyT
+ unionMaybeAlg = unionT
+ intersectAlg = intersectT
+ differenceAlg = differenceT
+ getMinAlg = getMinT
+ getMaxAlg = getMaxT
+ updateMinAlg = updateMinT
+ updateMaxAlg = updateMaxT
+ isSubmapAlg = isSubmapT
+ splitLookupAlg = splitLookupT
+
+instance TrieKey k m => TrieKeyT (Either k) (CUnionMap m) where
+ {-# SPECIALIZE instance TrieKeyT (Either ()) (CUnionMap Maybe) #-}
+ compareKeyT (Left a) (Left b) = compareKey a b
+ compareKeyT (Right a) (Right b) = compareKey a b
+ compareKeyT Left{} Right{} = LT
+ compareKeyT Right{} Left{} = GT
+ emptyT = CUMap emptyAlg emptyAlg
+ nullT (CUMap m1 m2) = nullAlg m1 && nullAlg m2
+ sizeT (CUMap m1 m2) = sizeAlg m1 + sizeAlg m2
+ getSingleT (CUMap m1 m2) = case (getSingleAlg m1, getSingleAlg m2) of
(Just (k, v), Nothing) -> Just (Left k, v)
(Nothing, Just (k, v)) -> Just (Right k, v)
_ -> Nothing
- alterLookupAlg f (Left k) (m1 :+: m2) =
- (:+: m2) <$> alterLookupAlg f k m1
- alterLookupAlg f (Right k) (m1 :+: 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) =
- liftA2 (:+:) (mapAppAlg (f . Left) m1) (mapAppAlg (f . Right) m2)
- mapMaybeAlg f (m1 :+: m2) = mapMaybeAlg (f . Left) m1 :+: mapMaybeAlg (f . Right) m2
- mapEitherAlg f (m1 :+: m2) = (m1L :+: m2L, m1R :+: m2R)
+ lookupT k (CUMap m1 m2) = either (`lookupAlg` m1) (`lookupAlg` m2) k
+ alterLookupT f (Left k) (CUMap m1 m2) = (`CUMap` m2) <$> alterLookupAlg f k m1
+ alterLookupT f (Right k) (CUMap m1 m2) = CUMap m1 <$> alterLookupAlg f k m2
+ foldWithKeyT f z (CUMap m1 m2) = foldWithKeyAlg (f . Left) (foldWithKeyAlg (f . Right) z m2) m1
+ mapAppT f (CUMap m1 m2) = CUMap <$> mapAppAlg (f . Left) m1 <*> mapAppAlg (f . Right) m2
+ mapMaybeT f (CUMap m1 m2) = CUMap (mapMaybeAlg (f . Left) m1) (mapMaybeAlg (f . Right) m2)
+ mapEitherT f (CUMap m1 m2) = (CUMap m1L m2L, CUMap m1R m2R)
where (m1L, m1R) = mapEitherAlg (f . Left) m1
(m2L, m2R) = mapEitherAlg (f . Right) m2
- unionMaybeAlg f (m11 :+: m12) (m21 :+: m22)
- = unionMaybeAlg (f . Left) m11 m21 :+: unionMaybeAlg (f . Right) m12 m22
- intersectAlg f (m11 :+: m12) (m21 :+: m22)
- = intersectAlg (f . Left) m11 m21 :+: intersectAlg (f . Right) m12 m22
- differenceAlg f (m11 :+: m12) (m21 :+: m22)
- = differenceAlg (f . Left) m11 m21 :+: differenceAlg (f . Right) m12 m22
- fromListAlg f xs = fromListAlg (f . Left) ys :+: fromListAlg (f . Right) zs
- where (ys, zs) = partitionEithers (map pullEither xs)
- fromAscListAlg f xs = fromAscListAlg (f . Left) ys :+: fromAscListAlg (f . Right) zs
- where (ys, zs) = partitionEithers (map pullEither xs)
- fromDistAscListAlg xs = fromDistAscListAlg ys :+: fromDistAscListAlg zs
- where (ys, zs) = partitionEithers (map pullEither xs)
- getMinAlg (m1 :+: m2)
- | Just ((k, v), m1') <- getMinAlg m1
- = Just ((Left k, v), m1' :+: m2)
- | Just ((k, v), m2') <- getMinAlg m2
- = Just ((Right k, v), m1 :+: m2')
- getMinAlg _ = Nothing
- getMaxAlg (m1 :+: m2) = getFirst $ First
- (do ((k, v), m2') <- getMaxAlg m2
- return ((Right k, v), m1 :+: m2')) `mappend` First
- (do ((k, v), m1') <- getMaxAlg m1
- return ((Left k, v), m1' :+: m2))
- updateMinAlg f (m1 :+: m2)
- | nullAlg m1 = fmap (m1 :+:) (updateMinAlg (f . Right) m2)
- | otherwise = fmap (:+: m2) (updateMinAlg (f . Left) m1)
- updateMaxAlg f (m1 :+: m2)
- | nullAlg m2 = fmap (:+: m2) (updateMaxAlg (f . Left) m1)
- | otherwise = fmap (m1 :+:) (updateMaxAlg (f . Right) m2)
- isSubmapAlg (<=) (m11 :+: m12) (m21 :+: m22) =
+ unionT f (CUMap m11 m12) (CUMap m21 m22) =
+ CUMap (unionMaybeAlg (f . Left) m11 m21) (unionMaybeAlg (f . Right) m12 m22)
+ intersectT f (CUMap m11 m12) (CUMap m21 m22) =
+ CUMap (intersectAlg (f . Left) m11 m21) (intersectAlg (f . Right) m12 m22)
+ differenceT f (CUMap m11 m12) (CUMap m21 m22) =
+ CUMap (differenceAlg (f . Left) m11 m21) (differenceAlg (f . Right) m12 m22)
+ isSubmapT (<=) (CUMap m11 m12) (CUMap m21 m22) =
isSubmapAlg (<=) m11 m21 && isSubmapAlg (<=) m12 m22
- valid (m1 :+: m2) = valid m1 && valid m2
- splitLookupAlg f (Left k) (m1 :+: m2) = case splitLookupAlg f k m1 of
- (m1L, ans, m1R) -> (m1L :+: emptyAlg, ans, m1R :+: m2)
- splitLookupAlg f (Right k) (m1 :+: m2) = case splitLookupAlg f k m2 of
- (m2L, ans, m2R) -> (m1 :+: m2L, ans, emptyAlg :+: m2R)
-
-pullEither :: (Either k1 k2, v) -> Either (k1, v) (k2, v)
-pullEither (Left k, v) = Left (k, v)
-pullEither (Right k, v) = Right (k, v)
+ splitLookupT f (Left k) (CUMap m1 m2) = case splitLookupAlg f k m1 of
+ (m1L, ans, m1R) -> (CUMap m1L emptyAlg, ans, CUMap m1R m2)
+ splitLookupT f (Right k) (CUMap m1 m2) = case splitLookupAlg f k m2 of
+ (m2L, ans, m2R) -> (CUMap m1 m2L, ans, CUMap emptyAlg m2R)
+ getMinT (CUMap m1 m2) = case (getMinAlg m1, getMinAlg m2) of
+ (Just ((k, v), m1'), _) -> Just ((Left k, v), CUMap m1' m2)
+ (_, Just ((k, v), m2')) -> Just ((Right k, v), CUMap m1 m2')
+ _ -> Nothing
+ getMaxT (CUMap m1 m2) = case (getMaxAlg m1, getMaxAlg m2) of
+ (_, Just ((k, v), m2')) -> Just ((Right k, v), CUMap m1 m2')
+ (Just ((k, v), m1'), _) -> Just ((Left k, v), CUMap m1' m2)
+ _ -> Nothing
+ updateMinT f (CUMap m1 m2)
+ | nullAlg m1 = CUMap m1 <$> updateMinAlg (f . Right) m2
+ | otherwise = (`CUMap` m2) <$> updateMinAlg (f . Left) m1
+ updateMaxT f (CUMap m1 m2)
+ | nullAlg m2 = (`CUMap` m2) <$> updateMaxAlg (f . Left) m1
+ | otherwise = CUMap m1 <$> updateMaxAlg (f . Right) m2
+ fromListT f xs = CUMap (fromListAlg (f . Left) ys) (fromListAlg (f . Right) zs)
+ where (ys, zs) = partitionEithers (map pullEither' xs)
+ fromAscListT f xs = CUMap (fromAscListAlg (f . Left) ys) (fromAscListAlg (f . Right) zs)
+ where (ys, zs) = partitionEithers (map pullEither' xs)
+ fromDistAscListT xs = CUMap (fromDistAscListAlg ys) (fromDistAscListAlg zs)
+ where (ys, zs) = partitionEithers (map pullEither' xs)
+
+instance (TrieKey k1 m1, TrieKey k2 m2) => TrieKey (Either k1 k2) (CUnionMap m1 k2 m2) where
+ {-# SPECIALIZE instance TrieKey k m => TrieKey (Either () k) (CUnionMap Maybe k m) #-}
+ compareKey = compareKeyT
+ emptyAlg = emptyT
+ nullAlg = nullT
+ getSingleAlg = getSingleT
+ guardNullAlg = guardNullT
+ sizeAlg = sizeT
+ lookupAlg = lookupT
+ alterLookupAlg = alterLookupT
+ mapAppAlg = mapAppT
+ mapMaybeAlg = mapMaybeT
+ mapEitherAlg = mapEitherT
+ foldWithKeyAlg = foldWithKeyT
+ unionMaybeAlg = unionT
+ intersectAlg = intersectT
+ differenceAlg = differenceT
+ getMinAlg = getMinT
+ getMaxAlg = getMaxT
+ updateMinAlg = updateMinT
+ updateMaxAlg = updateMaxT
+ isSubmapAlg = isSubmapT
+ splitLookupAlg = splitLookupT
+
+partitionEithers' :: [Either a b] -> ([a], [b])
+partitionEithers' = foldr part ([], []) where
+ part (Left x) (xs, ys) = (x:xs, ys)
+ part (Right y) (xs, ys) = (xs, y:ys)
+
+pullEither :: ((f1 :+: f2) k, v) -> Either (f1 k, v) (f2 k, v)
+pullEither (A k, v) = Left (k, v)
+pullEither (B k, v) = Right (k, v)
+
+pullEither' :: (Either k1 k2, v) -> Either (k1, v) (k2, v)
+pullEither' (Left k, v) = Left (k, v)
+pullEither' (Right k, v) = Right (k, v)
+
+instance TrieKey k m => TrieKeyT (Const k) (ConstMap m) where
+ compareKeyT (Const a) (Const b) = compareKey a b
+ emptyT = ConstMap emptyAlg
+ nullT (ConstMap m) = nullAlg m
+ sizeT (ConstMap m) = sizeAlg m
+ getSingleT (ConstMap m) = do
+ (k, v) <- getSingleAlg m
+ return (Const k, v)
+ lookupT (Const k) (ConstMap m) = lookupAlg k m
+ alterLookupT f (Const k) (ConstMap m) = ConstMap <$> alterLookupAlg f k m
+ foldWithKeyT f z (ConstMap m) = foldWithKeyAlg (f . Const) z m
+ mapAppT f (ConstMap m) = ConstMap <$> mapAppAlg (f . Const) m
+ mapMaybeT f (ConstMap m) = ConstMap (mapMaybeAlg (f . Const) m)
+ mapEitherT f (ConstMap m) = case mapEitherAlg (f . Const) m of
+ (mL, mR) -> (ConstMap mL, ConstMap mR)
+ unionT f (ConstMap m1) (ConstMap m2) = ConstMap (unionMaybeAlg (f . Const) m1 m2)
+ intersectT f (ConstMap m1) (ConstMap m2) = ConstMap (intersectAlg (f . Const) m1 m2)
+ differenceT f (ConstMap m1) (ConstMap m2) = ConstMap (differenceAlg (f . Const) m1 m2)
+ fromDistAscListT xs = ConstMap (fromDistAscListAlg [(k, v) | (Const k, v) <- xs])
+ fromAscListT f xs = ConstMap (fromAscListAlg (f . Const) [(k, v) | (Const k, v) <- xs])
+ fromListT f xs = ConstMap (fromListAlg (f . Const) [(k, v) | (Const k, v) <- xs])
+ getMinT (ConstMap m) = do
+ (~(k, v), m') <- getMinAlg m
+ return ((Const k, v), ConstMap m')
+ getMaxT (ConstMap m) = do
+ (~(k, v), m') <- getMaxAlg m
+ return ((Const k, v), ConstMap m')
+ updateMinT f (ConstMap m) = ConstMap <$> updateMinAlg (f . Const) m
+ updateMaxT f (ConstMap m) = ConstMap <$> updateMaxAlg (f . Const) m
+ isSubmapT (<=) (ConstMap m1) (ConstMap m2) = isSubmapAlg (<=) m1 m2
+ splitLookupT f (Const k) (ConstMap m) = case splitLookupAlg f k m of
+ (mL, ans, mR) -> (ConstMap mL, ans, ConstMap mR)
+
+instance (TrieKey k m, TrieKey k' m') => TrieKey (Const k k') (ConstMap m k' m') where
+ compareKey = compareKeyT
+ emptyAlg = emptyT
+ nullAlg = nullT
+ getSingleAlg = getSingleT
+ guardNullAlg = guardNullT
+ sizeAlg = sizeT
+ lookupAlg = lookupT
+ alterLookupAlg = alterLookupT
+ mapAppAlg = mapAppT
+ mapMaybeAlg = mapMaybeT
+ mapEitherAlg = mapEitherT
+ foldWithKeyAlg = foldWithKeyT
+ unionMaybeAlg = unionT
+ intersectAlg = intersectT
+ differenceAlg = differenceT
+ getMinAlg = getMinT
+ getMaxAlg = getMaxT
+ updateMinAlg = updateMinT
+ updateMaxAlg = updateMaxT
+ isSubmapAlg = isSubmapT
+ splitLookupAlg = splitLookupT
+
+instance TrieKeyT Id IdMap where
+ compareKeyT (Id a) (Id b) = compareKey a b
+ emptyT = IdMap emptyAlg
+ nullT (IdMap m) = nullAlg m
+ sizeT (IdMap m) = sizeAlg m
+ getSingleT (IdMap m) = do
+ (k, v) <- getSingleAlg m
+ return (Id k, v)
+ lookupT (Id k) (IdMap m) = lookupAlg k m
+ alterLookupT f (Id k) (IdMap m) = IdMap <$> alterLookupAlg f k m
+ foldWithKeyT f z (IdMap m) = foldWithKeyAlg (f . Id) z m
+ mapAppT f (IdMap m) = IdMap <$> mapAppAlg (f . Id) m
+ mapMaybeT f (IdMap m) = IdMap (mapMaybeAlg (f . Id) m)
+ mapEitherT f (IdMap m) = case mapEitherAlg (f . Id) m of
+ (mL, mR) -> (IdMap mL, IdMap mR)
+ unionT f (IdMap m1) (IdMap m2) = IdMap (unionMaybeAlg (f . Id) m1 m2)
+ intersectT f (IdMap m1) (IdMap m2) = IdMap (intersectAlg (f . Id) m1 m2)
+ differenceT f (IdMap m1) (IdMap m2) = IdMap (differenceAlg (f . Id) m1 m2)
+ fromDistAscListT xs = IdMap (fromDistAscListAlg [(k, v) | (Id k, v) <- xs])
+ fromAscListT f xs = IdMap (fromAscListAlg (f . Id) [(k, v) | (Id k, v) <- xs])
+ fromListT f xs = IdMap (fromListAlg (f . Id) [(k, v) | (Id k, v) <- xs])
+ getMinT (IdMap m) = do
+ (~(k, v), m') <- getMinAlg m
+ return ((Id k, v), IdMap m')
+ getMaxT (IdMap m) = do
+ (~(k, v), m') <- getMaxAlg m
+ return ((Id k, v), IdMap m')
+ updateMinT f (IdMap m) = IdMap <$> updateMinAlg (f . Id) m
+ updateMaxT f (IdMap m) = IdMap <$> updateMaxAlg (f . Id) m
+ isSubmapT (<=) (IdMap m1) (IdMap m2) = isSubmapAlg (<=) m1 m2
+ splitLookupT f (Id k) (IdMap m) = case splitLookupAlg f k m of
+ (mL, ans, mR) -> (IdMap mL, ans, IdMap mR)
+
+instance TrieKey k m => TrieKey (Id k) (IdMap k m) where
+ compareKey = compareKeyT
+ emptyAlg = emptyT
+ nullAlg = nullT
+ getSingleAlg = getSingleT
+ guardNullAlg = guardNullT
+ sizeAlg = sizeT
+ lookupAlg = lookupT
+ alterLookupAlg = alterLookupT
+ mapAppAlg = mapAppT
+ mapMaybeAlg = mapMaybeT
+ mapEitherAlg = mapEitherT
+ foldWithKeyAlg = foldWithKeyT
+ unionMaybeAlg = unionT
+ intersectAlg = intersectT
+ differenceAlg = differenceT
+ getMinAlg = getMinT
+ getMaxAlg = getMaxT
+ updateMinAlg = updateMinT
+ updateMaxAlg = updateMaxT
+ isSubmapAlg = isSubmapT
+ splitLookupAlg = splitLookupT
+
+-- instance (Sized k, TrieKey k m) => TrieKey (SizeElem k) (SizedMap k m) where
+-- compareKey (SElem a) (SElem b) = compareKey a b
+-- emptyAlg = SizedMap emptyAlg
+-- nullAlg (SizedMap m) = nullAlg m
+-- sizeAlg (SizedMap m) = sizeAlg m
+-- getSingleAlg (SizedMap m) = do
+-- (k, v) <- getSingleAlg m
+-- return (SElem k, v)
+-- lookupAlg (SElem k) (SizedMap m) = lookupAlg k m
+-- alterLookupAlg f (SElem k) (SizedMap m) = SizedMap <$> alterLookupAlg f k m
+-- foldWithKeyAlg f z (SizedMap m) = foldWithKeyAlg (f . SElem) z m
+-- mapAppAlg f (SizedMap m) = SizedMap <$> mapAppAlg (f . SElem) m
+-- mapMaybeAlg f (SizedMap m) = SizedMap (mapMaybeAlg (f . SElem) m)
+-- mapEitherAlg f (SizedMap m) = case mapEitherAlg (f . SElem) m of
+-- (mL, mR) -> (SizedMap mL, SizedMap mR)
+-- unionMaybeAlg f (SizedMap m1) (SizedMap m2) = SizedMap (unionMaybeAlg (f . SElem) m1 m2)
+-- intersectAlg f (SizedMap m1) (SizedMap m2) = SizedMap (intersectAlg (f . SElem) m1 m2)
+-- differenceAlg f (SizedMap m1) (SizedMap m2) = SizedMap (differenceAlg (f . SElem) m1 m2)
+-- fromDistAscListAlg xs = SizedMap (fromDistAscListAlg [(k, v) | (SElem k, v) <- xs])
+-- fromAscListAlg f xs = SizedMap (fromAscListAlg (f . SElem) [(k, v) | (SElem k, v) <- xs])
+-- fromListAlg f xs = SizedMap (fromListAlg (f . SElem) [(k, v) | (SElem k, v) <- xs])
+-- getMinAlg (SizedMap m) = do
+-- (~(k, v), m') <- getMinAlg m
+-- return ((SElem k, v), SizedMap m')
+-- getMaxAlg (SizedMap m) = do
+-- (~(k, v), m') <- getMaxAlg m
+-- return ((SElem k, v), SizedMap m')
+-- updateMinAlg f (SizedMap m) = SizedMap <$> updateMinAlg (f . SElem) m
+-- updateMaxAlg f (SizedMap m) = SizedMap <$> updateMaxAlg (f . SElem) m
+-- isSubmapAlg (<=) (SizedMap m1) (SizedMap m2) = isSubmapAlg (<=) m1 m2
+-- splitLookupAlg f (SElem k) (SizedMap m) = case splitLookupAlg f k m of
+-- (mL, ans, mR) -> (SizedMap mL, ans, SizedMap mR)
instance TrieKey Int IntMap where
+ compareKey = compare
emptyAlg = IMap.empty
nullAlg = IMap.null
- sizeAlg = foldl' (\ n x -> n + getSize x) 0
getSingleAlg m
| IMap.size m == 1, [(k, v)] <- IMap.toList m
= Just (k, v)
@@ -273,7 +708,7 @@ instance TrieKey Int IntMap where
foldWithKeyAlg = IMap.foldWithKey
mapAppAlg = sequenceA .: IMap.mapWithKey
mapMaybeAlg = IMap.mapMaybeWithKey
- mapEitherAlg = IMap.mapEitherWithKey
+ mapEitherAlg f m = (IMap.mapMaybeWithKey (fst .: f) m, IMap.mapMaybeWithKey (snd .: f) m)
unionMaybeAlg f m1 m2 = IMap.mapMaybe (either Just id) (IMap.unionWithKey g (fmap Left m1) (fmap Left m2)) where
g k (Left v1) (Left v2) = Right (f k v1 v2)
g k (Right v) _ = Right v
@@ -300,9 +735,10 @@ instance TrieKey Int IntMap where
(vL, ans, vR) -> (maybe mL (flip (IMap.insert k) mL) vL, ans, maybe mR (flip (IMap.insert k) mR) vR)
instance Ord k => TrieKey (Ordered k) (Map k) where
+ compareKey = compare
emptyAlg = Map.empty
nullAlg = Map.null
- sizeAlg = foldl' (\ n x -> n + getSize x) 0
+-- sizeAlg = foldl' (\ n x -> n + getSize x) 0
getSingleAlg m
| Map.size m == 1, (k, v) <- Map.findMin m
= Just (Ord k, v)
@@ -312,7 +748,7 @@ instance Ord k => TrieKey (Ordered k) (Map k) where
foldWithKeyAlg f = Map.foldWithKey (f . Ord)
mapAppAlg f = sequenceA . Map.mapWithKey (f . Ord)
mapMaybeAlg f = Map.mapMaybeWithKey (f . Ord)
- mapEitherAlg f = Map.mapEitherWithKey (f . Ord)
+ mapEitherAlg f m = (Map.mapMaybeWithKey (fst .: f . Ord) m, Map.mapMaybeWithKey (snd .: f . Ord) m)
unionMaybeAlg f m1 m2 = Map.mapMaybe (either Just id) (Map.unionWithKey g (fmap Left m1) (fmap Left m2)) where
g k (Left v1) (Left v2) = Right (f (Ord k) v1 v2)
g k (Right v) _ = Right v
@@ -322,9 +758,9 @@ instance Ord k => TrieKey (Ordered k) (Map k) where
fromListAlg f xs = Map.fromListWithKey (f . Ord) [(k, v) | (Ord k, v) <- xs]
fromAscListAlg f xs = Map.fromAscListWithKey (f . Ord) [(k, v) | (Ord k, v) <- xs]
fromDistAscListAlg xs = Map.fromDistinctAscList [(k, v) | (Ord k, v) <- xs]
- getMinAlg m = do ~(~(k, v), m') <- Map.minViewWithKey m
+ getMinAlg m = do (~(k, v), m') <- Map.minViewWithKey m
return ((Ord k, v), m')
- getMaxAlg m = do ~(~(k, v), m') <- Map.maxViewWithKey m
+ getMaxAlg m = do (~(k, v), m') <- Map.maxViewWithKey m
return ((Ord k, v), m')
updateMinAlg f m
| Map.null m = (False, m)
@@ -341,6 +777,7 @@ instance Ord k => TrieKey (Ordered k) (Map k) where
(vL, ans, vR) -> (maybe mL (flip (Map.insert k) mL) vL, ans, maybe mR (flip (Map.insert k) mR) vR)
instance TrieKey () Maybe where
+ compareKey _ _ = EQ
emptyAlg = Nothing
nullAlg = isNothing
sizeAlg = maybe 0 getSize
@@ -350,10 +787,7 @@ instance TrieKey () Maybe where
foldWithKeyAlg f = foldr (f ())
mapAppAlg f = traverse (f ())
mapMaybeAlg f = (>>= f ())
- mapEitherAlg _ Nothing = (Nothing, Nothing)
- mapEitherAlg f (Just v) = case f () v of
- Left v -> (Just v, Nothing)
- Right v -> (Nothing, Just v)
+ mapEitherAlg f = maybe (Nothing, Nothing) (f ())
unionMaybeAlg f = unionMaybe (f ())
intersectAlg f = intersectMaybe (f ())
differenceAlg f = differenceMaybe (f ())
@@ -372,10 +806,93 @@ instance TrieKey () Maybe where
isSubmapAlg (<=) (Just x) (Just y) = x <= y
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;
- #-} \ No newline at end of file
+ #-}
+
+instance (TrieKeyT f t, TrieKey k m) => TrieKey (App f k) (App (t k m)) where
+ compareKey (App a) (App b) = compareKeyT a b
+ emptyAlg = App emptyT
+ nullAlg (App m) = nullT m
+ getSingleAlg (App m) = do
+ (k, v) <- getSingleT m
+ return (App k, v)
+ alterLookupAlg f (App k) (App m) = App <$> alterLookupT f k m
+ foldWithKeyAlg f z (App m) = foldWithKeyT (f . App) z m
+ mapAppAlg f (App m) = App <$> mapAppT (f . App) m
+ mapMaybeAlg f (App m) = App (mapMaybeT (f . App) m)
+ mapEitherAlg f (App m) = (App *** App) (mapEitherT (f . App) m)
+ fromListAlg f xs = App (fromListT (f . App) [(k, v) | (App k, v) <- xs])
+ fromAscListAlg f xs = App (fromAscListT (f . App) [(k, v) | (App k, v) <- xs])
+ fromDistAscListAlg xs = App (fromDistAscListT [(k, v) | (App k, v) <- xs])
+ unionMaybeAlg f (App m1) (App m2) = App (unionT (f . App) m1 m2)
+ intersectAlg f (App m1) (App m2) = App (intersectT (f . App) m1 m2)
+ differenceAlg f (App m1) (App m2) = App (differenceT (f . App) m1 m2)
+ getMinAlg (App m) = do
+ ((k, v), m') <- getMinT m
+ return ((App k, v), App m')
+ getMaxAlg (App m) = do
+ ((k, v), m') <- getMaxT m
+ return ((App k, v), App m')
+ updateMinAlg f (App m) = App <$> updateMinT (f . App) m
+ updateMaxAlg f (App m) = App <$> updateMaxT (f . App) m
+ isSubmapAlg (<=) (App m1) (App m2) = isSubmapT (<=) m1 m2
+ splitLookupAlg f (App k) (App m) = case splitLookupT f k m of
+ (mL, ans, mR) -> (App mL, ans, App mR)
+
+instance (TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKeyT (f1 `O` f2) (CompMap t1 f2 t2) where
+ compareKeyT (O a) (O b) = compareKeyT a b
+ emptyT = CompMap emptyT
+ nullT (CompMap m) = nullT m
+ guardNullT (CompMap m) = CompMap <$> guardNullT m
+ sizeT (CompMap m) = sizeT m
+ getSingleT (CompMap m) = do
+ (k, v) <- getSingleT m
+ return (O k, v)
+ lookupT (O k) (CompMap m) = lookupT k m
+ alterLookupT f (O k) (CompMap m) = CompMap <$> alterLookupT f k m
+ foldWithKeyT f z (CompMap m) = foldWithKeyT (f . O) z m
+ mapAppT f (CompMap m) = CompMap <$> mapAppT (f . O) m
+ mapMaybeT f (CompMap m) = CompMap (mapMaybeT (f . O) m)
+ mapEitherT f (CompMap m) = (CompMap *** CompMap) (mapEitherT (f . O) m)
+ unionT f (CompMap m1) (CompMap m2) = CompMap (unionT (f . O) m1 m2)
+ intersectT f (CompMap m1) (CompMap m2) = CompMap (intersectT (f . O) m1 m2)
+ differenceT f (CompMap m1) (CompMap m2) = CompMap (differenceT (f . O) m1 m2)
+ fromDistAscListT xs = CompMap (fromDistAscListT [(k, v) | (O k, v) <- xs])
+ fromAscListT f xs = CompMap (fromAscListT (f . O) [(k, v) | (O k, v) <- xs])
+ fromListT f xs = CompMap (fromListT (f . O) [(k, v) | (O k, v) <- xs])
+ getMinT (CompMap m) = do
+ ((k, v), m') <- getMinT m
+ return ((O k, v), CompMap m')
+ getMaxT (CompMap m) = do
+ ((k, v), m') <- getMaxT m
+ return ((O k, v), CompMap m')
+ updateMinT f (CompMap m) = CompMap <$> updateMinT (f . O) m
+ updateMaxT f (CompMap m) = CompMap <$> updateMaxT (f . O) m
+ isSubmapT (<=) (CompMap m1) (CompMap m2) = isSubmapT (<=) m1 m2
+ splitLookupT f (O k) (CompMap m) = case splitLookupT f k m of
+ (mL, ans, mR) -> (CompMap mL, ans, CompMap mR)
+
+instance (TrieKey k m, TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKey ((f1 `O` f2) k) (CompMap t1 f2 t2 k m) where
+ compareKey = compareKeyT
+ emptyAlg = emptyT
+ nullAlg = nullT
+ getSingleAlg = getSingleT
+ guardNullAlg = guardNullT
+ sizeAlg = sizeT
+ lookupAlg = lookupT
+ alterLookupAlg = alterLookupT
+ mapAppAlg = mapAppT
+ mapMaybeAlg = mapMaybeT
+ mapEitherAlg = mapEitherT
+ foldWithKeyAlg = foldWithKeyT
+ unionMaybeAlg = unionT
+ intersectAlg = intersectT
+ differenceAlg = differenceT
+ getMinAlg = getMinT
+ getMaxAlg = getMaxT
+ updateMinAlg = updateMinT
+ updateMaxAlg = updateMaxT
+ isSubmapAlg = isSubmapT
+ splitLookupAlg = splitLookupT \ No newline at end of file