summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLouisWasserman <>2009-10-21 17:18:39 (GMT)
committerLuite Stegeman <luite@luite.com>2009-10-21 17:18:39 (GMT)
commit2349c6b7aa3c4f79968907799d90d60c67f9b297 (patch)
tree3a6b14c45abcb966122499b7590d0dc8dbef4322
parent6d4ac0e48f4a3fb8b7022f86e4a9e55b463662cd (diff)
version 0.5.30.5.3
-rw-r--r--Data/TrieMap.hs32
-rw-r--r--Data/TrieMap/CPair.hs35
-rw-r--r--Data/TrieMap/Class.hs6
-rw-r--r--Data/TrieMap/Class/Instances.hs109
-rw-r--r--Data/TrieMap/IntMap.hs164
-rw-r--r--Data/TrieMap/MultiRec.hs2
-rw-r--r--Data/TrieMap/MultiRec/Base.hs33
-rw-r--r--Data/TrieMap/MultiRec/Class.hs226
-rw-r--r--Data/TrieMap/MultiRec/ConstMap.hs68
-rw-r--r--Data/TrieMap/MultiRec/Eq.hs60
-rw-r--r--Data/TrieMap/MultiRec/FamMap.hs199
-rw-r--r--Data/TrieMap/MultiRec/FixMap.hs37
-rw-r--r--Data/TrieMap/MultiRec/IMap.hs76
-rw-r--r--Data/TrieMap/MultiRec/Instances.hs2
-rw-r--r--Data/TrieMap/MultiRec/Ord.hs111
-rw-r--r--Data/TrieMap/MultiRec/ProdMap.hs211
-rw-r--r--Data/TrieMap/MultiRec/TH.hs89
-rw-r--r--Data/TrieMap/MultiRec/TagMap.hs60
-rw-r--r--Data/TrieMap/MultiRec/UnionMap.hs172
-rw-r--r--Data/TrieMap/MultiRec/UnitMap.hs34
-rw-r--r--Data/TrieMap/OrdMap.hs29
-rw-r--r--Data/TrieMap/ProdMap.hs123
-rw-r--r--Data/TrieMap/RadixTrie.hs289
-rw-r--r--Data/TrieMap/Regular/Base.hs2
-rw-r--r--Data/TrieMap/Regular/Class.hs10
-rw-r--r--Data/TrieMap/Regular/CompMap.hs76
-rw-r--r--Data/TrieMap/Regular/ConstMap.hs4
-rw-r--r--Data/TrieMap/Regular/Eq.hs7
-rw-r--r--Data/TrieMap/Regular/IdMap.hs4
-rw-r--r--Data/TrieMap/Regular/Ord.hs10
-rw-r--r--Data/TrieMap/Regular/ProdMap.hs43
-rw-r--r--Data/TrieMap/Regular/RadixTrie.hs41
-rw-r--r--Data/TrieMap/Regular/RegMap.hs3
-rw-r--r--Data/TrieMap/Regular/TH.hs7
-rw-r--r--Data/TrieMap/Regular/UnionMap.hs43
-rw-r--r--Data/TrieMap/Regular/UnitMap.hs18
-rw-r--r--Data/TrieMap/Rep/Instances.hs99
-rw-r--r--Data/TrieMap/Rep/TH.hs4
-rw-r--r--Data/TrieMap/Representation/TH.hs64
-rw-r--r--Data/TrieMap/ReverseMap.hs41
-rw-r--r--Data/TrieMap/TrieKey.hs20
-rw-r--r--Data/TrieMap/UnionMap.hs106
-rw-r--r--Data/TrieMap/UnitMap.hs43
-rw-r--r--TrieMap.cabal11
44 files changed, 1737 insertions, 1086 deletions
diff --git a/Data/TrieMap.hs b/Data/TrieMap.hs
index af1b2ac..977f171 100644
--- a/Data/TrieMap.hs
+++ b/Data/TrieMap.hs
@@ -119,22 +119,26 @@ import Data.TrieMap.Class.Instances()
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 (Eq k, TKey k, Eq a) => Eq (TMap k a) where
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 @@ m ! k = fromMaybe (error "Element not found") (lookup k m)
alter :: TKey k => (Maybe a -> Maybe a) -> k -> TMap k a -> TMap k a
alter f k (TMap m) = TMap (alterM 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 @@ extract f m = unwrapMonad (extractA (WrapMonad .: f) m)
-- | Generalization of 'extract' for 'Alternative' functors.
extractA :: (TKey k, Alternative f) => (k -> a -> f (x, Maybe a)) -> TMap k a -> f (x, TMap k a)
-extractA f (TMap m) = second TMap <$> extractM elemSize (\ k (Elem a) -> second (fmap Elem) <$> f (fromRep k) a) m
+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 @@ snd3 (a, b, c) = b
thd3 (a, b, c) = c
findIndex :: TKey k => k -> TMap k a -> Int
-findIndex k m = fromMaybe (error "element is not in the map") (lookupIndex k m)
+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)
@@ -444,4 +452,10 @@ neighborhoodAt i (TMap m) = case assocAtM elemSize i m of
where fix (Asc i k (Elem a)) = (i, fromRep k, a)
keysSet :: TKey k => TMap k a -> TSet k
-keysSet = TSet . map (const ()) \ No newline at end of file
+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) \ No newline at end of file
diff --git a/Data/TrieMap/CPair.hs b/Data/TrieMap/CPair.hs
new file mode 100644
index 0000000..604b4bc
--- /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) \ No newline at end of file
diff --git a/Data/TrieMap/Class.hs b/Data/TrieMap/Class.hs
index 277d505..b2e523d 100644
--- 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,8 +25,12 @@ class (Repr k, TrieKey (Rep k) (TrieMap (Rep k))) => TKey k
-- 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
index f8047ab..cdc6e9d 100644
--- 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
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.Base
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 @@ instance TKey k => TKey [k] where
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
index 79fcef1..f07ada2 100644
--- 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.Bits
import Data.Maybe
import Data.Monoid
import Data.Word
-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
+-- 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
import Prelude hiding (lookup, null, foldl, foldr)
@@ -72,6 +73,7 @@ instance TrieKey Word32 WordMap where
assocAtM s = assocAt s 0
-- updateAtM s r = updateAt s r 0
alterM = alter
+ alterLookupM = alterLookup
traverseWithKeyM = traverseWithKey
foldWithKeyM = foldr
foldlWithKeyM = foldl
@@ -161,21 +163,6 @@ lookup k (Tip _ kx x)
| 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)
@@ -187,14 +174,6 @@ assocAt s !i0 !i (Bin _ _ _ l r)
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 @@ alter s f k t = case t of
| 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 @@ foldr f t
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 (Bin _ p m l r) = case (mapEither s1 s2 f l, mapEither s1 s2 f
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<ky -> (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 _ (Bin _ _ _ _ _) _ = False
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 @@ maxViewUnsigned s f t
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 @@ minViewUnsigned s f t
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 @@ updateMinWithKeyUnsigned s f t
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
@@ -517,54 +475,4 @@ join p1 t1 p2 t2
bin :: Prefix -> Mask -> WordMap a -> WordMap a -> WordMap a
bin _ _ l Nil = l
bin _ _ Nil r = r
-bin p m l r = Bin (size l + size r) p m l r
-
--- import Data.Monoid
--- import Data.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 \ No newline at end of file
+bin p m l r = Bin (size l + size r) p m l r \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec.hs b/Data/TrieMap/MultiRec.hs
index 97896f3..5468d14 100644
--- 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
index 2953490..a14e46b 100644
--- 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 TrieKey k (TrieMap k) => El KeyFam k where
-- 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 (Functor (f r), Functor (g r)) => Functor ((f :+: g) r) where
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
index 9638841..89a6636 100644
--- 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 \ No newline at end of file
+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) \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/ConstMap.hs b/Data/TrieMap/MultiRec/ConstMap.hs
index 7f780ed..5b9c7c9 100644
--- 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.Applicative
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 @@ type instance HTrieMap phi (K k r) = HTrieMapT phi (K k) r
-- 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
- 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]) \ No newline at end of file
+ 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 \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/Eq.hs b/Data/TrieMap/MultiRec/Eq.hs
index b3a0838..377e6d9 100644
--- 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 HEq0 phi r => HEq0 phi (A0 r) where
-- 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 \ No newline at end of file
+-- 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 \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/FamMap.hs b/Data/TrieMap/MultiRec/FamMap.hs
index 85b61c2..cf7b776 100644
--- a/Data/TrieMap/MultiRec/FamMap.hs
+++ b/Data/TrieMap/MultiRec/FamMap.hs
@@ -7,150 +7,95 @@ import Data.TrieMap.MultiRec.Eq
import Data.TrieMap.MultiRec.Ord
import Data.TrieMap.MultiRec.Sized
import Data.TrieMap.MultiRec.Base
-import Data.TrieMap.Sized
-import Data.TrieMap.Applicative
+-- import Data.TrieMap.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))
+type instance TrieMap (Family phi ix) = FamMap phi (HTrieMapT phi (PF phi)) ix
-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)
+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 (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
-
-instance HOrd0 phi r => HOrd0 phi (FamT phi r) where
- compareH0 pf (FamT x) (FamT y) = compareH0 pf x y
-
-instance (El phi ix, HEq0 phi r) => Eq (FamT phi r ix) where
- x == y = heqH (prove' x) x y
+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)
-
-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) \ No newline at end of file
+ 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 (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 \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/FixMap.hs b/Data/TrieMap/MultiRec/FixMap.hs
deleted file mode 100644
index a4964d0..0000000
--- 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 \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/IMap.hs b/Data/TrieMap/MultiRec/IMap.hs
index c35913e..14c6968 100644
--- a/Data/TrieMap/MultiRec/IMap.hs
+++ b/Data/TrieMap/MultiRec/IMap.hs
@@ -4,8 +4,9 @@ module Data.TrieMap.MultiRec.IMap () where
import Data.TrieMap.MultiRec.Class
import Data.TrieMap.MultiRec.Sized
-import Data.TrieMap.MultiRec.TH
--- import Data.TrieMap.Rep.TH
+-- import Data.TrieMap.MultiRec.KeyFam
+-- import Data.TrieMap.MultiRec.TT
+-- import Data.TrieMap.Rep.TT
-- import Data.TrieMap.Rep
import Data.TrieMap.TrieKey
@@ -16,41 +17,40 @@ import Generics.MultiRec
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 |] )
-
-
-$(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]) |]) \ No newline at end of file
+-- -- $(genRepH [d|
+-- instance ReprH (TTrieMap phi r xi) => ReprH (IMap phi xi r ix) where
+-- toRepH (IMap m) = toRepH m
+-- fromRepH = IMap . fromRepH |] )
+
+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]) \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/Instances.hs b/Data/TrieMap/MultiRec/Instances.hs
index 3330dfb..181e087 100644
--- a/Data/TrieMap/MultiRec/Instances.hs
+++ b/Data/TrieMap/MultiRec/Instances.hs
@@ -9,4 +9,4 @@ import Data.TrieMap.MultiRec.UnitMap
import Data.TrieMap.MultiRec.FamMap
-- import Data.TrieMap.MultiRec.AppMap
-- import Data.TrieMap.MultiRec.XMap
-import Data.TrieMap.MultiRec.FixMap \ No newline at end of file
+-- import Data.TrieMap.MultiRec.FixMap \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/Ord.hs b/Data/TrieMap/MultiRec/Ord.hs
index 25bb6e8..c41a288 100644
--- a/Data/TrieMap/MultiRec/Ord.hs
+++ b/Data/TrieMap/MultiRec/Ord.hs
@@ -4,69 +4,98 @@ module Data.TrieMap.MultiRec.Ord where
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 f => HOrd0 phi (HFix f) where
- compareH0 pf (HIn a) (HIn b) = hcompare pf a b \ No newline at end of file
+instance HOrd phi U where
+ compareH _ _ _ _ = EQ
+
+-- 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 \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/ProdMap.hs b/Data/TrieMap/MultiRec/ProdMap.hs
index 6c97a23..e0f8a64 100644
--- a/Data/TrieMap/MultiRec/ProdMap.hs
+++ b/Data/TrieMap/MultiRec/ProdMap.hs
@@ -4,10 +4,12 @@ module Data.TrieMap.MultiRec.ProdMap () where
import Data.TrieMap.MultiRec.Class
import Data.TrieMap.MultiRec.Eq
-import Data.TrieMap.MultiRec.Ord
+-- import Data.TrieMap.MultiRec.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 @@ import Generics.MultiRec
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)]
- |]) \ No newline at end of file
+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)] \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/TH.hs b/Data/TrieMap/MultiRec/TH.hs
deleted file mode 100644
index 95dc3cd..0000000
--- 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 \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/TagMap.hs b/Data/TrieMap/MultiRec/TagMap.hs
index 5d66bdc..946fd92 100644
--- a/Data/TrieMap/MultiRec/TagMap.hs
+++ b/Data/TrieMap/MultiRec/TagMap.hs
@@ -5,8 +5,9 @@ module Data.TrieMap.MultiRec.TagMap () where
import Data.TrieMap.MultiRec.Class
import Data.TrieMap.MultiRec.Eq
import Data.TrieMap.MultiRec.Sized
-import Data.TrieMap.MultiRec.TH
-import Data.TrieMap.Applicative
+import Data.TrieMap.CPair
+-- import Data.TrieMap.MultiRec.TH
+-- import Data.TrieMap.Applicative
import Data.TrieMap.TrieKey
-- import Data.TrieMap.Rep
@@ -15,8 +16,8 @@ import Control.Arrow
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 @@ unTagF (TagF x) = x
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 @@ restructure :: HTrieKeyT phi f (HTrieMapT phi f) =>
((f r ix, TagF a xi ix), HTrieMapT phi f r ix (TagF a xi ix)) -> (((f :>: xi) r ix, a), TagMap phi f xi r ix a)
restructure ((k, TagF a), m) = ((Tag k, a), TagMap m)
-restructure' :: Applicative t => ((f :>: xi) r ix -> a -> t (x, Maybe a)) -> f r ix -> TagF a xi ix -> t (x, Maybe (TagF a xi ix))
-restructure' f k (TagF a) = second (fmap TagF) <$> f (Tag k) a
+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
index f07e4a3..3a8bc7b 100644
--- 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 \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/UnitMap.hs b/Data/TrieMap/MultiRec/UnitMap.hs
index c78a570..6c867c0 100644
--- a/Data/TrieMap/MultiRec/UnitMap.hs
+++ b/Data/TrieMap/MultiRec/UnitMap.hs
@@ -12,7 +12,7 @@ import Data.TrieMap.TrieKey
import Control.Applicative
import Control.Arrow
-import Control.Monad
+-- import Control.Monad
import Data.Maybe
import Data.Monoid
@@ -24,7 +24,7 @@ import Prelude hiding (foldr, foldl)
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 @@ type instance HTrieMap phi (U r) = UMap phi r
-- 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 @@ instance HTrieKey phi (U r) (UMap phi r) where
-- | 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 @@ instance HTrieKey phi (U r) (UMap phi r) where
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
index 4888079..c729201 100644
--- a/Data/TrieMap/OrdMap.hs
+++ b/Data/TrieMap/OrdMap.hs
@@ -4,21 +4,22 @@ module Data.TrieMap.OrdMap () where
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 @@ instance Ord k => TrieKey (Ordered k) (OrdMap k) where
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 @@ alter s f k (Bin _ kx x l r) = case compare k kx of
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 @@ glue s l r
| size l > size r = let (f,l') = deleteFindMax s (\ k a -> (balance s k a, Nothing)) l in f l' r
| otherwise = let (f,r') = deleteFindMin s (\ k a -> (balance s k a, Nothing)) r in f l r'
-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
index 0000000..1015390
--- /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-} \ No newline at end of file
diff --git a/Data/TrieMap/RadixTrie.hs b/Data/TrieMap/RadixTrie.hs
new file mode 100644
index 0000000..9dd486b
--- /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
index 4234320..3e7c6a9 100644
--- 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
index 0931a90..a78a83a 100644
--- a/Data/TrieMap/Regular/Class.hs
+++ b/Data/TrieMap/Regular/Class.hs
@@ -5,10 +5,11 @@ module Data.TrieMap.Regular.Class where
import Data.TrieMap.Sized
import Data.TrieMap.Applicative
import Data.TrieMap.TrieKey
-import Data.TrieMap.Regular.Eq
+-- import Data.TrieMap.Regular.Eq
import Data.TrieMap.Regular.Ord
+import Data.TrieMap.CPair
-import Data.Monoid
+-- import Data.Monoid
import Control.Applicative
@@ -23,6 +24,7 @@ class OrdT f => TrieKeyT (f :: * -> *) (m :: * -> * -> *) | m -> f, f -> m where
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 @@ class OrdT f => TrieKeyT (f :: * -> *) (m :: * -> * -> *) | m -> f, f -> m where
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 @@ mapWithKeyT s f m = unId (traverseWithKeyT s (Id .: f) m)
aboutT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k), Alternative t) =>
(f k -> a -> t z) -> TrieMapT f k a -> t z
-aboutT f m = fst <$> extractT (const 0) (\ k a -> fmap (flip (,) Nothing) (f k a)) m
+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
index db68f23..3660d7d 100644
--- a/Data/TrieMap/Regular/CompMap.hs
+++ b/Data/TrieMap/Regular/CompMap.hs
@@ -6,10 +6,10 @@ import Data.TrieMap.Regular.Base
import Data.TrieMap.Regular.Class
import Data.TrieMap.Regular.Ord
import Data.TrieMap.Regular.Eq
-import Data.TrieMap.Regular.TH
+-- import Data.TrieMap.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 (EqT f, Eq r) => Eq (App f r) where
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)
+
+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
-$(deriveM [d|
- instance TrieKeyT f m => TrieKeyT (App f) (AppMap m) where
+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 @@ $(deriveM [d|
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 @@ $(deriveM [d|
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 |]) \ No newline at end of file
+ isSubmapT (<=) (AMap m1) (AMap m2) = isSubmapT (<=) m1 m2 \ No newline at end of file
diff --git a/Data/TrieMap/Regular/ConstMap.hs b/Data/TrieMap/Regular/ConstMap.hs
index 3a1993a..06cef8d 100644
--- a/Data/TrieMap/Regular/ConstMap.hs
+++ b/Data/TrieMap/Regular/ConstMap.hs
@@ -25,6 +25,7 @@ instance (TrieKey k m, m ~ TrieMap k) => TrieKey (K0 k r) (KMap m r) where
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 @@ instance (TrieKey k m, m ~ TrieMap k) => TrieKey (K0 k r) (KMap m r) where
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 @@ instance (TrieKey k m, m ~ TrieMap k) => TrieKeyT (K0 k) (KMap m) where
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
index 1f7640f..b628fc9 100644
--- 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
@@ -13,6 +13,9 @@ class EqT f where
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
index b8a305b..2d664a2 100644
--- a/Data/TrieMap/Regular/IdMap.hs
+++ b/Data/TrieMap/Regular/IdMap.hs
@@ -23,6 +23,7 @@ instance TrieKeyT I0 IMap where
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 @@ instance TrieKeyT I0 IMap where
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 @@ instance TrieKey k (TrieMap k) => TrieKey (I0 k) (IMap k) where
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
index 82fbf7a..34c6d59 100644
--- a/Data/TrieMap/Regular/Ord.hs
+++ b/Data/TrieMap/Regular/Ord.hs
@@ -4,9 +4,9 @@ module Data.TrieMap.Regular.Ord where
import Data.TrieMap.Regular.Base
import Data.TrieMap.Regular.Eq
-import Data.TrieMap.MultiRec.Base(FamT(..), KeyFam(..))
-import Data.TrieMap.MultiRec.Ord(HOrd0(..))
-import Data.TrieMap.TrieKey
+-- import Data.TrieMap.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 :: (OrdT f, Ord a) => Comparator (f a)
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
index 5806355..a56b796 100644
--- a/Data/TrieMap/Regular/ProdMap.hs
+++ b/Data/TrieMap/Regular/ProdMap.hs
@@ -8,7 +8,7 @@ import Data.TrieMap.Regular.Eq
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 @@ lastIx s m = fromMaybe (sizeT s m) (getLast (aboutT (\ _ a -> return $ sizeT s m
--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 @@ $(deriveM [d|
-- = 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 @@ $(deriveM [d|
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 @@ $(deriveM [d|
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)]
- |]) \ No newline at end of file
+ breakFst' a vs [] = [(a, toList vs)] \ No newline at end of file
diff --git a/Data/TrieMap/Regular/RadixTrie.hs b/Data/TrieMap/Regular/RadixTrie.hs
index b211da9..e3d61ca 100644
--- a/Data/TrieMap/Regular/RadixTrie.hs
+++ b/Data/TrieMap/Regular/RadixTrie.hs
@@ -6,13 +6,14 @@ import Data.TrieMap.Regular.Class
import Data.TrieMap.Regular.Base
import Data.TrieMap.Regular.Ord
import Data.TrieMap.Regular.Eq
-import Data.TrieMap.Regular.TH
+-- import Data.TrieMap.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 @@ instance (OrdT f, TrieKeyT f m, m ~ TrieMapT f) => TrieKeyT (L f) (RadixTrie f)
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 @@ instance (OrdT f, TrieKeyT f m, m ~ TrieMapT f) => TrieKeyT (L f) (RadixTrie f)
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 @@ instance (OrdT f, TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => TrieKey (L
assocAtM = assocAtT
-- updateAtM = updateAtT
alterM = alterT
+ alterLookupM = alterLookupT
traverseWithKeyM = traverseWithKeyT
foldWithKeyM = foldWithKeyT
foldlWithKeyM = foldlWithKeyT
@@ -165,6 +168,24 @@ alterE s f ks0 e@(Edge sz ls0 v0 ts0) = match 0 ks0 ls0 where
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 @@ unionE s f (Edge szK ks0 vK tsK) (Edge szL ls0 vL tsL) = match 0 ks0 ls0 where
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
index 5933b9c..75facfa 100644
--- a/Data/TrieMap/Regular/RegMap.hs
+++ b/Data/TrieMap/Regular/RegMap.hs
@@ -21,6 +21,7 @@ instance (Regular k, Functor (PF k), TrieKeyT (PF k) m, m ~ TrieMapT (PF k)) =>
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 @@ instance (Regular k, Functor (PF k), TrieKeyT (PF k) m, m ~ TrieMapT (PF k)) =>
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
index 85e5d55..a8fbc7f 100644
--- a/Data/TrieMap/Regular/TH.hs
+++ b/Data/TrieMap/Regular/TH.hs
@@ -8,7 +8,7 @@ import Language.Haskell.TH
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 @@ deriveM decs = do
lookupIxM = lookupIxT
assocAtM = assocAtT
-- updateAtM = updateAtT
+
alterM = alterT
+ alterLookupM = alterLookupT
traverseWithKeyM = traverseWithKeyT
foldWithKeyM = foldWithKeyT
foldlWithKeyM = foldlWithKeyT
@@ -39,8 +41,7 @@ deriveM decs = do
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 \ No newline at end of file
diff --git a/Data/TrieMap/Regular/UnionMap.hs b/Data/TrieMap/Regular/UnionMap.hs
index f1c3d21..bfa56df 100644
--- a/Data/TrieMap/Regular/UnionMap.hs
+++ b/Data/TrieMap/Regular/UnionMap.hs
@@ -4,18 +4,18 @@ module Data.TrieMap.Regular.UnionMap() where
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 @@ type instance TrieMap ((f :+: g) r) = TrieMapT (f :+: g) r
-- 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 @@ $(deriveM [d|
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 @@ $(deriveM [d|
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 @@ $(deriveM [d|
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 |]) \ No newline at end of file
+ (ys, zs) -> fromDistAscListT s ys :&: fromDistAscListT s zs \ No newline at end of file
diff --git a/Data/TrieMap/Regular/UnitMap.hs b/Data/TrieMap/Regular/UnitMap.hs
index 38c0f95..3005849 100644
--- a/Data/TrieMap/Regular/UnitMap.hs
+++ b/Data/TrieMap/Regular/UnitMap.hs
@@ -5,9 +5,9 @@ module Data.TrieMap.Regular.UnitMap() where
import Data.TrieMap.Regular.Class
import Data.TrieMap.Regular.Base
import Data.TrieMap.TrieKey
-import Data.TrieMap.Rep
-import Data.TrieMap.Rep.Instances
-import Data.TrieMap.Rep.TH
+-- import Data.TrieMap.Rep
+-- import Data.TrieMap.Rep.Instances
+-- import Data.TrieMap.Rep.TH
import Data.TrieMap.Applicative
import Control.Applicative
@@ -25,14 +25,6 @@ newtype M k a = M (Maybe a)
type instance TrieMapT U0 = M
type instance TrieMap (U0 r) = M r
-type instance RepT (M k) = RepT Maybe
-type instance Rep (M k a) = RepT Maybe (Rep a)
-
-$(genRepT [d|
- instance ReprT (M k) where
- toRepT (M a) = toRepT a
- fromRepT = M . fromRepT |])
-
instance TrieKey (U0 r) (M r) where
emptyM = M Nothing
nullM (M a) = isNothing a
@@ -50,6 +42,7 @@ instance TrieKey (U0 r) (M r) where
-- | 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 @@ instance TrieKey (U0 r) (M r) where
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 @@ instance TrieKeyT U0 M where
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
index 7d7b441..298ed96 100644
--- a/Data/TrieMap/Rep/Instances.hs
+++ b/Data/TrieMap/Rep/Instances.hs
@@ -5,7 +5,7 @@ module Data.TrieMap.Rep.Instances() where
import Data.TrieMap.Rep
import Data.TrieMap.Rep.TH
import Data.TrieMap.Regular.Base
-import Data.TrieMap.OrdMap
+-- import Data.TrieMap.OrdMap
import Data.TrieMap.Modifiers
-- import Language.Haskell.TH
@@ -17,6 +17,8 @@ import Data.Word
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 @@ import Prelude hiding (concat, take, length)
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 @@ $(genRepT [d|
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 @@ instance Repr Word32 where
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 :: Words' -> Maybe (Word8, Words')
toBlock (W (Words i0@(i+1) w) xs) = Just (extract w (8 * i0), (W (Words i w) xs))
where extract :: Word32 -> Int -> Word8
extract w x = fromIntegral (w `shiftR` x)
-toBlock (W (Words 0 w) (I0 x:xs)) = Just (fromIntegral w, (W (Words 3 x) xs))
+toBlock (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 @@ $(genRepT [d|
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 @@ $(genRepT [d|
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) |]) \ No newline at end of file
+ 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
index 0f2b8b4..6901c92 100644
--- a/Data/TrieMap/Rep/TH.hs
+++ b/Data/TrieMap/Rep/TH.hs
@@ -4,8 +4,8 @@ module Data.TrieMap.Rep.TH (genRepT, mkCon, conT, mkVar, appT, Type(..)) where
import Language.Haskell.TH
import Data.TrieMap.Rep
-import Language.Haskell.TH.Ppr
-import Debug.Trace
+-- 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
index 5c1243e..06a247d 100644
--- 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 #-}
-import Data.TrieMap.Rep.TH \ No newline at end of file
+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, \ No newline at end of file
diff --git a/Data/TrieMap/ReverseMap.hs b/Data/TrieMap/ReverseMap.hs
index c3929e0..2cc7492 100644
--- 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 Control.Arrow
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 @@ $(deriveM [d|
-- 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 @@ $(deriveM [d|
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 \ No newline at end of file
diff --git a/Data/TrieMap/TrieKey.hs b/Data/TrieMap/TrieKey.hs
index 799dd99..21fa0cb 100644
--- a/Data/TrieMap/TrieKey.hs
+++ b/Data/TrieMap/TrieKey.hs
@@ -4,6 +4,7 @@ module Data.TrieMap.TrieKey where
import Data.TrieMap.Applicative
import Data.TrieMap.Sized
+import Data.TrieMap.CPair
import Control.Applicative
import Control.Arrow
@@ -21,7 +22,7 @@ type SplitMap a x = a -> (Maybe a, Maybe x, Maybe a)
type UnionFunc k a = k -> a -> a -> Maybe a
type IsectFunc k a b c = k -> a -> b -> Maybe c
type DiffFunc k a b = k -> a -> b -> Maybe a
-type ExtractFunc 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 @@ class Ord k => TrieKey k m | m -> k where
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 @@ class Ord k => TrieKey k m | m -> k where
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 @@ sides f (l, x, r) = (f l, x, f r)
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 (<=) (Just a) (Just b) = a <= b
subMaybe _ _ _ = False
aboutM :: (TrieKey k (TrieMap k), Alternative t) => (k -> a -> t z) -> TrieMap k a -> t z
-aboutM f = fst <.> extractM (const 0) (\ k a -> fmap (flip (,) Nothing) (f k a)) \ No newline at end of file
+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);
+ #-} \ No newline at end of file
diff --git a/Data/TrieMap/UnionMap.hs b/Data/TrieMap/UnionMap.hs
new file mode 100644
index 0000000..92fe59d
--- /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
+ \ No newline at end of file
diff --git a/Data/TrieMap/UnitMap.hs b/Data/TrieMap/UnitMap.hs
new file mode 100644
index 0000000..87ba187
--- /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 \ No newline at end of file
diff --git a/TrieMap.cabal b/TrieMap.cabal
index 81ac265..f8854d7 100644
--- 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 @@ other-modules:
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 @@ other-modules:
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,