TrieMap 0.0.1.2 → 0.5.0

raw patch · 44 files changed

+3719/−2817 lines, 44 filesdep +multirecdep −bytestringdep ~basedep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: multirec

Dependencies removed: bytestring

Dependency ranges changed: base, containers

API changes (from Hackage documentation)

Files

• Data/TrieMap.hs +355/−0
• Data/TrieMap/Applicative.hs +46/−0
• Data/TrieMap/Class.hs +36/−0
• Data/TrieMap/Class/Instances.hs +180/−0
• Data/TrieMap/IntMap.hs +478/−0
• Data/TrieMap/MultiRec.hs +6/−0
• Data/TrieMap/MultiRec/Class.hs +122/−0
• Data/TrieMap/MultiRec/ConstMap.hs +78/−0
• Data/TrieMap/MultiRec/Eq.hs +37/−0
• Data/TrieMap/MultiRec/FamMap.hs +125/−0
• Data/TrieMap/MultiRec/IMap.hs +86/−0
• Data/TrieMap/MultiRec/Instances.hs +9/−0
• Data/TrieMap/MultiRec/Ord.hs +63/−0
• Data/TrieMap/MultiRec/ProdMap.hs +126/−0
• Data/TrieMap/MultiRec/Sized.hs +20/−0
• Data/TrieMap/MultiRec/TagMap.hs +125/−0
• Data/TrieMap/MultiRec/UnionMap.hs +121/−0
• Data/TrieMap/MultiRec/UnitMap.hs +79/−0
• Data/TrieMap/OrdMap.hs +393/−0
• Data/TrieMap/Regular.hs +6/−0
• Data/TrieMap/Regular/Base.hs +60/−0
• Data/TrieMap/Regular/Class.hs +69/−0
• Data/TrieMap/Regular/ConstMap.hs +70/−0
• Data/TrieMap/Regular/Eq.hs +64/−0
• Data/TrieMap/Regular/IdMap.hs +68/−0
• Data/TrieMap/Regular/Instances.hs +9/−0
• Data/TrieMap/Regular/Ord.hs +71/−0
• Data/TrieMap/Regular/ProdMap.hs +84/−0
• Data/TrieMap/Regular/RadixTrie.hs +322/−0
• Data/TrieMap/Regular/RegMap.hs +40/−0
• Data/TrieMap/Regular/Sized.hs +9/−0
• Data/TrieMap/Regular/UnionMap.hs +109/−0
• Data/TrieMap/Regular/UnitMap.hs +75/−0
• Data/TrieMap/Sized.hs +18/−0
• Data/TrieMap/TrieKey.hs +109/−0
• LICENSE +1/−1
• TrieMap.cabal +50/−32
• TrieMap.hs +0/−954
• TrieMap/Algebraic.hs +0/−417
• TrieMap/Applicative.hs +0/−28
• TrieMap/MapTypes.hs +0/−166
• TrieMap/RadixTrie.hs +0/−274
• TrieMap/Reflection.hs +0/−47
• TrieMap/TrieAlgebraic.hs +0/−898

@@ -0,0 +1,355 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}++module Data.TrieMap (+	-- * Map type+	TKey,+	TMap,+	-- * Operators+	(!),+	(\\),+	-- * Query+	null,+	size,+	member,+	notMember,+	lookup,+	findWithDefault,+	-- * Construction+	empty,+	singleton,+	-- ** Insertion+	insert,+	insertWith,+	insertWithKey,+	-- ** Delete/Update+	delete,+	adjust,+	adjustWithKey,+	update,+	updateWithKey,+	alter,+	-- * Combine+	-- ** Union+	union,+	unionWith,+	unionWithKey,+	unionMaybeWith,+	unionMaybeWithKey,+	-- ** Difference+	difference,+	differenceWith,+	differenceWithKey,+	-- ** Intersection+	intersection,+	intersectionWith,+	intersectionWithKey,+	intersectionMaybeWith,+	intersectionMaybeWithKey,+	-- * Traversal+	-- ** Map+	map,+	mapWithKey,+	mapKeys,+	mapKeysWith,+	mapKeysMonotonic,+	-- ** Traverse+	traverseWithKey,+	-- ** Fold+	fold,+	foldWithKey,+	foldrWithKey,+	foldlWithKey,+	-- * Conversion+	elems,+	keys,+	assocs,+	-- ** Lists+	fromList,+	fromListWith,+	fromListWithKey,+	-- ** Ordered lists+	fromAscList,+	fromAscListWith,+	fromAscListWithKey,+	fromDistinctAscList,+	-- * Filter+	filter,+	filterWithKey,+	partition,+	partitionWithKey,+	mapMaybe,+	mapMaybeWithKey,+	mapEither,+	mapEitherWithKey,+	split,+	splitLookup,+	-- * Submap+	isSubmapOf,+	isSubmapOfBy,+	-- * Min/Max+	findMin,+	findMax,+	deleteMin,+	deleteMax,+	deleteFindMin,+	deleteFindMax,+	updateMin,+	updateMax,+	updateMinWithKey,+	updateMaxWithKey,+	minView,+	maxView,+	minViewWithKey,+	maxViewWithKey+	) where++import Data.TrieMap.Class+import Data.TrieMap.Class.Instances()+import Data.TrieMap.TrieKey+import Data.TrieMap.Applicative++import Control.Applicative hiding (empty)+import Control.Arrow+import Data.Maybe hiding (mapMaybe)+import Data.Monoid(First(..), Last(..))+-- import Data.Foldable+-- import Data.Traversable++-- import Generics.MultiRec.Base+import Data.TrieMap.Regular.Base+import Data.TrieMap.Regular.Sized+import GHC.Exts (build)++import Prelude hiding (lookup, foldr, null, map, filter)++-- newtype Elem a k = Elem {getElem :: a}+empty :: TKey k => TMap k a+empty = TMap emptyM++singleton :: TKey k => k -> a -> TMap k a+singleton k a = insert k a empty++null :: TKey k => TMap k a -> Bool+null (TMap m) = nullM m++lookup :: TKey k => k -> TMap k a -> Maybe a+lookup k (TMap m) = unK0 <$> lookupM (toRep k) m++findWithDefault :: TKey k => a -> k -> TMap k a -> a+findWithDefault a = fromMaybe a .: lookup++(!) :: TKey k => TMap k a -> k -> a+m ! k = fromMaybe (error "Element not found") (lookup k m)++alter :: TKey k => (Maybe a -> Maybe a) -> k -> TMap k a -> TMap k a+alter f k (TMap m) = TMap (alterM sizeK0 (fmap K0 . f . fmap unK0) (toRep k) m)++insert :: TKey k => k -> a -> TMap k a -> TMap k a+insert = insertWith const++insertWith :: TKey k => (a -> a -> a) -> k -> a -> TMap k a -> TMap k a+insertWith = insertWithKey . const++insertWithKey :: TKey k => (k -> a -> a -> a) -> k -> a -> TMap k a -> TMap k a+insertWithKey f k a = alter f' k where+	f' = Just . maybe a (f k a)++delete :: TKey k => k -> TMap k a -> TMap k a+delete = alter (const Nothing)++adjust :: TKey k => (a -> a) -> k -> TMap k a -> TMap k a+adjust = adjustWithKey . const++adjustWithKey :: TKey k => (k -> a -> a) -> k -> TMap k a -> TMap k a+adjustWithKey f = updateWithKey (Just .: f)++update :: TKey k => (a -> Maybe a) -> k -> TMap k a -> TMap k a+update f = alter (>>= f)++updateWithKey :: TKey k => (k -> a -> Maybe a) -> k -> TMap k a -> TMap k a+updateWithKey f k = update (f k) k++fold :: TKey k => (a -> b -> b) -> b -> TMap k a -> b+fold = foldWithKey . const++foldWithKey, foldrWithKey :: TKey k => (k -> a -> b -> b) -> b -> TMap k a -> b+foldWithKey f z (TMap m) = foldWithKeyM (\ k (K0 a) -> f (fromRep k) a) m z+foldrWithKey = foldWithKey++foldlWithKey :: TKey k => (b -> k -> a -> b) -> b -> TMap k a -> b+foldlWithKey f z (TMap m) = foldlWithKeyM (\ k z (K0 a) -> f z (fromRep k) a) m z++traverseWithKey :: (TKey k, Applicative f) => (k -> a -> f b) -> TMap k a -> f (TMap k b)+traverseWithKey f (TMap m) = TMap <$> traverseWithKeyM sizeK0 (\ k (K0 a) -> K0 <$> f (fromRep k) a) m++map :: TKey k => (a -> b) -> TMap k a -> TMap k b+map = fmap++mapWithKey :: TKey k => (k -> a -> b) -> TMap k a -> TMap k b+mapWithKey f (TMap m) = TMap (mapWithKeyM sizeK0 (\ k (K0 a) -> K0 (f (fromRep k) a)) m)++mapKeys :: (TKey k, TKey k') => (k -> k') -> TMap k a -> TMap k' a+mapKeys f m = fromList [(f k, a) | (k, a) <- assocs m]++mapKeysWith :: (TKey k, TKey k') => (a -> a -> a) -> (k -> k') -> TMap k a -> TMap k' a+mapKeysWith g f m = fromListWith g [(f k, a) | (k, a) <- assocs m]++mapKeysMonotonic :: (TKey k, TKey k') => (k -> k') -> TMap k a -> TMap k' a+mapKeysMonotonic f m = fromDistinctAscList [(f k, a) | (k, a) <- assocs m]++union :: TKey k => TMap k a -> TMap k a -> TMap k a+union = unionWith const++unionWith :: TKey k => (a -> a -> a) -> TMap k a -> TMap k a -> TMap k a+unionWith = unionWithKey . const++unionWithKey :: TKey k => (k -> a -> a -> a) -> TMap k a -> TMap k a -> TMap k a+unionWithKey f = unionMaybeWithKey (\ k a b -> Just (f k a b))++unionMaybeWith :: TKey k => (a -> a -> Maybe a) -> TMap k a -> TMap k a -> TMap k a+unionMaybeWith = unionMaybeWithKey . const++unionMaybeWithKey :: TKey k => (k -> a -> a -> Maybe a) -> TMap k a -> TMap k a -> TMap k a+unionMaybeWithKey f (TMap m1) (TMap m2) = TMap (unionM sizeK0 f' m1 m2) where+	f' k (K0 a) (K0 b) = K0 <$> f (fromRep k) a b++symmetricDifference :: TKey k => TMap k a -> TMap k a -> TMap k a+symmetricDifference = unionMaybeWith (\ _ _ -> Nothing)++intersection :: TKey k => TMap k a -> TMap k b -> TMap k a+intersection = intersectionWith const++intersectionWith :: TKey k => (a -> b -> c) -> TMap k a -> TMap k b -> TMap k c+intersectionWith = intersectionWithKey . const++intersectionWithKey :: TKey k => (k -> a -> b -> c) -> TMap k a -> TMap k b -> TMap k c+intersectionWithKey f = intersectionMaybeWithKey (\ k a b -> Just (f k a b))++intersectionMaybeWith :: TKey k => (a -> b -> Maybe c) -> TMap k a -> TMap k b -> TMap k c+intersectionMaybeWith = intersectionMaybeWithKey . const++intersectionMaybeWithKey :: TKey k => (k -> a -> b -> Maybe c) -> TMap k a -> TMap k b -> TMap k c+intersectionMaybeWithKey f (TMap m1) (TMap m2) = TMap (isectM sizeK0 f' m1 m2) where+	f' k (K0 a) (K0 b) = K0 <$> f (fromRep k) a b++difference, (\\) :: TKey k => TMap k a -> TMap k b -> TMap k a+difference = differenceWith (\ x _ -> Nothing)++(\\) = difference++differenceWith :: TKey k => (a -> b -> Maybe a) -> TMap k a -> TMap k b -> TMap k a+differenceWith = differenceWithKey . const++differenceWithKey :: TKey k => (k -> a -> b -> Maybe a) -> TMap k a -> TMap k b -> TMap k a+differenceWithKey f (TMap m1) (TMap m2) = TMap (diffM sizeK0 f' m1 m2) where+	f' k (K0 a) (K0 b) = K0 <$> f (fromRep k) a b++minView, maxView :: TKey k => TMap k a -> Maybe (a, TMap k a)+minView m = first snd <$> minViewWithKey m+maxView m = first snd <$> maxViewWithKey m++findMin, findMax :: TKey k => TMap k a -> (k, a)+findMin = maybe (error "empty map has no minimal element") fst . minViewWithKey+findMax = maybe (error "empty map has no maximal element") fst . maxViewWithKey++deleteMin, deleteMax :: TKey k => TMap k a -> TMap k a+deleteMin m = maybe m snd (minViewWithKey m)+deleteMax m = maybe m snd (maxViewWithKey m)++updateMin, updateMax :: TKey k => (a -> Maybe a) -> TMap k a -> TMap k a+updateMin = updateMinWithKey . const+updateMax = updateMaxWithKey . const++updateMinWithKey, updateMaxWithKey :: TKey k => (k -> a -> Maybe a) -> TMap k a -> TMap k a+updateMinWithKey f (TMap m) = TMap (alterMinM sizeK0 (\ k (K0 a) -> K0 <$> f (fromRep k) a) m)+updateMaxWithKey f (TMap m) = TMap (alterMaxM sizeK0 (\ k (K0 a) -> K0 <$> f (fromRep k) a) m)++deleteFindMin, deleteFindMax :: TKey k => TMap k a -> ((k, a), TMap k a)+deleteFindMin m = fromMaybe (error "Cannot return the minimal element of an empty map") (minViewWithKey m)+deleteFindMax m = fromMaybe (error "Cannot return the maximal element of an empty map") (maxViewWithKey m)++minViewWithKey, maxViewWithKey :: TKey k => TMap k a -> Maybe ((k, a), TMap k a)+minViewWithKey (TMap m) = do+	((k, K0 a), m') <- getFirst (extractMinM sizeK0 m)+	return ((fromRep k, a), TMap m')+maxViewWithKey (TMap m) = do+	((k, K0 a), m') <- getLast (extractMaxM sizeK0 m)+	return ((fromRep k, a), TMap m')++elems :: TKey k => TMap k a -> [a]+elems = fmap snd . assocs++keys :: TKey k => TMap k a -> [k]+keys = fmap fst . assocs++assocs :: TKey k => TMap k a -> [(k, a)]+assocs m = build (\ c n -> foldWithKey (curry c) n m)++mapEither :: TKey k => (a -> Either b c) -> TMap k a -> (TMap k b, TMap k c)+mapEither = mapEitherWithKey . const++mapEitherWithKey :: TKey k => (k -> a -> Either b c) -> TMap k a -> (TMap k b, TMap k c)+mapEitherWithKey f (TMap m) = case mapEitherM sizeK0 sizeK0 f' m of+	(mL, mR) -> (TMap mL, TMap mR) +	where	f' k (K0 a) = case f (fromRep k) a of+			Left b	-> (Just (K0 b), Nothing)+			Right c	-> (Nothing, Just (K0 c))++mapMaybe :: TKey k => (a -> Maybe b) -> TMap k a -> TMap k b+mapMaybe = mapMaybeWithKey . const++mapMaybeWithKey :: TKey k => (k -> a -> Maybe b) -> TMap k a -> TMap k b+mapMaybeWithKey f (TMap m) = TMap (snd (mapEitherM sizeK0 sizeK0 f' m)) where+	f' k (K0 a) = (Nothing, K0 <$> f (fromRep k) a)++partition :: TKey k => (a -> Bool) -> TMap k a -> (TMap k a, TMap k a)+partition = partitionWithKey . const++partitionWithKey :: TKey k => (k -> a -> Bool) -> TMap k a -> (TMap k a, TMap k a)+partitionWithKey p = mapEitherWithKey (\ k a -> (if p k a then Left else Right) a)++filter :: TKey k => (a -> Bool) -> TMap k a -> TMap k a+filter = filterWithKey . const++filterWithKey :: TKey k => (k -> a -> Bool) -> TMap k a -> TMap k a+filterWithKey p = mapMaybeWithKey (\ k a -> if p k a then Just a else Nothing)++split :: TKey k => k -> TMap k a -> (TMap k a, TMap k a)+split k m = case splitLookup k m of+	(mL, _, mR) -> (mL, mR)++splitLookup :: TKey k => k -> TMap k a -> (TMap k a, Maybe a, TMap k a)+splitLookup k (TMap m) = case splitLookupM sizeK0 f (toRep k) m of+	(mL, x, mR) -> (TMap mL, x, TMap mR) +	where	f (K0 x) = (Nothing, Just x, Nothing)++isSubmapOf :: (TKey k, Eq a) => TMap k a -> TMap k a -> Bool+isSubmapOf = isSubmapOfBy (==)++isSubmapOfBy :: TKey k => (a -> b -> Bool) -> TMap k a -> TMap k b -> Bool+isSubmapOfBy (<=) (TMap m1) (TMap m2) = isSubmapM (<<=) m1 m2 where+	K0 a <<= K0 b = a <= b++fromList, fromAscList :: TKey k => [(k, a)] -> TMap k a+fromList = fromListWith const+fromAscList = fromAscListWith const++fromListWith, fromAscListWith :: TKey k => (a -> a -> a) -> [(k, a)] -> TMap k a+fromListWith = fromListWithKey . const+fromAscListWith = fromAscListWithKey . const++fromListWithKey, fromAscListWithKey :: TKey k => (k -> a -> a -> a) -> [(k, a)] -> TMap k a+fromListWithKey f xs = TMap (fromListM sizeK0 (\ k (K0 a) (K0 b) -> K0 (f (fromRep k) a b)) [(toRep k, K0 a) | (k, a) <- xs])+fromAscListWithKey f xs = TMap (fromAscListM sizeK0 (\ k (K0 a) (K0 b) -> K0 (f (fromRep k) a b)) [(toRep k, K0 a) | (k, a) <- xs])++fromDistinctAscList :: TKey k => [(k, a)] -> TMap k a+fromDistinctAscList xs = TMap (fromDistAscListM sizeK0 [(toRep k, K0 a) | (k, a) <- xs])++size :: TKey k => TMap k a -> Int+size (TMap m) = sizeM sizeK0 m++member :: TKey k => k -> TMap k a -> Bool+member = isJust .: lookup++notMember :: TKey k => k -> TMap k a -> Bool+notMember = not .: member

