Permalink
Browse files

Added support for HashMap-based Candidate, Supplemental and Inverted …

…indices
  • Loading branch information...
1 parent dc34e58 commit bc0cb76f97b33e29036b7b000fc0f685f5b25555 @ekmett committed Dec 29, 2012
Showing with 146 additions and 46 deletions.
  1. +145 −46 src/Data/Table.hs
  2. +1 −0 tables.cabal
View
191 src/Data/Table.hs
@@ -76,6 +76,9 @@ import Data.Data
import Data.Foldable as F
import Data.Function (on)
import Data.Functor.Identity
+import Data.Hashable
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import Data.Map (Map)
@@ -140,13 +143,16 @@ autoIncrement pk t
-- | This is used to store a single index.
data Index t k a where
- PrimaryMap :: Map (PKT t) t -> Index t Primary a
- CandidateMap :: Ord a => Map a t -> Index t Candidate a
- CandidateIntMap :: IntMap t -> Index t CandidateInt Int
- SupplementalMap :: Ord a => Map a [t] -> Index t Supplemental a
- SupplementalIntMap :: IntMap [t] -> Index t SupplementalInt Int
- InvertedMap :: Ord a => Map a [t] -> Index t Inverted [a]
- InvertedIntMap :: IntMap [t] -> Index t InvertedInt [Int]
+ PrimaryMap :: Map (PKT t) t -> Index t Primary a
+ CandidateIntMap :: IntMap t -> Index t CandidateInt Int
+ CandidateHashMap :: (Eq a, Hashable a) => HashMap a t -> Index t CandidateHash a
+ CandidateMap :: Ord a => Map a t -> Index t Candidate a
+ InvertedIntMap :: IntMap [t] -> Index t InvertedInt [Int]
+ InvertedHashMap :: (Eq a, Hashable a) => HashMap a [t] -> Index t InvertedHash [a]
+ InvertedMap :: Ord a => Map a [t] -> Index t Inverted [a]
+ SupplementalIntMap :: IntMap [t] -> Index t SupplementalInt Int
+ SupplementalHashMap :: (Eq a, Hashable a) => HashMap a [t] -> Index t SupplementalHash a
+ SupplementalMap :: Ord a => Map a [t] -> Index t Supplemental a
-- | Find the primary key index a tab
primaryMap :: Tabular t => Lens' (Tab t (Index t)) (Map (PKT t) t)
@@ -231,29 +237,37 @@ instance Tabular t => At (Table t) where
deleteCollisions :: Table t -> [t] -> Table t
deleteCollisions EmptyTable _ = EmptyTable
deleteCollisions (Table tab) ts = Table $ runIdentity $ forTab tab $ \k i -> Identity $ case i of
- PrimaryMap idx -> PrimaryMap $ primarily k $ F.foldl' (flip (M.delete . fetch primary)) idx ts
- CandidateMap idx -> CandidateMap $ F.foldl' (flip (M.delete . fetch k)) idx ts
- CandidateIntMap idx -> CandidateIntMap $ F.foldl' (flip (IM.delete . fetch k)) idx ts
- SupplementalMap idx -> SupplementalMap $ M.foldlWithKey' ?? idx ?? M.fromListWith (++) [ (fetch k t, [t]) | t <- ts ] $ \m ky ys ->
+ PrimaryMap idx -> PrimaryMap $ primarily k $ F.foldl' (flip (M.delete . fetch primary)) idx ts
+ CandidateMap idx -> CandidateMap $ F.foldl' (flip (M.delete . fetch k)) idx ts
+ CandidateIntMap idx -> CandidateIntMap $ F.foldl' (flip (IM.delete . fetch k)) idx ts
+ CandidateHashMap idx -> CandidateHashMap $ F.foldl' (flip (HM.delete . fetch k)) idx ts
+ SupplementalMap idx -> SupplementalMap $ M.foldlWithKey' ?? idx ?? M.fromListWith (++) [ (fetch k t, [t]) | t <- ts ] $ \m ky ys ->
m & at ky . anon [] P.null %~ let pys = fetch primary <$> ys in filter (\e -> fetch primary e `P.notElem` pys)
- SupplementalIntMap idx -> SupplementalIntMap $ IM.foldlWithKey' ?? idx ?? IM.fromListWith (++) [ (fetch k t, [t]) | t <- ts ] $ \m ky ys ->
+ SupplementalIntMap idx -> SupplementalIntMap $ IM.foldlWithKey' ?? idx ?? IM.fromListWith (++) [ (fetch k t, [t]) | t <- ts ] $ \m ky ys ->
m & at ky . anon [] P.null %~ let pys = fetch primary <$> ys in filter (\e -> fetch primary e `P.notElem` pys)
- InvertedMap idx -> InvertedMap $ M.foldlWithKey' ?? idx ?? M.fromListWith (++) [ (f, [t]) | t <- ts, f <- fetch k t ] $ \m ky ys ->
+ SupplementalHashMap idx -> SupplementalHashMap $ HM.foldlWithKey' ?? idx ?? HM.fromListWith (++) [ (fetch k t, [t]) | t <- ts ] $ \m ky ys ->
m & at ky . anon [] P.null %~ let pys = fetch primary <$> ys in filter (\e -> fetch primary e `P.notElem` pys)
- InvertedIntMap idx -> InvertedIntMap $ M.foldlWithKey' ?? idx ?? M.fromListWith (++) [ (f, [t]) | t <- ts, f <- fetch k t ] $ \m ky ys ->
+ InvertedMap idx -> InvertedMap $ M.foldlWithKey' ?? idx ?? M.fromListWith (++) [ (f, [t]) | t <- ts, f <- fetch k t ] $ \m ky ys ->
+ m & at ky . anon [] P.null %~ let pys = fetch primary <$> ys in filter (\e -> fetch primary e `P.notElem` pys)
+ InvertedIntMap idx -> InvertedIntMap $ IM.foldlWithKey' ?? idx ?? IM.fromListWith (++) [ (f, [t]) | t <- ts, f <- fetch k t ] $ \m ky ys ->
+ m & at ky . anon [] P.null %~ let pys = fetch primary <$> ys in filter (\e -> fetch primary e `P.notElem` pys)
+ InvertedHashMap idx -> InvertedHashMap $ HM.foldlWithKey' ?? idx ?? HM.fromListWith (++) [ (f, [t]) | t <- ts, f <- fetch k t ] $ \m ky ys ->
m & at ky . anon [] P.null %~ let pys = fetch primary <$> ys in filter (\e -> fetch primary e `P.notElem` pys)
{-# INLINE deleteCollisions #-}
emptyTab :: Tabular t => Tab t (Index t)
emptyTab = runIdentity $ mkTab $ \k -> Identity $ case keyType k of
- Primary -> primarily k (PrimaryMap M.empty)
- Candidate -> CandidateMap M.empty
- Supplemental -> SupplementalMap M.empty
- Inverted -> InvertedMap M.empty
- CandidateInt -> CandidateIntMap IM.empty
- SupplementalInt -> SupplementalIntMap IM.empty
- InvertedInt -> InvertedIntMap IM.empty
+ Primary -> primarily k (PrimaryMap M.empty)
+ Candidate -> CandidateMap M.empty
+ CandidateHash -> CandidateHashMap HM.empty
+ CandidateInt -> CandidateIntMap IM.empty
+ Inverted -> InvertedMap M.empty
+ InvertedHash -> InvertedHashMap HM.empty
+ InvertedInt -> InvertedIntMap IM.empty
+ Supplemental -> SupplementalMap M.empty
+ SupplementalHash -> SupplementalHashMap HM.empty
+ SupplementalInt -> SupplementalIntMap IM.empty
{-# INLINE emptyTab #-}
-- * Public API
@@ -272,22 +286,26 @@ null (Table m) = M.null (m^.primaryMap)
-- | Construct a relation with a single row
singleton :: Tabular t => t -> Table t
singleton row = Table $ runIdentity $ mkTab $ \ k -> Identity $ case keyType k of
- Primary -> primarily k $ PrimaryMap $ M.singleton (fetch k row) row
- Candidate -> CandidateMap $ M.singleton (fetch k row) row
- CandidateInt -> CandidateIntMap $ IM.singleton (fetch k row) row
- Supplemental -> SupplementalMap $ M.singleton (fetch k row) [row]
- SupplementalInt -> SupplementalIntMap $ IM.singleton (fetch k row) [row]
- Inverted -> InvertedMap $ M.fromList $ zip (fetch k row) (repeat [row])
- InvertedInt -> InvertedIntMap $ IM.fromList $ zip (fetch k row) (repeat [row])
+ Primary -> primarily k $ PrimaryMap $ M.singleton (fetch k row) row
+ Candidate -> CandidateMap $ M.singleton (fetch k row) row
+ CandidateInt -> CandidateIntMap $ IM.singleton (fetch k row) row
+ CandidateHash -> CandidateHashMap $ HM.singleton (fetch k row) row
+ Supplemental -> SupplementalMap $ M.singleton (fetch k row) [row]
+ SupplementalInt -> SupplementalIntMap $ IM.singleton (fetch k row) [row]
+ SupplementalHash -> SupplementalHashMap $ HM.singleton (fetch k row) [row]
+ Inverted -> InvertedMap $ M.fromList $ zip (fetch k row) (repeat [row])
+ InvertedInt -> InvertedIntMap $ IM.fromList $ zip (fetch k row) (repeat [row])
+ InvertedHash -> InvertedHashMap $ HM.fromList $ zip (fetch k row) (repeat [row])
{-# INLINE singleton #-}
-- | Return the set of rows that would be delete by deleting or inserting this row
collisions :: t -> Table t -> [t]
collisions _ EmptyTable = []
collisions t (Table m) = getConst $ forTab m $ \k i -> Const $ case i of
- PrimaryMap idx -> primarily k $ idx^..ix (fetch k t)
- CandidateMap idx -> idx^..ix (fetch k t)
- CandidateIntMap idx -> idx^..ix (fetch k t)
+ PrimaryMap idx -> primarily k $ idx^..ix (fetch k t)
+ CandidateMap idx -> idx^..ix (fetch k t)
+ CandidateIntMap idx -> idx^..ix (fetch k t)
+ CandidateHashMap idx -> idx^..ix (fetch k t)
_ -> []
{-# INLINE collisions #-}
@@ -308,13 +326,16 @@ insert t0 r = case autoTab t0 of
go t = case delete t r of
EmptyTable -> singleton t
Table m -> Table $ runIdentity $ forTab m $ \k i -> Identity $ case i of
- PrimaryMap idx -> primarily k $ PrimaryMap $ idx & at (fetch k t) ?~ t
- CandidateMap idx -> CandidateMap $ idx & at (fetch k t) ?~ t
- CandidateIntMap idx -> CandidateIntMap $ idx & at (fetch k t) ?~ t
- SupplementalMap idx -> SupplementalMap $ idx & at (fetch k t) . anon [] P.null %~ (t:)
- SupplementalIntMap idx -> SupplementalIntMap $ idx & at (fetch k t) . anon [] P.null %~ (t:)
- InvertedMap idx -> InvertedMap $ idx & flip (F.foldr $ \ik -> at ik . anon [] P.null %~ (t:)) (fetch k t)
- InvertedIntMap idx -> InvertedIntMap $ idx & flip (F.foldr $ \ik -> at ik . anon [] P.null %~ (t:)) (fetch k t)
+ PrimaryMap idx -> primarily k $ PrimaryMap $ idx & at (fetch k t) ?~ t
+ CandidateMap idx -> CandidateMap $ idx & at (fetch k t) ?~ t
+ CandidateIntMap idx -> CandidateIntMap $ idx & at (fetch k t) ?~ t
+ CandidateHashMap idx -> CandidateHashMap $ idx & at (fetch k t) ?~ t
+ SupplementalMap idx -> SupplementalMap $ idx & at (fetch k t) . anon [] P.null %~ (t:)
+ SupplementalIntMap idx -> SupplementalIntMap $ idx & at (fetch k t) . anon [] P.null %~ (t:)
+ SupplementalHashMap idx -> SupplementalHashMap $ idx & at (fetch k t) . anon [] P.null %~ (t:)
+ InvertedMap idx -> InvertedMap $ idx & flip (F.foldr $ \ik -> at ik . anon [] P.null %~ (t:)) (fetch k t)
+ InvertedIntMap idx -> InvertedIntMap $ idx & flip (F.foldr $ \ik -> at ik . anon [] P.null %~ (t:)) (fetch k t)
+ InvertedHashMap idx -> InvertedHashMap $ idx & flip (F.foldr $ \ik -> at ik . anon [] P.null %~ (t:)) (fetch k t)
{-# INLINE go #-}
{-# INLINE insert #-}
@@ -380,6 +401,12 @@ instance (Applicative f, a ~ Int) => Group f (Key CandidateInt t a) t a where
CandidateIntMap idx -> traverse (\(k,v) -> indexed f k (singleton v)) (IM.toList idx) <&> mconcat
{-# INLINE group #-}
+instance Applicative f => Group f (Key CandidateHash t a) t a where
+ group _ _ EmptyTable = pure EmptyTable
+ group ky f (Table m) = case ixTab m ky of
+ CandidateHashMap idx -> traverse (\(k,v) -> indexed f k (singleton v)) (HM.toList idx) <&> mconcat
+ {-# INLINE group #-}
+
instance Applicative f => Group f (Key Supplemental t a) t a where
group _ _ EmptyTable = pure EmptyTable
group ky f (Table m) = case ixTab m ky of
@@ -392,6 +419,12 @@ instance (Applicative f, a ~ Int) => Group f (Key SupplementalInt t a) t a where
SupplementalIntMap idx -> traverse (\(k,vs) -> indexed f k (fromList vs)) (IM.toList idx) <&> mconcat
{-# INLINE group #-}
+instance Applicative f => Group f (Key SupplementalHash t a) t a where
+ group _ _ EmptyTable = pure EmptyTable
+ group ky f (Table m) = case ixTab m ky of
+ SupplementalHashMap idx -> traverse (\(k,vs) -> indexed f k (fromList vs)) (HM.toList idx) <&> mconcat
+ {-# INLINE group #-}
+
instance (Applicative f, Gettable f) => Group f (Key Inverted t [a]) t a where
group _ _ EmptyTable = pure EmptyTable
group ky f (Table m) = case ixTab m ky of
@@ -402,6 +435,11 @@ instance (Applicative f, Gettable f, a ~ Int) => Group f (Key InvertedInt t [a])
group ky f (Table m) = case ixTab m ky of
InvertedIntMap idx -> coerce $ traverse (\(k,vs) -> indexed f k (fromList vs)) $ IM.toList idx
+instance (Applicative f, Gettable f) => Group f (Key InvertedHash t [a]) t a where
+ group _ _ EmptyTable = pure EmptyTable
+ group ky f (Table m) = case ixTab m ky of
+ InvertedHashMap idx -> coerce $ traverse (\(k,vs) -> indexed f k (fromList vs)) $ HM.toList idx
+
-- | Search inverted indices
class Withal q t | q -> t where
withAny :: Ord a => q [a] -> [a] -> Lens' (Table t) (Table t)
@@ -458,6 +496,22 @@ instance Withal (Key InvertedInt t) t where
where go xs = f (xs^.table) <&> mappend (deleteCollisions r xs)
{-# INLINE withAll #-}
+instance Withal (Key InvertedHash t) t where
+ withAny _ _ f EmptyTable = f EmptyTable
+ withAny ky as f r@(Table m) = go $ case ixTab m ky of
+ InvertedHashMap idx -> as >>= \a -> idx^..ix a.folded
+ where go xs = f (xs^.table) <&> mappend (deleteCollisions r xs)
+ {-# INLINE withAny #-}
+
+ withAll _ _ f EmptyTable = f EmptyTable
+ withAll _ [] f r = f r -- every row has all of an empty list of keywords
+ withAll ky (a:as) f r@(Table m) = case ixTab m ky of
+ InvertedHashMap idx -> let mkm c = M.fromList [ (fetch primary v, v) | v <- idx^..ix c.folded ]
+ in go $ F.toList $ F.foldl' (\r -> M.intersection r . mkm) (mkm a) as
+ where go xs = f (xs^.table) <&> mappend (deleteCollisions r xs)
+ {-# INLINE withAll #-}
+
+
class With q t | q -> t where
-- | Select a smaller, updateable subset of the rows of a table using an index or an arbitrary function.
with :: Ord a => q a -> (forall x. Ord x => x -> x -> Bool) -> a -> Lens' (Table t) (Table t)
@@ -531,6 +585,20 @@ instance With (Key CandidateInt t) t where
go xs = f (xs^.table) <&> mappend (deleteCollisions r xs)
{-# INLINE with #-}
+instance With (Key CandidateHash t) t where
+ with _ _ _ f EmptyTable = f EmptyTable
+ with ky cmp a f r@(Table m)
+ | lt && eq && gt = f r
+ | not lt && eq && not gt = case ixTab m ky of CandidateHashMap idx -> go $ idx^..ix a
+ | lt || eq || gt = go $ m^..primaryMap.folded.filtered (\row -> cmp (fetch ky row) a) -- table scan
+ | otherwise = f EmptyTable <&> mappend r -- no match
+ where
+ lt = cmp LT EQ
+ eq = cmp EQ EQ
+ gt = cmp GT EQ
+ go xs = f (xs^.table) <&> mappend (deleteCollisions r xs)
+ {-# INLINE with #-}
+
instance With (Key Supplemental t) t where
with _ _ _ f EmptyTable = f EmptyTable
with ky cmp a f r@(Table m)
@@ -565,6 +633,20 @@ instance With (Key SupplementalInt t) t where
go xs = f (xs^.table) <&> mappend (deleteCollisions r xs)
{-# INLINE with #-}
+instance With (Key SupplementalHash t) t where
+ with _ _ _ f EmptyTable = f EmptyTable
+ with ky cmp a f r@(Table m)
+ | lt && eq && gt = f r -- all rows
+ | not lt && eq && not gt = case ixTab m ky of SupplementalHashMap idx -> go $ idx^..ix a.folded
+ | lt || eq || gt = go $ m^..primaryMap.folded.filtered (\row -> cmp (fetch ky row) a) -- table scan
+ | otherwise = f EmptyTable <&> mappend r -- no match
+ where
+ lt = cmp LT EQ
+ eq = cmp EQ EQ
+ gt = cmp GT EQ
+ go xs = f (xs^.table) <&> mappend (deleteCollisions r xs)
+ {-# INLINE with #-}
+
-- | Build up a table from a list
fromList :: Tabular t => [t] -> Table t
fromList = foldl' (flip insert) empty
@@ -574,22 +656,28 @@ fromList = foldl' (flip insert) empty
-- | Value-level key types
data KeyType t a where
- Primary :: Ord a => KeyType Primary a
- Candidate :: Ord a => KeyType Candidate a
- CandidateInt :: KeyType CandidateInt Int
- Supplemental :: Ord a => KeyType Supplemental a
- SupplementalInt :: KeyType SupplementalInt Int
- Inverted :: Ord a => KeyType Inverted [a]
- InvertedInt :: KeyType InvertedInt [Int]
+ Primary :: Ord a => KeyType Primary a
+ Candidate :: Ord a => KeyType Candidate a
+ CandidateInt :: KeyType CandidateInt Int
+ CandidateHash :: (Eq a, Hashable a) => KeyType CandidateHash a
+ Supplemental :: Ord a => KeyType Supplemental a
+ SupplementalInt :: KeyType SupplementalInt Int
+ SupplementalHash :: (Eq a, Hashable a) => KeyType SupplementalHash a
+ Inverted :: Ord a => KeyType Inverted [a]
+ InvertedInt :: KeyType InvertedInt [Int]
+ InvertedHash :: (Eq a, Hashable a) => KeyType InvertedHash [a]
-- | Type level key types
data Primary
data Candidate
data CandidateInt
+data CandidateHash
data Supplemental
data SupplementalInt
+data SupplementalHash
data Inverted
data InvertedInt
+data InvertedHash
class IsKeyType k a where
keyType :: Key k t a -> KeyType k a
@@ -606,6 +694,10 @@ instance a ~ Int => IsKeyType CandidateInt a where
keyType _ = CandidateInt
{-# INLINE keyType #-}
+instance (Eq a, Hashable a)=> IsKeyType CandidateHash a where
+ keyType _ = CandidateHash
+ {-# INLINE keyType #-}
+
instance Ord a => IsKeyType Supplemental a where
keyType _ = Supplemental
{-# INLINE keyType #-}
@@ -614,6 +706,10 @@ instance a ~ Int => IsKeyType SupplementalInt a where
keyType _ = SupplementalInt
{-# INLINE keyType #-}
+instance (Eq a, Hashable a)=> IsKeyType SupplementalHash a where
+ keyType _ = SupplementalHash
+ {-# INLINE keyType #-}
+
instance Ord a => IsKeyType Inverted [a] where
keyType _ = Inverted
{-# INLINE keyType #-}
@@ -622,6 +718,10 @@ instance a ~ [Int] => IsKeyType InvertedInt a where
keyType _ = InvertedInt
{-# INLINE keyType #-}
+instance (Eq a, Hashable a)=> IsKeyType InvertedHash [a] where
+ keyType _ = InvertedHash
+ {-# INLINE keyType #-}
+
class HasValue p q f s t a b | s -> a, t -> b, s b -> t, t a -> s where
value :: Overloading p q f s t a b
@@ -684,7 +784,6 @@ instance Tabular (Auto a) where
instance (Indexable k p, q ~ (->), Functor f) => HasValue p q f (k, a) (k, b) a b where
value f (k, a) = indexed f k a <&> (,) k
-
-- | Simple (key, value) pairs
instance Ord k => Tabular (k,v) where
type PKT (k,v) = k
View
1 tables.cabal
@@ -42,6 +42,7 @@ library
base >= 4.3 && < 5,
comonad == 3.0.*,
containers >= 0.4.0 && < 0.6,
+ hashable >= 1.1 && < 1.3,
lens >= 3.8 && < 3.9,
profunctors >= 3.1.1 && < 3.2,
transformers >= 0.2 && < 0.4,

0 comments on commit bc0cb76

Please sign in to comment.