TrieMap 0.0.1.1 → 0.0.1.2

raw patch · 8 files changed

+1536/−640 lines, 8 filesdep +bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring

API changes (from Hackage documentation)

Files

• TrieMap.cabal +2/−2
• TrieMap.hs +144/−125
• TrieMap/Algebraic.hs +348/−53
• TrieMap/Applicative.hs +1/−5
• TrieMap/MapTypes.hs +115/−35
• TrieMap/RadixTrie.hs +223/−250
• TrieMap/Reflection.hs +30/−14
• TrieMap/TrieAlgebraic.hs +673/−156

@@ -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 @@   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

@@ -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 @@ 	-- ** Map 	map, 	mapWithKey,-	mapApp,-	mapAppWithKey,+	traverseWithKey, 	mapMaybe, 	mapMaybeWithKey, 	mapEither,@@ -153,6 +155,7 @@ 	maxView, 	minViewWithKey, 	maxViewWithKey) where+-- module TrieMap where  import Control.Monad import Data.Monoid@@ -163,7 +166,7 @@ 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 @@ -- | 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 Functor m => Functor (TrieMap k m) where-	fmap f (TrieMap n m) = TrieMap n (fmap (fmap f) m)+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 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 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 Traversable m => Traversable (TrieMap k m) where-	traverse f (TrieMap n m) = TrieMap n <$> traverse (traverse 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 (Algebraic k, TrieKey (Alg k) m) => Monoid (TrieMap k m a) where++instance TrieKey k' m => Functor (TrieMap k m) where+	fmap = fmapDefault++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 @@ -- -- > 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 @@ -- -- > 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 @@ -- > 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 @@ -- > 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 @@ -- -- > 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 @@ -- -- > 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 @@ -- /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 @@ -- > 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 @@ -- > 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 @@ -- > 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 @@ -- > 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 @@ -- > 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 @@ -- > 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 @@ -- > 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 @@ -- > 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 @@ -- -- > 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 @@ -- > -- > 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 @@ -- > -- > 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 @@ -- > 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 @@ -- -- > 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 @@ -- > 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 @@ -- > 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 @@ -- > 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 @@ -- > 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 @@ -- -- > 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 @@ -- -- > 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 @@ -- -- > 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 @@ -- -- > 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 @@ -- 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 @@ -- -- > 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 @@ -- (@'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 @@ -- > 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 @@ -- > 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 @@ -- -- > 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 @@ -- -- > 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 @@ -- -- > 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 @@ -- -- > 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 @@ -- -- > 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 @@ -- -- > 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 @@ -- -- > 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 @@ -- -- > 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 @@ -- | /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 @@  > 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 @@ -- > 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 @@ -- > 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.

@@ -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 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 -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)+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 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)+	type AlgRep (a, b, c, d) = AlgRep (AlgWrap ((,,,) a b c) d)+	toAlg = toAlg . AlgWrap+	fromAlg = unAlgWrap . fromAlg -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 a => AlgebraicT (Either a) where+	type AlgRepT (Either a) = Either (AlgRep a)+	toAlgT = either (Left . toAlg) Right+	fromAlgT = either (Left . fromAlg) Right -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)+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+	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;+ #-}

@@ -4,11 +4,7 @@ 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

