diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,24 +1,46 @@ language: haskell -before_install: - # Uncomment whenever hackage is down. - # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update - # grab lens 3.8 +env: + - GHCVER=7.4.2 + - GHCVER=7.6.3 + +before_install: + # Grab lens 4.0 - git clone https://github.com/ekmett/lens.git + # If $GHCVER is the one travis has, don't bother reinstalling it. + # We can also have faster builds by installing some libraries with + # `apt`. If it isn't, install the GHC we want from hvr's PPA along + # with cabal-1.18. + - | + if [ $GHCVER = `ghc --numeric-version` ]; then + # Try installing some of the build-deps with apt-get for speed. + cd lens + travis/cabal-apt-install $MODE + cd .. + export CABAL=cabal + else + # Install the GHC we want from hvr's PPA + sudo add-apt-repository -y ppa:hvr/ghc + sudo apt-get update + sudo apt-get install cabal-install-1.18 ghc-$GHCVER + export CABAL=cabal-1.18 + export PATH=/opt/ghc/$GHCVER/bin:$PATH + fi + # Uncomment whenever hackage is down. + # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && $CABAL update + - $CABAL update + # Install the rest of lens' dependencies and build it. - cd lens - - travis/cabal-apt-install --only-dependencies --force-reinstall - cabal install - cd .. - # Try installing some of the build-deps with apt-get for speed. - - travis/cabal-apt-install --only-dependencies --force-reinstall $mode - install: - - cabal configure $mode - - cabal build + - $CABAL install --dependencies-only --enable-tests + - $CABAL configure -flib-Werror --enable-tests $MODE script: - - $script + - $CABAL build + - $CABAL test --show-details=always notifications: irc: @@ -27,6 +49,3 @@ skip_join: true template: - "\x0313tables\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" - -env: - - mode="--enable-tests" script="cabal test --show-details=always" diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ Tables ====== -[![Build Status](https://secure.travis-ci.org/lens/tables.png?branch=master)](http://travis-ci.org/lens/tables) +[![Build Status](https://secure.travis-ci.org/ekmett/tables.png?branch=master)](http://travis-ci.org/ekmett/tables) This package provides simple in memory data tables with multiple indices. diff --git a/examples/Graph.hs b/examples/Graph.hs new file mode 100644 --- /dev/null +++ b/examples/Graph.hs @@ -0,0 +1,52 @@ +{-# Language TemplateHaskell #-} +{-# Language TypeFamilies #-} +{-# Language GADTs #-} +{-# Language GeneralizedNewtypeDeriving #-} +{-# Language RankNTypes #-} +-- base +import Control.Applicative +-- containers +import Data.Set (Set) +import qualified Data.Set as S +-- lens +import Control.Lens +-- tables +import Data.Table + +data Node = Node + { _name :: Int + , _arcs :: Set Int + } deriving (Show) +makeLenses ''Node + +instance Tabular Node where + type PKT Node = Int + data Key k Node b where + Key :: Key Primary Node Int + Arcs :: Key Inverted Node (Set Int) + data Tab Node i = NTab (i Primary Int) + (i Inverted (Set Int)) + fetch Key = _name + fetch Arcs = _arcs + primary = Key + primarily Key r = r + mkTab f = NTab <$> f Key <*> f Arcs + forTab (NTab i s) f = NTab <$> f Key i <*> f Arcs s + ixTab (NTab i _) Key = i + ixTab (NTab _ s) Arcs = s + +main :: IO () +main = do + -- Make a lot of graph nodes. + let t = fromList + [ Node 1 (S.fromList [1, 2, 3]) + , Node 2 (S.fromList [1, 2, 3]) + , Node 3 (S.fromList [1, 2]) + , Node 4 (S.fromList [5]) + , Node 5 (S.fromList [4]) + , Node 6 (S.fromList [3]) + ] + -- Print the names of all the nodes pointing to #3. + print $ t ^.. withAny Arcs [3] . folded . name + -- Print the names of all the nodes pointing to both #1 and #2. + print $ t ^.. withAll Arcs [1, 2] . folded . name diff --git a/src/Data/Table.hs b/src/Data/Table.hs --- a/src/Data/Table.hs +++ b/src/Data/Table.hs @@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE EmptyDataDecls #-} @@ -20,6 +21,9 @@ #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 @@ -40,11 +44,18 @@ , Tabular(..) , Tab(..) , Key(..) + -- ** Template Haskell helpers + , makeTabular -- ** Table Construction , empty , singleton , table , fromList + , unsafeFromList + -- ** Combining Tables + , union + , difference + , intersection -- ** Reading and Writing , null , count @@ -53,9 +64,18 @@ , Group(..) , insert , insert' + , unsafeInsert , delete , rows - , rows' + -- * Key Types + -- ** Primary Keys + , Primary + -- ** Candidate Keys + , Candidate, CandidateInt, CandidateHash + -- ** Supplemental Keys + , Supplemental, SupplementalInt, SupplementalHash + -- ** Inverted Keys + , Inverted, InvertedInt, InvertedHash -- * Esoterica , Auto(..) , autoKey @@ -64,24 +84,21 @@ -- * Implementation Details , IsKeyType(..) , KeyType(..) - , Primary - , Candidate, CandidateInt, CandidateHash - , Supplemental, SupplementalInt, SupplementalHash - , Inverted, InvertedInt, InvertedHash , 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 +import Data.Foldable as F hiding (foldl1) import Data.Function (on) -import Data.Functor.Identity import Data.Hashable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM @@ -100,7 +117,8 @@ import qualified Data.Serialize as C import Data.Set (Set) import qualified Data.Set as S -import Data.Traversable +import Data.Traversable hiding (mapM) +import Language.Haskell.TH import qualified Prelude as P import Prelude hiding (null) @@ -225,7 +243,7 @@ EmptyTable `mappend` r = r r `mappend` EmptyTable = r - r@Table{} `mappend` s = F.foldl' (flip insert) r s + r `mappend` s@Table{} = F.foldl' (flip insert) s r {-# INLINE mappend #-} instance Eq t => Eq (Table t) where @@ -253,11 +271,7 @@ type instance Index (Table t) = PKT t type instance IxValue (Table t) = t -instance Gettable f => Contains f (Table t) where - contains k f EmptyTable = coerce $ indexed f k False - contains k f (Table m) = Table <$> primaryMap (contains k f) m - -instance Applicative f => Ixed f (Table t) where +instance Ixed (Table t) where ix _ _ EmptyTable = pure EmptyTable ix k f (Table m) = Table <$> primaryMap (ix k f) m {-# INLINE ix #-} @@ -297,7 +311,6 @@ 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) - {-# INLINE deleteCollisions #-} emptyTab :: Tabular t => Tab t (AnIndex t) @@ -316,6 +329,75 @@ -- * Public API +-- | Generate a Tabular instance for a data type. Currently, this only +-- works for types which have no type variables, and won't generate autoTab. +-- +-- @ +-- data Foo = Foo { fooId :: Int, fooBar :: String, fooBaz :: Double } +-- +-- makeTabular 'fooId [(''Candidate, 'fooBaz), (''Supplemental, 'fooBar)] +-- @ +makeTabular :: Name -> [(Name, Name)] -> Q [Dec] +makeTabular p ks = do + -- Get the type name and PKT from the primary selector + -- FIXME: Work for more flexible type names + VarI _ (AppT (AppT ArrowT t) pkt) _ _ <- reify p + + + -- Locally used variable names + 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 + + -- FIXME: Work for more flexible type names + keyTypes <- map (\(VarI _ (AppT _ t) _ _) -> t) <$> mapM (reify . snd) keys + keyVars <- mapM (newName . nameBase . snd) keys + + return [InstanceD [] (AppT (ConT ''Tabular) t) + [ TySynInstD ''PKT [t] pkt + + , 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 + -- | Construct an empty relation empty :: Table t empty = EmptyTable @@ -367,6 +449,7 @@ -- | Insert a row into a relation, removing collisions. insert :: Tabular t => t -> Table t -> Table t insert t r = snd $ insert' t r +{-# INLINE insert #-} -- | Insert a row into a relation, removing collisions. insert' :: Tabular t => t -> Table t -> (t, Table t) @@ -376,22 +459,27 @@ Table m -> go (p m) Nothing -> go t0 where - go t = (,) 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 - 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) + go t = (,) t $ unsafeInsert t (delete t r) {-# INLINE go #-} -{-# INLINE insert #-} +{-# INLINE insert' #-} +-- | Insert a row into a relation, ignoring collisions. +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) +{-# INLINE unsafeInsert #-} + -- | Retrieve a row count. count :: Table t -> Int count EmptyTable = 0 @@ -411,19 +499,23 @@ table = iso fromList toList {-# INLINE table #-} -instance (Tabular b, Applicative f, PKT a ~ PKT b) => Each f (Table a) (Table b) a b where +instance (Tabular b, PKT a ~ PKT b) => Each (Table a) (Table b) a b where each _ EmptyTable = pure EmptyTable - each f (Table m) = P.foldr insert empty <$> sequenceA (M.foldrWithKey (\i a r -> indexed f i a : r) [] $ m^.primaryMap) + each f r@Table{} = P.foldr insert empty <$> traverse f (toList r) + {-# INLINE each #-} +{- -- | Traverse all of the rows in a table without changing any types rows' :: Traversal' (Table t) t rows' _ EmptyTable = pure EmptyTable rows' f r@Table{} = P.foldr insert empty <$> traverse f (toList r) {-# INLINE rows' #-} +-} -- | Traverse all of the rows in a table, potentially changing table types completely. -rows :: Tabular t => Traversal (Table s) (Table t) s t -rows f r = 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) {-# INLINE rows #-} class Group f q t i | q -> t i where @@ -509,13 +601,13 @@ 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 (xs^.table) <&> mappend (deleteCollisions r xs) + where go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) ss = S.fromList as {-# INLINE withAny #-} 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 (xs^.table) <&> mappend (deleteCollisions r xs) + where go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) ss = S.fromList as {-# INLINE withAll #-} @@ -523,7 +615,7 @@ 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 (xs^.table) <&> mappend (deleteCollisions r xs) + where go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) {-# INLINE withAny #-} withAll _ _ f EmptyTable = f EmptyTable @@ -531,14 +623,14 @@ 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 (xs^.table) <&> mappend (deleteCollisions r xs) + where go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) {-# INLINE withAll #-} -instance Withal (Key InvertedInt t (IntSet)) [Int] t where +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 (xs^.table) <&> mappend (deleteCollisions r xs) + where go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) {-# INLINE withAny #-} withAll _ _ f EmptyTable = f EmptyTable @@ -546,14 +638,14 @@ 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 (xs^.table) <&> mappend (deleteCollisions r xs) + where go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) {-# INLINE withAll #-} 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 (xs^.table) <&> mappend (deleteCollisions r xs) + where go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) {-# INLINE withAny #-} withAll _ _ f EmptyTable = f EmptyTable @@ -561,7 +653,7 @@ 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) + where go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) {-# INLINE withAll #-} @@ -586,7 +678,7 @@ lt = cmp LT EQ eq = cmp EQ EQ gt = cmp GT EQ - go xs = f (xs^.table) <&> mappend (deleteCollisions r xs) + go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) {-# INLINE with #-} instance With (Key Primary t) t where @@ -601,7 +693,7 @@ lt = cmp LT EQ eq = cmp EQ EQ gt = cmp GT EQ - go xs = f (xs^.table) <&> mappend (deleteCollisions r xs) + go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) {-# INLINE with #-} instance With (Key Candidate t) t where @@ -618,7 +710,7 @@ lt = cmp LT EQ eq = cmp EQ EQ gt = cmp GT EQ - go xs = f (xs^.table) <&> mappend (deleteCollisions r xs) + go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) {-# INLINE with #-} instance With (Key CandidateInt t) t where @@ -635,7 +727,7 @@ lt = cmp LT EQ eq = cmp EQ EQ gt = cmp GT EQ - go xs = f (xs^.table) <&> mappend (deleteCollisions r xs) + go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) {-# INLINE with #-} instance With (Key CandidateHash t) t where @@ -649,7 +741,7 @@ lt = cmp LT EQ eq = cmp EQ EQ gt = cmp GT EQ - go xs = f (xs^.table) <&> mappend (deleteCollisions r xs) + go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) {-# INLINE with #-} instance With (Key Supplemental t) t where @@ -666,7 +758,7 @@ lt = cmp LT EQ eq = cmp EQ EQ gt = cmp GT EQ - go xs = f (xs^.table) <&> mappend (deleteCollisions r xs) + go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) {-# INLINE with #-} instance With (Key SupplementalInt t) t where @@ -683,7 +775,7 @@ lt = cmp LT EQ eq = cmp EQ EQ gt = cmp GT EQ - go xs = f (xs^.table) <&> mappend (deleteCollisions r xs) + go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) {-# INLINE with #-} instance With (Key SupplementalHash t) t where @@ -697,7 +789,7 @@ lt = cmp LT EQ eq = cmp EQ EQ gt = cmp GT EQ - go xs = f (xs^.table) <&> mappend (deleteCollisions r xs) + go xs = f (unsafeFromList xs) <&> mappend (deleteCollisions r xs) {-# INLINE with #-} -- | Build up a table from a list @@ -705,6 +797,28 @@ fromList = foldl' (flip insert) empty {-# INLINE fromList #-} +-- | Build up a table from a list, without checking for collisions +unsafeFromList :: Tabular t => [t] -> Table t +unsafeFromList = foldl' (flip unsafeInsert) empty +{-# INLINE unsafeFromList #-} + +-- | Left-biased union of the two tables +-- +-- This is a synonym for 'mappend' +union :: Table t -> Table t -> Table t +union = mappend +{-# INLINE union #-} + +-- | Return the elements of the first table that do not share a key with an element of the second table +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 +{-# INLINE difference #-} + +-- | Return the elements of the first table that share a key with an element of the second table +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)) +{-# INLINE intersection #-} + -- * Lifting terms to types -- | Value-level key types @@ -720,14 +834,41 @@ InvertedInt :: KeyType InvertedInt IntSet InvertedHash :: (Eq a, Hashable a) => KeyType InvertedHash (HashSet a) --- | Type level key types +-- | The key type for the canonical, unique identifier attached to +-- every row. There should only be one 'Primary' key. data Primary + +-- | A key type for values unique to each row, but that are +-- not 'Primary'. data Candidate + +-- | 'CandidateInt' keys are like 'Candidate' keys but are backed by +-- an 'IntMap' rather than a 'Map'. This makes them more performant, +-- but values at 'CandidateInt' keys may only be 'Int's. data CandidateInt + +-- | 'CandidateHash' keys are like 'Candidate' keys but are backed by +-- a 'HashMap' rather than a 'Map'. This makes them more performant +-- on @('==')@ and @('/=')@ lookups, but values at 'CandidateHash' keys +-- must be instances of 'Hashable' and 'Eq'. data CandidateHash + +-- | A key type for supplemental data attached to each row that we +-- still may want to index by. Values need not be unique. data Supplemental + +-- | 'SupplementalInt' keys are like 'Supplemental' keys but are backed by +-- an 'IntMap' rather than a 'Map'. This makes them more performant, +-- but values at 'SupplementalInt' keys may only be 'Int's. data SupplementalInt + +-- | 'SupplementalHash' keys are like 'Supplemental' keys but are backed by +-- a 'HashMap' rather than a 'Map'. This makes them more performant +-- on @('==')@ and @('/=')@ lookups, but values at 'SupplementalHash' keys +-- must be instances of 'Hashable' and 'Eq'. data SupplementalHash + +-- | A key type for inverse keys. data Inverted data InvertedInt data InvertedHash @@ -775,9 +916,6 @@ 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 - ------------------------------------------------------------------------------ -- A simple table with an auto-incremented key ------------------------------------------------------------------------------ @@ -797,8 +935,8 @@ type instance Index (Auto a) = Int -instance (a ~ Int, b ~ Int, Applicative f) => Each f (Auto a) (Auto b) a b where - each f (Auto k a) = Auto <$> indexed f (0 :: Int) k <*> indexed f (1 :: Int) a +instance (a ~ Int, b ~ Int) => Each (Auto a) (Auto b) a b where + each f (Auto k a) = Auto <$> f k <*> f a {-# INLINE each #-} data Auto a = Auto !Int a @@ -808,10 +946,6 @@ autoKey f (Auto k a) = f k <&> \k' -> Auto k' a {-# INLINE autoKey #-} -instance (Indexable Int p, q ~ (->), Functor f) => HasValue p q f (Auto a) (Auto b) a b where - value f (Auto k a) = indexed f k a <&> Auto k - {-# INLINE value #-} - instance FunctorWithIndex Int Auto where imap f (Auto k a) = Auto k (f k a) {-# INLINE imap #-} @@ -830,6 +964,18 @@ extend f w@(Auto k _) = Auto k (f w) {-# INLINE extend #-} +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) @@ -854,10 +1000,6 @@ -- A simple key-value pair, indexed on the key ------------------------------------------------------------------------------ -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 - {-# INLINE value #-} - -- | Simple (key, value) pairs instance Ord k => Tabular (k,v) where type PKT (k,v) = k @@ -881,10 +1023,6 @@ -- Set-like tables with Identity ------------------------------------------------------------------------------ -instance (Profunctor p, Functor f, p ~ q) => HasValue p q f (Identity a) (Identity b) a b where - value = unwrapped - {-# INLINE value #-} - instance Ord a => Tabular (Identity a) where type PKT (Identity a) = a data Tab (Identity a) i = IdentityTab (i Primary a) @@ -914,21 +1052,18 @@ type instance Index (Value a) = () type instance IxValue (Value a) = a -instance Functor f => Each f (Value a) (Value b) a b where - each f (Value a) = Value <$> indexed f () a +instance Each (Value a) (Value b) a b where + each f (Value a) = Value <$> f a {-# INLINE each #-} -instance Gettable f => Contains f (Value a) where - contains () pafb _ = coerce (indexed pafb () True) - {-# INLINE contains #-} - -instance Functor f => Ixed f (Value a) where +instance Ixed (Value a) where ix () pafb (Value a) = Value <$> indexed pafb () a {-# INLINE ix #-} -instance Wrapped a b (Value a) (Value b) where - wrapped = iso Value $ \(Value a) -> a - {-# INLINE wrapped #-} +instance Wrapped (Value a) where + type Unwrapped (Value a) = a + _Wrapped' = iso (\(Value a) -> a) Value + {-# INLINE _Wrapped' #-} data Value a = Value a deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable,Data,Typeable) @@ -959,10 +1094,6 @@ Value f <@> Value a = Value (f a) {-# INLINE (<@>) #-} -instance (Profunctor p, Functor f, p ~ q) => HasValue p q f (Value a) (Value b) a b where - value = unwrapped - {-# INLINE value #-} - instance Ord a => Tabular (Value a) where type PKT (Value a) = a data Tab (Value a) i = ValueTab (i Primary a) @@ -980,3 +1111,38 @@ {-# INLINE ixTab #-} forTab (ValueTab x) f = ValueTab <$> f Val x {-# INLINE forTab #-} + +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 + diff --git a/tables.cabal b/tables.cabal --- a/tables.cabal +++ b/tables.cabal @@ -1,6 +1,6 @@ name: tables category: Data, Lenses -version: 0.3.1 +version: 0.4 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -34,24 +34,29 @@ location: git://github.com/ekmett/tables.git flag test-properties + description: Enable the properties test-suite. default: True manual: True flag transformers2 + description: Enables the use of old versions of transformers. Users should + never care about this. default: False manual: False library build-depends: base >= 4.3 && < 5, - binary >= 0.5 && < 0.6, + binary >= 0.5 && < 0.8, cereal >= 0.3 && < 0.4, - comonad >= 3 && < 4, + comonad >= 4 && < 5, containers >= 0.4 && < 0.6, + deepseq >= 1.3 && < 1.4, hashable >= 1.1 && < 1.3, - lens >= 3.8 && < 4, - profunctors >= 3.2 && < 4, + lens >= 4 && < 5, + profunctors >= 4 && < 5, safecopy >= 0.6.3 && < 0.9, + template-haskell >= 2.7 && < 2.9, transformers >= 0.2 && < 0.4, transformers-compat >= 0.1 && < 1, unordered-containers == 0.2.*