#ifndef MIN_VERSION_containers
#define MIN_VERSION_containers(x,y,z) 1
#endif
#ifndef MIN_VERSION_lens
#define MIN_VERSION_lens(x,y,z) 1
#endif
module Data.Table
(
Table(..)
, Tabular(..)
, Tab(..)
, Key(..)
, makeTabular
, empty
, singleton
, table
, fromList
, unsafeFromList
, union
, difference
, intersection
, null
, count
, With(..)
, Withal(..)
, Group(..)
, insert
, insert'
, unsafeInsert
, delete
, rows
, Primary
, Candidate, CandidateInt, CandidateHash
, Supplemental, SupplementalInt, SupplementalHash
, Inverted, InvertedInt, InvertedHash
, Auto(..)
, autoKey
, auto
, autoIncrement
, IsKeyType(..)
, KeyType(..)
, AnIndex(..)
) where
import Control.Applicative hiding (empty)
import Control.Comonad
import Control.DeepSeq (NFData(rnf))
import Control.Lens hiding (anon)
import Control.Monad
import Control.Monad.Fix
import Data.Binary (Binary)
import qualified Data.Binary as B
import Data.Char (toUpper)
import Data.Data
import Data.Foldable as F hiding (foldl1)
import Data.Function (on)
import Data.Hashable
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.HashSet (HashSet)
import qualified Data.HashSet as HS
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import Data.IntSet (IntSet)
import qualified Data.IntSet as IS
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.SafeCopy (SafeCopy(..), safeGet, safePut, contain)
import Data.Serialize (Serialize)
import qualified Data.Serialize as C
import Data.Set (Set)
import qualified Data.Set as S
import Data.Traversable hiding (mapM)
import Language.Haskell.TH
import qualified Prelude as P
import Prelude hiding (null)
class Ord (PKT t) => Tabular (t :: *) where
type PKT t
data Tab t (m :: * -> * -> *)
data Key (k :: *) t :: * -> *
fetch :: Key k t a -> t -> a
primary :: Key Primary t (PKT t)
primarily :: Key Primary t a -> ((a ~ PKT t) => r) -> r
mkTab :: Applicative h => (forall k a. IsKeyType k a => Key k t a -> h (i k a)) -> h (Tab t i)
ixTab :: Tab t i -> Key k t a -> i k a
forTab :: Applicative h => Tab t i -> (forall k a . IsKeyType k a => Key k t a -> i k a -> h (j k a)) -> h (Tab t j)
autoTab :: t -> Maybe (Tab t (AnIndex t) -> t)
autoTab _ = Nothing
autoIncrement :: (Tabular t, Num (PKT t)) => ALens' t (PKT t) -> t -> Maybe (Tab t (AnIndex t) -> t)
autoIncrement pk t
| t ^# pk == 0 = Just $ \ tb -> t & pk #~ 1 + fromMaybe 0 (tb ^? primaryMap.traverseMax.asIndex)
| otherwise = Nothing
data AnIndex t k a where
PrimaryMap :: Map (PKT t) t -> AnIndex t Primary a
CandidateIntMap :: IntMap t -> AnIndex t CandidateInt Int
CandidateHashMap :: (Eq a, Hashable a) => HashMap a t -> AnIndex t CandidateHash a
CandidateMap :: Ord a => Map a t -> AnIndex t Candidate a
InvertedIntMap :: IntMap [t] -> AnIndex t InvertedInt IntSet
InvertedHashMap :: (Eq a, Hashable a) => HashMap a [t] -> AnIndex t InvertedHash (HashSet a)
InvertedMap :: Ord a => Map a [t] -> AnIndex t Inverted (Set a)
SupplementalIntMap :: IntMap [t] -> AnIndex t SupplementalInt Int
SupplementalHashMap :: (Eq a, Hashable a) => HashMap a [t] -> AnIndex t SupplementalHash a
SupplementalMap :: Ord a => Map a [t] -> AnIndex t Supplemental a
primaryMap :: Tabular t => Lens' (Tab t (AnIndex t)) (Map (PKT t) t)
primaryMap f t = case ixTab t primary of
PrimaryMap m -> f m <&> \u -> runIdentity $ forTab t $ \k o -> Identity $ case o of
PrimaryMap _ -> primarily k (PrimaryMap u)
_ -> o
data Table t where
EmptyTable :: Table t
Table :: Tabular t => Tab t (AnIndex t) -> Table t
deriving Typeable
instance (Tabular t, Data t) => Data (Table t) where
gfoldl f z im = z fromList `f` toList im
toConstr _ = fromListConstr
gunfold k z c = case constrIndex c of
1 -> k (z fromList)
_ -> error "gunfold"
dataTypeOf _ = tableDataType
dataCast1 f = gcast1 f
instance (Tabular t, Binary t) => Binary (Table t) where
put = reviews table B.put
get = view table <$> B.get
instance (Tabular t, Serialize t) => Serialize (Table t) where
put = reviews table C.put
get = view table <$> C.get
instance (Typeable t, Tabular t, SafeCopy t) => SafeCopy (Table t) where
putCopy = contain . reviews table safePut
getCopy = contain $ view table <$> safeGet
errorTypeName pt = show $ typeOf (undefined `asProxyTypeOf` pt)
where asProxyTypeOf :: a -> p a -> a
asProxyTypeOf a _ = a
fromListConstr :: Constr
fromListConstr = mkConstr tableDataType "fromList" [] Prefix
tableDataType :: DataType
tableDataType = mkDataType "Data.Table.Table" [fromListConstr]
instance Monoid (Table t) where
mempty = EmptyTable
EmptyTable `mappend` r = r
r `mappend` EmptyTable = r
r `mappend` s@Table{} = F.foldl' (flip insert) s r
instance Eq t => Eq (Table t) where
(==) = (==) `on` toList
instance Ord t => Ord (Table t) where
compare = compare `on` toList
instance Show t => Show (Table t) where
showsPrec d t = showParen (d > 10) $ showString "fromList " . showsPrec 11 (toList t)
instance (Tabular t, Read t) => Read (Table t) where
readsPrec d = readParen (d > 10) $ \r -> do
("fromList",s) <- lex r
(m, t) <- readsPrec 11 s
return (fromList m, t)
instance Foldable Table where
foldMap _ EmptyTable = mempty
foldMap f (Table m) = foldMapOf (primaryMap.folded) f m
type instance Index (Table t) = PKT t
type instance IxValue (Table t) = t
instance Ixed (Table t) where
ix _ _ EmptyTable = pure EmptyTable
ix k f (Table m) = Table <$> primaryMap (ix k f) m
instance Tabular t => At (Table t) where
at k f EmptyTable = maybe EmptyTable singleton <$> indexed f k Nothing
at k f (Table m) = Table <$> primaryMap (at k f) m
anon :: APrism' a () -> Iso' (Maybe a) a
anon p = iso (fromMaybe def) go where
def = review (clonePrism p) ()
go b | has (clonePrism p) b = Nothing
| otherwise = Just b
nil :: Prism' [a] ()
nil = prism' (const []) (guard . P.null)
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
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 nil %~ 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 ->
m & at ky . anon nil %~ let pys = fetch primary <$> ys in filter (\e -> fetch primary e `P.notElem` pys)
SupplementalHashMap idx -> SupplementalHashMap $ HM.foldlWithKey' ?? idx ?? HM.fromListWith (++) [ (fetch k t, [t]) | t <- ts ] $ \m ky ys ->
m & at ky . anon nil %~ 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 <- S.toList $ fetch k t ] $ \m ky ys ->
m & at ky . anon nil %~ 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 <- IS.toList $ fetch k t ] $ \m ky ys ->
m & at ky . anon nil %~ 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 <- HS.toList $ fetch k t ] $ \m ky ys ->
m & at ky . anon nil %~ let pys = fetch primary <$> ys in filter (\e -> fetch primary e `P.notElem` pys)
emptyTab :: Tabular t => Tab t (AnIndex t)
emptyTab = runIdentity $ mkTab $ \k -> Identity $ case keyType k of
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
makeTabular :: Name -> [(Name, Name)] -> Q [Dec]
makeTabular p ks = do
VarI _ (AppT (AppT ArrowT t) pkt) _ _ <- reify p
k <- VarT <$> newName "k"
a <- VarT <$> newName "a"
f <- newName "f"
tabName <- newName $ "Tab_" ++ nameBase p
let keys = (''Primary, p) : ks
keyCons@(pK:_) = map (uppercase.snd) keys
idiom, idiom' :: [Exp] -> Exp
idiom' = foldl1 (\l r -> AppE (AppE (VarE '(<*>)) l) r)
idiom [] = AppE (VarE 'pure) (ConE '())
idiom (x:xs) = idiom' $ AppE (VarE 'pure) x : xs
keyTypes <- map (\(VarI _ (AppT _ t) _ _) -> t) <$> mapM (reify . snd) keys
keyVars <- mapM (newName . nameBase . snd) keys
return [InstanceD [] (AppT (ConT ''Tabular) t)
[
#if MIN_VERSION_template_haskell(2,9,0)
TySynInstD ''PKT $ TySynEqn [t] pkt
#else
TySynInstD ''PKT [t] pkt
#endif
, DataInstD [] ''Key [k, t, a] (zipWith (\(kk,n) kt ->
ForallC [] [EqualP k (ConT kk), EqualP a kt]
(NormalC (uppercase n) [])) keys keyTypes) []
, DataInstD [] ''Tab [t, a] [NormalC tabName $ zipWith
(\(k,_) t -> (NotStrict, AppT (AppT a (ConT k)) t)) keys keyTypes] []
, FunD 'fetch $ map (\(_,k) ->
Clause [ConP (uppercase k) []] (NormalB (VarE k)) []) keys
, ValD (VarP 'primary) (NormalB (ConE pK)) []
, FunD 'primarily [Clause [ConP pK [], VarP f] (NormalB (VarE f)) []]
, FunD 'mkTab [Clause [VarP f]
( NormalB . idiom $ ConE tabName : map (AppE (VarE f) . ConE) keyCons
) []]
, FunD 'forTab [Clause [ConP tabName (map VarP keyVars), VarP f]
( NormalB . idiom $ ConE tabName : zipWith
(\c x -> AppE (AppE (VarE f) (ConE c)) (VarE x)) keyCons keyVars
) []]
, FunD 'ixTab [Clause [ConP tabName (map VarP keyVars), VarP f]
( NormalB . CaseE (VarE f) $ zipWith
(\c x -> Match (ConP c []) (NormalB $ VarE x) []) keyCons keyVars
) []]
]]
where uppercase :: Name -> Name
uppercase = iso nameBase mkName._head %~ toUpper
empty :: Table t
empty = EmptyTable
null :: Table t -> Bool
null EmptyTable = True
null (Table m) = M.null (m^.primaryMap)
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
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]
#if MIN_VERSION_containers(0,5,0)
Inverted -> InvertedMap $ M.fromSet (const [row]) (fetch k row)
InvertedInt -> InvertedIntMap $ IM.fromSet (const [row]) (fetch k row)
#else
Inverted -> InvertedMap $ M.fromDistinctAscList [ (e, [row]) | e <- S.toAscList (fetch k row) ]
InvertedInt -> InvertedIntMap $ IM.fromDistinctAscList [ (e, [row]) | e <- IS.toAscList (fetch k row) ]
#endif
InvertedHash -> InvertedHashMap $ HS.foldl' (\m k -> HM.insert k [row] m) HM.empty (fetch k 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)
CandidateHashMap idx -> idx^..ix (fetch k t)
_ -> []
delete :: t -> Table t -> Table t
delete t m = deleteCollisions m (collisions t m)
insert :: Tabular t => t -> Table t -> Table t
insert t r = snd $ insert' t r
insert' :: Tabular t => t -> Table t -> (t, Table t)
insert' t0 r = case autoTab t0 of
Just p -> case r of
EmptyTable -> go (p emptyTab)
Table m -> go (p m)
Nothing -> go t0
where
go t = (,) t $ unsafeInsert t (delete t r)
unsafeInsert :: Tabular t => t -> Table t -> Table t
unsafeInsert t r = case 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
CandidateHashMap idx -> CandidateHashMap $ idx & at (fetch k t) ?~ t
SupplementalMap idx -> SupplementalMap $ idx & at (fetch k t) . anon nil %~ (t:)
SupplementalIntMap idx -> SupplementalIntMap $ idx & at (fetch k t) . anon nil %~ (t:)
SupplementalHashMap idx -> SupplementalHashMap $ idx & at (fetch k t) . anon nil %~ (t:)
InvertedMap idx -> InvertedMap $ idx & flip (F.foldr $ \ik -> at ik . anon nil %~ (t:)) (fetch k t)
InvertedIntMap idx -> InvertedIntMap $ idx & flip (IS.foldr $ \ik -> at ik . anon nil %~ (t:)) (fetch k t)
InvertedHashMap idx -> InvertedHashMap $ idx & flip (F.foldr $ \ik -> at ik . anon nil %~ (t:)) (fetch k t)
count :: Table t -> Int
count EmptyTable = 0
count (Table m) = M.size (m^.primaryMap)
table :: Tabular t => Iso' [t] (Table t)
table = iso fromList toList
instance (Tabular b, PKT a ~ PKT b) => Each (Table a) (Table b) a b where
each _ EmptyTable = pure EmptyTable
each f r@Table{} = P.foldr insert empty <$> traverse f (toList r)
rows :: (Tabular t, PKT s ~ PKT t) => IndexedTraversal (PKT s) (Table s) (Table t) s t
rows _ EmptyTable = pure EmptyTable
rows f (Table m) = P.foldr insert empty <$> sequenceA (M.foldrWithKey (\i a r -> indexed f i a : r) [] $ m^.primaryMap)
class Group f q t i | q -> t i where
group :: Ord i => q -> IndexedLensLike' i f (Table t) (Table t)
instance Applicative f => Group f (t -> a) t a where
group _ _ EmptyTable = pure EmptyTable
group ky f (Table m) = traverse (\(k,vs) -> indexed f k (fromList vs)) (M.toList idx) <&> mconcat where
idx = M.fromListWith (++) (m^..primaryMap.folded.to(\v -> (ky v, [v])))
instance Applicative f => Group f (Key Primary t a) t a where
group _ _ EmptyTable = pure EmptyTable
group ky f (Table m) = case ixTab m ky of
PrimaryMap idx -> primarily ky $ for (toList idx) (\v -> indexed f (fetch primary v) (singleton v)) <&> mconcat
instance Applicative f => Group f (Key Candidate t a) t a where
group _ _ EmptyTable = pure EmptyTable
group ky f (Table m) = case ixTab m ky of
CandidateMap idx -> traverse (\(k,v) -> indexed f k (singleton v)) (M.toList idx) <&> mconcat
instance (Applicative f, a ~ Int) => Group f (Key CandidateInt t a) t a where
group _ _ EmptyTable = pure EmptyTable
group ky f (Table m) = case ixTab m ky of
CandidateIntMap idx -> traverse (\(k,v) -> indexed f k (singleton v)) (IM.toList idx) <&> mconcat
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
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
SupplementalMap idx -> traverse (\(k,vs) -> indexed f k (fromList vs)) (M.toList idx) <&> mconcat
instance (Applicative f, a ~ Int) => Group f (Key SupplementalInt t a) t a where
group _ _ EmptyTable = pure EmptyTable
group ky f (Table m) = case ixTab m ky of
SupplementalIntMap idx -> traverse (\(k,vs) -> indexed f k (fromList vs)) (IM.toList idx) <&> mconcat
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
instance (Applicative f, Gettable f) => Group f (Key Inverted t (Set a)) t a where
group _ _ EmptyTable = pure EmptyTable
group ky f (Table m) = case ixTab m ky of
InvertedMap idx -> coerce $ traverse (\(k,vs) -> indexed f k (fromList vs)) $ M.toList idx
instance (Applicative f, Gettable f, a ~ Int) => Group f (Key InvertedInt t IntSet) t a where
group _ _ EmptyTable = pure EmptyTable
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 (HashSet 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
class Withal q s t | q -> s t where
withAny :: q -> s -> Lens' (Table t) (Table t)
withAll ::q -> s -> Lens' (Table t) (Table t)
deleteWithAny :: q -> s -> Table t -> Table t
deleteWithAny p as t = set (withAny p as) empty t
deleteWithAll :: q -> s -> Table t -> Table t
deleteWithAll p as t = set (withAll p as) empty t
instance Ord a => Withal (t -> [a]) [a] t where
withAny _ _ f EmptyTable = f EmptyTable
withAny k as f r@(Table m) = go $ m^..primaryMap.folded.filtered (P.any (\e -> ss^.contains e) . k)
where go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
ss = S.fromList as
withAll _ _ f EmptyTable = f EmptyTable
withAll k as f r@(Table m) = go $ m^..primaryMap.folded.filtered (P.all (\e -> ss^.contains e) . k)
where go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
ss = S.fromList as
instance Ord a => Withal (Key Inverted t (Set a)) [a] t where
withAny _ _ f EmptyTable = f EmptyTable
withAny ky as f r@(Table m) = go $ case ixTab m ky of
InvertedMap idx -> as >>= \a -> idx^..ix a.folded
where go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
withAll _ _ f EmptyTable = f EmptyTable
withAll _ [] f r = f r
withAll ky (a:as) f r@(Table m) = case ixTab m ky of
InvertedMap 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 (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
instance Withal (Key InvertedInt t IntSet) [Int] t where
withAny _ _ f EmptyTable = f EmptyTable
withAny ky as f r@(Table m) = go $ case ixTab m ky of
InvertedIntMap idx -> as >>= \a -> idx^..ix a.folded
where go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
withAll _ _ f EmptyTable = f EmptyTable
withAll _ [] f r = f r
withAll ky (a:as) f r@(Table m) = case ixTab m ky of
InvertedIntMap 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 (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
instance (Eq a, Hashable a) =>Withal (Key InvertedHash t (HashSet a)) [a] 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 (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
withAll _ _ f EmptyTable = f EmptyTable
withAll _ [] f r = f r
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 (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
class With q t | q -> t where
with :: Ord a => q a -> (forall x. Ord x => x -> x -> Bool) -> a -> Lens' (Table t) (Table t)
deleteWith :: Ord a => q a -> (forall x. Ord x => x -> x -> Bool) -> a -> Table t -> Table t
deleteWith p cmp a t = set (with p cmp a) empty t
instance With ((->) t) t where
with _ _ _ f EmptyTable = f EmptyTable
with ky cmp a f r@(Table m)
| lt && eq && gt = f r
| lt || eq || gt = go $ m^..primaryMap.folded.filtered (\row -> cmp (ky row) a)
| otherwise = f EmptyTable <&> mappend r
where
lt = cmp LT EQ
eq = cmp EQ EQ
gt = cmp GT EQ
go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
instance With (Key Primary 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 = primarily ky $ go $ m^..primaryMap.ix a
| lt || eq || gt = primarily ky $ go $ case M.splitLookup a (m^.primaryMap) of
(l,e,g) -> (if lt then F.toList l else []) ++ (if eq then F.toList e else []) ++ (if gt then F.toList g else [])
| otherwise = f EmptyTable <&> mappend r
where
lt = cmp LT EQ
eq = cmp EQ EQ
gt = cmp GT EQ
go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
instance With (Key Candidate 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
CandidateMap idx -> go $ idx^..ix a
| lt || eq || gt = case ixTab m ky of
CandidateMap idx -> go $ case M.splitLookup a idx of
(l,e,g) -> (if lt then F.toList l else []) ++ (if eq then F.toList e else []) ++ (if gt then F.toList g else [])
| otherwise = f EmptyTable <&> mappend r
where
lt = cmp LT EQ
eq = cmp EQ EQ
gt = cmp GT EQ
go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
instance With (Key CandidateInt 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
CandidateIntMap idx -> go $ idx^..ix a
| lt || eq || gt = case ixTab m ky of
CandidateIntMap idx -> go $ case IM.splitLookup a idx of
(l,e,g) -> (if lt then F.toList l else []) ++ (if eq then F.toList e else []) ++ (if gt then F.toList g else [])
| otherwise = f EmptyTable <&> mappend r
where
lt = cmp LT EQ
eq = cmp EQ EQ
gt = cmp GT EQ
go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
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)
| otherwise = f EmptyTable <&> mappend r
where
lt = cmp LT EQ
eq = cmp EQ EQ
gt = cmp GT EQ
go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
instance With (Key Supplemental 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
SupplementalMap idx -> go $ idx^..ix a.folded
| lt || eq || gt = go $ case ixTab m ky of
SupplementalMap idx -> case M.splitLookup a idx of
(l,e,g) -> (if lt then F.concat l else []) ++ (if eq then F.concat e else []) ++ (if gt then F.concat g else [])
| otherwise = f EmptyTable <&> mappend r
where
lt = cmp LT EQ
eq = cmp EQ EQ
gt = cmp GT EQ
go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
instance With (Key SupplementalInt 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
SupplementalIntMap idx -> go $ idx^..ix a.folded
| lt || eq || gt = go $ case ixTab m ky of
SupplementalIntMap idx -> case IM.splitLookup a idx of
(l,e,g) -> (if lt then F.concat l else []) ++ (if eq then F.concat e else []) ++ (if gt then F.concat g else [])
| otherwise = f EmptyTable <&> mappend r
where
lt = cmp LT EQ
eq = cmp EQ EQ
gt = cmp GT EQ
go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
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
| 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)
| otherwise = f EmptyTable <&> mappend r
where
lt = cmp LT EQ
eq = cmp EQ EQ
gt = cmp GT EQ
go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs)
fromList :: Tabular t => [t] -> Table t
fromList = foldl' (flip insert) empty
unsafeFromList :: Tabular t => [t] -> Table t
unsafeFromList = foldl' (flip unsafeInsert) empty
union :: Table t -> Table t -> Table t
union = mappend
difference :: (Tabular t1, Tabular t2, PKT t1 ~ PKT t2) => Table t1 -> Table t2 -> Table t1
difference t1 t2 = deleteWithAny ((:[]) . fetch primary) (t2 ^.. each . to (fetch primary)) t1
intersection :: (Tabular t1, Tabular t2, PKT t1 ~ PKT t2) => Table t1 -> Table t2 -> Table t1
intersection t1 t2 = t1 ^. withAny ((:[]) . fetch primary) (t2 ^.. each . to (fetch primary))
data KeyType t a where
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 (Set a)
InvertedInt :: KeyType InvertedInt IntSet
InvertedHash :: (Eq a, Hashable a) => KeyType InvertedHash (HashSet a)
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
instance Ord a => IsKeyType Primary a where
keyType _ = Primary
instance Ord a => IsKeyType Candidate a where
keyType _ = Candidate
instance a ~ Int => IsKeyType CandidateInt a where
keyType _ = CandidateInt
instance (Eq a, Hashable a)=> IsKeyType CandidateHash a where
keyType _ = CandidateHash
instance Ord a => IsKeyType Supplemental a where
keyType _ = Supplemental
instance a ~ Int => IsKeyType SupplementalInt a where
keyType _ = SupplementalInt
instance (Eq a, Hashable a)=> IsKeyType SupplementalHash a where
keyType _ = SupplementalHash
instance (t ~ Set, Ord a) => IsKeyType Inverted (t a) where
keyType _ = Inverted
instance IsKeyType InvertedInt IntSet where
keyType _ = InvertedInt
instance (t ~ HashSet, Eq a, Hashable a) => IsKeyType InvertedHash (t a) where
keyType _ = InvertedHash
auto :: a -> Auto a
auto = Auto 0
instance Field1 (Auto a) (Auto a) Int Int where
_1 f (Auto k a) = indexed f (0 :: Int) k <&> \k' -> Auto k' a
instance Field2 (Auto a) (Auto b) a b where
_2 f (Auto k a) = indexed f (1 :: Int) a <&> Auto k
type instance Index (Auto a) = Int
instance (a ~ Int, b ~ Int) => Each (Auto a) (Auto b) a b where
each f (Auto k a) = Auto <$> f k <*> f a
data Auto a = Auto !Int a
deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable,Data,Typeable)
autoKey :: Lens' (Auto a) Int
autoKey f (Auto k a) = f k <&> \k' -> Auto k' a
instance FunctorWithIndex Int Auto where
imap f (Auto k a) = Auto k (f k a)
instance FoldableWithIndex Int Auto where
ifoldMap f (Auto k a) = f k a
instance TraversableWithIndex Int Auto where
itraverse f (Auto k a) = Auto k <$> f k a
instance Comonad Auto where
extract (Auto _ a) = a
extend f w@(Auto k _) = Auto k (f w)
instance Binary a => Binary (Auto a) where
put (Auto k a) = B.put k >> B.put a
get = Auto <$> B.get <*> B.get
instance Serialize a => Serialize (Auto a) where
put (Auto k a) = C.put k >> C.put a
get = Auto <$> C.get <*> C.get
instance SafeCopy a => SafeCopy (Auto a) where
getCopy = contain $ Auto <$> safeGet <*> safeGet
putCopy (Auto k a) = contain $ safePut k >> safePut a
instance Tabular (Auto a) where
type PKT (Auto a) = Int
data Tab (Auto a) i = AutoTab (i Primary Int)
data Key p (Auto a) b where
AutoKey :: Key Primary (Auto a) Int
fetch AutoKey (Auto k _) = k
primary = AutoKey
primarily AutoKey r = r
mkTab f = AutoTab <$> f AutoKey
ixTab (AutoTab x) AutoKey = x
forTab (AutoTab x) f = AutoTab <$> f AutoKey x
autoTab = autoIncrement autoKey
instance Ord k => Tabular (k,v) where
type PKT (k,v) = k
data Tab (k,v) i = KVTab (i Primary k)
data Key p (k,v) b where
Fst :: Key Primary (k,v) k
fetch Fst = fst
primary = Fst
primarily Fst r = r
mkTab f = KVTab <$> f Fst
ixTab (KVTab x) Fst = x
forTab (KVTab x) f = KVTab <$> f Fst x
instance Ord a => Tabular (Identity a) where
type PKT (Identity a) = a
data Tab (Identity a) i = IdentityTab (i Primary a)
data Key p (Identity a) b where
Id :: Key Primary (Identity a) a
fetch Id = extract
primary = Id
primarily Id r = r
mkTab f = IdentityTab <$> f Id
ixTab (IdentityTab x) Id = x
forTab (IdentityTab x) f = IdentityTab <$> f Id x
instance Field1 (Value a) (Value b) a b where
_1 f (Value a) = Value <$> indexed f (0 :: Int) a
type instance Index (Value a) = ()
type instance IxValue (Value a) = a
instance Each (Value a) (Value b) a b where
each f (Value a) = Value <$> f a
instance Ixed (Value a) where
ix () pafb (Value a) = Value <$> indexed pafb () a
instance Wrapped (Value a) where
type Unwrapped (Value a) = a
_Wrapped' = iso (\(Value a) -> a) Value
data Value a = Value a
deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable,Data,Typeable)
instance Applicative Value where
pure = Value
Value f <*> Value a = Value (f a)
instance Monad Value where
return = Value
Value a >>= f = f a
instance MonadFix Value where
mfix f = let m = f (extract m) in m
instance Comonad Value where
extract (Value a) = a
extend f w@(Value _) = Value (f w)
instance ComonadApply Value where
Value f <@> Value a = Value (f a)
instance Ord a => Tabular (Value a) where
type PKT (Value a) = a
data Tab (Value a) i = ValueTab (i Primary a)
data Key p (Value a) b where
Val :: Key Primary (Value a) a
fetch Val = extract
primary = Val
primarily Val r = r
mkTab f = ValueTab <$> f Val
ixTab (ValueTab x) Val = x
forTab (ValueTab x) f = ValueTab <$> f Val x
instance (Tabular a, NFData a, NFData (Tab a (AnIndex a))) => NFData (Table a) where
rnf (Table tab) = rnf tab
rnf EmptyTable = ()
instance (NFData t, NFData a, NFData (PKT t)) => NFData (AnIndex t Primary a) where
rnf (PrimaryMap m) = rnf m
instance (NFData t, NFData a, NFData (PKT t)) => NFData (AnIndex t Supplemental a) where
rnf (SupplementalMap m) = rnf m
instance (NFData t, NFData (PKT t)) => NFData (AnIndex t SupplementalInt Int) where
rnf (SupplementalIntMap m) = rnf m
instance (NFData t, NFData a, NFData (PKT t)) => NFData (AnIndex t SupplementalHash a) where
rnf (SupplementalHashMap m) = rnf m
instance (NFData t, NFData a, NFData (PKT t)) => NFData (AnIndex t Candidate a) where
rnf (CandidateMap m) = rnf m
instance (NFData t, NFData (PKT t)) => NFData (AnIndex t CandidateInt Int) where
rnf (CandidateIntMap m) = rnf m
instance (NFData t, NFData a, NFData (PKT t)) => NFData (AnIndex t CandidateHash a) where
rnf (CandidateHashMap m) = rnf m
instance (NFData t, NFData (PKT t)) => NFData (AnIndex t InvertedInt IntSet) where
rnf (InvertedIntMap m) = rnf m
instance (NFData t, NFData a, NFData (PKT t)) => NFData (AnIndex t Inverted (Set a)) where
rnf (InvertedMap m) = rnf m
instance (NFData t, NFData a, NFData (PKT t)) => NFData (AnIndex t InvertedHash (HashSet a)) where
rnf (InvertedHashMap m) = rnf m