@@ -1,25 +1,49 @@-{-# 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) --- | '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)+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++-- | '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)  -- | '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 @@  infixr 5 `ProdMap` infixr 5 :+:+infixr 8 :*:+infixr 9 `O`  class Sized a where 	getSize :: a -> Int@@ -41,46 +67,100 @@ 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 m => Functor (RadixTrie k m) where-	fmap f (Radix e) = Radix (fmap (fmap f) e)+instance Functor (Const a) where+	fmap f (Const x) = Const x -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 Foldable (Const a) where+	foldr f z _ = z+	foldl f z _ = z -instance Foldable m => Foldable (RadixTrie k m) where-	foldr f z (Radix e) = foldr (flip (foldr f)) z e-	foldl f z (Radix e) = foldl (foldl f) z e+instance Traversable (Const a) where+	traverse f (Const x) = pure (Const x) -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 Functor Id where+	fmap f (Id a) = Id (f a) -instance Traversable m => Traversable (RadixTrie k m) where-	traverse f (Radix e) = Radix <$> traverse (traverse f) e+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 EqT f => EqT (App f) where+	App a `eq` App b = a `eq` b++instance (EqT f, Eq a) => Eq (App f a) where+	(==) = eq++instance (EqT f, EqT g) => EqT (f `O` g) where+	O a `eq` O b = a `eq` b++instance (EqT f, EqT g, Eq a) => Eq ((f `O` g) a) where+	(==) = eq++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)

@@ -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 hiding (Alternative(..))-import Control.Monad-import Data.Foldable-import Data.Traversable-import Data.Monoid+import Control.Applicative+ 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+import Prelude hiding (foldr) -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)+instance Sized (Edge k m a) where+	getSize (Edge s _ _ _) = s -	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+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)+	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) -	fromListAlg f xs = Radix (edgeFromList f xs)-	fromAscListAlg f xs = Radix (edgeFromAscList f xs)-	fromDistAscListAlg = fromAscListAlg (\ _ v _ -> v)+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 -	isSubmapAlg (<=) (Radix e1) (Radix e2) = isSubmapAlg subEdge e1 e2 -- hehe, using the Maybe instance here!-		where	subEdge = isSubmapEdge (==) (<=) lookupAlg $! isSubmapAlg subEdge+single :: (Sized a, TrieKey k m) => [k] -> Maybe a -> MEdge k m a+single ks = fmap (\ v -> Edge (getSize v) ks (Just v) emptyAlg) -	valid (Radix e) = maybe True validEdge e+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 -	splitLookupAlg _ _ (Radix Nothing) = (Radix Nothing, Nothing, Radix Nothing)-	splitLookupAlg f k (Radix (Just e)) = case splitEdge f k e of-		(eL, ans, eR)	-> (Radix eL, ans, Radix eR)+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+	(l, e') <- getSingleAlg ts+	(ls, v) <- getSingleEdge e'+	return (ks ++ l:ls, v)+getSingleEdge _ = Nothing --- sizeEdge :: Edge k m v -> Int--- sizeEdge (Edge n _ _ _) = n+guardNullEdge :: TrieKey k m => Edge k m a -> MEdge k m a+guardNullEdge (Edge s ks Nothing ts)+	| nullAlg ts	= Nothing+	| Just (l, Edge _ ls v ts') <- getSingleAlg ts+			= Just (Edge s (ks ++ l:ls) v ts')+guardNullEdge e = Just e -{-# INLINE edge #-}-edge :: (Sized v, TrieKey k m) => [k] -> Maybe v -> m (Edge k m v) -> Edge k m v-edge ks v ts = Edge (getSize v + getSize ts) ks v ts+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	= 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 :: TrieKey k m => (k -> k -> Bool) -> [k] -> Edge k m v -> Maybe v-lookupEdge (==) ks (Edge _ ls v ts) = procEdge ks ls where+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+		| 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+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 -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+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 -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')+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)) -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-}+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) -maybeSingleEdge :: Sized v => TrieKey k m => [k] -> Maybe v -> MEdge k m v-maybeSingleEdge ks = fmap (\ v -> Edge (getSize v) ks (Just v) emptyAlg)+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))])) -getSingleEdge :: (TrieKey k m) => Edge k m v -> Maybe ([k], v)-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) -getSingleEdge _ = Nothing+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 -{-# INLINE guardNullEdge #-}-guardNullEdge :: TrieKey k m => Edge k m v -> MEdge k m v-guardNullEdge (Edge n ks Nothing ts)-	| nullAlg ts	= Nothing-	| Just (x, Edge n' xs v ts') <- getSingleAlg ts-		= Just (Edge n' (ks ++ x:xs) v ts')-guardNullEdge e = Just e+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) -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-	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+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)) -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+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 -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)+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'')) -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'+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'')) -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)+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)) -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+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))++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+		| 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 :: (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+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+			= 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--{-# 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-		

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances #-}  module TrieMap.Reflection where @@ -11,21 +11,37 @@ 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+-- 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

@@ -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.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 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 @@ 	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 @@ 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 _ _ = 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)+		where g m' = case splitLookupT f k2 m' of+			(mL, ans, mR)	-> (guardNullT mL, ans, guardNullT mR) -	valid (PMap m) = valid m && all valid m && not (any nullAlg m)+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 :: (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+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)+	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) -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 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 @@ 	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 @@ 			(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 @@ 	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 @@ 	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 @@ 			(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 @@ 	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 @@ 	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; 	#-}++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