packages feed

TrieMap 0.5.1 → 0.5.2

raw patch · 49 files changed

+2697/−1213 lines, 49 filesdep +arraydep +bytestringdep +template-haskell

Dependencies added: array, bytestring, template-haskell

Files

Data/TrieMap.hs view
@@ -16,7 +16,7 @@ 	findWithDefault, 	-- * Construction 	empty,-	showMap,+-- 	showMap, 	singleton, 	-- ** Insertion 	insert,@@ -87,6 +87,16 @@ 	-- * Submap 	isSubmapOf, 	isSubmapOfBy,+	-- * Indexed+	predecessor,+	lookupWithIndex,+	successor,+	neighborhood,+	lookupIndex,+	predecessorAt,+	lookupAt,+	successorAt,+	neighborhoodAt,	 	-- * Min/Max 	findMin, 	findMax,@@ -108,9 +118,12 @@ import Data.TrieMap.Class.Instances() import Data.TrieMap.TrieKey import Data.TrieMap.Applicative+import Data.TrieMap.Rep+import Data.TrieMap.Sized  import Control.Applicative hiding (empty) import Control.Arrow+import Control.Monad import Data.Maybe hiding (mapMaybe) import Data.Monoid(First(..), Last(..)) -- import Data.Foldable@@ -143,7 +156,7 @@ null (TMap m) = nullM m  lookup :: TKey k => k -> TMap k a -> Maybe a-lookup k (TMap m) = unK0 <$> lookupM (toRep k) m+lookup k (TMap m) = getElem <$> lookupM (toRep k) m  findWithDefault :: TKey k => a -> k -> TMap k a -> a findWithDefault a = fromMaybe a .: lookup@@ -152,8 +165,35 @@ 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)+alter f k (TMap m) = TMap (alterM elemSize (fmap Elem . f . fmap getElem) (toRep k) m) +-- | Projects information out of an individual association pair, over all alternatives in the map.+-- For example, +-- +-- > minViewWithKey == getFirst (extract (\ k a -> return ((k, a), Nothing)))+-- > updateMaxWithKey f m == maybe m snd (getLast (extract (\ k a -> return ((), f k a)) m))+-- +-- In addition,+-- +-- > getFirst (extract (\ k a -> if p k a then return ((k, a), Nothing) else mzero) m)+-- +-- finds and removes the first association pair satisfying the predicate |p|.++extract :: (TKey k, MonadPlus m) => (k -> a -> m (x, Maybe a)) -> TMap k a -> m (x, TMap k a)+extract f m = unwrapMonad (extractA (WrapMonad .: f) m)++-- | Generalization of 'extract' for 'Alternative' functors.+extractA :: (TKey k, Alternative f) => (k -> a -> f (x, Maybe a)) -> TMap k a -> f (x, TMap k a)+extractA f (TMap m) = second TMap <$> extractM elemSize (\ k (Elem a) -> second (fmap Elem) <$> f (fromRep k) a) m++-- | Like 'extract', but does not modify the map.+about :: (TKey k, MonadPlus m) => (k -> a -> m x) -> TMap k a -> m x+about f = unwrapMonad . aboutA (WrapMonad .: f)++-- | Generalization of 'about' for 'Alternative' functors.+aboutA :: (TKey k, Alternative f) => (k -> a -> f x) -> TMap k a -> f x+aboutA f = fst <.> extractA (\ k a -> flip (,) Nothing <$> f k a)+ insert :: TKey k => k -> a -> TMap k a -> TMap k a insert = insertWith const @@ -183,20 +223,20 @@ 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+foldWithKey f z (TMap m) = foldWithKeyM (\ k (Elem 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+foldlWithKey f z (TMap m) = foldlWithKeyM (\ k z (Elem 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+traverseWithKey f (TMap m) = TMap <$> traverseWithKeyM elemSize (\ k (Elem a) -> Elem <$> 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)+mapWithKey f (TMap m) = TMap (mapWithKeyM elemSize (\ k (Elem a) -> Elem (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]@@ -220,8 +260,8 @@ 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+unionMaybeWithKey f (TMap m1) (TMap m2) = TMap (unionM elemSize f' m1 m2) where+	f' k (Elem a) (Elem b) = Elem <$> f (fromRep k) a b  symmetricDifference :: TKey k => TMap k a -> TMap k a -> TMap k a symmetricDifference = unionMaybeWith (\ _ _ -> Nothing)@@ -239,8 +279,8 @@ 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+intersectionMaybeWithKey f (TMap m1) (TMap m2) = TMap (isectM elemSize f' m1 m2) where+	f' k (Elem a) (Elem b) = Elem <$> f (fromRep k) a b  difference, (\\) :: TKey k => TMap k a -> TMap k b -> TMap k a difference = differenceWith (\ x _ -> Nothing)@@ -251,8 +291,8 @@ 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+differenceWithKey f (TMap m1) (TMap m2) = TMap (diffM elemSize f' m1 m2) where+	f' k (Elem a) (Elem b) = Elem <$> f (fromRep k) a b  minView, maxView :: TKey k => TMap k a -> Maybe (a, TMap k a) minView m = first snd <$> minViewWithKey m@@ -271,20 +311,16 @@ 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)+updateMinWithKey f m = maybe m snd (getFirst (extract (\ k a -> return ((), f k a)) m))+updateMaxWithKey f m = maybe m snd (getLast (extract (\ k a -> return ((), f 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')+minViewWithKey = getFirst . extract (\ k a -> return ((k, a), Nothing))+maxViewWithKey = getLast . extract (\ k a -> return ((k, a), Nothing))  elems :: TKey k => TMap k a -> [a] elems = fmap snd . assocs@@ -299,18 +335,18 @@ 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+mapEitherWithKey f (TMap m) = case mapEitherM elemSize elemSize 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))+	where	f' k (Elem a) = case f (fromRep k) a of+			Left b	-> (Just (Elem b), Nothing)+			Right c	-> (Nothing, Just (Elem 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)+mapMaybeWithKey f (TMap m) = TMap (snd (mapEitherM elemSize elemSize f' m)) where+	f' k (Elem a) = (Nothing, Elem <$> f (fromRep k) a)  partition :: TKey k => (a -> Bool) -> TMap k a -> (TMap k a, TMap k a) partition = partitionWithKey . const@@ -329,16 +365,16 @@ 	(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+splitLookup k (TMap m) = case splitLookupM elemSize f (toRep k) m of 	(mL, x, mR) -> (TMap mL, x, TMap mR) -	where	f (K0 x) = (Nothing, Just x, Nothing)+	where	f (Elem 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+	Elem a <<= Elem b = a <= b  fromList, fromAscList :: TKey k => [(k, a)] -> TMap k a fromList = fromListWith const@@ -349,14 +385,14 @@ 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])+fromListWithKey f xs = TMap (fromListM elemSize (\ k (Elem a) (Elem b) -> Elem (f (fromRep k) a b)) [(toRep k, Elem a) | (k, a) <- xs])+fromAscListWithKey f xs = TMap (fromAscListM elemSize (\ k (Elem a) (Elem b) -> Elem (f (fromRep k) a b)) [(toRep k, Elem a) | (k, a) <- xs])  fromDistinctAscList :: TKey k => [(k, a)] -> TMap k a-fromDistinctAscList xs = TMap (fromDistAscListM sizeK0 [(toRep k, K0 a) | (k, a) <- xs])+fromDistinctAscList xs = TMap (fromDistAscListM elemSize [(toRep k, Elem a) | (k, a) <- xs])  size :: TKey k => TMap k a -> Int-size (TMap m) = sizeM sizeK0 m+size (TMap m) = sizeM elemSize m  member :: TKey k => k -> TMap k a -> Bool member = isJust .: lookup@@ -364,5 +400,48 @@ notMember :: TKey k => k -> TMap k a -> Bool notMember = not .: member -showMap :: (TKey k, Show (TrieMap (Rep k) (K0 a) (Rep k))) => TMap k a -> String-showMap (TMap m) = show m+-- showMap :: (TKey k, Show (TrieMap (Rep k) (Elem a) (Rep k))) => TMap k a -> String+-- showMap (TMap m) = show m++-- | @'predecessor' k a@ returns the index, key, and value of the immediate predecessor of @k@ in the map.  +-- The predecessor is the element with the largest key @< k@.+predecessor :: TKey k => k -> TMap k a -> Maybe (Int, k, a)+predecessor k m = fst3 (neighborhood k m)++lookupIndex :: TKey k => k -> TMap k a -> Maybe Int+lookupIndex k m = fst3 <$> lookupWithIndex k m ++fst3 (a, b, c) = a+snd3 (a, b, c) = b+thd3 (a, b, c) = c++findIndex :: TKey k => k -> TMap k a -> Int+findIndex k m = fromMaybe (error "element is not in the map") (lookupIndex k m)++lookupWithIndex :: TKey k => k -> TMap k a -> Maybe (Int, k, a)+lookupWithIndex k m = snd3 (neighborhood k m)++successor :: TKey k => k -> TMap k a -> Maybe (Int, k, a)+successor k m = thd3 (neighborhood k m)++neighborhood :: TKey k => k -> TMap k a -> (Maybe (Int, k, a), Maybe (Int, k, a), Maybe (Int, k, a))+neighborhood k (TMap m) = case lookupIxM elemSize (toRep k) m of+		(pr, x, su) -> (fix <$> getLast pr, fix <$> x, fix <$> getFirst su)+	where	fix (Asc i k (Elem a)) = (i, fromRep k, a)++predecessorAt :: TKey k => Int -> TMap k a -> Maybe (Int, k, a)+predecessorAt k m = fst3 (neighborhoodAt k m)++lookupAt :: TKey k => Int -> TMap k a -> Maybe (Int, k, a)+lookupAt k m = snd3 (neighborhoodAt k m)++successorAt :: TKey k => Int -> TMap k a -> Maybe (Int, k, a)+successorAt k m = thd3 (neighborhoodAt k m)++neighborhoodAt :: TKey k => Int -> TMap k a -> (Maybe (Int, k, a), Maybe (Int, k, a), Maybe (Int, k, a))+neighborhoodAt i (TMap m) = case assocAtM elemSize i m of+		(pr, x, su) -> (fix <$> getLast pr, fix <$> x, fix <$> getFirst su)+	where	fix (Asc i k (Elem a)) = (i, fromRep k, a)++keysSet :: TKey k => TMap k a -> TSet k+keysSet = TSet . map (const ())
Data/TrieMap/Applicative.hs view
@@ -3,17 +3,33 @@ module Data.TrieMap.Applicative where  import Control.Applicative+import Control.Arrow import Control.Monad -import Data.Monoid+import Data.Monoid hiding (Dual)  newtype Id a = Id {unId :: a}+newtype WM w m a = WM {runWM :: m (w, a)}  deriving instance Functor First deriving instance Functor Last deriving instance Monad First deriving instance Monad Last +instance Functor m => Functor (WM w m) where+	fmap f (WM x) = WM (fmap (second f) x)++instance (Applicative m, Monoid w) => Applicative (WM w m) where+	pure x = WM (pure (mempty, x))+	WM f <*> WM x = WM (fmap (\ (fW, ff) (xW, xx) -> (fW `mappend` xW, ff xx)) f <*> x)++instance (Alternative m, Monoid w) => Alternative (WM w m) where+	empty = WM empty+	WM a <|> WM b = WM (a <|> b)++write :: (Functor m, Monoid w) => w -> WM w m a -> WM w m a+write w (WM m) = WM (fmap (\ (v, xx) -> (v `mappend` w, xx)) m)+ instance Applicative Id where 	pure = Id 	Id f <*> Id x = Id (f x)@@ -44,3 +60,35 @@  (<.:>) :: Functor f => (c -> d) -> (a -> b -> f c) -> a -> b -> f d (f <.:> g) x y = f <$> g x y+{-+(<|>) :: MonadPlus m => m a -> m a -> m a+(<|>) = mplus-}++instance Applicative First where+	pure = return+	(<*>) = ap++instance Alternative First where+	empty = mempty+	(<|>) = mplus++instance Applicative Last where+	pure = return+	(<*>) = ap++instance Alternative Last where+	empty = mempty+	(<|>) = mplus++newtype Dual f a = Dual {runDual :: f a}++instance Functor f => Functor (Dual f) where+	fmap f (Dual x) = Dual (fmap f x)++instance Applicative f => Applicative (Dual f) where+	pure = Dual . pure+	Dual f <*> Dual x = Dual (flip ($) <$> x <*> f)++instance Alternative f => Alternative (Dual f) where+	empty = Dual empty+	Dual a <|> Dual b = Dual (b <|> a)
Data/TrieMap/Class.hs view
@@ -1,36 +1,41 @@ {-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances #-} -module Data.TrieMap.Class (TMap(..), TKey(..), Rep, Ordered (..), TrieMap, TrieKey) where+module Data.TrieMap.Class (TMap(..), TSet (..), TKey, TKeyT, Rep, TrieMap, TrieKey) where  import Data.TrieMap.TrieKey import Data.TrieMap.OrdMap+import Data.TrieMap.Rep+import Data.TrieMap.Sized  import Control.Applicative import Data.Foldable import Data.Traversable  -- import Generics.MultiRec.Base+import Data.TrieMap.Regular.Class 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)}+newtype TMap k a = TMap {getTMap :: TrieMap (Rep k) (Elem a)}+newtype TSet a = TSet (TMap a ()) -type family Rep k+class (Repr k, TrieKey (Rep k) (TrieMap (Rep k))) => TKey k+-- 	toRep :: k -> Rep k+-- 	fromRep :: Rep k -> k -class TrieKey (Rep k) (TrieMap (Rep k)) => TKey k where-	toRep :: k -> Rep k-	fromRep :: Rep k -> k+class (ReprT f, TrieKeyT (RepT f) (TrieMapT (RepT f))) => TKeyT f  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+	foldr f z (TMap m) = foldWithKeyM (\ _ (Elem 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+trv f (TMap m) = TMap <$> traverseWithKeyM elemSize (\ _ (Elem a) -> Elem <$> f a) m
Data/TrieMap/Class/Instances.hs view
@@ -1,14 +1,22 @@-{-# LANGUAGE CPP, Rank2Types, TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell, CPP, Rank2Types, TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances #-}  module Data.TrieMap.Class.Instances where  import Data.TrieMap.Class import Data.TrieMap.TrieKey+import Data.TrieMap.Rep+import Data.TrieMap.Rep.TH+import Data.TrieMap.Rep.Instances+import Data.TrieMap.Sized -- import Data.TrieMap.RadixTrie() import Data.TrieMap.MultiRec.Instances-import Data.TrieMap.IntMap()-import Data.TrieMap.OrdMap(Ordered(..))+import Data.TrieMap.IntMap+import Data.TrieMap.OrdMap+import Data.TrieMap.ReverseMap+import Data.TrieMap.ProdMap+import Data.TrieMap.UnionMap import Data.TrieMap.Class+import Data.TrieMap.Modifiers import Data.TrieMap.Regular.Base import Data.TrieMap.Regular.Class import Data.TrieMap.Regular.Instances@@ -23,6 +31,9 @@ import Data.Int  import Data.List hiding (foldr) import Data.Word+import Data.Array.IArray+import Data.Map(Map)+import Data.Set(Set)  import Prelude hiding (foldr) @@ -39,164 +50,62 @@ 	toRep = map toRep 	fromRep = map fromRep-} -type instance Rep Int = Int-instance TKey Int where-	toRep = id-	fromRep = id--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 = (I0 :+: I0) (Rep [Int32])-instance TKey Integer where-	toRep x = (if x >= 0 then R . I0 else L . I0) (toRep (unroll x))-	fromRep (L (I0 xs)) = - roll (map negate (fromRep xs))-	fromRep (R (I0 xs)) = roll (fromRep xs)--unroll :: Integer -> [Int32]-unroll x = if x >= 0 then unfoldr step x else map negate (unfoldr step (negate x)) 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 Bool = (U0 :+: U0) (U0 ())-instance TKey Bool where-	toRep False = L U0-	toRep True = R U0-	fromRep L{} = False-	fromRep R{} = True--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+instance TKey Int+instance TKey Double+instance TKey Char+instance TKey Bool+instance TKey Word+instance TKey Int32+instance TKey Word32+instance TKey Word16+instance TKey Word8+instance TKey Int8+instance TKey Int16+instance TKey Word64+instance TKey Int64+instance TKey ()+instance TKey a => TKeyT ((,) a)+instance (TKey a, TKey b) => TKey (a, b)+instance (TKey a, TKey b) => TKeyT ((,,) a b)+instance (TKey a, TKey b, TKey c) => TKey (a, b, c)+instance (TKey a, TKey b, TKey c) => TKeyT ((,,,) a b c)+instance (TKey a, TKey b, TKey c, TKey d) => TKey (a, b, c, d)+instance TKey a => TKey (I0 a)+instance TKeyT I0+instance TKey (U0 a)+instance TKeyT U0+instance TKey a => TKey (K0 a b)+instance TKey a => TKeyT (K0 a)+instance TKeyT f => TKeyT (L f)+instance (TKeyT f, TKey a) => TKey (L f a)+instance (Functor f, TKeyT f, TKeyT g) => TKeyT (f `O` g)+instance (TKeyT f, TKeyT g, TKey a) => TKey ((f `O` g) a)+instance (TKeyT f, TKeyT g) => TKeyT (f :*: g)+instance (TKeyT f, TKeyT g, TKey a) => TKey ((f :*: g) a)+instance (TKey a, TKey b) => TKey (Either a b)+instance TKey a => TKeyT (Either a)+instance TKey a => TKey [a]+instance TKeyT []+instance TKey a => TKey (Maybe a)+instance TKeyT Maybe+instance (TKey k, TKey a) => TKey (TMap k a)+instance TKey k => TKeyT (TMap k)+instance TKeyT Set+instance TKeyT Rev+instance TKey a => TKey (Rev a)+instance TKey a => TKey (Set a)+instance TKey k => TKeyT (Map k)+instance (TKey k, TKey a) => TKey (Map k a)+instance (TKey i, Ix i) => TKeyT (Array i)+instance (TKey i, Ix i, TKey e) => TKey (Array i e) -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 RepT (TMap k) = L (K0 (Rep k) :*: I0)+type instance Rep (TMap k a) = RepT (TMap k) (Rep a) -type instance Rep (I0 r) = I0 (Rep r)-instance TKey r => TKey (I0 r) where-	toRep = fmap toRep-	fromRep = fmap fromRep+instance TKey k => ReprT (TMap k) where+	toRepTMap f (TMap m) = List (foldWithKeyM (\ k (Elem a) xs -> (K0 k :*: I0 (f a)):xs) m [])+	fromRepTMap f (List xs) = TMap (fromDistAscListM (const 1) [(k, Elem (f a)) | (K0 k :*: I0 a) <- xs]) -type instance Rep (TMap k a) = L (K0 (Rep k) :*: I0) (Rep a)-instance (TKey k, TKey a) => TKey (TMap k a) where-	toRep (TMap m) = List [K0 k :*: I0 (toRep a) | (k, K0 a) <- foldWithKeyM (curry (:)) m []]-	fromRep (List xs) = TMap (fromDistAscListM (const 1) [(k, K0 (fromRep a)) | K0 k :*: I0 a <- xs])+instance (TKey k, Repr a) => Repr (TMap k a) where+	toRep = toRepTMap toRep+	fromRep = fromRepTMap fromRep
Data/TrieMap/IntMap.hs view
@@ -1,18 +1,24 @@-{-# LANGUAGE BangPatterns, Rank2Types, CPP, MagicHash, PatternGuards, MultiParamTypeClasses, TypeFamilies #-}+{-# LANGUAGE TemplateHaskell, TypeOperators, UndecidableInstances, BangPatterns, Rank2Types, CPP, MagicHash, PatternGuards, MultiParamTypeClasses, TypeFamilies #-}  module Data.TrieMap.IntMap () where  import Data.TrieMap.TrieKey+import Data.TrieMap.MultiRec.Base import Data.TrieMap.Applicative import Data.TrieMap.Sized+import Data.TrieMap.ReverseMap+-- import Data.TrieMap.Rep+-- import Data.TrieMap.Rep.TH -import Control.Applicative (Applicative(..), (<$>))+import Control.Applicative (Applicative(..), Alternative(..), (<$>)) import Control.Arrow+import Control.Monad (MonadPlus(..))  import Data.Bits import Data.Maybe import Data.Monoid import Data.Word+import Data.Int  #if __GLASGOW_HASKELL__ >= 503 import GHC.Exts ( Word(..), Int(..), shiftRL# )@@ -25,27 +31,46 @@  import Prelude hiding (lookup, null, foldl, foldr) -type Nat = Word+type Nat = Word32 -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) +data WordMap a = Nil+              | Tip {-# UNPACK #-} !Size {-# UNPACK #-} !Key (a)+              | Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(WordMap a) !(WordMap a)  		deriving (Show)-type instance TrieMap Int = IntMap+-- data IntMap a = IMap (WordMap a) (WordMap a)+type instance TrieMap Word32 = WordMap+-- type instance TrieMap Int32 = IntMap -type Prefix = Int-type Mask   = Int-type Key    = Int+type Prefix = Word32+type Mask   = Word32+type Key    = Word32 type Size   = Int -instance TrieKey Int IntMap where+-- type instance RepT WordMap = FamT KeyFam (HFix (U :+: (K Size :*: K Key :*: X) :+:+-- 				(K Size :*: K Prefix :*: K Mask :*: A0 :*: A0)))+-- type instance Rep (WordMap a) = RepT WordMap (Rep a)+-- +-- -- $(genRepT [d|+--    instance ReprT WordMap where+-- 	toRepT = FamT . toFix where+-- 		toFix = HIn . toFix'+-- 		toFix' Nil = L U+-- 		toFix' (Tip s kx x) = R (L (K s :*: K kx :*: X x))+-- 		toFix' (Bin s p m l r) = R (R (K s :*: K p :*: K m :*: A0 (toFix l) :*: A0 (toFix r)))+-- 	fromRepT (FamT m) = fromFix m where+-- 		fromFix (HIn x) = fromFix' x+-- 		fromFix' L{} = Nil+-- 		fromFix' (R (L (K s :*: K kx :*: X x))) = Tip s kx x+-- 		fromFix' (R (R (K s :*: K p :*: K m :*: A0 l :*: A0 r))) = Bin s p m (fromFix l) (fromFix r) |])++instance TrieKey Word32 WordMap where 	emptyM = Nil 	nullM = null 	sizeM _ = size-	lookupM = lookup . natFromInt-	lookupIxM _ = lookupIx . natFromInt-	assocAtM _ = fromJust .: assocAt-	updateAtM = updateAt+	lookupM = lookup+	lookupIxM s = lookupIx s 0+	assocAtM s = assocAt s 0+-- 	updateAtM s r = updateAt s r 0 	alterM = alter 	traverseWithKeyM = traverseWithKey 	foldWithKeyM = foldr@@ -55,98 +80,154 @@ 	unionM = unionWithKey 	isectM = intersectionWithKey 	diffM = differenceWithKey-	extractMinM _ = First . minViewWithKey-	extractMaxM _ = Last . maxViewWithKey-	alterMinM = updateMinWithKey-	alterMaxM = updateMaxWithKey+	extractM s f = extract s f+-- 	extractMinM s f = First . minViewWithKey s f+-- 	extractMaxM s f = Last . maxViewWithKey s f+-- 	alterMinM = updateMinWithKey+-- 	alterMaxM = updateMaxWithKey 	isSubmapM = isSubmapOfBy -natFromInt :: Int -> Nat-natFromInt = fromIntegral+{-instance TrieKey Int32 IntMap where+	emptyM = IMap Nil Nil+	nullM (IMap mN mP) = nullM mN && nullM mP+	sizeM s (IMap mN mP) = sizeM s mN + sizeM s mP+	lookupM k (IMap mN mP)+		| k < 0		= lookupM (fromIntegral (-k)) mN+		| otherwise	= lookupM (fromIntegral k) mP+	lookupIxM s k (IMap mN mP)+		| k < 0		= do	(i, v) <- lookupIx' 0 s (fromIntegral (-k)) mN+					return (sizeM s mN - 1 - i, v)+		| otherwise	= do	(i, v) <- lookupIxM s (fromIntegral k) mP+					return (i + sizeM s mN, v)+	assocAtM s i (IMap mN mP)+		| i < sN, (i', k, a) <- assocAt' s i mN+			= (i', - fromIntegral k, a)+		| (i', k, a) <-assocAtM s (i - sN) mP+			= (i' + sN, fromIntegral k, a)+		where	sN = sizeM s mN+	updateAtM s f i (IMap mN mP)+		| i < sN	= updateAtM s (\ i' k -> f i' (- fromIntegral k)) (sN - 1 - i) mN `IMap` mP+		| otherwise	= mN `IMap` updateAtM s (\ i' k -> f (i' + sN) (fromIntegral k)) (i - sN) mP+		where	sN = sizeM s mN+	alterM s f k (IMap mN mP)+		| k < 0		= alterM s f (fromIntegral (- k)) mN `IMap` mP+		| otherwise	= mN `IMap` alterM s f (fromIntegral k) mP+	traverseWithKeyM s f (IMap mN mP) =+		IMap <$> traverseWithKeyM s (\ k -> f (- fromIntegral k)) mN <*>+			traverseWithKeyM s (f . fromIntegral) mP+	foldWithKeyM f (IMap mN mP) =+		foldlWithKeyM (\ k -> flip (f (- fromIntegral k))) mN . foldWithKeyM (f . fromIntegral) mP+	foldlWithKeyM f (IMap mN mP) =+		foldlWithKeyM (f . fromIntegral) mP . foldWithKeyM (\ k -> flip (f (- fromIntegral k))) mN+	mapEitherM s1 s2 f (IMap mN mP) = (IMap mNL mPL, IMap mNR mPR)+		where	(mNL, mNR) = mapEitherM s1 s2 (\ k -> f (- fromIntegral k)) mN+			(mPL, mPR) = mapEitherM s1 s2 (f . fromIntegral) mP+	splitLookupM s f k (IMap mN mP)+		| k < 0, (mNL, ans, mNR) <- splitLookupM s ((\ (l, x, r) -> (r, x, l)) . f) (fromIntegral (-k)) mN+			= (IMap mNR emptyM, ans, IMap mNL mP)+		| (mPL, ans, mPR) <- splitLookupM s f (fromIntegral k) mP+			= (IMap mN mPL, ans, IMap emptyM mPR)-} -intFromNat :: Nat -> Int-intFromNat = fromIntegral+natFromInt :: Word32 -> Nat+natFromInt = id +intFromNat :: Nat -> Word32+intFromNat = id+ shiftRL :: Nat -> Key -> Nat-#if __GLASGOW_HASKELL__+-- #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+-- shiftRL (W# x) (I# i)+--   = W# (shiftRL# x i)+-- #else+shiftRL x i   = shiftR x (fromIntegral i)+-- #endif  -size :: IntMap a ix -> Int+size :: WordMap a -> Int size Nil = 0 size (Tip s _ _) = s size (Bin s _ _ _ _) = s -null :: IntMap a ix -> Bool+null :: WordMap a -> 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 :: Nat -> WordMap a -> Maybe (a)+lookup k (Bin _ _ m l r) = lookup k (if zeroN k m then l else r) lookup k (Tip _ kx x)-	| k == natFromInt kx	= Just x+	| k == kx	= Just x lookup _ _ = Nothing -lookupIx :: Nat -> IntMap a ix -> Maybe (Int, a ix)+{-+lookupIx :: Nat -> WordMap a -> Maybe (Int, a) 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+	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 -> WordMap a -> Maybe (Int, Key, a)+-- 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+assocAt :: Sized a -> Int -> Int -> WordMap a -> IndexPos Key a+assocAt s !i0 !i (Bin _ _ _ l r)+	| i < sl, (lb, x, ub) <- assocAt s i0 i l+		= (lb, x, ub <|> fst <$> First (minViewWithKey s (\ k a -> (Asc (i0 + size l) k a, Just a)) r))+	| (lb, x, ub) <- assocAt s (i0 + sl) (i - sl) r+		= (fst <$> Last (maxViewWithKey s (\ k a -> (Asc (i0 + size l - s a) k a, Just a)) l) <|> lb, x, ub) 	where	sl = size l-assocAt' i0 _ (Tip _ k x) = return (i0, k, x)-assocAt' _ _ _ = Nothing+assocAt _ i0 _ (Tip _ k x) = (mzero, return (Asc i0 k x), mzero)+assocAt _ _ _ _ = (mzero, mzero, mzero) -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 -> Key -> a -> Maybe (a)) -> Int -> WordMap a -> WordMap a+-- 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+updateAt :: Sized a -> Round -> Int -> (Int -> Key -> a -> Maybe (a)) -> Int -> WordMap a -> WordMap a+updateAt s True !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)+		if i < sl then bin p m (updateAt s True i0 f i l) r +			else bin p m l (updateAt s True (i0 + sl) f (i - sl) r)+	Tip _ kx x -> singletonMaybe s kx (f i0 kx x)+	_	-> t+updateAt s False !i0 f !i t = case t of+	Bin sz p m l r -> let {sl = size l; mI = maxIx l} in+		if i < mI then bin p m (updateAt s False i0 f i l) r+			else bin p m l (updateAt s False (i0 + sl) f (i - sl) r)+	Tip _ kx x -> singletonMaybe s kx (f i0 kx x)+	_	-> t+	where	maxIx m = maybe (size m) fst (maxViewWithKey s (\ _ a -> (size m - s a, Just a)) m) -lookupIx' :: Int -> Nat -> IntMap a ix -> Maybe (Int, a ix)-lookupIx' !i k t = case t of+lookupIx :: Sized a -> Int -> Nat -> WordMap a -> IndexPos Nat a+lookupIx s !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+		| zeroN k m, (lb, x, ub) <- lookupIx s i k l+			-> (lb, x, ub <|> fst <$> First (minViewWithKey s (\ k a -> (Asc (i + size l) k a, Just a)) r))+		| (lb, x, ub) <- lookupIx s (i + size l) k r+			-> (fst <$> Last (maxViewWithKey s (\ k a -> (Asc (i + size l - s a) k a, Just a)) l) <|> lb, x, ub) 	Tip _ kx x-		| k == natFromInt kx		-> Just (i, x)-	_ -> Nothing+		| k == kx	-> (mzero, return (Asc i kx x), mzero)+	_ -> (mzero, mzero, mzero) -singleton :: Sized a -> Key -> a ix -> IntMap a ix+singleton :: Sized a -> Key -> a -> WordMap a singleton s k a = Tip (s a) k a -singletonMaybe :: Sized a -> Key -> Maybe (a ix) -> IntMap a ix+singletonMaybe :: Sized a -> Key -> Maybe (a) -> WordMap a 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 :: Sized a -> (Maybe (a) -> Maybe (a)) -> Key -> WordMap a -> WordMap a alter s f k t = case t of 	Bin sz p m l r 		| nomatch k p m	-> join k (singletonMaybe s k (f Nothing)) p t@@ -159,48 +240,48 @@ 		| 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 :: Applicative f => Sized b -> (Key -> a -> f (b)) -> WordMap a -> f (WordMap b) 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 -> b -> b) -> WordMap a -> 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+foldr :: (Key -> a -> b -> b) -> WordMap a -> b -> b+foldr f t   = case t of-      Bin _ _ _ l r -> foldr' f l . foldr' f r+      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+foldl{-, foldl' -}:: (Key -> b -> a -> b) -> WordMap a -> 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+      Nil           -> id-}+foldl f t   = case t of-      Bin _ _ _ l r -> foldl' f r . foldl' f l+      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 :: Sized b -> Sized c -> EitherMap Key (a) (b) (c) ->+	WordMap a -> (WordMap b, WordMap c) 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+splitLookup :: Sized a -> SplitMap (a) x -> Key -> WordMap a -> (WordMap a ,Maybe x,WordMap a)+{-splitLookup s f k t   = case t of       Bin _ _ m l r           | m < 0 -> (if k >= 0 -- handle negative numbers.@@ -213,8 +294,8 @@         | 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+splitLookup' :: Sized a -> SplitMap (a) x -> Key -> WordMap a -> (WordMap a ,Maybe x,WordMap a)-}+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)@@ -226,7 +307,7 @@         | otherwise -> singletonMaybe s k `sides` f y       Nil -> (Nil,Nothing,Nil) -union :: Sized a -> IntMap a ix -> IntMap a ix -> IntMap a ix+union :: Sized a -> WordMap a -> WordMap a -> WordMap a union s t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)   | shorter m1 m2  = union1   | shorter m2 m1  = union2@@ -245,7 +326,7 @@ union _ Nil t       = t union _ t Nil       = t -unionWithKey :: Sized a -> UnionFunc Key (a ix) -> IntMap a ix -> IntMap a ix -> IntMap a ix+unionWithKey :: Sized a -> UnionFunc Key (a) -> WordMap a -> WordMap a -> WordMap a unionWithKey s f t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)   | shorter m1 m2  = union1   | shorter m2 m1  = union2@@ -264,7 +345,7 @@ 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 :: Sized c -> IsectFunc Key (a) (b) (c) -> WordMap a -> WordMap b -> WordMap c intersectionWithKey s f t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)   | shorter m1 m2  = intersection1   | shorter m2 m1  = intersection2@@ -286,7 +367,7 @@ 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 :: Sized a -> (Key -> a -> b -> Maybe (a)) -> WordMap a -> WordMap b -> WordMap a differenceWithKey s f t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)   | shorter m1 m2  = difference1   | shorter m2 m1  = difference2@@ -307,7 +388,7 @@ 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 :: LEq (a) (b) -> LEq (WordMap a) (WordMap b) 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@@ -317,62 +398,68 @@ isSubmapOfBy (<=) (Tip _ k x) t     = maybe False (x <=) (lookup (natFromInt k) t) isSubmapOfBy _         Nil _           = True +extract :: Alternative f => Sized a -> (Key -> a -> f (x, Maybe a)) -> WordMap a -> f (x, WordMap a)+extract s f t = case t of+	Bin _ p m l r -> second (\ l' -> bin p m l' r) <$> extract s f l+				<|> second (bin p m l) <$> extract s f r+	Tip _ k x -> second (singletonMaybe s k) <$> f k x+	Nil -> empty -maxViewWithKey, minViewWithKey :: IntMap a ix -> Maybe ((Key, a ix), IntMap a ix)-maxViewWithKey t+maxViewWithKey, minViewWithKey :: Sized a -> (Key -> a -> (x, Maybe a)) -> WordMap a -> Maybe (x, WordMap a)+maxViewWithKey s f 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)+--         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 s f r in Just (result, bin p m l t')+        Tip _ k y -> let (result, x) = f k y in Just (result, singletonMaybe s k x)         Nil -> Nothing -maxViewUnsigned, minViewUnsigned :: IntMap a ix -> ((Key, a ix), IntMap a ix)-maxViewUnsigned t +maxViewUnsigned, minViewUnsigned :: Sized a -> (Key -> a -> (x, Maybe a)) -> WordMap a -> (x, WordMap a)+maxViewUnsigned s f 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)+        Bin _ p m l r -> let (result,t') = maxViewUnsigned s f r in (result,bin p m l t')+        Tip _ k y -> let (result, x) = f k y in (result, singletonMaybe s k x)         Nil -> error "maxViewUnsigned Nil"  -- --- minViewWithKey :: IntMap a ix -> Maybe ((Key, a ix), IntMap a ix)-minViewWithKey t+-- minViewWithKey :: WordMap a -> Maybe ((Key, a), WordMap a)+minViewWithKey s f 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)+--         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 s f l in Just (result, bin p m t' r)+        Tip _ k y -> let (result, x) = f k y in Just (result, singletonMaybe s k x)         Nil -> Nothing --- minViewUnsigned :: IntMap a ix -> ((Key, a ix), IntMap a ix)-minViewUnsigned t +-- minViewUnsigned :: WordMap a -> ((Key, a), WordMap a)+minViewUnsigned s f 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)+        Bin _ p m l r -> let (result,t') = minViewUnsigned s f l in (result,bin p m t' r)+        Tip _ k y -> let (result, x) = f k y in (result, singletonMaybe s k x)         Nil -> error "minViewUnsigned Nil" -updateMinWithKey :: Sized a -> (Key -> a ix -> Maybe (a ix)) -> IntMap a ix -> IntMap a ix+updateMinWithKey :: Sized a -> (Key -> a -> Maybe (a)) -> WordMap a -> WordMap a 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 | 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 :: Sized a -> (Key -> a -> Maybe (a)) -> WordMap a -> WordMap a 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 :: Sized a -> (Key -> a -> Maybe (a)) -> WordMap a -> WordMap a 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 | 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 :: Sized a -> (Key -> a -> Maybe (a)) -> WordMap a -> WordMap a updateMaxWithKeyUnsigned s f t     = case t of         Bin _ p m l r -> let t' = updateMaxWithKeyUnsigned s f r in bin p m l t'@@ -419,7 +506,7 @@          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 :: Prefix -> WordMap a -> Prefix -> WordMap a -> WordMap a join p1 t1 p2 t2   | zero p1 m = bin p m t1 t2   | otherwise = bin p m t2 t1@@ -427,19 +514,19 @@     m = branchMask p1 p2     p = mask p1 m -bin :: Prefix -> Mask -> IntMap a ix -> IntMap a ix -> IntMap a ix+bin :: Prefix -> Mask -> WordMap a -> WordMap a -> WordMap a 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.WordMap+-- import qualified Data.WordMap as IMap -- import Data.Traversable -- --- newtype IntTMap a ix = ITMap (IntMap (a ix))+-- newtype IntTMap a = ITMap (WordMap (a)) -- type instance TrieMap Int = IntTMap--- newtype MaybeF a ix = MF {unF :: Maybe (a ix)}+-- newtype MaybeF a = MF {unF :: Maybe (a)} --  -- instance TrieKey Int IntTMap where -- 	emptyM = ITMap empty
+ Data/TrieMap/Modifiers.hs view
@@ -0,0 +1,12 @@+module Data.TrieMap.Modifiers where++newtype Ordered a = Ord {unOrd :: a} deriving (Eq, Ord)+newtype Rev k = Rev {getRev :: k} deriving (Eq)+instance Ord k => Ord (Rev k) where+	compare (Rev a) (Rev b) = compare b a++instance Functor Ordered where+	fmap f (Ord a) = Ord (f a)++instance Functor Rev where+	fmap f (Rev a) = Rev (f a)
Data/TrieMap/MultiRec.hs view
@@ -1,6 +1,7 @@ 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.FamMap import Data.TrieMap.MultiRec.Eq+import Data.TrieMap.MultiRec.Base import Data.TrieMap.MultiRec.Ord
+ Data/TrieMap/MultiRec/Base.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE UndecidableInstances, TypeOperators, FlexibleContexts, ExistentialQuantification, KindSignatures, FlexibleInstances, MultiParamTypeClasses #-}++module Data.TrieMap.MultiRec.Base (module Generics.MultiRec.Base, module Generics.MultiRec.HFix, {-A0(..), X(..), -}Family(..), FamT(..), KeyFam(..), FunctorT (..), breakEither) where++import Data.TrieMap.TrieKey++import Generics.MultiRec+import Generics.MultiRec.Base+import Generics.MultiRec.HFix++import Control.Applicative++-- newtype A f (r :: * -> *) ix = A {unA :: f r ix}+-- newtype A0 (r :: * -> *) ix = A0 {unA0 :: r ix}+-- newtype R (r1 :: * -> *) (r :: * -> *) ix = Rec {unRec :: r1 (r ix)}+-- newtype X (r :: * -> *) ix = X {unX :: ix}+newtype Family (phi :: * -> *) ix = F ix++data KeyFam k = TrieKey k (TrieMap k) => KF+newtype FamT (phi :: * -> *) f ix = FamT (f ix)++instance TrieKey k (TrieMap k) => El KeyFam k where+	proof = KF++-- instance HFunctor phi f => HFunctor phi (A f) where+-- 	hmapA f pf (A x) = A <$> hmapA f pf x++-- instance HFunctor phi A0 where+-- 	hmapA f pf (A0 x) = A0 <$> f pf x++-- instance HEq phi f => HEq phi (A f) where+-- 	heq f pf (A x) (A y) = heq f pf x y++-- instance HEq phi A0 where+-- 	heq f pf (A0 x) (A0 y) = f pf x y++class FunctorT f where+	fmapp :: Functor r => (a -> b) -> f r a -> f r b++instance FunctorT (FamT phi) where+	fmapp f (FamT x) = FamT (fmap f x)++instance Functor (Family phi) where+	fmap f (F x) = F (f x)++instance Functor f => Functor (FamT phi f) where+	fmap = fmapp++instance FunctorT (K k) where+	fmapp = fmap++instance Functor (K k r) where+	fmap f (K a) = K a++instance FunctorT (I ix) where+	fmapp = fmap++instance Functor (I ix r) where+	fmap f (I a) = I a++instance FunctorT U where+	fmapp f U = U ++instance Functor (U r) where+	fmap f U = U++instance (FunctorT f, FunctorT g) => FunctorT (f :*: g) where	+	fmapp f (x :*: y) = fmapp f x :*: fmapp f y++instance (Functor (f r), Functor (g r)) => Functor ((f :*: g) r) where+	fmap f (x :*: y) = fmap f x :*: fmap f y++instance (FunctorT f, FunctorT g) => FunctorT (f :+: g) where+	fmapp f (L l) = L (fmapp f l)+	fmapp f (R r) = R (fmapp f r)++instance (Functor (f r), Functor (g r)) => Functor ((f :+: g) r) where+	fmap f (L l) = L (fmap f l)+	fmap f (R r) = R (fmap f r)++-- instance FunctorT f => FunctorT (A f) where+-- 	fmapp f (A x) = A (fmapp f x)++-- instance FunctorT A0 where+-- 	fmapp f (A0 x) = A0 (fmap f x)++-- instance (FunctorT f, Functor r) => Functor (A f r) where+-- 	fmap = fmapp++-- instance Functor r => Functor (A0 r) where+-- 	fmap = fmapp++-- instance FunctorT X where+-- 	fmapp = fmap++-- instance Functor (X r) where+-- 	fmap f (X x) = X (f x)++instance FunctorT f => Functor (HFix f) where+	fmap f (HIn x) = HIn (fmapp f x)++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)
Data/TrieMap/MultiRec/Class.hs view
@@ -12,111 +12,124 @@ import Data.Monoid import Generics.MultiRec.Eq -type family HTrieMapT (phi :: * -> *) (f :: (* -> *) -> * -> *) :: (* -> *) -> (* -> *) -> * -> *-type family HTrieMap (phi :: * -> *) (r :: * -> *) :: (* -> *) -> * -> *+type family HTrieMapT (phi :: * -> *) (f :: (* -> *) -> * -> *) :: (* -> *) -> * -> * -> *+type family HTrieMap (phi :: * -> *) (r :: * -> *) :: * -> * -> *  class HOrd phi f => HTrieKeyT (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+	emptyT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> m r ix a+	nullT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> m r ix a -> Bool+	sizeT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> HSized phi a -> m r ix a -> Int+	lookupT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> f r ix -> m r ix a -> Maybe a+	lookupIxT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> HSized phi a -> f r ix -> m r ix a -> IndexPos (f r ix) a+	assocAtT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> HSized phi a -> Int -> m r ix a -> IndexPos (f r ix) a+-- 	updateAtT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +-- 		phi ix -> HSized phi a -> Round -> (Int -> f r ix -> a -> Maybe a) -> Int -> m r ix a -> m r ix a 	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+		phi ix -> HSized phi a -> (Maybe a -> Maybe a) -> f r ix ->+			m r ix a -> m r ix a 	{-# 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) #-}+		phi ix -> HSized phi b -> (f r ix -> ix a -> Id b) -> m r ix a -> Id (m r ix b) #-} 	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)+		phi ix -> HSized phi b -> (f r ix -> a -> t b) -> m r ix a -> t (m r ix b) 	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+		phi ix -> (f r ix -> a -> b -> b) -> m r ix a -> 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+		phi ix -> (f r ix -> b -> a -> b) -> m r ix a -> 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)+		HSized phi b -> HSized phi c -> EitherMap (f r ix) a b c -> m r ix a -> (m r ix b, m r ix c) 	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)+		phi ix -> HSized phi a -> SplitMap a x -> f r ix ->+			m r ix a -> (m r ix a, Maybe x, m r ix a) 	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+		phi ix -> HSized phi a -> UnionFunc (f r ix) a ->+			m r ix a -> m r ix a -> m r ix a 	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+		phi ix -> HSized phi c -> IsectFunc (f r ix) a b c -> m r ix a -> m r ix b -> m r ix c 	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+		phi ix -> HSized phi a -> DiffFunc (f r ix) a b -> m r ix a -> m r ix b -> m r ix a+	extractT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r), Alternative t) =>+		phi ix -> HSized phi a -> ExtractFunc t (m r ix a) (f r ix) a x+-- 	extractMinT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +-- 		phi ix -> HSized phi a -> ExtractFunc (f r ix) First a (m r ix a) x+-- 	extractMaxT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +-- 		phi ix -> HSized phi a -> ExtractFunc (f r ix) Last a (m r ix a) x+-- 	alterMinT:: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +-- 		phi ix -> HSized phi a -> (f r ix -> a -> Maybe a) -> m r ix a -> First (m r ix a)+-- 	alterMaxT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => +-- 		phi ix -> HSized phi a -> (f r ix -> a -> Maybe a) -> m r ix a -> Last (m r ix a) 	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)+		phi ix -> LEq a b -> LEq (m r ix a) (m r ix b) 	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+		phi ix -> HSized phi a -> (f r ix -> a -> a -> a ) -> [(f r ix, a )] -> m r ix a 	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+		phi ix -> HSized phi a -> [(f r ix, a )] -> m r ix a+	sizeT pf s m = foldWithKeyT pf (\ _ x n -> s 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 | 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) #-}+	emptyH :: m ~ HTrieMap phi r => phi ix -> m ix a+	nullH :: m ~ HTrieMap phi r => phi ix -> m ix a -> Bool+	sizeH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> m ix a -> Int+	lookupH :: m ~ HTrieMap phi r => phi ix -> r ix -> m ix a -> Maybe a+	alterH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> (Maybe a -> Maybe a) -> r ix -> m ix a -> m ix a+	lookupIxH :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> r ix -> m ix a -> IndexPos (r ix) a+	assocAtH :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> Int -> m ix a -> IndexPos (r ix) a+-- 	updateAtH :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> Round -> (Int -> r ix -> a -> Maybe a) -> Int -> m ix a -> m ix a+	{-# SPECIALIZE traverseWithKeyH :: phi ix -> (r ix -> ix a -> Id b) ->+		m ix a -> Id (m ix b) #-} 	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+		phi ix -> HSized phi b -> (r ix -> a -> f b) -> m ix a -> f (m ix b)+	foldWithKeyH :: m ~ HTrieMap phi r => phi ix -> (r ix -> a -> b -> b) -> m ix a -> b -> b+	foldlWithKeyH :: m ~ HTrieMap phi r => phi ix -> (r ix -> b -> a -> b) -> m ix a -> 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+		EitherMap (r ix) a b c -> m ix a -> (m ix b, m ix c)+	splitLookupH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> SplitMap a x -> r ix -> m ix a ->+				(m ix a, Maybe x, m ix a)+	unionH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> UnionFunc (r ix) a -> m ix a -> m ix a+			-> m ix a+	isectH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi c -> IsectFunc (r ix) a b c ->+			m ix a -> m ix b -> m ix c+	diffH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> DiffFunc (r ix) a b ->+			m ix a -> m ix b -> m ix a+	extractH :: (m ~ HTrieMap phi r, Alternative t) =>+		phi ix -> HSized phi a -> ExtractFunc t (m ix a) (r ix) a x+-- 	extractMinH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> ExtractFunc (r ix) First a (m ix a) x+-- 	extractMaxH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> ExtractFunc (r ix) Last a (m ix a) x+-- 	alterMinH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> (r ix -> a -> Maybe a) ->+-- 		m ix a -> First (m ix a)+-- 	alterMaxH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> (r ix -> a -> Maybe a) ->+-- 		m ix a -> Last (m ix a) 	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+		phi ix -> LEq a b -> LEq (m ix a) (m ix b)+	fromListH, fromAscListH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> (r ix -> a -> a -> a) ->+		[(r ix, a)] -> m ix a+	fromDistAscListH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> [(r ix, a)] -> m ix a+	sizeH pf s m = foldWithKeyH pf (\ _ x n -> s 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+	phi ix -> HSized phi b -> (f r ix -> a -> b ) -> HTrieMapT phi f r ix a -> HTrieMapT phi f r ix b 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+	phi ix -> HSized phi b -> (r ix -> a -> b) -> HTrieMap phi r ix a -> HTrieMap phi r ix b 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)+	phi ix -> m r ix a -> Maybe (m r ix a) guardNullT pf m 	| nullT pf m	= Nothing 	| otherwise	= Just m++-- alterMaxT, alterMinT :: (m ~ HTrieMapT phi f, HTrieKeyT phi f m, HTrieKey phi r (HTrieMap phi r)) =>+-- 	phi ix -> HSized phi a -> (f r ix -> a -> Maybe a) -> m r ix a -> m r ix a+-- alterMaxT pf s f m = maybe m snd $ getLast (extractMaxT pf s (\ k a -> ((), f k a)) m)+-- alterMinT pf s f m = maybe m snd $ getFirst (extractMinT pf s (\ k a -> ((), f k a)) m)++aboutT :: (m ~ HTrieMapT phi f, HTrieKeyT phi f m, HTrieKey phi r (HTrieMap phi r), Alternative t) =>+	phi ix -> (f r ix -> a -> t z) -> m r ix a -> t z+aboutT pf f m = fst <$> extractT pf (const 0) (\ k a -> fmap (flip (,) Nothing) (f k a)) m
Data/TrieMap/MultiRec/ConstMap.hs view
@@ -1,12 +1,14 @@-{-# LANGUAGE KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-} -module Data.TrieMap.MultiRec.ConstMap where+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 Data.TrieMap.Rep+-- import Data.TrieMap.Rep.TH  import Control.Applicative import Control.Arrow@@ -16,10 +18,18 @@ import Data.Foldable import Generics.MultiRec -newtype KMap (phi :: * -> *) m (r :: * -> *) (a :: * -> *) ix = KMap (m a ix)+newtype KMap (phi :: * -> *) m (r :: * -> *) ix a = KMap (m a) type instance HTrieMapT phi (K k) = KMap phi (TrieMap k) type instance HTrieMap phi (K k r) = HTrieMapT phi (K k) r +-- type instance RepT (KMap phi m r ix) = RepT m+-- type instance Rep (KMap phi m r ix a) = RepT m (Rep a)+-- +-- -- $(genRepT [d|+--    instance ReprT m => ReprT (KMap phi m r ix) where+-- 	toRepT (KMap m) = toRepT m+-- 	fromRepT = KMap . fromRepT |])+ instance TrieKey k m => HTrieKeyT phi (K k) (KMap phi m) where 	emptyT = emptyH 	nullT = nullH@@ -27,7 +37,7 @@ 	lookupT = lookupH 	lookupIxT = lookupIxH 	assocAtT = assocAtH-	updateAtT = updateAtH+-- 	updateAtT = updateAtH 	alterT = alterH 	traverseWithKeyT = traverseWithKeyH 	foldWithKeyT = foldWithKeyH@@ -37,10 +47,11 @@ 	unionT = unionH 	isectT = isectH 	diffT = diffH-	extractMinT = extractMinH-	extractMaxT = extractMaxH-	alterMinT = alterMinH-	alterMaxT = alterMaxH+	extractT = extractH+-- 	extractMinT = extractMinH+-- 	extractMaxT = extractMaxH+-- 	alterMinT = alterMinH+-- 	alterMaxT = alterMaxH 	isSubmapT = isSubmapH 	fromListT = fromListH 	fromAscListT = fromAscListH@@ -49,12 +60,11 @@ 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+	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)+	lookupIxH _ s (K k) (KMap m) = onKey K (lookupIxM s k m)+	assocAtH _ s i (KMap m) = onKey K (assocAtM s i m)+-- 	updateAtH _ s r f i (KMap m) = KMap (updateAtM s r (\ 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@@ -64,14 +74,11 @@ 	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)+	extractH pf s f (KMap m) = second KMap <$> extractM s (f . K) m+-- 	extractMinH pf s f (KMap m) = second KMap <$> extractMinM (s) (f . K) m+-- 	extractMaxH pf s f (KMap m) = second KMap <$> extractMaxM s (f . K) 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])
Data/TrieMap/MultiRec/Eq.hs view
@@ -2,7 +2,8 @@  module Data.TrieMap.MultiRec.Eq where -import Generics.MultiRec+import Data.TrieMap.MultiRec.Base+import Generics.MultiRec.HFix import Generics.MultiRec.Eq  class HEq0 phi r where@@ -13,6 +14,12 @@  instance Eq k => HEq0 phi (K k r) where 	heqH _ (K x) (K y) = x == y+{-+instance HEq0 phi r => HEq0 phi (A0 r) where+	heqH pf (A0 x) (A0 y) = heqH pf x y-}++-- instance (HEq phi f, HEq0 phi r) => HEq0 phi (A f r) where+-- 	heqH pf (A x) (A y) = heqT pf 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
Data/TrieMap/MultiRec/FamMap.hs view
@@ -1,14 +1,16 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, Rank2Types, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE PatternGuards, TypeFamilies, MultiParamTypeClasses, Rank2Types, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} -module Data.TrieMap.MultiRec.FamMap where+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.MultiRec.Base import Data.TrieMap.Sized import Data.TrieMap.Applicative import Data.TrieMap.TrieKey+import qualified Data.TrieMap.Regular.Class as Reg  import Control.Applicative import Control.Arrow@@ -20,8 +22,7 @@  import Generics.MultiRec -newtype Family phi ix = F ix-newtype FamMap (phi :: * -> *) m (a :: * -> *) ix = FamMap (m (Family phi) a ix)+newtype FamMap (phi :: * -> *) m ix a = FamMap (m (Family phi) ix a) 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@@ -36,6 +37,21 @@ 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 +instance HEq0 phi r => HEq0 phi (FamT phi r) where+	heqH pf (FamT x) (FamT y) = heqH pf x y++instance HOrd0 phi r => HOrd0 phi (FamT phi r) where+	compareH0 pf (FamT x) (FamT y) = compareH0 pf x y++instance (El phi ix, HEq0 phi r) => Eq (FamT phi r ix) where+	x == y = heqH (prove' x) x y++instance (El phi ix, HOrd0 phi r) => Ord (FamT phi r ix) where+	x `compare` y = compareH0 (prove' x) x y++prove' :: El phi ix => FamT phi r ix -> phi ix+prove' _ = proof+ prove :: El phi ix => Family phi ix -> phi ix prove _ = proof @@ -51,12 +67,11 @@ 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+	sizeH pf s (FamMap m) = sizeT pf 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)+	lookupIxH pf s (F k) (FamMap m) = onKey (F . to' pf) (lookupIxT pf s (from' pf k) m)+	assocAtH pf s i (FamMap m) = onKey (F . to' pf) (assocAtT pf s i m)+-- 	updateAtH pf s r f i (FamMap m) = FamMap (updateAtT pf s r (\ 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@@ -67,59 +82,75 @@ 	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)+	extractH pf s f (FamMap m) = second FamMap <$> extractT pf s (f . F . to' pf) m+-- 	extractMinH pf s f (FamMap m) = second FamMap <$> extractMinT pf s (f . F . to' pf) m+-- 	extractMaxH pf s f (FamMap m) = second FamMap <$> extractMaxT pf s (f . F . to' pf) 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)+newtype FMap (phi :: * -> *) m ix a = FMap (m ix a) 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+	sizeM s (FMap m) = sizeH proof s m+	lookupM k (FMap m) = lookupH proof k m+	lookupIxM s k (FMap m) = lookupIxH proof s k m+	assocAtM s i (FMap m) = assocAtH proof s i m+-- 	updateAtM s r f i (FMap m) = FMap (updateAtH proof s r f i m)+	alterM s f k (FMap m) = FMap (alterH proof s f k m)+	traverseWithKeyM s f (FMap m) = FMap <$> traverseWithKeyH proof s f m+	foldWithKeyM f (FMap m) = foldWithKeyH proof f m+	foldlWithKeyM f (FMap m) = foldlWithKeyH proof f 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])+		(FMap *** FMap) (mapEitherH proof s1 s2 f m)+	splitLookupM s f k (FMap m) = FMap `sides` splitLookupH proof s (f) k m+	unionM s f (FMap m1) (FMap m2) = FMap (unionH proof s f m1 m2) +	isectM s f (FMap m1) (FMap m2) = FMap (isectH proof s f m1 m2) +	diffM s f (FMap m1) (FMap m2) = FMap (diffH proof s f m1 m2) +	extractM s f (FMap m) = second FMap <$> extractH proof s f m+-- 	extractMinM s f (FMap m) = second FMap <$> extractMinH proof s f m+-- 	extractMaxM s f (FMap m) = second FMap <$> extractMaxH proof s f m+-- 	alterMinM s f (FMap m) = FMap (alterMinH proof s f m)+-- 	alterMaxM s f (FMap m) = FMap (alterMaxH proof s f m)+	isSubmapM (<=) (FMap m1) (FMap m2) = isSubmapH proof (<=) m1 m2 +	fromListM s f xs = FMap (fromListH proof s f xs)+	fromAscListM s f xs = FMap (fromAscListH proof s f xs)+	fromDistAscListM s xs = FMap (fromDistAscListH proof s xs)++newtype FTMap (phi :: * -> *) (r :: * -> *) ix a = FTMap (HTrieMap phi r ix a)+type instance TrieMap (FamT phi r ix) = FTMap phi r ix++-- instance (HTrieKey KeyFam r (HTrieMap KeyFam r)) => Reg.TrieKeyT (FamT KeyFam r) (FTMap KeyFam r) where+-- 	emptyT = FTMap (emptyH KF)++instance (El phi ix, HTrieKey phi r (HTrieMap phi r)) => TrieKey (FamT phi r ix) (FTMap phi r ix) where+	emptyM = FTMap (emptyH proof)+	nullM (FTMap m) = nullH proof m+	sizeM s (FTMap m) = sizeH proof s m+	lookupM (FamT k) (FTMap m) = lookupH proof k m+	lookupIxM s (FamT k) (FTMap m) = onKey FamT (lookupIxH proof s k m)+	assocAtM s i (FTMap m) = onKey FamT (assocAtH proof s i m)+-- 	updateAtM s r f i (FTMap m) = FTMap (updateAtH proof s r (\ i' -> f i' . FamT) i m)+	alterM s f (FamT k) (FTMap m) = FTMap (alterH proof s f k m)+	foldWithKeyM f (FTMap m) = foldWithKeyH proof (f . FamT) m+	foldlWithKeyM f (FTMap m) = foldlWithKeyH proof (f . FamT) m+	traverseWithKeyM s f (FTMap m) = FTMap <$> traverseWithKeyH proof s (f . FamT) m+	mapEitherM s1 s2 f (FTMap m) = (FTMap *** FTMap) (mapEitherH proof s1 s2 (f . FamT) m)+	splitLookupM s f (FamT k) (FTMap m) = FTMap `sides` splitLookupH proof s f k m+	unionM s f (FTMap m1) (FTMap m2) = FTMap (unionH proof s (f . FamT) m1 m2)+	isectM s f (FTMap m1) (FTMap m2) = FTMap (isectH proof s (f . FamT) m1 m2)+	diffM s f (FTMap m1) (FTMap m2) = FTMap (diffH proof s (f . FamT) m1 m2)+	isSubmapM (<=) (FTMap m1) (FTMap m2) = isSubmapH proof (<=) m1 m2+	extractM s f (FTMap m) = second FTMap <$> extractH proof s (f . FamT) m+-- 	extractMinM s f (FTMap m){--} = second FTMap <$> extractMinH proof s (f . FamT) m+-- 	extractMaxM s f (FTMap m) = second FTMap <$> extractMaxH proof s (f . FamT) m+-- 	alterMinM s f (FTMap m) = FTMap (alterMinH proof s (f . FamT) m)+-- 	alterMaxM s f (FTMap m) = FTMap (alterMaxH proof s (f . FamT) m)
+ Data/TrieMap/MultiRec/FixMap.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE PatternGuards, FlexibleContexts, FlexibleInstances, TypeFamilies, MultiParamTypeClasses #-}++module Data.TrieMap.MultiRec.FixMap () where++import Data.TrieMap.MultiRec.Base+import Data.TrieMap.MultiRec.Class+import Data.TrieMap.TrieKey++import Control.Applicative+import Control.Arrow++newtype HFixMap (phi :: * -> *) (f :: (* -> *) -> * -> *) a ix = HFixMap (HTrieMapT phi f (HFix f) a ix)+type instance HTrieMap phi (HFix f) = HFixMap phi f++instance HTrieKeyT phi f (HTrieMapT phi f) => HTrieKey phi (HFix f) (HFixMap phi f) where+	emptyH = HFixMap . emptyT+	nullH pf (HFixMap m) = nullT pf m+	sizeH pf s (HFixMap m) = sizeT pf s m+	lookupH pf (HIn k) (HFixMap m) = lookupT pf k m+	lookupIxH pf s (HIn k) (HFixMap m) = onKey HIn (lookupIxT pf s k m)+	assocAtH pf s i (HFixMap m) = onKey HIn (assocAtT pf s i m)+-- 	updateAtH pf s r f i (HFixMap m) = HFixMap (updateAtT pf s r (\ i' -> f i' . HIn) i m)+	alterH pf s f (HIn k) (HFixMap m) = HFixMap (alterT pf s f k m)+	traverseWithKeyH pf s f (HFixMap m) = HFixMap <$> traverseWithKeyT pf s (f . HIn) m+	foldWithKeyH pf f (HFixMap m) = foldWithKeyT pf (f . HIn) m+	foldlWithKeyH pf f (HFixMap m) = foldlWithKeyT pf (f . HIn) m+	unionH pf s f (HFixMap m1) (HFixMap m2) = HFixMap (unionT pf s (f . HIn) m1 m2)+	isectH pf s f (HFixMap m1) (HFixMap m2) = HFixMap (isectT pf s (f . HIn) m1 m2)+	diffH pf s f (HFixMap m1) (HFixMap m2) = HFixMap (diffT pf s (f . HIn) m1 m2)+	isSubmapH pf (<=) (HFixMap m1) (HFixMap m2) = isSubmapT pf (<=) m1 m2+	mapEitherH pf s1 s2 f (HFixMap m) = (HFixMap *** HFixMap) (mapEitherT pf s1 s2 (f . HIn) m)+	splitLookupH pf s f (HIn k) (HFixMap m) = HFixMap `sides` splitLookupT pf s f k m+	extractH pf s f (HFixMap m) = second HFixMap <$> extractT pf s (f . HIn) m+-- 	extractMinH pf s f (HFixMap m) = second HFixMap <$> extractMinT pf s (f . HIn) m+-- 	extractMaxH pf s f (HFixMap m) = second HFixMap <$> extractMaxT pf s (f . HIn) m+-- 	alterMinH pf s f (HFixMap m) = HFixMap <$> alterMinT pf s (f . HIn) m+-- 	alterMaxH pf s f (HFixMap m) = HFixMap <$> alterMaxT pf s (f . HIn) m
Data/TrieMap/MultiRec/IMap.hs view
@@ -1,9 +1,12 @@-{-# LANGUAGE Rank2Types, TypeFamilies, FlexibleInstances, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, Rank2Types, TypeFamilies, FlexibleInstances, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses #-} -module Data.TrieMap.MultiRec.IMap where+module Data.TrieMap.MultiRec.IMap () where  import Data.TrieMap.MultiRec.Class import Data.TrieMap.MultiRec.Sized+import Data.TrieMap.MultiRec.TH+-- import Data.TrieMap.Rep.TH+-- import Data.TrieMap.Rep import Data.TrieMap.TrieKey  import Control.Applicative@@ -11,76 +14,43 @@  import Generics.MultiRec -newtype IMap phi xi r a ix = IMap (HTrieMap phi r (I ix a) xi)+newtype IMap phi xi r ix a = IMap (HTrieMap phi r xi a) 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+-- type instance RepT (IMap phi xi r ix) = RepT (HTrieMap phi r xi)+-- type instance Rep (IMap phi xi r ix a) = RepT (IMap phi xi r ix) (Rep a)+-- +-- -- $(genRepT [d|+--   instance ReprT (HTrieMap phi r xi) => ReprT (IMap phi xi r ix) where+-- 	toRepT (IMap m) = toRepT m+-- 	fromRepT = IMap . fromRepT |] ) -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+$(inferH [d|+   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+	sizeT _ s (IMap m) = sizeH proof s m+	lookupT _ (I k) (IMap m) = lookupH proof k m+	lookupIxT _ s (I k) (IMap m) = onKey I (lookupIxH proof s k m)+	assocAtT _ s i (IMap m) = onKey I (assocAtH proof s i m)+-- 	updateAtT _ s r f i (IMap m) = IMap (updateAtH proof s r (\ i' -> f i' . I) i m)+	alterT _ s f (I k) (IMap m) = IMap (alterH proof s f k m)+	traverseWithKeyT _ s f (IMap m) = IMap <$> traverseWithKeyH proof s (f . I) m+	foldWithKeyT _ f (IMap m) = foldWithKeyH proof (f . I) m+	foldlWithKeyT _ f (IMap m) = foldlWithKeyH proof (f . I) m+	mapEitherT _ s1 s2 f (IMap m) = (IMap *** IMap) (mapEitherH proof s1 s2 (f . I) m)+	splitLookupT pf s f (I k) (IMap m) = IMap `sides` splitLookupH proof s (f) k m+	unionT pf s f (IMap m1) (IMap m2) = IMap (unionH proof s (f . I) m1 m2)+	isectT pf s f (IMap m1) (IMap m2) = IMap (isectH proof s (f . I) m1 m2)+	diffT pf s f (IMap m1) (IMap m2) = IMap (diffH proof s (f . I) m1 m2)+	extractT pf s f (IMap m) = second IMap <$> extractH proof s (f . I) m+-- 	extractMinT pf s f (IMap m) = second IMap <$> extractMinH proof s (f . I) m+-- 	extractMaxT pf s f (IMap m) = second IMap <$> extractMaxH proof s (f . I) m+-- 	alterMinT pf s f (IMap m) = IMap <$> alterMinH proof s (f . I) m+-- 	alterMaxT pf s f (IMap m) = IMap <$> alterMaxH proof s (f . I) m+	isSubmapT pf (<=) (IMap m1) (IMap m2) = isSubmapH proof (<=) m1 m2 +	fromListT _ s f xs = IMap (fromListH proof s (f . I) [(k, a) | (I k, a) <- xs])+	fromAscListT _ s f xs = IMap (fromAscListH proof s (f . I) [(k, a) | (I k, a) <- xs])+	fromDistAscListT _ s xs = IMap (fromDistAscListH proof s [(k, a) | (I k, a) <- xs]) |])
Data/TrieMap/MultiRec/Instances.hs view
@@ -7,3 +7,6 @@ import Data.TrieMap.MultiRec.ConstMap import Data.TrieMap.MultiRec.UnitMap import Data.TrieMap.MultiRec.FamMap+-- import Data.TrieMap.MultiRec.AppMap+-- import Data.TrieMap.MultiRec.XMap+import Data.TrieMap.MultiRec.FixMap
Data/TrieMap/MultiRec/Ord.hs view
@@ -3,7 +3,7 @@ module Data.TrieMap.MultiRec.Ord where  import Data.TrieMap.MultiRec.Eq-+import Data.TrieMap.MultiRec.Base import Generics.MultiRec  import Data.Monoid@@ -18,6 +18,15 @@  class HEq0 phi r => HOrd0 phi r where 	compareH0 :: phi ix -> Comparator (r ix)++-- instance HOrd0 phi r => HOrd0 phi (A0 r) where+-- 	compareH0 pf (A0 a) (A0 b) = compareH0 pf a b++-- instance (HOrd phi f, HOrd0 phi r) => HOrd0 phi (A f r) where+-- 	compareH0 pf (A a) (A b) = hcompare pf a b++-- instance HOrd phi A0 where+-- 	compareH cmp pf (A0 a) (A0 b) = cmp pf a b  instance Ord k => HOrd phi (K k) where 	compareH _ = compareH0
Data/TrieMap/MultiRec/ProdMap.hs view
@@ -1,126 +1,138 @@-{-# LANGUAGE TypeOperators, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeFamilies, MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards, TemplateHaskell, TypeOperators, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeFamilies, MultiParamTypeClasses #-} -module Data.TrieMap.MultiRec.ProdMap where+module Data.TrieMap.MultiRec.ProdMap () where  import Data.TrieMap.MultiRec.Class import Data.TrieMap.MultiRec.Eq+import Data.TrieMap.MultiRec.Ord import Data.TrieMap.MultiRec.Sized+import Data.TrieMap.MultiRec.TH+import Data.TrieMap.Regular.Base (O(..)) import Data.TrieMap.Applicative import Data.TrieMap.TrieKey+-- import Data.TrieMap.Rep+-- import Data.TrieMap.Rep.TH  import Control.Applicative import Control.Arrow  import Data.Maybe+import Data.Monoid 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)+newtype ProdMap (phi :: * -> *) f g (r :: * -> *) ix a = PMap (HTrieMapT phi f r ix (HTrieMapT phi g r ix a))+type instance HTrieMapT phi (f :*: g) = ProdMap phi f g--(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+-- type instance RepT (ProdMap phi f g r ix) = RepT (HTrieMapT phi f r ix) `O` RepT (HTrieMapT phi g r ix)+-- type instance Rep (ProdMap phi f g r ix a) = RepT (ProdMap phi f g r ix) (Rep a) -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])+-- -- $(genRepT [d|+-- 	instance (ReprT (HTrieMapT phi f r ix), ReprT (HTrieMapT phi g r ix)) =>+-- 			ReprT (ProdMap phi f g r ix) where+-- 		toRepT (PMap m) = O (fmap toRepT (toRepT m))+-- 		fromRepT (O m) = PMap (fromRepT (fmap fromRepT m)) |] ) -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)]+maxIx :: (HTrieKeyT phi f (HTrieMapT phi f), HTrieKey phi r (HTrieMap phi r)) => phi ix -> HSized phi a -> +		HTrieMapT phi f r ix a -> Int+maxIx pf s m = fromMaybe (sizeT pf s m) (getFirst (aboutT pf (\ _ a -> return (sizeT pf s m - s a)) m)) -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+$(inferH [d|+	instance (HTrieKeyT phi f (HTrieMapT phi f), HTrieKeyT phi g (HTrieMapT phi g)) => +			HTrieKeyT phi (f :*: g) (ProdMap phi f g) where+		emptyT = PMap . emptyT+		nullT pf (PMap m) = nullT pf m+		sizeT pf s (PMap m) = sizeT pf (sizeT pf s) m+		lookupT pf (a :*: b) (PMap m) = lookupT pf a m >>= lookupT pf b+		lookupIxT pf s (a :*: b) (PMap m) = case lookupIxT pf (sizeT pf s) a m of+			(lb, x, rb) -> let lookupX = do	Asc i a' m' <- x+							let (lb', x', rb') = lookupIxT pf s b m'+							let f = onIndexA (i +) . onKeyA (a' :*:)+							return (f <$> lb', f <$> x', f <$> rb')+			   in 	((do	Asc iA aL mL <- lb+					fmap (onIndexA (iA +) . onKeyA (aL :*:)) (getLast pf s mL)) <|>+				 (do	(lb', _, _) <- Last lookupX+					lb'),+				 (do	(_, x', _) <- lookupX+					x'),+				 (do	(_, _, rb') <- First lookupX+					rb') <|>+				 (do	Asc iA aR mR <- rb+				  	fmap (onIndexA (iA +) . onKeyA (aR :*:)) (getFirst pf s mR)))+			where 	getLast pf s m = aboutT pf (\ k a -> return (Asc (sizeT pf s m - s a) k a)) m+				getFirst pf s m = aboutT pf (\ k a -> return (Asc 0 k a)) m+		assocAtT pf s i (PMap m) = case assocAtT pf (sizeT pf s) i m of+			(lb, x, rb) -> let lookupX = do	Asc i' a' m' <- x+							let (lb', x', rb') = assocAtT pf s (i - i') m'+							let f = onIndexA (i' +) . onKeyA (a' :*:)+							return (f <$> lb', f <$> x', f <$> rb')+				in ((do	Asc iA aL mL <- lb+					fmap (onIndexA (iA +) . onKeyA (aL :*:)) (getLast pf s mL)) <|>+				    (do	(lb', _, _) <- Last lookupX+				    	lb'),+				    (do	(_, x', _) <- lookupX+				    	x'),+				    (do	(_, _, rb') <- First lookupX+				    	rb') <|>+				    (do	Asc iA aR mR <- rb+				    	fmap (onIndexA (iA +) . onKeyA (aR :*:)) (getFirst pf s mR)))+			where 	getLast pf s m = aboutT pf (\ k a -> return (Asc (sizeT pf s m - s a) k a)) m+				getFirst pf s m = aboutT pf (\ k a -> return (Asc 0 k a)) m+-- 		updateAtT pf s r f i (PMap m) = PMap (updateAtT pf (sizeT pf s) r g i m) where+-- 			g iA a m +-- 				| i >= iA && i <= iA + maxIx pf s m+-- 					= (guardNullT pf . updateAtT pf s r (\ iB b -> f (iA + iB) (a :*: b)) (i - iA)) m+-- 				| i < iA+-- 					= guardNullT pf $+-- 						alterMaxT pf s (\ b v -> f (iA + sizeT pf s m - s v) (a :*: b) v) m+-- 				| otherwise+-- 					= guardNullT pf $ alterMinT pf s (f iA . (a :*:)) m+		alterT pf s f (a :*: b) (PMap m) = PMap (alterT pf (sizeT pf 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 pf 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 pf s1) (sizeT pf 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 pf 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 pf 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 pf 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 pf s) g m1 m2) where+			g a = guardNullT pf .: diffT pf s (\ b -> f (a :*: b))+		extractT pf s f (PMap m) = second PMap <$> extractT pf (sizeT pf s) g m where+			g a = second (guardNullT pf) <.> extractT pf s (\ b -> f (a :*: b))+-- 		extractMinT pf s f (PMap m) = second PMap <$> extractMinT pf (sizeT pf s) g m where +-- 			g a m1 = fromJust $ getFirst $ second (guardNullT pf) <$> extractMinT pf s (f . (a :*:)) m1+-- 		extractMaxT pf s f (PMap m) = second PMap <$> extractMaxT pf (sizeT pf s) g m where +-- 			g a m1 = fromJust $ getLast $ second (guardNullT pf) <$> extractMaxT pf s (f . (a :*:)) m1+-- 		alterMinT pf s f (PMap m) = PMap (alterMinT pf (sizeT pf 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 pf 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 pf s) (\ a -> fromListT pf s (\ b -> f (a :*: b)))+					(fromListT pf (const 1) (\ _ (xs) (ys) -> (xs ++ ys))+						[(a, ts) | (a, ts) <- breakFst pf xs]))+		fromAscListT pf s f xs = PMap (fromDistAscListT pf (sizeT pf s)+			[(a, fromAscListT pf s (\ b -> f (a :*: b)) ts) | (a, ts) <- breakFst pf xs])+		fromDistAscListT pf s xs = PMap (fromDistAscListT pf (sizeT pf 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)] -> [(f r ix, [(g r ix, a)])]+	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)]+	|])
Data/TrieMap/MultiRec/Sized.hs view
@@ -12,9 +12,9 @@ -- 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+type HSized (phi :: * -> *) a = a -> Int  newtype Elem a = Elem {getElem :: a} -sizeElem :: HSized phi Elem+sizeElem :: HSized phi (Elem a) sizeElem _ = 1
+ Data/TrieMap/MultiRec/TH.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, QuasiQuotes, TemplateHaskell #-}++module Data.TrieMap.MultiRec.TH where++import Data.TrieMap.MultiRec.Class+import Data.TrieMap.MultiRec.Ord+import Language.Haskell.TH+import Language.Haskell.TH.Ppr+import Control.Monad+import Debug.Trace++data Scheme = Sch {empt, nul, siz, look, lookIx, assocAt, updateAt, alter, traverse, fold, foldl, mapE, splitL, union, isect, diff, extractMi, extractMa, alterMi, alterMa, isSub, fromL, fromAL, fromDAL :: String}++htriekeyT :: Scheme+htriekeyT = Sch "emptyT" "nullT" "sizeT" "lookupT" "lookupIxT" "assocAtT" "updateAtT" "alterT" "traverseWithKeyT" "foldWithKeyT" "foldlWithKeyT"+	"mapEitherT" "splitLookupT" "unionT" "isectT" "diffT" "extractMinT" "extractMaxT" "alterMinT" "alterMaxT" "isSubmapT" +	"fromListT" "fromAscListT" "fromDistAscListT"++htriekey :: Scheme+htriekey = Sch "emptyH" "nullH" "sizeH" "lookupH" "lookupIxH" "assocAtH" "updateAtH" "alterH" "traverseWithKeyH" "foldWithKeyH" "foldlWithKeyH"+	"mapEitherH" "splitLookupH" "unionH" "isectH" "diffH" "extractHinH" "extractHaxH" "alterHinH" "alterHaxH" "isSubmapH" +	"fromListH" "fromAscListH" "fromDistAscListH"++{-inferNewtype :: Name -> Name -> Scheme -> Scheme -> Q [Dec] -> Q [Dec]+inferNewtype kCon mCon sch1 sch2 decl = do+	decs@(InstanceD cxt t _:_) <- decl+	let fund = FunD . mkName+	let mcon = ConE mCon+	mapV <- newName "m"+	let mapVar = VarE mapV+	let mapPat = ConP mCon [VarP mapV]+	pfV <- newName "pf"+	let pfPat = VarP pfV+	let pfVar = VarE pfV+	szV <- newName "s"+	let szPat = VarP szV+	let szVar = VarE szV+	let empty = fund (empt sch1) [pfPat] (AppE mcon (AppE (VarE (empt sch2)) pfVar))+	let null = fund (nul sch1) [pfPat, mapPat] (VarE (nul sch2) `AppE` pfVar `AppE` mapVar)+	let size = fund (siz sch1) [pfPat, szPat, mapPat] (VarE (siz sch2) `AppE` pfVar `AppE` szPat `AppE` mapVar+	return [InstanceD cxt t [empty, null, size]]-}+	++inferH :: Q [Dec] -> Q [Dec]+inferH instanceT = do+	iT@(InstanceD cxt0 (htriekeyt `AppT` phi `AppT` f `AppT` m) _:_) <- instanceT+	(InstanceD _ _ decs:_) <- [d|+	  instance (HTrieKeyT phi f m, HTrieKey phi r mm, HOrd0 phi (f r)) => HTrieKey phi (f r) (m 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+		extractH = extractT+-- 		alterMinH = alterMinT+-- 		alterMaxH = alterMaxT+-- 		extractMinH = extractMinT+-- 		extractMaxH = extractMaxT+		isSubmapH = isSubmapT+		fromListH = fromListT+		fromAscListH = fromAscListT+		fromDistAscListH = fromDistAscListT |]+	let r = mkName "r"+	let mm = mkName "mm"+-- 	let phiT = varT phi+	let rT = varT r+	let mmT = varT mm+-- 	let mT = varT m+	let htriekey = conT ''HTrieKey+	let hord = conT ''HOrd+	let hord0 = conT ''HOrd0+	let htriemap = conT ''HTrieMap+	ans <- instanceD (cxt (map return cxt0 ++ [htriekey `appQ` phi `appT` rT `appT` (htriemap `appQ` phi `appT` rT)]))+		(htriekey `appT` return phi `appT` (return f `appT` rT) `appT` (return m `appT` rT)) (map return decs)+	return (ans:iT)++appQ :: TypeQ -> Type -> TypeQ+t1 `appQ` t2 = t1 `appT` return t2
Data/TrieMap/MultiRec/TagMap.hs view
@@ -1,12 +1,14 @@-{-# LANGUAGE Rank2Types, TypeOperators, KindSignatures, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeFamilies, GADTs, MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell, Rank2Types, TypeOperators, KindSignatures, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeFamilies, GADTs, MultiParamTypeClasses #-} -module Data.TrieMap.MultiRec.TagMap where+module Data.TrieMap.MultiRec.TagMap () where  import Data.TrieMap.MultiRec.Class import Data.TrieMap.MultiRec.Eq import Data.TrieMap.MultiRec.Sized+import Data.TrieMap.MultiRec.TH import Data.TrieMap.Applicative import Data.TrieMap.TrieKey+-- import Data.TrieMap.Rep  import Control.Applicative import Control.Arrow@@ -17,88 +19,98 @@ import Data.Foldable import Generics.MultiRec -data TagF a ix :: * -> * where-	TagF :: a ix -> TagF a ix ix+data TagF a ix xi where+	TagF :: a -> TagF a ix ix -unTagF :: TagF a ix xi -> a xi+unTagF :: TagF a ix xi -> a 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+newtype TagMap (phi :: * -> *) f ix (r :: * -> *) xi a = TagMap (HTrieMapT phi f r xi (TagF a ix xi))+type instance HTrieMapT phi (f :>: ix) = TagMap 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) ->+-- type instance RepT (TagMap phi f ix r xi) = RepT (HTrieMapT phi f r xi)+-- type instance Rep (TagMap phi f ix r xi a) = RepT (HTrieMapT phi f r xi) (Rep a)++-- instance (ReprT (HTrieMapT phi f r xi), ix ~ xi) => ReprT (TagMap phi f ix r xi) where+-- 	toRepT (TagMap m) = fmap unTagF (toRepT m)+-- 	fromRepT = TagMap . fromRepT . fmap TagF+-- +-- instance (ReprT (HTrieMapT phi f r xi), ix ~ xi, Repr a) => Repr (TagMap phi f ix r xi a) where+-- 	toRep (TagMap m) = fmap (toRep . unTagF) (toRepT m)+-- 	fromRep = TagMap . fromRepT . fmap (TagF . fromRep)++combineTag :: IsectFunc ((f :>: ix) r xi) (a) (b) (c) -> 	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 :: Functor t => ((f :>: ix) r xi -> a -> t (b)) -> 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 :: HSized phi a -> HSized phi (TagF a ix xi) sizeTag s (TagF x) = s x -instance (HTrieKeyT phi f m, m ~ HTrieMapT phi f) => HTrieKeyT phi (f :>: ix) (TagMap phi m ix) where+restructure :: HTrieKeyT phi f (HTrieMapT phi f) =>+	((f r ix, TagF a xi ix), HTrieMapT phi f r ix (TagF a xi ix)) -> (((f :>: xi) r ix, a), TagMap phi f xi r ix a)+restructure ((k, TagF a), m) = ((Tag k, a), TagMap m)++restructure' :: Applicative t => ((f :>: xi) r ix -> a -> t (x, Maybe a)) -> f r ix -> TagF a xi ix -> t (x, Maybe (TagF a xi ix))+restructure' f k (TagF a) = second (fmap TagF) <$> f (Tag k) a++retag :: (f r ix, TagF a xi ix) -> ((f :>: xi) r ix, a)+retag (k, TagF a) = (Tag k, a)++$(inferH [d|+  instance (HTrieKeyT phi f (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+	sizeT pf s (TagMap m) = sizeT pf (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+	lookupIxT pf s (Tag k) (TagMap m) = onValue retag (lookupIxT pf (sizeTag s) k m)+	assocAtT pf s i (TagMap m) = onValue retag (assocAtT pf (sizeTag s) i m) +-- 	updateAtT pf s r f i (TagMap m) = TagMap (updateAtT pf (sizeTag s) r (f' f) i m) where+-- 		f' :: (Int -> (f :>: xi) r ix -> a -> Maybe (a)) -> 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' :: Applicative t => ((f :>: ix) r xi -> a -> t (b )) -> 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 :>: ix) r xi -> a -> 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 :>: ix) r xi -> b -> a -> 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' :: EitherMap ((f :>: ix) r xi) (a ) (b) (c) -> 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' :: SplitMap (a) 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) +-- 	extractMinT pf s f (TagMap m) = second TagMap <$> extractMinT pf (sizeTag s) (restructure' f) m+-- 	extractMaxT pf s f (TagMap m) = second TagMap <$> extractMaxT pf (sizeTag s) (restructure' f) m+	extractT pf s f (TagMap m) = second TagMap <$> extractT pf (sizeTag s) (restructure' f) m+-- 	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 :: LEq a b -> 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 :>: ix) r xi -> a -> a -> a) -> 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 :>: ix) r xi -> a -> a -> a ) -> 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 :: ((f :>: ix) r xi, a) -> (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+		HTrieKey phi ((f :>: ix) r) (TagMap phi f ix r) where 	emptyH = emptyT 	nullH = nullT 	sizeH = sizeT@@ -122,4 +134,4 @@ 	isSubmapH = isSubmapT 	fromListH = fromListT 	fromAscListH = fromAscListT-	fromDistAscListH = fromDistAscListT+	fromDistAscListH = fromDistAscListT-}
Data/TrieMap/MultiRec/UnionMap.hs view
@@ -1,46 +1,75 @@-{-# LANGUAGE TypeFamilies, KindSignatures, FlexibleContexts, FlexibleInstances, UndecidableInstances, PatternGuards, MultiParamTypeClasses, TypeOperators #-}+{-# LANGUAGE TemplateHaskell, TypeFamilies, KindSignatures, FlexibleContexts, FlexibleInstances, UndecidableInstances, PatternGuards, MultiParamTypeClasses, TypeOperators #-} -module Data.TrieMap.MultiRec.UnionMap where+module Data.TrieMap.MultiRec.UnionMap () where  import Data.TrieMap.MultiRec.Class import Data.TrieMap.MultiRec.Eq+import Data.TrieMap.MultiRec.Base import Data.TrieMap.Applicative import Data.TrieMap.TrieKey+-- import Data.TrieMap.Rep+-- import Data.TrieMap.Rep.TH+import Data.TrieMap.MultiRec.TH+import qualified Data.TrieMap.Regular.Base as Reg  import Control.Applicative import Control.Arrow import Control.Monad  import Data.Maybe+import Data.Monoid 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)+data UnionMap (phi :: * -> *) f g (r :: * -> *) ix a = HTrieMapT phi f r ix a :&: HTrieMapT phi g r ix a+type instance HTrieMapT phi (f :+: g) = UnionMap phi f 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+-- type instance RepT (UnionMap phi f g r ix) = (Reg.:*:) (RepT (HTrieMapT phi f r ix)) (RepT (HTrieMapT phi g r ix))+-- type instance Rep (UnionMap phi f g r ix a) = RepT (UnionMap phi f g r ix) (Rep a)++-- -- $(genRepT [d|+--     instance (ReprT (HTrieMapT phi f r ix), ReprT (HTrieMapT phi g r ix)) => ReprT (UnionMap phi f g r ix) where+-- 	toRepT (m1 :&: m2) = (Reg.:*:) (toRepT m1) (toRepT m2)+-- 	fromRepT ((Reg.:*:) m1 m2) = fromRepT m1 :&: fromRepT m2+-- 	|])++$(inferH [d|+    instance (HTrieKeyT phi f (HTrieMapT phi f), HTrieKeyT phi g (HTrieMapT phi g)) => HTrieKeyT phi (f :+: g) (UnionMap phi f g) 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+	sizeT pf s (m1 :&: m2) = sizeT pf s m1 + sizeT pf 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+		| L k <- k	= case onKey L (lookupIxT pf s k m1) of+			(lb, x, ub) -> (lb, x, ub <|> ((onKeyA R . onIndexA (+ sizeT pf s m1)) <$> getMin pf s m2))+		| R k <- k	= case onIndex (sizeT pf s m1 +) (onKey R (lookupIxT pf s k m2)) of+			(lb, x, ub) -> ((onKeyA L <$> getMax pf s m1) <|> lb, x, ub)+			where	getMin pf s m = aboutT pf (\ k a -> return $ Asc 0 k a) m+				getMax pf s m = aboutT pf (\ k a -> return $ Asc (sizeT pf s m - s a) k a) m 	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+		| i < s1	= case onKey L (assocAtT pf s i m1) of+			(lb, x, ub) -> (lb, x, ub <|> ((onKeyA R . onIndexA (+ s1)) <$> getMin pf s m2))+		| otherwise	= case onKey R (onIndex (s1 +) (assocAtT pf s (i - s1) m2)) of+			(lb, x, ub) -> ((onKeyA L <$> getMax pf s m1) <|> lb, x, ub)+		where	getMin pf s m = aboutT pf (\ k a -> return $ Asc 0 k a) m+			getMax pf s m = aboutT pf (\ k a -> return $ Asc (sizeT pf s m - s a) k a) m+			s1 = sizeT pf s m1+{-	updateAtT pf s r f i (m1 :&: m2)+		| not r && i >= lastIx m1+			= m1 :&: updateAtT pf s r (\ i' -> f (i' + s1) . R) (i - s1) m2+		| i < s1+			= updateAtT pf s r (\ i' -> f i' . L) i m1 :&: m2+		| otherwise+			= m1 :&: updateAtT pf s r (\ i' -> f (i' + s1) . R) (i - s1) m2+		where	s1 = sizeT pf s m1+			lastIx m = case extractMaxT pf s (\ _ v -> (v, Just v)) m of+				Last (Just (v, _)) -> sizeT pf s m - s v+				_			-> sizeT pf s m-} 	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@@ -63,22 +92,18 @@ 		= 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+	extractT pf s f (m1 :&: m2) = second (:&: m2) <$> extractT pf s (f . L) m1 <|>+		second (m1 :&:) <$> extractT pf s (f . R) m2+-- 	extractMinT pf s f (m1 :&: m2) = second (:&: m2) <$> extractMinT pf s (f . L) m1 <|>+-- 		second (m1 :&:) <$> extractMinT pf s (f . R) m2+-- 	extractMaxT pf s f (m1 :&: m2) = second (:&: m2) <$> extractMaxT pf s (f . L) m1 <|>+-- 		second (m1 :&:) <$> extractMaxT pf s (f . R) 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@@ -86,36 +111,4 @@ 	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+		(ys, zs) -> fromDistAscListT pf s ys :&: fromDistAscListT pf s zs |])
Data/TrieMap/MultiRec/UnitMap.hs view
@@ -1,11 +1,14 @@-{-# LANGUAGE KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances, TemplateHaskell, KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-} -module Data.TrieMap.MultiRec.UnitMap where+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 Data.TrieMap.Rep+-- import Data.TrieMap.Rep.Instances+-- import Data.TrieMap.Rep.TH  import Control.Applicative import Control.Arrow@@ -19,10 +22,18 @@  import Prelude hiding (foldr, foldl) -newtype UMap (phi :: * -> *) (r :: * -> *) a ix = UMap (Maybe (a ix))+newtype UMap (phi :: * -> *) (r :: * -> *) ix a = UMap (Maybe a) type instance HTrieMapT phi U = UMap phi type instance HTrieMap phi (U r) = UMap phi r +-- type instance RepT (UMap phi r ix) = RepT Maybe+-- type instance Rep (UMap phi r ix a) = RepT Maybe (Rep a)+-- +-- -- $(genRepT [d|+--   instance ReprT (UMap phi r ix) where+-- 	toRepT (UMap m) = toRepT m+-- 	fromRepT = UMap . fromRepT |])+ instance HTrieKeyT phi U (UMap phi) where 	emptyT = emptyH 	nullT = nullH@@ -30,7 +41,7 @@ 	lookupT = lookupH 	lookupIxT = lookupIxH 	assocAtT = assocAtH-	updateAtT = updateAtH+-- 	updateAtT = updateAtH 	alterT = alterH 	traverseWithKeyT = traverseWithKeyH 	foldWithKeyT = foldWithKeyH@@ -40,10 +51,11 @@ 	unionT = unionH 	isectT = isectH 	diffT = diffH-	extractMinT = extractMinH-	extractMaxT = extractMaxH-	alterMinT = alterMinH-	alterMaxT = alterMaxH+	extractT = extractH+-- 	extractMinT = extractMinH+-- 	extractMaxT = extractMaxH+-- 	alterMinT = alterMinH+-- 	alterMaxT = alterMaxH 	isSubmapT = isSubmapH 	fromListT = fromListH 	fromAscListT = fromAscListH@@ -52,11 +64,15 @@ 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+	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)+	lookupIxH _ _ _ (UMap m) = (mempty, Asc 0 U <$> m, mempty)+	assocAtH _ _ _ (UMap m) = (mempty, Asc 0 U <$> m, mempty)+-- 	updateAtH _ s r f i (UMap m)+-- 		| r == (i >= 0)+-- 			= UMap (m >>= f 0 U)+-- 		| otherwise+-- 			= UMap m 	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@@ -66,12 +82,11 @@ 	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+	extractH _ _ f (UMap m) = maybe empty (second UMap <.> f U) m+-- 	extractMinH _ _ f (UMap m) = fmap (second UMap . f U) (First m)+-- 	extractMaxH _ _ f (UMap m) = fmap (second UMap . f U) (Last m)+-- 	alterMinH _ _ f (UMap m) = (UMap . f U) <$> (First m)+-- 	alterMaxH _ _ f (UMap m) = (UMap . f U) <$> (Last m) 	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)
Data/TrieMap/OrdMap.hs view
@@ -1,12 +1,16 @@-{-# LANGUAGE Rank2Types, PatternGuards, MultiParamTypeClasses, TypeFamilies #-}+{-# LANGUAGE UndecidableInstances, TemplateHaskell, FlexibleContexts, TypeOperators, Rank2Types, PatternGuards, MultiParamTypeClasses, TypeFamilies #-} -module Data.TrieMap.OrdMap (Ordered (..)) where+module Data.TrieMap.OrdMap () where  import Data.TrieMap.TrieKey import Data.TrieMap.Sized import Data.TrieMap.Applicative+import Data.TrieMap.Modifiers+import Data.TrieMap.MultiRec.Base+-- import Data.TrieMap.Rep+-- import Data.TrieMap.Rep.TH -import Control.Applicative (Applicative(..), (<$>))+import Control.Applicative (Applicative(..), Alternative(..), (<$>)) import Control.Arrow import Control.Monad hiding (join) @@ -18,33 +22,45 @@  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) +data OrdMap k a = Tip +              | Bin {-# UNPACK #-} !Int k (a) !(OrdMap k a) !(OrdMap k a)   type instance TrieMap (Ordered k) = OrdMap k +-- type instance RepT (OrdMap k) = FamT KeyFam (HFix (U :+: (K Int :*: K k :*: X :*: A0 :*: A0)))+-- type instance Rep (OrdMap k a) = RepT (OrdMap k) (Rep a)++-- -- $(genRepT [d|+--    instance ReprT (OrdMap k) where+-- 	toRepT = FamT . toFix where+-- 		toFix Tip = HIn (L U)+-- 		toFix (Bin s kx x l r) = HIn (R (K s :*: K kx :*: X x :*: A0 (toFix l) :*: A0 (toFix r)))+-- 	fromRepT (FamT x) = fromFix x where+-- 		fromFix (HIn L{}) = Tip+-- 		fromFix (HIn (R (K s :*: K kx :*: X x :*: A0 l :*: A0 r)))+-- 			= Bin s kx x (fromFix l) (fromFix r) |])+ 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)+	lookupIxM s (Ord k) = onKey Ord . lookupIx s 0 k+	assocAtM s i = onKey Ord . assocAt s 0 i+-- 	updateAtM s r f = updateAt s 0 r (\ 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)+	extractM s f m = extract s (f . Ord) m+-- 	extractMinM _ _ Tip = mzero+-- 	extractMinM s f m = return (deleteFindMin s (f . Ord) m)+-- 	extractMaxM _ _ Tip = mzero+-- 	extractMaxM s f m = return (deleteFindMax s (f . Ord) 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]@@ -59,44 +75,70 @@ 		(_, Tip) -> m1 		_	 -> hedgeDiffWithKey s (f . Ord) (const LT) (const GT) m1 m2 -lookup :: Ord k => k -> OrdMap k a ix -> Maybe (a ix)+lookup :: Ord k => k -> OrdMap k a -> Maybe (a) 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+lookupIx :: Ord k => Sized a -> Int -> k -> OrdMap k a -> IndexPos k a+lookupIx _ i _ _ | i `seq` False = undefined+lookupIx _ _ _ Tip = (mzero, mzero, mzero)+lookupIx s i k (Bin sz kx x l r) = case compare k kx of+	LT	-> case lookupIx s i k l of+		(lb, ans, ub) -> (lb, ans, ub <|> return (Asc (i + size l) kx x))+	EQ	-> (extractMax (\ k v -> Asc (i + size l - s v) k v) l,+			return (Asc (i + size l) kx x),+		    extractMin (Asc (i + sz - size r)) r)+	GT	-> case lookupIx s (i + sz - size r) k r of+		(lb, ans, ub) -> (return (Asc (i + size l) kx x) <|> lb, ans, ub)+	where	extractMin f Tip = mzero+		extractMin f b = return (fst $ deleteFindMin s (\ k x -> (f k x, Just x)) b)+		extractMax f Tip = mzero+		extractMax f b = return (fst $ deleteFindMax s (\ k x -> (f k x, Just x)) b) -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+assocAt :: Sized a -> Int -> Int -> OrdMap k a -> IndexPos k a+assocAt _ i0 i _ | i0 `seq` i `seq` False = undefined+assocAt _ _ _ Tip = (mzero, mzero, mzero)+assocAt s i0 i (Bin sz k a l r)+	| i < sL, (lb, ans, ub) <- assocAt s i0 i l+			= (lb, ans, ub <|> return (Asc (i0 + size l) k a))+	| i < sK	= (extractMax (\ k v -> Asc (i0 + sL - s v) k v) l,+				return (Asc (i0 + sL) k a),+			   extractMin (Asc sK) r)+	| (lb, ans, ub) <- assocAt s (i0 + sK) (i - sK) r+			= (return (Asc (i0 + sL) k a) <|> lb, ans, ub) 	where	sL = size l 		sK = sz - size r+		extractMin f Tip = mzero+		extractMin f b = return (fst $ deleteFindMin s (\ k x -> (f k x, Just x)) b)+		extractMax f Tip = mzero+		extractMax f b = return (fst $ deleteFindMax s (\ k x -> (f k x, Just x)) b) -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+updateAt :: Sized a -> Int -> Round -> (Int -> k -> a -> Maybe (a)) -> Int -> OrdMap k a -> OrdMap k a+updateAt _ i0 _ _ i _ | i0 `seq` i `seq` False = undefined+updateAt _ _ _ _ _ Tip = Tip+updateAt s i0 True f i (Bin sz k a l r)+	| i < sL	= balance s k a (updateAt s i0 True f i l) r+	| i < sK	= case f (i0 + sL) 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)+	| otherwise	= balance s k a l (updateAt s (i0 + sK) True f (i - sK) r) 	where	sL = size l 		sK = sz - size r +updateAt s i0 False f i (Bin sz k a l r)+	| i < maxIxL	= balance s k a (updateAt s i0 False f i l) r+	| i <= sL	= case f (i0 + sL) k a of+		Nothing	-> glue s l r+		Just a' -> bin s k a' l r+	| otherwise	= balance s k a l (updateAt s (i0 + sK) False f (i - sK) r)+	where	sL = size l+		maxIxL = case l of	Tip	-> 0+					_ 	-> fst (deleteFindMax s (\ _ a -> (size l - s a, Just a)) 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 :: Ord k => Sized a -> (Maybe (a) -> Maybe (a)) -> k -> OrdMap k a -> OrdMap k a alter s f k Tip = case f Nothing of 	Nothing	-> Tip 	Just x	-> singleton s k x@@ -107,30 +149,30 @@ 		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 :: Sized a -> k -> a -> OrdMap k a 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 :: Applicative f => Sized b -> (k -> a -> f (b)) -> OrdMap k a -> f (OrdMap k b) 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 :: (k -> a -> b -> b) -> OrdMap k a -> 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 :: (k -> b -> a -> b) -> OrdMap k a -> 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 :: Ord k => Sized b -> Sized c -> EitherMap k (a) (b) (c) ->+	OrdMap k a -> (OrdMap k b, OrdMap k c) 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 :: Ord k => Sized a -> (k -> a -> Maybe (a)) -> OrdMap k a -> OrdMap k a updateMin s f m = case m of 	Tip	-> Tip 	Bin _ k a Tip r -> case f k a of@@ -138,7 +180,7 @@ 		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 :: Ord k => Sized a -> (k -> a -> Maybe (a)) -> OrdMap k a -> OrdMap k a updateMax s f m = case m of 	Tip	-> Tip 	Bin _ k a l Tip	-> case f k a of@@ -146,7 +188,7 @@ 		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 :: Ord k => Sized a -> SplitMap (a) x -> k -> OrdMap k a -> (OrdMap k a, Maybe x, OrdMap k a) splitLookup s f k m = case m of 	Tip	-> (Tip, Nothing, Tip) 	Bin _ kx x l r -> case compare k kx of@@ -158,7 +200,7 @@ 		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 :: Ord k => LEq (a) (b) -> LEq (OrdMap k a) (OrdMap k b) isSubmap (<=) Tip _ = True isSubmap (<=) _ Tip = False isSubmap (<=) (Bin _ kx x l r) t = case found of@@ -166,7 +208,7 @@ 	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 :: Eq k => Sized a -> (k -> a -> a -> a) -> [(k, a)] -> OrdMap k a fromAscList s f xs = fromDistinctAscList s (combineEq xs) where 	combineEq (x:xs) = combineEq' x xs 	combineEq [] = []@@ -176,7 +218,7 @@ 		| 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 :: Sized a -> [(k, a)] -> OrdMap k a fromDistinctAscList s xs = build const (length xs) xs   where     -- 1) use continutations so that we use heap space instead of stack space.@@ -196,9 +238,9 @@     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))+                  => Sized a -> (k -> a -> a -> Maybe (a))                   -> (k -> Ordering) -> (k -> Ordering)-                  -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+                  -> OrdMap k a -> OrdMap k a -> OrdMap k a hedgeUnionWithKey _ _ _     _     t1 Tip   = t1 hedgeUnionWithKey s _ cmplo cmphi Tip (Bin _ kx x l r)@@ -214,7 +256,7 @@                     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 :: Ord k => Sized a -> (k -> Ordering) -> OrdMap k a -> OrdMap k a filterGt _ _   Tip = Tip filterGt s cmp (Bin _ kx x l r)   = case cmp kx of@@ -222,7 +264,7 @@       GT -> filterGt s cmp r       EQ -> r       -filterLt :: Ord k => Sized a -> (k -> Ordering) -> OrdMap k a ix -> OrdMap k a ix+filterLt :: Ord k => Sized a -> (k -> Ordering) -> OrdMap k a -> OrdMap k a filterLt _ _   Tip = Tip filterLt s cmp (Bin _ kx x l r)   = case cmp kx of@@ -230,7 +272,7 @@       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 :: (k -> Ordering) -> (k -> Ordering) -> OrdMap k a -> OrdMap k a trim _     _     Tip = Tip trim cmplo cmphi t@(Bin _ kx _ l r)   = case cmplo kx of@@ -239,7 +281,7 @@               _  -> 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 :: Ord k => k -> (k -> Ordering) -> OrdMap k a -> (Maybe (k,a), OrdMap k a) trimLookupLo _  _     Tip = (Nothing,Tip) trimLookupLo lo cmphi t@(Bin _ kx x l r)   = case compare lo kx of@@ -249,7 +291,7 @@       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 :: Ord k => Sized c -> IsectFunc k (a) (b) (c) -> OrdMap k a -> OrdMap k b -> OrdMap k c 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) =@@ -260,9 +302,9 @@   hedgeDiffWithKey :: Ord k-                 => Sized a -> (k -> a ix -> b ix -> Maybe (a ix))+                 => Sized a -> (k -> a -> b -> Maybe (a))                  -> (k -> Ordering) -> (k -> Ordering)-                 -> OrdMap k a ix -> OrdMap k b ix -> OrdMap k a ix+                 -> OrdMap k a -> OrdMap k b -> OrdMap k a hedgeDiffWithKey _ _ _     _     Tip _   = Tip hedgeDiffWithKey s _ cmplo cmphi (Bin _ kx x l r) Tip@@ -281,10 +323,10 @@     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 :: Ord k => Sized a -> k -> Maybe (a) -> OrdMap k a -> OrdMap k a -> OrdMap k a 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 :: Ord k => Sized a -> k -> a -> OrdMap k a -> OrdMap k a -> OrdMap k a 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)@@ -294,7 +336,7 @@   -- 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,insertMin :: Sized a -> k -> a -> OrdMap k a -> OrdMap k a insertMax s kx x t   = case t of       Tip -> singleton s kx x@@ -310,7 +352,7 @@ {--------------------------------------------------------------------   [merge l r]: merges two trees. --------------------------------------------------------------------}-merge :: Sized a -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+merge :: Sized a -> OrdMap k a -> OrdMap k a -> OrdMap k a merge _ Tip r   = r merge _ l Tip   = l merge s l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)@@ -322,36 +364,43 @@   [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 :: Sized a -> OrdMap k a -> OrdMap k a -> OrdMap k a 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'+  | size l > size r = let (f,l') = deleteFindMax s (\ k a -> (balance s k a, Nothing)) l in f l' r+  | otherwise       = let (f,r') = deleteFindMin s (\ k a -> (balance s k a, Nothing)) r in f l r' -deleteFindMin :: Sized a -> OrdMap k a ix -> ((k, a ix), OrdMap k a ix)-deleteFindMin s t +extract :: Alternative t => Sized a -> (k -> a -> t (z, Maybe a)) -> OrdMap k a -> t (z, OrdMap k a)+extract s f t = case t of+	Bin _ k x l r -> +		second (\ l' -> balance s k x l' r) <$> extract s f l <|>+		second (maybe (glue s l r) (\ x' -> balance s k x' l r))  <$> f k x <|>+		second (balance s k x l) <$> extract s f r++deleteFindMin :: Sized a -> (k -> a -> (x, Maybe a)) -> OrdMap k a -> (x, OrdMap k a)+deleteFindMin s f 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)+      Bin _ k x Tip r -> let (ans, x') = f k x in (ans, maybe r (\ y' -> bin s k y' Tip r) x')+      Bin _ k x l r   -> let (km,l') = deleteFindMin s f 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+deleteFindMax :: Sized a -> (k -> a -> (x, Maybe a)) -> OrdMap k a -> (x, OrdMap k a)+deleteFindMax s f 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')+      Bin _ k x l Tip -> let (ans, x') = f k x in (ans, maybe l (\ y -> bin s k y l Tip) x')+      Bin _ k x l r   -> let (km,r') = deleteFindMax s f 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 :: OrdMap k a -> 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 :: Sized a -> k -> a -> OrdMap k a -> OrdMap k a -> OrdMap k a balance s k x l r   | sizeL + sizeR <= 1    = Bin sizeX k x l r   | sizeR >= delta*sizeL  = rotateL s k x l r@@ -363,31 +412,31 @@     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 :: Sized a -> k -> a -> OrdMap k a -> OrdMap k a -> OrdMap k a 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 :: Sized a -> k -> a -> OrdMap k a -> OrdMap k a -> OrdMap k a 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, singleR :: Sized a -> k -> a -> OrdMap k a -> OrdMap k a -> OrdMap k a singleL s k1 x1 t1 (Bin _ k2 x2 t2 t3)  = bin s k2 x2 (bin s k1 x1 t1 t2) t3 singleL s k1 x1 t1 Tip = bin s k1 x1 t1 Tip singleR s k1 x1 (Bin _ k2 x2 t1 t2) t3  = bin s k2 x2 t1 (bin s k1 x1 t2 t3) singleR s k1 x1 Tip t2 = bin s k1 x1 Tip t2 -doubleL, doubleR :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+doubleL, doubleR :: Sized a -> k -> a -> OrdMap k a -> OrdMap k a -> OrdMap k a 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 s k1 x1 t1 t2 = singleL s k1 x1 t1 t2 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 s k1 x1 t1 t2 = singleR s k1 x1 t1 t2 -bin :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix+bin :: Sized a -> k -> a -> OrdMap k a -> OrdMap k a -> OrdMap k a bin s k x l r   = Bin (size l + size r + s x) k x l r
Data/TrieMap/Regular/Base.hs view
@@ -10,12 +10,16 @@ data (f :*: g) r = f r :*: g r deriving (Show) data (f :+: g) r = L (f r) | R (g r) deriving (Show) newtype L f r = List [f r] deriving (Show)+newtype (f `O` g) r = O (f (g r)) newtype Reg r = Reg {unReg :: r} deriving (Show)  newtype Fix f = In {out :: f (Fix f)}  type family PF a :: * -> * +instance (Functor f, Functor g) => Functor (f `O` g) where+	fmap f (O x) = O (fmap (fmap f) x)+ class Regular a where 	from :: a -> PF a a 	to :: PF a a -> a@@ -60,3 +64,8 @@  infixr 7 :*: infixr 6 :+:++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)
Data/TrieMap/Regular/Class.hs view
@@ -12,58 +12,76 @@  import Control.Applicative -type family TrieMapT (f :: * -> *) :: * -> (* -> *) -> * -> *+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+class OrdT f => TrieKeyT (f :: * -> *) (m :: * -> * -> *) | m -> f, f -> m where+	emptyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => m k a+	nullT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => m k a -> Bool+	sizeT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> m k a -> Int+	lookupT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => f k -> m k a -> Maybe (a)+	lookupIxT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> f k -> m k a -> IndexPos (f k) a+	assocAtT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> Int -> m k a -> IndexPos (f k) a+-- 	updateAtT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> Round -> (Int -> f k -> a -> Maybe (a)) -> Int -> m k a -> m k a+	alterT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (Maybe (a) -> Maybe (a)) -> f k -> m k a -> m k a 	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)+		Sized b -> (f k -> a -> t (b)) -> m k a -> t (m k b) 	foldWithKeyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => -		(f k -> a ix -> b -> b) -> m k a ix -> b -> b+		(f k -> a -> b -> b) -> m k a -> b -> b 	foldlWithKeyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) =>-		(f k -> b -> a ix -> b) -> m k a ix -> b -> b+		(f k -> b -> a -> b) -> m k a -> 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+		Sized b -> Sized c -> EitherMap (f k) (a) (b) (c) -> m k a -> (m k b, m k c)+	splitLookupT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> SplitMap (a) x -> f k ->+		m k a -> (m k a, Maybe x, m k a)+	unionT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> UnionFunc (f k) (a) ->+		m k a -> m k a -> m k a+	isectT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized c -> IsectFunc (f k) (a) (b) (c) ->+		m k a -> m k b -> m k c+	diffT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> DiffFunc (f k) (a) (b) ->+		m k a -> m k b -> m k a+	extractT :: (TrieMapT f ~ m, TrieKey k (TrieMap k), Alternative t) => +		Sized a -> ExtractFunc t (m k a) (f k) a x+-- 	extractMinT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> ExtractFunc (f k) First a (m k a) x+-- 	extractMaxT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> ExtractFunc (f k) Last a (m k a) x+-- 	alterMinT, alterMaxT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (f k -> a -> Maybe (a)) ->+-- 		m k a -> m k a+	isSubmapT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => LEq (a) (b) -> LEq (m k a) (m k b)+	fromListT, fromAscListT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (f k -> a -> a -> a) ->+		[(f k, a)] -> m k a+	fromDistAscListT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> [(f k, a)] -> m k a 	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+-- 	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)+-- mapWithKeyT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>+-- 	Sized b -> (f k -> a -> b) -> TrieMapT f k a -> TrieMapT f k b+-- mapWithKeyT s f m = unId (traverseWithKeyT s (\ k a -> Id (f k a)) m)++guardNullT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => TrieMapT f k a -> Maybe (TrieMapT f k a) 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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => TrieMapT f k a -> [(f k, a)] 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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> f k -> a -> TrieMapT f k a 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+	Sized b -> (f k -> a -> b) -> TrieMapT f k a -> TrieMapT f k b mapWithKeyT s f m = unId (traverseWithKeyT s (Id .: f) m)++aboutT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k), Alternative t) =>+	(f k -> a -> t z) -> TrieMapT f k a -> t z+aboutT f m = fst <$> extractT (const 0) (\ k a -> fmap (flip (,) Nothing) (f k a)) m++{-alterMinT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>+	Sized a -> (f k -> a -> Maybe a) -> TrieMapT f k a -> TrieMapT f k a+alterMinT s f m = maybe m snd (getFirst (extractMinT s (\ k a -> ((), f k a)) m))++alterMaxT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>+	Sized a -> (f k -> a -> Maybe a) -> TrieMapT f k a -> TrieMapT f k a-}+-- alterMaxT s f m = maybe m snd (getLast (extractMaxT s (\ k a -> ((), f k a)) m))
+ Data/TrieMap/Regular/CompMap.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE TemplateHaskell, PatternGuards, UndecidableInstances, FlexibleContexts, TypeOperators, TypeFamilies, MultiParamTypeClasses #-}++module Data.TrieMap.Regular.CompMap () where++import Data.TrieMap.Regular.Base+import Data.TrieMap.Regular.Class+import Data.TrieMap.Regular.Ord+import Data.TrieMap.Regular.Eq+import Data.TrieMap.Regular.TH+import Data.TrieMap.TrieKey+import Data.TrieMap.Rep+import Data.TrieMap.Rep.TH++import Control.Applicative+import Control.Arrow++import Prelude hiding (lookup)++newtype CompMap m g k a = CMap (m (App g k) a)+newtype App f a = A {unA :: f a}+newtype AppMap m k a = AMap (m k a)++type instance TrieMapT (App f) = AppMap (TrieMapT f)+type instance TrieMap (App f r) = AppMap (TrieMapT f) r+type instance TrieMapT (f `O` g) = CompMap (TrieMapT f) g+type instance TrieMap ((f `O` g) r) = CompMap (TrieMapT f) g r++instance EqT f => EqT (App f) where+	eqT0 (==) (A a) (A b) = eqT0 (==) a b++instance OrdT f => OrdT (App f) where+	compareT0 cmp (A a) (A b) = compareT0 cmp a b++instance (EqT f, Eq r) => Eq (App f r) where+	(==) = eqT++instance (OrdT f, Ord g) => Ord (App f g) where+	compare = compareT++$(deriveM [d|+   instance (TrieKeyT f m, Functor f, TrieKeyT g (TrieMapT g)) => TrieKeyT (f `O` g) (CompMap m g) where+	emptyT = CMap emptyT+	nullT (CMap m) = nullT m+	sizeT s (CMap m) = sizeT s m+	lookupT (O x) (CMap m) = lookupT (fmap A x) m+	lookupIxT s (O x) (CMap m) = onKey (O . fmap unA) (lookupIxT s (fmap A x) m)+	assocAtT s i (CMap m) = onKey (O . fmap unA) (assocAtT s i m)+-- 	updateAtT s r f i (CMap m)+-- 		= CMap (updateAtT s r (\ i' -> f i' . O . fmap unA) i m)+	alterT s f (O x) (CMap m) = CMap (alterT s f (fmap A x) m)+	traverseWithKeyT s f (CMap m) = CMap <$> traverseWithKeyT s (f . O . fmap unA) m+	foldWithKeyT f (CMap m) = foldWithKeyT (f . O . fmap unA) m+	foldlWithKeyT f (CMap m) = foldlWithKeyT (f . O . fmap unA) m+	mapEitherT s1 s2 f (CMap m) = (CMap *** CMap) (mapEitherT s1 s2 (f . O . fmap unA) m)+	splitLookupT s f (O k) (CMap m) = CMap `sides` splitLookupT s f (fmap A k) m+	isSubmapT (<=) (CMap m1) (CMap m2) = isSubmapT (<=) m1 m2+	extractT s f (CMap m) = second CMap <$> extractT s (f . O . fmap unA) m+-- 	extractMinT s f (CMap m) = second CMap <$> extractMinT s (f . O . fmap unA) m+-- 	extractMaxT s f (CMap m) = second CMap <$> extractMaxT s (f . O . fmap unA) m+-- 	alterMinT s f (CMap m) = CMap (alterMinT s (f . O . fmap unA) m)+-- 	alterMaxT s f (CMap m) = CMap (alterMaxT s (f . O . fmap unA) m)+	unionT s f (CMap m1) (CMap m2) = CMap (unionT s (f . O . fmap unA) m1 m2)+	isectT s f (CMap m1) (CMap m2) = CMap (isectT s (f . O . fmap unA) m1 m2)+	diffT s f (CMap m1) (CMap m2) = CMap (diffT s (f . O . fmap unA) m1 m2) |])++$(deriveM [d| +   instance TrieKeyT f m => TrieKeyT (App f) (AppMap m) where+	emptyT = AMap emptyT+	nullT (AMap m) = nullT m+	sizeT s (AMap m) = sizeT s m+	lookupT (A k) (AMap m) = lookupT k m+	lookupIxT s (A k) (AMap m) = onKey A (lookupIxT s k m)+	assocAtT s i (AMap m) = onKey A (assocAtT s i m)+-- 	updateAtT s r f i (AMap m) = AMap (updateAtT s r (\ i' -> f i' . A) i m)+	alterT s f (A k) (AMap m) = AMap (alterT s f k m)+	traverseWithKeyT s f (AMap m) = AMap <$> traverseWithKeyT s (f . A) m+	foldWithKeyT f (AMap m) = foldWithKeyT (f . A) m+	foldlWithKeyT f (AMap m) = foldlWithKeyT (f . A) m+	mapEitherT s1 s2 f (AMap m) = (AMap *** AMap) (mapEitherT s1 s2 (f . A) m)+	splitLookupT s f (A k) (AMap m) = AMap `sides` splitLookupT s f k m+	extractT s f (AMap m) = second AMap <$> extractT s (f . A) m+-- 	extractMinT s f (AMap m) = second AMap <$> extractMinT s (f . A) m+-- 	extractMaxT s f (AMap m) = second AMap <$> extractMaxT s (f . A) m+-- 	alterMinT s f (AMap m) = AMap (alterMinT s (f . A) m)+-- 	alterMaxT s f (AMap m) = AMap (alterMaxT s (f . A) m)+	unionT s f (AMap m1) (AMap m2) = AMap (unionT s (f . A) m1 m2)+	isectT s f (AMap m1) (AMap m2) = AMap (isectT s (f . A) m1 m2)+	diffT s f (AMap m1) (AMap m2) = AMap (diffT s (f . A) m1 m2)+	isSubmapT (<=) (AMap m1) (AMap m2) = isSubmapT (<=) m1 m2 |])
Data/TrieMap/Regular/ConstMap.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, UndecidableInstances #-} -module Data.TrieMap.Regular.ConstMap where+module Data.TrieMap.Regular.ConstMap() where  import Data.TrieMap.Regular.Class import Data.TrieMap.Regular.Base@@ -12,24 +12,18 @@  -- import Data.Monoid -newtype KMap m k (a :: * -> *) ix = KMap (m a ix)+newtype KMap m k a = KMap (m a) type instance TrieMapT (K0 a) = KMap (TrieMap a) type instance TrieMap (K0 a r) = TrieMapT (K0 a) r-type instance PF (KMap m k a ix) = PF (m a ix) -instance (Regular (m a ix), Functor (PF (m a ix))) => Regular (KMap m k a ix) where-	from (KMap m) = fmap KMap (from m)-	to = KMap . to . fmap (\ (KMap m) -> m)- 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)+	lookupIxM s (K0 k) (KMap m) = onKey K0 (lookupIxM s k m)+	assocAtM s i (KMap m) = onKey K0 (assocAtM s i m)+-- 	updateAtM s r f i (KMap m) = KMap (updateAtM s r (\ 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@@ -39,10 +33,11 @@ 	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)+	extractM s f (KMap m) = second KMap <$> extractM s (f . K0) m+-- 	extractMinM s f (KMap m) = second KMap <$> extractMinM s (f . K0) m+-- 	extractMaxM s f (KMap m) = second KMap <$> extractMaxM s (f . K0) 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])@@ -55,7 +50,7 @@ 	lookupT = lookupM 	lookupIxT = lookupIxM 	assocAtT = assocAtM-	updateAtT = updateAtM+-- 	updateAtT = updateAtM 	alterT = alterM 	traverseWithKeyT = traverseWithKeyM 	foldWithKeyT = foldWithKeyM@@ -65,10 +60,11 @@ 	unionT = unionM 	isectT = isectM 	diffT = diffM-	extractMinT = extractMinM-	extractMaxT = extractMaxM-	alterMinT = alterMinM-	alterMaxT = alterMaxM+	extractT = extractM+-- 	extractMinT = extractMinM+-- 	extractMaxT = extractMaxM+-- 	alterMinT = alterMinM+-- 	alterMaxT = alterMaxM 	isSubmapT = isSubmapM 	fromListT = fromListM 	fromAscListT = fromAscListM
Data/TrieMap/Regular/Eq.hs view
@@ -1,8 +1,11 @@-{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeOperators #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeOperators #-}  module Data.TrieMap.Regular.Eq where  import Data.TrieMap.Regular.Base+import Data.TrieMap.MultiRec.Base(FamT(..), KeyFam(..))+import Data.TrieMap.MultiRec.Eq(HEq0(..))+import Data.TrieMap.Modifiers  class EqT f where 	eqT0 :: (a -> a -> Bool) -> f a -> f a -> Bool@@ -54,6 +57,12 @@ instance (EqT f, EqT g, Eq r) => Eq ((f :+: g) r) where 	(==) = eqT +instance (EqT f, EqT g) => EqT (f `O` g) where+	eqT0 (==) (O x) (O y) = eqT0 (eqT0 (==)) x y++instance (EqT f, EqT g, Eq r) => Eq ((f `O` g) r) where+	(==) = eqT+ instance Eq a => Eq (K0 a r) where 	K0 a == K0 b = a == b @@ -62,3 +71,17 @@  instance Eq (U0 r) where 	_ == _ = True++instance Eq a => EqT ((,) a) where+	eqT0 (=#=) (a, b) (c, d) = a == c && b =#= d++instance Eq a => EqT (Either a) where+	eqT0 _ (Left a) (Left b) = a == b+	eqT0 (==) (Right a) (Right b) = a == b+	eqT0 _ _ _ = False++instance EqT Ordered where+	eqT0 (==) (Ord x) (Ord y) = x == y++instance EqT Rev where+	eqT0 (==) (Rev x) (Rev y) = y == x
Data/TrieMap/Regular/IdMap.hs view
@@ -10,7 +10,7 @@ import Control.Arrow import Control.Monad -newtype IMap k a ix = IMap (TrieMap k a ix)+newtype IMap k a = IMap (TrieMap k a) type instance TrieMapT I0 = IMap type instance TrieMap (I0 k) = IMap k @@ -19,10 +19,9 @@ 	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)+	lookupIxT s (I0 k) (IMap m) = onKey I0 (lookupIxM s k m)+	assocAtT s i (IMap m) = onKey I0 (assocAtM s i m)+-- 	updateAtT s r f i (IMap m) = IMap (updateAtM s r (\ 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@@ -32,10 +31,11 @@ 	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)+	extractT s f (IMap m) = second IMap <$> extractM s (f . I0) m+-- 	extractMinT s f (IMap m) = second IMap <$> extractMinM s (f . I0) m+-- 	extractMaxT s f (IMap m) = second IMap <$> extractMaxM s (f . I0) 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])@@ -48,7 +48,7 @@ 	lookupM = lookupT 	lookupIxM = lookupIxT 	assocAtM = assocAtT-	updateAtM = updateAtT+-- 	updateAtM = updateAtT 	alterM = alterT 	traverseWithKeyM = traverseWithKeyT 	foldWithKeyM = foldWithKeyT@@ -58,10 +58,11 @@ 	unionM = unionT 	isectM = isectT 	diffM = diffT-	extractMinM = extractMinT-	extractMaxM = extractMaxT-	alterMinM = alterMinT-	alterMaxM = alterMaxT+	extractM = extractT+-- 	extractMinM = extractMinT+-- 	extractMaxM = extractMaxT+-- 	alterMinM = alterMinT +-- 	alterMaxM = alterMaxT 	isSubmapM = isSubmapT 	fromListM = fromListT 	fromAscListM = fromAscListT
Data/TrieMap/Regular/Instances.hs view
@@ -7,3 +7,5 @@ import Data.TrieMap.Regular.RadixTrie import Data.TrieMap.Regular.IdMap import Data.TrieMap.Regular.RegMap+import Data.TrieMap.Regular.CompMap+import Data.TrieMap.Regular.Rep
Data/TrieMap/Regular/Ord.hs view
@@ -1,10 +1,13 @@-{-# LANGUAGE UndecidableInstances, FlexibleContexts, TypeOperators #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances, FlexibleContexts, TypeOperators #-}  module Data.TrieMap.Regular.Ord where  import Data.TrieMap.Regular.Base import Data.TrieMap.Regular.Eq-+import Data.TrieMap.MultiRec.Base(FamT(..), KeyFam(..))+import Data.TrieMap.MultiRec.Ord(HOrd0(..))+import Data.TrieMap.TrieKey+import Data.TrieMap.Modifiers import Data.Monoid  type Comparator a = a -> a -> Ordering@@ -15,6 +18,9 @@ compareT :: (OrdT f, Ord a) => Comparator (f a) compareT = compareT0 compare +-- instance HOrd0 KeyFam r => OrdT (FamT KeyFam r) where+	+ instance Ord a => OrdT (K0 a) where 	compareT0 _ (K0 a) (K0 b) = compare a b @@ -33,6 +39,12 @@ instance (OrdT f, OrdT g, Ord r) => Ord ((f :*: g) r) where 	compare = compareT +instance (OrdT f, OrdT g) => OrdT (f `O` g) where+	compareT0 cmp (O x) (O y) = compareT0 (compareT0 cmp) x y++instance (OrdT f, OrdT g, Ord r) => Ord ((f `O` 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@@ -69,3 +81,19 @@  instance (Regular a, Functor (PF a), OrdT (PF a)) => Ord (Reg a) where 	compare a b = compareT (from' a) (from' b)++instance Ord a => OrdT ((,) a) where+	compareT0 cmp (a, b) (c, d) = compare a c `mappend` cmp b d+	+instance Ord a => OrdT (Either a) where+	compareT0 cmp x y = case (x, y) of+		(Left a, Left b) -> compare a b+		(Right a, Right b) -> cmp a b+		(Left{}, Right{}) -> LT+		(Right{}, Left{}) -> GT++instance OrdT Rev where+	compareT0 cmp (Rev x) (Rev y) = cmp y x++instance OrdT Ordered where+	compareT0 cmp (Ord x) (Ord y) = cmp x y
Data/TrieMap/Regular/ProdMap.hs view
@@ -1,41 +1,81 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts,  TypeOperators, UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell, PatternGuards, TypeFamilies, MultiParamTypeClasses, FlexibleContexts,  TypeOperators, UndecidableInstances #-}  module Data.TrieMap.Regular.ProdMap() where  import Data.TrieMap.Regular.Class import Data.TrieMap.Regular.Base+import Data.TrieMap.Regular.Eq import Data.TrieMap.TrieKey import Data.TrieMap.Applicative+import Data.TrieMap.Sized+import Data.TrieMap.Regular.TH  import Control.Applicative import Control.Arrow  import Data.Maybe+import Data.Monoid+import Data.Sequence (Seq, (|>))+import qualified Data.Sequence as Seq+import Data.Foldable -newtype PMap m1 (m2 :: * -> (* -> *) -> * -> *) k (a :: * -> *) ix = PMap (m1 k (m2 k a) ix)+newtype PMap m1 (m2 :: * -> * -> *) k a = PMap (m1 k (m2 k a)) type instance TrieMapT (f :*: g) = PMap (TrieMapT f) (TrieMapT g) type instance TrieMap ((f :*: g) r) = TrieMapT (f :*: g) r -type instance PF (PMap m1 m2 k a ix) = PF (m1 k (m2 k a) ix)+lastIx :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> TrieMapT f k a -> Int+lastIx s m = fromMaybe (sizeT s m) (getLast (aboutT (\ _ a -> return $ sizeT s m - s a) m)) -instance (Regular (m1 k (m2 k a) ix), Functor (PF (m1 k (m2 k a) ix))) => Regular (PMap m1 m2 k a ix) where-	from (PMap m) = fmap PMap (from m)-	to = PMap . to . fmap (\ (PMap m) -> m)+--maybe (sizeT s m) fst (getLast (extractMaxT s (\ _ a -> (sizeT s m - s a, Just a)) m)) -instance (TrieKeyT f m1, TrieKeyT g m2) => TrieKeyT (f :*: g) (PMap m1 m2) where+$(deriveM [d|+   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)+	lookupIxT s (a :*: b) (PMap m) = case lookupIxT (sizeT s) a m of+		(lb, x, ub) -> let lookupX = do	Asc i' a' m' <- x+						let (lb', x', ub') = lookupIxT s b m'+						let f = onKeyA (a' :*:) . onIndexA (i' +)+						return (f <$> lb', f <$> x', f <$> ub')+			in ((do	Asc iL aL mL <- lb+				fmap (onKeyA (aL :*:) . onIndexA (iL +)) (getMax s mL)) <|>+			    (do	(lb', _, _) <- Last lookupX+			    	lb'),+			    (do	(_, x', _) <- lookupX+			    	x'),+			    (do	(_, _, ub') <- First lookupX+			    	ub') <|>+			    (do Asc iR aR mR <- ub+			    	fmap (onKeyA (aR :*:) . onIndexA (iR +)) (getMin s mR))) +		where	getMin s m = aboutT (\ k a -> return (Asc 0 k a)) m+			getMax s m = aboutT (\ k a -> return (Asc (sizeT s m - s a) k a)) m 	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)+		(lb, x, ub) -> let lookupX = do	Asc i' a' m' <- x+						let (lb', x', ub') = assocAtT s (i - i') m'+						let f = onKeyA (a' :*:) . onIndexA (i' +)+						return (f <$> lb', f <$> x', f <$> ub')+			in ((do	Asc iL aL mL <- lb+				fmap (onKeyA (aL :*:) . onIndexA (iL +)) (getMax mL)) <|>+			    (do	(lb', _, _) <- Last lookupX+			    	lb'),+			    (do	(_, x', _) <- lookupX+			    	x'),+			    (do	(_, _, ub') <- First lookupX+			    	ub') <|>+			    (do	Asc iR aR mR <- ub+			    	fmap (onKeyA (aR :*:) . onIndexA (iR +)) (getMin mR)))+		where	getMin m = aboutT (\ k a -> return (Asc 0 k a)) m+			getMax m = aboutT (\ k a -> return (Asc (sizeT s m - s a) k a)) m+-- 	updateAtT s r f i (PMap m) = PMap (updateAtT (sizeT s) r g i m) where+-- 		g iA a m'+-- 			| not r && i < iA+-- 				= guardNullT (alterMinT s (f iA . (a :*:)) m')+-- 			| r && i >= iA + lastIx s m'+-- 				= guardNullT (alterMaxT s (f (lastIx s m') . (a :*:)) m')+-- 			| otherwise+-- 				= guardNullT (updateAtT s r (\ i' -> f (iA + i') . (a :*:)) (i - iA) m') 	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@@ -51,40 +91,25 @@ 	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+	extractT s f (PMap m) = second PMap <$> extractT (sizeT s) g m where+		g a = second guardNullT <.> extractT s (\ b -> f (a :*: b))+-- 	extractMinT s f (PMap m) = second PMap <$> extractMinT (sizeT s) g m where+-- 		g a = second guardNullT . fromJust . getFirst . extractMinT s (f . (a :*:))+-- 	extractMaxT s f (PMap m) = second PMap <$> extractMaxT (sizeT s) g m where+-- 		g a = second guardNullT . fromJust . getLast . extractMaxT s (f . (a :*:))+-- 	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 +	fromListT s f xs = PMap (mapWithKeyT (sizeT s) (\ a -> fromListT s (\ b -> f (a :*: b))) +		(fromListT (const 1) (const (++)) (breakFst xs)))+	fromAscListT s f xs = PMap (fromDistAscListT (sizeT s)+		[(a, fromAscListT s (\ b -> f (a :*: b)) ys) | (a, ys) <- breakFst xs])+	+   breakFst :: (EqT f, Eq k) => [((f :*: g) k, a)] -> [(f k, [(g k, a)])]+   breakFst [] = []+   breakFst ((a :*: b, v):xs) = breakFst' a (Seq.singleton (b, v)) xs where+   	breakFst' a vs ((a' :*: b', v):xs)+		| a `eqT` a'	= breakFst' a (vs |> (b', v)) xs+		| otherwise	= (a, toList vs):breakFst' a' (Seq.singleton (b', v)) xs+	breakFst' a vs [] = [(a, toList vs)]+	|])
Data/TrieMap/Regular/RadixTrie.hs view
@@ -1,14 +1,18 @@-{-# LANGUAGE Rank2Types, PatternGuards, FlexibleContexts, TypeFamilies, UndecidableInstances, MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell, Rank2Types, PatternGuards, FlexibleContexts, TypeFamilies, UndecidableInstances, MultiParamTypeClasses #-} -module Data.TrieMap.Regular.RadixTrie where+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.Regular.TH import Data.TrieMap.Sized import Data.TrieMap.TrieKey import Data.TrieMap.Applicative+import Data.TrieMap.Rep+import Data.TrieMap.Rep.TH+import qualified Data.TrieMap.MultiRec.Base as MR  import Control.Arrow import Control.Applicative@@ -21,28 +25,27 @@  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)+data Edge f (m :: * -> * -> *) k a = Edge {-# UNPACK #-} !Int [f k] (Maybe (a)) (m k (Edge f m k a))+type Edge' f k a = Edge f (TrieMapT f) k a+type MEdge f k m a = Maybe (Edge f m k a)+type MEdge' f k a = Maybe (Edge' f k a) --- type instance PF (Edge f m k a ix) = (K0 (L f k) :*: K0 (Maybe (a ix)) :*: L (K0 k :*: I0) :*: K0 Int)--- type instance (RadixTrie f k a ix) = U0 :+: PF (Edge f m k a ix)+-- type instance PF (Edge f m k a) = (K0 (L f k) :*: K0 (Maybe (a)) :*: L (K0 k :*: I0) :*: K0 Int)+-- type instance (RadixTrie f k a) = U0 :+: PF (Edge f m k a) --- instance (TrieKeyT f m, m ~ TrieMapT f, TrieKey k (TrieMap k)) => Regular (Edge f m k a ix) where+-- instance (TrieKeyT f m, m ~ TrieMapT f, TrieKey k (TrieMap k)) => Regular (Edge f m k a) where -- 	from (Edge n ks v ts) = K0 (List ks) :*: K0 v :*:  -newtype RadixTrie f k a ix = Radix (MEdge' f k a ix)+newtype RadixTrie f k a = Radix (MEdge' f k a) -- 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 :: (TrieKeyT f m, m ~ TrieMapT f, TrieKey k (TrieMap k)) => Sized a -> [f k] -> Maybe (a) -> m k (Edge f m k a) -> Edge f m k a 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@@ -50,10 +53,9 @@ 	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)+	lookupIxT s (List ks) (Radix m) = maybe (mzero, mzero, mzero) (onKey List . lookupIxE s 0 ks) m+	assocAtT s i (Radix m) = maybe (mzero, mzero, mzero) (onKey List . assocAtE s 0 i) m+-- 	updateAtT s r f i (Radix m) = Radix (m >>= updateAtE s r (\ 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@@ -63,10 +65,11 @@ 	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))+	extractT s f (Radix m) = maybe empty (second Radix <.> extractE s (f . List)) m+-- -- 	extractMinT s f (Radix m) = First m >>= fmap (second Radix) . extractMinE s (f . List)+-- 	extractMaxT s f (Radix m) = Last m >>= fmap (second Radix) . extractMaxE s (f . List)+-- 	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])@@ -78,7 +81,7 @@ 	lookupM = lookupT 	lookupIxM = lookupIxT 	assocAtM = assocAtT-	updateAtM = updateAtT+-- 	updateAtM = updateAtT 	alterM = alterT 	traverseWithKeyM = traverseWithKeyT 	foldWithKeyM = foldWithKeyT@@ -88,10 +91,11 @@ 	unionM = unionT 	isectM = isectT 	diffM = diffT-	extractMinM = extractMinT-	extractMaxM = extractMaxT-	alterMinM = alterMinT-	alterMaxM = alterMaxT+	extractM = extractT+-- 	extractMinM = extractMinT+-- 	extractMaxM = extractMaxT+-- 	alterMinM = alterMinT+-- 	alterMaxM = alterMaxT 	isSubmapM = isSubmapT 	fromListM = fromListT 	fromAscListM = fromAscListT@@ -117,7 +121,7 @@ -- 	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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Edge' f k a -> MEdge' f k a compact e@(Edge s ks Nothing ts) = case assocsT ts of 	[]	-> Nothing 	[~(k, e'@(Edge s' ls v ts'))]@@ -125,16 +129,16 @@ 	_	-> Just e compact e = Just e -cons :: f k -> Edge' f k a ix -> Edge' f k a ix+cons :: f k -> Edge' f k a -> Edge' f k a 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+cat :: [f k] -> Edge' f k a -> Edge' f k a 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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> [f k] -> Maybe (a) -> MEdge' f k a 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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => [f k] -> Edge' f k a -> Maybe (a) lookupE ks (Edge _ ls v ts) = match ks ls where 	match (k:ks) (l:ls) 		| k `eqT` l	= match ks ls@@ -144,7 +148,7 @@ 	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+	Sized a -> (Maybe (a) -> Maybe (a)) -> [f k] -> Edge' f k a -> MEdge' f k a 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)@@ -162,23 +166,23 @@ 	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)+	Sized b -> ([f k] -> a -> t (b)) -> Edge' f k a -> t (Edge' f k b) 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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => ([f k] -> a -> b -> b) -> Edge' f k a -> 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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => ([f k] -> b -> a -> b) -> Edge' f k a -> 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)+	EitherMap (EitherMap [f k] (a) (b) (c)) (Edge' f k a) (Edge' f k b) (Edge' f k c) 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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> SplitMap (a) x -> [f k] -> SplitMap (Edge' f k a) 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)@@ -193,7 +197,7 @@ 		(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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> UnionFunc (UnionFunc [f k] (a)) (Edge' f k a) 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)@@ -209,34 +213,37 @@ 	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''))))+extractE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k), Alternative t) => Sized a -> ([f k] -> a -> t (x, Maybe a)) -> +	Edge' f k a -> t (x, MEdge' f k a)+extractE s f (Edge _ ks v ts) = (maybe empty (second (\ v' -> compact (edge s ks v' ts)) <.> f ks) v) <|>+  		(second (compact . edge s ks Nothing) <$> extractT edgeSize g ts)+	where	g l = extractE s (\ ls -> f (ks ++ l:ls)) -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''))))+aboutE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k), Alternative t) => ([f k] -> a -> t x) ->+	Edge' f k a -> t x+aboutE f = fst <.> extractE (const 0) (\ k a -> fmap (flip (,) Nothing) (f k a)) -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))+-- extractMaxE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> ([f k] -> a -> (x, Maybe a)) -> +-- 	Edge' f k a -> Last (x, MEdge' f k a)+-- extractMaxE s f (Edge _ ks v ts) = (do+-- 		v <- Last v+-- 		let (x, v') = f ks v+-- 		return (x, compact (edge s ks v' ts))) <|> +--  			(second (compact . edge s ks v) <.> extractMaxT edgeSize g ts)+-- 	where	g x = fromJust . getLast . extractMaxE s (\ xs -> f (ks ++ x:xs)) -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))+-- alterMinE, alterMaxE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a ->+-- 	([f k] -> a -> Maybe (a)) -> Edge' f k a -> MEdge' f k a+-- 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)+	IsectFunc (IsectFunc [f k] (a) (b) (c)) (Edge' f k a) (Edge' f k b) (Edge' f k c) 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@@ -248,7 +255,7 @@ 		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)+	DiffFunc (DiffFunc [f k] (a) (b)) (Edge' f k a) (Edge' f k b) 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@@ -260,7 +267,7 @@ 	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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => LEq (a) (b) -> LEq (Edge' f k a) (Edge' f k b) 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@@ -281,7 +288,7 @@ 		| 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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> ([f k] -> a -> a -> a) -> [([f k], a)] -> MEdge' f k a fromListE _ _ [] = Nothing fromListE s f xs = case filterer eqT (f []) xs of 	(Nothing, [(k, xs)]) -> cons k <$> fromListE s (f . (k:)) xs@@ -289,42 +296,101 @@ 				(fromListT (const 1) (\ _ (K0 xs) (K0 ys) -> K0 (ys ++ xs)) [(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+	Sized a -> ([f k] -> a -> a -> a) -> [([f k], a)] -> MEdge' f k a 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)+	Sized a -> Int -> [f k] -> Edge' f k a -> IndexPos [f k] a 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+lookupIxE s i ks e@(Edge _ ls v ts) = match ks ls where+	match (k:ks) (l:ls) = case compareT k l of+		LT	-> (mzero, mzero, getMin (Asc i) e)+		EQ	-> match ks ls+		GT	-> (getMax (Asc i) e, mzero, mzero)+	match (k:ks) [] = case lookupIxT edgeSize k ts of+		(lb, x, ub) -> let lookupX = do	Asc iK k' e' <- x+						let (lb', x', ub') = lookupIxE s (i + iK) ks e'+						let f = onKeyA ((ls ++) . (k' :))+						return (f <$> lb', f <$> x', f <$> ub')+			in ((do	Asc iL kL eL <- lb+				getMax (\ ksL -> Asc (i + iL) (ls ++ kL:ksL)) eL) <|>+			    (do	(lb', _, _) <- Last lookupX+			    	lb'),+			    (do	(_, x', _) <- lookupX+			    	x'),+			    (do (_, _, ub') <- First lookupX+			    	ub') <|>+			    (do	Asc iR kR eR <- ub+			    	getMin (\ ksR -> Asc (i + iR) (ls ++ kR:ksR)) eR))+	match [] [] = (mzero, Asc i ls <$> v, aboutT+				(\ x -> aboutE (\ xs v' -> return (Asc (i + maybe 0 s v) (ls ++ x:xs) v'))) ts)+	match [] _ = (mzero, mzero, getMin (Asc i) e)+	getMin f = aboutE (return .: f)+	getMax f = aboutE (return .: f)  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+	Sized a -> Int -> Int -> Edge' f k a -> IndexPos [f k] a+assocAtE s i0 i (Edge _ ks Nothing ts) = case assocAtT edgeSize i ts of+	(lb, x, ub) -> let lookupX = do	Asc i' l e' <- x+					return (onKey ((ks ++) . (l:)) (assocAtE s (i0 + i') (i - i') e'))+		in ((do	Asc iL lL eL <- lb+			getMax (\ ls -> Asc (i0 + iL) (ks ++ lL:ls)) eL) <|>+		    (do	(lb', _, _) <- Last lookupX+		    	lb'),+		    (do	(_, x', _) <- lookupX+		    	x'),+		    (do	(_, _, ub') <- First lookupX+		    	ub') <|>+		    (do	Asc iR lR eR <- ub+		    	getMin (\ ls -> Asc (i0 + iR) (ks ++ lR:ls)) eR))+	where 	getMin f e = aboutE (return .: f) e+		getMax f e = aboutE (return .: f) e+assocAtE s i0 i (Edge _ ks (Just v) ts)+	| i < sv	= (mzero, return (Asc i ks v), aboutT (\ l -> aboutE (\ ls v' -> return (Asc (i0 + sv) (ks ++ l:ls) v'))) ts)+	| (lb, x, ub) <- assocAtT edgeSize (i - sv) ts+		= let lookupX = do	Asc i' l e' <- x+					return (onKey ((ks ++) . (l:)) (assocAtE s (i0 + i' + sv) (i - sv - i') e'))+		in ((do	Asc iL lL eL <- lb+			getMax (\ ls -> Asc (i0 + iL + sv) (ks ++ lL:ls)) eL) <|>+		    (do	(lb', _, _) <- Last lookupX+		    	lb'),+		    (do	(_, x', _) <- lookupX+		    	x'),+		    (do	(_, _, ub') <- First lookupX+		    	ub') <|>+		    (do	Asc iR lR eR <- ub+		    	getMin (\ ls -> Asc (i0 + iR + sv) (ks ++ lR:ls)) eR))+	where 	getMin f = aboutE (return .: f)+		getMax f = aboutE (return .: f)+		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)+-- alterMinE, alterMaxE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => +-- 	Sized a -> ([f k] -> a -> Maybe a) -> Edge' f k a -> MEdge' f k a+-- alterMinE s f e = maybe (Just e) snd $ getFirst (extractMinE s (\ k a -> ((), f k a)) e)+-- alterMaxE s f e = maybe (Just e) snd $ getLast (extractMaxE s (\ k a -> ((), f k a)) e)++-- updateAtE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>+-- 	Sized a -> Round -> (Int -> [f k] -> a -> Maybe (a)) -> Int -> Edge' f k a -> MEdge' f k a+-- updateAtE s r f i (Edge sz ks Nothing ts) = compact (edge s ks Nothing (updateAtT edgeSize r g i ts)) where+-- 	g iT l e+-- 		| not r, i < iT+-- 			= alterMinE s (f iT . (ks++) . (l:)) e+-- 		| r, i >= iT + edgeSize e+-- 			= alterMaxE s (\ ls a -> f (edgeSize e + iT - s a) (ks ++ l:ls) a) e+-- 		| otherwise+-- 			= updateAtE s r (\ i' ls -> f (i' + iT) (ks ++ l:ls)) (i - iT) e+-- updateAtE s r 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 r g i1 ts))+-- 	where	sv = s v+-- 		i1 = i - sv+-- 		g iT l e +-- 			| not r, i1 < iT +-- 				= alterMinE s (f (iT + sv) . (ks ++) . (l:)) e+-- 			| r, i1 >= iT + edgeSize e+-- 				= alterMaxE s (\ ls a -> f (iT + sv + edgeSize e + iT - s a) (ks ++ l:ls) a) e+-- 			| otherwise+-- 				= updateAtE s r (\ i' ls -> f (sv + iT + i') (ks ++ l:ls)) (i - sv - iT) e
Data/TrieMap/Regular/RegMap.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeFamilies, MultiParamTypeClasses #-} -module Data.TrieMap.Regular.RegMap where+module Data.TrieMap.Regular.RegMap() where  import Data.TrieMap.Regular.Class import Data.TrieMap.Regular.Base@@ -10,17 +10,16 @@ import Control.Arrow import Control.Monad -newtype RegMap k m (a :: * -> *) ix = RegMap (m (Reg k) a ix)+newtype RegMap k m a = RegMap (m (Reg k) a)  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)+	lookupIxM s k (RegMap m) = onKey to' (lookupIxT s (from' k) m)+	assocAtM s i (RegMap m) = onKey to' (assocAtT s i m)+-- 	updateAtM s r f i (RegMap m) = RegMap (updateAtT s r (\ 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@@ -30,10 +29,11 @@ 	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)+	extractM s f (RegMap m) = second RegMap <$> extractT s (f . to') m+-- 	extractMinM s f (RegMap m) = second RegMap <$> extractMinT s (f . to') m+-- 	extractMaxM s f (RegMap m) = second RegMap <$> extractMaxT s (f . to') 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])
+ Data/TrieMap/Regular/Rep.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE UndecidableInstances, TypeOperators, TypeFamilies, TemplateHaskell #-}++module Data.TrieMap.Regular.Rep where++import Data.TrieMap.Rep+import Data.TrieMap.Rep.TH+import Data.TrieMap.Regular.Base++type instance RepT (K0 a) = K0 (Rep a)+type instance RepT I0 = I0+type instance RepT U0 = U0+type instance RepT (L f) = L (RepT f)+type instance RepT (f :*: g) = RepT f :*: RepT g+type instance RepT (f :+: g) = RepT f :+: RepT g+type instance RepT (f `O` g) = RepT f `O` RepT g++type instance Rep (K0 a b) = RepT (K0 a) b+type instance Rep (I0 a) = I0 (Rep a)+type instance Rep (U0 a) = U0 a+type instance Rep (L f a) = L (RepT f) (Rep a)+type instance Rep ((f :*: g) a) = RepT (f :*: g) (Rep a)+type instance Rep ((f :+: g) a) = RepT (f :+: g) (Rep a)+type instance Rep ((f `O` g) a) = RepT (f `O` g) (Rep a)+type instance Rep (Fix f) = Fix (RepT f)++instance Repr a => ReprT (K0 a) where+	toRepTMap _ (K0 a) = K0 (toRep a)+	fromRepTMap _ (K0 a) = K0 (fromRep a)++instance Repr a => Repr (K0 a b) where+	toRep = toRepT+	fromRep = fromRepT++$(genRepT [d|+   instance ReprT I0 where+	toRepTMap = fmap+	fromRepTMap = fmap |])++instance ReprT U0 where+	toRepTMap _ _ = U0+	fromRepTMap _ _ = U0++instance Repr (U0 a) where+	toRep _ = U0+	fromRep _ = U0++$(genRepT [d|+   instance ReprT f => ReprT (L f) where+	toRepTMap f (List xs) = List (map (toRepTMap f) xs)+	fromRepTMap f (List xs) = List (map (fromRepTMap f) xs) |])++$(genRepT [d|+   instance (ReprT f, ReprT g) => ReprT (f :*: g) where+	toRepTMap f (x :*: y) = toRepTMap f x :*: toRepTMap f y+	fromRepTMap f (x :*: y) = fromRepTMap f x :*: fromRepTMap f y |])++$(genRepT [d|+   instance (ReprT f, ReprT g) => ReprT (f :+: g) where+	toRepTMap f (L a) = L (toRepTMap f a)+	toRepTMap f (R b) = R (toRepTMap f b)+	fromRepTMap f (L a) = L (fromRepTMap f a)+	fromRepTMap f (R b) = R (fromRepTMap f b) |])++$(genRepT [d|+   instance (ReprT f, ReprT g) => ReprT (f `O` g) where+	toRepTMap f (O x) = O (toRepTMap (toRepTMap f) x)+	fromRepTMap f (O x) = O (fromRepTMap (fromRepTMap f) x) |])++instance ReprT f => Repr (Fix f) where+	toRep (In x) = In (toRepTMap toRep x)+	fromRep (In x) = In (fromRepTMap fromRep x)
Data/TrieMap/Regular/Sized.hs view
@@ -5,5 +5,5 @@ import Data.TrieMap.Regular.Base import Data.TrieMap.Sized -sizeK0 :: Sized (K0 a)+sizeK0 :: Sized (K0 a b) sizeK0 _ = 1
+ Data/TrieMap/Regular/TH.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE UndecidableInstances, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, QuasiQuotes #-}++module Data.TrieMap.Regular.TH where++import Data.TrieMap.Regular.Class+import Data.TrieMap.TrieKey+import Language.Haskell.TH++deriveM :: Q [Dec] -> Q [Dec]+deriveM decs = do+	iT@(InstanceD cxt (triekeyt `AppT` f `AppT` m) _:_) <- decs+	(InstanceD _ _ myDecs:_) <- [d|+	  instance (TrieKeyT f m, Ord (f k), TrieKey k mm) => TrieKey (f k) (m 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+		extractM = extractT+-- 		extractMinM = extractMinT+-- 		extractMaxM = extractMaxT+-- 		alterMinM = alterMinT+-- 		alterMaxM = alterMaxT+		isSubmapM = isSubmapT+		fromListM = fromListT+		fromAscListM = fromAscListT+		fromDistAscListM = fromDistAscListT |]+	k <- mkVar "k"+	let triekey = ConT ''TrieKey+	let triemap = ConT ''TrieMap+	let ordT = ConT ''Ord+	return (InstanceD (triekey `AppT` k `AppT` (triemap `AppT` k):ordT `AppT` (f `AppT` k):cxt)+			(triekey `AppT` (f `AppT` k) `AppT` (m `AppT` k)) myDecs:iT)++mkVar :: String -> TypeQ+mkVar x = varT =<< newName x
Data/TrieMap/Regular/UnionMap.hs view
@@ -1,24 +1,38 @@-{-# LANGUAGE TypeOperators, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE PatternGuards, FlexibleInstances, TemplateHaskell, TypeOperators, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}  module Data.TrieMap.Regular.UnionMap() where  import Data.TrieMap.Regular.Class import Data.TrieMap.Regular.Base+import Data.TrieMap.Regular.TH import Data.TrieMap.TrieKey+import Data.TrieMap.Applicative+-- import Data.TrieMap.Rep+-- import Data.TrieMap.Rep.TH  import Control.Applicative import Control.Arrow import Control.Monad  import Data.Either+import Data.Monoid  -- import Generics.MultiRec.Base-data UnionMap m1 m2 k (a :: * -> *) ix = m1 k a ix :&: m2 k a ix+data UnionMap m1 m2 k a = m1 k a :&: m2 k a  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+-- type instance RepT (UnionMap m1 m2 k) = RepT (m1 k) :*: RepT (m2 k)+-- type instance Rep (UnionMap f g k a) = RepT (UnionMap f g k) (Rep a)+-- +-- -- $(genRepT [d|+--    instance (ReprT (m1 k), ReprT (m2 k)) => ReprT (UnionMap m1 m2 k) where+-- 	toRepT (m1 :&: m2) = toRepT m1 :*: toRepT m2+-- 	fromRepT (m1 :*: m2) = fromRepT m1 :&: fromRepT m2 |])++$(deriveM [d| +   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@@ -26,18 +40,23 @@ 		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+		L k | (lb, x, ub) <- onKey L (lookupIxT s k m1)+			-> (lb, x, ub <|> fmap (onKeyA R . onIndexA (sizeT s m1 +)) (getMin m2))+		R k | (lb, x, ub) <- onIndex (sizeT s m1 +) (onKey R (lookupIxT s k m2))+			-> (fmap (onKeyA L) (getMax m1) <|> lb, x, ub)+		where	getMin = aboutT (return .: Asc 0)+			getMax m = aboutT (\ k a -> return (Asc (sizeT s m - s a) k a)) m 	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+		| i < s1	= onKey L (assocAtT s i m1)+		| otherwise	= onKey R (onIndex (s1 +) (assocAtT s (i - s1) m2)) 		where s1 = sizeT s m1+{-	updateAtT s r f i (m1 :&: m2)+		| not r, i >= maxIx m1+				= m1 :&: updateAtT s r (\ i' -> f (i' + s1) . R) (i - s1) m2+		| i < s1	= updateAtT s r (\ i' -> f i' . L) i m1 :&: m2+		| otherwise	= m1 :&: updateAtT s r (\ i' -> f (i' + s1) . R) (i - s1) m2+		where 	s1 = sizeT s m1+			maxIx m = maybe (sizeT s m) fst $ getLast (extractMaxT s (\ _ v -> (sizeT s m - s v, Just v)) m)-} 	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@@ -54,56 +73,22 @@ 	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+	extractT s f (m1 :&: m2) = second (:&: m2) <$> extractT s (f . L) m1 <|>+		second (m1 :&:) <$> extractT s (f . R) m2+-- 	extractMinT s f (m1 :&: m2) = second (:&: m2) <$> extractMinT s (f . L) m1 <|>+-- 		second (m1 :&:) <$> extractMinT s (f . R) m2+-- 	extractMaxT s f (m1 :&: m2) = second (:&: m2) <$> extractMaxT s (f . L) m1 <|>+-- 		second (m1 :&:) <$> extractMaxT s (f . R) 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+		(ys, zs) -> fromDistAscListT s ys :&: fromDistAscListT s zs |])
Data/TrieMap/Regular/UnitMap.hs view
@@ -1,13 +1,18 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}+{-# LANGUAGE UndecidableInstances, TemplateHaskell, MultiParamTypeClasses, TypeFamilies #-}  module Data.TrieMap.Regular.UnitMap() where  import Data.TrieMap.Regular.Class import Data.TrieMap.Regular.Base import Data.TrieMap.TrieKey+import Data.TrieMap.Rep+import Data.TrieMap.Rep.Instances+import Data.TrieMap.Rep.TH+import Data.TrieMap.Applicative  import Control.Applicative import Control.Arrow+import Control.Monad  import Data.Foldable import Data.Maybe@@ -16,18 +21,34 @@  import Prelude hiding (foldr, foldl) -newtype M k a ix = M (Maybe (a ix))+newtype M k a = M (Maybe a) type instance TrieMapT U0 = M type instance TrieMap (U0 r) = M r +type instance RepT (M k) = RepT Maybe+type instance Rep (M k a) = RepT Maybe (Rep a)++$(genRepT [d|+   instance ReprT (M k) where+	toRepT (M a) = toRepT a+	fromRepT = M . fromRepT |])+ 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)+	lookupIxM s _ (M a) = (mzero, Asc 0 U0 <$> a, mzero)+	assocAtM s i (M a)+		| i < 0	= (mzero, mzero, Asc 0 U0 <$> First a)+		| i > maybe 0 s a+			= (Asc 0 U0 <$> Last a, mzero, mzero)+		| otherwise+			= (mzero, Asc 0 U0 <$> a, mzero)+-- 	updateAtM s r f i (M v) = case v of+-- 		Just a	| not r && i <= 0	-> M (v >>= f 0 U0)+-- 			| r && i >= 0		-> M (v >>= f 0 U0)+-- 		_ -> M v 	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@@ -38,12 +59,11 @@ 	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+	extractM _ f (M a) = maybe empty (second M <.> f U0) a+-- 	extractMinM _ f (M a) = fmap (second M . f U0) (First a)+-- 	extractMaxM _ f (M a) = fmap (second M . f U0) (Last a)+-- 	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@@ -55,7 +75,7 @@ 	lookupT = lookupM 	lookupIxT = lookupIxM 	assocAtT = assocAtM-	updateAtT = updateAtM+-- 	updateAtT = updateAtM 	alterT = alterM 	traverseWithKeyT = traverseWithKeyM 	foldWithKeyT = foldWithKeyM@@ -65,10 +85,11 @@ 	unionT = unionM 	isectT = isectM 	diffT = diffM-	extractMinT = extractMinM-	extractMaxT = extractMaxM-	alterMinT = alterMinM-	alterMaxT = alterMaxM+	extractT = extractM+-- 	extractMinT = extractMinM+-- 	extractMaxT = extractMaxM+-- 	alterMinT = alterMinM+-- 	alterMaxT = alterMaxM 	isSubmapT = isSubmapM 	fromListT = fromListM 	fromAscListT = fromAscListM
+ Data/TrieMap/Rep.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE UndecidableInstances, FlexibleContexts, TypeFamilies, KindSignatures #-}++module Data.TrieMap.Rep where++type family Rep a+type family RepT (f :: * -> *) :: * -> *++class Repr a where+	toRep :: a -> Rep a+	fromRep :: Rep a -> a++class Functor (RepT f) => ReprT f where+	toRepT :: f a -> RepT f a+	fromRepT :: RepT f a -> f a+	toRepTMap :: (a -> b) -> f a -> RepT f b+	fromRepTMap :: (b -> a) -> RepT f b -> f a++	toRepT = toRepTMap id+	fromRepT = fromRepTMap id+	toRepTMap f = fmap f . toRepT+	fromRepTMap f = fromRepT . fmap f++{-# RULES+	"toRep/fromRep" forall x . toRep (fromRep x) = x;+-- 	"fromRep/toRep" forall x . fromRep (toRep x) = x;+	#-}
+ Data/TrieMap/Rep/Instances.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeFamilies, TypeOperators, TemplateHaskell #-}++module Data.TrieMap.Rep.Instances()  where++import Data.TrieMap.Rep+import Data.TrieMap.Rep.TH+import Data.TrieMap.Regular.Base+import Data.TrieMap.OrdMap+import Data.TrieMap.Modifiers+-- import Language.Haskell.TH++import Control.Arrow++import Data.Char+import Data.Int+import Data.Word+import Data.Foldable (toList)+import Data.Bits+import Data.Array.IArray+import Data.ByteString hiding (map)+import qualified Data.ByteString as BS++import Data.Sequence (Seq, (|>))+import qualified Data.Sequence as Seq+import qualified Data.Foldable as Fold++import qualified Data.Map as Map+import qualified Data.Set as Set++import Prelude hiding (concat, take, length)++type Pair a = (,) a+type Sum a = Either a++type instance RepT Maybe = U0 :+: I0+type instance Rep (Maybe a) = RepT Maybe (Rep a)++$(genRepT [d|+   instance ReprT Maybe where+	toRepTMap f = maybe (L U0) (R . I0 . f)+	fromRepTMap _ L{} = Nothing+	fromRepTMap f (R (I0 a)) = Just (f a) |])++type instance RepT [] = L I0+type instance Rep [a] = L I0 (Rep a)++$(genRepT [d| +   instance ReprT [] where+	toRepTMap f = List . map (I0 . f)+	fromRepTMap f (List xs) = map (f . unI0) xs |])++type instance RepT ((,) a) = Pair (Rep a)+type instance Rep (a, b) = RepT ((,) a) (Rep b)++$(genRepT [d|+    instance Repr a => ReprT ((,) a) where+	toRepTMap f = toRep *** f+	fromRepTMap f = fromRep *** f |])++-- instance (ReprT ((,) a), Repr b) => Repr ((,) a b) where++-- instance (Repr a, Repr b) => Repr (a, b) where+-- 	toRep = fmap toRep . toRepT+-- 	fromRep = fromRepT . fmap fromRep++type instance RepT ((,,) a b) = K0 (Rep a) :*: K0 (Rep b) :*: I0+type instance Rep (a, b, c) = RepT ((,,) a b) (Rep c)++$(genRepT [d|+   instance (Repr a, Repr b) => ReprT ((,,) a b) where+	toRepTMap f (a, b, c) = K0 (toRep a) :*: K0 (toRep b) :*: I0 (f c)+	fromRepTMap f (K0 a :*: K0 b :*: I0 c) = (fromRep a, fromRep b, f c) |])++type instance RepT ((,,,) a b c) = K0 (Rep a) :*: K0 (Rep b) :*: K0 (Rep c) :*: I0+type instance Rep (a, b, c, d) = RepT ((,,,) a b c) (Rep d)++$(genRepT [d|+   instance (Repr a, Repr b, Repr c) => ReprT ((,,,) a b c) where+	toRepTMap f (a, b, c, d) = K0 (toRep a) :*: K0 (toRep b) :*: K0 (toRep c) :*: I0 (f d)+	fromRepTMap f (K0 a :*: K0 b :*: K0 c :*: I0 d) = (fromRep a, fromRep b, fromRep c, f d) |])++type instance RepT (Either a) = Sum (Rep a)+type instance Rep (Either a b) = RepT (Either a) (Rep b)++$(genRepT [d|+  instance Repr a => ReprT (Either a) where+	toRepTMap f = either (Left . toRep) (Right . f)+	fromRepTMap f = either (Left . fromRep) (Right . f) |])++type instance Rep Bool = (U0 :+: U0) (U0 ())+instance Repr Bool where+	toRep False = L U0+	toRep True = R U0+	fromRep L{} = False+	fromRep R{} = True++type instance Rep Char = Word32+instance Repr Char where+	toRep = fromIntegral . ord+	fromRep = chr . fromIntegral++type instance Rep () = U0 ()+instance Repr () where+	toRep _ = U0+	fromRep _ = ()++type instance Rep Double = Ordered Double+instance Repr Double where+	toRep = Ord+	fromRep = unOrd++type instance Rep Int = Rep Int32+instance Repr Int where+	toRep = toSigned+	fromRep = fromSigned++type instance Rep Word8 = Word32+instance Repr Word8 where+	toRep = fromIntegral+	fromRep = fromIntegral++type instance Rep Word16 = Word32+instance Repr Word16 where+	toRep = fromIntegral+	fromRep = fromIntegral++type instance Rep Word = Word32+instance Repr Word where+	toRep = fromIntegral+	fromRep = fromIntegral++type instance Rep Int8 = Rep Int32++instance Repr Int8 where+	toRep = toSigned+	fromRep = fromSigned++type instance Rep Int16 = Rep Int32+instance Repr Int16 where+	toRep = toSigned+	fromRep = fromSigned++type instance Rep Int32 = Sum (Rev Word32) Word32+instance Repr Int32 where+	toRep = toSigned+	fromRep = fromSigned++type instance Rep Word64 = Pair Word32 Word32+instance Repr Word64 where+	toRep x = (fromIntegral (x `shiftR` 32), fromIntegral x)+	fromRep (x, y) = fromIntegral x `shiftL` 32 .|. fromIntegral y++type instance Rep Int64 = Sum (Rev (Rep Word64)) (Rep Word64)+instance Repr Int64 where+	toRep x | x < 0	= Left (Rev (toRep' (fromIntegral (-x))))+		| otherwise = Right (toRep' (fromIntegral x))+		where toRep' = toRep :: Word64 -> Rep Word64+	fromRep (Left (Rev x)) = - fromIntegral ((fromRep :: Rep Word64 -> Word64) x)+	fromRep (Right x) = fromIntegral ((fromRep :: Rep Word64 -> Word64) x)++{-# INLINE toSigned #-}+toSigned :: Integral a => a -> Sum (Rev Word32) Word32+toSigned x+	| x < 0		= Left (Rev (fromIntegral (-x)))+	| otherwise	= Right (fromIntegral x)++{-# INLINE fromSigned #-}+fromSigned :: Integral a => Sum (Rev Word32) Word32 -> a+fromSigned = either (\ (Rev x) -> - fromIntegral x) fromIntegral++type instance Rep Word32 = Word32+instance Repr Word32 where+	toRep = id+	fromRep = id++type instance Rep ByteString = (L I0 :*: I0) Word32+instance Repr ByteString where+	toRep xs = List (toList64 xs) :*: I0 (fromIntegral (length xs))+	fromRep (List xs :*: I0 n) = case xs of+		[]	-> BS.empty+		(I0 x:xs) -> fst (unfoldrN (fromIntegral n) toBlock (W (Words 3 x) xs))++data Words = Words {ix :: {-# UNPACK #-} !Int, word32 :: {-# UNPACK #-} !Word32}+data Words' = W {-# UNPACK #-} !Words [I0 Word32]++toList64 :: ByteString -> [I0 Word32]+toList64 xs = case BS.foldl c (Words 4 0, Seq.empty) xs of+	(Words i w32, ys) -> toList ys ++ [I0 w32]+	where	fS :: Word8 -> Int -> Word32+		fS w x = fromIntegral w `shiftL` x+		(Words 0 w, xs) `c` w8+			= (Words 3 (w .|. sL w8 24), xs |> I0 w)+		(Words (i+1) w, xs) `c` w8+			= (Words i (w .|. sL w8 (8 * i)), xs)+		sL :: Word8 -> Int -> Word32+		w `sL` x = fromIntegral w `shiftL` x++toBlock :: Words' -> Maybe (Word8, Words')+toBlock (W (Words i0@(i+1) w) xs) = Just (extract w (8 * i0), (W (Words i w) xs))+	where	extract :: Word32 -> Int -> Word8+		extract w x = fromIntegral (w `shiftR` x)+toBlock (W (Words 0 w) (I0 x:xs)) = Just (fromIntegral w, (W (Words 3 x) xs))+toBlock _ = Nothing++type instance RepT (Array i) = L (Pair (Rep i)) :*: K0 (Pair (Rep i) (Rep i))+type instance Rep (Array i e) = RepT (Array i) (Rep e)++$(genRepT [d| +   instance (Repr i, Ix i) => ReprT (Array i) where+	toRepTMap f arr = List [(toRep i, f a) | (i, a) <- assocs arr] :*: K0 (toRep l, toRep u)+		where (l, u) = bounds arr+	fromRepTMap f (List xs :*: K0 (l, r))+		= array (fromRep l, fromRep r) [(fromRep k, f a) | (k, a) <- xs] |])++type instance RepT Set.Set = L I0+type instance RepT (Map.Map k) = L (Pair (Rep k))+type instance Rep (Set.Set a) = L I0 (Rep a)+type instance Rep (Map.Map k a) = RepT (Map.Map k) (Rep a)++$(genRepT [d|+   instance ReprT Set.Set where+	toRepTMap f s = List (Fold.foldr (\ a xs -> I0 (f a):xs) [] s)+	fromRepTMap f (List xs) = Set.fromDistinctAscList [f x | I0 x <- xs] |])++$(genRepT [d|+   instance Repr k => ReprT (Map.Map k) where+	toRepTMap f m = List (Map.foldWithKey (\ k a xs -> (toRep k, f a):xs) [] m)+	fromRepTMap f (List xs) = Map.fromDistinctAscList [(fromRep k, f x) | (k, x) <- xs] |])++type instance RepT Rev = Rev+type instance Rep (Rev a) = Rev (Rep a)++$(genRepT [d|+   instance ReprT Rev where+   	toRepTMap f (Rev m) = Rev (f m)+	fromRepTMap f (Rev m) = Rev (f m) |])
+ Data/TrieMap/Rep/TH.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, TemplateHaskell, QuasiQuotes #-}++module Data.TrieMap.Rep.TH (genRepT, mkCon, conT, mkVar, appT, Type(..)) where++import Language.Haskell.TH+import Data.TrieMap.Rep+import Language.Haskell.TH.Ppr+import Debug.Trace+{-+genRepT ::  TypeQ -> Q [Dec]+genRepT ff = do+	f <- ff+	a <- newName "a"+	b <- newName "b"+	g <- newName "g"+	let reprt = ConT (mkName "ReprT")+	let repr = ConT (mkName "Repr")+	let rept = ConT (mkName "RepT")+	let rep = ConT (mkName "Rep")+	torep <- [| fmap toRep . toRepT |]+	fromrep <- [| fromRepT . fmap fromRep |]+	let toRepType = ForallT [g, b] [AppT reprt (VarT g), AppT repr (VarT b)]+		(AppT (VarT g) (VarT b) ~> AppT (AppT rept (VarT g)) (AppT rep (VarT b)))+	let fromRepType = ForallT [g, b] [AppT reprt (VarT g), AppT repr (VarT b)] +		(AppT (AppT rept (VarT g)) (AppT rep (VarT b)) ~> AppT (VarT g) (VarT b))+	let ans = [InstanceD [AppT reprt f, AppT repr (VarT a)] (AppT repr (AppT f (VarT a)))+		[FunD (mkName "toRep") [Clause [] (NormalB ( torep )) []],+			FunD (mkName "fromRep") [Clause [] (NormalB ( fromrep )) []]]]+	return ans-}++genRepT :: Q [Dec] -> Q [Dec]+genRepT decs = do+	iT@(InstanceD cxt (reprt `AppT` f) _:_) <- decs+	(InstanceD _ _ myDecs:_) <- [d|+		instance (ReprT f, Repr a) => Repr (f a) where+			toRep = toRepTMap toRep+			fromRep = fromRepTMap fromRep+		|]+	a <- mkVar "a"+	repr <- conT ''Repr+	return (InstanceD (repr `AppT` a:cxt) (repr `AppT` (f `AppT` a)) myDecs :iT)++(~>) :: Type -> Type -> Type+a ~> b = AppT (AppT ArrowT a) b++mkCon :: String -> TypeQ+mkCon = conT . mkName++mkVar :: String -> TypeQ+mkVar x = varT =<< newName x++-- f :: Q [Dec]+-- f = do	ans <- [d| instance (ReprT ((,) a), Repr b) => Repr (a, b) where |]+-- 	traceShow ans $ return ans
+ Data/TrieMap/Representation.hs view
@@ -0,0 +1,6 @@+module Data.TrieMap.Representation (Repr(..), ReprT(..), Rep, RepT) where++import Data.TrieMap.Rep+import Data.TrieMap.Rep.Instances+import Data.TrieMap.Regular.Rep+
+ Data/TrieMap/Representation/TH.hs view
@@ -0,0 +1,3 @@+module Data.TrieMap.Representation.TH (module Data.TrieMap.Rep.TH) where++import Data.TrieMap.Rep.TH
+ Data/TrieMap/ReverseMap.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell, UndecidableInstances, TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-}++module Data.TrieMap.ReverseMap() where++import Data.TrieMap.TrieKey+import Data.TrieMap.Modifiers+import Data.TrieMap.Applicative+import Data.TrieMap.Regular.Class+import Data.TrieMap.Regular.TH++import Control.Applicative+import Control.Arrow++import Data.Monoid hiding (Dual)++newtype ReverseMap k a = RMap (TrieMap k a)++type instance TrieMapT Rev = ReverseMap+type instance TrieMap (Rev k) = ReverseMap k++$(deriveM [d|+   instance TrieKeyT Rev ReverseMap where+	emptyT = RMap emptyM+	nullT (RMap m) = nullM m+	sizeT s (RMap m) = sizeM s m+	lookupT (Rev k) (RMap m) = lookupM k m+	lookupIxT s (Rev k) (RMap m) = case lookupIxM s k m of+		(Last lb, x, First ub) -> onKey Rev (onIndex (sizeM s m - 1 -) (Last ub, x, First lb))+	assocAtT s i (RMap m) = case assocAtM s (sz - 1 - i) m of+		(Last lb, x, First ub) -> onKey Rev (onIndex (sz -) (Last ub, x, First lb))+		where 	sz = sizeM s m+-- 	updateAtM s r f i (RMap m) = RMap (updateAtM s r' f' (sz - i) m) where+-- 		r' = not r+-- 		f' i = f (sz - 1 - i) . Rev+-- 		sz = sizeM s m+	traverseWithKeyT s f (RMap m) = RMap <$> runDual (traverseWithKeyM s (\ k a -> Dual (f (Rev k) a)) m)+	alterT s f (Rev k) (RMap m) = RMap (alterM s f k m)+	splitLookupT s f (Rev k) (RMap m) = case splitLookupM s f' k m of+		(mL, x, mR) -> (RMap mR, x, RMap mL)+		where f' x = case f x of+			(xL, ans, xR) -> (xR, ans, xL)+	mapEitherT s1 s2 f (RMap m) = (RMap *** RMap) (mapEitherM s1 s2 (f . Rev) m)+	foldWithKeyT f (RMap m) = foldlWithKeyM (flip . f . Rev) m+	foldlWithKeyT f (RMap m) = foldWithKeyM (flip . f . Rev) m+	unionT s f (RMap m1) (RMap m2) = RMap (unionM s (f . Rev) m1 m2)+	isectT s f (RMap m1) (RMap m2) = RMap (isectM s (f . Rev) m1 m2)+	diffT s f (RMap m1) (RMap m2) = RMap (diffM s (f . Rev) m1 m2)+	extractT s f (RMap m) = second RMap <$> runDual (extractM s (\ k a -> Dual (f (Rev k) a)) m)+-- 	extractMinM s f (RMap m) = second RMap <$> First (getLast (extractMaxM s (f . Rev) m))+-- 	extractMaxM s f (RMap m) = second RMap <$> Last (getFirst (extractMinM s (f . Rev) m))+-- 	alterMinM s f (RMap m) = RMap (alterMaxM s (f . Rev) m)+-- 	alterMaxM s f (RMap m) = RMap (alterMinM s (f . Rev) m)+	isSubmapT (<=) (RMap m1) (RMap m2) = isSubmapM (<=) m1 m2++   reverse :: TrieMap k a -> TrieMap (Rev k) a+   reverse = RMap |])++unreverse :: TrieMap (Rev k) a -> TrieMap k a+unreverse (RMap m) = m
Data/TrieMap/Sized.hs view
@@ -10,9 +10,9 @@ -- instance Sized Elem where -- 	getSize _ = 1 -type Sized f = forall ix . f ix -> Int+type Sized a = a -> Int  newtype Elem a = Elem {getElem :: a} -elemSize :: Sized Elem+elemSize :: Sized (Elem a) elemSize _ = 1
Data/TrieMap/TrieKey.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies, KindSignatures #-}+{-# LANGUAGE PatternGuards, Rank2Types, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies, KindSignatures #-}  module Data.TrieMap.TrieKey where @@ -6,13 +6,14 @@ import Data.TrieMap.Sized  import Control.Applicative+import Control.Arrow  import Data.Monoid import Data.List -type family TrieMap k :: (* -> *) -> * -> *+type family TrieMap k :: * -> * -type family MapPF (m :: (* -> *) -> * -> *) ix :: (* -> *) -> *+-- type family MapPF (m :: (* -> *) -> * -> *) ix :: (* -> *) -> * -- data Fixer f  type EitherMap k a b c = k -> a -> (Maybe b, Maybe c)@@ -20,47 +21,81 @@ 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 ExtractFunc f m k a x = (k -> a -> f (x, Maybe a)) -> m -> f (x, m) type LEq a b = a -> b -> Bool++data Assoc k a = Asc {-# UNPACK #-} !Int k a+-- data IndexPos k a = Between {-# UNPACK #-} !(Assoc k a) {-# UNPACK #-} !(Assoc k a)+-- 			| Exact {-# UNPACK #-} !(Assoc k a) (Last (Assoc k a)) (First (Assoc k a))+-- 			| Above {-# UNPACK #-} !(Assoc k a) | Below {-# UNPACK #-} !(Assoc k a) | Nada+type IndexPos k a = (Last (Assoc k a), Maybe (Assoc k a), First (Assoc k a))++onIndexA :: (Int -> Int) -> Assoc k a -> Assoc k a+onIndexA f (Asc i k a) = Asc (f i) k a++onIndex :: (Int -> Int) -> IndexPos k a -> IndexPos k a+onIndex f (l, x, r) = (onIndexA f <$> l, onIndexA f <$> x, onIndexA f <$> r)++onKey :: (k -> k') -> IndexPos k a -> IndexPos k' a+onKey = onValue . first++onVal :: (a -> a') -> IndexPos k a -> IndexPos k a'+onVal = onValue . second++onKeyA :: (k -> k') -> Assoc k a -> Assoc k' a+onKeyA = onValueA . first++onValA :: (a -> a') -> Assoc k a -> Assoc k a'+onValA = onValueA . second++{-# INLINE onValueA #-}+onValueA :: ((k, a) -> (k', a')) -> Assoc k a -> Assoc k' a'+onValueA f (Asc i k a) = uncurry (Asc i) (f (k, a))++{-# INLINE onValue #-}+onValue :: ((k, a) -> (k', a')) -> IndexPos k a -> IndexPos k' a'+onValue f (l, x, r) = (onValueA f <$> l, onValueA f <$> x, onValueA f <$> r)++type Round = Bool -- type Sized f = forall ix . f ix -> Int  -- toFixer :: a -> Fixer a -- toFixer _ = undefined  class Ord k => TrieKey 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+	emptyM :: TrieMap k ~ m => m a+	nullM :: TrieMap k ~ m => m a -> Bool+	sizeM :: (TrieMap k ~ m) => Sized a -> m a -> Int+	lookupM :: TrieMap k ~ m => k -> m a -> Maybe (a)+	lookupIxM :: TrieMap k ~ m => Sized a -> k -> m a -> IndexPos k a+	assocAtM :: TrieMap k ~ m => Sized a -> Int -> m a -> IndexPos k a+-- 	updateAtM :: TrieMap k ~ m => Sized a -> Round -> (Int -> k -> a -> Maybe (a)) -> Int -> m a -> m a+	alterM :: (TrieMap k ~ m) => Sized a -> (Maybe (a) -> Maybe (a)) -> k -> m a -> m a+	{-# SPECIALIZE traverseWithKeyM :: (k -> a -> Id (b)) -> m a -> Id (m b) #-}+	traverseWithKeyM :: (TrieMap k ~ m, Applicative f) => Sized b ->+		(k -> a -> f (b)) -> m a -> f (m b)+	foldWithKeyM :: TrieMap k ~ m => (k -> a -> b -> b) -> m a -> b -> b+	foldlWithKeyM :: TrieMap k ~ m => (k -> b -> a -> b) -> m a -> b -> b+	mapEitherM :: (TrieMap k ~ m) => Sized b -> Sized c -> EitherMap k (a) (b) (c) -> m a -> (m b, m c)+	splitLookupM :: (TrieMap k ~ m) => Sized a -> SplitMap (a) x -> k -> m a -> (m a, Maybe x, m a)+	unionM :: (TrieMap k ~ m) => Sized a -> UnionFunc k (a) -> m a -> m a -> m a+	isectM :: (TrieMap k ~ m) => Sized c -> IsectFunc k (a) (b) (c) -> m a -> m b -> m c+	diffM :: (TrieMap k ~ m) => Sized a -> DiffFunc k (a) (b) -> m a -> m b -> m a+	extractM :: (TrieMap k ~ m, Alternative f) => Sized a -> ExtractFunc f (m a) k a x+-- 	extractMinM :: (TrieMap k ~ m) => Sized a -> ExtractFunc k First (a) (m a) x+-- 	extractMaxM :: (TrieMap k ~ m) => Sized a -> ExtractFunc k Last (a) (m a) x+-- 	alterMinM :: (TrieMap k ~ m) => Sized a -> (k -> a -> Maybe a) -> m a -> First (m a)+-- 	alterMaxM :: (TrieMap k ~ m) => Sized a -> (k -> a -> Maybe a) -> m a -> Last (m a)+	isSubmapM :: TrieMap k ~ m => LEq (a) (b) -> LEq (m a) (m b)+	fromListM, fromAscListM :: (TrieMap k ~ m) => Sized a -> (k -> a -> a -> a) -> [(k, a)] -> m a+	fromDistAscListM :: (TrieMap k ~ m) => Sized a -> [(k, a)] -> m a 	 	sizeM s m = foldWithKeyM (\ _ a n -> s a + n) m 0 	fromListM s f = foldl' (flip (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 :: (TrieKey k m, m ~ TrieMap k) => m a -> Maybe (m a) guardNullM m 	| nullM m	= Nothing 	| otherwise	= Just m@@ -68,29 +103,29 @@ 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 :: (TrieKey k m, m ~ TrieMap k) => Sized b -> (k -> a -> Maybe (b)) -> m a -> m b 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 :: (TrieKey k m, m ~ TrieMap k) => Sized b -> (k -> a -> b) -> m a -> m b 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 :: (TrieKey k m, m ~ TrieMap k) => Sized b -> (a -> b) -> m a -> m b mapM s = mapWithKeyM s . const -assocsM :: (TrieKey k m, m ~ TrieMap k) => m a ix -> [(k, a ix)]+assocsM :: (TrieKey k m, m ~ TrieMap k) => m a -> [(k, a)] 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 :: (TrieKey k m, m ~ TrieMap k) => Sized a -> k -> a -> m a -> m a 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 :: (TrieKey k m, m ~ TrieMap k) => Sized a -> (k -> a -> a -> a) -> k -> a -> m a -> m a 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 :: (TrieKey k m, m ~ TrieMap k) => Sized a -> k -> a -> m a 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' :: (TrieKey k m, m ~ TrieMap k) => Sized a -> [(k, a)] -> m a fromListM' s = fromListM s (const const) --xs = foldr (uncurry insertM) emptyM xs  unionMaybe :: (a -> a -> Maybe a) -> Maybe a -> Maybe a -> Maybe a@@ -110,3 +145,6 @@ subMaybe _ Nothing _ = True subMaybe (<=) (Just a) (Just b) = a <= b subMaybe _ _ _ = False++aboutM :: (TrieKey k (TrieMap k), Alternative t) => (k -> a -> t z) -> TrieMap k a -> t z+aboutM f = fst <.> extractM (const 0) (\ k a -> fmap (flip (,) Nothing) (f k a))
+ Data/TrieSet.hs view
@@ -0,0 +1,173 @@+module Data.TrieSet (+	-- * Set type+	TSet,+	-- * Operators+	(\\),+	-- * Query+	null,+	size,+	member,+	notMember,+	isSubsetOf,+	isProperSubsetOf,+	-- * Construction+	empty,+	singleton,+	insert,+	delete,+	-- * Combine+	union,+	symmetricDifference,+	intersection,+	difference,+	-- * Filter+	filter,+	partition,+	split,+	splitMember,+	-- * Map+	map,+	mapMonotonic,+	-- * Fold+	fold,+	foldl,+	foldr,+	-- * Min/Max+	findMin,+	findMax,+	deleteMin,+	deleteMax,+	deleteFindMin,+	deleteFindMax,+	minView,+	maxView,+	-- * Conversion+	-- ** List+	elems,+	toList,+	fromList,+	-- ** Ordered lists+	toAscList,+	fromAscList,+	fromDistinctAscList)+ 		where++import qualified Data.TrieMap as M+import Data.TrieMap.Class++import Control.Applicative hiding (empty)+import Control.Arrow++import Data.Maybe+import Data.Monoid++import Prelude hiding (foldr, foldl, map, filter, null)++instance TKey a => Eq (TSet a) where+	s1 == s2 = s1 `isSubsetOf` s2 && size s1 == size s2++instance (TKey a, Ord a) => Ord (TSet a) where+	s1 `compare` s2 = elems s1 `compare` elems s2++instance (TKey a, Show a) => Show (TSet a) where+	show s = "fromList " ++ show (elems s)++instance TKey a => Monoid (TSet a) where+	mempty = empty+	mappend = union++empty :: TKey a => TSet a+empty = TSet M.empty++insert :: TKey a => a -> TSet a -> TSet a+insert a (TSet s) = TSet (M.insert a () s)++delete :: TKey a => a -> TSet a -> TSet a+delete a (TSet s) = TSet (M.delete a s)++singleton :: TKey a => a -> TSet a+singleton a = insert a empty++union :: TKey a => TSet a -> TSet a -> TSet a+TSet s1 `union` TSet s2 = TSet (s1 `M.union` s2)++symmetricDifference :: TKey a => TSet a -> TSet a -> TSet a+TSet s1 `symmetricDifference` TSet s2 = TSet (M.unionMaybeWith (\ _ _ -> Nothing) s1 s2)++difference :: TKey a => TSet a -> TSet a -> TSet a+TSet s1 `difference` TSet s2 = TSet (s1 `M.difference` s2)++intersection :: TKey a => TSet a -> TSet a -> TSet a+TSet s1 `intersection` TSet s2 = TSet (s1 `M.intersection` s2)++filter :: TKey a => (a -> Bool) -> TSet a -> TSet a+filter p (TSet s) = TSet (M.filterWithKey (\ k _ -> p k) s)++partition :: TKey a => (a -> Bool) -> TSet a -> (TSet a, TSet a)+partition p (TSet s) = (TSet *** TSet) (M.partitionWithKey (\ k _ -> p k) s)++split :: TKey a => a -> TSet a -> (TSet a, TSet a)+split a s = case splitMember a s of+	(sL, _, sR) -> (sL, sR)++splitMember :: TKey a => a -> TSet a -> (TSet a, Bool, TSet a)+splitMember a (TSet s) = case M.splitLookup a s of+	(sL, x, sR) -> (TSet sL, isJust x, TSet sR)++map :: (TKey a, TKey b) => (a -> b) -> TSet a -> TSet b+map f (TSet s) = TSet (M.mapKeys f s)++mapMonotonic :: (TKey a, TKey b) => (a -> b) -> TSet a -> TSet b+mapMonotonic f (TSet s) = TSet (M.mapKeysMonotonic f s)++fold, foldr :: TKey a => (a -> b -> b) -> b -> TSet a -> b+fold = foldr+foldr f z (TSet s) = M.foldrWithKey (const . f) z s++foldl :: TKey b => (a -> b -> a) -> a -> TSet b -> a+foldl f z (TSet s) = M.foldlWithKey (\ z a _ -> f z a) z s++findMin, findMax :: TKey a => TSet a -> a+findMin = fst . deleteFindMin+findMax = fst . deleteFindMax++deleteMin, deleteMax :: TKey a => TSet a -> TSet a+deleteMin s = maybe s snd (minView s)+deleteMax s = maybe s snd (maxView s)++deleteFindMin, deleteFindMax :: TKey a => TSet a -> (a, TSet a)+deleteFindMin = fromJust . minView+deleteFindMax = fromJust . maxView++minView, maxView :: TKey a => TSet a -> Maybe (a, TSet a)+minView (TSet s) = (fst *** TSet) <$> M.minViewWithKey s+maxView (TSet s) = (fst *** TSet) <$> M.maxViewWithKey s++elems, toList, toAscList :: TKey a => TSet a -> [a]+elems (TSet s) = M.keys s+toList = elems+toAscList = toList++fromList, fromAscList, fromDistinctAscList :: TKey a => [a] -> TSet a+fromList xs = TSet (M.fromList [(x, ()) | x <- xs])+fromAscList xs = TSet (M.fromAscList [(x, ()) | x <- xs])+fromDistinctAscList xs = TSet (M.fromDistinctAscList [(x, ()) | x <- xs])++null :: TKey a => TSet a -> Bool+null (TSet s) = M.null s++size :: TKey a => TSet a -> Int+size (TSet s) = M.size s++member :: TKey a => a -> TSet a -> Bool+member a (TSet s) = a `M.member` s++notMember :: TKey a => a -> TSet a -> Bool+notMember a = not . member a++isSubsetOf, isProperSubsetOf :: TKey a => TSet a -> TSet a -> Bool+TSet s1 `isSubsetOf` TSet s2 = M.isSubmapOfBy (\ _ _ -> True) s1 s2+s1 `isProperSubsetOf` s2 = size s1 < size s2 && s1 `isSubsetOf` s2++(\\) :: TKey a => TSet a -> TSet a -> TSet a+(\\) = difference
TrieMap.cabal view
@@ -1,5 +1,5 @@ name:		     TrieMap-version:             0.5.1+version:             0.5.2 tested-with:	     GHC category:            Algorithms synopsis:	     Automatic type inference of generalized tries.@@ -8,24 +8,36 @@ license-file:	     LICENSE author:              Louis Wasserman maintainer:          wasserman.louis@gmail.com-build-Depends:       base < 5.0.0.0, containers, multirec+build-Depends:       base < 5.0.0.0, containers, multirec, template-haskell, bytestring, array build-type:	     Simple exposed-modules:   	Data.TrieMap,+	Data.TrieSet, 	Data.TrieMap.Class, 	Data.TrieMap.Regular,-	Data.TrieMap.MultiRec+	Data.TrieMap.MultiRec,+	Data.TrieMap.Representation,+	Data.TrieMap.Representation.TH,+	Data.TrieMap.Modifiers 	-- Data.TrieMap.TrieKey other-modules: 	Data.TrieMap.Class.Instances, 	Data.TrieMap.TrieKey, 	Data.TrieMap.Applicative,+	Data.TrieMap.Rep,+	Data.TrieMap.Rep.Instances,+	Data.TrieMap.Rep.TH,+	Data.TrieMap.MultiRec.TH, 	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.Base,+	-- Data.TrieMap.MultiRec.XMap,+	Data.TrieMap.MultiRec.FixMap,+	-- Data.TrieMap.MultiRec.AppMap, 	Data.TrieMap.MultiRec.Instances, 	Data.TrieMap.MultiRec.ProdMap, 	Data.TrieMap.MultiRec.TagMap,@@ -43,9 +55,13 @@ 	Data.TrieMap.Regular.RadixTrie, 	Data.TrieMap.Regular.UnitMap, 	Data.TrieMap.Regular.RegMap,+	Data.TrieMap.Regular.CompMap, 	Data.TrieMap.Regular.UnionMap,+	Data.TrieMap.Regular.TH, 	Data.TrieMap.Regular.Sized,+	Data.TrieMap.Regular.Rep, 	Data.TrieMap.IntMap, 	Data.TrieMap.OrdMap,+	Data.TrieMap.ReverseMap, 	Data.TrieMap.Sized, 	Data.TrieMap.Applicative