diff --git a/Data/TrieMap.hs b/Data/TrieMap.hs --- a/Data/TrieMap.hs +++ b/Data/TrieMap.hs @@ -119,22 +119,26 @@ import Data.TrieMap.TrieKey import Data.TrieMap.Applicative import Data.TrieMap.Rep +import Data.TrieMap.Rep.Instances +import Data.TrieMap.Modifiers +-- import Data.TrieMap.ReverseMap import Data.TrieMap.Sized +import Data.TrieMap.CPair import Control.Applicative hiding (empty) import Control.Arrow import Control.Monad import Data.Maybe hiding (mapMaybe) -import Data.Monoid(First(..), Last(..)) +import Data.Monoid(Monoid(..), First(..), Last(..)) -- import Data.Foldable -- import Data.Traversable -- import Generics.MultiRec.Base -import Data.TrieMap.Regular.Base -import Data.TrieMap.Regular.Sized +-- import Data.TrieMap.Regular.Base +-- import Data.TrieMap.Regular.Sized import GHC.Exts (build) -import Prelude hiding (lookup, foldr, null, map, filter) +import Prelude hiding (lookup, foldr, null, map, filter, reverse) instance (Show k, Show a, TKey k) => Show (TMap k a) where show m = "fromList " ++ show (assocs m) @@ -145,6 +149,10 @@ instance (Ord k, TKey k, Ord a) => Ord (TMap k a) where m1 `compare` m2 = assocs m1 `compare` assocs m2 +instance TKey k => Monoid (TMap k a) where + mempty = empty + mappend = union + -- newtype Elem a k = Elem {getElem :: a} empty :: TKey k => TMap k a empty = TMap emptyM @@ -167,8 +175,8 @@ alter :: TKey k => (Maybe a -> Maybe a) -> k -> TMap k a -> TMap k a 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, +-- | Projects information out of, and modifies or deletes, an individual association pair, +-- alternating over all associations in the map. -- -- > minViewWithKey == getFirst (extract (\ k a -> return ((k, a), Nothing))) -- > updateMaxWithKey f m == maybe m snd (getLast (extract (\ k a -> return ((), f k a)) m)) @@ -184,7 +192,7 @@ -- | 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 +extractA f (TMap m) = pairFromC <$> fmap TMap <$> extractM elemSize (\ k (Elem a) -> fmap (\ (x, y) -> x `cP` (Elem <$> y)) (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 @@ -416,7 +424,7 @@ 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) +k `findIndex` m = fromMaybe (error "element is not in the map") (k `lookupIndex` m) lookupWithIndex :: TKey k => k -> TMap k a -> Maybe (Int, k, a) lookupWithIndex k m = snd3 (neighborhood k m) @@ -445,3 +453,9 @@ keysSet :: TKey k => TMap k a -> TSet k keysSet = TSet . map (const ()) + +-- reverseMap :: TKey k => TMap k a -> TMap (Rev k) a +-- reverseMap (TMap m) = TMap (reverse m) + +-- unReverseMap :: TKey k => TMap (Rev k) a -> TMap k a +-- unReverseMap (TMap m) = TMap (unreverse m) diff --git a/Data/TrieMap/CPair.hs b/Data/TrieMap/CPair.hs new file mode 100644 --- /dev/null +++ b/Data/TrieMap/CPair.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Rank2Types #-} + +module Data.TrieMap.CPair where + +newtype CPair a b = CP (forall r . (a -> b -> r) -> r) + +pairFromC :: CPair a b -> (a, b) +pairFromC (CP k) = k (,) + +pairToC :: (a, b) -> CPair a b +pairToC p = CP (\ k -> uncurry k p) + +instance Functor (CPair a) where + fmap f (CP k) = CP (\ g -> k (\ x -> g x . f)) + +on1st :: (a -> b) -> CPair a c -> CPair b c +on1st f (CP k) = CP (\ g -> k (g . f)) + +on2nd :: (b -> c) -> CPair a b -> CPair a c +on2nd f (CP k) = CP (\ g -> k (\ x -> g x . f)) + +cP :: a -> b -> CPair a b +x `cP` y = CP (\ k -> k x y) + +cpFst :: CPair a b -> a +cpFst = cpUncurry const + +cpSnd :: CPair a b -> b +cpSnd = cpUncurry (flip const) + +cpUncurry :: (a -> b -> r) -> CPair a b -> r +cpUncurry f (CP k) = k f + +cpCurry :: (CPair a b -> r) -> a -> b -> r +cpCurry f a b = f (a `cP` b) diff --git a/Data/TrieMap/Class.hs b/Data/TrieMap/Class.hs --- a/Data/TrieMap/Class.hs +++ b/Data/TrieMap/Class.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances, TypeFamilies, FlexibleContexts, UndecidableInstances #-} module Data.TrieMap.Class (TMap(..), TSet (..), TKey, TKeyT, Rep, TrieMap, TrieKey) where @@ -25,7 +25,11 @@ -- toRep :: k -> Rep k -- fromRep :: Rep k -> k +instance (Repr k, TrieKey (Rep k) (TrieMap (Rep k))) => TKey k + class (ReprT f, TrieKeyT (RepT f) (TrieMapT (RepT f))) => TKeyT f + +instance (ReprT f, TrieKeyT (RepT f) (TrieMapT (RepT f))) => TKeyT f instance TKey k => Functor (TMap k) where fmap = fmapDefault diff --git a/Data/TrieMap/Class/Instances.hs b/Data/TrieMap/Class/Instances.hs --- a/Data/TrieMap/Class/Instances.hs +++ b/Data/TrieMap/Class/Instances.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, CPP, Rank2Types, TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances, TemplateHaskell, CPP, Rank2Types, TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances #-} module Data.TrieMap.Class.Instances where @@ -8,7 +8,7 @@ import Data.TrieMap.Rep.TH import Data.TrieMap.Rep.Instances import Data.TrieMap.Sized --- import Data.TrieMap.RadixTrie() +import Data.TrieMap.RadixTrie() import Data.TrieMap.MultiRec.Instances import Data.TrieMap.IntMap import Data.TrieMap.OrdMap @@ -21,7 +21,7 @@ import Data.TrieMap.Regular.Class import Data.TrieMap.Regular.Instances -- import Data.TrieMap.UnionMap() --- import Data.TrieMap.UnitMap() +import Data.TrieMap.UnitMap() import Data.Bits import Data.Char @@ -50,62 +50,65 @@ toRep = map toRep fromRep = map fromRep-} -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) +-- 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 RepT (TMap k) = L (K0 (Rep k) :*: I0) type instance Rep (TMap k a) = RepT (TMap k) (Rep a) +-- instance (Repr k, TrieKey (Rep k) (TrieMap (Rep k))) => TKey k +-- instance (ReprT f, TrieKeyT (RepT f) (TrieMapT (RepT f))) => TKeyT f + 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]) - +{- instance (TKey k, Repr a) => Repr (TMap k a) where toRep = toRepTMap toRep - fromRep = fromRepTMap fromRep + fromRep = fromRepTMap fromRep-} diff --git a/Data/TrieMap/IntMap.hs b/Data/TrieMap/IntMap.hs --- a/Data/TrieMap/IntMap.hs +++ b/Data/TrieMap/IntMap.hs @@ -3,10 +3,11 @@ module Data.TrieMap.IntMap () where import Data.TrieMap.TrieKey -import Data.TrieMap.MultiRec.Base -import Data.TrieMap.Applicative +-- import Data.TrieMap.MultiRec.Base +-- import Data.TrieMap.Applicative import Data.TrieMap.Sized -import Data.TrieMap.ReverseMap +import Data.TrieMap.CPair +-- import Data.TrieMap.ReverseMap -- import Data.TrieMap.Rep -- import Data.TrieMap.Rep.TH @@ -18,16 +19,16 @@ import Data.Maybe import Data.Monoid import Data.Word -import Data.Int +-- import Data.Int -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts ( Word(..), Int(..), shiftRL# ) -#elif __GLASGOW_HASKELL__ -import Word -import GlaExts ( Word(..), Int(..), shiftRL# ) -#else -import Data.Word -#endif +-- #if __GLASGOW_HASKELL__ >= 503 +-- import GHC.Exts ( Word(..), Int(..), shiftRL# ) +-- #elif __GLASGOW_HASKELL__ +-- import Word +-- import GlaExts ( Word(..), Int(..), shiftRL# ) +-- #else +-- import Data.Word +-- #endif import Prelude hiding (lookup, null, foldl, foldr) @@ -72,6 +73,7 @@ assocAtM s = assocAt s 0 -- updateAtM s r = updateAt s r 0 alterM = alter + alterLookupM = alterLookup traverseWithKeyM = traverseWithKey foldWithKeyM = foldr foldlWithKeyM = foldl @@ -161,22 +163,7 @@ | k == kx = Just x lookup _ _ = Nothing -{- -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-} --- 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 :: 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 @@ -187,14 +174,6 @@ assocAt _ i0 _ (Tip _ k x) = (mzero, return (Asc i0 k x), mzero) assocAt _ _ _ _ = (mzero, mzero, mzero) --- 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 -> 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 @@ -240,20 +219,26 @@ | otherwise -> Tip sz ky y Nil -> singletonMaybe s k (f Nothing) +alterLookup :: Sized a -> (Maybe a -> CPair x (Maybe a)) -> Key -> WordMap a -> CPair x (WordMap a) +alterLookup s f k t = case t of + Bin sz p m l r + | nomatch k p m + -> fmap (\ v -> join k (singletonMaybe s k v) p t) (f Nothing) + | zero k m + -> fmap (\ l' -> bin p m l' r) (alterLookup s f k l) + | otherwise + -> fmap (\ r' -> bin p m l r') (alterLookup s f k r) + Tip sz ky y + | k == ky -> singletonMaybe s k <$> f (Just y) + | otherwise -> fmap (\ v -> join k (singletonMaybe s k v) ky t) (f Nothing) + Nil -> singletonMaybe s k <$> f Nothing + 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 -> 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 -> b -> b) -> WordMap a -> b -> b foldr f t = case t of @@ -261,13 +246,7 @@ Tip _ k x -> f k x Nil -> id -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 :: (Key -> b -> a -> b) -> WordMap a -> b -> b foldl f t = case t of Bin _ _ _ l r -> foldl f r . foldl f l @@ -281,20 +260,6 @@ mapEither s1 s2 f (Tip _ kx x) = (singletonMaybe s1 kx *** singletonMaybe s2 kx) (f kx x) 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. - then let (lt,found,gt) = splitLookup' s f k l in (union s r lt,found, gt) - else let (lt,found,gt) = splitLookup' s f k r in (lt,found, union s gt l)) - | otherwise -> splitLookup' s f k t - Tip _ ky y - | k>ky -> (t,Nothing,Nil) - | k (Nil,Nothing,t) - | otherwise -> singletonMaybe s k `sides` f y - Nil -> (Nil,Nothing,Nil) - -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 @@ -398,17 +363,16 @@ 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 :: Alternative f => Sized a -> (Key -> a -> f (CPair x (Maybe a))) -> WordMap a -> f (CPair 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 + Bin _ p m l r -> fmap (\ l' -> bin p m l' r) <$> extract s f l + <|> fmap (bin p m l) <$> extract s f r + Tip _ k x -> fmap (singletonMaybe s k) <$> f k x Nil -> empty 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 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 @@ -420,16 +384,12 @@ Tip _ k y -> let (result, x) = f k y in (result, singletonMaybe s k x) Nil -> error "maxViewUnsigned Nil" --- --- 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 s f l in Just (result, bin p m t' r) + 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 :: WordMap a -> ((Key, a), WordMap a) minViewUnsigned s f t = case t of Bin _ p m l r -> let (result,t') = minViewUnsigned s f l in (result,bin p m t' r) @@ -439,7 +399,6 @@ 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 -> let t' = updateMinWithKeyUnsigned s f l in bin p m t' r Tip _ k y -> singletonMaybe s k (f k y) Nil -> Nil @@ -454,7 +413,6 @@ 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 -> let t' = updateMaxWithKeyUnsigned s f r in bin p m l t' Tip _ k y -> singletonMaybe s k (f k y) Nil -> Nil @@ -518,53 +476,3 @@ 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.WordMap --- import qualified Data.WordMap as IMap --- import Data.Traversable --- --- newtype IntTMap a = ITMap (WordMap (a)) --- type instance TrieMap Int = IntTMap --- newtype MaybeF a = MF {unF :: Maybe (a)} --- --- instance TrieKey Int IntTMap where --- emptyM = ITMap empty --- nullM (ITMap m) = IMap.null m --- alterM _ f k (ITMap m) = ITMap (IMap.alter f k m) --- lookupM k (ITMap m) = IMap.lookup k m --- traverseWithKeyM _ f (ITMap m) = (ITMap . IMap.fromDistinctAscList) <$> --- sequenceA (IMap.foldWithKey (\ k a xs -> (((,) k) <$> f k a):xs) [] m) --- foldWithKeyM f (ITMap m) z = IMap.foldWithKey f z m --- foldlWithKeyM f (ITMap m) z = foldl (\ z (k, a) -> f k z a) z (IMap.assocs m) --- mapEitherM _ _ f (ITMap m) = (ITMap (mapMaybe fst m'), ITMap (mapMaybe snd m')) where --- m' = mapWithKey f m --- splitLookupM _ f k (ITMap m) = ITMap `sides` case splitLookup k m of --- (mL, x, mR) --- | Nothing <- x -> (mL, Nothing, mR) --- | Just x <- x, (xL, x, xR) <- f x --- -> (mIns k mL xL, x, mIns k mR xR) --- where mIns k m = maybe m (\ x -> IMap.insert k x m) --- unionM _ f (ITMap m1) (ITMap m2) = ITMap (mapMaybe unF (unionWithKey f' m1' m2')) where --- f' k (MF a) (MF b) = MF (unionMaybe (f k) a b) --- m1' = fmap (MF . Just) m1 --- m2' = fmap (MF . Just) m2 --- isectM _ f (ITMap m1) (ITMap m2) = ITMap (mapMaybe unF (intersectionWithKey f' m1' m2')) where --- f' k (MF a) (MF b) = MF (isectMaybe (f k) a b) --- m1' = fmap (MF . Just) m1 --- m2' = fmap (MF . Just) m2 --- diffM _ f (ITMap m1) (ITMap m2) = ITMap (differenceWithKey f m1 m2) --- extractMinM _ (ITMap m) = fmap ITMap <$> First (minViewWithKey m) --- extractMaxM _ (ITMap m) = fmap ITMap <$> Last (maxViewWithKey m) --- alterMinM _ f (ITMap m) = ITMap $ case minViewWithKey m of --- Just ((k, v), m') --- -> maybe m' (\ v' -> updateMin (const v') m) (f k v) --- Nothing -> m --- alterMaxM _ f (ITMap m) = ITMap $ case maxViewWithKey m of --- Just ((k, v), m') --- -> maybe m' (\ v' -> updateMax (const v') m) (f k v) --- Nothing -> m --- isSubmapM (<=) (ITMap m1) (ITMap m2) = isSubmapOfBy (<=) m1 m2 --- fromListM _ = ITMap .: fromListWithKey --- fromAscListM _ = ITMap .: fromAscListWithKey --- fromDistAscListM _ = ITMap . fromDistinctAscList diff --git a/Data/TrieMap/MultiRec.hs b/Data/TrieMap/MultiRec.hs --- a/Data/TrieMap/MultiRec.hs +++ b/Data/TrieMap/MultiRec.hs @@ -1,4 +1,4 @@ -module Data.TrieMap.MultiRec (HTrieKey, HTrieKeyT, Family(..), HEq0(..), HOrd0(..), HOrd(..)) where +module Data.TrieMap.MultiRec (HTrieKeyT, HTrieKey, HTrieMapT, HTrieMap, Family(..), HOrd(..)) where import Data.TrieMap.MultiRec.Class import Data.TrieMap.MultiRec.FamMap diff --git a/Data/TrieMap/MultiRec/Base.hs b/Data/TrieMap/MultiRec/Base.hs --- a/Data/TrieMap/MultiRec/Base.hs +++ b/Data/TrieMap/MultiRec/Base.hs @@ -1,26 +1,26 @@ {-# 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 +module Data.TrieMap.MultiRec.Base (module Generics.MultiRec.Base, module Generics.MultiRec.HFix, {-A0(..), X(..), -}Family(..)) where --, FamT(..), KeyFam(..), FunctorT (..), breakEither) where -import Data.TrieMap.TrieKey +-- import Data.TrieMap.TriseKey -import Generics.MultiRec +-- import Generics.MultiRec import Generics.MultiRec.Base import Generics.MultiRec.HFix -import Control.Applicative +-- 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 +newtype Family (phi :: * -> *) ix = F {unF :: ix} -data KeyFam k = TrieKey k (TrieMap k) => KF -newtype FamT (phi :: * -> *) f ix = FamT (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 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 @@ -33,21 +33,21 @@ -- 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 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 Functor f => Functor (FamT phi f) where +-- fmap = fmapp -instance FunctorT (K k) where - fmapp = fmap +-- instance FunctorT (K k) where +-- fmapp = fmap instance Functor (K k r) where fmap f (K a) = K a @@ -98,6 +98,7 @@ 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 diff --git a/Data/TrieMap/MultiRec/Class.hs b/Data/TrieMap/MultiRec/Class.hs --- a/Data/TrieMap/MultiRec/Class.hs +++ b/Data/TrieMap/MultiRec/Class.hs @@ -1,135 +1,179 @@ -{-# LANGUAGE Rank2Types, FunctionalDependencies, FlexibleContexts, KindSignatures, TypeFamilies, MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators, Rank2Types, FunctionalDependencies, FlexibleContexts, KindSignatures, TypeFamilies, MultiParamTypeClasses #-} module Data.TrieMap.MultiRec.Class where +-- import Data.TrieMap.Regular.Class +import Data.TrieMap.CPair import Data.TrieMap.MultiRec.Sized -import Data.TrieMap.MultiRec.Eq +-- import Data.TrieMap.MultiRec.Eq import Data.TrieMap.MultiRec.Ord +-- import Data.TrieMap.Regular.Ord +import Data.TrieMap.MultiRec.Base +-- import Data.TrieMap.MultiRec.KeyFam import Data.TrieMap.TrieKey import Data.TrieMap.Applicative import Control.Applicative -import Data.Monoid -import Generics.MultiRec.Eq +-- import Data.Monoid +-- import Generics.MultiRec.Eq type family HTrieMapT (phi :: * -> *) (f :: (* -> *) -> * -> *) :: (* -> *) -> * -> * -> * type family HTrieMap (phi :: * -> *) (r :: * -> *) :: * -> * -> * class HOrd phi f => HTrieKeyT (phi :: * -> *) (f :: (* -> *) -> * -> *) m | m -> phi f where - 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)) => + emptyH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> m r ix a + nullH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> m r ix a -> Bool + sizeH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> HSized phi a -> m r ix a -> Int + lookupH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> f r ix -> m r ix a -> Maybe a + lookupIxH :: (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 + assocAtH :: (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 +-- updateAtH :: (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 -> 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 -> 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) => + alterH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => + phi ix -> HSized phi a -> (Maybe a -> Maybe a) -> f r ix -> m r ix a -> m r ix a + alterLookupH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => + phi ix -> HSized phi a -> (Maybe a -> CPair x (Maybe a)) -> f r ix -> + m r ix a -> CPair x (m r ix a) +-- {-# SPECIALIZE traverseWithKeyH :: HTrieKey phi r (HTrieMap phi r) => +-- phi ix -> HSized phi b -> (f r ix -> ix a -> Id b) -> m r ix a -> Id (m r ix b) #-} + traverseWithKeyH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r), Applicative t) => 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)) => + foldWithKeyH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => 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)) => + foldlWithKeyH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => 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 -> + mapEitherH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi 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)) => + splitLookupH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => 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)) => + unionH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => 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)) => + isectH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => 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)) => + diffH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => 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) => + extractH :: (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)) => +-- extractMinH :: (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)) => +-- extractMaxH :: (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)) => +-- alterMaxH :: (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)) => + isSubmapH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => 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)) => + fromListH, fromAscListH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => 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)) => + fromDistAscListH :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => 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) - -class HOrd0 phi r => HTrieKey (phi :: * -> *) (r :: * -> *) m | m -> phi r where - 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 -> 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 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 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) -mapWithKeyT :: (HTrieKeyT phi f (HTrieMapT phi f), HTrieKey phi r (HTrieMap phi r)) => - 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) +class HOrd0 phi r => HTrieKey (phi :: * -> *) (r :: * -> *) m | m -> phi r where + empty0 :: m ~ HTrieMap phi r => phi ix -> m ix a + null0 :: m ~ HTrieMap phi r => phi ix -> m ix a -> Bool + size0 :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> m ix a -> Int + lookup0 :: m ~ HTrieMap phi r => phi ix -> r ix -> m ix a -> Maybe a + lookupIx0 :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> r ix -> m ix a -> IndexPos (r ix) a + assocAt0 :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> Int -> m ix a -> IndexPos (r ix) a + alter0 :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> (Maybe a -> Maybe a) -> r ix -> m ix a -> m ix a + alterLookup0 :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> (Maybe a -> CPair z (Maybe a)) + -> r ix -> m ix a -> CPair z (m ix a) + extract0 :: (m ~ HTrieMap phi r, Alternative t) => phi ix -> HSized phi a -> + ExtractFunc t (m ix a) (r ix) a x + traverseWithKey0 :: (m ~ HTrieMap phi r, Applicative t) => phi ix -> HSized phi b -> + (r ix -> a -> t b) -> m ix a -> t (m ix b) + foldWithKey0 :: m ~ HTrieMap phi r => phi ix -> (r ix -> a -> b -> b) -> m ix a -> b -> b + foldlWithKey0 :: m ~ HTrieMap phi r => phi ix -> (r ix -> b -> a -> b) -> m ix a -> b -> b + mapEither0 :: m ~ HTrieMap phi r => phi ix -> HSized phi b -> HSized phi c -> EitherMap (r ix) a b c -> m ix a -> (m ix b, m ix c) + splitLookup0 :: 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) + union0 :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> UnionFunc (r ix) a -> + m ix a -> m ix a -> m ix a + isect0 :: m ~ HTrieMap phi r => phi ix -> HSized phi c -> IsectFunc (r ix) a b c-> + m ix a -> m ix b -> m ix c + diff0 :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> DiffFunc (r ix) a b -> + m ix a -> m ix b -> m ix a + isSubmap0 :: m ~ HTrieMap phi r => phi ix -> LEq a b -> LEq (m ix a) (m ix b) + fromList0, fromAscList0 :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> (r ix -> a -> a -> a) -> [(r ix, a)] -> m ix a + fromDistAscList0 :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> [(r ix, a)] -> m ix a + -mapWithKeyH :: (HTrieKey phi r (HTrieMap phi r)) => - phi ix -> HSized phi b -> (r ix -> a -> b) -> HTrieMap phi r ix a -> HTrieMap phi r ix b +-- class HOrd0 phi r => HTrieKey (phi :: * -> *) (r :: * -> *) m | m -> phi r where +-- 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 -> 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 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 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) +-- +-- mapWithKeyH :: (HTrieKeyT phi f (HTrieMapT phi f), HTrieKey phi r (HTrieMap phi r)) => +-- 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), HTrieKeyT phi f (HTrieMapT phi f)) => +-- phi ix -> HSized phi b -> (r ix -> a -> b) -> HTrieMapT phi f r ix a -> HTrieMapT phi f 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)) => +-- +guardNullH :: (m ~ HTrieMapT phi f, HTrieKeyT phi f m, HTrieKey phi r (HTrieMap phi r)) => phi ix -> m r ix a -> Maybe (m r ix a) -guardNullT pf m - | nullT pf m = Nothing +guardNullH pf m + | nullH 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) => +-- +-- -- alterMaxT, alterMinH :: (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) +-- +aboutH :: (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 +aboutH pf f m = cpFst <$> extractH pf (const 0) (\ k a -> fmap (flip cP Nothing) (f k a)) m + +breakEither :: [((f :+: g) r ix, a)] -> ([(f r ix, a)], [(g r ix, a)]) +breakEither [] = ([], []) +breakEither ((L k, a):xs) = case breakEither xs of + (ys, zs) -> ((k, a):ys, zs) +breakEither ((R k, a):xs) = case breakEither xs of + (ys, zs) -> (ys, (k, a):zs) diff --git a/Data/TrieMap/MultiRec/ConstMap.hs b/Data/TrieMap/MultiRec/ConstMap.hs --- a/Data/TrieMap/MultiRec/ConstMap.hs +++ b/Data/TrieMap/MultiRec/ConstMap.hs @@ -3,9 +3,10 @@ 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.MultiRec.Eq +-- import Data.TrieMap.MultiRec.Sized +-- import Data.TrieMap.MultiRec.KeyFam +-- import Data.TrieMap.Applicative import Data.TrieMap.TrieKey -- import Data.TrieMap.Rep -- import Data.TrieMap.Rep.TH @@ -14,13 +15,13 @@ import Control.Arrow import Control.Monad -import Data.Maybe -import Data.Foldable +-- import Data.Maybe +-- import Data.Foldable import Generics.MultiRec 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 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) @@ -31,55 +32,20 @@ -- fromRepT = KMap . fromRepT |]) instance TrieKey k m => HTrieKeyT phi (K k) (KMap phi m) where - emptyT = emptyH - nullT = nullH - sizeT = sizeH - lookupT = lookupH - lookupIxT = lookupIxH - assocAtT = assocAtH --- updateAtT = updateAtH - alterT = alterH - traverseWithKeyT = traverseWithKeyH - foldWithKeyT = foldWithKeyH - foldlWithKeyT = foldlWithKeyH - mapEitherT = mapEitherH - splitLookupT = splitLookupH - unionT = unionH - isectT = isectH - diffT = diffH - extractT = extractH --- extractMinT = extractMinH --- extractMaxT = extractMaxH --- alterMinT = alterMinH --- alterMaxT = alterMaxH - isSubmapT = isSubmapH - fromListT = fromListH - fromAscListT = fromAscListH - fromDistAscListT = fromDistAscListH - -instance TrieKey k m => HTrieKey phi (K k r) (KMap phi m r) where emptyH _ = KMap emptyM nullH _ (KMap m) = nullM m - sizeH _ s (KMap m) = sizeM (s) m lookupH _ (K k) (KMap m) = lookupM k m lookupIxH _ s (K k) (KMap m) = 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 + alterH _ s f (K k) (KMap m) = KMap (alterM s f k m) + alterLookupH _ s f (K k) (KMap m) = KMap <$> alterLookupM s f k m + traverseWithKeyH _ s f (KMap m) = KMap <$> traverseWithKeyM s (f . K) m foldWithKeyH _ f (KMap m) = foldWithKeyM (f . K) m foldlWithKeyH _ f (KMap m) = foldlWithKeyM (f . K) m - mapEitherH pf s1 s2 f (KMap m) = (KMap *** KMap) (mapEitherM (s1) (s2) (f . K) m) - splitLookupH pf s f (K k) (KMap m) = KMap `sides` splitLookupM (s) f k m - unionH pf s f (KMap m1) (KMap m2) = KMap (unionM (s) (f . K) m1 m2) - isectH pf s f (KMap m1) (KMap m2) = KMap (isectM (s) (f . K) m1 m2) - diffH pf s f (KMap m1) (KMap m2) = KMap (diffM (s) (f . K) m1 m2) - 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 + mapEitherH _ s1 s2 f (KMap m) = (KMap *** KMap) (mapEitherM s1 s2 (f . K) m) + splitLookupH _ s f (K k) (KMap m) = KMap `sides` splitLookupM s f k m + unionH _ s f (KMap m1) (KMap m2) = KMap (unionM s (f . K) m1 m2) + isectH _ s f (KMap m1) (KMap m2) = KMap (isectM s (f . K) m1 m2) + diffH _ s f (KMap m1) (KMap m2) = KMap (diffM s (f . K) m1 m2) + extractH _ s f (KMap m) = fmap KMap <$> extractM s (f . K) m isSubmapH _ (<=) (KMap m1) (KMap m2) = isSubmapM (<=) m1 m2 - fromListH pf s f xs = KMap (fromListM (s) (f . K) [(k, a) | (K k, a) <- xs]) - fromAscListH pf s f xs = KMap (fromAscListM (s) (f . K) [(k, a) | (K k, a) <- xs]) - fromDistAscListH pf s xs = KMap (fromDistAscListM (s) [(k, a) | (K k, a) <- xs]) diff --git a/Data/TrieMap/MultiRec/Eq.hs b/Data/TrieMap/MultiRec/Eq.hs --- a/Data/TrieMap/MultiRec/Eq.hs +++ b/Data/TrieMap/MultiRec/Eq.hs @@ -2,18 +2,28 @@ module Data.TrieMap.MultiRec.Eq where -import Data.TrieMap.MultiRec.Base -import Generics.MultiRec.HFix +-- import Data.TrieMap.MultiRec.Base +-- import Generics.MultiRec.HFix import Generics.MultiRec.Eq +-- import Data.TrieMap.Regular.Eq +-- class HEq phi r where +-- heqH :: phi ix -> r ix -> r ix -> Bool + +-- class EqFam phi where +-- eqF :: phi ix -> (ix -> ix -> Bool) + class HEq0 phi r where - heqH :: phi ix -> r ix -> r ix -> Bool + heq0 :: phi ix -> r ix -> r ix -> Bool heqT :: (HEq phi f, HEq0 phi r) => phi ix -> f r ix -> f r ix -> Bool +heqT = heq heq0 +{- +heqT :: (HEq phi f, HEq0 phi r) => phi ix -> f r ix -> f r ix -> Bool heqT = heq heqH instance Eq k => HEq0 phi (K k r) where - heqH _ (K x) (K y) = x == y + 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-} @@ -21,24 +31,24 @@ -- 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 - proofOn :: El phi xi => phi ix -> phi xi - proofOn _ = proof - -instance HEq0 phi (U r) where - heqH _ _ _ = True - -instance (HEq phi f, HEq phi g, HEq0 phi r) => HEq0 phi ((f :*: g) r) where - heqH pf (x1 :*: y1) (x2 :*: y2) = heqT pf x1 x2 && heqT pf y1 y2 - -instance (HEq phi f, HEq phi g, HEq0 phi r) => HEq0 phi ((f :+: g) r) where - heqH pf (L x) (L y) = heqT pf x y - heqH pf (R x) (R y) = heqT pf x y - heqH _ _ _ = False - -instance (HEq phi f, HEq0 phi r) => HEq0 phi ((f :>: ix) r) where - heqH pf (Tag x) (Tag y) = heqT pf x y - -instance HEq phi f => HEq0 phi (HFix f) where - heqH pf (HIn x) (HIn y) = heqT pf x y +-- instance (El phi xi, HEq0 phi r) => HEq0 phi (I xi r) where +-- heqH pf (I x) (I y) = heqH (proofOn pf) x y where +-- proofOn :: El phi xi => phi ix -> phi xi +-- proofOn _ = proof +-- +-- instance HEq0 phi (U r) where +-- heqH _ _ _ = True +-- +-- instance (HEq phi f, HEq phi g, HEq0 phi r) => HEq0 phi ((f :*: g) r) where +-- heqH pf (x1 :*: y1) (x2 :*: y2) = heqT pf x1 x2 && heqT pf y1 y2 +-- +-- instance (HEq phi f, HEq phi g, HEq0 phi r) => HEq0 phi ((f :+: g) r) where +-- heqH pf (L x) (L y) = heqT pf x y +-- heqH pf (R x) (R y) = heqT pf x y +-- heqH _ _ _ = False +-- +-- instance (HEq phi f, HEq0 phi r) => HEq0 phi ((f :>: ix) r) where +-- heqH pf (Tag x) (Tag y) = heqT pf x y +-- +-- instance HEq phi f => HEq0 phi (HFix f) where +-- heqH pf (HIn x) (HIn y) = heqT pf x y diff --git a/Data/TrieMap/MultiRec/FamMap.hs b/Data/TrieMap/MultiRec/FamMap.hs --- a/Data/TrieMap/MultiRec/FamMap.hs +++ b/Data/TrieMap/MultiRec/FamMap.hs @@ -7,150 +7,95 @@ 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.Sized +-- import Data.TrieMap.Applicative import Data.TrieMap.TrieKey -import qualified Data.TrieMap.Regular.Class as Reg +-- import qualified Data.TrieMap.Regular.Class as Reg import Control.Applicative import Control.Arrow -import Data.Maybe -import Data.Foldable -import Data.Sequence ((|>)) -import qualified Data.Sequence as Seq +-- import Data.Maybe +-- import Data.Foldable +-- import Data.Sequence ((|>)) +-- import qualified Data.Sequence as Seq import Generics.MultiRec 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 - heqH pf (F x) (F y) = heqT pf (from' pf x) (from' pf y) - -instance (Fam phi, HOrd phi (PF phi), HFunctor phi (PF phi)) => HOrd0 phi (Family phi) where - compareH0 pf (F x) (F y) = hcompare pf (from' pf x) (from' pf y) - -instance (El phi ix, Fam phi, HEq phi (PF phi), HFunctor phi (PF phi)) => Eq (Family phi ix) where - x == y = heqH (prove x) x y - -instance (El phi ix, Fam phi, HOrd phi (PF phi), HFunctor phi (PF phi)) => Ord (Family phi ix) where - x `compare` y = compareH0 (prove x) x y - -instance HEq0 phi r => HEq0 phi (FamT phi r) where - heqH pf (FamT x) (FamT y) = heqH pf x y +type instance TrieMap (Family phi ix) = FamMap phi (HTrieMapT phi (PF phi)) ix -instance HOrd0 phi r => HOrd0 phi (FamT phi r) where - compareH0 pf (FamT x) (FamT y) = compareH0 pf x y +to' :: (Fam phi, HFunctor phi (PF phi)) => phi ix -> PF phi (Family phi) ix -> Family phi ix +to' pf = F . to pf . hmap (\ _ (F x) -> I0 x) pf -instance (El phi ix, HEq0 phi r) => Eq (FamT phi r ix) where - x == y = heqH (prove' x) x y +push :: (Fam phi, HFunctor phi (PF phi)) => phi ix -> (Family phi ix -> a) -> PF phi (Family phi) ix -> a +push pf f = f . to' pf -instance (El phi ix, HOrd0 phi r) => Ord (FamT phi r ix) where - x `compare` y = compareH0 (prove' x) x y +from' :: (Fam phi, HFunctor phi (PF phi)) => phi ix -> Family phi ix -> PF phi (Family phi) ix +from' pf (F x) = hmap (const (F . unI0)) pf (from pf x) -prove' :: El phi ix => FamT phi r ix -> phi ix -prove' _ = proof +from'' :: (Fam phi, HFunctor phi (PF phi), El phi ix) => Family phi ix -> PF phi (Family phi) ix +from'' = from' proof -prove :: El phi ix => Family phi ix -> phi ix -prove _ = proof +instance (Fam phi, HFunctor phi (PF phi), HEq phi (PF phi)) => HEq0 phi (Family phi) where + heq0 pf a b = heqT pf (from' pf a) (from' pf b) -from' :: (Fam phi, HFunctor phi (PF phi)) => phi ix -> ix -> PF phi (Family phi) ix -from' pf = hmap (const (F . unI0)) pf . from pf +instance (Fam phi, HFunctor phi (PF phi), HOrd phi (PF phi)) => HOrd0 phi (Family phi) where + compare0 pf a b = hcompare pf (from' pf a) (from' pf b) -to' :: (Fam phi, HFunctor phi (PF phi)) => phi ix -> PF phi (Family phi) ix -> ix -to' pf = to pf . hmap (\ _ (F x) -> I0 x) pf +instance (Fam phi, HFunctor phi (PF phi), HEq phi (PF phi), El phi ix) => Eq (Family phi ix) where + a == b = heq0 (prove a) a b where + prove :: El phi ix => Family phi ix -> phi ix + prove _ = proof -push :: (Fam phi, HFunctor phi (PF phi)) => phi ix -> (Family phi ix -> a) -> PF phi (Family phi) ix -> a -push pf f = f . F . to' pf +instance (Fam phi, HFunctor phi (PF phi), HOrd phi (PF phi), El phi ix) => Ord (Family phi ix) where + compare a b = compare0 (prove a) a b where + prove :: El phi ix => Family phi ix -> phi ix + prove _ = proof 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 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) = 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 - foldWithKeyH pf f (FamMap m) = foldWithKeyT pf (push pf f) m - foldlWithKeyH pf f (FamMap m) = foldlWithKeyT pf (push pf f) m - mapEitherH pf s1 s2 f (FamMap m) = (FamMap *** FamMap) (mapEitherT pf s1 s2 (push pf f) m) - splitLookupH pf s f (F k) (FamMap m) = FamMap `sides` splitLookupT pf s f (from' pf k) m - unionH pf s f (FamMap m1) (FamMap m2) = FamMap (unionT pf s (push pf f) m1 m2) - isectH pf s f (FamMap m1) (FamMap m2) = FamMap (isectT pf s (push pf f) m1 m2) - diffH pf s f (FamMap m1) (FamMap m2) = FamMap (diffT pf s (push pf f) m1 m2) - 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 ix a = FMap (m ix a) -type instance TrieMap (Family phi ix) = FMap phi (HTrieMap phi (Family phi)) ix - -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 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 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) + empty0 pf = FamMap (emptyH pf) + null0 pf (FamMap m) = nullH pf m + size0 pf s (FamMap m) = sizeH pf s m + lookup0 pf k (FamMap m) = lookupH pf (from' pf k) m + lookupIx0 pf s k (FamMap m) = onKey (to' pf) (lookupIxH pf s (from' pf k) m) + assocAt0 pf s i (FamMap m) = onKey (to' pf) (assocAtH pf s i m) + alter0 pf s f k (FamMap m) = FamMap (alterH pf s f (from' pf k) m) + extract0 pf s f (FamMap m) = fmap FamMap <$> extractH pf s (push pf f) m + alterLookup0 pf s f k (FamMap m) = FamMap <$> alterLookupH pf s f (from' pf k) m + traverseWithKey0 pf s f (FamMap m) = FamMap <$> traverseWithKeyH pf s (push pf f) m + foldWithKey0 pf f (FamMap m) = foldWithKeyH pf (push pf f) m + foldlWithKey0 pf f (FamMap m) = foldlWithKeyH pf (push pf f) m + mapEither0 pf s1 s2 f (FamMap m) = (FamMap *** FamMap) (mapEitherH pf s1 s2 (push pf f) m) + splitLookup0 pf s f k (FamMap m) = FamMap `sides` splitLookupH pf s f (from' pf k) m + union0 pf s f (FamMap m1) (FamMap m2) = FamMap (unionH pf s (push pf f) m1 m2) + isect0 pf s f (FamMap m1) (FamMap m2) = FamMap (isectH pf s (push pf f) m1 m2) + diff0 pf s f (FamMap m1) (FamMap m2) = FamMap (diffH pf s (push pf f) m1 m2) + isSubmap0 pf (<=) (FamMap m1) (FamMap m2) = isSubmapH pf (<=) m1 m2 + fromList0 pf s f xs = FamMap (fromListH pf s (push pf f) [(from' pf k, a) | (k, a) <- xs]) + fromAscList0 pf s f xs = FamMap (fromAscListH pf s (push pf f) [(from' pf k, a) | (k, a) <- xs]) + fromDistAscList0 pf s xs = FamMap (fromDistAscListH pf s [(from' pf k, a) | (k, a) <- xs]) -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) +instance (Fam phi, HFunctor phi (PF phi), El phi ix, HTrieKeyT phi (PF phi) m) => TrieKey (Family phi ix) (FamMap phi m ix) where + emptyM = empty0 proof + nullM = null0 proof + sizeM = size0 proof + lookupM = lookup0 proof + lookupIxM = lookupIx0 proof + assocAtM = assocAt0 proof + alterM = alter0 proof + alterLookupM = alterLookup0 proof + extractM = extract0 proof + traverseWithKeyM = traverseWithKey0 proof + foldWithKeyM = foldWithKey0 proof + foldlWithKeyM = foldlWithKey0 proof + mapEitherM = mapEither0 proof + splitLookupM = splitLookup0 proof + unionM = union0 proof + isectM = isect0 proof + diffM = diff0 proof + isSubmapM = isSubmap0 proof + fromListM = fromList0 proof + fromAscListM = fromAscList0 proof + fromDistAscListM = fromDistAscList0 proof diff --git a/Data/TrieMap/MultiRec/FixMap.hs b/Data/TrieMap/MultiRec/FixMap.hs deleted file mode 100644 --- a/Data/TrieMap/MultiRec/FixMap.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# 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 diff --git a/Data/TrieMap/MultiRec/IMap.hs b/Data/TrieMap/MultiRec/IMap.hs --- a/Data/TrieMap/MultiRec/IMap.hs +++ b/Data/TrieMap/MultiRec/IMap.hs @@ -4,8 +4,9 @@ import Data.TrieMap.MultiRec.Class import Data.TrieMap.MultiRec.Sized -import Data.TrieMap.MultiRec.TH --- import Data.TrieMap.Rep.TH +-- import Data.TrieMap.MultiRec.KeyFam +-- import Data.TrieMap.MultiRec.TT +-- import Data.TrieMap.Rep.TT -- import Data.TrieMap.Rep import Data.TrieMap.TrieKey @@ -16,41 +17,40 @@ 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 +-- type instance TTrieMap phi (I xi r) = TTrieMapH phi (I xi) r --- 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) +-- type instance RepH (IMap phi xi r ix) = RepH (TTrieMap phi r xi) +-- type instance Rep (IMap phi xi r ix a) = RepH (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 |] ) - +-- -- $(genRepH [d| +-- instance ReprH (TTrieMap phi r xi) => ReprH (IMap phi xi r ix) where +-- toRepH (IMap m) = toRepH m +-- fromRepH = IMap . fromRepH |] ) -$(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 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]) |]) +instance (El phi xi) => HTrieKeyT phi (I xi) (IMap phi xi) where + emptyH _ = IMap (empty0 proof) + nullH _ (IMap m) = null0 proof m + sizeH _ s (IMap m) = size0 proof s m + lookupH _ (I k) (IMap m) = lookup0 proof k m + lookupIxH _ s (I k) (IMap m) = onKey I (lookupIx0 proof s k m) + assocAtH _ s i (IMap m) = onKey I (assocAt0 proof s i m) +-- updateAtH _ s r f i (IMap m) = IMap (updateAtH proof s r (\ i' -> f i' . I) i m) + alterH _ s f (I k) (IMap m) = IMap (alter0 proof s f k m) + alterLookupH _ s f (I k) (IMap m) = IMap <$> alterLookup0 proof s f k m + traverseWithKeyH _ s f (IMap m) = IMap <$> traverseWithKey0 proof s (f . I) m + foldWithKeyH _ f (IMap m) = foldWithKey0 proof (f . I) m + foldlWithKeyH _ f (IMap m) = foldlWithKey0 proof (f . I) m + mapEitherH _ s1 s2 f (IMap m) = (IMap *** IMap) (mapEither0 proof s1 s2 (f . I) m) + splitLookupH pf s f (I k) (IMap m) = IMap `sides` splitLookup0 proof s (f) k m + unionH pf s f (IMap m1) (IMap m2) = IMap (union0 proof s (f . I) m1 m2) + isectH pf s f (IMap m1) (IMap m2) = IMap (isect0 proof s (f . I) m1 m2) + diffH pf s f (IMap m1) (IMap m2) = IMap (diff0 proof s (f . I) m1 m2) + extractH pf s f (IMap m) = fmap IMap <$> extract0 proof s (f . I) m +-- extractMinH pf s f (IMap m) = second IMap <$> extractMinH proof s (f . I) m +-- extractMaxH pf s f (IMap m) = second IMap <$> extractMaxH proof s (f . I) m +-- alterMinH pf s f (IMap m) = IMap <$> alterMinH proof s (f . I) m +-- alterMaxH pf s f (IMap m) = IMap <$> alterMaxH proof s (f . I) m + isSubmapH pf (<=) (IMap m1) (IMap m2) = isSubmap0 proof (<=) m1 m2 + fromListH _ s f xs = IMap (fromList0 proof s (f . I) [(k, a) | (I k, a) <- xs]) + fromAscListH _ s f xs = IMap (fromAscList0 proof s (f . I) [(k, a) | (I k, a) <- xs]) + fromDistAscListH _ s xs = IMap (fromDistAscList0 proof s [(k, a) | (I k, a) <- xs]) diff --git a/Data/TrieMap/MultiRec/Instances.hs b/Data/TrieMap/MultiRec/Instances.hs --- a/Data/TrieMap/MultiRec/Instances.hs +++ b/Data/TrieMap/MultiRec/Instances.hs @@ -9,4 +9,4 @@ import Data.TrieMap.MultiRec.FamMap -- import Data.TrieMap.MultiRec.AppMap -- import Data.TrieMap.MultiRec.XMap -import Data.TrieMap.MultiRec.FixMap +-- import Data.TrieMap.MultiRec.FixMap diff --git a/Data/TrieMap/MultiRec/Ord.hs b/Data/TrieMap/MultiRec/Ord.hs --- a/Data/TrieMap/MultiRec/Ord.hs +++ b/Data/TrieMap/MultiRec/Ord.hs @@ -4,69 +4,98 @@ import Data.TrieMap.MultiRec.Eq import Data.TrieMap.MultiRec.Base +import Data.TrieMap.Regular.Ord import Generics.MultiRec import Data.Monoid -type Comparator a = a -> a -> Ordering +-- type Comparator a = a -> a -> Ordering class HEq phi f => HOrd phi f where compareH :: (forall ix . phi ix -> Comparator (r ix)) -> phi ix -> Comparator (f r ix) -hcompare :: (HOrd phi f, HOrd0 phi r) => phi ix -> Comparator (f r ix) -hcompare = compareH compareH0 - class HEq0 phi r => HOrd0 phi r where - compareH0 :: phi ix -> Comparator (r ix) - --- instance 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 + compare0 :: phi ix -> Comparator (r ix) --- instance HOrd phi A0 where --- compareH cmp pf (A0 a) (A0 b) = cmp pf a b +hcompare :: (HOrd phi f, HOrd0 phi r) => phi ix -> Comparator (f r ix) +hcompare = compareH compare0 instance Ord k => HOrd phi (K k) where - compareH _ = compareH0 - -instance Ord k => HOrd0 phi (K k r) where - compareH0 _ (K a) (K b) = compare a b + compareH _ _ (K a) (K b) = compare a b instance El phi xi => HOrd phi (I xi) where compareH cmp _ (I a) (I b) = cmp proof a b -instance (El phi xi, HOrd0 phi r) => HOrd0 phi (I xi r) where - compareH0 = hcompare - -instance HOrd phi U where - compareH _ = compareH0 - -instance HOrd0 phi (U r) where - compareH0 _ _ _ = EQ - instance (HOrd phi f, HOrd phi g) => HOrd phi (f :*: g) where compareH cmp pf (x1 :*: y1) (x2 :*: y2) = compareH cmp pf x1 x2 `mappend` compareH cmp pf y1 y2 -instance (HOrd phi f, HOrd phi g, HOrd0 phi r) => HOrd0 phi ((f :*: g) r) where - compareH0 = hcompare - instance (HOrd phi f, HOrd phi g) => HOrd phi (f :+: g) where - compareH cmp pf x y = case (x, y) of - (L x, L y) -> compareH cmp pf x y - (R x, R y) -> compareH cmp pf x y + compareH cmp pf a b = case (a, b) of + (L a, L b) -> compareH cmp pf a b + (R a, R b) -> compareH cmp pf a b (L _, R _) -> LT - (R _, L _) -> GT - -instance (HOrd phi f, HOrd phi g, HOrd0 phi r) => HOrd0 phi ((f :+: g) r) where - compareH0 = hcompare + _ -> GT instance HOrd phi f => HOrd phi (f :>: ix) where compareH cmp pf (Tag a) (Tag b) = compareH cmp pf a b -instance (HOrd phi f, HOrd0 phi r) => HOrd0 phi ((f :>: ix) r) where - compareH0 pf (Tag a) (Tag b) = hcompare pf a b +instance HOrd phi U where + compareH _ _ _ _ = EQ -instance HOrd phi f => HOrd0 phi (HFix f) where - compareH0 pf (HIn a) (HIn b) = hcompare pf a b +-- hcompare :: (HOrd phi f, HOrd0 phi r) => phi ix -> Comparator (f r ix) +-- hcompare = compareH compareH0 +-- +-- class HEq0 phi r => HOrd0 phi r where +-- compareH0 :: phi ix -> Comparator (r ix) +-- +-- -- instance 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 +-- +-- instance Ord k => HOrd0 phi (K k r) where +-- compareH0 _ (K a) (K b) = compare a b +-- +-- instance El phi xi => HOrd phi (I xi) where +-- compareH cmp _ (I a) (I b) = cmp proof a b +-- +-- instance (El phi xi, HOrd0 phi r) => HOrd0 phi (I xi r) where +-- compareH0 = hcompare +-- +-- instance HOrd phi U where +-- compareH _ = compareH0 +-- +-- instance HOrd0 phi (U r) where +-- compareH0 _ _ _ = EQ +-- +-- instance (HOrd phi f, HOrd phi g) => HOrd phi (f :*: g) where +-- compareH cmp pf (x1 :*: y1) (x2 :*: y2) = compareH cmp pf x1 x2 `mappend` compareH cmp pf y1 y2 +-- +-- instance (HOrd phi f, HOrd phi g, HOrd0 phi r) => HOrd0 phi ((f :*: g) r) where +-- compareH0 = hcompare +-- +-- instance (HOrd phi f, HOrd phi g) => HOrd phi (f :+: g) where +-- compareH cmp pf x y = case (x, y) of +-- (L x, L y) -> compareH cmp pf x y +-- (R x, R y) -> compareH cmp pf x y +-- (L _, R _) -> LT +-- (R _, L _) -> GT +-- +-- instance (HOrd phi f, HOrd phi g, HOrd0 phi r) => HOrd0 phi ((f :+: g) r) where +-- compareH0 = hcompare +-- +-- instance HOrd phi f => HOrd phi (f :>: ix) where +-- compareH cmp pf (Tag a) (Tag b) = compareH cmp pf a b +-- +-- instance (HOrd phi f, HOrd0 phi r) => HOrd0 phi ((f :>: ix) r) where +-- compareH0 pf (Tag a) (Tag b) = hcompare pf a b +-- +-- instance HOrd phi f => HOrd0 phi (HFix f) where +-- compareH0 pf (HIn a) (HIn b) = hcompare pf a b diff --git a/Data/TrieMap/MultiRec/ProdMap.hs b/Data/TrieMap/MultiRec/ProdMap.hs --- a/Data/TrieMap/MultiRec/ProdMap.hs +++ b/Data/TrieMap/MultiRec/ProdMap.hs @@ -4,10 +4,12 @@ import Data.TrieMap.MultiRec.Class import Data.TrieMap.MultiRec.Eq -import Data.TrieMap.MultiRec.Ord +-- import Data.TrieMap.MultiRec.Ord import Data.TrieMap.MultiRec.Sized -import Data.TrieMap.MultiRec.TH -import Data.TrieMap.Regular.Base (O(..)) +-- import Data.TrieMap.MultiRec.TH +-- import Data.TrieMap.Regular.Eq +-- import Data.TrieMap.Regular.Ord +-- import Data.TrieMap.Regular.Base (O(..)) import Data.TrieMap.Applicative import Data.TrieMap.TrieKey -- import Data.TrieMap.Rep @@ -26,113 +28,114 @@ 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 +-- type instance HTrieMap phi ((f :*: g) r) = HTrieMapT phi (f :*: g) r --- 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) +-- type instance RepH (ProdMap phi f g r ix) = RepH (HTrieMapT phi f r ix) `O` RepH (HTrieMapT phi g r ix) +-- type instance Rep (ProdMap phi f g r ix a) = RepH (ProdMap phi f g r ix) (Rep a) --- -- $(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)) |] ) +-- -- $(genRepH [d| +-- instance (ReprH (HTrieMapT phi f r ix), ReprH (HTrieMapT phi g r ix)) => +-- ReprH (ProdMap phi f g r ix) where +-- toRepH (PMap m) = O (fmap toRepH (toRepH m)) +-- fromRepH (O m) = PMap (fromRepH (fmap fromRepH m)) |] ) 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)) +maxIx pf s m = fromMaybe (sizeH pf s m) (getFirst (aboutH pf (\ _ a -> return (sizeH pf s m - s a)) m)) -$(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 +instance (HTrieKeyT phi f (HTrieMapT phi f), HTrieKeyT phi g (HTrieMapT phi g)) => + HTrieKeyT phi (f :*: g) (ProdMap phi f g) where + emptyH = PMap . emptyH + nullH pf (PMap m) = nullH pf m + sizeH pf s (PMap m) = sizeH pf (sizeH pf s) m + lookupH pf (a :*: b) (PMap m) = lookupH pf a m >>= lookupH pf b + lookupIxH pf s (a :*: b) (PMap m) = case lookupIxH pf (sizeH pf s) a m of + (lb, x, rb) -> let lookupX = do Asc i a' m' <- x + let (lb', x', rb') = lookupIxH 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 = aboutH pf (\ k a -> return (Asc (sizeH pf s m - s a) k a)) m + getFirst pf s m = aboutH pf (\ k a -> return (Asc 0 k a)) m + assocAtH pf s i (PMap m) = case assocAtH pf (sizeH pf s) i m of + (lb, x, rb) -> let lookupX = do Asc i' a' m' <- x + let (lb', x', rb') = assocAtH 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 = aboutH pf (\ k a -> return (Asc (sizeH pf s m - s a) k a)) m + getFirst pf s m = aboutH pf (\ k a -> return (Asc 0 k a)) m +-- updateAtH pf s r f i (PMap m) = PMap (updateAtH pf (sizeH pf s) r g i m) where +-- g iA a m +-- | i >= iA && i <= iA + maxIx pf s m +-- = (guardNullH pf . updateAtH 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 +-- = guardNullH pf $ +-- alterMaxH pf s (\ b v -> f (iA + sizeH 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]) +-- = guardNullH pf $ alterMinH pf s (f iA . (a :*:)) m + alterH pf s f (a :*: b) (PMap m) = PMap (alterH pf (sizeH pf s) (guardNullH pf . g) a m) where + g = alterH pf s f b . fromMaybe (emptyH pf) + alterLookupH pf s f (a :*: b) (PMap m) = PMap <$> alterLookupH pf (sizeH pf s) g a m where + g = fmap (guardNullH pf) . alterLookupH pf s f b . fromMaybe (emptyH pf) + traverseWithKeyH pf s f (PMap m) = + PMap <$> traverseWithKeyH pf (sizeH pf s) (\ a -> traverseWithKeyH pf s (\ b -> f (a :*: b))) m + foldWithKeyH pf f (PMap m) = + foldWithKeyH pf (\ a -> foldWithKeyH pf (\ b -> f (a :*: b))) m + foldlWithKeyH pf f (PMap m) = + foldlWithKeyH pf (\ a -> flip (foldlWithKeyH pf (\ b -> f (a :*: b)))) m + mapEitherH pf s1 s2 f (PMap m) = (PMap *** PMap) (mapEitherH pf (sizeH pf s1) (sizeH pf s2) g m) where + g a = (guardNullH pf *** guardNullH pf) . mapEitherH pf s1 s2 (\ b -> f (a :*: b)) + splitLookupH pf s f (a :*: b) (PMap m) = PMap `sides` splitLookupH pf (sizeH pf s) g a m where + g = sides (guardNullH pf) . splitLookupH pf s f b + unionH pf s f (PMap m1) (PMap m2) = PMap (unionH pf (sizeH pf s) g m1 m2) where + g a = guardNullH pf .: unionH pf s (\ b -> f (a :*: b)) + isectH pf s f (PMap m1) (PMap m2) = PMap (isectH pf (sizeH pf s) g m1 m2) where + g a = guardNullH pf .: isectH pf s (\ b -> f (a :*: b)) + diffH pf s f (PMap m1) (PMap m2) = PMap (diffH pf (sizeH pf s) g m1 m2) where + g a = guardNullH pf .: diffH pf s (\ b -> f (a :*: b)) + extractH pf s f (PMap m) = fmap PMap <$> extractH pf (sizeH pf s) g m where + g a = fmap (guardNullH pf) <.> extractH pf s (\ b -> f (a :*: b)) +-- extractMinH pf s f (PMap m) = second PMap <$> extractMinH pf (sizeH pf s) g m where +-- g a m1 = fromJust $ getFirst $ second (guardNullH pf) <$> extractMinH pf s (f . (a :*:)) m1 +-- extractMaxH pf s f (PMap m) = second PMap <$> extractMaxH pf (sizeH pf s) g m where +-- g a m1 = fromJust $ getLast $ second (guardNullH pf) <$> extractMaxH pf s (f . (a :*:)) m1 +-- alterMinH pf s f (PMap m) = PMap (alterMinH pf (sizeH pf s) g m) where +-- g a = guardNullH pf . alterMinH pf s (\ b -> f (a :*: b)) +-- alterMaxH pf s f (PMap m) = PMap (alterMaxH pf (sizeH pf s) g m) where +-- g a = guardNullH pf . alterMaxH pf s (\ b -> f (a :*: b)) + isSubmapH pf (<=) (PMap m1) (PMap m2) = isSubmapH pf (isSubmapH pf (<=)) m1 m2 + fromListH pf s f xs = PMap (mapWithKeyH pf (sizeH pf s) (\ a -> fromListH pf s (\ b -> f (a :*: b))) + (fromListH pf (const 1) (\ _ (xs) (ys) -> (xs ++ ys)) + [(a, ts) | (a, ts) <- breakFst pf xs])) + fromAscListH pf s f xs = PMap (fromDistAscListH pf (sizeH pf s) + [(a, fromAscListH pf s (\ b -> f (a :*: b)) ts) | (a, ts) <- breakFst pf xs]) + fromDistAscListH pf s xs = PMap (fromDistAscListH pf (sizeH pf s) + [(a, fromDistAscListH 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)] - |]) +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)] diff --git a/Data/TrieMap/MultiRec/TH.hs b/Data/TrieMap/MultiRec/TH.hs deleted file mode 100644 --- a/Data/TrieMap/MultiRec/TH.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# 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 diff --git a/Data/TrieMap/MultiRec/TagMap.hs b/Data/TrieMap/MultiRec/TagMap.hs --- a/Data/TrieMap/MultiRec/TagMap.hs +++ b/Data/TrieMap/MultiRec/TagMap.hs @@ -5,8 +5,9 @@ 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.CPair +-- import Data.TrieMap.MultiRec.TH +-- import Data.TrieMap.Applicative import Data.TrieMap.TrieKey -- import Data.TrieMap.Rep @@ -15,8 +16,8 @@ import Control.Monad import Data.Maybe -import Data.Monoid -import Data.Foldable +-- import Data.Monoid +-- import Data.Foldable import Generics.MultiRec data TagF a ix xi where @@ -27,7 +28,7 @@ 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 +-- type instance HTrieMap phi ((f :>: ix) r) = HTrieMapT phi (f :>: ix) r -- 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) @@ -54,60 +55,59 @@ ((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 +restructure' :: Applicative t => ((f :>: xi) r ix -> a -> t (CPair x (Maybe a))) -> f r ix -> TagF a xi ix -> t (CPair x (Maybe (TagF a xi ix))) +restructure' f k (TagF a) = fmap (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 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) = onValue retag (lookupIxT pf (sizeTag s) k m) - assocAtT pf s i (TagMap m) = onValue retag (assocAtT pf (sizeTag s) i m) +instance (HTrieKeyT phi f (HTrieMapT phi f)) => HTrieKeyT phi (f :>: ix) (TagMap phi m ix) where + emptyH = TagMap . emptyH + nullH pf (TagMap m) = nullH pf m + sizeH pf s (TagMap m) = sizeH pf (sizeTag s) m + lookupH pf (Tag k) (TagMap m) = unTagF <$> lookupH pf k m + lookupIxH pf s (Tag k) (TagMap m) = onValue retag (lookupIxH pf (sizeTag s) k m) + assocAtH pf s i (TagMap m) = onValue retag (assocAtH 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 + alterH pf s f (Tag k) (TagMap m) = TagMap (alterH pf (sizeTag s) (fmap TagF . f . fmap unTagF) k m) + alterLookupH pf s f (Tag k) (TagMap m) = TagMap <$> alterLookupH pf (sizeTag s) (fmap (fmap TagF) . f . fmap unTagF) k m + traverseWithKeyH pf s f (TagMap m) = TagMap <$> traverseWithKeyH pf (sizeTag s) (mapTag f) m where 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 + foldWithKeyH pf f (TagMap m) = foldWithKeyH pf (f' f) m where 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 + foldlWithKeyH pf f (TagMap m) = foldlWithKeyH pf (f' f) m where 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 + mapEitherH pf s1 s2 f (TagMap m) = (TagMap *** TagMap) (mapEitherH pf (sizeTag s1) (sizeTag s2) (f' f) m) where 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 + splitLookupH pf s f (Tag k) (TagMap m) = TagMap `sides` splitLookupH pf (sizeTag s) (f' f) k m where 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) + unionH pf s f (TagMap m1) (TagMap m2) = TagMap (unionH pf (sizeTag s) (combineTag f) m1 m2) + isectH pf s f (TagMap m1) (TagMap m2) = TagMap (isectH pf (sizeTag s) (combineTag f) m1 m2) + diffH pf s f (TagMap m1) (TagMap m2) = TagMap (diffH pf (sizeTag s) (combineTag f) m1 m2) -- 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 + extractH pf s f (TagMap m) = fmap TagMap <$> extractH 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 + isSubmapH pf (<=) (TagMap m1) (TagMap m2) = isSubmapH pf (le (<=)) m1 m2 where 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 + fromListH pf s f xs = TagMap (fromListH pf (sizeTag s) (f' f) [(k, TagF a) | (Tag k, a) <- xs]) where 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 + fromAscListH pf s f xs = TagMap (fromAscListH pf (sizeTag s) (f' f) [(k, TagF a) | (Tag k, a) <- xs]) where 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 + fromDistAscListH pf s xs = TagMap (fromDistAscListH pf (sizeTag s) (map f xs)) where 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 f ix r) where diff --git a/Data/TrieMap/MultiRec/UnionMap.hs b/Data/TrieMap/MultiRec/UnionMap.hs --- a/Data/TrieMap/MultiRec/UnionMap.hs +++ b/Data/TrieMap/MultiRec/UnionMap.hs @@ -3,112 +3,114 @@ 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.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 Data.TrieMap.MultiRec.TH +-- import qualified Data.TrieMap.Regular.Base as Reg import Control.Applicative -import Control.Arrow +-- import Control.Arrow import Control.Monad -import Data.Maybe -import Data.Monoid -import Data.Foldable +-- import Data.Maybe +-- import Data.Monoid +-- import Data.Foldable import Generics.MultiRec import Prelude hiding (foldr) 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 +-- type instance HTrieMap phi ((f :+: g) r) = HTrieMapH phi (f :+: g) r --- 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) +-- type instance RepH (UnionMap phi f g r ix) = (Reg.:*:) (RepH (HTrieMapH phi f r ix)) (RepH (HTrieMapH phi g r ix)) +-- type instance Rep (UnionMap phi f g r ix a) = RepH (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 +-- -- $(genRepH [d| +-- instance (ReprH (HTrieMapH phi f r ix), ReprH (HTrieMapH phi g r ix)) => ReprH (UnionMap phi f g r ix) where +-- toRepH (m1 :&: m2) = (Reg.:*:) (toRepH m1) (toRepH m2) +-- fromRepH ((Reg.:*:) m1 m2) = fromRepH m1 :&: fromRepH 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 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 = 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 +instance (HTrieKeyT phi f (HTrieMapT phi f), HTrieKeyT phi g (HTrieMapT phi g)) => HTrieKeyT phi (f :+: g) (UnionMap phi f g) where + emptyH = liftM2 (:&:) emptyH emptyH + nullH pf (m1 :&: m2) = nullH pf m1 && nullH pf m2 + sizeH pf s (m1 :&: m2) = sizeH pf s m1 + sizeH pf s m2 + lookupH pf k (m1 :&: m2) + | L k <- k = lookupH pf k m1 + | R k <- k = lookupH pf k m2 + lookupIxH pf s k (m1 :&: m2) + | L k <- k = case onKey L (lookupIxH pf s k m1) of + (lb, x, ub) -> (lb, x, ub <|> ((onKeyA R . onIndexA (+ sizeH pf s m1)) <$> getMin pf s m2)) + | R k <- k = case onIndex (sizeH pf s m1 +) (onKey R (lookupIxH 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 = case onKey L (assocAtT pf s i m1) of + where getMin pf s m = aboutH pf (\ k a -> return $ Asc 0 k a) m + getMax pf s m = aboutH pf (\ k a -> return $ Asc (sizeH pf s m - s a) k a) m + assocAtH pf s i (m1 :&: m2) + | i < s1 = case onKey L (assocAtH 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 + | otherwise = case onKey R (onIndex (s1 +) (assocAtH 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) + where getMin pf s m = aboutH pf (\ k a -> return $ Asc 0 k a) m + getMax pf s m = aboutH pf (\ k a -> return $ Asc (sizeH pf s m - s a) k a) m + s1 = sizeH pf s m1 +{- updateAtH 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 + = m1 :&: updateAtH pf s r (\ i' -> f (i' + s1) . R) (i - s1) m2 | i < s1 - = updateAtT pf s r (\ i' -> f i' . L) i m1 :&: m2 + = updateAtH 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 - traverseWithKeyT pf s f (m1 :&: m2) - = (:&:) <$> traverseWithKeyT pf s (f . L) m1 <*> traverseWithKeyT pf s (f . R) m2 - foldWithKeyT pf f (m1 :&: m2) - = foldWithKeyT pf (f . L) m1 . foldWithKeyT pf (f . R) m2 - foldlWithKeyT pf f (m1 :&: m2) - = foldlWithKeyT pf (f . R) m2 . foldlWithKeyT pf (f . L) m1 - mapEitherT pf s1 s2 f (m1 :&: m2) = case (mapEitherT pf s1 s2 (f . L) m1, mapEitherT pf s1 s2 (f . R) m2) of + = m1 :&: updateAtH pf s r (\ i' -> f (i' + s1) . R) (i - s1) m2 + where s1 = sizeH pf s m1 + lastIx m = case extractMaxH pf s (\ _ v -> (v, Just v)) m of + Last (Just (v, _)) -> sizeH pf s m - s v + _ -> sizeH pf s m-} + alterH pf s f k (m1 :&: m2) + | L k <- k = alterH pf s f k m1 :&: m2 + | R k <- k = m1 :&: alterH pf s f k m2 + alterLookupH pf s f k (m1 :&: m2) + | L k <- k = fmap (:&: m2) (alterLookupH pf s f k m1) + | R k <- k = fmap (m1 :&:) (alterLookupH pf s f k m2) + traverseWithKeyH pf s f (m1 :&: m2) + = (:&:) <$> traverseWithKeyH pf s (f . L) m1 <*> traverseWithKeyH pf s (f . R) m2 + foldWithKeyH pf f (m1 :&: m2) + = foldWithKeyH pf (f . L) m1 . foldWithKeyH pf (f . R) m2 + foldlWithKeyH pf f (m1 :&: m2) + = foldlWithKeyH pf (f . R) m2 . foldlWithKeyH pf (f . L) m1 + mapEitherH pf s1 s2 f (m1 :&: m2) = case (mapEitherH pf s1 s2 (f . L) m1, mapEitherH pf s1 s2 (f . R) m2) of ((m1L, m1R), (m2L, m2R)) -> (m1L :&: m2L, m1R :&: m2R) - splitLookupT pf s f k0 (m1 :&: m2) - | L k <- k0, (m1L, x, m1R) <- splitLookupT pf s f k m1 - = (m1L :&: emptyT pf, x, m1R :&: m2) - | R k <- k0, (m2L, x, m2R) <- splitLookupT pf s f k m2 - = (m1 :&: m2L, x, emptyT pf :&: m2R) - unionT pf s f (m11 :&: m12) (m21 :&: m22) - = unionT pf s (f . L) m11 m21 :&: unionT pf s (f . R) m12 m22 - isectT pf s f (m11 :&: m12) (m21 :&: m22) - = isectT pf s (f . L) m11 m21 :&: isectT pf s (f . R) m12 m22 - diffT pf s f (m11 :&: m12) (m21 :&: m22) - = diffT pf s (f . L) m11 m21 :&: diffT pf s (f . R) m12 m22 - 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 - (ys, zs) -> fromListT pf s (f . L) ys :&: fromListT pf s (f . R) zs - fromAscListT pf s f xs = case breakEither xs of - (ys, zs) -> fromAscListT pf s (f . L) ys :&: fromAscListT pf s (f . R) zs - fromDistAscListT pf s xs = case breakEither xs of - (ys, zs) -> fromDistAscListT pf s ys :&: fromDistAscListT pf s zs |]) + splitLookupH pf s f k0 (m1 :&: m2) + | L k <- k0, (m1L, x, m1R) <- splitLookupH pf s f k m1 + = (m1L :&: emptyH pf, x, m1R :&: m2) + | R k <- k0, (m2L, x, m2R) <- splitLookupH pf s f k m2 + = (m1 :&: m2L, x, emptyH pf :&: m2R) + unionH pf s f (m11 :&: m12) (m21 :&: m22) + = unionH pf s (f . L) m11 m21 :&: unionH pf s (f . R) m12 m22 + isectH pf s f (m11 :&: m12) (m21 :&: m22) + = isectH pf s (f . L) m11 m21 :&: isectH pf s (f . R) m12 m22 + diffH pf s f (m11 :&: m12) (m21 :&: m22) + = diffH pf s (f . L) m11 m21 :&: diffH pf s (f . R) m12 m22 + extractH pf s f (m1 :&: m2) = fmap (:&: m2) <$> extractH pf s (f . L) m1 <|> + fmap (m1 :&:) <$> extractH pf s (f . R) m2 +-- extractMinH pf s f (m1 :&: m2) = second (:&: m2) <$> extractMinH pf s (f . L) m1 <|> +-- second (m1 :&:) <$> extractMinH pf s (f . R) m2 +-- extractMaxH pf s f (m1 :&: m2) = second (:&: m2) <$> extractMaxH pf s (f . L) m1 <|> +-- second (m1 :&:) <$> extractMaxH pf s (f . R) m2 +-- alterMinH pf s f (m1 :&: m2) +-- | nullH pf m1 = m1 :&: alterMinH pf s (f . R) m2 +-- | otherwise = alterMinH pf s (f . L) m1 :&: m2 +-- alterMaxH pf s f (m1 :&: m2) +-- | nullH pf m2 = alterMaxH pf s (f . L) m1 :&: m2 +-- | otherwise = m1 :&: alterMaxH pf s (f . R) m2 + isSubmapH pf (<=) (m11 :&: m12) (m21 :&: m22) + = isSubmapH pf (<=) m11 m21 && isSubmapH pf (<=) m12 m22 + fromListH pf s f xs = case breakEither xs of + (ys, zs) -> fromListH pf s (f . L) ys :&: fromListH pf s (f . R) zs + fromAscListH pf s f xs = case breakEither xs of + (ys, zs) -> fromAscListH pf s (f . L) ys :&: fromAscListH pf s (f . R) zs + fromDistAscListH pf s xs = case breakEither xs of + (ys, zs) -> fromDistAscListH pf s ys :&: fromDistAscListH pf s zs diff --git a/Data/TrieMap/MultiRec/UnitMap.hs b/Data/TrieMap/MultiRec/UnitMap.hs --- a/Data/TrieMap/MultiRec/UnitMap.hs +++ b/Data/TrieMap/MultiRec/UnitMap.hs @@ -12,7 +12,7 @@ import Control.Applicative import Control.Arrow -import Control.Monad +-- import Control.Monad import Data.Maybe import Data.Monoid @@ -24,7 +24,7 @@ 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 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) @@ -35,33 +35,6 @@ -- fromRepT = UMap . fromRepT |]) instance HTrieKeyT phi U (UMap phi) where - emptyT = emptyH - nullT = nullH - sizeT = sizeH - lookupT = lookupH - lookupIxT = lookupIxH - assocAtT = assocAtH --- updateAtT = updateAtH - alterT = alterH - traverseWithKeyT = traverseWithKeyH - foldWithKeyT = foldWithKeyH - foldlWithKeyT = foldlWithKeyH - mapEitherT = mapEitherH - splitLookupT = splitLookupH - unionT = unionH - isectT = isectH - diffT = diffH - extractT = extractH --- extractMinT = extractMinH --- extractMaxT = extractMaxH --- alterMinT = alterMinH --- alterMaxT = alterMaxH - isSubmapT = isSubmapH - fromListT = fromListH - fromAscListT = fromAscListH - fromDistAscListT = fromDistAscListH - -instance HTrieKey phi (U r) (UMap phi r) where emptyH _ = UMap Nothing nullH _ (UMap m) = isNothing m sizeH _ s (UMap m) = maybe 0 s m @@ -74,6 +47,7 @@ -- | otherwise -- = UMap m alterH _ _ f _ (UMap m) = UMap (f m) + alterLookupH _ _ f _ (UMap m) = UMap <$> f m traverseWithKeyH _ _ f (UMap m) = UMap <$> traverse (f U) m foldWithKeyH _ f (UMap m) z = foldr (f U) z m foldlWithKeyH _ f (UMap m) z = foldl (f U) z m @@ -82,7 +56,7 @@ 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) - extractH _ _ f (UMap m) = maybe empty (second UMap <.> f U) m + extractH _ _ f (UMap m) = maybe empty (fmap 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) diff --git a/Data/TrieMap/OrdMap.hs b/Data/TrieMap/OrdMap.hs --- a/Data/TrieMap/OrdMap.hs +++ b/Data/TrieMap/OrdMap.hs @@ -4,21 +4,22 @@ import Data.TrieMap.TrieKey import Data.TrieMap.Sized -import Data.TrieMap.Applicative +-- import Data.TrieMap.Applicative import Data.TrieMap.Modifiers -import Data.TrieMap.MultiRec.Base +import Data.TrieMap.CPair +-- import Data.TrieMap.MultiRec.Base -- import Data.TrieMap.Rep -- import Data.TrieMap.Rep.TH import Control.Applicative (Applicative(..), Alternative(..), (<$>)) -import Control.Arrow +-- import Control.Arrow import Control.Monad hiding (join) -import Data.Monoid -import Data.Maybe +-- import Data.Monoid +-- import Data.Maybe -- import Data.Map -- import qualified Data.Map as Map -import Data.Traversable +-- import Data.Traversable import Prelude hiding (lookup) @@ -50,6 +51,7 @@ 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 + alterLookupM s f (Ord k) = alterLookup s f k traverseWithKeyM s f = traverseWithKey s (f . Ord) foldWithKeyM f = foldrWithKey (f . Ord) foldlWithKeyM f = foldlWithKey (f . Ord) @@ -149,6 +151,13 @@ Just x' -> balance s k x' l r GT -> balance s kx x l (alter s f k r) +alterLookup :: Ord k => Sized a -> (Maybe a -> CPair z (Maybe a)) -> k -> OrdMap k a -> CPair z (OrdMap k a) +alterLookup s f k Tip = maybe Tip (singleton s k) <$> f Nothing +alterLookup s f k (Bin _ kx x l r) = case compare k kx of + LT -> fmap (\ l' -> balance s kx x l' r) (alterLookup s f k l) + EQ -> maybe (glue s l r) (\ x' -> balance s k x' l r) <$> f (Just x) + GT -> fmap (\ r' -> balance s kx x l r') (alterLookup s f k r) + singleton :: Sized a -> k -> a -> OrdMap k a singleton s k a = Bin (s a) k a Tip Tip @@ -371,12 +380,12 @@ | 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' -extract :: Alternative t => Sized a -> (k -> a -> t (z, Maybe a)) -> OrdMap k a -> t (z, OrdMap k a) +extract :: Alternative t => Sized a -> (k -> a -> t (CPair z (Maybe a))) -> OrdMap k a -> t (CPair 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 + fmap (\ l' -> balance s k x l' r) <$> extract s f l <|> + fmap (maybe (glue s l r) (\ x' -> balance s k x' l r)) <$> f k x <|> + fmap (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 diff --git a/Data/TrieMap/ProdMap.hs b/Data/TrieMap/ProdMap.hs new file mode 100644 --- /dev/null +++ b/Data/TrieMap/ProdMap.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE FlexibleContexts, UndecidableInstances, MultiParamTypeClasses, TypeFamilies #-} + +module Data.TrieMap.ProdMap () where + +import Data.TrieMap.TrieKey +-- import Data.TrieMap.Sized +import Data.TrieMap.Applicative +import Data.TrieMap.Regular.Class +-- import Data.TrieMap.Regular.TH + +import Control.Applicative +import Control.Arrow + +import Data.Maybe +import Data.Monoid +import Data.Foldable + +import Data.Sequence (Seq, (|>)) +import qualified Data.Sequence as Seq + +newtype PMap m1 k2 a = PMap (m1 (TrieMap k2 a)) +type instance TrieMapT ((,) a) = PMap (TrieMap a) +type instance TrieMap (a, b) = PMap (TrieMap a) b +-- type instance TrieMap (a, b) = PMap (TrieMap a) (TrieMap b) + +instance (TrieKey a m, TrieKey b (TrieMap b)) => TrieKey (a, b) (PMap m b) where + emptyM = emptyT + nullM = nullT + lookupM = lookupT + lookupIxM = lookupIxT + assocAtM = assocAtT + alterM = alterT + alterLookupM = alterLookupT + traverseWithKeyM = traverseWithKeyT + foldWithKeyM = foldWithKeyT + foldlWithKeyM = foldlWithKeyT + mapEitherM = mapEitherT + splitLookupM = splitLookupT + unionM = unionT + isectM = isectT + diffM = diffT + extractM = extractT + isSubmapM = isSubmapT + fromListM = fromListT + fromAscListM = fromAscListT + fromDistAscListM = fromDistAscListT + +instance TrieKey k1 m1 => TrieKeyT ((,) k1) (PMap m1) where + emptyT = PMap emptyM + nullT (PMap m) = nullM m + sizeT s (PMap m) = sizeM (sizeM s) m + lookupT (k1, k2) (PMap m) = lookupM k1 m >>= lookupM k2 + lookupIxT s (a, b) (PMap m) = case lookupIxM (sizeM s) a m of + (lb, x, ub) -> let lookupX = do Asc i1 a' m' <- x + return (onIndex (i1 +) (onKey ((,) a') (lookupIxM s b m'))) + in ((do Asc iL aL mL <- lb + aboutM (\ bL v -> return (Asc (iL + sizeM s mL - s v) (aL, bL) v)) mL) <|> + (do (lb', _, _) <- Last lookupX + lb'), + (do (_, x', _) <- lookupX + x'), + (do (_, _, ub') <- First lookupX + ub') <|> + (do Asc iU aU mU <- ub + aboutM (\ bU -> return . Asc iU (aU, bU)) mU)) + assocAtT s i (PMap m) = case assocAtM (sizeM s) i m of + (lb, x, ub) -> let lookupX = do Asc i1 a' m' <- x + return (onIndex (i1 +) (onKey ((,) a') (assocAtM s (i - i1) m'))) + in ((do Asc iL aL mL <- lb + aboutM (\ bL v -> return (Asc (iL + sizeM s mL - s v) (aL, bL) v)) mL) <|> + (do (lb', _, _) <- Last lookupX + lb'), + (do (_, x', _) <- lookupX + x'), + (do (_, _, ub') <- First lookupX + ub') <|> + (do Asc iU aU mU <- ub + aboutM (\ bU -> return . Asc iU (aU, bU)) mU)) +-- updateAtM + alterT s f (a, b) (PMap m) = PMap (alterM (sizeM s) g a m) where + g = guardNullM . alterM s f b . fromMaybe emptyM + alterLookupT s f (a, b) (PMap m) = PMap <$> alterLookupM (sizeM s) g a m where + g = fmap guardNullM . alterLookupM s f b . fromMaybe emptyM + traverseWithKeyT s f (PMap m) = PMap <$> traverseWithKeyM (sizeM s) (\ a -> traverseWithKeyM s (\ b -> f (a, b))) m + foldWithKeyT f (PMap m) = foldWithKeyM (\ a -> foldWithKeyM (\ b -> f (a, b))) m + foldlWithKeyT f (PMap m) = foldlWithKeyM (\ a -> flip (foldlWithKeyM (\ b -> f (a, b)))) m + mapEitherT s1 s2 f (PMap m) = (PMap *** PMap) (mapEitherM (sizeM s1) (sizeM s2) g m) where + g a = (guardNullM *** guardNullM) . mapEitherM s1 s2 (\ b -> f (a, b)) + splitLookupT s f (a, b) (PMap m) = PMap `sides` splitLookupM (sizeM s) g a m where + g = sides guardNullM . splitLookupM s f b + isSubmapT (<=) (PMap m1) (PMap m2) = isSubmapM (isSubmapM (<=)) m1 m2 + unionT s f (PMap m1) (PMap m2) = PMap (unionM (sizeM s) (\ a -> guardNullM .: unionM s (\ b -> f (a, b))) m1 m2) + isectT s f (PMap m1) (PMap m2) = PMap (isectM (sizeM s) (\ a -> guardNullM .: isectM s (\ b -> f (a, b))) m1 m2) + diffT s f (PMap m1) (PMap m2) = PMap (diffM (sizeM s) (\ a -> guardNullM .: diffM s (\ b -> f (a, b))) m1 m2) + extractT s f (PMap m) = fmap PMap <$> extractM (sizeM s) g m where + g a = fmap guardNullM <.> extractM s (\ b -> f (a, b)) +-- extractMinT s f (PMap m) = second PMap <$> extractMinM (sizeM s) g m where +-- g a = second guardNullM . fromJust . getFirst . extractMinM s (\ b -> f (a, b)) +-- extractMaxT s f (PMap m) = second PMap <$> extractMaxM (sizeM s) g m where +-- g a = second guardNullM . fromJust . getLast . extractMaxM s (\ b -> f (a, b)) + fromListT s f xs = PMap (mapWithKeyM (sizeM s) (\ a -> fromListM s (\ b -> f (a, b))) + (fromListM (const 1) (const (++)) (breakFst xs))) + fromAscListT s f xs = PMap (fromDistAscListM (sizeM s) + [(a, fromAscListM s (\ b -> f (a, b)) ys) | (a, ys) <- breakFst xs]) + +-- aboutMin :: TrieKey k (TrieMap k) => Sized a -> (k -> a -> x) -> TrieMap k a -> First x +-- aboutMin s f m = fst <$> extractMinM s (\ k a -> (f k a, Nothing)) m +-- +-- aboutMax :: TrieKey k (TrieMap k) => Sized a -> (k -> a -> x) -> TrieMap k a -> Last x +-- aboutMax s f m = fst <$> extractMaxM s (\ k a -> (f k a, Nothing)) m + +breakFst :: Eq k1 => [((k1, k2), a)] -> [(k1, [(k2, a)])] +breakFst [] = [] +breakFst (((a, b),v):xs) = breakFst' a (Seq.singleton (b, v)) xs where + breakFst' a vs (((a', b'), v'):xs) + | a == a' = breakFst' a' (vs |> (b', v')) xs + | otherwise = (a, toList vs):breakFst' a' (Seq.singleton (b', v')) xs + breakFst' a vs [] = [(a, toList vs)] + {- +guardNullM :: TrieKey k (TrieMap k) => TrieMap k a -> Maybe (TrieMap k a) +guardNullM m + | nullM m = Nothing + | otherwise = Just m-} diff --git a/Data/TrieMap/RadixTrie.hs b/Data/TrieMap/RadixTrie.hs new file mode 100644 --- /dev/null +++ b/Data/TrieMap/RadixTrie.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE TemplateHaskell, FlexibleContexts, TypeFamilies, MultiParamTypeClasses, PatternGuards #-} + +module Data.TrieMap.RadixTrie () where + +import Data.TrieMap.TrieKey +import Data.TrieMap.Sized +import Data.TrieMap.Applicative +import Data.TrieMap.CPair +import Data.TrieMap.Regular.Class +-- import Data.TrieMap.Regular.TH + +import Control.Applicative +import Control.Arrow +import Control.Monad + +import Data.Maybe +import Data.Monoid +import Data.Foldable +import Data.Traversable + +import Prelude hiding (lookup, foldr, foldl) + +data Edge k m a = Edge {-# UNPACK #-} !Int [k] (Maybe a) (m (Edge k m a)) +type Edge' k a = Edge k (TrieMap k) a +type MEdge k m a = Maybe (Edge k m a) +type MEdge' k a = Maybe (Edge' k a) + +newtype RadixTrie k a = Radix (MEdge' k a) + +type instance TrieMapT [] = RadixTrie +type instance TrieMap [k] = RadixTrie k + +edgeSize :: Edge k m a -> Int +edgeSize (Edge sz _ _ _) = sz + +instance TrieKey k (TrieMap k) => TrieKey [k] (RadixTrie k) where + emptyM = emptyT + nullM = nullT + lookupM = lookupT + lookupIxM = lookupIxT + assocAtM = assocAtT + alterM = alterT + alterLookupM = alterLookupT + traverseWithKeyM = traverseWithKeyT + foldWithKeyM = foldWithKeyT + foldlWithKeyM = foldlWithKeyT + mapEitherM = mapEitherT + splitLookupM = splitLookupT + unionM = unionT + isectM = isectT + diffM = diffT + extractM = extractT + isSubmapM = isSubmapT + fromListM = fromListT + fromAscListM = fromAscListT + fromDistAscListM = fromDistAscListT + +instance TrieKeyT [] RadixTrie where + emptyT = Radix Nothing + nullT (Radix m) = isNothing m + sizeT _ (Radix m) = maybe 0 edgeSize m + lookupT ks (Radix m) = m >>= lookup ks + alterT s f ks (Radix m) = Radix (alter s f ks m) + alterLookupT s f ks (Radix m) = Radix <$> alterLookupE s f ks m + traverseWithKeyT s f (Radix m) = Radix <$> traverse (traverseE s f) m + extractT s f (Radix m) = maybe empty (fmap Radix <.> extractE s f) m + foldWithKeyT f (Radix m) z = foldr (foldE f) z m + foldlWithKeyT f (Radix m) z = foldl (foldlE f) z m + mapEitherT s1 s2 f (Radix m) = (Radix *** Radix) (maybe (Nothing, Nothing) (mapEitherE s1 s2 f) m) + unionT s f (Radix m1) (Radix m2) = Radix (unionMaybe (unionE s f) m1 m2) + isectT s f (Radix m1) (Radix m2) = Radix (isectMaybe (isectE s f) m1 m2) + diffT s f (Radix m1) (Radix m2) = Radix (diffMaybe (diffE s f) m1 m2) + lookupIxT s ks (Radix m) = maybe (empty, empty, empty) (lookupIxE s 0 ks) m + isSubmapT (<=) (Radix m1) (Radix m2) = subMaybe (isSubmapE (<=)) m1 m2 + splitLookupT s f ks (Radix m) = Radix `sides` maybe (Nothing, Nothing, Nothing) (splitLookupE s f ks) m + assocAtT s i (Radix m) = maybe (empty, empty, empty) (assocAtE s 0 i) m + +cat :: [k] -> Edge' k a -> Edge' k a +ks `cat` Edge sz ls v ts = Edge sz (ks ++ ls) v ts + +cons :: k -> Edge' k a -> Edge' k a +k `cons` Edge sz ks v ts = Edge sz (k:ks) v ts + +edge :: TrieKey k (TrieMap k) => Sized a -> [k] -> Maybe a -> TrieMap k (Edge' k a) -> Edge' k a +edge s ks v ts = Edge (maybe 0 s v + sizeM edgeSize ts) ks v ts + +singleMaybe :: TrieKey k (TrieMap k) => Sized a -> [k] -> Maybe a -> MEdge' k a +singleMaybe s ks v = do v <- v + return (edge s ks (Just v) emptyM) + +compact :: TrieKey k (TrieMap k) => Edge' k a -> MEdge' k a +compact e@(Edge sz ks Nothing ts) = case assocsM ts of + [] -> Nothing + [(l, e')] -> compact (ks `cat` (l `cons` e')) + _ -> Just e +compact e = Just e + +lookup :: (Eq k, TrieKey k (TrieMap k)) => [k] -> Edge' k a -> Maybe a +lookup ks (Edge _ ls v ts) = match ks ls where + match (k:ks) (l:ls) + | k == l = match ks ls + match (k:ks) [] = lookupM k ts >>= lookup ks + match [] [] = v + match _ _ = Nothing + +alter :: (TrieKey k (TrieMap k)) => Sized a -> (Maybe a -> Maybe a) -> [k] -> MEdge' k a -> MEdge' k a +alter s f ks0 Nothing = singleMaybe s ks0 (f Nothing) +alter s f ks0 (Just e@(Edge sz ls0 v ts)) = match 0 ks0 ls0 where + match i _ _ | i `seq` False = undefined + match i (k:ks) (l:ls) = case compare k l of + LT | Just v' <- f Nothing + -> Just $ let sv = s v' in Edge (sv + sz) (take i ls0) Nothing (fromDistAscListM edgeSize + [(k, Edge sv ks (Just v') emptyM), (l, Edge sz ls v ts)]) + EQ -> match (i+1) ks ls + GT | Just v' <- f Nothing + -> Just $ let sv = s v' in Edge (sv + sz) (take i ls0) Nothing (fromDistAscListM edgeSize + [(l, Edge sz ls v ts), (k, Edge sv ks (Just v') emptyM)]) + _ -> Just e + match _ (k:ks) [] = compact $ edge s ls0 v (alterM edgeSize g k ts) where + g = alter s f ks + match _ [] (l:ls) + | Just v' <- f Nothing + = Just (Edge (s v' + sz) ks0 (Just v') (singletonM edgeSize l (Edge sz ls v ts))) + match _ [] [] + = compact (edge s ls0 (f v) ts) + match _ _ _ = Just e + +alterLookupE :: TrieKey k (TrieMap k) => Sized a -> (Maybe a -> CPair z (Maybe a)) -> [k] -> MEdge' k a -> CPair z (MEdge' k a) +alterLookupE s f ks Nothing = singleMaybe s ks <$> f Nothing +alterLookupE s f ks0 (Just e@(Edge sz ls0 v0 ts0)) = match 0 ks0 ls0 where + match i _ _ | i `seq` False = undefined + match i (k:ks) (l:ls) = case compare k l of + LT -> fmap (Just . maybe e (\ v' -> let sv = s v' in Edge (sz + sv) (take i ls0) Nothing $ + fromDistAscListM edgeSize [(k, Edge sv ks (Just v') emptyM), (l, Edge sz ls v0 ts0)])) + (f Nothing) + GT -> fmap (Just . maybe e (\ v' -> let sv = s v' in Edge (sz + sv) (take i ls0) Nothing $ + fromDistAscListM edgeSize [(l, Edge sz ls v0 ts0), (k, Edge sv ks (Just v') emptyM)])) + (f Nothing) + EQ -> match (i+1) ks ls + match _ (k:ks) [] = fmap (compact . edge s ls0 v0) (alterLookupM edgeSize g k ts0) where + g = alterLookupE s f ks + match _ [] (l:ls) = fmap (Just . maybe e (\ v' -> let sv = s v' in Edge (sv + sz) ks0 (Just v') (singletonM edgeSize l (Edge sz ls v0 ts0)))) + (f Nothing) + match _ [] [] = fmap (\ v' -> compact $ edge s ls0 v' ts0) (f v0) + +traverseE :: (Applicative f, TrieKey k (TrieMap k)) => Sized b -> ([k] -> a -> f b) -> Edge' k a -> f (Edge' k b) +traverseE s f (Edge _ ks v ts) + = edge s ks <$> traverse (f ks) v <*> traverseWithKeyM edgeSize g ts + where g l = traverseE s (\ ls -> f (ks ++ l:ls)) + +extractE :: (Alternative f, TrieKey k (TrieMap k)) => Sized a -> ([k] -> a -> f (CPair x (Maybe a))) -> Edge' k a -> f (CPair x (MEdge' k a)) +extractE s f (Edge _ ks v ts) = case v of + Nothing -> rest + Just v -> fmap (\ v' -> compact (edge s ks v' ts)) <$> f ks v <|> rest + where rest = fmap (compact . edge s ks v) <$> extractM edgeSize g ts + g l = extractE s (\ ls -> f (ks ++ l:ls)) + +aboutE :: (Alternative f, TrieKey k (TrieMap k)) => ([k] -> a -> f x) -> Edge' k a -> f x +aboutE f = cpFst <.> extractE (const 0) (\ k a -> fmap (flip cP Nothing) (f k a)) + +foldE :: TrieKey k (TrieMap k) => ([k] -> a -> b -> b) -> Edge' k a -> b -> b +foldE f (Edge _ ks v ts) z = foldr (f ks) (foldWithKeyM g ts z) v where + g l = foldE (\ ls -> f (ks ++ l:ls)) + +foldlE :: TrieKey k (TrieMap k) => ([k] -> b -> a -> b) -> b -> Edge' k a -> b +foldlE f z (Edge _ ks v ts) = foldlWithKeyM g ts (foldl (f ks) z v) where + g l = foldlE (\ ls -> f (ks ++ l:ls)) + +mapEitherE :: TrieKey k (TrieMap k) => Sized b -> Sized c -> ([k] -> a -> (Maybe b, Maybe c)) -> Edge' k a -> + (MEdge' k b, MEdge' k c) +mapEitherE s1 s2 f (Edge _ ks v ts) = (compact *** compact) (edge s1 ks vL tsL, edge s2 ks vR tsR) + where (vL, vR) = maybe (Nothing, Nothing) (f ks) v + (tsL, tsR) = mapEitherM edgeSize edgeSize (\ l -> mapEitherE s1 s2 (\ ls -> f (ks ++ l:ls))) ts + +unionE :: TrieKey k (TrieMap k) => Sized a -> ([k] -> a -> a -> Maybe a) -> Edge' k a -> Edge' k a -> MEdge' k a +unionE s f eK@(Edge szK ks0 vK tsK) eL@(Edge szL ls0 vL tsL) = match 0 ks0 ls0 where + match i _ _ | i `seq` False = undefined + match i (k:ks) (l:ls) = case compare k l of + EQ -> match (i+1) ks ls + LT -> Just $ Edge (szK + szL) (take i ks0) Nothing (fromDistAscListM edgeSize + [(k, Edge szK ks vK tsK), (l, Edge szL ls vL tsL)]) + GT -> Just $ Edge (szK + szL) (take i ks0) Nothing (fromDistAscListM edgeSize + [(l, Edge szL ls vL tsL), (k, Edge szK ks vK tsK)]) + match _ [] (l:ls) = compact (edge s ks0 vK (alterM edgeSize g l tsK)) where + g (Just eK') = unionE s (\ ls' -> f (ks0 ++ l:ls')) eK' (Edge szL ls vL tsL) + g Nothing = Just (Edge szL ls vL tsL) + match _ (k:ks) [] = compact (edge s ls0 vL (alterM edgeSize g k tsL)) where + g Nothing = Just (Edge szK ks vK tsK) + g (Just eL') = unionE s (\ ks' -> f (ls0 ++ k:ks')) (Edge szK ks vK tsK) eL' + match _ [] [] = compact (edge s ls0 (unionMaybe (f ls0) vK vL) (unionM edgeSize g tsK tsL)) where + g x = unionE s (\ xs -> f (ls0 ++ x:xs)) + +isectE :: TrieKey k (TrieMap k) => Sized c -> ([k] -> a -> b -> Maybe c) -> Edge' k a -> Edge' k b -> MEdge' k c +isectE s f eK@(Edge szK ks0 vK tsK) eL@(Edge szL ls0 vL tsL) = match ks0 ls0 where + match (k:ks) (l:ls) + | k == l = match ks ls + match (k:ks) [] = do eL' <- lookupM k tsL + cat ls0 <$> cons k <$> isectE s (\ ks' -> f (ls0 ++ k:ks')) (Edge szK ks vK tsK) eL' + match [] (l:ls) = do eK' <- lookupM l tsK + cat ks0 <$> cons l <$> isectE s (\ ls' -> f (ks0 ++ l:ls')) eK' (Edge szL ls vL tsL) + match [] [] = compact (edge s ks0 (isectMaybe (f ks0) vK vL) (isectM edgeSize g tsK tsL)) where + g x = isectE s (\ xs -> f (ks0 ++ x:xs)) + match _ _ = Nothing + +diffE :: TrieKey k (TrieMap k) => Sized a -> ([k] -> a -> b -> Maybe a) -> Edge' k a -> Edge' k b -> MEdge' k a +diffE s f eK@(Edge szK ks0 vK tsK) eL@(Edge szL ls0 vL tsL) = match ks0 ls0 where + match (k:ks) (l:ls) + | k == l = match ks ls + match (k:ks) [] + | Just eL' <- lookupM k tsL + = cat ls0 . cons k <$> diffE s (\ ks' -> f (ls0 ++ k:ks')) (Edge szK ks vK tsK) eL' + match [] (l:ls) + = compact (edge s ks0 vK (alterM edgeSize (>>= g) l tsK)) + where g eK' = diffE s (\ ls' -> f (ks0 ++ l:ls')) eK' (Edge szL ls vL tsL) + match [] [] = compact (edge s ks0 (diffMaybe (f ks0) vK vL) (diffM edgeSize g tsK tsL)) where + g x = diffE s (\ xs -> f (ks0 ++ x:xs)) + match _ _ = Just eK + +lookupIxE :: TrieKey k (TrieMap k) => Sized a -> Int -> [k] -> Edge' k a -> IndexPos [k] a +lookupIxE s i ks e@(Edge sz ls v ts) = match ks ls where + match (k:ks) (l:ls) = case compare k l of + LT -> (empty, empty, aboutE (return .: Asc i) e) + EQ -> match ks ls + GT -> (aboutE (\ k a -> return (Asc (i + sz - s a) k a)) e, empty, empty) + match (k:ks) [] = let sv = maybe 0 s v in case onIndex (i + sv +) (lookupIxM edgeSize k ts) of + (lb, x, ub) -> let lookupX = do Asc i' k' e' <- x + return $ onKey (\ ks' -> ls ++ k':ks') $ + lookupIxE s i' ks e' + in ((do v <- Last v + return (Asc i ls v)) <|> + (do Asc iL kL eL <- lb + aboutE (\ ksL vL -> return $ Asc (iL + edgeSize eL - s vL) (ls ++ kL:ksL) vL) eL) <|> + (do (lb', _, _) <- Last lookupX + lb'), + (do (_, x', _) <- lookupX + x'), + (do (_, _, ub') <- First lookupX + ub') <|> + (do Asc iU kU eU <- ub + aboutE (\ ksU -> return . Asc iU (ls ++ kU:ksU)) eU)) + match [] (l:ls) = (empty, empty, aboutE (return .: Asc i) e) + match [] [] = (empty, Asc i ls <$> v, aboutM (\ x -> aboutE (\ xs -> return . Asc (i + maybe 0 s v) (ls ++ x:xs))) ts) + +isSubmapE :: TrieKey k (TrieMap k) => LEq a b -> LEq (Edge' k a) (Edge' k b) +isSubmapE (<=) (Edge szK ks vK tsK) (Edge szL ls vL tsL) = match ks ls where + match (k:ks) (l:ls) + | k == l = match ks ls + match (k:ks) [] + | Just eL' <- lookupM k tsL + = isSubmapE (<=) (Edge szK ks vK tsK) eL' + match [] [] = subMaybe (<=) vK vL && isSubmapM (isSubmapE (<=)) tsK tsL + match _ _ = False + +splitLookupE :: TrieKey k (TrieMap k) => Sized a -> (a -> (Maybe a, Maybe x, Maybe a)) -> [k] -> Edge' k a -> + (MEdge' k a, Maybe x, MEdge' k a) +splitLookupE s f ks e@(Edge _ ls v ts) = match ks ls where + match (k:ks) (l:ls) = case compare k l of + LT -> (Nothing, Nothing, Just e) + GT -> (Just e, Nothing, Nothing) + EQ -> match ks ls + match (k:ks) [] = case splitLookupM edgeSize g k ts of + (tsL, x, tsR) -> (compact (edge s ls v tsL), x, compact (edge s ls Nothing tsR)) + where g = splitLookupE s f ks + match [] (l:ls) = (Nothing, Nothing, Just e) + match [] [] = (singleMaybe s ls vL, x, compact (edge s ls vR ts)) + where (vL, x, vR) = maybe (Nothing, Nothing, Nothing) f v + +assocAtE :: TrieKey k (TrieMap k) => Sized a -> Int -> Int -> Edge' k a -> IndexPos [k] a +assocAtE _ i0 i _ | i0 `seq` i `seq` False = undefined +assocAtE s i0 i (Edge sz ks v ts) = let sv = maybe 0 s v in case assocAtM edgeSize (i - sv) ts of + (lb, x, ub) -> let lookupX = do Asc i' l e' <- x + return (onKey (\ ls -> ks ++ l:ls) (assocAtE s (i0 + sv + i') (i - i') e')) + in ((do v <- Last v + guard (i >= sv) + return (Asc i0 ks v)) <|> + (do Asc iL lL eL <- lb + aboutE (\ ls vL -> return (Asc (i0 + iL + sv + edgeSize eL - s vL) (ks ++ lL:ls) vL)) eL) <|> + (do (lb', _, _) <- Last lookupX + lb'), + (do v <- v + guard (i >= 0 && i < sv) + return (Asc i0 ks v)) <|> + (do (_, x', _) <- lookupX + x'), + (do (_, _, ub') <- First lookupX + ub') <|> + (do v <- First v + guard (i < 0) + return (Asc i0 ks v))) diff --git a/Data/TrieMap/Regular/Base.hs b/Data/TrieMap/Regular/Base.hs --- a/Data/TrieMap/Regular/Base.hs +++ b/Data/TrieMap/Regular/Base.hs @@ -2,7 +2,7 @@ module Data.TrieMap.Regular.Base where -import Data.TrieMap.TrieKey +-- import Data.TrieMap.TrieKey newtype K0 a r = K0 {unK0 :: a} deriving (Show) newtype I0 r = I0 {unI0 :: r} deriving (Show) diff --git a/Data/TrieMap/Regular/Class.hs b/Data/TrieMap/Regular/Class.hs --- a/Data/TrieMap/Regular/Class.hs +++ b/Data/TrieMap/Regular/Class.hs @@ -5,10 +5,11 @@ import Data.TrieMap.Sized import Data.TrieMap.Applicative import Data.TrieMap.TrieKey -import Data.TrieMap.Regular.Eq +-- import Data.TrieMap.Regular.Eq import Data.TrieMap.Regular.Ord +import Data.TrieMap.CPair -import Data.Monoid +-- import Data.Monoid import Control.Applicative @@ -23,6 +24,7 @@ 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 + alterLookupT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (Maybe a -> CPair x (Maybe a)) -> f k -> m k a -> CPair x (m k a) traverseWithKeyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k), Applicative t) => Sized b -> (f k -> a -> t (b)) -> m k a -> t (m k b) foldWithKeyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => @@ -52,6 +54,8 @@ fromListT s f = foldr (\ (k, a) -> alterT s (Just . maybe a (f k a)) k) emptyT fromAscListT = fromListT fromDistAscListT s = fromAscListT s (const const) +-- alterLookupT s f k m = fmap (\ v' -> alterT s (const v') k m) (f (lookupT k m)) + alterT s f k m = cpSnd (alterLookupT s (cP () . f) 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 @@ -76,7 +80,7 @@ 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 +aboutT f m = cpFst <$> extractT (const 0) (\ k a -> fmap (flip cP 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 diff --git a/Data/TrieMap/Regular/CompMap.hs b/Data/TrieMap/Regular/CompMap.hs --- a/Data/TrieMap/Regular/CompMap.hs +++ b/Data/TrieMap/Regular/CompMap.hs @@ -6,10 +6,10 @@ import Data.TrieMap.Regular.Class import Data.TrieMap.Regular.Ord import Data.TrieMap.Regular.Eq -import Data.TrieMap.Regular.TH +-- import Data.TrieMap.Regular.TH import Data.TrieMap.TrieKey -import Data.TrieMap.Rep -import Data.TrieMap.Rep.TH +-- import Data.TrieMap.Rep +-- import Data.TrieMap.Rep.TH import Control.Applicative import Control.Arrow @@ -37,34 +37,79 @@ 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 +instance (TrieKeyT f m, Functor f, TrieKeyT g (TrieMapT g), TrieKey k (TrieMap k)) => + TrieKey ((f `O` g) k) (CompMap m g k) where + emptyM = emptyT + nullM = nullT + lookupM = lookupT + lookupIxM = lookupIxT + assocAtM = assocAtT + alterM = alterT + alterLookupM = alterLookupT + traverseWithKeyM = traverseWithKeyT + foldWithKeyM = foldWithKeyT + foldlWithKeyM = foldlWithKeyT + mapEitherM = mapEitherT + splitLookupM = splitLookupT + unionM = unionT + isectM = isectT + diffM = diffT + extractM = extractT + isSubmapM = isSubmapT + fromListM = fromListT + fromAscListM = fromAscListT + fromDistAscListM = fromDistAscListT + + +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) + lookupT (O x) (CMap m) = lookupT (A <$> x) m + lookupIxT s (O x) (CMap m) = onKey (O . fmap unA) (lookupIxT s (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) + alterT s f (O x) (CMap m) = CMap (alterT s f (A <$> x) m) + alterLookupT s f (O x) (CMap m) = CMap <$> alterLookupT s f (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 + splitLookupT s f (O k) (CMap m) = CMap `sides` splitLookupT s f (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 + extractT s f (CMap m) = fmap 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) |]) + 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 +instance (TrieKeyT f m, TrieKey k (TrieMap k)) => TrieKey (App f k) (AppMap m k) where + emptyM = emptyT + nullM = nullT + lookupM = lookupT + lookupIxM = lookupIxT + assocAtM = assocAtT + alterM = alterT + alterLookupM = alterLookupT + traverseWithKeyM = traverseWithKeyT + foldWithKeyM = foldWithKeyT + foldlWithKeyM = foldlWithKeyT + mapEitherM = mapEitherT + splitLookupM = splitLookupT + unionM = unionT + isectM = isectT + diffM = diffT + extractM = extractT + isSubmapM = isSubmapT + fromListM = fromListT + fromAscListM = fromAscListT + fromDistAscListM = fromDistAscListT + +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 @@ -73,12 +118,13 @@ 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) + alterLookupT s f (A k) (AMap m) = AMap <$> alterLookupT 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 + extractT s f (AMap m) = fmap 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) @@ -86,4 +132,4 @@ 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 |]) + isSubmapT (<=) (AMap m1) (AMap m2) = isSubmapT (<=) m1 m2 diff --git a/Data/TrieMap/Regular/ConstMap.hs b/Data/TrieMap/Regular/ConstMap.hs --- a/Data/TrieMap/Regular/ConstMap.hs +++ b/Data/TrieMap/Regular/ConstMap.hs @@ -25,6 +25,7 @@ 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) + alterLookupM s f (K0 k) (KMap m) = KMap <$> alterLookupM s f k m traverseWithKeyM s f (KMap m) = KMap <$> traverseWithKeyM s (f . K0) m foldWithKeyM f (KMap m) = foldWithKeyM (f . K0) m foldlWithKeyM f (KMap m) = foldlWithKeyM (f . K0) m @@ -33,7 +34,7 @@ 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) - extractM s f (KMap m) = second KMap <$> extractM s (f . K0) m + extractM s f (KMap m) = fmap 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) @@ -52,6 +53,7 @@ assocAtT = assocAtM -- updateAtT = updateAtM alterT = alterM + alterLookupT = alterLookupM traverseWithKeyT = traverseWithKeyM foldWithKeyT = foldWithKeyM foldlWithKeyT = foldlWithKeyM diff --git a/Data/TrieMap/Regular/Eq.hs b/Data/TrieMap/Regular/Eq.hs --- a/Data/TrieMap/Regular/Eq.hs +++ b/Data/TrieMap/Regular/Eq.hs @@ -3,8 +3,8 @@ 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.MultiRec.Base(Family(..)) +-- import Data.TrieMap.MultiRec.Eq(HEq0(..)) import Data.TrieMap.Modifiers class EqT f where @@ -12,6 +12,9 @@ eqT :: (EqT f, Eq a) => f a -> f a -> Bool eqT = eqT0 (==) + +-- instance EqT (Family phi) where +-- eqT0 (==) (F a) (F b) = a == b instance Eq a => EqT (K0 a) where eqT0 _ (K0 a) (K0 b) = a == b diff --git a/Data/TrieMap/Regular/IdMap.hs b/Data/TrieMap/Regular/IdMap.hs --- a/Data/TrieMap/Regular/IdMap.hs +++ b/Data/TrieMap/Regular/IdMap.hs @@ -23,6 +23,7 @@ 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) + alterLookupT s f (I0 k) (IMap m) = IMap <$> alterLookupM s f k m traverseWithKeyT s f (IMap m) = IMap <$> traverseWithKeyM s (f . I0) m foldWithKeyT f (IMap m) = foldWithKeyM (f . I0) m foldlWithKeyT f (IMap m) = foldlWithKeyM (f . I0) m @@ -31,7 +32,7 @@ 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) - extractT s f (IMap m) = second IMap <$> extractM s (f . I0) m + extractT s f (IMap m) = fmap 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) @@ -50,6 +51,7 @@ assocAtM = assocAtT -- updateAtM = updateAtT alterM = alterT + alterLookupM = alterLookupT traverseWithKeyM = traverseWithKeyT foldWithKeyM = foldWithKeyT foldlWithKeyM = foldlWithKeyT diff --git a/Data/TrieMap/Regular/Ord.hs b/Data/TrieMap/Regular/Ord.hs --- a/Data/TrieMap/Regular/Ord.hs +++ b/Data/TrieMap/Regular/Ord.hs @@ -4,9 +4,9 @@ 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.MultiRec.Base(Family(..)) +-- import Data.TrieMap.MultiRec.Ord(HOrd0(..)) +-- import Data.TrieMap.TrieKey import Data.TrieMap.Modifiers import Data.Monoid @@ -19,7 +19,9 @@ compareT = compareT0 compare -- instance HOrd0 KeyFam r => OrdT (FamT KeyFam r) where - + +-- instance OrdT (Family phi) where +-- compareT0 cmp (F a) (F b) = cmp a b instance Ord a => OrdT (K0 a) where compareT0 _ (K0 a) (K0 b) = compare a b diff --git a/Data/TrieMap/Regular/ProdMap.hs b/Data/TrieMap/Regular/ProdMap.hs --- a/Data/TrieMap/Regular/ProdMap.hs +++ b/Data/TrieMap/Regular/ProdMap.hs @@ -8,7 +8,7 @@ import Data.TrieMap.TrieKey import Data.TrieMap.Applicative import Data.TrieMap.Sized -import Data.TrieMap.Regular.TH +-- import Data.TrieMap.Regular.TH import Control.Applicative import Control.Arrow @@ -28,8 +28,30 @@ --maybe (sizeT s m) fst (getLast (extractMaxT s (\ _ a -> (sizeT s m - s a, Just a)) m)) -$(deriveM [d| - instance (TrieKeyT f m1, TrieKeyT g m2) => TrieKeyT (f :*: g) (PMap m1 m2) where +instance (TrieKeyT f m1, TrieKeyT g m2, TrieKey k (TrieMap k)) => + TrieKey ((f :*: g) k) (PMap m1 m2 k) where + emptyM = emptyT + nullM = nullT + lookupM = lookupT + lookupIxM = lookupIxT + assocAtM = assocAtT + alterM = alterT + alterLookupM = alterLookupT + traverseWithKeyM = traverseWithKeyT + foldWithKeyM = foldWithKeyT + foldlWithKeyM = foldlWithKeyT + mapEitherM = mapEitherT + splitLookupM = splitLookupT + unionM = unionT + isectM = isectT + diffM = diffT + extractM = extractT + isSubmapM = isSubmapT + fromListM = fromListT + fromAscListM = fromAscListT + fromDistAscListM = fromDistAscListT + +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 @@ -78,6 +100,8 @@ -- = 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 + alterLookupT s f (a :*: b) (PMap m) = PMap <$> alterLookupT (sizeT s) g a m where + g = fmap guardNullT . alterLookupT s f b . fromMaybe emptyT traverseWithKeyT s f (PMap m) = PMap <$> traverseWithKeyT (sizeT s) g m where g a = traverseWithKeyT s (\ b -> f (a :*: b)) foldWithKeyT f (PMap m) = foldWithKeyT g m where @@ -91,8 +115,8 @@ 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) - extractT s f (PMap m) = second PMap <$> extractT (sizeT s) g m where - g a = second guardNullT <.> extractT s (\ b -> f (a :*: b)) + extractT s f (PMap m) = fmap PMap <$> extractT (sizeT s) g m where + g a = fmap 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 @@ -105,11 +129,10 @@ 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 :: (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)] - |]) diff --git a/Data/TrieMap/Regular/RadixTrie.hs b/Data/TrieMap/Regular/RadixTrie.hs --- a/Data/TrieMap/Regular/RadixTrie.hs +++ b/Data/TrieMap/Regular/RadixTrie.hs @@ -6,13 +6,14 @@ import Data.TrieMap.Regular.Base import Data.TrieMap.Regular.Ord import Data.TrieMap.Regular.Eq -import Data.TrieMap.Regular.TH +-- 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 Data.TrieMap.CPair +-- import Data.TrieMap.Rep +-- import Data.TrieMap.Rep.TH +-- import qualified Data.TrieMap.MultiRec.Base as MR import Control.Arrow import Control.Applicative @@ -57,6 +58,7 @@ 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) + alterLookupT s f (List ks) (Radix m) = Radix <$> maybe (singletonME s ks <$> f Nothing) (alterLookupE s f ks) m traverseWithKeyT s f (Radix m) = Radix <$> traverse (traverseE s (f . List)) m foldWithKeyT f (Radix m) z = foldr (foldE (f . List)) z m foldlWithKeyT f (Radix m) z = foldr (foldlE (f . List)) z m @@ -65,7 +67,7 @@ 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) - extractT s f (Radix m) = maybe empty (second Radix <.> extractE s (f . List)) m + extractT s f (Radix m) = maybe empty (fmap 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)) @@ -83,6 +85,7 @@ assocAtM = assocAtT -- updateAtM = updateAtT alterM = alterT + alterLookupM = alterLookupT traverseWithKeyM = traverseWithKeyT foldWithKeyM = foldWithKeyT foldlWithKeyM = foldlWithKeyT @@ -165,6 +168,24 @@ match _ [] [] = compact (edge s ls0 (f v0) ts0) match _ _ _ = Just e +alterLookupE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => + Sized a -> (Maybe a -> CPair x (Maybe a)) -> [f k] -> Edge' f k a -> CPair x (MEdge' f k a) +alterLookupE 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) = case compareT k l of + LT -> fmap (Just . maybe e (\ v' -> let sv = s v' in Edge (sz + sv) (take i ls0) Nothing $ + fromDistAscListT edgeSize [(k, Edge sv ks (Just v') emptyT), (l, Edge sz ls v0 ts0)])) + (f Nothing) + GT -> fmap (Just . maybe e (\ v' -> let sv = s v' in Edge (sz + sv) (take i ls0) Nothing $ + fromDistAscListT edgeSize [(l, Edge sz ls v0 ts0), (k, Edge sv ks (Just v') emptyT)])) + (f Nothing) + EQ -> match (i+1) ks ls + match _ (k:ks) [] = fmap (compact . edge s ls0 v0) (alterLookupT edgeSize g k ts0) where + g = maybe (singletonME s ks <$> f Nothing) (alterLookupE s f ks) + match _ [] (l:ls) = fmap (Just . maybe e (\ v' -> Edge (sz + s v') ks0 (Just v') (singletonT edgeSize l (Edge sz ls v0 ts0)))) + (f Nothing) + match _ [] [] = fmap (\ v' -> compact (edge s ls0 v' ts0)) (f v0) + traverseE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k), Applicative t) => Sized b -> ([f k] -> a -> t (b)) -> Edge' f k a -> t (Edge' f k b) traverseE s f (Edge _ ks v ts) = @@ -213,15 +234,15 @@ 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)) -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) +extractE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k), Alternative t) => Sized a -> ([f k] -> a -> t (CPair x (Maybe a))) -> + Edge' f k a -> t (CPair x (MEdge' f k a)) +extractE s f (Edge _ ks v ts) = (maybe empty (fmap (\ v' -> compact (edge s ks v' ts)) <.> f ks) v) <|> + (fmap (compact . edge s ks Nothing) <$> extractT edgeSize g ts) where g l = extractE s (\ ls -> f (ks ++ l:ls)) 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)) +aboutE f = cpFst <.> extractE (const 0) (\ k a -> fmap (flip cP Nothing) (f k a)) -- 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) diff --git a/Data/TrieMap/Regular/RegMap.hs b/Data/TrieMap/Regular/RegMap.hs --- a/Data/TrieMap/Regular/RegMap.hs +++ b/Data/TrieMap/Regular/RegMap.hs @@ -21,6 +21,7 @@ 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) + alterLookupM s f k (RegMap m) = RegMap <$> alterLookupT s f (from' k) m traverseWithKeyM s f (RegMap m) = RegMap <$> traverseWithKeyT s (f . to') m foldWithKeyM f (RegMap m) = foldWithKeyT (f . to') m foldlWithKeyM f (RegMap m) = foldlWithKeyT (f . to') m @@ -29,7 +30,7 @@ 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) - extractM s f (RegMap m) = second RegMap <$> extractT s (f . to') m + extractM s f (RegMap m) = fmap 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) diff --git a/Data/TrieMap/Regular/TH.hs b/Data/TrieMap/Regular/TH.hs --- a/Data/TrieMap/Regular/TH.hs +++ b/Data/TrieMap/Regular/TH.hs @@ -8,7 +8,7 @@ deriveM :: Q [Dec] -> Q [Dec] deriveM decs = do - iT@(InstanceD cxt (triekeyt `AppT` f `AppT` m) _:_) <- decs + iT@(InstanceD cxt inst _:_) <- decs (InstanceD _ _ myDecs:_) <- [d| instance (TrieKeyT f m, Ord (f k), TrieKey k mm) => TrieKey (f k) (m k) where emptyM = emptyT @@ -17,7 +17,9 @@ lookupIxM = lookupIxT assocAtM = assocAtT -- updateAtM = updateAtT + alterM = alterT + alterLookupM = alterLookupT traverseWithKeyM = traverseWithKeyT foldWithKeyM = foldWithKeyT foldlWithKeyM = foldlWithKeyT @@ -39,8 +41,7 @@ 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) + return [InstanceD cxt inst myDecs] mkVar :: String -> TypeQ mkVar x = varT =<< newName x diff --git a/Data/TrieMap/Regular/UnionMap.hs b/Data/TrieMap/Regular/UnionMap.hs --- a/Data/TrieMap/Regular/UnionMap.hs +++ b/Data/TrieMap/Regular/UnionMap.hs @@ -4,18 +4,18 @@ import Data.TrieMap.Regular.Class import Data.TrieMap.Regular.Base -import Data.TrieMap.Regular.TH +-- 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.Arrow import Control.Monad -import Data.Either -import Data.Monoid +-- import Data.Either +-- import Data.Monoid -- import Generics.MultiRec.Base data UnionMap m1 m2 k a = m1 k a :&: m2 k a @@ -31,8 +31,30 @@ -- 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 +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 + alterM = alterT + alterLookupM = alterLookupT + traverseWithKeyM = traverseWithKeyT + foldWithKeyM = foldWithKeyT + foldlWithKeyM = foldlWithKeyT + mapEitherM = mapEitherT + splitLookupM = splitLookupT + unionM = unionT + isectM = isectT + diffM = diffT + extractM = extractT + isSubmapM = isSubmapT + fromListM = fromListT + fromAscListM = fromAscListT + fromDistAscListM = fromDistAscListT + + +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 @@ -60,6 +82,9 @@ 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 + alterLookupT s f k (m1 :&: m2) = case k of + L k -> fmap (:&: m2) (alterLookupT s f k m1) + R k -> fmap (m1 :&:) (alterLookupT s f k m2) traverseWithKeyT s f (m1 :&: m2) = (:&:) <$> traverseWithKeyT s (f . L) m1 <*> traverseWithKeyT s (f . R) m2 foldWithKeyT f (m1 :&: m2) = foldWithKeyT (f . L) m1 . foldWithKeyT (f . R) m2 foldlWithKeyT f (m1 :&: m2) = foldlWithKeyT (f . R) m2 . foldlWithKeyT (f . L) m1 @@ -73,8 +98,8 @@ 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 - extractT s f (m1 :&: m2) = second (:&: m2) <$> extractT s (f . L) m1 <|> - second (m1 :&:) <$> extractT s (f . R) m2 + extractT s f (m1 :&: m2) = fmap (:&: m2) <$> extractT s (f . L) m1 <|> + fmap (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 <|> @@ -91,4 +116,4 @@ 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 |]) + (ys, zs) -> fromDistAscListT s ys :&: fromDistAscListT s zs diff --git a/Data/TrieMap/Regular/UnitMap.hs b/Data/TrieMap/Regular/UnitMap.hs --- a/Data/TrieMap/Regular/UnitMap.hs +++ b/Data/TrieMap/Regular/UnitMap.hs @@ -5,9 +5,9 @@ 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.Rep +-- import Data.TrieMap.Rep.Instances +-- import Data.TrieMap.Rep.TH import Data.TrieMap.Applicative import Control.Applicative @@ -25,14 +25,6 @@ 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 @@ -50,6 +42,7 @@ -- | r && i >= 0 -> M (v >>= f 0 U0) -- _ -> M v alterM _ f _ (M a) = M (f a) + alterLookupM _ f _ (M a) = M <$> f a traverseWithKeyM _ f (M a) = M <$> traverse (f U0) a foldWithKeyM f (M a) z = foldr (f U0) z a foldlWithKeyM f (M a) z = foldl (f U0) z a @@ -59,7 +52,7 @@ 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) - extractM _ f (M a) = maybe empty (second M <.> f U0) a + extractM _ f (M a) = maybe empty (fmap 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) @@ -77,6 +70,7 @@ assocAtT = assocAtM -- updateAtT = updateAtM alterT = alterM + alterLookupT = alterLookupM traverseWithKeyT = traverseWithKeyM foldWithKeyT = foldWithKeyM foldlWithKeyT = foldlWithKeyM diff --git a/Data/TrieMap/Rep/Instances.hs b/Data/TrieMap/Rep/Instances.hs --- a/Data/TrieMap/Rep/Instances.hs +++ b/Data/TrieMap/Rep/Instances.hs @@ -5,7 +5,7 @@ import Data.TrieMap.Rep import Data.TrieMap.Rep.TH import Data.TrieMap.Regular.Base -import Data.TrieMap.OrdMap +-- import Data.TrieMap.OrdMap import Data.TrieMap.Modifiers -- import Language.Haskell.TH @@ -17,6 +17,8 @@ import Data.Foldable (toList) import Data.Bits import Data.Array.IArray +import qualified Data.IntSet as ISet +import qualified Data.IntMap as IMap import Data.ByteString hiding (map) import qualified Data.ByteString as BS @@ -32,22 +34,29 @@ type Pair a = (,) a type Sum a = Either a -type instance RepT Maybe = U0 :+: I0 +type instance RepT Rev = Rev +type instance Rep (Rev a) = Rev (Rep a) + +$(genRepT [d| + instance ReprT Rev where + toRepTMap f (Rev a) = Rev (f a) + fromRepTMap f (Rev a) = Rev (f a) |]) + +type instance RepT Maybe = Sum () 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) |]) + toRepTMap f = maybe (Left ()) (Right . f) + fromRepTMap f = either (const Nothing) (Just . f) |]) -type instance RepT [] = L I0 -type instance Rep [a] = L I0 (Rep a) +type instance RepT [] = [] +type instance Rep [a] = [Rep a] $(genRepT [d| instance ReprT [] where - toRepTMap f = List . map (I0 . f) - fromRepTMap f (List xs) = map (f . unI0) xs |]) + toRepTMap = map + fromRepTMap = map |]) type instance RepT ((,) a) = Pair (Rep a) type instance Rep (a, b) = RepT ((,) a) (Rep b) @@ -87,21 +96,20 @@ toRepTMap f = either (Left . toRep) (Right . f) fromRepTMap f = either (Left . fromRep) (Right . f) |]) -type instance Rep Bool = (U0 :+: U0) (U0 ()) +type instance Rep Bool = Sum () () instance Repr Bool where - toRep False = L U0 - toRep True = R U0 - fromRep L{} = False - fromRep R{} = True + toRep False = Left () + toRep True = Right () + fromRep = either (const False) (const True) type instance Rep Char = Word32 instance Repr Char where toRep = fromIntegral . ord fromRep = chr . fromIntegral -type instance Rep () = U0 () +type instance Rep () = () instance Repr () where - toRep _ = U0 + toRep _ = () fromRep _ = () type instance Rep Double = Ordered Double @@ -173,23 +181,23 @@ toRep = id fromRep = id -type instance Rep ByteString = (L I0 :*: I0) Word32 +type instance Rep ByteString = ([] :*: I0) Word32 instance Repr ByteString where - toRep xs = List (toList64 xs) :*: I0 (fromIntegral (length xs)) - fromRep (List xs :*: I0 n) = case xs of + toRep xs = toList64 xs :*: I0 (fromIntegral (length xs)) + fromRep (xs :*: I0 n) = case xs of [] -> BS.empty - (I0 x:xs) -> fst (unfoldrN (fromIntegral n) toBlock (W (Words 3 x) xs)) + (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] +data Words' = W {-# UNPACK #-} !Words [Word32] -toList64 :: ByteString -> [I0 Word32] +toList64 :: ByteString -> [Word32] toList64 xs = case BS.foldl c (Words 4 0, Seq.empty) xs of - (Words i w32, ys) -> toList ys ++ [I0 w32] + (Words i w32, ys) -> toList ys ++ [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 3 (w .|. sL w8 24), xs |> w) (Words (i+1) w, xs) `c` w8 = (Words i (w .|. sL w8 (8 * i)), xs) sL :: Word8 -> Int -> Word32 @@ -199,7 +207,7 @@ 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 (W (Words 0 w) (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)) @@ -212,15 +220,15 @@ 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 Set.Set = [] type instance RepT (Map.Map k) = L (Pair (Rep k)) -type instance Rep (Set.Set a) = L I0 (Rep a) +type instance Rep (Set.Set a) = [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] |]) + toRepTMap f s = Fold.foldr ((:) . f) [] s + fromRepTMap f xs = Set.fromDistinctAscList [f x | x <- xs] |]) $(genRepT [d| instance Repr k => ReprT (Map.Map k) where @@ -230,7 +238,34 @@ 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) |]) + +type instance Rep ISet.IntSet = Rep [Int] +type instance RepT IMap.IntMap = L (Pair (Rep Int)) +type instance Rep (IMap.IntMap a) = RepT IMap.IntMap (Rep a) + +instance Repr ISet.IntSet where + toRep = toRep . ISet.toList + fromRep = ISet.fromDistinctAscList . fromRep + $(genRepT [d| - instance ReprT Rev where - toRepTMap f (Rev m) = Rev (f m) - fromRepTMap f (Rev m) = Rev (f m) |]) + instance ReprT IMap.IntMap where + toRepTMap f m = List [(toRep k, f a) | (k, a) <- IMap.assocs m] + fromRepTMap f (List xs) = IMap.fromDistinctAscList [(fromRep k, f a) | (k, a) <- xs] |]) + +type instance RepT Seq.Seq = [] +type instance Rep (Seq.Seq a) = [Rep a] + +-- type instance Rep (Rev a) = Rev (Rep a) + +$(genRepT [d| + instance ReprT Seq.Seq where + toRepTMap f = Fold.foldr (\ a xs -> f a:xs) [] + fromRepTMap f = Fold.foldl (\ xs a -> xs |> f a) Seq.empty |]) + + +-- instance Functor Rev where +-- fmap f (Rev a) = Rev (f a) diff --git a/Data/TrieMap/Rep/TH.hs b/Data/TrieMap/Rep/TH.hs --- a/Data/TrieMap/Rep/TH.hs +++ b/Data/TrieMap/Rep/TH.hs @@ -4,8 +4,8 @@ import Language.Haskell.TH import Data.TrieMap.Rep -import Language.Haskell.TH.Ppr -import Debug.Trace +-- import Language.Haskell.TH.Ppr +-- import Debug.Trace {- genRepT :: TypeQ -> Q [Dec] genRepT ff = do diff --git a/Data/TrieMap/Representation/TH.hs b/Data/TrieMap/Representation/TH.hs --- a/Data/TrieMap/Representation/TH.hs +++ b/Data/TrieMap/Representation/TH.hs @@ -1,3 +1,63 @@ -module Data.TrieMap.Representation.TH (module Data.TrieMap.Rep.TH) where +{-# LANGUAGE TemplateHaskell #-} +module Data.TrieMap.Representation.TH where + import Data.TrieMap.Rep.TH +import Data.TrieMap.Rep +import Data.TrieMap.Regular.Base +import Language.Haskell.TH +import Control.Arrow +import Control.Monad + +type RepInfo = (Q Type, Q Exp, Q Exp) + -- RepInfo t = (t', t -> t', t' -> t) +-- inferRepresentation :: Name -> String -> Q [Dec] +-- inferRepresentation k kRepName = do + +-- conToMatch :: Name -> Int -> Q Match +-- conToMatch con [] = return (Match (ConP con []) (NormalB (ConE ''U0)) []) +-- conToMatch con ts = +-- do varTs <- replicateM ts (newName "a") +-- let pat = ConP con (map (VarP . fst) varTs) +-- +-- let bod = NormalB (prod [ConE 'toRep `AppE` (VarE x) | (x, _) <- varTs]) +-- return (Match pat bod []) +-- where prod [x] = x +-- prod (x:xs) = ConE (mkName ":*:") `AppE` x `AppE` prod xs +-- +-- infixConToMatch :: Name -> Q Match +-- infixConToMatch con = do +-- a <- newName "a" +-- b <- newName "b" +-- let ae = varE a +-- let be = varE b +-- b <- [| toRep $ae :*: toRep $be |] +-- return (Match (InfixP (VarP a) con (VarP b)) (NormalB b) []) + +-- conToRep :: Type -> [Type] -> RepInfo +-- conToRep _ [] = (conT ''U0, [| const U0 |], [| const U0 |]) +-- conToRep t [x] +-- | x == t = (conT ''I0, [| I0 |], [| unI0 |]) +-- | otherwise = (conT ''K0 `appT` x, [| K0 |], [| unK0 |]) +-- conToRep t (arg0:args) = case conToRep t args of +-- (tArgs, toArgs, fromArgs) +-- | arg0 == t -> (conT '':*: `appT` conT ''I0 `appT` tArgs, [| \ (a, b) -> (I0 a, $toArgs b) |], +-- [| \ (I0 a, b) -> (a, $fromArgs b) |]) +-- | otherwise -> (conT '':*: `appT` (conT ''K0 `appT` +-- where toTuple [(_, x), (_, y)] = TupleT 2 `AppT` x `AppT` y +-- +-- +-- product :: Q Exp -> Q Exp -> RepInfo -> RepInfo -> RepInfo +-- product inj outj (t1, to1, from1) (t2, to2, from2) = +-- (tupleT 2 `appT` t1 `appT` t2, +-- [| ($to1 *** $to2) . $outj |], +-- [| $inj . ($from1 *** $from2) |]) +-- +-- sum :: Q Exp -> Q Exp -> RepInfo -> RepInfo -> RepInfo +-- sum inj outj (t1, to1, from1) (t2, to2, from2) = +-- (conT ''Either `appT` t1 `appT` t2, +-- [| ($to1 +++ $to2) . $outj |], +-- [| $inj ($from1 +++ $from2) |]) +-- repInstances :: Set Name +-- repInstances = fromList [''Int, ''Bool, ''Char, ''Double, ''Int, ''Int8, ''Int16, ''Int32, ''Int64, ''Word, ''Word8, +-- ''Word16, ''Word32, ''Word64, ''(), ''ByteString, ''IntSet, diff --git a/Data/TrieMap/ReverseMap.hs b/Data/TrieMap/ReverseMap.hs --- a/Data/TrieMap/ReverseMap.hs +++ b/Data/TrieMap/ReverseMap.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, UndecidableInstances, TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-} -module Data.TrieMap.ReverseMap() where +module Data.TrieMap.ReverseMap (reverse, unreverse) where import Data.TrieMap.TrieKey import Data.TrieMap.Modifiers @@ -13,13 +13,38 @@ import Data.Monoid hiding (Dual) +import Prelude hiding (reverse) +import qualified Data.List as L + 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 +instance TrieKey k (TrieMap k) => TrieKey (Rev k) (ReverseMap k) where + emptyM = emptyT + nullM = nullT + lookupM = lookupT + lookupIxM = lookupIxT + assocAtM = assocAtT + alterM = alterT + alterLookupM = alterLookupT + traverseWithKeyM = traverseWithKeyT + foldWithKeyM = foldWithKeyT + foldlWithKeyM = foldlWithKeyT + mapEitherM = mapEitherT + splitLookupM = splitLookupT + unionM = unionT + isectM = isectT + diffM = diffT + extractM = extractT + isSubmapM = isSubmapT + fromListM = fromListT + fromAscListM = fromAscListT + fromDistAscListM = fromDistAscListT + + +instance TrieKeyT Rev ReverseMap where emptyT = RMap emptyM nullT (RMap m) = nullM m sizeT s (RMap m) = sizeM s m @@ -35,6 +60,7 @@ -- 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) + alterLookupT s f (Rev k) (RMap m) = RMap <$> alterLookupM 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 @@ -45,15 +71,18 @@ 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) + extractT s f (RMap m) = fmap 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 + fromListT s f xs = RMap (fromListM s (f . Rev) [(k, a) | (Rev k, a) <- xs]) + fromAscListT s f xs = RMap (fromAscListM s (\ k -> flip (f (Rev k))) [(k, a) | (Rev k, a) <- L.reverse xs]) + fromDistAscListT s xs = RMap (fromDistAscListM s [(k, a) | (Rev k, a) <- L.reverse xs]) - reverse :: TrieMap k a -> TrieMap (Rev k) a - reverse = RMap |]) +reverse :: TrieMap k a -> TrieMap (Rev k) a +reverse = RMap unreverse :: TrieMap (Rev k) a -> TrieMap k a unreverse (RMap m) = m diff --git a/Data/TrieMap/TrieKey.hs b/Data/TrieMap/TrieKey.hs --- a/Data/TrieMap/TrieKey.hs +++ b/Data/TrieMap/TrieKey.hs @@ -4,6 +4,7 @@ import Data.TrieMap.Applicative import Data.TrieMap.Sized +import Data.TrieMap.CPair import Control.Applicative import Control.Arrow @@ -21,7 +22,7 @@ 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 f m k a x = (k -> a -> f (x, Maybe a)) -> m -> f (x, m) +type ExtractFunc f m k a x = (k -> a -> f (CPair x (Maybe a))) -> m -> f (CPair x m) type LEq a b = a -> b -> Bool data Assoc k a = Asc {-# UNPACK #-} !Int k a @@ -71,6 +72,7 @@ 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 + alterLookupM :: TrieMap k ~ m => Sized a -> (Maybe a -> CPair x (Maybe a)) -> k -> m a -> CPair x (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) @@ -90,6 +92,8 @@ 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 +-- alterLookupM s f k m = fmap (\ v' -> alterM s (const v') k m) (f (lookupM k m)) + alterM s f k m = cpSnd (alterLookupM s (cP () . f) k m) sizeM s m = foldWithKeyM (\ _ a n -> s a + n) m 0 fromListM s f = foldl' (flip (uncurry (insertWithKeyM s f))) emptyM fromAscListM = fromListM @@ -106,6 +110,7 @@ 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) +{-# INLINE [1] mapWithKeyM #-} mapWithKeyM :: (TrieKey k m, m ~ TrieMap k) => Sized b -> (k -> a -> b) -> m a -> m b mapWithKeyM s f = unId . traverseWithKeyM s (Id .: f) @@ -147,4 +152,15 @@ 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)) +aboutM f = cpFst <.> extractM (const 0) (\ k a -> fmap (flip cP Nothing) (f k a)) + +{-# RULES +-- "lookupM/emptyM" forall k . lookupM k emptyM = Nothing; +-- "sizeM/emptyM" forall s . sizeM s emptyM = 0; +-- "traverseWithKeyM/emptyM" forall s f . traverseWithKeyM s f emptyM = pure emptyM; +-- "extractM/emptyM" forall s f . extractM s f emptyM = empty; +-- "foldWithKeyM/emptyM" forall f . foldWithKeyM f emptyM z = z; +-- "foldlWithKeyM/emptyM" forall f . foldlWithKeyM f emptyM z = z; +-- "lookupIxM/emptyM" forall s k . lookupIxM s k emptyM = (empty, empty, empty); +-- "mapEitherM/emptyM" forall s1 s2 f . mapEitherM s1 s2 f emptyM = (emptyM, emptyM); + #-} diff --git a/Data/TrieMap/UnionMap.hs b/Data/TrieMap/UnionMap.hs new file mode 100644 --- /dev/null +++ b/Data/TrieMap/UnionMap.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE FlexibleContexts, PatternGuards, UndecidableInstances, TypeFamilies, MultiParamTypeClasses #-} + +module Data.TrieMap.UnionMap () where + +import Data.TrieMap.TrieKey +import Data.TrieMap.Regular.Class +-- import Data.TrieMap.Regular.TH +import Data.TrieMap.Applicative + +import Control.Applicative +-- import Control.Arrow + +-- import Data.Monoid + +data UMap m1 k2 a = m1 a :&: TrieMap k2 a + +type instance TrieMapT (Either a) = UMap (TrieMap a) +type instance TrieMap (Either a b) = UMap (TrieMap a) b + +instance (TrieKey a m, TrieKey b (TrieMap b)) => TrieKey (Either a b) (UMap m b) where + emptyM = emptyT + nullM = nullT + lookupM = lookupT + lookupIxM = lookupIxT + assocAtM = assocAtT + alterM = alterT + alterLookupM = alterLookupT + traverseWithKeyM = traverseWithKeyT + foldWithKeyM = foldWithKeyT + foldlWithKeyM = foldlWithKeyT + mapEitherM = mapEitherT + splitLookupM = splitLookupT + unionM = unionT + isectM = isectT + diffM = diffT + extractM = extractT + isSubmapM = isSubmapT + fromListM = fromListT + fromAscListM = fromAscListT + fromDistAscListM = fromDistAscListT + +instance TrieKey k1 m1 => TrieKeyT (Either k1) (UMap m1) where + emptyT = emptyM :&: emptyM + nullT (m1 :&: m2) = nullM m1 && nullM m2 + sizeT s (m1 :&: m2) = sizeM s m1 + sizeM s m2 + lookupT k (m1 :&: m2) = either (`lookupM` m1) (`lookupM` m2) k + lookupIxT s k (m1 :&: m2) = case k of + Left k | (lb, x, ub) <- onKey Left $ lookupIxM s k m1 + -> (lb, x, ub <|> aboutM (\ k -> return . Asc (sizeM s m1) (Right k)) m2) + Right k | (lb, x, ub) <- onKey Right $ lookupIxM s k m2 + -> (aboutM (\ k a -> return (Asc (sizeM s m1 - s a) (Left k) a)) m1 <|> lb, x, ub) + assocAtT s i (m1 :&: m2) + | i < s1, (lb, x, ub) <- onKey Left (assocAtM s i m1) + = (lb, x, ub <|> aboutM (\ k -> return . Asc s1 (Right k)) m2) + | (lb, x, ub) <- onKey Right (onIndex (s1 +) (assocAtM s (i - s1) m2)) + = (aboutM (\ k a -> return (Asc (s1 - s a) (Left k) a)) m1 <|> lb, x, ub) + where s1 = sizeM s m1 +-- updateAtM s r i (m1 :&: m2) + alterT s f k (m1 :&: m2) = case k of + Left k -> alterM s f k m1 :&: m2 + Right k -> m1 :&: alterM s f k m2 + alterLookupT s f k (m1 :&: m2) = case k of + Left k -> fmap (:&: m2) (alterLookupM s f k m1) + Right k -> fmap (m1 :&:) (alterLookupM s f k m2) + traverseWithKeyT s f (m1 :&: m2) = (:&:) <$> traverseWithKeyM s (f . Left) m1 <*> traverseWithKeyM s (f . Right) m2 + foldWithKeyT f (m1 :&: m2) = foldWithKeyM (f . Left) m1 . foldWithKeyM (f . Right) m2 + foldlWithKeyT f (m1 :&: m2) = foldlWithKeyM (f . Right) m2 . foldlWithKeyM (f . Left) m1 + mapEitherT s1 s2 f (m1 :&: m2) = (m1L :&: m2L, m1R :&: m2R) + where (m1L, m1R) = mapEitherM s1 s2 (f . Left) m1 + (m2L, m2R) = mapEitherM s1 s2 (f . Right) m2 +-- extractMinT s f (m1 :&: m2) = second (:&: m2) <$> extractMinM s (f . Left) m1 <|> +-- second (m1 :&:) <$> extractMinM s (f . Right) m2 +-- extractMaxT s f (m1 :&: m2) = second (:&: m2) <$> extractMaxM s (f . Left) m1 <|> +-- second (m1 :&:) <$> extractMaxM s (f . Right) m2 + extractT s f (m1 :&: m2) = fmap (:&: m2) <$> extractM s (f . Left) m1 <|> + fmap (m1 :&:) <$> extractM s (f . Right) m2 + splitLookupT s f k (m1 :&: m2) = case k of + Left k | (m1L, x, m1R) <- splitLookupM s f k m1 + -> (m1L :&: emptyM, x, m1R :&: m2) + Right k | (m2L, x, m2R) <- splitLookupM s f k m2 + -> (m1 :&: m2L, x, emptyM :&: m2R) + unionT s f (m11 :&: m12) (m21 :&: m22) + = unionM s (f . Left) m11 m21 :&: unionM s (f . Right) m12 m22 + isectT s f (m11 :&: m12) (m21 :&: m22) + = isectM s (f . Left) m11 m21 :&: isectM s (f . Right) m12 m22 + diffT s f (m11 :&: m12) (m21 :&: m22) + = diffM s (f . Left) m11 m21 :&: diffM s (f . Right) m12 m22 + isSubmapT (<=) (m11 :&: m12) (m21 :&: m22) = isSubmapM (<=) m11 m21 && isSubmapM (<=) m12 m22 + fromListT s f xs = case partEithers xs of + (ys, zs) -> fromListM s (f . Left) ys :&: fromListM s (f . Right) zs + fromAscListT s f xs = case partEithers xs of + (ys, zs) -> fromAscListM s (f . Left) ys :&: fromAscListM s (f . Right) zs + fromDistAscListT s xs = case partEithers xs of + (ys, zs) -> fromDistAscListM s ys :&: fromDistAscListM s zs + +partEithers :: [(Either a b, x)] -> ([(a, x)], [(b, x)]) +partEithers = foldr part ([], []) where + part (Left x, z) (xs, ys) = ((x,z):xs, ys) + part (Right y, z) (xs, ys) = (xs, (y, z):ys) + +-- aboutMinM :: TrieKey k (TrieMap k) => (k -> a -> x) -> TrieMap k a -> First x +-- aboutMinM f m = fst <$> extractMinM (const 0) (\ k a -> (f k a, Nothing)) m +-- +-- aboutMaxM :: TrieKey k (TrieMap k) => (k -> a -> x) -> TrieMap k a -> Last x +-- aboutMaxM f m = fst <$> extractMaxM (const 0) (\ k a -> (f k a, Nothing)) m + diff --git a/Data/TrieMap/UnitMap.hs b/Data/TrieMap/UnitMap.hs new file mode 100644 --- /dev/null +++ b/Data/TrieMap/UnitMap.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} + +module Data.TrieMap.UnitMap where + +import Data.TrieMap.TrieKey + +import Control.Applicative + +import Data.Foldable +import Data.Traversable +import Data.Maybe + +import Prelude hiding (foldr, foldl) + +type instance TrieMap () = Maybe + +instance TrieKey () Maybe where + emptyM = Nothing + nullM = isNothing + sizeM = maybe 0 + lookupM = flip const + lookupIxM _ _ m = (empty, Asc 0 () <$> m, empty) + assocAtM s i m = case m of + Nothing -> (empty, empty, empty) + Just m + | i < 0 -> (empty, empty, return (Asc 0 () m)) + | i < s m -> (empty, return (Asc 0 () m), empty) + | otherwise -> (return (Asc 0 () m), empty, empty) + traverseWithKeyM _ f = traverse (f ()) + foldWithKeyM f m z = foldr (f ()) z m + foldlWithKeyM f m z = foldl (f ()) z m + mapEitherM _ _ f = maybe (Nothing, Nothing) (f ()) + splitLookupM _ f _ = maybe (Nothing, Nothing, Nothing) f + alterM _ f _ = f + alterLookupM _ f _ = f + unionM _ f = unionMaybe (f ()) + isectM _ f = isectMaybe (f ()) + diffM _ f = diffMaybe (f ()) + extractM _ f = maybe empty (f ()) + isSubmapM (<=) = subMaybe (<=) + fromListM _ f [] = Nothing + fromListM _ f ((_, v):xs) = Just (foldl (\ v' -> f () v' . snd) v xs) + fromAscListM = fromListM diff --git a/TrieMap.cabal b/TrieMap.cabal --- a/TrieMap.cabal +++ b/TrieMap.cabal @@ -1,5 +1,5 @@ name: TrieMap -version: 0.5.2 +version: 0.5.3 tested-with: GHC category: Algorithms synopsis: Automatic type inference of generalized tries. @@ -24,10 +24,15 @@ Data.TrieMap.Class.Instances, Data.TrieMap.TrieKey, Data.TrieMap.Applicative, + Data.TrieMap.CPair, + Data.TrieMap.ProdMap, + Data.TrieMap.RadixTrie, + Data.TrieMap.UnionMap, + Data.TrieMap.UnitMap, Data.TrieMap.Rep, Data.TrieMap.Rep.Instances, Data.TrieMap.Rep.TH, - Data.TrieMap.MultiRec.TH, + -- Data.TrieMap.MultiRec.TH, Data.TrieMap.MultiRec.FamMap, Data.TrieMap.MultiRec.Eq, Data.TrieMap.MultiRec.Ord, @@ -36,7 +41,7 @@ Data.TrieMap.MultiRec.IMap, Data.TrieMap.MultiRec.Base, -- Data.TrieMap.MultiRec.XMap, - Data.TrieMap.MultiRec.FixMap, + -- Data.TrieMap.MultiRec.FixMap, -- Data.TrieMap.MultiRec.AppMap, Data.TrieMap.MultiRec.Instances, Data.TrieMap.MultiRec.ProdMap,