@@ -0,0 +1,46 @@+{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-}++module Data.TrieMap.Applicative where++import Control.Applicative+import Control.Monad++import Data.Monoid++newtype Id a = Id {unId :: a}++deriving instance Functor First+deriving instance Functor Last+deriving instance Monad First+deriving instance Monad Last++instance Applicative Id where+	pure = Id+	Id f <*> Id x = Id (f x)++instance Functor Id where+	fmap f (Id x) = Id (f x)++instance MonadPlus First where+	mzero = mempty+	mplus = mappend++instance MonadPlus Last where+	mzero = mempty+	mplus = mappend++-- instance Monad First where+-- 	return x = First (Just x)+-- 	First Nothing >>= _ = First Nothing+-- 	First (Just x) >>= k = k x+-- +-- instance Monad Last++(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+(f .: g) x y = f (g x y)++(<.>) :: Functor f => (b -> c) -> (a -> f b) -> a -> f c+f <.> g = fmap f . g++(<.:>) :: Functor f => (c -> d) -> (a -> b -> f c) -> a -> b -> f d+(f <.:> g) x y = f <$> g x y

@@ -0,0 +1,36 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances #-}++module Data.TrieMap.Class (TMap(..), TKey(..), Rep, Ordered (..), TrieMap, TrieKey) where++import Data.TrieMap.TrieKey+import Data.TrieMap.OrdMap++import Control.Applicative+import Data.Foldable+import Data.Traversable++-- import Generics.MultiRec.Base+import Data.TrieMap.Regular.Base+import Data.TrieMap.Regular.Sized++import Prelude hiding (foldr)++newtype TMap k a = TMap {getTMap :: TrieMap (Rep k) (K0 a) (Rep k)}++type family Rep k++class TrieKey (Rep k) (TrieMap (Rep k)) => TKey k where+	toRep :: k -> Rep k+	fromRep :: Rep k -> k++instance TKey k => Functor (TMap k) where+	fmap = fmapDefault++instance TKey k => Foldable (TMap k) where+	foldr f z (TMap m) = foldWithKeyM (\ _ (K0 a) -> f a) m z++instance TKey k => Traversable (TMap k) where+	traverse = trv+-- 	traverse f (TMap m) = TMap <$> traverseWithKeyM (\ _ (K0 a) -> K0 <$> f a) m+trv :: (Applicative f, TKey k) => (a -> f b) -> TMap k a -> f (TMap k b)+trv f (TMap m) = TMap <$> traverseWithKeyM sizeK0 (\ _ (K0 a) -> K0 <$> f a) m

@@ -0,0 +1,180 @@+{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances #-}++module Data.TrieMap.Class.Instances where++import Data.TrieMap.Class+-- import Data.TrieMap.RadixTrie()+import Data.TrieMap.MultiRec.Instances+import Data.TrieMap.IntMap()+import Data.TrieMap.OrdMap(Ordered(..))+import Data.TrieMap.Class+import Data.TrieMap.Regular.Base+import Data.TrieMap.Regular.Class+import Data.TrieMap.Regular.Instances+-- import Data.TrieMap.UnionMap()+-- import Data.TrieMap.UnitMap()++import Data.Bits+import Data.Char+import Data.Complex+import Data.Either+import Data.Foldable+import Data.Int +import Data.List hiding (foldr)+import Data.Word++import Prelude hiding (foldr)+{-+instance TKey k => TKey [k] where+	type Rep [k] = L I0 (Rep k)+	toRep = map toRep+	fromRep = map fromRep-}++type instance Rep Int = Ordered Int+instance TKey Int where+	toRep = Ord+	fromRep = unOrd++type instance Rep Double = Ordered Double+instance TKey Double where+	toRep = Ord+	fromRep = unOrd++type instance Rep Char = Int+instance TKey Char where+	toRep = ord+	fromRep = chr++type instance Rep Word = Int+instance TKey Word where+	toRep = fromEnum+	fromRep = toEnum++type instance Rep Word8 = Int+instance TKey Word8 where+	toRep = fromEnum+	fromRep = toEnum++type instance Rep Word16 = Int+instance TKey Word16 where+	toRep = fromEnum+	fromRep = toEnum++type instance Rep Word32 = Int+instance TKey Word32 where+	toRep = fromEnum+	fromRep = toEnum++type instance Rep Int8 = Int+instance TKey Int8 where+	toRep = fromIntegral+	fromRep = fromIntegral++type instance Rep Int16 = Int+instance TKey Int16 where+	toRep = fromIntegral+	fromRep = fromIntegral++type instance Rep Int32 = Int+instance TKey Int32 where+	toRep = fromIntegral+	fromRep = fromIntegral+-- +-- type instance Rep (Complex a) = Rep (a, a)+-- instance (RealFloat a, TKey a) => TKey (Complex a) where+-- 	toRep (a :+ b) = toRep (a, b)+-- 	fromRep = uncurry (:+) . fromRep++type instance Rep Integer = Rep [Int32]+instance TKey Integer where+	toRep = toRep . unroll+	fromRep = roll . fromRep++unroll :: Integer -> [Int32]+unroll = unfoldr step where+	step 0 = Nothing+	step i = Just (fromIntegral i,  i `shiftR` 32)++roll :: [Int32] -> Integer+roll = foldr unstep 0 where+	unstep b a = a `shiftL` 32 .|. fromIntegral b++type instance Rep () = U0 ()+instance TKey () where+	toRep _ = U0+	fromRep _ = ()++type instance Rep (Either a b) = (K0 (Rep a) :+: I0) (Rep b)+instance (TKey a, TKey b) => TKey (Either a b) where+	toRep = either (L . K0 . toRep) (R . I0 . toRep)+	fromRep = either' (Left . unK0 . fromRep) (Right . unI0 . fromRep)++either' :: (f r -> a) -> (g r -> a) -> (f :+: g) r -> a+either' f g x = case x of+	L x	-> f x+	R x	-> g x++type instance Rep (a, b) = (K0 (Rep a) :*: I0) (Rep b)+instance (TKey a, TKey b) => TKey (a, b) where+	toRep (a, b) = K0 (toRep a) :*: I0 (toRep b)+	fromRep (K0 a :*: I0 b) = (fromRep a, fromRep b)++type instance Rep (a, b, c) = (K0 (Rep a) :*: K0 (Rep b) :*: I0) (Rep c)+instance (TKey a, TKey b, TKey c) => TKey (a, b, c) where+	toRep (a, b, c) = K0 (toRep a) :*: K0 (toRep b) :*: I0 (toRep c)+	fromRep (K0 a :*: K0 b :*: I0 c) = (fromRep a, fromRep b, fromRep c)++type instance Rep (a, b, c, d) = (K0 (Rep a) :*: K0 (Rep b) :*: K0 (Rep c) :*: I0) (Rep d)+instance (TKey a, TKey b, TKey c, TKey d) => TKey (a, b, c, d) where+	toRep (a, b, c, d) = K0 (toRep a) :*: K0 (toRep b) :*: K0 (toRep c) :*: I0 (toRep d)+	fromRep (K0 a :*: K0 b :*: K0 c :*: I0 d) = (fromRep a, fromRep b, fromRep c, fromRep d)++type instance Rep (a, b, c, d, e) = (K0 (Rep a) :*: K0 (Rep b) :*: K0 (Rep c) :*: K0 (Rep d) :*: I0) (Rep e)+instance (TKey a, TKey b, TKey c, TKey d, TKey e) => TKey (a, b, c, d, e) where+	toRep (a, b, c, d, e) = K0 (toRep a) :*: K0 (toRep b) :*: K0 (toRep c) :*: K0 (toRep d) :*: I0 (toRep e)+	fromRep (K0 a :*: K0 b :*: K0 c :*: K0 d :*: I0 e) = (fromRep a, fromRep b, fromRep c, fromRep d, fromRep e)++type instance Rep (Maybe a) = (U0 :+: I0) (Rep a)+instance TKey a => TKey (Maybe a) where+	toRep = maybe (L U0) (R . I0 . toRep)+	fromRep = either' (const Nothing) (Just . fromRep . unI0)++type instance Rep [a] = L I0 (Rep a)+instance TKey a => TKey [a] where+	toRep xs = List [I0 (toRep x) | x <- xs]+	fromRep (List xs) = [fromRep x | I0 x <- xs]++type instance Rep ((f :*: g) r) = (f :*: g) (Rep r)+instance (TKey a, TrieKeyT f (TrieMapT f), TrieKeyT g (TrieMapT g), Functor f, Functor g) => TKey ((f :*: g) a) where+	toRep = fmap toRep+	fromRep = fmap fromRep++type instance Rep ((f :+: g) r) = (f :+: g) (Rep r)+instance (TKey a, TrieKeyT f (TrieMapT f), TrieKeyT g (TrieMapT g), Functor f, Functor g) => TKey ((f :+: g) a) where+	toRep = fmap toRep+	fromRep = fmap fromRep+{-+type instance Rep [r] = L I0 (Rep r)+instance TKey r => TKey [r] where+	toRep = List . map (I0 . toRep)+	fromRep (List xs) = [fromRep x | I0 x <- xs]-}++type instance Rep (L f r) = L f (Rep r)+instance (TKey a, TrieKeyT f (TrieMapT f), Functor f) => TKey (L f a) where+	toRep = fmap toRep+	fromRep = fmap fromRep++type instance Rep (U0 r) = U0 r+instance TKey (U0 r) where+	toRep _ = U0+	fromRep _ = U0++type instance Rep (K0 k r) = K0 (Rep k) r+instance TKey k => TKey (K0 k r) where+	toRep (K0 a) = K0 (toRep a)+	fromRep (K0 a) = K0 (fromRep a)++type instance Rep (I0 r) = I0 (Rep r)+instance TKey r => TKey (I0 r) where+	toRep = fmap toRep+	fromRep = fmap fromRep

@@ -0,0 +1,478 @@+{-# LANGUAGE BangPatterns, Rank2Types, CPP, MagicHash, PatternGuards, MultiParamTypeClasses, TypeFamilies #-}++module Data.TrieMap.IntMap () where++import Data.TrieMap.TrieKey+import Data.TrieMap.Applicative+import Data.TrieMap.Sized++import Control.Applicative (Applicative(..), (<$>))+import Control.Arrow++import Data.Bits+import Data.Maybe+import Data.Monoid+import Data.Word++#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts ( Word(..), Int(..), shiftRL# )+#elif __GLASGOW_HASKELL__+import Word+import GlaExts ( Word(..), Int(..), shiftRL# )+#else+import Data.Word+#endif++import Prelude hiding (lookup, null, foldl, foldr)++type Nat = Word++data IntMap a ix = Nil+              | Tip {-# UNPACK #-} !Size {-# UNPACK #-} !Key (a ix)+              | Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(IntMap a ix) !(IntMap a ix) +type instance TrieMap Int = IntMap++type Prefix = Int+type Mask   = Int+type Key    = Int+type Size   = Int++instance TrieKey Int IntMap where+	emptyM = Nil+	nullM = null+	sizeM _ = size+	lookupM = lookup . natFromInt+	lookupIxM _ = lookupIx . natFromInt+	assocAtM _ = fromJust .: assocAt+	updateAtM = updateAt+	alterM = alter+	traverseWithKeyM = traverseWithKey+	foldWithKeyM = foldr+	foldlWithKeyM = foldl+	mapEitherM = mapEither+	splitLookupM = splitLookup+	unionM = unionWithKey+	isectM = intersectionWithKey+	diffM = differenceWithKey+	extractMinM _ = First . minViewWithKey+	extractMaxM _ = Last . maxViewWithKey+	alterMinM = updateMinWithKey+	alterMaxM = updateMaxWithKey+	isSubmapM = isSubmapOfBy++natFromInt :: Int -> Nat+natFromInt = fromIntegral++intFromNat :: Nat -> Int+intFromNat = fromIntegral++shiftRL :: Nat -> Key -> Nat+#if __GLASGOW_HASKELL__+{--------------------------------------------------------------------+  GHC: use unboxing to get @shiftRL@ inlined.+--------------------------------------------------------------------}+shiftRL (W# x) (I# i)+  = W# (shiftRL# x i)+#else+shiftRL x i   = shiftR x i+#endif+++size :: IntMap a ix -> Int+size Nil = 0+size (Tip s _ _) = s+size (Bin s _ _ _ _) = s++null :: IntMap a ix -> Bool+null Nil = True+null _ = False++lookup :: Nat -> IntMap a ix -> Maybe (a ix)+lookup k (Bin _ _ m l r) = lookup k (if zeroN k (natFromInt m) then l else r)+lookup k (Tip _ kx x)+	| k == natFromInt kx	= Just x+lookup _ _ = Nothing++lookupIx :: Nat -> IntMap a ix -> Maybe (Int, a ix)+lookupIx k t = case t of+	Bin _ 0 m l r | m < 0	-> if zeroN k (natFromInt m) then lookupIx' (size r) k l else lookupIx' 0 k r+	Bin{}	-> lookupIx' 0 k t+	Tip _ k x -> return (0, x)+	Nil	-> Nothing++assocAt :: Int -> IntMap a ix -> Maybe (Int, Key, a ix)+assocAt !i t = case t of+	Bin _ 0 m l r | m < 0	-> let sr = size r in+		if i < sr then assocAt' 0 i r else assocAt' sr (i - sr) l+	Bin{} -> assocAt' 0 i t+	Tip _ k x -> return (0, k, x)+	_	-> Nothing++assocAt' :: Int -> Int -> IntMap a ix -> Maybe (Int, Key, a ix)+assocAt' !i0 !i (Bin _ _ _ l r)+	| i < sl	= assocAt' i0 i l+	| otherwise	= assocAt' (i0 + sl) (i - sl) r+	where	sl = size l+assocAt' i0 _ (Tip _ k x) = return (i0, k, x)+assocAt' _ _ _ = Nothing++updateAt :: Sized a -> (Int -> Key -> a ix -> Maybe (a ix)) -> Int -> IntMap a ix -> IntMap a ix+updateAt s f !i t = case t of+	Bin _ 0 m l r | m < 0	-> let sr = size r in+		if i < sr then updateAt' s 0 f i r else updateAt' s sr f (i - sr) l+	Bin{}	-> updateAt' s 0 f i t+	Tip _ kx x -> singletonMaybe s kx (f 0 kx x)+	Nil	-> Nil++updateAt' :: Sized a -> Int -> (Int -> Key -> a ix -> Maybe (a ix)) -> Int -> IntMap a ix -> IntMap a ix+updateAt' s !i0 f !i t = case t of+	Bin _ p m l r -> let sl = size l in+		if i < sl then bin p m (updateAt' s i0 f i l) r +			else bin p m l (updateAt' s (i0 + sl) f (i - sl) r)++lookupIx' :: Int -> Nat -> IntMap a ix -> Maybe (Int, a ix)+lookupIx' !i k t = case t of+	Bin _ _ m l r+		| zeroN k (natFromInt m)	-> lookupIx' i k l+		| otherwise			-> lookupIx' (i + size l) k r+	Tip _ kx x+		| k == natFromInt kx		-> Just (i, x)+	_ -> Nothing++singleton :: Sized a -> Key -> a ix -> IntMap a ix+singleton s k a = Tip (s a) k a++singletonMaybe :: Sized a -> Key -> Maybe (a ix) -> IntMap a ix+singletonMaybe s k = maybe Nil (singleton s k)++alter :: Sized a -> (Maybe (a ix) -> Maybe (a ix)) -> Int -> IntMap a ix -> IntMap a ix+alter s f k t = case t of+	Bin sz p m l r+		| nomatch k p m	-> singletonMaybe s k (f Nothing)+		| zero k m	-> bin p m (alter s f k l) r+		| otherwise	-> bin p m l (alter s f k r)+	Tip sz ky y+		| k == ky	-> singletonMaybe s k (f (Just y))+		| Just x <- f Nothing+				-> join k (Tip (s x) k x) ky t+		| otherwise	-> Tip sz ky y+	Nil	-> singletonMaybe s k (f Nothing)++traverseWithKey :: Applicative f => Sized b -> (Key -> a ix -> f (b ix)) -> IntMap a ix -> f (IntMap b ix)+traverseWithKey s f t = case t of+	Nil		-> pure Nil+	Tip _ kx x	-> singleton s kx <$> f kx x+	Bin _ p m l r	-> bin p m <$> traverseWithKey s f l <*> traverseWithKey s f r++foldr :: (Key -> a ix -> b -> b) -> IntMap a ix -> b -> b+foldr f t+  = case t of+      Bin _ 0 m l r | m < 0 -> foldr' f r . foldr' f l  -- put negative numbers before.+      Bin _ _ _ _ _ -> foldr' f t+      Tip _ k x     -> f k x+      Nil         -> id++foldr' :: (Key -> a ix -> b -> b) -> IntMap a ix -> b -> b+foldr' f t+  = case t of+      Bin _ _ _ l r -> foldr' f l . foldr' f r+      Tip _ k x     -> f k x+      Nil         -> id++foldl, foldl' :: (Key -> b -> a ix -> b) -> IntMap a ix -> b -> b+foldl f t+  = case t of+      Bin _ 0 m l r | m < 0 -> foldl' f l . foldl' f r  -- put negative numbers before.+      Bin _ _ _ _ _ -> foldl' f t+      Tip _ k x     -> flip (f k) x+      Nil           -> id+foldl' f t+  = case t of+      Bin _ _ _ l r -> foldl' f r . foldl' f l+      Tip _ k x     -> flip (f k) x+      Nil         -> id++mapEither :: Sized b -> Sized c -> EitherMap Key (a ix) (b ix) (c ix) ->+	IntMap a ix -> (IntMap b ix, IntMap c ix)+mapEither s1 s2 f (Bin _ p m l r) = case (mapEither s1 s2 f l, mapEither s1 s2 f r) of+	((lL, lR), (rL, rR)) -> (bin p m lL rL, bin p m lR rR)+mapEither s1 s2 f (Tip _ kx x) = (singletonMaybe s1 kx *** singletonMaybe s2 kx) (f kx x)++splitLookup :: Sized a -> SplitMap (a ix) x -> Key -> IntMap a ix -> (IntMap a ix ,Maybe x,IntMap a ix)+splitLookup s f k t+  = case t of+      Bin _ _ m l r+          | m < 0 -> (if k >= 0 -- handle negative numbers.+                      then let (lt,found,gt) = splitLookup' s f k l in (union r lt,found, gt)+                      else let (lt,found,gt) = splitLookup' s f k r in (lt,found, union gt l))+          | otherwise   -> splitLookup' s f k t+      Tip _ ky y +        | k>ky      -> (t,Nothing,Nil)+        | k<ky      -> (Nil,Nothing,t)+        | otherwise -> singletonMaybe s k `sides` f y+      Nil -> (Nil,Nothing,Nil)++splitLookup' :: Sized a -> SplitMap (a ix) x -> Key -> IntMap a ix -> (IntMap a ix ,Maybe x,IntMap a ix)+splitLookup' s f k t+  = case t of+      Bin _ p m l r+        | nomatch k p m -> if k>p then (t,Nothing,Nil) else (Nil,Nothing,t)+        | zero k m  -> let (lt,found,gt) = splitLookup s f k l in (lt,found,union gt r)+        | otherwise -> let (lt,found,gt) = splitLookup s f k r in (union l lt,found,gt)+      Tip _ ky y +        | k>ky      -> (t,Nothing,Nil)+        | k<ky      -> (Nil,Nothing,t)+        | otherwise -> singletonMaybe s k `sides` f y+      Nil -> (Nil,Nothing,Nil)++union :: IntMap a ix -> IntMap a ix -> IntMap a ix+union t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)+  | shorter m1 m2  = union1+  | shorter m2 m1  = union2+  | p1 == p2       = bin p1 m1 (union l1 l2) (union r1 r2)+  | otherwise      = join p1 t1 p2 t2+  where+    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2+            | zero p2 m1        = bin p1 m1 (union l1 t2) r1+            | otherwise         = bin p1 m1 l1 (union r1 t2)++    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2+            | zero p1 m2        = bin p2 m2 (union t1 l2) r2+            | otherwise         = bin p2 m2 l2 (union t1 r2)++unionWithKey :: Sized a -> UnionFunc Key (a ix) -> IntMap a ix -> IntMap a ix -> IntMap a ix+unionWithKey s f t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)+  | shorter m1 m2  = union1+  | shorter m2 m1  = union2+  | p1 == p2       = bin p1 m1 (unionWithKey s f l1 l2) (unionWithKey s f r1 r2)+  | otherwise      = join p1 t1 p2 t2+  where+    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2+            | zero p2 m1        = bin p1 m1 (unionWithKey s f l1 t2) r1+            | otherwise         = bin p1 m1 l1 (unionWithKey s f r1 t2)++    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2+            | zero p1 m2        = bin p2 m2 (unionWithKey s f t1 l2) r2+            | otherwise         = bin p2 m2 l2 (unionWithKey s f t1 r2)+unionWithKey s f (Tip _ k x) t = alter s (maybe (Just x) (f k x)) k t+unionWithKey s f t (Tip _ k x) = alter s (maybe (Just x) (flip (f k) x)) k t+unionWithKey _ _ Nil t  = t+unionWithKey _ _ t Nil  = t++intersectionWithKey :: Sized c -> IsectFunc Key (a ix) (b ix) (c ix) -> IntMap a ix -> IntMap b ix -> IntMap c ix+intersectionWithKey s f t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)+  | shorter m1 m2  = intersection1+  | shorter m2 m1  = intersection2+  | p1 == p2       = bin p1 m1 (intersectionWithKey s f l1 l2) (intersectionWithKey s f r1 r2)+  | otherwise      = Nil+  where+    intersection1 | nomatch p2 p1 m1  = Nil+                  | zero p2 m1        = intersectionWithKey s f l1 t2+                  | otherwise         = intersectionWithKey s f r1 t2++    intersection2 | nomatch p1 p2 m2  = Nil+                  | zero p1 m2        = intersectionWithKey s f t1 l2+                  | otherwise         = intersectionWithKey s f t1 r2++intersectionWithKey s f (Tip _ k x) t2+  = singletonMaybe s k (lookup (natFromInt k) t2 >>= f k x)+intersectionWithKey s f t1 (Tip _ k y) +  = singletonMaybe s k (lookup (natFromInt k) t1 >>= flip (f k) y)+intersectionWithKey _ _ Nil _ = Nil+intersectionWithKey _ _ _ Nil = Nil++differenceWithKey :: Sized a -> (Key -> a ix -> b ix -> Maybe (a ix)) -> IntMap a ix -> IntMap b ix -> IntMap a ix+differenceWithKey s f t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)+  | shorter m1 m2  = difference1+  | shorter m2 m1  = difference2+  | p1 == p2       = bin p1 m1 (differenceWithKey s f l1 l2) (differenceWithKey s f r1 r2)+  | otherwise      = t1+  where+    difference1 | nomatch p2 p1 m1  = t1+                | zero p2 m1        = bin p1 m1 (differenceWithKey s f l1 t2) r1+                | otherwise         = bin p1 m1 l1 (differenceWithKey s f r1 t2)++    difference2 | nomatch p1 p2 m2  = t1+                | zero p1 m2        = differenceWithKey s f t1 l2+                | otherwise         = differenceWithKey s f t1 r2++differenceWithKey s f t1@(Tip _ k x) t2 +  = maybe t1 (singletonMaybe s k . f k x) (lookup (natFromInt k) t2)+differenceWithKey _ _ Nil _       = Nil+differenceWithKey s f t (Tip _ k y) = alter s (>>= flip (f k) y) k t+differenceWithKey _ _ t Nil       = t++isSubmapOfBy :: LEq (a ix) (b ix) -> LEq (IntMap a ix) (IntMap b ix)+isSubmapOfBy (<=) t1@(Bin _ p1 m1 l1 r1) (Bin _ p2 m2 l2 r2)+  | shorter m1 m2  = False+  | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then isSubmapOfBy (<=) t1 l2+                                                      else isSubmapOfBy (<=) t1 r2)                     +  | otherwise      = (p1==p2) && isSubmapOfBy (<=) l1 l2 && isSubmapOfBy (<=) r1 r2+isSubmapOfBy _         (Bin _ _ _ _ _) _ = False+isSubmapOfBy (<=) (Tip _ k x) t     = maybe False (x <=) (lookup (natFromInt k) t)+isSubmapOfBy _         Nil _           = True+++maxViewWithKey, minViewWithKey :: IntMap a ix -> Maybe ((Key, a ix), IntMap a ix)+maxViewWithKey t+    = case t of+        Bin _ p m l r | m < 0 -> let (result, t') = maxViewUnsigned l in Just (result, bin p m t' r)+        Bin _ p m l r         -> let (result, t') = maxViewUnsigned r in Just (result, bin p m l t')+        Tip _ k y -> Just ((k,y), Nil)+        Nil -> Nothing++maxViewUnsigned, minViewUnsigned :: IntMap a ix -> ((Key, a ix), IntMap a ix)+maxViewUnsigned t +    = case t of+        Bin _ p m l r -> let (result,t') = maxViewUnsigned r in (result,bin p m l t')+        Tip _ k y -> ((k,y), Nil)+        Nil -> error "maxViewUnsigned Nil"++-- +-- minViewWithKey :: IntMap a ix -> Maybe ((Key, a ix), IntMap a ix)+minViewWithKey t+    = case t of+        Bin _ p m l r | m < 0 -> let (result, t') = minViewUnsigned r in Just (result, bin p m l t')+        Bin _ p m l r         -> let (result, t') = minViewUnsigned l in Just (result, bin p m t' r)+        Tip _ k y -> Just ((k,y),Nil)+        Nil -> Nothing++-- minViewUnsigned :: IntMap a ix -> ((Key, a ix), IntMap a ix)+minViewUnsigned t +    = case t of+        Bin _ p m l r -> let (result,t') = minViewUnsigned l in (result,bin p m t' r)+        Tip _ k y -> ((k,y),Nil)+        Nil -> error "minViewUnsigned Nil"++updateMinWithKey :: Sized a -> (Key -> a ix -> Maybe (a ix)) -> IntMap a ix -> IntMap a ix+updateMinWithKey s f t+    = case t of+        Bin _ p m l r | m < 0 -> let t' = updateMinWithKeyUnsigned s f r in bin p m l t'+        Bin _ p m l r         -> let t' = updateMinWithKeyUnsigned s f l in bin p m t' r+        Tip _ k y -> singletonMaybe s k (f k y)+        Nil -> Nil++updateMinWithKeyUnsigned :: Sized a -> (Key -> a ix -> Maybe (a ix)) -> IntMap a ix -> IntMap a ix+updateMinWithKeyUnsigned s f t+    = case t of+        Bin _ p m l r -> let t' = updateMinWithKeyUnsigned s f l in bin p m t' r+        Tip _ k y -> singletonMaybe s k (f k y)+        Nil -> Nil++updateMaxWithKey :: Sized a -> (Key -> a ix -> Maybe (a ix)) -> IntMap a ix -> IntMap a ix+updateMaxWithKey s f t+    = case t of+        Bin _ p m l r | m < 0 -> let t' = updateMaxWithKeyUnsigned s f l in bin p m t' r+        Bin _ p m l r         -> let t' = updateMaxWithKeyUnsigned s f r in bin p m l t'+        Tip _ k y -> singletonMaybe s k (f k y)+        Nil -> Nil++updateMaxWithKeyUnsigned :: Sized a -> (Key -> a ix -> Maybe (a ix)) -> IntMap a ix -> IntMap a ix+updateMaxWithKeyUnsigned s f t+    = case t of+        Bin _ p m l r -> let t' = updateMaxWithKeyUnsigned s f r in bin p m l t'+        Tip _ k y -> singletonMaybe s k (f k y)+        Nil -> Nil++mask :: Key -> Mask -> Prefix+mask i m+  = maskW (natFromInt i) (natFromInt m)++zero :: Key -> Mask -> Bool+zero i m+  = (natFromInt i) .&. (natFromInt m) == 0++nomatch,match :: Key -> Prefix -> Mask -> Bool+nomatch i p m+  = (mask i m) /= p++match i p m+  = (mask i m) == p++zeroN :: Nat -> Nat -> Bool+zeroN i m = (i .&. m) == 0++maskW :: Nat -> Nat -> Prefix+maskW i m+  = intFromNat (i .&. (complement (m-1) `xor` m))++shorter :: Mask -> Mask -> Bool+shorter m1 m2+  = (natFromInt m1) > (natFromInt m2)++branchMask :: Prefix -> Prefix -> Mask+branchMask p1 p2+  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))++highestBitMask :: Nat -> Nat+highestBitMask x0+  = case (x0 .|. shiftRL x0 1) of+     x1 -> case (x1 .|. shiftRL x1 2) of+      x2 -> case (x2 .|. shiftRL x2 4) of+       x3 -> case (x3 .|. shiftRL x3 8) of+        x4 -> case (x4 .|. shiftRL x4 16) of+         x5 -> case (x5 .|. shiftRL x5 32) of   -- for 64 bit platforms+          x6 -> (x6 `xor` (shiftRL x6 1))++join :: Prefix -> IntMap a ix -> Prefix -> IntMap a ix -> IntMap a ix+join p1 t1 p2 t2+  | zero p1 m = bin p m t1 t2+  | otherwise = bin p m t2 t1+  where+    m = branchMask p1 p2+    p = mask p1 m++bin :: Prefix -> Mask -> IntMap a ix -> IntMap a ix -> IntMap a ix+bin _ _ l Nil = l+bin _ _ Nil r = r+bin p m l r   = Bin (size l + size r) p m l r++-- import Data.Monoid+-- import Data.IntMap+-- import qualified Data.IntMap as IMap+-- import Data.Traversable+-- +-- newtype IntTMap a ix = ITMap (IntMap (a ix))+-- type instance TrieMap Int = IntTMap+-- newtype MaybeF a ix = MF {unF :: Maybe (a ix)}+-- +-- instance TrieKey Int IntTMap where+-- 	emptyM = ITMap empty+-- 	nullM (ITMap m) = IMap.null m+-- 	alterM _ f k (ITMap m) = ITMap (IMap.alter f k m)+-- 	lookupM k (ITMap m) = IMap.lookup k m+-- 	traverseWithKeyM _ f (ITMap m) = (ITMap . IMap.fromDistinctAscList) <$>+-- 		sequenceA (IMap.foldWithKey (\ k a xs -> (((,) k) <$> f k a):xs) [] m)+-- 	foldWithKeyM f (ITMap m) z = IMap.foldWithKey f z m+-- 	foldlWithKeyM f (ITMap m) z = foldl (\ z (k, a) -> f k z a) z (IMap.assocs m)+-- 	mapEitherM _ _ f (ITMap m) = (ITMap (mapMaybe fst m'), ITMap (mapMaybe snd m')) where+-- 		m' = mapWithKey f m+-- 	splitLookupM _ f k (ITMap m) = ITMap `sides` case splitLookup k m of+-- 		(mL, x, mR)+-- 			| Nothing <- x	-> (mL, Nothing, mR)+-- 			| Just x <- x, (xL, x, xR) <- f x+-- 				-> (mIns k mL xL, x, mIns k mR xR)+-- 		where	mIns k m = maybe m (\ x -> IMap.insert k x m)+-- 	unionM _ f (ITMap m1) (ITMap m2) = ITMap (mapMaybe unF (unionWithKey f' m1' m2')) where+-- 		f' k (MF a) (MF b) = MF (unionMaybe (f k) a b)+-- 		m1' = fmap (MF . Just) m1+-- 		m2' = fmap (MF . Just) m2+-- 	isectM _ f (ITMap m1) (ITMap m2) = ITMap (mapMaybe unF (intersectionWithKey f' m1' m2')) where+-- 		f' k (MF a) (MF b) = MF (isectMaybe (f k) a b)+-- 		m1' = fmap (MF . Just) m1+-- 		m2' = fmap (MF . Just) m2+-- 	diffM _ f (ITMap m1) (ITMap m2) = ITMap (differenceWithKey f m1 m2)+-- 	extractMinM _ (ITMap m) = fmap ITMap <$> First (minViewWithKey m)+-- 	extractMaxM _ (ITMap m) = fmap ITMap <$> Last (maxViewWithKey m)+-- 	alterMinM _ f (ITMap m) = ITMap $ case minViewWithKey m of+-- 		Just ((k, v), m') +-- 				-> maybe m' (\ v' -> updateMin (const v') m) (f k v)+-- 		Nothing		-> m+-- 	alterMaxM _ f (ITMap m) = ITMap $ case maxViewWithKey m of+-- 		Just ((k, v), m')+-- 				-> maybe m' (\ v' -> updateMax (const v') m) (f k v)+-- 		Nothing		-> m+-- 	isSubmapM (<=) (ITMap m1) (ITMap m2) = isSubmapOfBy (<=) m1 m2+-- 	fromListM _ = ITMap .: fromListWithKey+-- 	fromAscListM _ = ITMap .: fromAscListWithKey+-- 	fromDistAscListM _ = ITMap . fromDistinctAscList

@@ -0,0 +1,6 @@+module Data.TrieMap.MultiRec (HTrieKey, HTrieKeyT, Family(..), HEq0(..), HOrd0(..), HOrd(..)) where++import Data.TrieMap.MultiRec.Class+import Data.TrieMap.MultiRec.FamMap (Family (..))+import Data.TrieMap.MultiRec.Eq+import Data.TrieMap.MultiRec.Ord

@@ -0,0 +1,122 @@+{-# LANGUAGE Rank2Types, FunctionalDependencies, FlexibleContexts, KindSignatures, TypeFamilies, MultiParamTypeClasses #-}++module Data.TrieMap.MultiRec.Class where++import Data.TrieMap.MultiRec.Sized+import Data.TrieMap.MultiRec.Eq+import Data.TrieMap.MultiRec.Ord+import Data.TrieMap.TrieKey+import Data.TrieMap.Applicative++import Control.Applicative+import Data.Monoid+import Generics.MultiRec.Eq++type family HTrieMapT (phi :: * -> *) (f :: (* -> *) -> * -> *) :: (* -> *) -> (* -> *) -> * -> *+type family HTrieMap (phi :: * -> *) (r :: * -> *) :: (* -> *) -> * -> *++class HOrd phi f => HTrieKeyT (phi :: * -> *) (f :: (* -> *) -> * -> *) m | phi f -> m, m -> phi f where+	emptyT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> m r a ix+	nullT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> m r a ix -> Bool+	sizeT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => HSized phi a -> m r a ix -> Int+	lookupT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> f r ix -> m r a ix -> Maybe (a ix)+	lookupIxT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> HSized phi a -> f r ix -> m r a ix -> Maybe (Int, a ix)+	assocAtT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> HSized phi a -> Int -> m r a ix -> (Int, f r ix, a ix)+	updateAtT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +		phi ix -> HSized phi a -> (Int -> f r ix -> a ix -> Maybe (a ix)) -> Int -> m r a ix -> m r a ix+	alterT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +		phi ix -> HSized phi a -> (Maybe (a ix) -> Maybe (a ix)) -> f r ix ->+			m r a ix -> m r a ix+	{-# SPECIALIZE traverseWithKeyT :: HTrieKey phi r =>+		phi ix -> HSized phi b -> (f r ix -> a ix -> Id (b ix)) -> m r a ix -> Id (m r b ix) #-}+	traverseWithKeyT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r), Applicative t) =>+		phi ix -> HSized phi b -> (f r ix -> a ix -> t (b ix)) -> m r a ix -> t (m r b ix)+	foldWithKeyT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +		phi ix -> (f r ix -> a ix -> b -> b) -> m r a ix -> b -> b+	foldlWithKeyT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>+		phi ix -> (f r ix -> b -> a ix -> b) -> m r a ix -> b -> b+	mapEitherT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> +		HSized phi b -> HSized phi c -> EitherMap (f r ix) (a ix) (b ix) (c ix) -> m r a ix -> (m r b ix, m r c ix)+	splitLookupT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +		phi ix -> HSized phi a -> SplitMap (a ix) x -> f r ix ->+			m r a ix -> (m r a ix, Maybe x, m r a ix)+	unionT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +		phi ix -> HSized phi a -> UnionFunc (f r ix) (a ix) ->+			m r a ix -> m r a ix -> m r a ix+	isectT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +		phi ix -> HSized phi c -> IsectFunc (f r ix) (a ix) (b ix) (c ix) -> m r a ix -> m r b ix -> m r c ix+	diffT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>+		phi ix -> HSized phi a -> DiffFunc (f r ix) (a ix) (b ix) -> m r a ix -> m r b ix -> m r a ix+	extractMinT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +		phi ix -> HSized phi a -> ExtractFunc (f r ix) First (a ix) (m r a ix)+	extractMaxT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +		phi ix -> HSized phi a -> ExtractFunc (f r ix) Last (a ix) (m r a ix)+	alterMinT, alterMaxT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +		phi ix -> HSized phi a -> (f r ix -> a ix -> Maybe (a ix)) -> m r a ix -> m r a ix+	isSubmapT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +		phi ix -> LEq (a ix) (b ix) -> LEq (m r a ix) (m r b ix)+	fromListT, fromAscListT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +		phi ix -> HSized phi a -> (f r ix -> a ix -> a ix -> a ix) -> [(f r ix, a ix)] -> m r a ix+	fromDistAscListT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +		phi ix -> HSized phi a -> [(f r ix, a ix)] -> m r a ix+-- 	sizeT pf s m = foldWithKeyT pf (\ _ x n -> s pf x + n) m 0+	fromListT pf s f = foldr (\ (k, a) -> alterT pf s (Just . maybe a (f k a)) k) (emptyT pf)+	fromAscListT = fromListT+	fromDistAscListT pf s = fromAscListT pf s (const const)+	updateAtT pf s f i m = case assocAtT pf s i m of+		(i', k, a) -> alterT pf s (const (f i' k a)) k m++class HOrd0 phi r => HTrieKey (phi :: * -> *) (r :: * -> *) m | phi r -> m, m -> phi r where+	emptyH :: m ~ HTrieMap phi r => phi ix -> m a ix+	nullH :: m ~ HTrieMap phi r => phi ix -> m a ix -> Bool+	sizeH :: (m ~ HTrieMap phi r) => HSized phi a -> m a ix -> Int+	lookupH :: m ~ HTrieMap phi r => phi ix -> r ix -> m a ix -> Maybe (a ix)+	alterH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> (Maybe (a ix) -> Maybe (a ix)) -> r ix -> m a ix -> m a ix+	lookupIxH :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> r ix -> m a ix -> Maybe (Int, a ix)+	assocAtH :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> Int -> m a ix -> (Int, r ix, a ix)+	updateAtH :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> (Int -> r ix -> a ix -> Maybe (a ix)) -> Int -> m a ix -> m a ix+	{-# SPECIALIZE traverseWithKeyH :: phi ix -> (r ix -> a ix -> Id (b ix)) ->+		m a ix -> Id (m b ix) #-}+	traverseWithKeyH :: (m ~ HTrieMap phi r, Applicative f) => +		phi ix -> HSized phi b -> (r ix -> a ix -> f (b ix)) -> m a ix -> f (m b ix)+	foldWithKeyH :: m ~ HTrieMap phi r => phi ix -> (r ix -> a ix -> b -> b) -> m a ix -> b -> b+	foldlWithKeyH :: m ~ HTrieMap phi r => phi ix -> (r ix -> b -> a ix -> b) -> m a ix -> b -> b+	mapEitherH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi b -> HSized phi c ->+		EitherMap (r ix) (a ix) (b ix) (c ix) -> m a ix -> (m b ix, m c ix)+	splitLookupH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> SplitMap (a ix) x -> r ix -> m a ix ->+				(m a ix, Maybe x, m a ix)+	unionH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> UnionFunc (r ix) (a ix) -> m a ix -> m a ix+			-> m a ix+	isectH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi c -> IsectFunc (r ix) (a ix) (b ix) (c ix) ->+			m a ix -> m b ix -> m c ix+	diffH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> DiffFunc (r ix) (a ix) (b ix) ->+			m a ix -> m b ix -> m a ix+	extractMinH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> ExtractFunc (r ix) First (a ix) (m a ix)+	extractMaxH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> ExtractFunc (r ix) Last (a ix) (m a ix)+	alterMinH, alterMaxH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> (r ix -> a ix -> Maybe (a ix)) ->+		m a ix -> m a ix+	isSubmapH :: m ~ HTrieMap phi r => +		phi ix -> LEq (a ix) (b ix) -> LEq (m a ix) (m b ix)+	fromListH, fromAscListH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> (r ix -> a ix -> a ix -> a ix) ->+		[(r ix, a ix)] -> m a ix+	fromDistAscListH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> [(r ix, a ix)] -> m a ix+-- 	sizeH pf s m = foldWithKeyH pf (\ _ x n -> s pf x + n) m 0+	fromListH pf s f = foldr (\ (k, a) -> alterH pf s (Just . maybe a (f k a)) k) (emptyH pf)+	fromAscListH = fromListH+	fromDistAscListH pf s = fromAscListH pf s (const const)+	updateAtH pf s f i m = case assocAtH pf s i m of+		(i', k, a) -> alterH pf s (const (f i' k a)) k m++mapWithKeyT :: (HTrieKeyT phi f (HTrieMapT phi f), HTrieKey phi r (HTrieMap phi r)) =>+	phi ix -> HSized phi b -> (f r ix -> a ix -> b ix) -> HTrieMapT phi f r a ix -> HTrieMapT phi f r b ix+mapWithKeyT pf s f m = unId (traverseWithKeyT pf s (Id .: f) m)++mapWithKeyH :: (HTrieKey phi r (HTrieMap phi r)) =>+	phi ix -> HSized phi b -> (r ix -> a ix -> b ix) -> HTrieMap phi r a ix -> HTrieMap phi r b ix+mapWithKeyH pf s f m = unId (traverseWithKeyH pf s (Id .: f) m)++guardNullT :: (m ~ HTrieMapT phi f, HTrieKeyT phi f m, HTrieKey phi r (HTrieMap phi r)) => +	phi ix -> m r a ix -> Maybe (m r a ix)+guardNullT pf m+	| nullT pf m	= Nothing+	| otherwise	= Just m

@@ -0,0 +1,78 @@+{-# LANGUAGE KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}++module Data.TrieMap.MultiRec.ConstMap where++import Data.TrieMap.MultiRec.Class+import Data.TrieMap.MultiRec.Eq+import Data.TrieMap.MultiRec.Sized+import Data.TrieMap.Applicative+import Data.TrieMap.TrieKey++import Control.Applicative+import Control.Arrow+import Control.Monad++import Data.Maybe+import Data.Foldable+import Generics.MultiRec++newtype KMap (phi :: * -> *) m (r :: * -> *) (a :: * -> *) ix = KMap (m a ix)+type instance HTrieMapT phi (K k) = KMap phi (TrieMap k)+type instance HTrieMap phi (K k r) = HTrieMapT phi (K k) r++instance TrieKey k m => HTrieKeyT phi (K k) (KMap phi m) where+	emptyT = emptyH+	nullT = nullH+	sizeT = sizeH+	lookupT = lookupH+	lookupIxT = lookupIxH+	assocAtT = assocAtH+	updateAtT = updateAtH+	alterT = alterH+	traverseWithKeyT = traverseWithKeyH+	foldWithKeyT = foldWithKeyH+	foldlWithKeyT = foldlWithKeyH+	mapEitherT = mapEitherH+	splitLookupT = splitLookupH+	unionT = unionH+	isectT = isectH+	diffT = diffH+	extractMinT = extractMinH+	extractMaxT = extractMaxH+	alterMinT = alterMinH+	alterMaxT = alterMaxH+	isSubmapT = isSubmapH+	fromListT = fromListH+	fromAscListT = fromAscListH+	fromDistAscListT = fromDistAscListH++instance TrieKey k m => HTrieKey phi (K k r) (KMap phi m r) where+	emptyH _ = KMap emptyM+	nullH _ (KMap m) = nullM m+	sizeH s (KMap m) = sizeM (s) m+	lookupH _ (K k) (KMap m) = lookupM k m+	lookupIxH _ s (K k) (KMap m) = lookupIxM s k m+	assocAtH _ s i (KMap m) = case assocAtM s i m of+		(i, k, a) -> (i, K k, a)+	updateAtH _ s f i (KMap m) = KMap (updateAtM s (\ i -> f i . K) i m)+	alterH pf s f (K k) (KMap m) = KMap (alterM (s) f k m)+	traverseWithKeyH pf s f (KMap m) = KMap <$> traverseWithKeyM (s) (f . K) m+	foldWithKeyH _ f (KMap m) = foldWithKeyM (f . K) m+	foldlWithKeyH _ f (KMap m) = foldlWithKeyM (f . K) m+	mapEitherH pf s1 s2 f (KMap m) = (KMap *** KMap) (mapEitherM (s1) (s2) (f . K) m)+	splitLookupH pf s f (K k) (KMap m) = KMap `sides` splitLookupM (s) f k m+	unionH pf s f (KMap m1) (KMap m2) = KMap (unionM (s) (f . K) m1 m2)+	isectH pf s f (KMap m1) (KMap m2) = KMap (isectM (s) (f . K) m1 m2)+	diffH pf s f (KMap m1) (KMap m2) = KMap (diffM (s) (f . K) m1 m2)+	extractMinH pf s (KMap m) = do+		((k, a), m') <- extractMinM (s) m+		return ((K k, a), KMap m')+	extractMaxH pf s (KMap m) = do+		((k, a), m') <- extractMaxM (s) m+		return ((K k, a), KMap m')+	alterMinH pf s f (KMap m) = KMap (alterMinM (s) (f . K) m)+	alterMaxH pf s f (KMap m) = KMap (alterMaxM (s) (f . K) m)+	isSubmapH _ (<=) (KMap m1) (KMap m2) = isSubmapM (<=) m1 m2+	fromListH pf s f xs = KMap (fromListM (s) (f . K) [(k, a) | (K k, a) <- xs])+	fromAscListH pf s f xs = KMap (fromAscListM (s) (f . K) [(k, a) | (K k, a) <- xs])+	fromDistAscListH pf s xs = KMap (fromDistAscListM (s) [(k, a) | (K k, a) <- xs])

@@ -0,0 +1,37 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances #-}++module Data.TrieMap.MultiRec.Eq where++import Generics.MultiRec+import Generics.MultiRec.Eq++class HEq0 phi r where+	heqH :: phi ix -> r ix -> r ix -> Bool++heqT :: (HEq phi f, HEq0 phi r) => phi ix -> f r ix -> f r ix -> Bool+heqT = heq heqH++instance Eq k => HEq0 phi (K k r) where+	heqH _ (K x) (K y) = x == y++instance (El phi xi, HEq0 phi r) => HEq0 phi (I xi r) where+	heqH pf (I x) (I y) = heqH (proofOn pf) x y where+		proofOn :: El phi xi => phi ix -> phi xi+		proofOn _ = proof++instance HEq0 phi (U r) where+	heqH _ _ _ = True++instance (HEq phi f, HEq phi g, HEq0 phi r) => HEq0 phi ((f :*: g) r) where+	heqH pf (x1 :*: y1) (x2 :*: y2) = heqT pf x1 x2 && heqT pf y1 y2++instance (HEq phi f, HEq phi g, HEq0 phi r) => HEq0 phi ((f :+: g) r) where+	heqH pf (L x) (L y) = heqT pf x y+	heqH pf (R x) (R y) = heqT pf x y+	heqH _ _ _ = False++instance (HEq phi f, HEq0 phi r) => HEq0 phi ((f :>: ix) r) where+	heqH pf (Tag x) (Tag y) = heqT pf x y++instance HEq phi f => HEq0 phi (HFix f) where+	heqH pf (HIn x) (HIn y) = heqT pf x y

@@ -0,0 +1,125 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, Rank2Types, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}++module Data.TrieMap.MultiRec.FamMap where++import Data.TrieMap.MultiRec.Class+import Data.TrieMap.MultiRec.Eq+import Data.TrieMap.MultiRec.Ord+import Data.TrieMap.MultiRec.Sized+import Data.TrieMap.Sized+import Data.TrieMap.Applicative+import Data.TrieMap.TrieKey++import Control.Applicative+import Control.Arrow++import Data.Maybe+import Data.Foldable+import Data.Sequence ((|>))+import qualified Data.Sequence as Seq++import Generics.MultiRec++newtype Family phi ix = F ix+newtype FamMap (phi :: * -> *) m (a :: * -> *) ix = FamMap (m (Family phi) a ix)+type instance HTrieMap phi (Family phi) = FamMap phi (HTrieMapT phi (PF phi))++instance (Fam phi, HEq phi (PF phi), HFunctor phi (PF phi)) => HEq0 phi (Family phi) where+	heqH pf (F x) (F y) = heqT pf (from' pf x) (from' pf y)++instance (Fam phi, HOrd phi (PF phi), HFunctor phi (PF phi)) => HOrd0 phi (Family phi) where+	compareH0 pf (F x) (F y) = hcompare pf (from' pf x) (from' pf y)++instance (El phi ix, Fam phi, HEq phi (PF phi), HFunctor phi (PF phi)) => Eq (Family phi ix) where+	x == y = heqH (prove x) x y++instance (El phi ix, Fam phi, HOrd phi (PF phi), HFunctor phi (PF phi)) => Ord (Family phi ix) where+	x `compare` y = compareH0 (prove x) x y++prove :: El phi ix => Family phi ix -> phi ix+prove _ = proof++from' :: (Fam phi, HFunctor phi (PF phi)) => phi ix -> ix -> PF phi (Family phi) ix+from' pf = hmap (const (F . unI0)) pf . from pf++to' :: (Fam phi, HFunctor phi (PF phi)) => phi ix -> PF phi (Family phi) ix -> ix+to' pf = to pf . hmap (\ _ (F x) -> I0 x) pf++push :: (Fam phi, HFunctor phi (PF phi)) => phi ix -> (Family phi ix -> a) -> PF phi (Family phi) ix -> a+push pf f = f . F . to' pf++instance (Fam phi, HFunctor phi (PF phi), HTrieKeyT phi (PF phi) m) => HTrieKey phi (Family phi) (FamMap phi m) where+	emptyH pf = FamMap (emptyT pf)+	nullH pf (FamMap m) = nullT pf m+	sizeH s (FamMap m) = sizeT s m+	lookupH pf (F k) (FamMap m) = lookupT pf (from' pf k) m+	lookupIxH pf s (F k) (FamMap m) = lookupIxT pf s (from' pf k) m+	assocAtH pf s i (FamMap m) = case assocAtT pf s i m of+		(i, k, a) -> (i, F (to' pf k), a)+	updateAtH pf s f i (FamMap m) = FamMap (updateAtT pf s (\ i -> f i . F . to' pf) i m)+	alterH pf s f (F k) (FamMap m) = FamMap (alterT pf s f (from' pf k) m)+	traverseWithKeyH pf s f (FamMap m) =+		FamMap <$> traverseWithKeyT pf s (push pf f) m+	foldWithKeyH pf f (FamMap m) = foldWithKeyT pf (push pf f) m+	foldlWithKeyH pf f (FamMap m) = foldlWithKeyT pf (push pf f) m+	mapEitherH pf s1 s2 f (FamMap m) = (FamMap *** FamMap) (mapEitherT pf s1 s2 (push pf f) m)+	splitLookupH pf s f (F k) (FamMap m) = FamMap `sides` splitLookupT pf s f (from' pf k) m+	unionH pf s f (FamMap m1) (FamMap m2) = FamMap (unionT pf s (push pf f) m1 m2)+	isectH pf s f (FamMap m1) (FamMap m2) = FamMap (isectT pf s (push pf f) m1 m2)+	diffH pf s f (FamMap m1) (FamMap m2) = FamMap (diffT pf s (push pf f) m1 m2)+	extractMinH pf s (FamMap m) = do+		((k, a), m') <- extractMinT pf s m+		return ((F (to' pf k), a), FamMap m')+	extractMaxH pf s (FamMap m) = do+		((k, a), m') <- extractMaxT pf s m+		return ((F (to' pf k), a), FamMap m')+	alterMinH pf s f (FamMap m) = FamMap (alterMinT pf s (push pf f) m)+	alterMaxH pf s f (FamMap m) = FamMap (alterMaxT pf s (push pf f) m)+	isSubmapH pf (<=) (FamMap m1) (FamMap m2) = isSubmapT pf (<=) m1 m2+	fromListH pf s f xs = FamMap (fromListT pf s (push pf f) [(from' pf k, a) | (F k, a) <- xs])+	fromAscListH pf s f xs = FamMap (fromAscListT pf s (push pf f) [(from' pf k, a) | (F k, a) <- xs])+	fromDistAscListH pf s xs = FamMap (fromDistAscListT pf s [(from' pf k, a) | (F k, a) <- xs])++-- type family UniqueFam ix :: * -> *+newtype FMap (phi :: * -> *) m xi a ix = FMap (m (I ix a) xi)+type instance TrieMap (Family phi ix) = FMap phi (HTrieMap phi (Family phi)) ix++sizeI :: Sized a -> HSized phi (I ix a)+sizeI s (I a) = s a++instance (El phi ix, Fam phi, HFunctor phi (PF phi), HTrieKey phi (Family phi) m, m ~ HTrieMap phi (Family phi),+		HOrd phi (PF phi)) => TrieKey (Family phi ix) (FMap phi m ix) where+	emptyM = FMap (emptyH proof)+	nullM (FMap m) = nullH proof m+	sizeM s (FMap m) = sizeH (sizeI s) m+	lookupM k (FMap m) = unI <$> lookupH proof k m+	lookupIxM s k (FMap m) = fmap unI <$> lookupIxH proof (sizeI s) k m+	assocAtM s i (FMap m) = case assocAtH proof (sizeI s) i m of+		(i, k, I a) -> (i, k, a)+	updateAtM s f i (FMap m) = FMap (updateAtH proof (sizeI s) (\ i' k (I a) -> I <$> f i' k a) i m)+	alterM s f k (FMap m) = FMap (alterH proof (sizeI s) (fmap I . f . fmap unI) k m)+	traverseWithKeyM s f (FMap m) = FMap <$> traverseWithKeyH proof (sizeI s) (\ k (I a) -> I <$> f k a) m+	foldWithKeyM f (FMap m) = foldWithKeyH proof (\ k (I a) -> f k a) m+	foldlWithKeyM f (FMap m) = foldlWithKeyH proof (\ k z (I a) -> f k z a) m+	mapEitherM s1 s2 f (FMap m) = +		(FMap *** FMap) (mapEitherH proof (sizeI s1) (sizeI s2) (\ k (I a) -> (fmap I *** fmap I) (f k a)) m)+	splitLookupM s f k (FMap m) = FMap `sides` splitLookupH proof (sizeI s) (sides (I <$>) . f . unI) k m+	unionM s f (FMap m1) (FMap m2) = FMap (unionH proof (sizeI s) f' m1 m2) where+		f' k (I x) (I y) = I <$> f k x y+	isectM s f (FMap m1) (FMap m2) = FMap (isectH proof (sizeI s) f' m1 m2) where+		f' k (I x) (I y) = I <$> f k x y+	diffM s f (FMap m1) (FMap m2) = FMap (diffH proof (sizeI s) f' m1 m2) where+		f' k (I x) (I y) = I <$> f k x y+	extractMinM s (FMap m) = do+		((k, I a), m') <- extractMinH proof (sizeI s) m+		return ((k, a), FMap m')+	extractMaxM s (FMap m) = do+		((k, I a), m') <- extractMaxH proof (sizeI s) m+		return ((k, a), FMap m')+	alterMinM s f (FMap m) = FMap (alterMinH proof (sizeI s) (\ k (I a) -> I <$> f k a) m)+	alterMaxM s f (FMap m) = FMap (alterMaxH proof (sizeI s) (\ k (I a) -> I <$> f k a) m)+	isSubmapM (<=) (FMap m1) (FMap m2) = isSubmapH proof (<<=) m1 m2 where+		I a <<= I b = a <= b+	fromListM s f xs = FMap (fromListH proof (sizeI s) (\ k (I a) (I b) -> I (f k a b)) [(k, I a) | (k, a) <- xs])+	fromAscListM s f xs = FMap (fromAscListH proof (sizeI s) (\ k (I a) (I b) -> I (f k a b)) [(k, I a) | (k, a) <- xs])+	fromDistAscListM s xs = FMap (fromDistAscListH proof (sizeI s) [(k, I a) | (k, a) <- xs])

@@ -0,0 +1,86 @@+{-# LANGUAGE Rank2Types, TypeFamilies, FlexibleInstances, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses #-}++module Data.TrieMap.MultiRec.IMap where++import Data.TrieMap.MultiRec.Class+import Data.TrieMap.MultiRec.Sized+import Data.TrieMap.TrieKey++import Control.Applicative+import Control.Arrow++import Generics.MultiRec++newtype IMap phi xi r a ix = IMap (HTrieMap phi r (I ix a) xi)+type instance HTrieMapT phi (I xi) = IMap phi xi+type instance HTrieMap phi (I xi r) = HTrieMapT phi (I xi) r++combineI :: (I xi r ix -> a ix -> b ix -> Maybe (c ix)) -> r xi -> I ix a xi -> I ix b xi -> Maybe (I ix c xi)+combineI f k (I a) (I b) = I <$> f (I k) a b++mapI :: Functor f => (I xi r ix -> a ix -> f (b ix)) -> r xi -> I ix a xi -> f (I ix b xi)+mapI f k (I a) = I <$> f (I k) a++sizeI :: HSized phi r -> HSized phi (I xi r)+sizeI s (I x) = s x++instance El phi xi => HTrieKeyT phi (I xi) (IMap phi xi) where+	emptyT _ = IMap (emptyH proof)+	nullT _ (IMap m) = nullH proof m+	sizeT s (IMap m) = sizeH (sizeI s) m+	lookupT _ (I k) (IMap m) = unI <$> lookupH proof k m+	lookupIxT _ s (I k) (IMap m) = fmap unI <$> lookupIxH proof (sizeI s) k m+	assocAtT _ s i (IMap m) = case assocAtH proof (sizeI s) i m of+		(i, k, I a) -> (i, I k, a)+	updateAtT _ s f i (IMap m) = IMap (updateAtH proof (sizeI s) (\ i' k (I a) -> I <$> f i' (I k) a) i m)+	alterT _ s f (I k) (IMap m) = IMap (alterH proof (sizeI s) f' k m) where+		f' = fmap I . f . fmap unI+	traverseWithKeyT _ s f (IMap m) = IMap <$> traverseWithKeyH proof (sizeI s) (mapI f) m+	foldWithKeyT _ f (IMap m) = foldWithKeyH proof (\ k (I a) -> f (I k) a) m+	foldlWithKeyT _ f (IMap m) = foldlWithKeyH proof (\ k z (I a) -> f (I k) z a) m+	mapEitherT _ s1 s2 f (IMap m) = (IMap *** IMap) (mapEitherH proof (sizeI s1) (sizeI s2) f' m) where+		f' k (I a) = (fmap I *** fmap I) (f (I k) a)+	splitLookupT pf s f (I k) (IMap m) = IMap `sides` splitLookupH proof (sizeI s) f' k m+		where	f' = sides (I <$>) . f . unI+	unionT pf s f (IMap m1) (IMap m2) = IMap (unionH proof (sizeI s) (combineI f) m1 m2)+	isectT pf s f (IMap m1) (IMap m2) = IMap (isectH proof (sizeI s) (combineI f) m1 m2)+	diffT pf s f (IMap m1) (IMap m2) = IMap (diffH proof (sizeI s) (combineI f) m1 m2)+	extractMinT pf s (IMap m) = do+		((k, I a), m') <- extractMinH proof (sizeI s) m+		return ((I k, a), IMap m')+	extractMaxT pf s (IMap m) = do+		((k, I a), m') <- extractMaxH proof (sizeI s) m+		return ((I k, a), IMap m')+	alterMinT pf s f (IMap m) = IMap (alterMinH proof (sizeI s) (mapI f) m)+	alterMaxT pf s f (IMap m) = IMap (alterMaxH proof (sizeI s) (mapI f) m)+	isSubmapT pf (<=) (IMap m1) (IMap m2) = isSubmapH proof (<<=) m1 m2 where+		I a <<= I b = a <= b+	fromListT _ s f xs = IMap (fromListH proof (sizeI s) (\ k (I a) (I b) -> I (f (I k) a b)) [(k, I a) | (I k, a) <- xs])+	fromAscListT _ s f xs = IMap (fromAscListH proof (sizeI s) (\ k (I a) (I b) -> I (f (I k) a b)) [(k, I a) | (I k, a) <- xs])+	fromDistAscListT _ s xs = IMap (fromDistAscListH proof (sizeI s) [(k, I a) | (I k, a) <- xs])++instance (El phi xi, HTrieKey phi r (HTrieMap phi r)) => HTrieKey phi (I xi r) (IMap phi xi r) where+	emptyH = emptyT+	nullH = nullT+	sizeH = sizeT+	lookupH = lookupT+	lookupIxH = lookupIxT+	assocAtH = assocAtT+	updateAtH = updateAtT+	alterH = alterT+	traverseWithKeyH = traverseWithKeyT+	foldWithKeyH = foldWithKeyT+	foldlWithKeyH = foldlWithKeyT+	mapEitherH = mapEitherT+	splitLookupH = splitLookupT+	unionH = unionT+	isectH = isectT+	diffH = diffT+	alterMinH = alterMinT+	alterMaxH = alterMaxT+	extractMinH = extractMinT+	extractMaxH = extractMaxT+	isSubmapH = isSubmapT+	fromListH = fromListT+	fromAscListH = fromAscListT+	fromDistAscListH = fromDistAscListT

@@ -0,0 +1,9 @@+module Data.TrieMap.MultiRec.Instances where++import Data.TrieMap.MultiRec.ProdMap+import Data.TrieMap.MultiRec.IMap+import Data.TrieMap.MultiRec.UnionMap+import Data.TrieMap.MultiRec.TagMap+import Data.TrieMap.MultiRec.ConstMap+import Data.TrieMap.MultiRec.UnitMap+import Data.TrieMap.MultiRec.FamMap

@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleInstances, TypeOperators, MultiParamTypeClasses, Rank2Types #-}++module Data.TrieMap.MultiRec.Ord where++import Data.TrieMap.MultiRec.Eq++import Generics.MultiRec++import Data.Monoid++type Comparator a = a -> a -> Ordering++class HEq phi f => HOrd phi f where+	compareH :: (forall ix . phi ix -> Comparator (r ix)) -> phi ix -> Comparator (f r ix)++hcompare :: (HOrd phi f, HOrd0 phi r) => phi ix -> Comparator (f r ix)+hcompare = compareH compareH0++class HEq0 phi r => HOrd0 phi r where+	compareH0 :: phi ix -> Comparator (r ix)++instance Ord k => HOrd phi (K k) where+	compareH _ = compareH0++instance Ord k => HOrd0 phi (K k r) where+	compareH0 _ (K a) (K b) = compare a b++instance El phi xi => HOrd phi (I xi) where+	compareH cmp _ (I a) (I b) = cmp proof a b++instance (El phi xi, HOrd0 phi r) => HOrd0 phi (I xi r) where+	compareH0 = hcompare++instance HOrd phi U where+	compareH _ = compareH0++instance HOrd0 phi (U r) where+	compareH0 _ _ _ = EQ++instance (HOrd phi f, HOrd phi g) => HOrd phi (f :*: g) where+	compareH cmp pf (x1 :*: y1) (x2 :*: y2) = compareH cmp pf x1 x2 `mappend` compareH cmp pf y1 y2++instance (HOrd phi f, HOrd phi g, HOrd0 phi r) => HOrd0 phi ((f :*: g) r) where+	compareH0 = hcompare++instance (HOrd phi f, HOrd phi g) => HOrd phi (f :+: g) where+	compareH cmp pf x y = case (x, y) of+		(L x, L y) -> compareH cmp pf x y+		(R x, R y) -> compareH cmp pf x y+		(L _, R _) -> LT+		(R _, L _) -> GT++instance (HOrd phi f, HOrd phi g, HOrd0 phi r) => HOrd0 phi ((f :+: g) r) where+	compareH0 = hcompare++instance HOrd phi f => HOrd phi (f :>: ix) where+	compareH cmp pf (Tag a) (Tag b) = compareH cmp pf a b++instance (HOrd phi f, HOrd0 phi r) => HOrd0 phi ((f :>: ix) r) where+	compareH0 pf (Tag a) (Tag b) = hcompare pf a b++instance HOrd phi f => HOrd0 phi (HFix f) where+	compareH0 pf (HIn a) (HIn b) = hcompare pf a b

@@ -0,0 +1,126 @@+{-# LANGUAGE TypeOperators, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeFamilies, MultiParamTypeClasses #-}++module Data.TrieMap.MultiRec.ProdMap where++import Data.TrieMap.MultiRec.Class+import Data.TrieMap.MultiRec.Eq+import Data.TrieMap.MultiRec.Sized+import Data.TrieMap.Applicative+import Data.TrieMap.TrieKey++import Control.Applicative+import Control.Arrow++import Data.Maybe+import Data.Foldable+import Data.Sequence ((|>))+import qualified Data.Sequence as Seq++import Generics.MultiRec++newtype ProdMap (phi :: * -> *) m1 (m2 :: (* -> *) -> (* -> *) -> * -> *) (r :: * -> *) (a :: * -> *) ix = PMap (m1 r (m2 r a) ix)+type instance HTrieMapT phi (f :*: g) = ProdMap phi (HTrieMapT phi f) (HTrieMapT phi g)+type instance HTrieMap phi ((f :*: g) r) = HTrieMapT phi (f :*: g) r++-- instance (HTrieKey phi (f r), HTrieKey phi (g r)) => HTrieKey phi ((f :*: g) r) where+-- 	emptyH pf ~(a :*: b) = PMap (emptyH pf a)+-- 	nullH pf ~(a :*: b) (PMap m) = nullH pf a m+-- 	lookupH pf (a :*: b) (PMap m) = lookupH pf a m >>= lookupH pf b+-- 	alterH pf f (a :*: b) (PMap m) = PMap (alterH pf (guardNull . g) a m) where+-- 		g = alterH pf f b . fromMaybe (emptyH pf b)+-- 		guardNull m+-- 			| nullH pf b m	= Nothing+-- 			| otherwise	= Just m+-- 	traverseWithKeyH pf f (PMap m) = +-- 		PMap <$> traverseWithKeyH pf (\ a -> traverseWithKeyH pf (\ b -> f (a :*: b))) m+-- 	foldWithKeyH pf f (PMap m) = +-- 		foldWithKeyH pf (\ a -> foldWithKeyH pf (\ b -> f (a :*: b))) m++instance (HTrieKeyT phi f m1, m1 ~ HTrieMapT phi f, HTrieKeyT phi g m2, m2 ~ HTrieMapT phi g) => +		HTrieKeyT phi (f :*: g) (ProdMap phi m1 m2) where+	emptyT = PMap . emptyT+	nullT pf (PMap m) = nullT pf m+	sizeT s (PMap m) = sizeT (sizeT s) m+	lookupT pf (a :*: b) (PMap m) = lookupT pf a m >>= lookupT pf b+	lookupIxT pf s (a :*: b) (PMap m) = do+		(iA, m') <- lookupIxT pf (sizeT s) a m+		(iB, v) <- lookupIxT pf s b m'+		return (iA + iB, v)+	assocAtT pf s i (PMap m) = case assocAtT pf (sizeT s) i m of+		(iA, a, m') -> case assocAtT pf s (i - iA) m' of+			(iB, b, v) -> (iA + iB, a :*: b, v)+	updateAtT pf s f i (PMap m) = PMap (updateAtT pf (sizeT s) g i m) where+		g iA a = guardNullT pf . updateAtT pf s (\ iB b -> f (iA + iB) (a :*: b)) (i - iA)+	alterT pf s f (a :*: b) (PMap m) = PMap (alterT pf (sizeT s) (guardNullT pf . g) a m) where+		g = alterT pf s f b . fromMaybe (emptyT pf)+	traverseWithKeyT pf s f (PMap m) = +		PMap <$> traverseWithKeyT pf (sizeT s) (\ a -> traverseWithKeyT pf s (\ b -> f (a :*: b))) m+	foldWithKeyT pf f (PMap m) =+		foldWithKeyT pf (\ a -> foldWithKeyT pf (\ b -> f (a :*: b))) m+	foldlWithKeyT pf f (PMap m) =+		foldlWithKeyT pf (\ a -> flip (foldlWithKeyT pf (\ b -> f (a :*: b)))) m+	mapEitherT pf s1 s2 f (PMap m) = (PMap *** PMap) (mapEitherT pf (sizeT s1) (sizeT s2) g m) where+		g a = (guardNullT pf *** guardNullT pf) . mapEitherT pf s1 s2 (\ b -> f (a :*: b))+	splitLookupT pf s f (a :*: b) (PMap m) = PMap `sides` splitLookupT pf (sizeT s) g a m where+		g = sides (guardNullT pf) . splitLookupT pf s f b+	unionT pf s f (PMap m1) (PMap m2) = PMap (unionT pf (sizeT s) g m1 m2) where+		g a = guardNullT pf .: unionT pf s (\ b -> f (a :*: b))+	isectT pf s f (PMap m1) (PMap m2) = PMap (isectT pf (sizeT s) g m1 m2) where+		g a = guardNullT pf .: isectT pf s (\ b -> f (a :*: b))+	diffT pf s f (PMap m1) (PMap m2) = PMap (diffT pf (sizeT s) g m1 m2) where+		g a = guardNullT pf .: diffT pf s (\ b -> f (a :*: b))+	extractMinT pf s (PMap m) = do+		((a, m1), m') <- extractMinT pf (sizeT s) m+		((b, v), m1') <- extractMinT pf s m1+		return ((a :*: b, v), PMap (maybe m' (\ m1' -> alterMinT pf (sizeT s) (\ _ _ -> Just m1') m) (guardNullT pf m1')))+	extractMaxT pf s (PMap m) = do+		((a, m1), m') <- extractMaxT pf (sizeT s) m+		((b, v), m1') <- extractMaxT pf s m1+		return ((a :*: b, v), PMap (maybe m' (\ m1' -> alterMaxT pf (sizeT s) (\ _ _ -> Just m1') m) (guardNullT pf m1')))+	alterMinT pf s f (PMap m) = PMap (alterMinT pf (sizeT s) g m) where+		g a = guardNullT pf . alterMinT pf s (\ b -> f (a :*: b))+	alterMaxT pf s f (PMap m) = PMap (alterMaxT pf (sizeT s) g m) where+		g a = guardNullT pf . alterMaxT pf s (\ b -> f (a :*: b))+	isSubmapT pf (<=) (PMap m1) (PMap m2) = isSubmapT pf (isSubmapT pf (<=)) m1 m2+	fromListT pf s f xs = PMap (mapWithKeyT pf (sizeT s) (\ a -> fromListT pf s (\ b -> f (a :*: b)) . unK0)+				(fromListT pf (const 1) (\ _ (K0 xs) (K0 ys) -> K0 (xs ++ ys))+					[(a, K0 ts) | (a, ts) <- breakFst pf xs]))+	fromAscListT pf s f xs = PMap (fromDistAscListT pf (sizeT s)+		[(a, fromAscListT pf s (\ b -> f (a :*: b)) ts) | (a, ts) <- breakFst pf xs])+	fromDistAscListT pf s xs = PMap (fromDistAscListT pf (sizeT s)+		[(a, fromDistAscListT pf s ts) | (a, ts) <- breakFst pf xs])++breakFst :: (HEq phi f, HEq0 phi r) => phi ix -> [((f :*: g) r ix, a ix)] -> [(f r ix, [(g r ix, a ix)])]+breakFst pf [] = []+breakFst pf ((a :*: b, x):xs) = breakFst' a (Seq.singleton (b, x)) xs where+	breakFst' a0 ts ((a :*: b, x):xs)+		| heqT pf a0 a	= breakFst' a0 (ts |> (b, x)) xs+		| otherwise	= (a0, toList ts):breakFst' a (Seq.singleton (b,x)) xs+	breakFst' a ts [] = [(a, toList ts)]++instance (HTrieKeyT phi f m1, m1 ~ HTrieMapT phi f, HTrieKeyT phi g m2, m2 ~ HTrieMapT phi g,+		HTrieKey phi r (HTrieMap phi r)) => HTrieKey phi ((f :*: g) r) (ProdMap phi m1 m2 r) where+	emptyH = emptyT+	nullH = nullT+	sizeH = sizeT+	lookupH = lookupT+	lookupIxH = lookupIxT+	assocAtH = assocAtT+	updateAtH = updateAtT+	alterH = alterT+	traverseWithKeyH = traverseWithKeyT+	foldWithKeyH = foldWithKeyT+	foldlWithKeyH = foldlWithKeyT+	mapEitherH = mapEitherT+	splitLookupH = splitLookupT+	unionH = unionT+	isectH = isectT+	diffH = diffT+	alterMinH = alterMinT+	alterMaxH = alterMaxT+	extractMinH = extractMinT+	extractMaxH = extractMaxT+	isSubmapH = isSubmapT+	fromListH = fromListT+	fromAscListH = fromAscListT+	fromDistAscListH = fromDistAscListT

@@ -0,0 +1,20 @@+{-# LANGUAGE Rank2Types, KindSignatures #-}++module Data.TrieMap.MultiRec.Sized where++-- import Data.TrieMap.Sized+-- +-- class HSized phi r where+-- 	hGetSize :: phi ix -> r ix -> Int+-- +-- newtype ElF phi r ix = ElF (r ix)+-- +-- instance (HSized phi r, El phi ix) => Sized (ElF phi r) where+-- 	getSize (ElF x) = hGetSize proof x++type HSized (phi :: * -> *) r = forall ix . r ix -> Int++newtype Elem a = Elem {getElem :: a}++sizeElem :: HSized phi Elem+sizeElem _ = 1

@@ -0,0 +1,125 @@+{-# LANGUAGE Rank2Types, TypeOperators, KindSignatures, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeFamilies, GADTs, MultiParamTypeClasses #-}++module Data.TrieMap.MultiRec.TagMap where++import Data.TrieMap.MultiRec.Class+import Data.TrieMap.MultiRec.Eq+import Data.TrieMap.MultiRec.Sized+import Data.TrieMap.Applicative+import Data.TrieMap.TrieKey++import Control.Applicative+import Control.Arrow+import Control.Monad++import Data.Maybe+import Data.Monoid+import Data.Foldable+import Generics.MultiRec++data TagF a ix :: * -> * where+	TagF :: a ix -> TagF a ix ix++unTagF :: TagF a ix xi -> a xi+unTagF (TagF x) = x++newtype TagMap (phi :: * -> *) m ix (r :: * -> *) a xi = TagMap (m r (TagF a ix) xi)+type instance HTrieMapT phi (f :>: ix) = TagMap phi (HTrieMapT phi f) ix+type instance HTrieMap phi ((f :>: ix) r) = HTrieMapT phi (f :>: ix) r++combineTag :: IsectFunc ((f :>: ix) r xi) (a xi) (b xi) (c xi) ->+	IsectFunc (f r xi) (TagF a ix xi) (TagF b ix xi) (TagF c ix xi)+combineTag f k (TagF a) (TagF b) = TagF <$> f (Tag k) a b++mapTag :: Functor t => ((f :>: ix) r xi -> a xi -> t (b xi)) -> f r xi -> TagF a ix xi -> t (TagF b ix xi)+mapTag f k (TagF a) = TagF <$> f (Tag k) a++sizeTag :: HSized phi a -> HSized phi (TagF a ix)+sizeTag s (TagF x) = s x++instance (HTrieKeyT phi f m, m ~ HTrieMapT phi f) => HTrieKeyT phi (f :>: ix) (TagMap phi m ix) where+	emptyT = TagMap . emptyT+	nullT pf (TagMap m) = nullT pf m+	sizeT s (TagMap m) = sizeT (sizeTag s) m+	lookupT pf (Tag k) (TagMap m) = unTagF <$> lookupT pf k m+	lookupIxT pf s (Tag k) (TagMap m) = fmap unTagF <$> lookupIxT pf (sizeTag s) k m+	assocAtT pf s i (TagMap m) = unTagger (assocAtT pf (sizeTag s) i m)+		where	unTagger :: (Int, f r ix, TagF a xi ix) -> (Int, (f :>: xi) r ix, a ix)+			unTagger (i', k, TagF a) = (i', Tag k, a)+	updateAtT pf s f i (TagMap m) = TagMap (updateAtT pf (sizeTag s) (f' f) i m) where+		f' :: (Int -> (f :>: xi) r ix -> a ix -> Maybe (a ix)) -> Int -> f r ix -> TagF a xi ix -> Maybe (TagF a xi ix)+		f' f i k (TagF a) = TagF <$> f i (Tag k) a+	alterT pf s f (Tag k) (TagMap m) = TagMap (alterT pf (sizeTag s) (fmap TagF . f . fmap unTagF) k m)+	traverseWithKeyT pf s f (TagMap m) = TagMap <$> traverseWithKeyT pf (sizeTag s) (mapTag f) m where+		f' :: Applicative t => ((f :>: ix) r xi -> a xi -> t (b xi)) -> f r xi -> TagF a ix xi -> t (TagF b ix xi)+		f' f k (TagF a) = TagF <$> f (Tag k) a+	foldWithKeyT pf f (TagMap m) = foldWithKeyT pf (f' f) m where+		f' :: ((f :>: ix) r xi -> a xi -> b -> b) -> f r xi -> TagF a ix xi -> b -> b+		f' f k (TagF a) = f (Tag k) a+	foldlWithKeyT pf f (TagMap m) = foldlWithKeyT pf (f' f) m where+		f' :: ((f :>: ix) r xi -> b -> a xi  -> b) -> f r xi -> b -> TagF a ix xi -> b+		f' f k z (TagF a) = f (Tag k) z a+	mapEitherT pf s1 s2 f (TagMap m) = (TagMap *** TagMap) (mapEitherT pf (sizeTag s1) (sizeTag s2) (f' f) m) where+		f' :: EitherMap ((f :>: ix) r xi) (a xi) (b xi) (c xi) -> EitherMap (f r xi) (TagF a ix xi) (TagF b ix xi) (TagF c ix xi)+		f' f k (TagF a) = (fmap TagF *** fmap TagF) (f (Tag k) a)+	splitLookupT pf s f (Tag k) (TagMap m) = TagMap `sides` splitLookupT pf (sizeTag s) (f' f) k m where+		f' :: SplitMap (a ix) x -> SplitMap (TagF a xi ix) x+		f' f (TagF a) = fmap TagF `sides` f a+	unionT pf s f (TagMap m1) (TagMap m2) = TagMap (unionT pf (sizeTag s) (combineTag f) m1 m2) +	isectT pf s f (TagMap m1) (TagMap m2) = TagMap (isectT pf (sizeTag s) (combineTag f) m1 m2)+	diffT pf s f (TagMap m1) (TagMap m2) = TagMap (diffT pf (sizeTag s) (combineTag f) m1 m2)+	extractMinT pf s (TagMap m) = do+		((k, TagF a), m') <- extractMin' pf ((sizeTag :: HSized phi a -> HSized phi (TagF a ix)) s) m+		return ((Tag k, a), TagMap m')+	 where	extractMin' :: (HTrieKeyT phi f m, m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +	 		phi ix -> HSized phi (TagF a xi) -> m r (TagF a xi) ix ->+	 			First ((f r ix, TagF a xi ix), m r (TagF a xi) ix)+	 	extractMin' = extractMinT+	extractMaxT pf s (TagMap m) = do+		((k, TagF a), m') <- extractMax' pf ((sizeTag :: HSized phi a -> HSized phi (TagF a ix)) s) m+		return ((Tag k, a), TagMap m')+	 where	extractMax' :: (HTrieKeyT phi f m, m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +	 		phi ix -> HSized phi (TagF a xi) -> m r (TagF a xi) ix ->+	 			Last ((f r ix, TagF a xi ix), m r (TagF a xi) ix)+	 	extractMax' = extractMaxT+	alterMinT pf s f (TagMap m) = TagMap (alterMinT pf (sizeTag s) (mapTag f) m)+	alterMaxT pf s f (TagMap m) = TagMap (alterMaxT pf (sizeTag s) (mapTag f) m) +	isSubmapT pf (<=) (TagMap m1) (TagMap m2) = isSubmapT pf (le (<=)) m1 m2 where+		le :: LEq (a ix) (b ix) -> LEq (TagF a xi ix) (TagF b xi ix)+		le (<=) (TagF a) (TagF b) = a <= b+	fromListT pf s f xs = TagMap (fromListT pf (sizeTag s) (f' f) [(k, TagF a) | (Tag k, a) <- xs]) where+		f' :: ((f :>: ix) r xi -> a xi -> a xi -> a xi) -> f r xi -> TagF a ix xi -> TagF a ix xi -> TagF a ix xi+		f' f k (TagF a) (TagF b) = TagF (f (Tag k) a b)+	fromAscListT pf s f xs = TagMap (fromAscListT pf (sizeTag s) (f' f) [(k, TagF a) | (Tag k, a) <- xs]) where+		f' :: ((f :>: ix) r xi -> a xi -> a xi -> a xi) -> f r xi -> TagF a ix xi -> TagF a ix xi -> TagF a ix xi+		f' f k (TagF a) (TagF b) = TagF (f (Tag k) a b)+	fromDistAscListT pf s xs = TagMap (fromDistAscListT pf (sizeTag s) (map f xs)) where+		f :: ((f :>: ix) r xi, a xi) -> (f r xi, TagF a ix xi)+		f (Tag k, a) = (k, TagF a)++instance (HTrieKeyT phi f m, m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +		HTrieKey phi ((f :>: ix) r) (TagMap phi m ix r) where+	emptyH = emptyT+	nullH = nullT+	sizeH = sizeT+	lookupH = lookupT+	lookupIxH = lookupIxT+	assocAtH = assocAtT+	updateAtH = updateAtT+	alterH = alterT+	traverseWithKeyH = traverseWithKeyT+	foldWithKeyH = foldWithKeyT+	foldlWithKeyH = foldlWithKeyT+	mapEitherH = mapEitherT+	splitLookupH = splitLookupT+	unionH = unionT+	isectH = isectT+	diffH = diffT+	alterMinH = alterMinT+	alterMaxH = alterMaxT+	extractMinH = extractMinT+	extractMaxH = extractMaxT+	isSubmapH = isSubmapT+	fromListH = fromListT+	fromAscListH = fromAscListT+	fromDistAscListH = fromDistAscListT

@@ -0,0 +1,121 @@+{-# LANGUAGE TypeFamilies, KindSignatures, FlexibleContexts, FlexibleInstances, UndecidableInstances, PatternGuards, MultiParamTypeClasses, TypeOperators #-}++module Data.TrieMap.MultiRec.UnionMap where++import Data.TrieMap.MultiRec.Class+import Data.TrieMap.MultiRec.Eq+import Data.TrieMap.Applicative+import Data.TrieMap.TrieKey++import Control.Applicative+import Control.Arrow+import Control.Monad++import Data.Maybe+import Data.Foldable+import Generics.MultiRec++import Prelude hiding (foldr)++data UnionMap (phi :: * -> *) m1 m2 (r :: * -> *) (a :: * -> *) ix = m1 r a ix :&: m2 r a ix+type instance HTrieMapT phi (f :+: g) = UnionMap phi (HTrieMapT phi f) (HTrieMapT phi g)--HTrieMap phi (f r) :*: HTrieMap phi (g r)+type instance HTrieMap phi ((f :+: g) r) = HTrieMapT phi (f :+: g) r++instance (HTrieKeyT phi f m1, HTrieKeyT phi g m2) => HTrieKeyT phi (f :+: g) (UnionMap phi m1 m2) where+	emptyT = liftM2 (:&:) emptyT emptyT+	nullT pf (m1 :&: m2) = nullT pf m1 && nullT pf m2+	sizeT s (m1 :&: m2) = sizeT s m1 + sizeT s m2+	lookupT pf k (m1 :&: m2)+		| L k <- k	= lookupT pf k m1+		| R k <- k	= lookupT pf k m2+	lookupIxT pf s k (m1 :&: m2)+		| L k <- k	= lookupIxT pf s k m1+		| R k <- k	= first (sizeT s m1 +) <$> lookupIxT pf s k m2+	assocAtT pf s i (m1 :&: m2)+		| i < s1, (i', k, a) <- assocAtT pf s i m1+				= (i', L k, a)+		| (i', k, a) <- assocAtT pf s (i - s1) m2+				= (i' + s1, R k, a)+		where	s1 = sizeT s m1+	updateAtT pf s f i (m1 :&: m2)+		| i < s1	= updateAtT pf s (\ i' -> f i' . L) i m1 :&: m2+		| otherwise	= m1 :&: updateAtT pf s (\ i' -> f (s1 + i') . R) (i - s1) m2+		where	s1 = sizeT s m1+	alterT pf s f k (m1 :&: m2)+		| L k <- k	= alterT pf s f k m1 :&: m2+		| R k <- k	= m1 :&: alterT pf s f k m2+	traverseWithKeyT pf s f (m1 :&: m2)+		= (:&:) <$> traverseWithKeyT pf s (f . L) m1 <*> traverseWithKeyT pf s (f . R) m2+	foldWithKeyT pf f (m1 :&: m2) +		= foldWithKeyT pf (f . L) m1 . foldWithKeyT pf (f . R) m2+	foldlWithKeyT pf f (m1 :&: m2)+		= foldlWithKeyT pf (f . R) m2 . foldlWithKeyT pf (f . L) m1+	mapEitherT pf s1 s2 f (m1 :&: m2) = case (mapEitherT pf s1 s2 (f . L) m1, mapEitherT pf s1 s2 (f . R) m2) of+		((m1L, m1R), (m2L, m2R)) -> (m1L :&: m2L, m1R :&: m2R)+	splitLookupT pf s f k0 (m1 :&: m2)+		| L k <- k0, (m1L, x, m1R) <- splitLookupT pf s f k m1+			= (m1L :&: emptyT pf, x, m1R :&: m2)+		| R k <- k0, (m2L, x, m2R) <- splitLookupT pf s f k m2+			= (m1 :&: m2L, x, emptyT pf :&: m2R)+	unionT pf s f (m11 :&: m12) (m21 :&: m22)+		= unionT pf s (f . L) m11 m21 :&: unionT pf s (f . R) m12 m22+	isectT pf s f (m11 :&: m12) (m21 :&: m22)+		= isectT pf s (f . L) m11 m21 :&: isectT pf s (f . R) m12 m22+	diffT pf s f (m11 :&: m12) (m21 :&: m22)+		= diffT pf s (f . L) m11 m21 :&: diffT pf s (f . R) m12 m22+	extractMinT pf s (m1 :&: m2) = (do+		((k, v), m1') <- extractMinT pf s m1+		return ((L k, v), m1' :&: m2)) `mplus`+	  (do	((k, v), m2') <- extractMinT pf s m2+		return ((R k, v), m1 :&: m2'))+	extractMaxT pf s (m1 :&: m2) = (do+		((k, v), m1') <- extractMaxT pf s m1+		return ((L k, v), m1' :&: m2)) `mplus`+	  (do	((k, v), m2') <- extractMaxT pf s m2+		return ((R k, v), m1 :&: m2'))+	alterMinT pf s f (m1 :&: m2)+		| nullT pf m1	= m1 :&: alterMinT pf s (f . R) m2+		| otherwise	= alterMinT pf s (f . L) m1 :&: m2+	alterMaxT pf s f (m1 :&: m2)+		| nullT pf m2	= alterMaxT pf s (f . L) m1 :&: m2+		| otherwise	= m1 :&: alterMaxT pf s (f . R) m2+	isSubmapT pf (<=) (m11 :&: m12) (m21 :&: m22)+		= isSubmapT pf (<=) m11 m21 && isSubmapT pf (<=) m12 m22+	fromListT pf s f xs = case breakEither xs of+		(ys, zs) -> fromListT pf s (f . L) ys :&: fromListT pf s (f . R) zs+	fromAscListT pf s f xs = case breakEither xs of+		(ys, zs) -> fromAscListT pf s (f . L) ys :&: fromAscListT pf s (f . R) zs+	fromDistAscListT pf s xs = case breakEither xs of+		(ys, zs) -> fromDistAscListT pf s ys :&: fromDistAscListT pf s zs++breakEither :: [((f :+: g) r ix, a)] -> ([(f r ix, a)], [(g r ix, a)])+breakEither = foldr breakEither' ([], []) where+	breakEither' (L k, a) (xs, ys) = ((k, a):xs, ys)+	breakEither' (R k, a) (xs, ys) = (xs, (k, a):ys)++instance (HTrieKeyT phi f m1, m1 ~ HTrieMapT phi f, HTrieKeyT phi g m2, m2 ~ HTrieMapT phi g, +		HTrieKey phi r (HTrieMap phi r)) => HTrieKey phi ((f :+: g) r) (UnionMap phi m1 m2 r) where+	emptyH = emptyT+	nullH = nullT+	sizeH = sizeT+	lookupH = lookupT+	lookupIxH = lookupIxT+	assocAtH = assocAtT+	updateAtH = updateAtT+	alterH = alterT+	traverseWithKeyH = traverseWithKeyT+	foldWithKeyH = foldWithKeyT+	foldlWithKeyH = foldlWithKeyT+	mapEitherH = mapEitherT+	splitLookupH = splitLookupT+	unionH = unionT+	isectH = isectT+	diffH = diffT+	alterMinH = alterMinT+	alterMaxH = alterMaxT+	extractMinH = extractMinT+	extractMaxH = extractMaxT+	isSubmapH = isSubmapT+	fromListH = fromListT+	fromAscListH = fromAscListT+	fromDistAscListH = fromDistAscListT

@@ -0,0 +1,79 @@+{-# LANGUAGE KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-}++module Data.TrieMap.MultiRec.UnitMap where++import Data.TrieMap.MultiRec.Class+import Data.TrieMap.MultiRec.Eq+import Data.TrieMap.Applicative+import Data.TrieMap.TrieKey++import Control.Applicative+import Control.Arrow+import Control.Monad++import Data.Maybe+import Data.Monoid+import Data.Foldable+import Data.Traversable+import Generics.MultiRec++import Prelude hiding (foldr, foldl)++newtype UMap (phi :: * -> *) (r :: * -> *) a ix = UMap (Maybe (a ix))+type instance HTrieMapT phi U = UMap phi+type instance HTrieMap phi (U r) = UMap phi r++instance HTrieKeyT phi U (UMap phi) where+	emptyT = emptyH+	nullT = nullH+	sizeT = sizeH+	lookupT = lookupH+	lookupIxT = lookupIxH+	assocAtT = assocAtH+	updateAtT = updateAtH+	alterT = alterH+	traverseWithKeyT = traverseWithKeyH+	foldWithKeyT = foldWithKeyH+	foldlWithKeyT = foldlWithKeyH+	mapEitherT = mapEitherH+	splitLookupT = splitLookupH+	unionT = unionH+	isectT = isectH+	diffT = diffH+	extractMinT = extractMinH+	extractMaxT = extractMaxH+	alterMinT = alterMinH+	alterMaxT = alterMaxH+	isSubmapT = isSubmapH+	fromListT = fromListH+	fromAscListT = fromAscListH+	fromDistAscListT = fromDistAscListH++instance HTrieKey phi (U r) (UMap phi r) where+	emptyH _ = UMap Nothing+	nullH _ (UMap m) = isNothing m+	sizeH s (UMap m) = maybe 0 s m+	lookupH _ _ (UMap m) = m+	lookupIxH _ _ _ (UMap m) = fmap ((,) 0) m+	assocAtH _ _ _ (UMap (Just a)) = (0, U, a)+	updateAtH _ _ f _ (UMap m) = UMap (m >>= f 0 U)+	alterH _ _ f _ (UMap m) = UMap (f m)+	traverseWithKeyH _ _ f (UMap m) = UMap <$> traverse (f U) m+	foldWithKeyH _ f (UMap m) z = foldr (f U) z m+	foldlWithKeyH _ f (UMap m) z = foldl (f U) z m+	mapEitherH _ _ _ f (UMap m) = (UMap *** UMap) (maybe (Nothing, Nothing) (f U) m)+	splitLookupH _ _ f _ (UMap m) = UMap `sides` maybe (Nothing, Nothing, Nothing) f m+	unionH _ _ f (UMap m1) (UMap m2) = UMap (unionMaybe (f U) m1 m2)+	isectH _ _ f (UMap m1) (UMap m2) = UMap (isectMaybe (f U) m1 m2)+	diffH _ _ f (UMap m1) (UMap m2) = UMap (diffMaybe (f U) m1 m2)+	extractMinH _ _ (UMap m) = do	v <- First m+					return ((U, v), UMap Nothing)+	extractMaxH _ _ (UMap m) = do	v <- Last m+					return ((U, v), UMap Nothing)+	alterMinH _ _ f (UMap m) = UMap (m >>= f U)+	alterMaxH = alterMinH+	isSubmapH _ _ (UMap Nothing) _ = True+	isSubmapH _ (<=) (UMap m1) (UMap m2) = subMaybe (<=) m1 m2+	fromListH _ _ f xs = UMap (foldr (\ (_, a) -> Just . maybe a (f U a)) Nothing xs)+	fromAscListH = fromListH+	fromDistAscListH _ _ xs = UMap (fmap snd (listToMaybe xs))

@@ -0,0 +1,393 @@+{-# LANGUAGE Rank2Types, PatternGuards, MultiParamTypeClasses, TypeFamilies #-}++module Data.TrieMap.OrdMap (Ordered (..)) where++import Data.TrieMap.TrieKey+import Data.TrieMap.Sized+import Data.TrieMap.Applicative++import Control.Applicative (Applicative(..), (<$>))+import Control.Arrow+import Control.Monad hiding (join)++import Data.Monoid+import Data.Maybe+-- import Data.Map+-- import qualified Data.Map as Map+import Data.Traversable++import Prelude hiding (lookup)++newtype Ordered a = Ord {unOrd :: a} deriving (Eq, Ord)+data OrdMap k a ix = Tip +              | Bin {-# UNPACK #-} !Int k (a ix) !(OrdMap k a ix) !(OrdMap k a ix) ++type instance TrieMap (Ordered k) = OrdMap k++instance Ord k => TrieKey (Ordered k) (OrdMap k) where+	emptyM = Tip+	nullM Tip = True+	nullM _ = False+	sizeM _ = size+	lookupM (Ord k) = lookup k+	lookupIxM _ (Ord k) = lookupIx 0 k+	assocAtM _ i m = fromJust (do	(i', k, a) <- assocAt 0 i m+					return (i', Ord k, a))+	updateAtM s f = updateAt s (\ i -> f i . Ord)+	alterM s f (Ord k) = alter s f k+	traverseWithKeyM s f = traverseWithKey s (f . Ord)+	foldWithKeyM f = foldrWithKey (f . Ord)+	foldlWithKeyM f = foldlWithKey (f . Ord)+	mapEitherM s1 s2 f = mapEither s1 s2 (f . Ord)+	extractMinM s Tip = mzero+	extractMinM s m = return (first (first Ord) $ deleteFindMin s m)+	extractMaxM s Tip = mzero+	extractMaxM s m = return (first (first Ord) $ deleteFindMax s m)+	alterMinM s f = updateMin s (f . Ord)+	alterMaxM s f = updateMax s (f . Ord)+	splitLookupM s f (Ord k) = splitLookup s f k+	isSubmapM = isSubmap+	fromAscListM s f xs = fromAscList s (f . Ord) [(k, a) | (Ord k, a) <- xs]+	fromDistAscListM s xs = fromDistinctAscList s [(k, a) | (Ord k, a) <- xs]+	unionM s f m1 m2 = case (m1, m2) of+		(Tip, _) -> m2+		(_, Tip) -> m1+		_	 -> hedgeUnionWithKey s (f . Ord) (const LT) (const GT) m1 m2+	isectM s f = isect s (f . Ord)+	diffM s f m1 m2 = case (m1, m2) of+		(Tip, _) -> Tip+		(_, Tip) -> m1+		_	 -> hedgeDiffWithKey s (f . Ord) (const LT) (const GT) m1 m2++lookup :: Ord k => k -> OrdMap k a ix -> Maybe (a ix)+lookup k Tip = Nothing+lookup k (Bin _ k' v l r) = case compare k k' of+	LT	-> lookup k l+	EQ	-> Just v+	GT	-> lookup k r++lookupIx :: Ord k => Int -> k -> OrdMap k a ix -> Maybe (Int, a ix)+lookupIx i _ _ | i `seq` False = undefined+lookupIx _ _ Tip = Nothing+lookupIx i k (Bin sz k' v l r) = case compare k k' of+	LT	-> lookupIx i k l+	EQ	-> Just (size l, v)+	GT	-> lookupIx (i + sz - size r) k r++assocAt :: Int -> Int -> OrdMap k a ix -> Maybe (Int, k, a ix)+assocAt i0 i _ | i0 `seq` i `seq` False = Nothing+assocAt _ _ Tip = Nothing+assocAt i0 i (Bin sz k a l r)+	| i < sL	= assocAt i0 i l+	| i < sK	= Just (i0 + sL, k, a)+	| otherwise	= assocAt (i0 + sK) (i - sK) r+	where	sL = size l+		sK = sz - size r++updateAt :: Sized a -> (Int -> k -> a ix -> Maybe (a ix)) -> Int -> OrdMap k a ix -> OrdMap k a ix+updateAt _ _ i _ | i `seq` False = undefined+updateAt _ _ _ Tip = Tip+updateAt s f i (Bin sz k a l r)+	| i < sL	= balance s k a (updateAt s f i l) r+	| i < sK	= case f sK k a of+		Nothing	-> glue s l r+		Just a'	-> bin s k a' l r+	| otherwise	= balance s k a l (updateAt s (f . (+ sK)) (i - sK) r)+	where	sL = size l+		sK = sz - size r ++alter :: Ord k => Sized a -> (Maybe (a ix) -> Maybe (a ix)) -> k -> OrdMap k a ix -> OrdMap k a ix+alter s f k Tip = case f Nothing of+	Nothing	-> Tip+	Just x	-> singleton s k x+alter s f k (Bin _ kx x l r) = case compare k kx of+	LT	-> balance s kx x (alter s f k l) r+	EQ	-> case f (Just x) of+		Nothing	-> glue s l r+		Just x'	-> balance s k x' l r+	GT	-> balance s kx x l (alter s f k r)++singleton :: Sized a -> k -> a ix -> OrdMap k a ix+singleton s k a = Bin (s a) k a Tip Tip++traverseWithKey :: Applicative f => Sized b -> (k -> a ix -> f (b ix)) -> OrdMap k a ix -> f (OrdMap k b ix)+traverseWithKey s f Tip = pure Tip+traverseWithKey s f (Bin _ k a l r) = balance s k <$> f k a <*> traverseWithKey s f l <*> traverseWithKey s f r++foldrWithKey :: (k -> a ix -> b -> b) -> OrdMap k a ix -> b -> b+foldrWithKey f Tip = id+foldrWithKey f (Bin _ k a l r) = foldrWithKey f l . f k a . foldrWithKey f r++foldlWithKey :: (k -> b -> a ix -> b) -> OrdMap k a ix -> b -> b+foldlWithKey f Tip = id+foldlWithKey f (Bin _ k a l r) = foldlWithKey f r . flip (f k) a . foldlWithKey f l++mapEither :: Ord k => Sized b -> Sized c -> EitherMap k (a ix) (b ix) (c ix) ->+	OrdMap k a ix -> (OrdMap k b ix, OrdMap k c ix)+mapEither s1 s2 f m = case m of+	Tip	-> (Tip, Tip)+	Bin _ k a l r -> case (f k a, mapEither s1 s2 f l, mapEither s1 s2 f r) of+		((aL, aR), (lL, lR), (rL, rR)) ->+			(joinMaybe s1 k aL lL rL, joinMaybe s2 k aR lR rR)++updateMin :: Ord k => Sized a -> (k -> a ix -> Maybe (a ix)) -> OrdMap k a ix -> OrdMap k a ix+updateMin s f m = case m of+	Tip	-> Tip+	Bin _ k a Tip r -> case f k a of+		Nothing -> r+		Just a'	-> insertMin s k a' r+	Bin _ k a l r	-> balance s k a (updateMin s f l) r++updateMax :: Ord k => Sized a -> (k -> a ix -> Maybe (a ix)) -> OrdMap k a ix -> OrdMap k a ix+updateMax s f m = case m of+	Tip	-> Tip+	Bin _ k a l Tip	-> case f k a of+		Nothing	-> l+		Just a'	-> insertMax s k a' l+	Bin _ k a l r	-> balance s k a l (updateMax s f r)++splitLookup :: Ord k => Sized a -> SplitMap (a ix) x -> k -> OrdMap k a ix -> (OrdMap k a ix, Maybe x, OrdMap k a ix)+splitLookup s f k m = case m of+	Tip	-> (Tip, Nothing, Tip)+	Bin _ kx x l r -> case compare k kx of+		LT	-> case splitLookup s f k l of+			(lL, ans, lR) -> (lL, ans, join s kx x lR r)+		EQ	-> case f x of+			(xL, ans, xR) -> (maybe l (\ xL -> insertMax s kx xL l) xL, ans,+						maybe r (\ xR -> insertMin s kx xR r) xR)+		GT	-> case splitLookup s f k r of+			(rL, ans, rR) -> (join s kx x l rL, ans, rR)++isSubmap :: Ord k => LEq (a ix) (b ix) -> LEq (OrdMap k a ix) (OrdMap k b ix)+isSubmap (<=) Tip _ = True+isSubmap (<=) _ Tip = False+isSubmap (<=) (Bin _ kx x l r) t = case found of+	Nothing	-> False+	Just y	-> x <= y && isSubmap (<=) l lt && isSubmap (<=) r gt+	where	(lt, found, gt) = splitLookup (const 1) (\ x -> (Nothing, Just x, Nothing)) kx t++fromAscList :: Eq k => Sized a -> (k -> a ix -> a ix -> a ix) -> [(k, a ix)] -> OrdMap k a ix+fromAscList s f xs = fromDistinctAscList s (combineEq xs) where+	combineEq (x:xs) = combineEq' x xs+	combineEq [] = []+	+	combineEq' z [] = [z]+	combineEq' z@(kz, zz) (x@(kx, xx):xs)+		| kz == kx	= combineEq' (kx, f kx xx zz) xs+		| otherwise	= (kz,zz):combineEq' x xs++fromDistinctAscList :: Sized a -> [(k, a ix)] -> OrdMap k a ix+fromDistinctAscList s xs = build const (length xs) xs+  where+    -- 1) use continutations so that we use heap space instead of stack space.+    -- 2) special case for n==5 to build bushier trees. +    build c 0 xs'  = c Tip xs'+    build c 5 xs'  = case xs' of+                       ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx) +                            -> c (bin s k4 x4 (bin s k2 x2 (singleton s k1 x1) (singleton s k3 x3)) (singleton s k5 x5)) xx+                       _ -> error "fromDistinctAscList build"+    build c n xs'  = seq nr $ build (buildR nr c) nl xs'+                   where+                     nl = n `div` 2+                     nr = n - nl - 1++    buildR n c l ((k,x):ys) = build (buildB l k x c) n ys+    buildR _ _ _ []         = error "fromDistinctAscList buildR []"+    buildB l k x c r zs     = c (bin s k x l r) zs++hedgeUnionWithKey :: Ord k+                  => Sized a -> (k -> a ix -> a ix -> Maybe (a ix))+                  -> (k -> Ordering) -> (k -> Ordering)+                  -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+hedgeUnionWithKey _ _ _     _     t1 Tip+  = t1+hedgeUnionWithKey s _ cmplo cmphi Tip (Bin _ kx x l r)+  = join s kx x (filterGt s cmplo l) (filterLt s cmphi r)+hedgeUnionWithKey s f cmplo cmphi (Bin _ kx x l r) t2+  = joinMaybe s kx newx (hedgeUnionWithKey s f cmplo cmpkx l lt) +                 (hedgeUnionWithKey s f cmpkx cmphi r gt)+  where+    cmpkx k     = compare kx k+    lt          = trim cmplo cmpkx t2+    (found,gt)  = trimLookupLo kx cmphi t2+    newx        = case found of+                    Nothing -> Just x+                    Just (_,y) -> f kx x y++filterGt :: Ord k => Sized a -> (k -> Ordering) -> OrdMap k a ix -> OrdMap k a ix+filterGt _ _   Tip = Tip+filterGt s cmp (Bin _ kx x l r)+  = case cmp kx of+      LT -> join s kx x (filterGt s cmp l) r+      GT -> filterGt s cmp r+      EQ -> r+      +filterLt :: Ord k => Sized a -> (k -> Ordering) -> OrdMap k a ix -> OrdMap k a ix+filterLt _ _   Tip = Tip+filterLt s cmp (Bin _ kx x l r)+  = case cmp kx of+      LT -> filterLt s cmp l+      GT -> join s kx x l (filterLt s cmp r)+      EQ -> l++trim :: (k -> Ordering) -> (k -> Ordering) -> OrdMap k a ix -> OrdMap k a ix+trim _     _     Tip = Tip+trim cmplo cmphi t@(Bin _ kx _ l r)+  = case cmplo kx of+      LT -> case cmphi kx of+              GT -> t+              _  -> trim cmplo cmphi l+      _  -> trim cmplo cmphi r+              +trimLookupLo :: Ord k => k -> (k -> Ordering) -> OrdMap k a ix -> (Maybe (k,a ix), OrdMap k a ix)+trimLookupLo _  _     Tip = (Nothing,Tip)+trimLookupLo lo cmphi t@(Bin _ kx x l r)+  = case compare lo kx of+      LT -> case cmphi kx of+              GT -> (((,) lo) <$> lookup lo t, t)+              _  -> trimLookupLo lo cmphi l+      GT -> trimLookupLo lo cmphi r+      EQ -> (Just (kx,x),trim (compare lo) cmphi r)++isect :: Ord k => Sized c -> IsectFunc k (a ix) (b ix) (c ix) -> OrdMap k a ix -> OrdMap k b ix -> OrdMap k c ix+isect s f Tip _ = Tip+isect s f _ Tip = Tip+isect s f t1@(Bin _ k1 x1 l1 r1) t2@(Bin _ k2 x2 l2 r2) =+	let	(lt, found, gt) = splitLookup (const 1) (\ x -> (Nothing, Just x, Nothing)) k2 t1+		tl		= isect s f lt l2+		tr		= isect s f gt r2+	 in joinMaybe s k2 (found >>= \ x1' -> f k2 x1' x2) tl tr+++hedgeDiffWithKey :: Ord k+                 => Sized a -> (k -> a ix -> b ix -> Maybe (a ix))+                 -> (k -> Ordering) -> (k -> Ordering)+                 -> OrdMap k a ix -> OrdMap k b ix -> OrdMap k a ix+hedgeDiffWithKey _ _ _     _     Tip _+  = Tip+hedgeDiffWithKey s _ cmplo cmphi (Bin _ kx x l r) Tip+  = join s kx x (filterGt s cmplo l) (filterLt s cmphi r)+hedgeDiffWithKey s f cmplo cmphi t (Bin _ kx x l r) +  = case found of+      Nothing -> merge s tl tr+      Just (ky,y) -> +          case f ky y x of+            Nothing -> merge s tl tr+            Just z  -> join s ky z tl tr+  where+    cmpkx k     = compare kx k   +    lt          = trim cmplo cmpkx t+    (found,gt)  = trimLookupLo kx cmphi t+    tl          = hedgeDiffWithKey s f cmplo cmpkx lt l+    tr          = hedgeDiffWithKey s f cmpkx cmphi gt r++joinMaybe :: Ord k => Sized a -> k -> Maybe (a ix) -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+joinMaybe s kx = maybe (merge s) (join s kx)++join :: Ord k => Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+join s kx x Tip r  = insertMin s kx x r+join s kx x l Tip  = insertMax s kx x l+join s kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)+  | delta*sizeL <= sizeR  = balance s kz z (join s kx x l lz) rz+  | delta*sizeR <= sizeL  = balance s ky y ly (join s kx x ry r)+  | otherwise             = bin s kx x l r+++-- insertMin and insertMax don't perform potentially expensive comparisons.+insertMax,insertMin :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix+insertMax s kx x t+  = case t of+      Tip -> singleton s kx x+      Bin _ ky y l r+          -> balance s ky y l (insertMax s kx x r)+             +insertMin s kx x t+  = case t of+      Tip -> singleton s kx x+      Bin _ ky y l r+          -> balance s ky y (insertMin s kx x l) r+             +{--------------------------------------------------------------------+  [merge l r]: merges two trees.+--------------------------------------------------------------------}+merge :: Sized a -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+merge _ Tip r   = r+merge _ l Tip   = l+merge s l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)+  | delta*sizeL <= sizeR = balance s ky y (merge s l ly) ry+  | delta*sizeR <= sizeL = balance s kx x lx (merge s rx r)+  | otherwise            = glue s l r++{--------------------------------------------------------------------+  [glue l r]: glues two trees together.+  Assumes that [l] and [r] are already balanced with respect to each other.+--------------------------------------------------------------------}+glue :: Sized a -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+glue _ Tip r = r+glue _ l Tip = l+glue s l r   +  | size l > size r = let ((km,m),l') = deleteFindMax s l in balance s km m l' r+  | otherwise       = let ((km,m),r') = deleteFindMin s r in balance s km m l r'++deleteFindMin :: Sized a -> OrdMap k a ix -> ((k, a ix), OrdMap k a ix)+deleteFindMin s t +  = case t of+      Bin _ k x Tip r -> ((k,x),r)+      Bin _ k x l r   -> let (km,l') = deleteFindMin s l in (km,balance s k x l' r)+      Tip             -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)++deleteFindMax :: Sized a -> OrdMap k a ix -> ((k, a ix), OrdMap k a ix)+deleteFindMax s t+  = case t of+      Bin _ k x l Tip -> ((k,x),l)+      Bin _ k x l r   -> let (km,r') = deleteFindMax s r in (km,balance s k x l r')+      Tip             -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)++delta,ratio :: Int+delta = 5+ratio = 2++size :: OrdMap k a ix -> Int+size Tip = 0+size (Bin s _ _ _ _) = s++balance :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+balance s k x l r+  | sizeL + sizeR <= 1    = Bin sizeX k x l r+  | sizeR >= delta*sizeL  = rotateL s k x l r+  | sizeL >= delta*sizeR  = rotateR s k x l r+  | otherwise             = Bin sizeX k x l r+  where+    sizeL = size l+    sizeR = size r+    sizeX = sizeL + sizeR + s x++-- rotate+rotateL :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+rotateL s k x l r@(Bin _ _ _ ly ry)+  | size ly < ratio*size ry = singleL s k x l r+  | otherwise               = doubleL s k x l r+rotateL _ _ _ _ Tip = error "rotateL Tip"++rotateR :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+rotateR s k x l@(Bin _ _ _ ly ry) r+  | size ry < ratio*size ly = singleR s k x l r+  | otherwise               = doubleR s k x l r+rotateR _ _ _ Tip _ = error "rotateR Tip"++-- basic rotations+singleL, singleR :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+singleL s k1 x1 t1 (Bin _ k2 x2 t2 t3)  = bin s k2 x2 (bin s k1 x1 t1 t2) t3+singleL _ _ _ _ Tip = error "singleL Tip"+singleR s k1 x1 (Bin _ k2 x2 t1 t2) t3  = bin s k2 x2 t1 (bin s k1 x1 t2 t3)+singleR _ _ _ Tip _ = error "singleR Tip"++doubleL, doubleR :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+doubleL s k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin s k3 x3 (bin s k1 x1 t1 t2) (bin s k2 x2 t3 t4)+doubleL _ _ _ _ _ = error "doubleL"+doubleR s k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin s k3 x3 (bin s k2 x2 t1 t2) (bin s k1 x1 t3 t4)+doubleR _ _ _ _ _ = error "doubleR"++bin :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+bin s k x l r+  = Bin (size l + size r + s x) k x l r

@@ -0,0 +1,6 @@+module Data.TrieMap.Regular (TrieMapT, TrieKeyT, module Data.TrieMap.Regular.Base, EqT(..), Comparator, OrdT (..){-, K0 (..), I0 (..), U(..), (:*:)(..), (:+:)(..), L(..), Fix(..)-}) where++import Data.TrieMap.Regular.Base+import Data.TrieMap.Regular.Class+import Data.TrieMap.Regular.Ord+import Data.TrieMap.Regular.Eq

@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies, TypeOperators #-}++module Data.TrieMap.Regular.Base where++newtype K0 a r = K0 {unK0 :: a}+newtype I0 r = I0 {unI0 :: r}+data U0 r = U0+data (f :*: g) r = f r :*: g r+data (f :+: g) r = L (f r) | R (g r)+newtype L f r = List [f r]+newtype Reg r = Reg {unReg :: r}++newtype Fix f = In {out :: f (Fix f)}++type family PF a :: * -> *++class Regular a where+	from :: a -> PF a a+	to :: PF a a -> a++type instance PF (K0 a r) = K0 a+type instance PF (I0 r) = I0+type instance PF (U0 r) = U0+type instance PF ((f :*: g) r) = PF (f r) :*: PF (g r)+type instance PF ((f :+: g) r) = PF (f r) :+: PF (g r)+type instance PF (Fix f) = f+type instance PF [a] = L (PF a)+type instance PF (L f a) = L (PF (f a))+-- type instance PF Bool = K Bool+-- type instance PF Int = K Int+-- type instance PF Char = K Char+-- type instance PF ++instance Functor (K0 a) where+	fmap _ (K0 a) = K0 a++instance Functor I0 where+	fmap f (I0 a) = I0 (f a)++instance Functor U0 where+	fmap _ U0 = U0++instance Functor f => Functor (L f) where+	fmap f (List xs) = List (map (fmap f) xs)++instance (Functor f, Functor g) => Functor (f :*: g) where+	fmap f (x :*: y) = fmap f x :*: fmap f y++instance (Functor f, Functor g) => Functor (f :+: g) where+	fmap f (L x) = L (fmap f x)+	fmap f (R x) = R (fmap f x)++from' :: (Functor (PF a), Regular a) => Reg a -> PF a (Reg a)+from' (Reg a) = fmap Reg (from a)++to' :: (Functor (PF a), Regular a) => PF a (Reg a) -> Reg a+to' = Reg . to . fmap unReg++infixr 7 :*:+infixr 6 :+:

@@ -0,0 +1,69 @@+{-# LANGUAGE Rank2Types, FlexibleContexts, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies #-}++module Data.TrieMap.Regular.Class where++import Data.TrieMap.Sized+import Data.TrieMap.Applicative+import Data.TrieMap.TrieKey+import Data.TrieMap.Regular.Eq+import Data.TrieMap.Regular.Ord++import Data.Monoid++import Control.Applicative++type family TrieMapT (f :: * -> *) :: * -> (* -> *) -> * -> *++class OrdT f => TrieKeyT (f :: * -> *) (m :: * -> (* -> *) -> * -> *) | m -> f, f -> m where+	emptyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => m k a ix+	nullT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => m k a ix -> Bool+	sizeT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> m k a ix -> Int+	lookupT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => f k -> m k a ix -> Maybe (a ix)+	lookupIxT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> f k -> m k a ix -> Maybe (Int, a ix)+	assocAtT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> Int -> m k a ix -> (Int, f k, a ix)+	updateAtT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (Int -> f k -> a ix -> Maybe (a ix)) -> Int -> m k a ix -> m k a ix+	alterT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (Maybe (a ix) -> Maybe (a ix)) -> f k -> m k a ix -> m k a ix+	traverseWithKeyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k), Applicative t) => +		Sized b -> (f k -> a ix -> t (b ix)) -> m k a ix -> t (m k b ix)+	foldWithKeyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => +		(f k -> a ix -> b -> b) -> m k a ix -> b -> b+	foldlWithKeyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) =>+		(f k -> b -> a ix -> b) -> m k a ix -> b -> b+	mapEitherT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => +		Sized b -> Sized c -> EitherMap (f k) (a ix) (b ix) (c ix) -> m k a ix -> (m k b ix, m k c ix)+	splitLookupT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> SplitMap (a ix) x -> f k ->+		m k a ix -> (m k a ix, Maybe x, m k a ix)+	unionT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> UnionFunc (f k) (a ix) ->+		m k a ix -> m k a ix -> m k a ix+	isectT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized c -> IsectFunc (f k) (a ix) (b ix) (c ix) ->+		m k a ix -> m k b ix -> m k c ix+	diffT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> DiffFunc (f k) (a ix) (b ix) ->+		m k a ix -> m k b ix -> m k a ix+	extractMinT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> m k a ix -> First ((f k, a ix), m k a ix)+	extractMaxT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> m k a ix -> Last ((f k, a ix), m k a ix)+	alterMinT, alterMaxT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (f k -> a ix -> Maybe (a ix)) ->+		m k a ix -> m k a ix+	isSubmapT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => LEq (a ix) (b ix) -> LEq (m k a ix) (m k b ix)+	fromListT, fromAscListT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (f k -> a ix -> a ix -> a ix) ->+		[(f k, a ix)] -> m k a ix+	fromDistAscListT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> [(f k, a ix)] -> m k a ix+	fromListT s f = foldr (\ (k, a) -> alterT s (Just . maybe a (f k a)) k) emptyT+	fromAscListT = fromListT+	fromDistAscListT s = fromAscListT s (const const)+	updateAtT s f i m = case assocAtT s i m of+		(i, k, a) -> alterT s (const (f i k a)) k m++guardNullT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => TrieMapT f k a ix -> Maybe (TrieMapT f k a ix)+guardNullT m+	| nullT m	= Nothing+	| otherwise	= Just m++assocsT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => TrieMapT f k a ix -> [(f k, a ix)]+assocsT m = foldWithKeyT (\ k a -> ((k, a):)) m []++singletonT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> f k -> a ix -> TrieMapT f k a ix+singletonT s k a = alterT s (const (Just a)) k emptyT++mapWithKeyT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => +	Sized b -> (f k -> a ix -> b ix) -> TrieMapT f k a ix -> TrieMapT f k b ix+mapWithKeyT s f m = unId (traverseWithKeyT s (Id .: f) m)

@@ -0,0 +1,70 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, UndecidableInstances #-}++module Data.TrieMap.Regular.ConstMap where++import Data.TrieMap.Regular.Class+import Data.TrieMap.Regular.Base+import Data.TrieMap.TrieKey++import Control.Applicative+import Control.Arrow+import Control.Monad++-- import Data.Monoid++newtype KMap m k (a :: * -> *) ix = KMap (m a ix)+type instance TrieMapT (K0 a) = KMap (TrieMap a)+type instance TrieMap (K0 a r) = TrieMapT (K0 a) r++instance (TrieKey k m, m ~ TrieMap k) => TrieKey (K0 k r) (KMap m r) where+	emptyM = KMap emptyM+	nullM (KMap m) = nullM m+	sizeM s (KMap m) = sizeM s m+	lookupM (K0 k) (KMap m) = lookupM k m+	lookupIxM s (K0 k) (KMap m) = lookupIxM s k m+	assocAtM s i (KMap m) = case assocAtM s i m of+		(i', k, a) -> (i', K0 k, a)+	updateAtM s f i (KMap m) = KMap (updateAtM s (\ i -> f i . K0) i m)+	alterM s f (K0 k) (KMap m) = KMap (alterM s f k m)+	traverseWithKeyM s f (KMap m) = KMap <$> traverseWithKeyM s (f . K0) m+	foldWithKeyM f (KMap m) = foldWithKeyM (f . K0) m+	foldlWithKeyM f (KMap m) = foldlWithKeyM (f . K0) m+	mapEitherM s1 s2 f (KMap m) = (KMap *** KMap) (mapEitherM s1 s2 (f . K0) m)+	splitLookupM s f (K0 k) (KMap m) = KMap `sides` splitLookupM s f k m+	unionM s f (KMap m1) (KMap m2) = KMap (unionM s (f . K0) m1 m2)+	isectM s f (KMap m1) (KMap m2) = KMap (isectM s (f . K0) m1 m2)+	diffM s f (KMap m1) (KMap m2) = KMap (diffM s (f . K0) m1 m2)+	extractMinM s (KMap m) = (first K0 *** KMap) `liftM` extractMinM s m+	extractMaxM s (KMap m) = (first K0 *** KMap) `liftM` extractMaxM s m+	alterMinM s f (KMap m) = KMap (alterMinM s (f . K0) m) +	alterMaxM s f (KMap m) = KMap (alterMaxM s (f . K0) m)+	isSubmapM (<=) (KMap m1) (KMap m2) = isSubmapM (<=) m1 m2+	fromListM s f xs = KMap (fromListM s (f . K0) [(k, a) | (K0 k, a) <- xs])+	fromAscListM s f xs = KMap (fromAscListM s (f . K0) [(k, a) | (K0 k, a) <- xs])+	fromDistAscListM s xs = KMap (fromDistAscListM s [(k, a) | (K0 k, a) <- xs])++instance (TrieKey k m, m ~ TrieMap k) => TrieKeyT (K0 k) (KMap m) where+	emptyT = emptyM+	nullT = nullM+	sizeT = sizeM+	lookupT = lookupM+	lookupIxT = lookupIxM+	assocAtT = assocAtM+	updateAtT = updateAtM+	alterT = alterM+	traverseWithKeyT = traverseWithKeyM+	foldWithKeyT = foldWithKeyM+	foldlWithKeyT = foldlWithKeyM+	mapEitherT = mapEitherM+	splitLookupT = splitLookupM+	unionT = unionM+	isectT = isectM+	diffT = diffM+	extractMinT = extractMinM+	extractMaxT = extractMaxM+	alterMinT = alterMinM+	alterMaxT = alterMaxM+	isSubmapT = isSubmapM+	fromListT = fromListM+	fromAscListT = fromAscListM+	fromDistAscListT = fromDistAscListM

@@ -0,0 +1,64 @@+{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeOperators #-}++module Data.TrieMap.Regular.Eq where++import Data.TrieMap.Regular.Base++class EqT f where+	eqT0 :: (a -> a -> Bool) -> f a -> f a -> Bool++eqT :: (EqT f, Eq a) => f a -> f a -> Bool+eqT = eqT0 (==)++instance Eq a => EqT (K0 a) where+	eqT0 _ (K0 a) (K0 b) = a == b++instance EqT I0 where+	eqT0 (==) (I0 a) (I0 b) = a == b++instance EqT [] where+	eqT0 (==) = eqT' where+		eqT' (a:as) (b:bs) = a == b && eqT' as bs+		eqT' [] [] = True++eqT' _ _ = False++instance (EqT f, EqT g) => EqT (f :*: g) where+	eqT0 (==) (x1 :*: y1) (x2 :*: y2) = eqT0 (==) x1 x2 && eqT0 (==) y1 y2++instance (EqT f, EqT g) => EqT (f :+: g) where+	eqT0 (==) a b = case (a, b) of+		(L a, L b) -> eqT0 (==) a b+		(R a, R b) -> eqT0 (==) a b+		_	   -> False++instance EqT U0 where+	eqT0 _ _ _ = True++instance EqT f => EqT (L f) where+	eqT0 (==) (List xs) (List ys) = eqT' xs ys where+		eqT0' = eqT0 (==)+		eqT' (a:as) (b:bs) = eqT0' a b && eqT' as bs+		eqT' [] [] = True+		eqT' _ _ = False++instance (Regular a, Functor (PF a), EqT (PF a)) => Eq (Reg a) where+	a == b = eqT (from' a) (from' b)++instance (EqT f, Eq r) => Eq (L f r) where+	(==) = eqT++instance (EqT f, EqT g, Eq r) => Eq ((f :*: g) r) where+	(==) = eqT++instance (EqT f, EqT g, Eq r) => Eq ((f :+: g) r) where+	(==) = eqT++instance Eq a => Eq (K0 a r) where+	K0 a == K0 b = a == b++instance Eq r => Eq (I0 r) where+	I0 a == I0 b = a == b++instance Eq (U0 r) where+	_ == _ = True

@@ -0,0 +1,68 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies, MultiParamTypeClasses #-}++module Data.TrieMap.Regular.IdMap where++import Data.TrieMap.TrieKey+import Data.TrieMap.Regular.Base+import Data.TrieMap.Regular.Class++import Control.Applicative+import Control.Arrow+import Control.Monad++newtype IMap k a ix = IMap (TrieMap k a ix)+type instance TrieMapT I0 = IMap+type instance TrieMap (I0 k) = IMap k++instance TrieKeyT I0 IMap where+	emptyT = IMap emptyM+	nullT (IMap m) = nullM m+	sizeT s (IMap m) = sizeM s m+	lookupT (I0 k) (IMap m) = lookupM k m+	lookupIxT s (I0 k) (IMap m) = lookupIxM s k m+	assocAtT s i (IMap m) = case assocAtM s i m of+		(i', k, a) -> (i', I0 k, a)+	updateAtT s f i (IMap m) = IMap (updateAtM s (\ i -> f i . I0) i m)+	alterT s f (I0 k) (IMap m) = IMap (alterM s f k m)+	traverseWithKeyT s f (IMap m) = IMap <$> traverseWithKeyM s (f . I0) m+	foldWithKeyT f (IMap m) = foldWithKeyM (f . I0) m+	foldlWithKeyT f (IMap m) = foldlWithKeyM (f . I0) m+	mapEitherT s1 s2 f (IMap m) = (IMap *** IMap) (mapEitherM s1 s2 (f . I0) m)+	splitLookupT s f (I0 k) (IMap m) = IMap `sides` splitLookupM s f k m+	unionT s f (IMap m1) (IMap m2) = IMap (unionM s (f . I0) m1 m2)+	isectT s f (IMap m1) (IMap m2) = IMap (isectM s (f . I0) m1 m2)+	diffT s f (IMap m1) (IMap m2) = IMap (diffM s (f . I0) m1 m2)+	extractMinT s (IMap m) = (first I0 *** IMap) `liftM` extractMinM s m+	extractMaxT s (IMap m) = (first I0 *** IMap) `liftM` extractMaxM s m+	alterMinT s f (IMap m) = IMap (alterMinM s (f . I0) m)+	alterMaxT s f (IMap m) = IMap (alterMaxM s (f . I0) m)+	isSubmapT (<=) (IMap m1) (IMap m2) = isSubmapM (<=) m1 m2+	fromListT s f xs = IMap (fromListM s (f . I0) [(k, a) | (I0 k, a) <- xs])+	fromAscListT s f xs = IMap (fromAscListM s (f . I0) [(k, a) | (I0 k, a) <- xs])+	fromDistAscListT s xs = IMap (fromDistAscListM s [(k, a) | (I0 k, a) <- xs])++instance TrieKey k (TrieMap k) => TrieKey (I0 k) (IMap k) where+	emptyM = emptyT+	nullM = nullT+	sizeM = sizeT+	lookupM = lookupT+	lookupIxM = lookupIxT+	assocAtM = assocAtT+	updateAtM = updateAtT+	alterM = alterT+	traverseWithKeyM = traverseWithKeyT+	foldWithKeyM = foldWithKeyT+	foldlWithKeyM = foldlWithKeyT+	mapEitherM = mapEitherT+	splitLookupM = splitLookupT+	unionM = unionT+	isectM = isectT+	diffM = diffT+	extractMinM = extractMinT+	extractMaxM = extractMaxT+	alterMinM = alterMinT+	alterMaxM = alterMaxT+	isSubmapM = isSubmapT+	fromListM = fromListT+	fromAscListM = fromAscListT+	fromDistAscListM = fromDistAscListT

@@ -0,0 +1,9 @@+module Data.TrieMap.Regular.Instances where++import Data.TrieMap.Regular.UnitMap+import Data.TrieMap.Regular.ConstMap+import Data.TrieMap.Regular.ProdMap+import Data.TrieMap.Regular.UnionMap+import Data.TrieMap.Regular.RadixTrie+import Data.TrieMap.Regular.IdMap+import Data.TrieMap.Regular.RegMap

@@ -0,0 +1,71 @@+{-# LANGUAGE UndecidableInstances, FlexibleContexts, TypeOperators #-}++module Data.TrieMap.Regular.Ord where++import Data.TrieMap.Regular.Base+import Data.TrieMap.Regular.Eq++import Data.Monoid++type Comparator a = a -> a -> Ordering++class EqT f => OrdT f where+	compareT0 :: Comparator a -> Comparator (f a)++compareT :: (OrdT f, Ord a) => Comparator (f a)+compareT = compareT0 compare++instance Ord a => OrdT (K0 a) where+	compareT0 _ (K0 a) (K0 b) = compare a b++instance Ord a => Ord (K0 a r) where+	compare (K0 a) (K0 b) = compare a b++instance OrdT I0 where+	compareT0 cmp (I0 a) (I0 b) = cmp a b++instance Ord r => Ord (I0 r) where+	compare = compareT++instance (OrdT f, OrdT g) => OrdT (f :*: g) where+	compareT0 cmp (x1 :*: y1) (x2 :*: y2) = compareT0 cmp x1 x2 `mappend` compareT0 cmp y1 y2++instance (OrdT f, OrdT g, Ord r) => Ord ((f :*: g) r) where+	compare = compareT++instance (OrdT f, OrdT g) => OrdT (f :+: g) where+	compareT0 cmp x y = case (x, y) of+		(L x, L y)	-> compareT0 cmp x y+		(R x, R y)	-> compareT0 cmp x y+		(L _, R _)	-> LT+		(R _, L _)	-> GT++instance (OrdT f, OrdT g, Ord r) => Ord ((f :+: g) r) where+	compare = compareT++instance OrdT U0 where+	compareT0 _ = compare++instance Ord (U0 r) where+	compare _ _ = EQ++instance OrdT f => OrdT (L f) where+	compareT0 cmp (List xs) (List ys) = compareT0' xs ys where+		cmpT' = compareT0 cmp+		compareT0' (x:xs) (y:ys) = cmpT' x y `mappend` compareT0' xs ys+		compareT0' [] [] = EQ+		compareT0' [] _ = LT+		compareT0' _ [] = GT++instance (OrdT f, Ord r) => Ord (L f r) where+	compare = compareT++instance OrdT [] where+	compareT0 cmp = cmpT' where+		cmpT' (x:xs) (y:ys) = cmp x y `mappend` cmpT' xs ys+		cmpT' [] [] = EQ+		cmpT' [] _ = LT+		cmpT' _ [] = GT++instance (Regular a, Functor (PF a), OrdT (PF a)) => Ord (Reg a) where+	compare a b = compareT (from' a) (from' b)

@@ -0,0 +1,84 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts,  TypeOperators, UndecidableInstances #-}++module Data.TrieMap.Regular.ProdMap() where++import Data.TrieMap.Regular.Class+import Data.TrieMap.Regular.Base+import Data.TrieMap.TrieKey+import Data.TrieMap.Applicative++import Control.Applicative+import Control.Arrow++import Data.Maybe++newtype PMap m1 (m2 :: * -> (* -> *) -> * -> *) k (a :: * -> *) ix = PMap (m1 k (m2 k a) ix)+type instance TrieMapT (f :*: g) = PMap (TrieMapT f) (TrieMapT g)+type instance TrieMap ((f :*: g) r) = TrieMapT (f :*: g) r++instance (TrieKeyT f m1, TrieKeyT g m2) => TrieKeyT (f :*: g) (PMap m1 m2) where+	emptyT = PMap emptyT+	nullT (PMap m) = nullT m+	sizeT s (PMap m) = sizeT (sizeT s) m+	lookupT (a :*: b) (PMap m) = lookupT a m >>= lookupT b+	lookupIxT s (a :*: b) (PMap m) = do+		(iA, m') <- lookupIxT (sizeT s) a m+		(iB, v) <- lookupIxT s b m'+		return (iA + iB, v)+	assocAtT s i (PMap m) = case assocAtT (sizeT s) i m of+		(iA, a, m') -> case assocAtT s (i - iA) m' of+			(iB, b, v) -> (iA + iB, a :*: b, v)+	updateAtT s f i (PMap m) = PMap (updateAtT (sizeT s) g i m) where+		g iA a = guardNullT . updateAtT s (\ iB b -> f (iA + iB) (a :*: b)) (i - iA)+	alterT s f (a :*: b) (PMap m) = PMap (alterT (sizeT s) g a m) where+		g = guardNullT . alterT s f b . fromMaybe emptyT+	traverseWithKeyT s f (PMap m) = PMap <$> traverseWithKeyT (sizeT s) g m where+		g a = traverseWithKeyT s (\ b -> f (a :*: b))+	foldWithKeyT f (PMap m) = foldWithKeyT g m where+		g a = foldWithKeyT (\ b -> f (a :*: b))+	foldlWithKeyT f (PMap m) = foldlWithKeyT g m where+		g a z m = foldlWithKeyT (\ b -> f (a :*: b)) m z+	mapEitherT s1 s2 f (PMap m) = (PMap *** PMap) (mapEitherT (sizeT s1) (sizeT s2) g m) where+		g a = (guardNullT *** guardNullT) . mapEitherT s1 s2 (\ b -> f (a :*: b))+	splitLookupT s f (a :*: b) (PMap m) = PMap `sides` splitLookupT (sizeT s) g a m where+		g = sides guardNullT . splitLookupT s f b+	unionT s f (PMap m1) (PMap m2) = PMap (unionT (sizeT s) (\ a -> guardNullT .: unionT s (\ b -> f (a :*: b))) m1 m2)+	isectT s f (PMap m1) (PMap m2) = PMap (isectT (sizeT s) (\ a -> guardNullT .: isectT s (\ b -> f (a :*: b))) m1 m2)+	diffT s f (PMap m1) (PMap m2) = PMap (diffT (sizeT s) (\ a -> guardNullT .: diffT s (\ b -> f (a :*: b))) m1 m2)+	extractMinT s (PMap m) = do+		((a, m1), m') <- extractMinT (sizeT s) m+		((b, v), m1') <- extractMinT s m1+		return ((a :*: b, v), PMap (maybe m' (\ _ -> alterMinT (sizeT s) (\ _ _ -> Just m1') m) (guardNullT m1')))+	extractMaxT s (PMap m) = do+		((a, m1), m') <- extractMaxT (sizeT s) m+		((b, v), m1') <- extractMaxT s m1+		return ((a :*: b, v), PMap (maybe m' (\ _ -> alterMaxT (sizeT s) (\ _ _ -> Just m1') m) (guardNullT m1')))+	alterMinT s f (PMap m) = PMap (alterMinT (sizeT s) (\ a -> guardNullT . alterMinT s (\ b -> f (a :*: b))) m)+	alterMaxT s f (PMap m) = PMap (alterMaxT (sizeT s) (\ a -> guardNullT . alterMaxT s (\ b -> f (a :*: b))) m)+	isSubmapT (<=) (PMap m1) (PMap m2) = isSubmapT (isSubmapT (<=)) m1 m2++instance (TrieKeyT f m1, TrieKeyT g m2, TrieKey k (TrieMap k)) => TrieKey ((f :*: g) k) (PMap m1 m2 k) where+	emptyM = emptyT+	nullM = nullT+	sizeM = sizeT+	lookupM = lookupT+	lookupIxM = lookupIxT+	assocAtM = assocAtT+	updateAtM = updateAtT+	alterM = alterT+	traverseWithKeyM = traverseWithKeyT+	foldWithKeyM = foldWithKeyT+	foldlWithKeyM = foldlWithKeyT+	mapEitherM = mapEitherT+	splitLookupM = splitLookupT+	unionM = unionT+	isectM = isectT+	diffM = diffT+	extractMinM = extractMinT+	extractMaxM = extractMaxT+	alterMinM = alterMinT+	alterMaxM = alterMaxT+	isSubmapM = isSubmapT+	fromListM = fromListT+	fromAscListM = fromAscListT+	fromDistAscListM = fromDistAscListT

@@ -0,0 +1,322 @@+{-# LANGUAGE Rank2Types, PatternGuards, FlexibleContexts, TypeFamilies, UndecidableInstances, MultiParamTypeClasses #-}++module Data.TrieMap.Regular.RadixTrie where++import Data.TrieMap.Regular.Class+import Data.TrieMap.Regular.Base+import Data.TrieMap.Regular.Ord+import Data.TrieMap.Regular.Eq+import Data.TrieMap.Sized+import Data.TrieMap.TrieKey+import Data.TrieMap.Applicative++import Control.Arrow+import Control.Applicative+import Control.Monad++import Data.Maybe+import Data.Monoid+import Data.Foldable+import Data.Traversable++import Prelude hiding (foldr, foldl)++data Edge f (m :: * -> (* -> *) -> * -> *) k (a :: * -> *) ix = Edge {-# UNPACK #-} !Int [f k] (Maybe (a ix)) (m k (Edge f m k a) ix)+type Edge' f k a ix = Edge f (TrieMapT f) k a ix+type MEdge f k m a ix = Maybe (Edge f m k a ix)+type MEdge' f k a ix = Maybe (Edge' f k a ix)+newtype RadixTrie f k a ix = Radix (MEdge' f k a ix)+-- newtype K0 a b = K0 a++type instance TrieMapT (L f) = RadixTrie f+type instance TrieMap (L f r) = RadixTrie f r+-- type instance TrieMap [k] = RadixTrie k (TrieMap k)++edgeSize :: Sized (Edge f m k a)+edgeSize (Edge s _ _ _) = s++edge :: (TrieKeyT f m, m ~ TrieMapT f, TrieKey k (TrieMap k)) => Sized a -> [f k] -> Maybe (a ix) -> m k (Edge f m k a) ix -> Edge f m k a ix+edge s ks v ts = Edge (maybe 0 s v + sizeT edgeSize ts) ks v ts++instance (OrdT f, TrieKeyT f m, m ~ TrieMapT f) => TrieKeyT (L f) (RadixTrie f) where+	emptyT = Radix Nothing+	nullT (Radix m) = isNothing m+	sizeT _ (Radix m) = maybe 0 edgeSize m+	lookupT (List ks) (Radix m) = m >>= lookupE ks+	lookupIxT s (List ks) (Radix m) = m >>= lookupIxE s 0 ks+	assocAtT s i (Radix m) = fromJust (do	(i', ks, v) <- m >>= assocAtE s i+						return (i', List ks, v))+	updateAtT s f i (Radix m) = Radix (m >>= updateAtE s (\ i' -> f i' . List) i)+	alterT s f (List ks) (Radix m) = Radix (maybe (singletonME s ks (f Nothing)) (alterE s f ks) m)+	traverseWithKeyT s f (Radix m) = Radix <$> traverse (traverseE s (f . List)) m+	foldWithKeyT f (Radix m) z = foldr (foldE (f . List)) z m+	foldlWithKeyT f (Radix m) z = foldr (foldlE (f . List)) z m+	mapEitherT s1 s2 f (Radix m) = (Radix *** Radix) (maybe (Nothing, Nothing) (mapEitherE s1 s2 (f . List)) m)+	splitLookupT s f (List ks) (Radix m) = Radix `sides` maybe (Nothing, Nothing, Nothing) (splitLookupE s f ks) m+	unionT s f (Radix m1) (Radix m2) = Radix (unionMaybe (unionE s (f . List)) m1 m2)+	isectT s f (Radix m1) (Radix m2) = Radix (isectMaybe (isectE s (f . List)) m1 m2)+	diffT s f (Radix m1) (Radix m2) = Radix (diffMaybe (diffE s (f . List)) m1 m2)+	extractMinT s (Radix m) = First m >>= liftM (first List *** Radix) . extractMinE s+	extractMaxT s (Radix m) = Last m >>= liftM (first List *** Radix) . extractMaxE s+	alterMinT s f (Radix m) = Radix (m >>= alterMinE s (f . List))+	alterMaxT s f (Radix m) = Radix (m >>= alterMaxE s (f . List))+	isSubmapT (<=) (Radix m1) (Radix m2) = subMaybe (isSubEdge (<=)) m1 m2+	fromListT s f xs = Radix (fromListE s (f . List) [(ks, a) | (List ks, a) <- xs])+	fromAscListT s f xs = Radix (fromAscListE s (f . List) [(ks, a) | (List ks, a) <- xs])++instance (OrdT f, TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => TrieKey (L f k) (RadixTrie f k) where+	emptyM = emptyT+	nullM = nullT+	sizeM = sizeT+	lookupM = lookupT+	lookupIxM = lookupIxT+	assocAtM = assocAtT+	updateAtM = updateAtT+	alterM = alterT+	traverseWithKeyM = traverseWithKeyT+	foldWithKeyM = foldWithKeyT+	foldlWithKeyM = foldlWithKeyT+	mapEitherM = mapEitherT+	splitLookupM = splitLookupT+	unionM = unionT+	isectM = isectT+	diffM = diffT+	extractMinM = extractMinT+	extractMaxM = extractMaxT+	alterMinM = alterMinT+	alterMaxM = alterMaxT+	isSubmapM = isSubmapT+	fromListM = fromListT+	fromAscListM = fromAscListT+	fromDistAscListM = fromDistAscListT++-- instance (Ord k, TrieKey k m) => TrieKey [k] (RadixTrie k m) where+-- 	emptyM = Radix Nothing+-- 	nullM (Radix m) = isNothing m+-- 	lookupM ks (Radix m) = m >>= lookupE ks+-- 	alterM f ks (Radix m) = Radix (maybe (singletonME ks (f Nothing)) (alterE f ks) m)+-- 	traverseWithKeyM f (Radix m) = Radix <$> traverse (traverseE f) m+-- 	foldWithKeyM f (Radix m) z = foldr (foldE f) z m+-- 	mapEitherM f (Radix m) = (Radix *** Radix) (maybe (Nothing, Nothing) (mapEitherE f) m)+-- 	splitLookupM f ks (Radix m) = Radix `sides` maybe (Nothing, Nothing, Nothing) (splitLookupE f ks) m+-- 	unionM f (Radix m1) (Radix m2) = Radix (unionMaybe (unionE f) m1 m2)+-- 	isectM f (Radix m1) (Radix m2) = Radix (isectMaybe (isectE f) m1 m2)+-- 	diffM f (Radix m1) (Radix m2) = Radix (diffMaybe (diffE f) m1 m2)+-- 	extractMinM (Radix m) = First m >>= fmap (fmap Radix) . extractMinE+-- 	extractMaxM (Radix m) = Last m >>= fmap (fmap Radix) . extractMaxE+-- 	alterMinM f (Radix m) = Radix (m >>= alterMinE f)+-- 	alterMaxM f (Radix m) = Radix (m >>= alterMaxE f)+-- 	isSubmapM (<=) (Radix m1) (Radix m2) = subMaybe (isSubEdge (<=)) m1 m2+-- 	fromListM = Radix .: fromListE+-- 	fromAscListM = Radix .: fromAscListE++compact :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Edge' f k a ix -> MEdge' f k a ix+compact e@(Edge s ks Nothing ts) = case assocsT ts of+	[]	-> Nothing+	[~(k, e'@(Edge s' ls v ts'))]+		-> e' `seq` compact (Edge s' (ks ++ k:ls) v ts')+	_	-> Just e+compact e = Just e++cons :: f k -> Edge' f k a ix -> Edge' f k a ix+l `cons` Edge s ls v ts = Edge s (l:ls) v ts++cat :: [f k] -> Edge' f k a ix -> Edge' f k a ix+ks `cat` Edge s ls v ts = Edge s (ks ++ ls) v ts++singletonME :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> [f k] -> Maybe (a ix) -> MEdge' f k a ix+singletonME s ks = fmap (\ v -> Edge (s v) ks (Just v) emptyT)++lookupE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => [f k] -> Edge' f k a ix -> Maybe (a ix)+lookupE ks (Edge _ ls v ts) = match ks ls where+	match (k:ks) (l:ls)+		| k `eqT` l	= match ks ls+	match (k:ks) [] = do	e' <- lookupT k ts+				lookupE ks e'+	match [] [] = v+	match _ _ = Nothing++alterE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => +	Sized a -> (Maybe (a ix) -> Maybe (a ix)) -> [f k] -> Edge' f k a ix -> MEdge' f k a ix+alterE s f ks0 e@(Edge sz ls0 v0 ts0) = match 0 ks0 ls0 where+	match i _ _ | i `seq` False = undefined+	match i (k:ks) (l:ls)+		| k `eqT` l	= match (i+1) ks ls+		| Just v <- f Nothing+				= Just (Edge (sz + s v) (take i ls0) Nothing +					(fromListT edgeSize (const const) [(k, Edge (s v) ks (Just v) emptyT), +						(l, Edge sz ls v0 ts0)]))+	match _ (k:ks) [] = compact $ edge s ls0 v0 $ alterT edgeSize g k ts0 where+		g = maybe (singletonME s ks (f Nothing)) (alterE s f ks)+	match _ [] (l:ls)+		| Just v <- f Nothing+			= Just (Edge (sz + s v) ks0 (Just v) (singletonT edgeSize l (Edge sz ls v0 ts0)))+	match _ [] [] = compact (edge s ls0 (f v0) ts0)+	match _ _ _ = Just e++traverseE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k), Applicative t) => +	Sized b -> ([f k] -> a ix -> t (b ix)) -> Edge' f k a ix -> t (Edge' f k b ix)+traverseE s f (Edge _ ks v ts) =+	edge s ks <$> traverse (f ks) v <*> traverseWithKeyT edgeSize (\ l -> traverseE s (\ ls -> f (ks ++ l:ls))) ts++foldE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => ([f k] -> a ix -> b -> b) -> Edge' f k a ix -> b -> b+foldE f (Edge _ ks v ts) z = foldr (f ks) (foldWithKeyT (\ l -> foldE (\ ls -> f (ks ++ l:ls))) ts z) v++foldlE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => ([f k] -> b -> a ix -> b) -> Edge' f k a ix -> b -> b+foldlE f (Edge _ ks v ts) z = foldlWithKeyT (\ l z m -> foldlE (\ ls -> f (ks ++ l:ls)) m z) ts (foldl (f ks) z v)++mapEitherE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized b -> Sized c -> +	EitherMap (EitherMap [f k] (a ix) (b ix) (c ix)) (Edge' f k a ix) (Edge' f k b ix) (Edge' f k c ix)+mapEitherE s1 s2 f (Edge _ ks v ts) = case (maybe (Nothing, Nothing) (f ks) v, mapEitherT edgeSize edgeSize +					(\ l -> mapEitherE s1 s2 (\ ls -> f (ks ++ l:ls))) ts) of +	((vL, vR), (tsL, tsR)) -> (compact (edge s1 ks vL tsL), compact (edge s2 ks vR tsR))++splitLookupE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> SplitMap (a ix) x -> [f k] -> SplitMap (Edge' f k a ix) x+splitLookupE s f ks e@(Edge _ ls v ts) = match ks ls where+	match (k:ks) (l:ls) = case compareT k l of+		LT	-> (Nothing, Nothing, Just e)+		EQ	-> match ks ls+		GT	-> (Just e, Nothing, Nothing)+	match [] [] = case v of+		Nothing	-> (Nothing, Nothing, Just e)+		Just v	-> compact `sides` case f v of+			(vL, x, vR) -> (edge s ls vL emptyT, x, edge s ls vR ts)+	match [] (l:ls) = (Just e, Nothing, Nothing)+	match (k:ks) [] = compact `sides` case splitLookupT edgeSize g k ts of+		(tsL, x, tsR)	-> (edge s ls v tsL, x, edge s ls Nothing tsR)+		where	g = splitLookupE s f ks++unionE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> UnionFunc (UnionFunc [f k] (a ix)) (Edge' f k a ix)+unionE s f (Edge szK ks0 vK tsK) (Edge szL ls0 vL tsL) = match 0 ks0 ls0 where+	match i _ _ | i `seq` False = undefined+	match i (k:ks) (l:ls)+		| k `eqT` l	= match (i+1) ks ls+		| otherwise	= Just (Edge (szK + szL) (take i ks0) Nothing +					(fromListT edgeSize (const const) [(k, Edge szK ks vK tsK), (l, Edge szL ls vL tsL)]))+	match _ (k:ks) [] = compact (edge s ls0 vL $ alterT edgeSize g k tsL) where+		g Nothing = Just (Edge szK ks vK tsK)+		g (Just e) = unionE s (\ ks' -> f (ls0 ++ k:ks')) (Edge szK ks vK tsK) e+	match _ [] (l:ls) = compact (edge s ks0 vK $ alterT edgeSize g l tsK) where+		g Nothing = Just (Edge szL ls vL tsL)+		g (Just e) = unionE s (\ ls' -> f (ks0 ++ l:ls')) e (Edge szL ls vL tsL)+	match _ [] [] = compact (edge s ks0 (unionMaybe (f ks0) vK vL) (unionT edgeSize g tsK tsL)) where+		g x = unionE s (\ xs -> f (ks0 ++ x:xs))++extractMinE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> Edge' f k a ix -> First (([f k], a ix), MEdge' f k a ix)+extractMinE s (Edge _ ks v ts) = (do+	v <- First v+	return ((ks, v), compact (edge s ks Nothing ts))) `mplus` +  (do	((x, e'), ts') <- extractMinT edgeSize ts+	((xs, v), e'') <- extractMinE s e'+	return ((ks ++ x:xs, v), compact (edge s ks Nothing (maybe ts' (\ e'' -> alterMinT edgeSize (\ _ _ -> Just e'') ts) e''))))++extractMaxE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> Edge' f k a ix -> Last (([f k], a ix), MEdge' f k a ix)+extractMaxE s (Edge _ ks v ts) = (do+	v <- Last v+	return ((ks, v), Nothing)) `mplus`+  (do	((x, e'), ts') <- extractMaxT edgeSize ts+	((xs, v), e'') <- extractMaxE s e'+	return ((ks ++ x:xs, v), compact (edge s ks Nothing (maybe ts' (\ e'' -> alterMaxT edgeSize (\ _ _ -> Just e'') ts) e''))))++alterMinE, alterMaxE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a ->+	([f k] -> a ix -> Maybe (a ix)) -> Edge' f k a ix -> MEdge' f k a ix+alterMinE s f (Edge _ ks (Just v) ts) = compact (edge s ks (f ks v) ts)+alterMinE s f (Edge _ ks Nothing ts) = compact (edge s ks Nothing (alterMinT edgeSize (\ x -> alterMinE s (\ xs -> f (ks ++ x:xs))) ts))++alterMaxE s f (Edge _ ks v ts)+	| nullT ts	= do	v' <- v >>= f ks+				return (Edge (s v') ks (Just v') ts)+	| otherwise	= compact (edge s ks v (alterMaxT edgeSize (\ x -> alterMaxE s (\ xs -> f (ks ++ x:xs))) ts))++isectE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized c ->+	IsectFunc (IsectFunc [f k] (a ix) (b ix) (c ix)) (Edge' f k a ix) (Edge' f k b ix) (Edge' f k c ix)+isectE s f (Edge szK ks vK tsK) (Edge szL ls vL tsL) = match ks ls where+	match (k:ks) (l:ls)+		| k `eqT` l	= match ks ls+	match (k:ks) [] = do	e' <- lookupT k tsL+				liftM (cat ls . cons k) (isectE s (\ ks' -> f (ls ++ k:ks')) (Edge szK ks vK tsK) e')+	match [] (l:ls) = do	e' <- lookupT l tsK+				liftM (cat ks . cons l) (isectE s (\ ls' -> f (ks ++ l:ls')) e' (Edge szL ls vL tsL))+	match [] [] = compact (edge s ks (isectMaybe (f ks) vK vL) (isectT edgeSize g tsK tsL)) where+		g x = isectE s (\ xs -> f (ks ++ x:xs))++diffE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a ->+	DiffFunc (DiffFunc [f k] (a ix) (b ix)) (Edge' f k a ix) (Edge' f k b ix)+diffE s f e@(Edge szK ks vK tsK) (Edge szL ls vL tsL) = match ks ls where+	match (k:ks) (l:ls)+		| k `eqT` l	= match ks ls+	match (k:ks) []+		| Just e' <- lookupT k tsL+			= fmap (cat ls . cons k) (diffE s (\ ks' -> f (ls ++ k:ks')) (Edge szK ks vK tsK) e')+	match [] (l:ls) = compact (edge s ks vK (alterT edgeSize (>>= g) l tsK)) where+		g e' = diffE s (\ ls' -> f (ks ++ l:ls')) e' (Edge szL ls vL tsL)+	match [] [] = compact (edge s ks (diffMaybe (f ks) vK vL) (diffT edgeSize g tsK tsL)) where+		g x = diffE s (\ xs -> f (ks ++ x:xs))++isSubEdge :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => LEq (a ix) (b ix) -> LEq (Edge' f k a ix) (Edge' f k b ix)+isSubEdge (<=) (Edge szK ks vK tsK) (Edge szL ls vL tsL) = match ks ls where+	match (k:ks) (l:ls)+		| k `eqT` l	= match ks ls+	match (k:ks) []+		| Just e' <- lookupT k tsL+			= isSubEdge (<=) (Edge szK ks vK tsK) e'+	match [] []+		= subMaybe (<=) vK vL && isSubmapT (isSubEdge (<=)) tsK tsL+	match _ _ = False++filterer :: (k -> k -> Bool) -> (a -> a -> a) -> [([k], a)] -> (Maybe a, [(k, [([k], a)])])+filterer (==) f = filterer' where+	filterer' (([], a):xs) = first (Just . maybe a (f a)) (filterer' xs)+	filterer' ((k:ks, a):xs) = second (cons k ks a) (filterer' xs)+	cons k ks a [] = [(k, [(ks, a)])]+	cons k ks a ys0@((k', xs):ys)+		| k == k'	= (k', (ks,a):xs):ys+		| otherwise	= (k, [(ks, a)]):ys0++fromListE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> ([f k] -> a ix -> a ix -> a ix) -> [([f k], a ix)] -> MEdge' f k a ix+fromListE _ _ [] = Nothing+fromListE s f xs = case filterer eqT (f []) xs of+	(Nothing, [(k, xs)]) -> cons k <$> fromListE s (f . (k:)) xs+	(v, xss) -> Just (edge s [] v (mapWithKeyT edgeSize (\ k (K0 xs) -> fromJust (fromListE s (f . (k:)) xs))+				(fromListT (const 1) (\ _ (K0 xs) (K0 ys) -> K0 (xs ++ ys)) [(k, K0 xs) | (k, xs) <- xss])))++fromAscListE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => +	Sized a -> ([f k] -> a ix -> a ix -> a ix) -> [([f k], a ix)] -> MEdge' f k a ix+fromAscListE _ _ [] = Nothing+fromAscListE s f xs = case filterer eqT (f []) xs of+	(Nothing, [(k, xs)]) -> cons k <$> fromAscListE s (f . (k:)) xs+	(v, xss) -> Just (edge s [] v (fromDistAscListT edgeSize [(k, fromJust (fromAscListE s (f . (k:)) xs)) | (k, xs) <- xss]))++lookupIxE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>+	Sized a -> Int -> [f k] -> Edge' f k a ix -> Maybe (Int, a ix)+lookupIxE _ i _ _ | i `seq` False = undefined+lookupIxE s i ks (Edge _ ls v ts) = match ks ls where+	match (k:ks) (l:ls)+		| k `eqT` l	= match ks ls+	match (k:ks) [] = do+		(iT, e') <- lookupIxT edgeSize k ts+		lookupIxE s (i + maybe 0 s v + iT) ks e'+	match [] [] = (,) i <$> v+	match _ _ = Nothing++assocAtE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>+	Sized a -> Int -> Edge' f k a ix -> Maybe (Int, [f k], a ix)+assocAtE s i (Edge _ ks Nothing ts) = case assocAtT edgeSize i ts of+	(iT, l, e') -> do	(i', ls, v) <- assocAtE s (i - iT) e'+				return (iT + i', ks ++ l:ls, v)+assocAtE s i (Edge _ ks (Just v) ts)+	| i < sv	= return (0, ks, v)+	| (iT, l, e') <- assocAtT edgeSize (i - sv) ts+		= do	(i', ls, v') <- assocAtE s ((i - sv) - iT) e'+			return (i' + iT + sv, ks ++ l:ls, v')+	where sv = s v++updateAtE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>+	Sized a -> (Int -> [f k] -> a ix -> Maybe (a ix)) -> Int -> Edge' f k a ix -> MEdge' f k a ix+updateAtE s f i (Edge sz ks Nothing ts) = compact (edge s ks Nothing (updateAtT edgeSize g i ts)) where+	g iT l = updateAtE s (\ i' ls -> f (iT + i') (ks ++ l:ls)) (i - iT)+updateAtE s f i (Edge sz ks (Just v) ts)+	| i < sv	= compact (edge s ks (f 0 ks v) ts)+	| otherwise	= compact (edge s ks (Just v) (updateAtT edgeSize g (i - sv) ts))+	where	sv = s v+		g iT l = updateAtE s (\ i' ls -> f (sv + iT + i') (ks ++ l:ls)) (i - sv - iT)

@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeFamilies, MultiParamTypeClasses #-}++module Data.TrieMap.Regular.RegMap where++import Data.TrieMap.Regular.Class+import Data.TrieMap.Regular.Base+import Data.TrieMap.TrieKey++import Control.Applicative+import Control.Arrow+import Control.Monad++newtype RegMap k m (a :: * -> *) ix = RegMap (m (Reg k) a ix)++instance (Regular k, Functor (PF k), TrieKeyT (PF k) m, m ~ TrieMapT (PF k)) => TrieKey (Reg k) (RegMap k m) where+	emptyM = RegMap emptyT	+	nullM (RegMap m) = nullT m+	sizeM s (RegMap m) = sizeT s m+	lookupM k (RegMap m) = lookupT (from' k) m+	lookupIxM s k (RegMap m) = lookupIxT s (from' k) m+	assocAtM s i (RegMap m) = case assocAtT s i m of+		(i', k, a) -> (i', to' k, a)+	updateAtM s f i (RegMap m) = RegMap (updateAtT s (\ i' -> f i' . to') i m)+	alterM s f k (RegMap m) = RegMap (alterT s f (from' k) m)+	traverseWithKeyM s f (RegMap m) = RegMap <$> traverseWithKeyT s (f . to') m+	foldWithKeyM f (RegMap m) = foldWithKeyT (f . to') m+	foldlWithKeyM f (RegMap m) = foldlWithKeyT (f . to') m+	mapEitherM s1 s2 f (RegMap m) = (RegMap *** RegMap) (mapEitherT s1 s2 (f . to') m)+	splitLookupM s f k (RegMap m) = RegMap `sides` splitLookupT s f (from' k) m+	unionM s f (RegMap m1) (RegMap m2) = RegMap (unionT s (f . to') m1 m2)+	isectM s f (RegMap m1) (RegMap m2) = RegMap (isectT s (f . to') m1 m2)+	diffM s f (RegMap m1) (RegMap m2) = RegMap (diffT s (f . to') m1 m2)+	extractMinM s (RegMap m) = (first to' *** RegMap) `liftM` extractMinT s m+	extractMaxM s (RegMap m) = (first to' *** RegMap) `liftM` extractMaxT s m+	alterMinM s f (RegMap m) = RegMap (alterMinT s (f . to') m)+	alterMaxM s f (RegMap m) = RegMap (alterMaxT s (f . to') m)+	isSubmapM (<=) (RegMap m1) (RegMap m2) = isSubmapT (<=) m1 m2+	fromListM s f xs = RegMap (fromListT s (f . to') [(from' k, a) | (k, a) <- xs])+	fromAscListM s f xs = RegMap (fromAscListT s (f . to') [(from' k, a) | (k, a) <- xs])+	fromDistAscListM s xs = RegMap (fromDistAscListT s [(from' k, a) | (k, a) <- xs])

@@ -0,0 +1,9 @@+{-# LANGUAGE Rank2Types #-}++module Data.TrieMap.Regular.Sized where++import Data.TrieMap.Regular.Base+import Data.TrieMap.Sized++sizeK0 :: Sized (K0 a)+sizeK0 _ = 1

@@ -0,0 +1,109 @@+{-# LANGUAGE TypeOperators, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}++module Data.TrieMap.Regular.UnionMap() where++import Data.TrieMap.Regular.Class+import Data.TrieMap.Regular.Base+import Data.TrieMap.TrieKey++import Control.Applicative+import Control.Arrow+import Control.Monad++import Data.Either++-- import Generics.MultiRec.Base+data UnionMap m1 m2 k (a :: * -> *) ix = m1 k a ix :&: m2 k a ix++type instance TrieMapT (f :+: g) = UnionMap (TrieMapT f) (TrieMapT g)+type instance TrieMap ((f :+: g) r) = TrieMapT (f :+: g) r++instance (TrieKeyT f m1, TrieKeyT g m2) => TrieKeyT (f :+: g) (UnionMap m1 m2) where+	emptyT = emptyT :&: emptyT+	nullT (m1 :&: m2) = nullT m1 && nullT m2+	sizeT s (m1 :&: m2) = sizeT s m1 + sizeT s m2+	lookupT k (m1 :&: m2) = case k of+		L k -> lookupT k m1+		R k -> lookupT k m2+	lookupIxT s k (m1 :&: m2) = case k of+		L k -> lookupIxT s k m1+		R k -> first (+ sizeT s m1) <$> lookupIxT s k m2+	assocAtT s i (m1 :&: m2)+		| i < s1	= case assocAtT s i m1 of+			(i', k, a) -> (i', L k, a)+		| otherwise	= case assocAtT s (i - s1) m2 of+			(i', k, a) -> (i' + s1, R k, a)+		where s1 = sizeT s m1+	updateAtT s f i (m1 :&: m2)+		| i < s1	= updateAtT s (\ i' -> f i' . L) i m1 :&: m2+		| otherwise	= m1 :&: updateAtT s (\ i' -> f (i' + s1) . R) (i - s1) m2+		where s1 = sizeT s m1+	alterT s f k (m1 :&: m2) = case k of+		L k -> alterT s f k m1 :&: m2+		R k -> m1 :&: alterT s f k m2+	traverseWithKeyT s f (m1 :&: m2) = (:&:) <$> traverseWithKeyT s (f . L) m1 <*> traverseWithKeyT s (f . R) m2+	foldWithKeyT f (m1 :&: m2) = foldWithKeyT (f . L) m1 . foldWithKeyT (f . R) m2+	foldlWithKeyT f (m1 :&: m2) = foldlWithKeyT (f . R) m2 . foldlWithKeyT (f . L) m1+	mapEitherT s1 s2 f (m1 :&: m2) = case (mapEitherT s1 s2 (f . L) m1, mapEitherT s1 s2 (f . R) m2) of+		((m1L, m1R), (m2L, m2R)) -> (m1L :&: m2L, m1R :&: m2R)+	splitLookupT s f k (m1 :&: m2) = case k of+		L k -> case splitLookupT s f k m1 of+			(m1L, ans, m1R) -> (m1L :&: emptyT, ans, m1R :&: m2)+		R k -> case splitLookupT s f k m2 of+			(m2L, ans, m2R) -> (m1 :&: m2L, ans, emptyT :&: m2R)+	unionT s f (m11 :&: m12) (m21 :&: m22) = unionT s (f . L) m11 m21 :&: unionT s (f . R) m12 m22+	isectT s f (m11 :&: m12) (m21 :&: m22) = isectT s (f . L) m11 m21 :&: isectT s (f . R) m12 m22+	diffT s f (m11 :&: m12) (m21 :&: m22) = diffT s (f . L) m11 m21 :&: diffT s (f . R) m12 m22+	extractMinT s (m1 :&: m2) = (do+		((k, a), m1') <- extractMinT s m1+		return ((L k, a), m1' :&: m2)) `mplus`+	  (do	((k, a), m2') <- extractMinT s m2+	  	return ((R k, a), m1 :&: m2'))+	extractMaxT s (m1 :&: m2) = (do+		((k, a), m1') <- extractMaxT s m1+		return ((L k, a), m1' :&: m2)) `mplus`+	  (do	((k, a), m2') <- extractMaxT s m2+	  	return ((R k, a), m1 :&: m2'))+	alterMinT s f (m1 :&: m2)+		| nullT m1	= m1 :&: alterMinT s (f . R) m2+		| otherwise	= alterMinT s (f . L) m1 :&: m2+	alterMaxT s f (m1 :&: m2)+		| nullT m2	= alterMaxT s (f . L) m1 :&: m2+		| otherwise	= m1 :&: alterMaxT s (f . R) m2+	isSubmapT (<=) (m11 :&: m12) (m21 :&: m22) = isSubmapT (<=) m11 m21 && isSubmapT (<=) m12 m22+	fromListT s f xs = case partEithers xs of+		(ys, zs) -> fromListT s (f . L) ys :&: fromListT s (f . R) zs+	fromAscListT s f xs = case partEithers xs of+		(ys, zs) -> fromAscListT s (f . L) ys :&: fromAscListT s (f . R) zs+	fromDistAscListT s xs = case partEithers xs of+		(ys, zs) -> fromDistAscListT s ys :&: fromDistAscListT s zs++partEithers :: [((f :+: g) r, a)] -> ([(f r, a)], [(g r, a)])+partEithers = foldr part ([], []) where+	part (L k, a) (xs, ys) = ((k, a):xs, ys)+	part (R k, a) (xs, ys) = (xs, (k, a):ys)++instance (TrieKeyT f m1, TrieKeyT g m2, TrieKey k (TrieMap k)) => TrieKey ((f :+: g) k) (UnionMap m1 m2 k) where+	emptyM = emptyT+	nullM = nullT+	lookupM = lookupT+	lookupIxM = lookupIxT+	assocAtM = assocAtT+	updateAtM = updateAtT+	alterM = alterT+	traverseWithKeyM = traverseWithKeyT+	foldWithKeyM = foldWithKeyT+	foldlWithKeyM = foldlWithKeyT+	mapEitherM = mapEitherT+	splitLookupM = splitLookupT+	unionM = unionT+	isectM = isectT+	diffM = diffT+	extractMinM = extractMinT+	extractMaxM = extractMaxT+	alterMinM = alterMinT+	alterMaxM = alterMaxT+	isSubmapM = isSubmapT+	fromListM = fromListT+	fromAscListM = fromAscListT+	fromDistAscListM = fromDistAscListT

@@ -0,0 +1,75 @@+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}++module Data.TrieMap.Regular.UnitMap() where++import Data.TrieMap.Regular.Class+import Data.TrieMap.Regular.Base+import Data.TrieMap.TrieKey++import Control.Applicative+import Control.Arrow++import Data.Foldable+import Data.Maybe+import Data.Monoid+import Data.Traversable++import Prelude hiding (foldr, foldl)++newtype M k a ix = M (Maybe (a ix))+type instance TrieMapT U0 = M+type instance TrieMap (U0 r) = M r++instance TrieKey (U0 r) (M r) where+	emptyM = M Nothing+	nullM (M a) = isNothing a+	sizeM s (M a) = maybe 0 s a+	lookupM _ (M a) = a+	lookupIxM s _ (M a) = fmap ((,) 0) a+	assocAtM s i (M (Just v)) = (0, U0, v)+	updateAtM s f i (M v) = M (v >>= f 0 U0)+	alterM _ f _ (M a) = M (f a)+	traverseWithKeyM _ f (M a) = M <$> traverse (f U0) a+	foldWithKeyM f (M a) z = foldr (f U0) z a+	foldlWithKeyM f (M a) z = foldl (f U0) z a+	mapEitherM _ _ f (M Nothing) = (M Nothing, M Nothing)+	mapEitherM _ _ f (M (Just a)) = (M *** M) (f U0 a)+	splitLookupM _ f _ (M a) = M `sides` maybe (Nothing, Nothing, Nothing) f a+	unionM _ f (M a) (M b) = M (unionMaybe (f U0) a b)+	isectM _ f (M a) (M b) = M (isectMaybe (f U0) a b)+	diffM _ f (M a) (M b) = M (diffMaybe (f U0) a b)+	extractMinM _ (M a) = do	a <- First a+					return ((U0, a), M Nothing)+	extractMaxM _ (M a) = do	a <- Last a+					return ((U0, a), M Nothing)+	alterMinM _ f (M a) = M (a >>= f U0)+	alterMaxM = alterMinM+	isSubmapM (<=) (M a) (M b) = subMaybe (<=) a b+	fromListM _ f = M . foldr (\ (_, a) -> Just . maybe a (f U0 a)) Nothing+	fromDistAscListM _ = M . fmap snd . listToMaybe++instance TrieKeyT U0 M where+	emptyT = emptyM+	nullT = nullM+	sizeT = sizeM+	lookupT = lookupM+	lookupIxT = lookupIxM+	assocAtT = assocAtM+	updateAtT = updateAtM+	alterT = alterM+	traverseWithKeyT = traverseWithKeyM+	foldWithKeyT = foldWithKeyM+	foldlWithKeyT = foldlWithKeyM+	mapEitherT = mapEitherM+	splitLookupT = splitLookupM+	unionT = unionM+	isectT = isectM+	diffT = diffM+	extractMinT = extractMinM+	extractMaxT = extractMaxM+	alterMinT = alterMinM+	alterMaxT = alterMaxM+	isSubmapT = isSubmapM+	fromListT = fromListM+	fromAscListT = fromAscListM+	fromDistAscListT = fromDistAscListM

@@ -0,0 +1,18 @@+{-# LANGUAGE Rank2Types #-}++module Data.TrieMap.Sized where++-- class Sized f where+-- 	getSize :: f a -> Int+-- +-- newtype Elem a = Elem {getElem :: a}+-- +-- instance Sized Elem where+-- 	getSize _ = 1++type Sized f = forall ix . f ix -> Int++newtype Elem a = Elem {getElem :: a}++elemSize :: Sized Elem+elemSize _ = 1

@@ -0,0 +1,109 @@+{-# LANGUAGE Rank2Types, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies, KindSignatures #-}++module Data.TrieMap.TrieKey where++import Data.TrieMap.Applicative+import Data.TrieMap.Sized++import Control.Applicative++import Data.Monoid++type family TrieMap k :: (* -> *) -> * -> *+-- data Fixer f++type EitherMap k a b c = k -> a -> (Maybe b, Maybe c)+type SplitMap a x = a -> (Maybe a, Maybe x, Maybe a)+type UnionFunc k a = k -> a -> a -> Maybe a+type IsectFunc k a b c = k -> a -> b -> Maybe c+type DiffFunc k a b = k -> a -> b -> Maybe a+type ExtractFunc k f a m = m -> f ((k, a), m)+type LEq a b = a -> b -> Bool+-- type Sized f = forall ix . f ix -> Int++-- toFixer :: a -> Fixer a+-- toFixer _ = undefined++class Ord k => TrieKey k m | k -> m, m -> k where+	emptyM :: TrieMap k ~ m => m a ix+	nullM :: TrieMap k ~ m => m a ix -> Bool+	sizeM :: (TrieMap k ~ m) => Sized a -> m a ix -> Int+	lookupM :: TrieMap k ~ m => k -> m a ix -> Maybe (a ix)+	lookupIxM :: TrieMap k ~ m => Sized a -> k -> m a ix -> Maybe (Int, a ix)+	assocAtM :: TrieMap k ~ m => Sized a -> Int -> m a ix -> (Int, k, a ix)+	updateAtM :: TrieMap k ~ m => Sized a -> (Int -> k -> a ix -> Maybe (a ix)) -> Int -> m a ix -> m a ix+	alterM :: (TrieMap k ~ m) => Sized a -> (Maybe (a ix) -> Maybe (a ix)) -> k -> m a ix -> m a ix+	{-# SPECIALIZE traverseWithKeyM :: (k -> a ix -> Id (b ix)) -> m a ix -> Id (m b ix) #-}+	traverseWithKeyM :: (TrieMap k ~ m, Applicative f) => (forall ix . b ix -> Int) -> +		(k -> a ix -> f (b ix)) -> m a ix -> f (m b ix)+	foldWithKeyM :: TrieMap k ~ m => (k -> a ix -> b -> b) -> m a ix -> b -> b+	foldlWithKeyM :: TrieMap k ~ m => (k -> b -> a ix -> b) -> m a ix -> b -> b+	mapEitherM :: (TrieMap k ~ m) => Sized b -> Sized c -> EitherMap k (a ix) (b ix) (c ix) -> m a ix -> (m b ix, m c ix)+	splitLookupM :: (TrieMap k ~ m) => Sized a -> SplitMap (a ix) x -> k -> m a ix -> (m a ix, Maybe x, m a ix)+	unionM :: (TrieMap k ~ m) => Sized a -> UnionFunc k (a ix) -> m a ix -> m a ix -> m a ix+	isectM :: (TrieMap k ~ m) => Sized c -> IsectFunc k (a ix) (b ix) (c ix) -> m a ix -> m b ix -> m c ix+	diffM :: (TrieMap k ~ m) => Sized a -> DiffFunc k (a ix) (b ix) -> m a ix -> m b ix -> m a ix+	extractMinM :: (TrieMap k ~ m) => Sized a -> ExtractFunc k First (a ix) (m a ix)+	extractMaxM :: (TrieMap k ~ m) => Sized a -> ExtractFunc k Last (a ix) (m a ix)+	alterMinM, alterMaxM :: (TrieMap k ~ m) => Sized a -> (k -> a ix -> Maybe (a ix)) -> m a ix -> m a ix+	isSubmapM :: TrieMap k ~ m => LEq (a ix) (b ix) -> LEq (m a ix) (m b ix)+	fromListM, fromAscListM :: (TrieMap k ~ m) => Sized a -> (k -> a ix -> a ix -> a ix) -> [(k, a ix)] -> m a ix+	fromDistAscListM :: (TrieMap k ~ m) => Sized a -> [(k, a ix)] -> m a ix+	+	sizeM s m = foldWithKeyM (\ _ a n -> s a + n) m 0+	fromListM s f = foldr (uncurry (insertWithKeyM s f)) emptyM+	fromAscListM = fromListM+	fromDistAscListM s = fromAscListM s (const const)+	updateAtM s f i m = case assocAtM s i m of+		(i', k, a)	-> alterM s (const (f i' k a)) k m++guardNullM :: (TrieKey k m, m ~ TrieMap k) => m a ix -> Maybe (m a ix)+guardNullM m+	| nullM m	= Nothing+	| otherwise	= Just m++sides :: (a -> c) -> (a, b, a) -> (c, b, c)+sides f (l, x, r) = (f l, x, f r)++mapMaybeM :: (TrieKey k m, m ~ TrieMap k) => Sized b -> (k -> a ix -> Maybe (b ix)) -> m a ix -> m b ix+mapMaybeM s f = snd . mapEitherM elemSize s (((,) (Nothing :: Maybe (Elem ix))) .: f)++mapWithKeyM :: (TrieKey k m, m ~ TrieMap k) => Sized b -> (k -> a ix -> b ix) -> m a ix -> m b ix+mapWithKeyM s f  = unId . traverseWithKeyM s (Id .: f)++mapM :: (TrieKey k m, m ~ TrieMap k) => Sized b -> (a ix -> b ix) -> m a ix -> m b ix+mapM s = mapWithKeyM s . const++assocsM :: (TrieKey k m, m ~ TrieMap k) => m a ix -> [(k, a ix)]+assocsM m = foldWithKeyM (\ k a xs -> (k, a):xs) m []++insertM :: (TrieKey k m, m ~ TrieMap k) => Sized a -> k -> a ix -> m a ix -> m a ix+insertM s = insertWithKeyM s (const const)++insertWithKeyM :: (TrieKey k m, m ~ TrieMap k) => Sized a -> (k -> a ix -> a ix -> a ix) -> k -> a ix -> m a ix -> m a ix+insertWithKeyM s f k a = alterM s f' k where+	f' = Just . maybe a (f k a)++singletonM :: (TrieKey k m, m ~ TrieMap k) => Sized a -> k -> a ix -> m a ix+singletonM s k a = insertM s k a emptyM++fromListM' :: (TrieKey k m, m ~ TrieMap k) => Sized a -> [(k, a ix)] -> m a ix+fromListM' s = fromListM s (const const) --xs = foldr (uncurry insertM) emptyM xs++unionMaybe :: (a -> a -> Maybe a) -> Maybe a -> Maybe a -> Maybe a+unionMaybe _ Nothing y = y+unionMaybe _ x Nothing = x+unionMaybe f (Just x) (Just y) = f x y++isectMaybe :: (a -> b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c+isectMaybe f (Just x) (Just y) = f x y+isectMaybe _ _ _ = Nothing++diffMaybe :: (a -> b -> Maybe a) -> Maybe a -> Maybe b -> Maybe a+diffMaybe f Nothing = const Nothing+diffMaybe f (Just x) = maybe (Just x) (f x)++subMaybe :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool+subMaybe _ Nothing _ = True+subMaybe (<=) (Just a) (Just b) = a <= b+subMaybe _ _ _ = False

@@ -1,4 +1,4 @@-Copyright (c) 2009, Louis Wasserman+Copyright (c) 2008, Louis Wasserman All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

@@ -1,33 +1,51 @@-name:		TrieMap-version:	0.0.1.2-license:	BSD3-license-file:	LICENSE-maintainer:	wasserman.louis@gmail.com-category:	Data Structures-synopsis:	An implementation of generalized tries with sophisticated map type inference.-description:	Generalized trie implementation that automatically infers map types.  Keys must implement the class 'TrieMap.Algebraic.Algebraic', which -			declares that they are isomorphic to an /algebraic type/,-			defined recursively as follows:- .- * () and 'Int' are algebraic types.- .- * If @'Ord' a@, then @'Ordered' a@ is an algebraic type.- .- * If @a,b@ are algebraic types, then so are @(a, b)@ and @Either a b@.- .- * If @a@ is algebraic, so is @[a]@.- .- This package exports almost the entire collection of methods available in Data.Map, and several new methods as well.  In addition, each method will automatically infer the correct map type.- -build-type:	Simple-build-depends:-	base >= 4 && <= 5, containers == 0.2.0.1, bytestring-exposed-modules:-	TrieMap-	TrieMap.Algebraic+name:		     TrieMap+version:             0.5.0+tested-with:	     GHC+category:            Algorithms+synopsis:	     Automatic type inference of generalized tries.+description:	     Builds on the multirec library to create a system capable of automatic or simple generalized trie type inference.+license:             BSD3+license-file:	     LICENSE+author:              Louis Wasserman+maintainer:          wasserman.louis@gmail.com+build-Depends:       base < 5.0.0.0, containers, multirec+build-type:	     Simple+exposed-modules:  +	Data.TrieMap,+	Data.TrieMap.Class,+	Data.TrieMap.Regular,+	Data.TrieMap.MultiRec+	-- Data.TrieMap.TrieKey other-modules:-	TrieMap.TrieAlgebraic-	TrieMap.Applicative-	TrieMap.Reflection-	TrieMap.RadixTrie-	TrieMap.MapTypes+	Data.TrieMap.Class.Instances,+	Data.TrieMap.TrieKey,+	Data.TrieMap.Applicative,+	Data.TrieMap.MultiRec.FamMap,+	Data.TrieMap.MultiRec.Eq,+	Data.TrieMap.MultiRec.Ord,+	Data.TrieMap.MultiRec.Class,+	Data.TrieMap.MultiRec.ConstMap,+	Data.TrieMap.MultiRec.IMap,+	Data.TrieMap.MultiRec.Instances,+	Data.TrieMap.MultiRec.ProdMap,+	Data.TrieMap.MultiRec.TagMap,+	Data.TrieMap.MultiRec.UnionMap,+	Data.TrieMap.MultiRec.UnitMap,+	Data.TrieMap.MultiRec.Sized,+	Data.TrieMap.Regular.Base,+	Data.TrieMap.Regular.Class,+	Data.TrieMap.Regular.ConstMap,+	Data.TrieMap.Regular.Eq,+	Data.TrieMap.Regular.IdMap,+	Data.TrieMap.Regular.Instances,+	Data.TrieMap.Regular.Ord,+	Data.TrieMap.Regular.ProdMap,+	Data.TrieMap.Regular.RadixTrie,+	Data.TrieMap.Regular.UnitMap,+	Data.TrieMap.Regular.RegMap,+	Data.TrieMap.Regular.UnionMap,+	Data.TrieMap.Regular.Sized,+	Data.TrieMap.IntMap,+	Data.TrieMap.OrdMap,+	Data.TrieMap.Sized,+	Data.TrieMap.Applicative

@@ -1,954 +0,0 @@-{-# 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 @'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,--- --- @'fromList' [((\"alphabet\", 'Just' (0.2 :: 'Double'), 'True'), \"wxyz\")]@--- ---  returns a variable of type--- --- @'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:--- --- 	* @'AlgRep' 'Char' ~ 'Int'@: the 'Algebraic' instance for 'Char' maps characters to their ASCII representations, so an 'IntMap' can be used.--- --- 	* @'AlgRep' ('Maybe' a) ~ 'Either' () ('AlgRep' a)@; a 'TrieMap' on a 'Maybe' key type simply gets a space for one extra (possible) value.--- --- 	* @'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.--- --- 	* @'AlgRep' 'Bool' ~ 'Either' () ()@, so a 'TrieMap' on a 'Bool' takes the form of -- essentially -- a pair of 'Maybe's.--- 	--- 	* @'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' ('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.--- --- 	* Lookup operations take /O(log n)/ for 'Ordered' keys, /O(max(log n, W))/ for 'Int' keys, /O(l)/ times lookup cost for @k@ --- 		for keys of type @[k]@, and otherwise will take @O(1)@ over the total cost of their components.--- --- 	* Insertion operations take roughly the same asymptotic time as lookup operations.--- 	--- 	* Traversal operations take /O(n)/ for all map types, with obviously greater overhead for use of specialized --- 		'Applicative' functors.--- 	--- 	* Set operations (union, intersection, difference) take /O(m + n)/ in all cases.--module TrieMap (-	-- * Map type-	TrieMap,-	Algebraic (..), -	AlgebraicT (..),-	TrieKey,-	TrieKeyT,-	EqT,-	-- * Map instances-	ProdMap,  (:*:)(..), CProdMap, UnionMap, (:+:)(..), CUnionMap, RadixTrie, ConstMap, Const(..), IdMap, Id(..), CompMap, O, o, unO, FixMap, Fix(..), -	-- * Operators-	(!), -	(\\),-	-- * Query-	null,-	size,-	member,-	notMember,-	lookup, -	find,-	findWithDefault,-	-- * Construction-	empty,-	singleton,-	-- * Insertion-	insert,-	insertWith,-	insertWithKey,-	insertLookupWithKey,-	-- * Delete/Update-	delete,-	update,-	updateWithKey,-	updateLookupWithKey,-	alter,-	alterLookup,-	-- * Combine-	-- ** Union/Symmetric Difference-	union, -	unionWith,-	unionWithKey,-	unions,-	unionsWith,-	unionsWithKey,-	unionMaybeWith,-	unionMaybeWithKey,-	symDifference,-	-- ** Intersection-	intersection,-	intersectionWith,-	intersectionWithKey,-	intersectionMaybeWith,-	intersectionMaybeWithKey,-	-- ** Difference-	difference, -	differenceWith,-	differenceWithKey, -	-- * Traversal-	-- ** Map-	map,-	mapWithKey,-	traverseWithKey,-	mapMaybe,-	mapMaybeWithKey,-	mapEither,-	mapEitherWithKey,-	mapKeys,-	mapKeysWith,-	mapKeysMonotonic,-	-- ** Fold-	fold,-	foldWithKey,-	-- * Conversion-	elems,-	keys,-	assocs,-	-- ** Lists-	fromList,-	fromListWith,-	fromListWithKey,-	-- ** Ordered lists-	fromAscList,-	fromAscListWith,-	fromAscListWithKey,-	fromDistinctAscList,-	-- * Filter-	filter,-	filterWithKey,-	partition,-	partitionWithKey,-	split,-	splitLookup,-	-- * Submap-	isSubmapOf,-	isSubmapOfBy,-	-- * Min/Max-	findMin,-	getMin,-	findMax,-	getMax,-	deleteMin,-	deleteMax,-	deleteFindMin,-	deleteFindMax,-	updateMin,-	updateMax,-	updateMinWithKey,-	updateMaxWithKey,-	minView,-	maxView,-	minViewWithKey,-	maxViewWithKey) where--- module TrieMap where--import Control.Monad-import Data.Monoid-import Data.Traversable-import TrieMap.MapTypes-import TrieMap.Applicative-import TrieMap.Algebraic-import TrieMap.TrieAlgebraic-import TrieMap.RadixTrie-import TrieMap.Reflection-import Control.Applicative hiding (Alternative(..), Const)-import Data.Maybe hiding (mapMaybe)-import Data.Map (Map)-import Data.IntMap (IntMap)-import Data.Foldable hiding (fold, find)-import GHC.Exts--- import TrieMap.FixPoint--- import TrieMap.FixPoint.Algebraic--- import TrieMap.Reflection-import Prelude hiding (lookup, foldr, null, filter, foldl, map)-import qualified Prelude as Prelude---- | A 'TrieMap' is a size-tracking wrapper around a generalized trie map.-data TrieMap k m a = TrieMap {sizeMap :: Int, trieMap :: m (Elem a)}--instance (Eq k, Eq a, Algebraic k, TrieKey (AlgRep k) m) => Eq (TrieMap k m a) where-	(==) = (==) `on` assocs--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 (AlgRep k) m) => Show (TrieMap k m a) where-	show m = "fromList " ++ show (assocs m)---- instance (Algebraic k, Algebraic a, TrieKey (AlgRep k) m) => Algebraic (TrieMap k m a) where--- 	type AlgRep (TrieMap k m a) =  ([(AlgRep k, AlgRep a)], Int)--- 	toAlg (TrieMap n m) = (build (\ c n -> foldWithKeyAlg (\ k a -> c (k, toAlg a)) n m), n)--- 	fromAlg (xs, n) = TrieMap n $ fromDistAscListAlg [(k, fromAlg a) | (k, a) <- xs]--instance SAlgebraicT m => AlgebraicT (TrieMap k m) where-	type AlgRepT (TrieMap k m) = SAlgRepT m :*: Const Int-	toAlgT (TrieMap n m) = fmap getElem (toSAlgT m) :*: Const n-	fromAlgT (m :*: Const n) = TrieMap n (fromSAlgT (fmap Elem m))--instance Algebraic (m (Elem a)) => Algebraic (TrieMap k m a) where-	type AlgRep (TrieMap k m a) = AlgRep (m (Elem a), Int)-	toAlg (TrieMap n m) = toAlg (m, n)-	fromAlg = uncurry (flip TrieMap) . fromAlg-{--instance (Algebraic (AlgRep k), Algebraic k, TrieKey (AlgRep k) m) => AlgebraicT (TrieMap k m) where-	type AlgRepT (TrieMap k m) = AlgRepT ([] `O` ((,) (AlgRep k)))-	toAlgT (TrieMap _ m) = toAlgT (o (fmap (fmap getElem) (assocsAlg m)))-	fromAlgT = mkTrieMap . fromDistAscListAlg . fmap (fmap Elem) . unO . fromAlgT--instance (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 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 (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 (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 (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 (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 (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--- the value at key @k@ or returns default value @def@--- when the key is not in the map.------ > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'--- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'-findWithDefault :: (Algebraic k, TrieKey (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 (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.--- Calls 'error' when the element can not be found.------ > fromList [(5,'a'), (3,'b')] ! 1    Error: element not in the map--- > fromList [(5,'a'), (3,'b')] ! 5 == '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 (AlgRep k) m) => TrieMap k m a-empty = TrieMap 0 emptyAlg---- | Check if the specified map is empty.-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 (AlgRep k) m) => TrieMap k m a -> Int-size = sizeMap---- | Build a map from a list of key\/value pairs. See also 'fromAscList'.--- If the list contains more than one value for the same key, the last value--- for the key is retained.------ > 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 (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 (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'.------ > 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 (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.--- /The precondition (input list is ascending) is not checked./------ > 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 (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 (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--- combining function for equal keys.--- /The precondition (input list is ascending) is not checked./------ > 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 (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)---- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.--- /The precondition is not checked./------ > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]-fromDistinctAscList :: (Algebraic k, TrieKey (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.--- If the key is already present in the map, the associated value is--- replaced with the supplied value. 'insert' is equivalent to--- @'insertWith' 'const'@.------ > 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 (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.--- @'insertWith' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert the pair @(key, f new_value old_value)@.------ > 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 (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.--- @'insertWithKey' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert the pair @(key,f key new_value old_value)@.--- Note that the key passed to f is the same key passed to 'insertWithKey'.------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > 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 (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 (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')---- | The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f x = if x == "a" then Just "new a" else Nothing--- > 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 (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--- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',--- the element is deleted. If it is (@'Just' y@), the key @k@ is bound--- to the new value @y@.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > 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 (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'.--- The function returns changed value, if it is updated.--- Returns the original key value if the map entry is deleted. ------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > 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 (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')-	where	g v = let v' = v >>= f k . getElem in ((isNothing v' && isJust v, maybe (fmap getElem v) Just v'), fmap Elem v')---- | Delete a key and its value from the map. When the key is not--- a member of the map, the original map is returned.------ > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > delete 5 empty                         == empty--- --- 'delete' is equivalent to @'alter' ('const' 'Nothing')@.-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.--- 'alter' can be used to insert, delete, or update a value in a 'Map'.--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.------ > let f _ = Nothing--- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- >--- > 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 (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 (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)-		g (Just (Elem v)) = let fv = f (Just v) in ((Just v, just1 fv - 1), fmap Elem fv)-		just1 = maybe 0 (const 1)---- | /O(n)/. Map a function over all values in the map.------ > 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 (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 (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.-traverseWithKey :: (Algebraic k, TrieKey (AlgRep k) m, Applicative f) =>-	(k -> a -> f b) -> TrieMap k m a -> f (TrieMap k m b)-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 (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 (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.------ > let f a = if a < "c" then Left a else Right a--- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])--- >--- > 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 (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.------ > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)--- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])--- >--- > 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 (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 (\ 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@.--- --- The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key.  In this case the value at the smallest of--- these keys is retained.------ > 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 (AlgRep k1) m1, TrieKey (AlgRep k2) m2) =>-	(k1 -> k2) -> TrieMap k1 m1 a -> TrieMap k2 m2 a-mapKeys = mapKeysWith const---- |--- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.--- --- The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key.  In this case the associated values will be--- combined using @c@.------ > 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 (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]---- | /O(n)/.--- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@--- is strictly monotonic.--- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.--- /The precondition is not checked./--- Semi-formally, we have:--- --- > and [x < y ==> f x < f y | x <- ls, y <- ls] --- >                     ==> mapKeysMonotonic f s == mapKeys f s--- >     where ls = keys s------ This means that @f@ maps distinct original keys to distinct resulting keys.--- This function has better performance than 'mapKeys'.------ > 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 (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 (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.------ > 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 (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--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate.------ > 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 (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--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate.------ > 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 (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 #-}--- | /O(n)/. Return all key\/value pairs in the map in ascending key order.------ > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--- > assocs empty == []-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 (AlgRep k) m) => TrieMap k m a -> [k]-keys m = Prelude.map fst (assocs m)---- | /O(n)/.--- Return all elements of the map in the ascending order of their keys.------ > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]--- > elems empty == []-elems :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> [a]-elems = toList---- | /O(n)/. Fold the values in the map, such that--- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.--- For example,------ > elems map = fold (:) [] map------ > let f a len = len + (length a)--- > fold f 0 (fromList [(5,"a"), (3,"bbb")]) == 4-fold :: TrieKey k m => (a -> b -> b) -> b -> TrieMap k m a -> b-fold = foldr---- | /O(n)/. Fold the keys and values in the map, such that--- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'assocs'@.--- For example,------ > keys map = foldWithKey (\k x ks -> k:ks) [] map------ > 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 (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 (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)/.--- Union with a combining function. ------ > 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 (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 (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 (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)/.--- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. --- It prefers @t1@ when duplicate keys are encountered,--- 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 (AlgRep k) m) => TrieMap k m a -> TrieMap k m a -> TrieMap k m a-union = unionWith const--unions :: (Algebraic k, TrieKey (AlgRep k) m) => [TrieMap k m a] -> TrieMap k m a-unions = unionsWith const--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 (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 (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 (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---- | /O(n+m)/. Intersection with a combining function.------ > 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 (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 (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 (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.--- Return data in the first map for the keys existing in both maps.--- (@'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 (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--- encountered, the combining function is applied to the key and both values.--- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@. ------ > 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 (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---- | /O(n+m)/. Difference with a combining function. --- When two equal keys are--- encountered, the combining function is applied to the values of these keys.--- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@. ------ > 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 (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 (AlgRep k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a-difference = differenceWith (\ _ _ -> Nothing)---- | Same as 'difference'.-(\\) :: (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 (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 (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 (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 (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 (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 (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 (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)-checkNothing x = (isNothing x, x)---- | Delete and find the maximal element.------ > 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 (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 (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---- | Update the value at the maximal key.------ > 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 (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---- | Update the value at the minimal key.------ > 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 (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---- | Update the value at the maximal key.------ > 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 (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---- | Retrieves the value associated with the minimal key of the--- map, and the map stripped of that element, or 'Nothing' if passed an--- empty map.------ > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")--- > minView empty == Nothing-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')---- | Retrieves the value associated with the maximal key of the--- map, and the map stripped of that element, or 'Nothing' if passed an------ > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")--- > maxView empty == Nothing-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')---- | Retrieves the minimal (key,value) pair of the map, and--- the map stripped of that element, or 'Nothing' if passed an empty map.------ > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")--- > minViewWithKey empty == Nothing-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')---- | Retrieves the maximal (key,value) pair of the map, and--- the map stripped of that element, or 'Nothing' if passed an empty map.------ > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")--- > maxViewWithKey empty == Nothing-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')---- | /O(n+m)/.--- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).----isSubmapOf :: (Algebraic k, TrieKey (AlgRep k) m, Eq a) => TrieMap k m a -> TrieMap k m a -> Bool-isSubmapOf = isSubmapOfBy (==)--{- | /O(n+m)/.- The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if- all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when- applied to their respective values. For example, the following - expressions are all 'True':- - > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])-- But the following are all 'False':- - > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (<)  (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])- --}-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---- | The expression (@'split' k map@) is a pair @(map1,map2)@ where--- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.--- Any key equal to @k@ is found in neither @map1@ nor @map2@.------ > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])--- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")--- > 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 (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)---- | The expression (@'splitLookup' k map@) splits a map just--- like 'split' but also returns @'lookup' k map@.------ > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])--- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")--- > 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 (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)

@@ -1,417 +0,0 @@-{-# LANGUAGE TypeOperators, FlexibleContexts, UndecidableInstances, TypeFamilies, TypeSynonymInstances  #-}--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-import qualified Data.Set as Set-import Data.IntMap (IntMap)-import Data.Map (Map)-import qualified Data.IntMap as IMap-import qualified Data.Map as Map-import qualified Data.Foldable as Fold-import GHC.Exts (build)--import TrieMap.TrieAlgebraic-import TrieMap.MapTypes--newtype AlgWrap t a = AlgWrap {unAlgWrap :: t a}---- | 'Algebraic' refers to a type with an algebraic representation, armed with methods to convert in each direction.--- 'toAlg' and 'fromAlg' should preserve equality and ordering.-class Algebraic k where-	-- | @'AlgRep' k@ is a fully decomposed representation of k into algebraic pieces.-	type AlgRep k-	toAlg :: k -> AlgRep k-	fromAlg :: AlgRep k -> k--class Functor (AlgRepT t) => AlgebraicT t where-	type AlgRepT t :: * -> *-	toAlgT :: t a -> AlgRepT t a-	fromAlgT :: AlgRepT t a -> t a--class Functor (SAlgRepT t) => SAlgebraicT t where-	type SAlgRepT t :: * -> *-	toSAlgT :: Sized a => t a -> SAlgRepT t a-	fromSAlgT :: Sized a => SAlgRepT t a -> t a--instance AlgebraicT Id where-	type AlgRepT Id = Id-	toAlgT = id-	fromAlgT = id--instance (AlgebraicT t, Algebraic a) => Algebraic (AlgWrap t a) where-	type AlgRep (AlgWrap t a) = AlgRepT t (AlgRep a)-	toAlg = fmap toAlg . toAlgT . unAlgWrap-	fromAlg = AlgWrap . fromAlgT . fmap fromAlg--instance (AlgebraicT f, AlgebraicT g) => AlgebraicT (f `O` g) where-	type AlgRepT (f `O` g) = AlgRepT f `O` AlgRepT g-	toAlgT (O x) = O (fmap (\ (App y) -> App (toAlgT y)) (toAlgT x))-	fromAlgT (O x) = O (fromAlgT (fmap (\ (App y) -> App (fromAlgT y)) x))--instance (Algebraic (f (g a)), Functor f) => Algebraic ((f `O` g) a) where-	type AlgRep ((f `O` g) a) = AlgRep (f (g a))-	toAlg = toAlg . unO-	fromAlg = o . fromAlg--instance (AlgebraicT f, AlgebraicT g) => AlgebraicT (f :*: g) where-	type AlgRepT (f :*: g) = AlgRepT f :*: AlgRepT g-	toAlgT (a :*: b) = toAlgT a :*: toAlgT b-	fromAlgT (a :*: b) = fromAlgT a :*: fromAlgT b--instance (AlgebraicT f, AlgebraicT g, Algebraic a) => Algebraic ((f :*: g) a) where-	type AlgRep ((f :*: g) a) = (AlgRepT f :*: AlgRepT g) (AlgRep a)-	toAlg (a :*: b) = fmap toAlg (toAlgT a :*: toAlgT b)-	fromAlg (a :*: b) = fromAlgT (fmap fromAlg a) :*: fromAlgT (fmap fromAlg b)--instance (AlgebraicT f, AlgebraicT g) => AlgebraicT (f :+: g) where-	type AlgRepT (f :+: g) = AlgRepT f :+: AlgRepT g-	toAlgT (A a) = A (toAlgT a)-	toAlgT (B b) = B (toAlgT b)-	fromAlgT (A a) = A (fromAlgT a)-	fromAlgT (B b) = B (fromAlgT b)--instance (AlgebraicT f, AlgebraicT g, Algebraic a) => Algebraic ((f :+: g) a) where-	type AlgRep ((f :+: g) a) = AlgRep (AlgWrap (f :+: g) a)-	toAlg = toAlg . AlgWrap-	fromAlg = unAlgWrap . fromAlg--instance AlgebraicT f => Algebraic (Fix f) where-	type AlgRep (Fix f) = Fix (AlgRepT f)-	toAlg (Fix x) = Fix (fmap toAlg (toAlgT x))-	fromAlg (Fix x) = Fix (fromAlgT (fmap fromAlg x))--instance Algebraic a => AlgebraicT (Const a) where-	type AlgRepT (Const a) = Const (AlgRep a)-	toAlgT (Const a) = Const (toAlg a)-	fromAlgT (Const a) = Const (fromAlg a)--instance Algebraic a => Algebraic (Const a b) where-	type AlgRep (Const a b) = Const (AlgRep a) b-	toAlg (Const a) = Const (toAlg a)-	fromAlg (Const a) = fromAlg (Const a)--instance Algebraic a => AlgebraicT ((,) a) where-	type AlgRepT ((,) a) = (,) (AlgRep a)-	toAlgT = first toAlg-	fromAlgT = first fromAlg--instance (Algebraic a, Algebraic b) => Algebraic (a, b) where-	type AlgRep (a, b) = AlgRep (AlgWrap ((,) a) b)-	toAlg = toAlg . AlgWrap-	fromAlg = unAlgWrap . fromAlg--instance (Algebraic 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 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 AlgRep (a, b, c, d) = AlgRep (AlgWrap ((,,,) a b c) d)-	toAlg = toAlg . AlgWrap-	fromAlg = unAlgWrap . fromAlg--instance Algebraic a => AlgebraicT (Either a) where-	type AlgRepT (Either a) = Either (AlgRep a)-	toAlgT = either (Left . toAlg) Right-	fromAlgT = either (Left . fromAlg) Right--instance (Algebraic a, Algebraic b) => Algebraic (Either a b) where-	type AlgRep (Either a b) = AlgRep (AlgWrap (Either a) b)-	toAlg = toAlg . AlgWrap-	fromAlg = unAlgWrap . fromAlg--instance AlgebraicT [] where-	type AlgRepT [] = []-	toAlgT = id-	fromAlgT = id--instance Algebraic k => Algebraic [k] where-	type AlgRep [k] = [AlgRep k]-	toAlg = map toAlg-	fromAlg = map fromAlg--instance Algebraic () where-	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 AlgRep (Maybe a) = AlgRep (AlgWrap Maybe a)-	toAlg = toAlg . AlgWrap-	fromAlg = unAlgWrap . fromAlg--instance Algebraic Bool where-	type AlgRep Bool = AlgRep (Maybe ())-	toAlg b = toAlg $ if b then Just () else Nothing-	fromAlg = maybe False (const True) . fromAlg'-		where	fromAlg' = fromAlg :: AlgRep (Maybe ()) -> Maybe ()--instance Algebraic Int where-	type AlgRep Int = Int-	toAlg = id-	fromAlg = id--instance Algebraic Char where-	type AlgRep Char = Int-	toAlg = ord-	fromAlg = chr--instance Algebraic Float where-	type AlgRep Float = Ordered Float-	toAlg = Ord-	fromAlg = unOrd--instance Algebraic Double where-	type AlgRep Double = Ordered Double-	toAlg = Ord-	fromAlg = unOrd--instance Algebraic Rational where-	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 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 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 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 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;- #-}

@@ -1,28 +0,0 @@-module TrieMap.Applicative(Id(..), (.:), (<.>), on, build) where--import Control.Monad-import Control.Applicative-import Data.Traversable (sequenceA)-import GHC.Exts (build)-import TrieMap.MapTypes--instance Applicative Id where-	pure = return-	(<*>) = ap--instance Monad Id where-	return = Id-	m >>= k = k (unId m)--(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d-(.:) = (.) . (.)--(<.>) :: Functor f => (b -> c) -> (a -> f b) -> (a -> f c)-(<.>) = (.) . (<$>)--on :: (b -> b -> c) -> (a -> b) -> a -> a -> c-(f `on` g) x y = f (g x) (g y)--infixr 9 <.>-infixr 9 .:-infixr 8 `on`

@@ -1,166 +0,0 @@-{-# LANGUAGE FlexibleInstances, UndecidableInstances, KindSignatures, StandaloneDeriving, GeneralizedNewtypeDeriving, IncoherentInstances, TypeOperators, FlexibleContexts, StandaloneDeriving, ExistentialQuantification #-}--module TrieMap.MapTypes where--import Data.Foldable-import Data.Traversable-import Control.Applicative hiding (Const)-import Prelude hiding (foldl, foldr)-import qualified Data.IntMap as IMap--data (f :*: g) a = f a :*: g a deriving (Eq, Ord, Show)-data (f :+: g) a = A (f a) | B (g a) deriving (Eq, Ord, Show)-newtype Const a b = Const {unConst :: a} deriving (Eq, Ord, Show)-newtype Id a = Id {unId :: a} deriving (Eq, Ord, Show)-newtype Fix f = Fix (f (Fix f))-newtype FixMap f t a = FixMap (t (Fix f) (FixMap f t) a)--newtype O f g a = O (f (App g a))-newtype App f a = App {unApp :: f a}--o :: Functor f => f (g a) -> (f `O` g) a-o = O . fmap App--unO :: Functor f => (f `O` g) a -> f (g a)-unO (O x) = fmap unApp x---- | '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-	fmap f (Elem x) = Elem (f x)--instance Foldable Elem where-	foldr f z (Elem a) = a `f` z-	foldl f z (Elem a) = z `f` a--instance Traversable Elem where-	traverse f (Elem x) = Elem <$> f x--infixr 5 `ProdMap`-infixr 5 :+:-infixr 8 :*:-infixr 9 `O`--class Sized a where-	getSize :: a -> Int--instance Sized (Elem a) where-	getSize _ = 1--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 (Functor f, Functor g) => Functor (f :*: g) where-	fmap f (a :*: b) = fmap f a :*: fmap f b--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 (Traversable f, Traversable g) => Traversable (f :*: g) where-	traverse f (a :*: b) = liftA2 (:*:) (traverse f a) (traverse f b)--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 (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 (Traversable f, Traversable g) => Traversable (f :+: g) where-	traverse f (A a) = A <$> traverse f a-	traverse f (B b) = B <$> traverse f b--instance Functor (Const a) where-	fmap f (Const x) = Const x--instance Foldable (Const a) where-	foldr f z _ = z-	foldl f z _ = z--instance Traversable (Const a) where-	traverse f (Const x) = pure (Const x)--instance Functor Id where-	fmap f (Id a) = Id (f a)--instance Foldable Id where-	foldr f z (Id a) = a `f` z-	foldl f z (Id a) = z `f` a--instance Traversable Id where-	traverse f (Id a) = Id <$> f a--class EqT f where-	eq :: Eq a => f a -> f a -> Bool--instance EqT f => Eq (Fix f) where-	Fix x == Fix y = x `eq` y--instance (EqT f, EqT g) => EqT (f :*: g) where-	(a :*: x) `eq` (b :*: y) = a `eq` b && x `eq` y--instance (EqT f, EqT g) => EqT (f :+: g) where-	A a `eq` A b = a `eq` b-	B x `eq` B y = x `eq` y-	_ `eq` _ = False--instance Eq a => EqT (Const a) where-	Const a `eq` Const b = a == b--instance EqT Id where-	Id a `eq` Id b = a == b--instance EqT [] where-	eq = (==)--instance EqT Maybe where-	eq = (==)--instance Eq a => EqT ((,) a) where-	eq = (==)--instance Eq a => EqT (Either a) where-	eq = (==)--instance 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,274 +0,0 @@-{-# LANGUAGE IncoherentInstances, PatternGuards, MultiParamTypeClasses, UndecidableInstances #-}--module TrieMap.RadixTrie where--import Control.Applicative--import Data.Maybe-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 Prelude hiding (foldr)--instance Sized (Edge k m a) where-	getSize (Edge s _ _ _) = s--instance TrieKeyT [] RadixTrie where-	compareKeyT (a:as) (b:bs) = compareKey a b `mappend` compareKeyT as bs-	compareKeyT [] (_:_) = LT-	compareKeyT (_:_) [] = GT-	compareKeyT [] [] = EQ-	emptyT = Radix Nothing-	nullT (Radix m) = isNothing m-	sizeT (Radix m) = getSize m-	getSingleT (Radix m) = m >>= getSingleEdge-	guardNullT (Radix m) = m >>= guardNullEdge >>= return . Radix . Just-	alterLookupT f ks (Radix Nothing) = (Radix . single ks) <$> f Nothing-	alterLookupT f ks (Radix (Just e)) = Radix <$> alterLookupEdge f ks e-	lookupT ks (Radix m) = m >>= lookupEdge ks-	foldWithKeyT f z (Radix m) = foldr (foldEdge f) z m-	mapAppT f (Radix m) = Radix <$> traverse (mapAppEdge f) m-	mapMaybeT f (Radix m) = Radix (m >>= mapMaybeEdge f)-	mapEitherT f (Radix m) = radBoth (maybe (Nothing, Nothing) (mapEitherEdge f) m)-		where	 radBoth (e1, e2) = (Radix e1, Radix e2)-	fromDistAscListT = fromAscListT (\ _ x _ -> x)-	fromAscListT _ [] = Radix Nothing-	fromAscListT f (x:xs) = Radix (Just (groupAscHeads' f x xs))-	fromListT f xs = Radix (groupHeads f xs)-	splitLookupT _ _ (Radix Nothing) = (emptyT, Nothing, emptyT)-	splitLookupT f k (Radix (Just e)) = case splitLookupEdge f k e of-		(eL, ans, eR)	-> (Radix eL, ans, Radix eR)-	isSubmapT (<=) (Radix m1) (Radix m2) = isSubmapAlg (isSubEdge (<=)) m1 m2-	getMinT (Radix m) = fmap (Radix <$>) (m >>= getMinEdge)-	getMaxT (Radix m) = fmap (Radix <$>) (m >>= getMaxEdge)-	updateMinT _ (Radix Nothing) = (False, Radix Nothing)-	updateMinT f (Radix (Just e)) = Radix <$> updateMinEdge f e-	updateMaxT _ (Radix Nothing) = (False, Radix Nothing)-	updateMaxT f (Radix (Just e)) = Radix <$> updateMaxEdge f e-	unionT f (Radix m1) (Radix m2) = Radix (unionMaybe (unionEdge f) m1 m2)-	intersectT f (Radix m1) (Radix m2) = Radix (intersectMaybe (intersectEdge f) m1 m2)-	differenceT f (Radix m1) (Radix m2) = Radix (differenceMaybe (differenceEdge f) m1 m2)--instance TrieKey k m => TrieKey [k] (RadixTrie k m) where-	compareKey = compareKeyT-	emptyAlg = emptyT-	nullAlg = nullT-	getSingleAlg = getSingleT-	guardNullAlg = guardNullT-	sizeAlg = sizeT-	lookupAlg = lookupT-	alterLookupAlg = alterLookupT-	mapAppAlg = mapAppT-	mapMaybeAlg = mapMaybeT-	mapEitherAlg = mapEitherT-	foldWithKeyAlg = foldWithKeyT-	unionMaybeAlg = unionT-	intersectAlg = intersectT-	differenceAlg = differenceT-	getMinAlg = getMinT-	getMaxAlg = getMaxT-	updateMinAlg = updateMinT-	updateMaxAlg = updateMaxT-	isSubmapAlg = isSubmapT-	splitLookupAlg = splitLookupT--single :: (Sized a, TrieKey k m) => [k] -> Maybe a -> MEdge k m a-single ks = fmap (\ v -> Edge (getSize v) ks (Just v) emptyAlg)--edge :: (Sized a, TrieKey k m) => [k] -> Maybe a -> m (Edge k m a) -> Edge k m a-edge ks v ts = Edge (getSize v + getSize ts) ks v ts--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--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--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 :: (Eq k, TrieKey k m) => [k] -> Edge k m a -> Maybe a-lookupEdge ks (Edge _ ls v ts) = procEdge ks ls where-	procEdge (k:ks) (l:ls)-		| k == l	= procEdge ks ls-	procEdge (k:ks) [] = lookupAlg k ts >>= lookupEdge ks-	procEdge [] [] = v-	procEdge _ _ = Nothing--foldEdge :: TrieKey k m => ([k] -> a -> b -> b) -> Edge k m a -> b -> b-foldEdge f (Edge _ ks v ts) z = foldr (f ks) (foldWithKeyAlg (\ l -> foldEdge (\ ls -> f (ks ++ l:ls))) z ts) v--mapAppEdge :: (TrieKey k m, Applicative f, Sized b) => ([k] -> a -> f b) -> Edge k m a -> f (Edge k m b)-mapAppEdge f (Edge _ ks v ts) = edge ks <$> traverse (f ks) v <*> mapAppAlg (\ l -> mapAppEdge (\ ls -> f (ks ++ l:ls))) ts--mapMaybeEdge :: (TrieKey k m, Sized b) => ([k] -> a -> Maybe b) -> Edge k m a -> MEdge k m b-mapMaybeEdge f (Edge _ ks v ts) = -	guardNullEdge (edge ks (v >>= f ks) (mapMaybeAlg (\ l -> mapMaybeEdge (\ ls -> f (ks ++ l:ls))) ts))--mapEitherEdge :: (TrieKey k m, Sized b, Sized c) => ([k] -> a -> (Maybe b, Maybe c)) -> Edge k m a -> -	(MEdge k m b, MEdge k m c)-mapEitherEdge f (Edge _ ks v ts) = guardBoth (edge ks vL tsL, edge ks vR tsR)-	where	(vL, vR) = maybe (Nothing, Nothing) (f ks) v-		ts' = mapEitherAlg (\ l -> mapEitherEdge (\ ls -> f (ks ++ l:ls))) ts-		(tsL, tsR) = mapEitherAlg (\ l -> mapEitherEdge (\ ls -> f (ks ++ l:ls))) ts-		guardBoth (e1, e2) = (guardNullEdge e1, guardNullEdge e2)--groupAscHeads' :: (Eq k, TrieKey k m, Sized a) => ([k] -> a -> a -> a) -> ([k], a) -> [([k], a)] -> Edge k m a-groupAscHeads' f (ks, v) [] = Edge (getSize v) ks (Just v) emptyAlg-groupAscHeads' f x xs = group0 Nothing (x:xs) where-	group0 v0 (([], v):xs) = group0 (Just (maybe v (f [] v) v0)) xs-	group0 (Just v0) [] = Edge (getSize v0) [] (Just v0) emptyAlg-	group0 v0 ((k:ks, v):xs) = group1 Seq.empty k (ks, v) Seq.empty xs where-		group1 ts k vk vs ((l:ls, v):xs)-			| k == l	= group1 ts k vk (vs |> (ls, v)) xs-			| otherwise	= group1 (ts |> (k, groupAscHeads' (f . (k:)) vk (toList vs))) l (ls, v) Seq.empty xs-		group1 ts k v vs []-			| Nothing <- v0, Seq.null ts, Edge s xs vX tsX <- groupAscHeads' (f . (k:)) v (toList vs)-				= Edge s (k:xs) vX tsX-			| otherwise-				= edge [] v0 (fromDistAscListAlg (toList ts ++ [(k, groupAscHeads' (f . (k:)) v (toList vs))]))--groupHeads :: (Eq k, TrieKey k m, Sized a) => ([k] -> a -> a -> a) -> [([k], a)] -> MEdge k m a-groupHeads _ [] = Nothing-groupHeads f xs = guardNullEdge $ edge [] v0 (mapMaybeAlg (\ k (Elem xs) -> groupHeads (f . (k:)) xs) $-		fromListAlg (\ _ (Elem x) (Elem y) -> Elem (x ++ y)) [(k, Elem [(ks, v)]) | (k, ks, v) <- ts])-	where	(v0, ts) = let	proc ([], v) (v0, ts) = (Just (maybe v (f [] v) v0), ts)-				proc (k:ks, v) (v0, ts) = (v0, (k, ks, v):ts)-				in foldr proc (Nothing, []) xs--mapEdge :: (Sized b, TrieKey k m) => ([k] -> a -> b) -> Edge k m a -> Edge k m b-mapEdge f (Edge _ ks v ts) = edge ks (fmap (f ks) v) (mapWithKeyAlg (\ l -> mapEdge (\ ls -> f (ks ++ l:ls))) ts)--splitLookupEdge :: (Sized a, TrieKey k m) => (a -> (Maybe a, Maybe b, Maybe a)) -> [k] -> Edge k m a -> -	(MEdge k m a, Maybe b, MEdge k m a)-splitLookupEdge f ks e@(Edge s ls v ts) = procEdge ks ls where-	procEdge (k:ks) (l:ls) = case compareKey k l of-		LT	-> (Nothing, Nothing, Just e)-		GT	-> (Just e, Nothing, Nothing)-		EQ	-> procEdge ks ls-	procEdge (k:ks) [] = case splitLookupAlg g k ts of-		(tsL, ans, tsR)	-> (guardNullEdge (edge ls v tsL), ans, guardNullEdge (edge ls Nothing tsR))-		where	g = splitLookupEdge f ks -	procEdge [] (l:ls) = (Nothing, Nothing, Just e)-	procEdge [] [] = case v of-		Nothing	-> (Nothing, Nothing, Just e)-		Just v	-> case f v of-			(vL, ans, vR)	-> (single ls vL, ans, guardNullEdge (edge ls vR ts))--isSubEdge :: (TrieKey k m, Sized a, Sized b) => (a -> b -> Bool) -> Edge k m a -> Edge k m b -> Bool-isSubEdge (<=) (Edge sK ks vK tsK) (Edge _ ls vL tsL) = procEdge ks ls where-	procEdge (k:ks) (l:ls)-		| k == l	= procEdge ks ls-	procEdge (k:ks) []-		| Just e' <- lookupAlg k tsL-			= isSubEdge (<=) (Edge sK ks vK tsK) e'-	procEdge [] [] = isSubmapAlg (<=) vK vL && isSubmapAlg (isSubEdge (<=)) tsK tsL--getMinEdge :: (TrieKey k m, Sized a) => Edge k m a -> Maybe (([k], a), MEdge k m a)-getMinEdge (Edge s ks (Just v) ts) = Just ((ks, v), guardNullEdge (Edge (s - getSize v) ks Nothing ts))-getMinEdge (Edge _ ks Nothing ts) = do-	((l, e'), ts') <- getMinAlg ts-	((ls, v), e'') <- getMinEdge e'-	return ((ks ++ l:ls, v), fmap (edge ks Nothing) (maybe (guardNullAlg ts') -		(\ e'' -> Just $ snd $ updateMinAlg (\ _ _ -> (False, Just e'')) ts) e''))--getMaxEdge :: (TrieKey k m, Sized a) => Edge k m a -> Maybe (([k], a), MEdge k m a)-getMaxEdge (Edge _ ks v0 ts)-	| nullAlg ts = maybe Nothing (\ v -> Just ((ks, v), Nothing)) v0-	| otherwise	= do-		((l, e'), ts') <- getMaxAlg ts-		((ls, v), e'') <- getMaxEdge e'-		return ((ks ++ l:ls, v), fmap (edge ks Nothing) (maybe (guardNullAlg ts') -			(\ e'' -> Just $ snd $ updateMaxAlg (\ _ _ -> (False, Just e'')) ts) e''))--updateMinEdge :: (TrieKey k m, Sized a) => ([k] -> a -> (Bool, Maybe a)) -> Edge k m a -> (Bool, MEdge k m a)-updateMinEdge f (Edge _ ks (Just v) ts)-	= fmap (\ v -> guardNullEdge (edge ks v ts)) (f ks v)-updateMinEdge f (Edge _ ks Nothing ts) = fmap (guardNullEdge . edge ks Nothing) (updateMinAlg g ts) where-	g l = updateMinEdge (\ ls -> f (ks ++ l:ls))--updateMaxEdge :: (TrieKey k m, Sized a) => ([k] -> a -> (Bool, Maybe a)) -> Edge k m a -> (Bool, MEdge k m a)-updateMaxEdge f (Edge _ ks (Just v) ts)-	| nullAlg ts = fmap (\ v -> guardNullEdge (edge ks v ts)) (f ks v)-updateMaxEdge f (Edge _ ks v ts) = fmap (guardNullEdge . edge ks v) (updateMinAlg g ts) where-	g l = updateMinEdge (\ ls -> f (ks ++ l:ls))--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 (sK + sL) (take i ks0) Nothing -					(insertAlg k (Edge sK ks vK tsK) $ singletonAlg l (Edge sL ls vL tsL)))-	procEdge _ (k:ks) [] = guardNullEdge $ edge ls0 vL $ alterAlg g k tsL where-		g Nothing = Just (Edge sK ks vK tsK)-		g (Just e) = unionEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge sK ks vK tsK) e-	procEdge _ [] (l:ls) = guardNullEdge $ edge ks0 vK $ alterAlg g l tsK where-		g Nothing = Just (Edge sL ls vL tsL)-		g (Just e) = unionEdge (\ ls' -> f (ks0 ++ l:ls')) e (Edge sL ls vL tsL)-	procEdge _ [] [] = guardNullEdge $ edge ks0 (unionMaybe	(f ks0) vK vL) $-		unionMaybeAlg (\ x -> unionEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL--intersectEdge :: (TrieKey k m, Sized c) => ([k] -> a -> b -> Maybe c) -> Edge k m a -> Edge k m b -> MEdge k m c-intersectEdge f (Edge sK ks0 vK tsK) (Edge sL ls0 vL tsL) = procEdge ks0 ls0 where-	procEdge (k:ks) (l:ls)-		| k == l	= procEdge ks ls-		| otherwise	= Nothing-	procEdge (k:ks) [] = do-		e' <- lookupAlg k tsL-		Edge 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 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)--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 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

@@ -1,47 +0,0 @@-{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances #-}--module TrieMap.Reflection where---- import TrieMap.Fixpoint-import TrieMap.MapTypes-import TrieMap.TrieAlgebraic-import TrieMap.Algebraic-import TrieMap.Applicative-import TrieMap.RadixTrie()-import qualified TrieMap.TrieAlgebraic as TA--instance Algebraic v => Algebraic (Elem v) where-	type AlgRep (Elem v) = AlgRep v-	toAlg (Elem v) = toAlg v-	fromAlg v = Elem (fromAlg v)---- 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 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 (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,898 +0,0 @@-{-# 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-import Data.Sequence (Seq)-import Data.Maybe-import Data.Monoid-import Data.IntMap (IntMap)-import Data.Map (Map)-import qualified Data.Sequence as Seq-import qualified Data.IntMap as IMap-import qualified Data.Map as Map--import Control.Monad-import Control.Applicative hiding (Alternative(..), Const(..))-import GHC.Exts (build)--import TrieMap.Applicative--- import TrieMap.Algebraic (Ordered (..))-import TrieMap.MapTypes-import Prelude hiding (foldr, foldl, all, any)--newtype Ordered k = Ord {unOrd :: k} deriving (Eq, Ord)--instance Show k => Show (Ordered k) where-	show = show . unOrd-	showsPrec x = showsPrec x . unOrd--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 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 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-		| nullAlg m	= Nothing-		| otherwise	= Just m-	getSingleAlg m = do-		((k, v), m') <- getMinAlg m-		guard (nullAlg m')-		return (k, v)-	fromListAlg f = foldr (\ (k, v) -> alterAlg (Just . maybe v (f k v)) k) emptyAlg-	fromAscListAlg _ [] = emptyAlg-	fromAscListAlg f ((k, v):xs) = fromDistAscListAlg (distinct k v xs) where-		distinct k v ((k', 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 = 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 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)--singletonAlg :: (Sized v, TrieKey k m) => k -> v -> m v-singletonAlg k v = insertAlg k v emptyAlg--mapWithKeyAlg :: (Sized v, Sized w, TrieKey k m) => (k -> v -> w) -> m v -> m w-mapWithKeyAlg f m = unId (mapAppAlg (\ k v -> Id (f k v)) m)--mapWithKeyT :: (Sized v, Sized w, TrieKeyT f t, TrieKey k m) => (f k -> v -> w) -> t k m v -> t k m w-mapWithKeyT f m = unId (mapAppT (\ k v -> Id (f k v)) m)--mapAlg :: (Sized v, Sized w, TrieKey k m) => (v -> w) -> m v -> m w-mapAlg = mapWithKeyAlg . const--mapT :: (Sized v, Sized w, TrieKeyT f t, TrieKey k m) => (v -> w) -> t k m v -> t k m w-mapT = mapWithKeyT . const---- mapMaybeWithKeyAlg :: TrieKey k m => (k -> v -> Maybe w) -> m v -> m w--- mapMaybeWithKeyAlg f m = unId (mapAppMaybeAlg (\ k v -> Id (f k v)) m)--insertAlg :: (Sized v, TrieKey k m) => k -> v -> m v -> m v-insertAlg k v = alterAlg (const (Just v)) k--insertT :: (Sized v, TrieKey k m, TrieKeyT f t) => f k -> v -> t k m v -> t k m v-insertT k v = alterT (const (Just v)) k--alterAlg :: (Sized v, TrieKey k m) => (Maybe v -> Maybe v) -> k -> m v -> m v-alterAlg f k = snd . alterLookupAlg (\ x -> ((), f x)) k--alterT :: (Sized v, TrieKey k m, TrieKeyT f t) => (Maybe v -> Maybe v) -> f k -> t k m v -> t k m v-alterT f k = snd . alterLookupT (\ x -> ((), f x)) k---- alterLookupAlg :: TrieKey k m => (Maybe a -> (b, Maybe a)) -> k -> m a -> (b, m a)--- alterLookupAlg f = unId .: alterAppAlg (Id . f)--foldrAlg :: (Sized a, TrieKey k m) => (a -> b -> b) -> b -> m a -> b-foldrAlg = foldWithKeyAlg . const--unionMaybe :: (a -> a -> Maybe a) -> Maybe a -> Maybe a -> Maybe a-unionMaybe f (Just x) (Just y) = f x y-unionMaybe _ Nothing y = y-unionMaybe _ x Nothing = x--intersectMaybe :: (a -> b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c-intersectMaybe f (Just x) (Just y) = f x y-intersectMaybe _ _ _ = Nothing--differenceMaybe :: (a -> b -> Maybe a) -> Maybe a -> Maybe b -> Maybe a-differenceMaybe _ Nothing _ = Nothing-differenceMaybe _ x Nothing = x-differenceMaybe f (Just x) (Just y) = f x y--filterLeft :: a -> Either b c -> Maybe b-filterLeft _ (Left x) = Just x-filterLeft _ _ = Nothing--filterRight :: a -> Either b c -> Maybe c-filterRight _ (Right x) = Just x-filterRight _ _ = Nothing--{-# INLINE assocsAlg #-}-assocsAlg :: (TrieKey k m) => m a -> [(k, a)]-assocsAlg m = build (\ c n -> foldWithKeyAlg (\ k v xs -> (k,v) `c` xs) n m)--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 splitLookupT f k2 m' of-			(mL, ans, mR)	-> (guardNullT mL, ans, guardNullT mR)--instance (Eq (f1 k), Eq (f2 k), TrieKey k m, TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKey ((f1 :*: f2) k) (ProdMap t1 t2 k m) where-	compareKey = compareKeyT-	emptyAlg = emptyT-	nullAlg = nullT-	getSingleAlg = getSingleT-	guardNullAlg = guardNullT-	sizeAlg = sizeT-	lookupAlg = lookupT-	alterLookupAlg = alterLookupT-	mapAppAlg = mapAppT-	mapMaybeAlg = mapMaybeT-	mapEitherAlg = mapEitherT-	foldWithKeyAlg = foldWithKeyT-	unionMaybeAlg = unionT-	intersectAlg = intersectT-	differenceAlg = differenceT-	getMinAlg = getMinT-	getMaxAlg = getMaxT-	updateMinAlg = updateMinT-	updateMaxAlg = updateMaxT-	isSubmapAlg = isSubmapT-	splitLookupAlg = splitLookupT--breakFst :: (f1 k -> f1 k -> Bool) -> [((f1 :*: f2) k, v)] -> [(f1 k, [(f2 k, v)])]-breakFst _ [] = []-breakFst eq (((k1 :*: k2), x):xs) = breakFst' k1 (Seq.singleton (k2, x)) xs where-	breakFst' k xs (((k' :*: k2), x):xss)-		| k `eq` k'	= breakFst' k ((Seq.|>) xs (k2, x)) xss-		| otherwise	= (k, toList xs):breakFst' k' (Seq.singleton (k2, x)) xss-	breakFst' k xs [] = [(k, toList xs)]--instance (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-	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-	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-	splitLookupT f (Left k) (CUMap m1 m2) = case splitLookupAlg f k m1 of-		(m1L, ans, m1R)	-> (CUMap m1L emptyAlg, ans, CUMap m1R m2)-	splitLookupT f (Right k) (CUMap m1 m2) = case splitLookupAlg f k m2 of-		(m2L, ans, m2R)	-> (CUMap m1 m2L, ans, CUMap emptyAlg m2R)-	getMinT (CUMap m1 m2) = case (getMinAlg m1, getMinAlg m2) of-		(Just ((k, v), m1'), _)	-> Just ((Left k, v), CUMap m1' m2)-		(_, Just ((k, v), m2'))	-> Just ((Right k, v), CUMap m1 m2')-		_			-> Nothing-	getMaxT (CUMap m1 m2) = case (getMaxAlg m1, getMaxAlg m2) of-		(_, Just ((k, v), m2'))	-> Just ((Right k, v), CUMap m1 m2')-		(Just ((k, v), m1'), _)	-> Just ((Left k, v), CUMap m1' m2)-		_			-> Nothing-	updateMinT f (CUMap m1 m2)-		| nullAlg m1	= CUMap m1 <$> updateMinAlg (f . Right) m2-		| otherwise	= (`CUMap` m2) <$> updateMinAlg (f . Left) m1-	updateMaxT f (CUMap m1 m2)-		| nullAlg m2	= (`CUMap` m2) <$> updateMaxAlg (f . Left) m1-		| otherwise	= CUMap m1 <$> updateMaxAlg (f . Right) m2-	fromListT f xs = CUMap (fromListAlg (f . Left) ys) (fromListAlg (f . Right) zs)-		where	(ys, zs) = partitionEithers (map pullEither' xs)-	fromAscListT f xs = CUMap (fromAscListAlg (f . Left) ys) (fromAscListAlg (f . Right) zs)-		where	(ys, zs) = partitionEithers (map pullEither' xs)-	fromDistAscListT xs = CUMap (fromDistAscListAlg ys) (fromDistAscListAlg zs) -		where	(ys, zs) = partitionEithers (map pullEither' xs)--instance (TrieKey k1 m1, TrieKey k2 m2) => TrieKey (Either k1 k2) (CUnionMap m1 k2 m2) where-	{-# SPECIALIZE instance TrieKey k m => TrieKey (Either () k) (CUnionMap Maybe k m) #-}-	compareKey = compareKeyT-	emptyAlg = emptyT-	nullAlg = nullT-	getSingleAlg = getSingleT-	guardNullAlg = guardNullT-	sizeAlg = sizeT-	lookupAlg = lookupT-	alterLookupAlg = alterLookupT-	mapAppAlg = mapAppT-	mapMaybeAlg = mapMaybeT-	mapEitherAlg = mapEitherT-	foldWithKeyAlg = foldWithKeyT-	unionMaybeAlg = unionT-	intersectAlg = intersectT-	differenceAlg = differenceT-	getMinAlg = getMinT-	getMaxAlg = getMaxT-	updateMinAlg = updateMinT-	updateMaxAlg = updateMaxT-	isSubmapAlg = isSubmapT-	splitLookupAlg = splitLookupT--partitionEithers' :: [Either a b] -> ([a], [b])-partitionEithers' = foldr part ([], []) where-	part (Left x) (xs, ys) = (x:xs, ys)-	part (Right y) (xs, ys) = (xs, y:ys)--pullEither :: ((f1 :+: f2) k, v) -> Either (f1 k, v) (f2 k, v)-pullEither (A k, v) = Left (k, v)-pullEither (B k, v) = Right (k, v)--pullEither' :: (Either k1 k2, v) -> Either (k1, v) (k2, v)-pullEither' (Left k, v) = Left (k, v)-pullEither' (Right k, v) = Right (k, v)--instance TrieKey k m => TrieKeyT (Const k) (ConstMap m) where-	compareKeyT (Const a) (Const b) = compareKey a b-	emptyT = ConstMap emptyAlg-	nullT (ConstMap m) = nullAlg m-	sizeT (ConstMap m) = sizeAlg m-	getSingleT (ConstMap m) = do-		(k, v) <- getSingleAlg m-		return (Const k, v)-	lookupT (Const k) (ConstMap m) = lookupAlg k m-	alterLookupT f (Const k) (ConstMap m) = ConstMap <$> alterLookupAlg f k m-	foldWithKeyT f z (ConstMap m) = foldWithKeyAlg (f . Const) z m-	mapAppT f (ConstMap m) = ConstMap <$> mapAppAlg (f . Const) m-	mapMaybeT f (ConstMap m) = ConstMap (mapMaybeAlg (f . Const) m)-	mapEitherT f (ConstMap m) = case mapEitherAlg (f . Const) m of-		(mL, mR) -> (ConstMap mL, ConstMap mR)-	unionT f (ConstMap m1) (ConstMap m2) = ConstMap (unionMaybeAlg (f . Const) m1 m2)-	intersectT f (ConstMap m1) (ConstMap m2) = ConstMap (intersectAlg (f . Const) m1 m2)-	differenceT f (ConstMap m1) (ConstMap m2) = ConstMap (differenceAlg (f . Const) m1 m2)-	fromDistAscListT xs = ConstMap (fromDistAscListAlg [(k, v) | (Const k, v) <- xs])-	fromAscListT f xs = ConstMap (fromAscListAlg (f . Const) [(k, v) | (Const k, v) <- xs])-	fromListT f xs = ConstMap (fromListAlg (f . Const) [(k, v) | (Const k, v) <- xs])-	getMinT (ConstMap m) = do-		(~(k, v), m') <- getMinAlg m-		return ((Const k, v), ConstMap m')-	getMaxT (ConstMap m) = do-		(~(k, v), m') <- getMaxAlg m-		return ((Const k, v), ConstMap m')-	updateMinT f (ConstMap m) = ConstMap <$> updateMinAlg (f . Const) m-	updateMaxT f (ConstMap m) = ConstMap <$> updateMaxAlg (f . Const) m-	isSubmapT (<=) (ConstMap m1) (ConstMap m2) = isSubmapAlg (<=) m1 m2-	splitLookupT f (Const k) (ConstMap m) = case splitLookupAlg f k m of-		(mL, ans, mR) -> (ConstMap mL, ans, ConstMap mR)--instance (TrieKey k m, TrieKey k' m') => TrieKey (Const k k') (ConstMap m k' m') where-	compareKey = compareKeyT-	emptyAlg = emptyT-	nullAlg = nullT-	getSingleAlg = getSingleT-	guardNullAlg = guardNullT-	sizeAlg = sizeT-	lookupAlg = lookupT-	alterLookupAlg = alterLookupT-	mapAppAlg = mapAppT-	mapMaybeAlg = mapMaybeT-	mapEitherAlg = mapEitherT-	foldWithKeyAlg = foldWithKeyT-	unionMaybeAlg = unionT-	intersectAlg = intersectT-	differenceAlg = differenceT-	getMinAlg = getMinT-	getMaxAlg = getMaxT-	updateMinAlg = updateMinT-	updateMaxAlg = updateMaxT-	isSubmapAlg = isSubmapT-	splitLookupAlg = splitLookupT--instance TrieKeyT Id IdMap where-	compareKeyT (Id a) (Id b) = compareKey a b-	emptyT = IdMap emptyAlg-	nullT (IdMap m) = nullAlg m-	sizeT (IdMap m) = sizeAlg m-	getSingleT (IdMap m) = do-		(k, v) <- getSingleAlg m-		return (Id k, v)-	lookupT (Id k) (IdMap m) = lookupAlg k m-	alterLookupT f (Id k) (IdMap m) = IdMap <$> alterLookupAlg f k m-	foldWithKeyT f z (IdMap m) = foldWithKeyAlg (f . Id) z m-	mapAppT f (IdMap m) = IdMap <$> mapAppAlg (f . Id) m-	mapMaybeT f (IdMap m) = IdMap (mapMaybeAlg (f . Id) m)-	mapEitherT f (IdMap m) = case mapEitherAlg (f . Id) m of-		(mL, mR) -> (IdMap mL, IdMap mR)-	unionT f (IdMap m1) (IdMap m2) = IdMap (unionMaybeAlg (f . Id) m1 m2)-	intersectT f (IdMap m1) (IdMap m2) = IdMap (intersectAlg (f . Id) m1 m2)-	differenceT f (IdMap m1) (IdMap m2) = IdMap (differenceAlg (f . Id) m1 m2)-	fromDistAscListT xs = IdMap (fromDistAscListAlg [(k, v) | (Id k, v) <- xs])-	fromAscListT f xs = IdMap (fromAscListAlg (f . Id) [(k, v) | (Id k, v) <- xs])-	fromListT f xs = IdMap (fromListAlg (f . Id) [(k, v) | (Id k, v) <- xs])-	getMinT (IdMap m) = do-		(~(k, v), m') <- getMinAlg m-		return ((Id k, v), IdMap m')-	getMaxT (IdMap m) = do-		(~(k, v), m') <- getMaxAlg m-		return ((Id k, v), IdMap m')-	updateMinT f (IdMap m) = IdMap <$> updateMinAlg (f . Id) m-	updateMaxT f (IdMap m) = IdMap <$> updateMaxAlg (f . Id) m-	isSubmapT (<=) (IdMap m1) (IdMap m2) = isSubmapAlg (<=) m1 m2-	splitLookupT f (Id k) (IdMap m) = case splitLookupAlg f k m of-		(mL, ans, mR) -> (IdMap mL, ans, IdMap mR)--instance TrieKey k m => TrieKey (Id k) (IdMap k m) where-	compareKey = compareKeyT-	emptyAlg = emptyT-	nullAlg = nullT-	getSingleAlg = getSingleT-	guardNullAlg = guardNullT-	sizeAlg = sizeT-	lookupAlg = lookupT-	alterLookupAlg = alterLookupT-	mapAppAlg = mapAppT-	mapMaybeAlg = mapMaybeT-	mapEitherAlg = mapEitherT-	foldWithKeyAlg = foldWithKeyT-	unionMaybeAlg = unionT-	intersectAlg = intersectT-	differenceAlg = differenceT-	getMinAlg = getMinT-	getMaxAlg = getMaxT-	updateMinAlg = updateMinT-	updateMaxAlg = updateMaxT-	isSubmapAlg = isSubmapT-	splitLookupAlg = splitLookupT---- instance (Sized k, TrieKey k m) => TrieKey (SizeElem k) (SizedMap k m) where--- 	compareKey (SElem a) (SElem b) = compareKey a b--- 	emptyAlg = SizedMap emptyAlg--- 	nullAlg (SizedMap m) = nullAlg m--- 	sizeAlg (SizedMap m) = sizeAlg m--- 	getSingleAlg (SizedMap m) = do--- 		(k, v) <- getSingleAlg m--- 		return (SElem k, v)--- 	lookupAlg (SElem k) (SizedMap m) = lookupAlg k m--- 	alterLookupAlg f (SElem k) (SizedMap m) = SizedMap <$> alterLookupAlg f k m--- 	foldWithKeyAlg f z (SizedMap m) = foldWithKeyAlg (f . SElem) z m--- 	mapAppAlg f (SizedMap m) = SizedMap <$> mapAppAlg (f . SElem) m--- 	mapMaybeAlg f (SizedMap m) = SizedMap (mapMaybeAlg (f . SElem) m)--- 	mapEitherAlg f (SizedMap m) = case mapEitherAlg (f . SElem) m of--- 		(mL, mR) -> (SizedMap mL, SizedMap mR)--- 	unionMaybeAlg f (SizedMap m1) (SizedMap m2) = SizedMap (unionMaybeAlg (f . SElem) m1 m2)--- 	intersectAlg f (SizedMap m1) (SizedMap m2) = SizedMap (intersectAlg (f . SElem) m1 m2)--- 	differenceAlg f (SizedMap m1) (SizedMap m2) = SizedMap (differenceAlg (f . SElem) m1 m2)--- 	fromDistAscListAlg xs = SizedMap (fromDistAscListAlg [(k, v) | (SElem k, v) <- xs])--- 	fromAscListAlg f xs = SizedMap (fromAscListAlg (f . SElem) [(k, v) | (SElem k, v) <- xs])--- 	fromListAlg f xs = SizedMap (fromListAlg (f . SElem) [(k, v) | (SElem k, v) <- xs])--- 	getMinAlg (SizedMap m) = do--- 		(~(k, v), m') <- getMinAlg m--- 		return ((SElem k, v), SizedMap m')--- 	getMaxAlg (SizedMap m) = do--- 		(~(k, v), m') <- getMaxAlg m--- 		return ((SElem k, v), SizedMap m')--- 	updateMinAlg f (SizedMap m) = SizedMap <$> updateMinAlg (f . SElem) m--- 	updateMaxAlg f (SizedMap m) = SizedMap <$> updateMaxAlg (f . SElem) m--- 	isSubmapAlg (<=) (SizedMap m1) (SizedMap m2) = isSubmapAlg (<=) m1 m2--- 	splitLookupAlg f (SElem k) (SizedMap m) = case splitLookupAlg f k m of--- 		(mL, ans, mR) -> (SizedMap mL, ans, SizedMap mR)--instance TrieKey Int IntMap where-	compareKey = compare-	emptyAlg = IMap.empty-	nullAlg = IMap.null-	getSingleAlg m-		| IMap.size m == 1, [(k, v)] <- IMap.toList m-			= Just (k, v)-	getSingleAlg _ = Nothing-	lookupAlg = IMap.lookup-	alterLookupAlg f k m = fmap (\ v' -> IMap.alter (const v') k m) (f x)-		where x = IMap.lookup k m-	foldWithKeyAlg = IMap.foldWithKey-	mapAppAlg = sequenceA .: IMap.mapWithKey-	mapMaybeAlg = IMap.mapMaybeWithKey-	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-		g k _ (Right v) = Right v-	intersectAlg f m1 m2 = IMap.mapMaybe (either (const Nothing) Just) $ IMap.intersectionWithKey g (fmap Left m1) m2 where-		g k (Left x) = maybe (Left x) Right . f k x-		g _ (Right x) = const (Right x)-	differenceAlg = IMap.differenceWithKey-	fromListAlg = IMap.fromListWithKey-	fromAscListAlg = IMap.fromAscListWithKey-	fromDistAscListAlg = IMap.fromDistinctAscList-	getMinAlg = IMap.minViewWithKey-	getMaxAlg = IMap.maxViewWithKey-	updateMinAlg f m = case IMap.minViewWithKey m of-		Just ((k, v), m')	-> let (ans, v') = f k v in (ans, maybe m' (\ v' -> IMap.updateMin (const v') m) v')-		_			-> (False, m)-	updateMaxAlg f m = case IMap.maxViewWithKey m of-		Just ((k, v), m')	-> let (ans, v') = f k v in (ans, maybe m' (\ v' -> IMap.updateMax (const v') m) v')-		_			-> (False, m)-	isSubmapAlg = IMap.isSubmapOfBy-	splitLookupAlg f k m = case IMap.splitLookup k m of-		(mL, Nothing, mR)	-> (mL, Nothing, mR)-		(mL, Just v, mR) -> case f v of-			(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-	getSingleAlg m-		| Map.size m == 1, (k, v) <- Map.findMin m-			= Just (Ord k, v)-	lookupAlg = Map.lookup . unOrd-	alterLookupAlg f (Ord k) m = fmap (\ v -> Map.alter (const v) k m) (f x)-		where x = Map.lookup k m-	foldWithKeyAlg f = Map.foldWithKey (f . Ord)-	mapAppAlg f = sequenceA . Map.mapWithKey (f . Ord)- 	mapMaybeAlg f = Map.mapMaybeWithKey (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-		g k _ (Right v) = Right v-	intersectAlg f = Map.mapMaybe id .: Map.intersectionWithKey (f . Ord)-	differenceAlg f = Map.differenceWithKey (f . Ord)-	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-				return ((Ord k, v), m')-	getMaxAlg m = do	(~(k, v), m') <- Map.maxViewWithKey m-				return ((Ord k, v), m')-	updateMinAlg f m-		| Map.null m	= (False, m)-		| otherwise	= case Map.findMin m of-			(k, v)	-> let (ans, v') = f (Ord k) v in (ans, Map.updateMin (const v') m)-	updateMaxAlg f m-		| Map.null m	= (False, m)-		| otherwise	= case Map.findMin m of-			(k, v)	-> let (ans, v') = f (Ord k) v in (ans, Map.updateMax (const v') m)-	isSubmapAlg = Map.isSubmapOfBy-	splitLookupAlg f (Ord k) m = case Map.splitLookup k m of-		(mL, Nothing, mR)	-> (mL, Nothing, mR)-		(mL, Just v, mR) -> case f v of-			(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-	getSingleAlg = fmap ((,) ())-	lookupAlg _ = id-	alterLookupAlg f _ = f-	foldWithKeyAlg f = foldr (f ())-	mapAppAlg f = traverse (f ())-	mapMaybeAlg f = (>>= f ())-	mapEitherAlg f = maybe (Nothing, Nothing) (f ())-	unionMaybeAlg f = unionMaybe (f ())-	intersectAlg f = intersectMaybe (f ())-	differenceAlg f = differenceMaybe (f ())-	fromListAlg _ [] = Nothing-	fromListAlg f ((_, v):xs) = Just (foldr (f () . snd) v xs)-	fromAscListAlg = fromListAlg-	fromDistAscListAlg = fmap snd . listToMaybe-	getMinAlg = fmap g where-		g v = (((), v), Nothing)-	getMaxAlg = fmap g where-		g v = (((), v), Nothing)-	updateMinAlg f = maybe (False, Nothing) (f ())-	updateMaxAlg f = maybe (False, Nothing) (f ())-	isSubmapAlg _ Nothing _ = True-	isSubmapAlg _ _ Nothing = False-	isSubmapAlg (<=) (Just x) (Just y) = x <= y-	splitLookupAlg f _ = maybe (Nothing, Nothing, Nothing) f--{-# 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