tables (empty) → 0.1
raw patch · 14 files changed
+1332/−0 lines, 14 filesdep +basedep +comonaddep +containersbuild-type:Customsetup-changed
Dependencies added: base, comonad, containers, directory, doctest, filepath, hashable, lens, profunctors, transformers, transformers-compat, unordered-containers
Files
- .ghci +1/−0
- .gitignore +9/−0
- .travis.yml +32/−0
- .vim.custom +31/−0
- CHANGELOG.markdown +4/−0
- LICENSE +30/−0
- README.markdown +88/−0
- Setup.lhs +42/−0
- examples/Foo.hs +58/−0
- src/Data/Table.hs +894/−0
- tables.cabal +81/−0
- tests/doctests.hs +30/−0
- travis/cabal-apt-install +16/−0
- travis/config +16/−0
+ .ghci view
@@ -0,0 +1,1 @@+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
+ .gitignore view
@@ -0,0 +1,9 @@+dist+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo
+ .travis.yml view
@@ -0,0 +1,32 @@+language: haskell+before_install:+ # Uncomment whenever hackage is down.+ # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update++ # grab lens 3.8+ - git clone https://github.com/ekmett/lens.git+ - 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++script:+ - $script++notifications:+ irc:+ channels:+ - "irc.freenode.org#haskell-lens"+ 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"
+ .vim.custom view
@@ -0,0 +1,31 @@+" Add the following to your .vimrc to automatically load this on startup++" if filereadable(".vim.custom")+" so .vim.custom+" endif++function StripTrailingWhitespace()+ let myline=line(".")+ let mycolumn = col(".")+ silent %s/ *$//+ call cursor(myline, mycolumn)+endfunction++" enable syntax highlighting+syntax on++" search for the tags file anywhere between here and /+set tags=TAGS;/++" highlight tabs and trailing spaces+set listchars=tab:‗‗,trail:‗+set list++" f2 runs hasktags+map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>++" strip trailing whitespace before saving+" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()++" rebuild hasktags after saving+au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
+ CHANGELOG.markdown view
@@ -0,0 +1,4 @@+0.1+---+* Initial public release+* Repository initialized
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 2012-2013 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,88 @@+Tables+======++[](http://travis-ci.org/lens/tables)++This package provides simple in memory data tables with multiple indices.++Examples+--------++So if load `examples/Foo.hs` into `ghci`, we start with:++```haskell+>>> test+fromList [ Foo {fooId = 1, fooBar = "One", fooBaz = 1.0}+ , Foo {fooId = 2, fooBar = "Two", fooBaz = 2.0}+ , Foo {fooId = 3, fooBar = "Three", fooBaz = 3.0}+ , Foo {fooId = 4, fooBar = "Four", fooBaz = 4.0}+ , Foo {fooId = 5, fooBar = "Five", fooBaz = 5.0} ]+```++We use uppercase constructor names to match on built-in keys++```haskell+>>> test ^. with FooId (<) 3+fromList [ Foo {fooId = 1, fooBar = "One", fooBaz = 1.0}+ , Foo {fooId = 2, fooBar = "Two", fooBaz = 2.0} ]+```++Then we can use any lowercase field accessor (or any other function) to do a non-keyed lookup or filter++```haskell+>>> test ^. with (length . fooBar) (<=) 3+fromList [ Foo {fooId = 1, fooBar = "One", fooBaz = 1.0}+ , Foo {fooId = 2, fooBar = "Two", fooBaz = 2.0} ]+```++You can delete by assigning to that filtered table:++```haskell+>>> test & with (length . fooBar) (<=) 3 .~ empty+fromList [ Foo {fooId = 3, fooBar = "Three", fooBaz = 3.0}+ , Foo {fooId = 4, fooBar = "Four", fooBaz = 4.0}+ , Foo {fooId = 5, fooBar = "Five", fooBaz = 5.0} ]+```++You can edit the actual type of the fields if the table is configured to allow it:++```haskell+>>> test & rows.fooBar_ %~ length+fromList [ Foo {fooId = 1, fooBar = 3, fooBaz = 1.0}+ , Foo {fooId = 2, fooBar = 3, fooBaz = 2.0}+ , Foo {fooId = 3, fooBar = 5, fooBaz = 3.0}+ , Foo {fooId = 4, fooBar = 4, fooBaz = 4.0}+ , Foo {fooId = 5, fooBar = 4, fooBaz = 5.0} ]+```++If you edit multiple fields, the edits all take place at the same time. so we can offset or swap a bunch of keys:++```haskell+>>> test & with FooId (>=) 2.rows.fooId_ +~ 1+fromList [ Foo {fooId = 1, fooBar = "One", fooBaz = 1.0}+ , Foo {fooId = 3, fooBar = "Two", fooBaz = 2.0}+ , Foo {fooId = 4, fooBar = "Three", fooBaz = 3.0}+ , Foo {fooId = 5, fooBar = "Four", fooBaz = 4.0}+ , Foo {fooId = 6, fooBar = "Five", fooBaz = 5.0} ]+```++We can do grouping by arbitrary functions or fields similarly++```haskell+>>> test ^@.. group (length.fooBar)+[ (3, fromList [ Foo {fooId = 1, fooBar = "One", fooBaz = 1.0}+ , Foo {fooId = 2, fooBar = "Two", fooBaz = 2.0} ])+, (4, fromList [ Foo {fooId = 4, fooBar = "Four", fooBaz = 4.0}+ , Foo {fooId = 5, fooBar = "Five", fooBaz = 5.0} ])+, (5, fromList [Foo {fooId = 3, fooBar = "Three", fooBaz = 3.0} ])+]+```++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell or #haskell-lens IRC channels on irc.freenode.net.++-Edward Kmett
+ Setup.lhs view
@@ -0,0 +1,42 @@+#!/usr/bin/runhaskell+\begin{code}+module Main (main) where++import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )+import Distribution.Verbosity ( Verbosity )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )+import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(libraryConfig, testSuiteConfigs), ComponentLocalBuildInfo(componentPackageDeps) )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+ { buildHook = \pkg lbi hooks flags -> do+ generateBuildModule "doctests" (fromFlag (buildVerbosity flags)) lbi+ buildHook simpleUserHooks pkg lbi hooks flags+ }++generateBuildModule :: String -> Verbosity -> LocalBuildInfo -> IO ()+generateBuildModule testSuite verbosity lbi = do+ let dir = autogenModulesDir lbi+ createDirectoryIfMissingVerbose verbosity True dir+ rewriteFile (dir </> "Build_" ++ testSuite ++ ".hs") $ unlines+ [ "module Build_" ++ testSuite ++ " where"+ , "deps :: [String]"+ , "deps = " ++ (show $ formatdeps (testDeps testSuite lbi))+ ]+ where+ formatdeps = map (formatone . snd)+ formatone p = case packageName p of+ PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: String -> LocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps testSuite lbi = nub $+ maybe [] componentPackageDeps (lookup testSuite (testSuiteConfigs lbi))+ ++ maybe [] componentPackageDeps (libraryConfig lbi)++\end{code}
+ examples/Foo.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+module Foo where++import Control.Applicative hiding (empty)+import Control.Lens+import Data.Data+import Data.Foldable as Foldable+import Data.Function (on)+import Data.Functor.Identity+import Data.List ((\\))+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid+import Data.Table+import Data.Traversable+import qualified Prelude+import Prelude hiding (null)++-- * Example Table++data Foo a = Foo { fooId :: Int, fooBar :: a, fooBaz :: Double }+ deriving (Eq,Ord,Show,Read,Data,Typeable)++makeLensesWith ?? ''Foo $ defaultRules & lensField .~ \x -> Just (x ++ "_")++instance Tabular (Foo a) where+ type PKT (Foo a) = Int+ data Key k (Foo a) b where+ FooId :: Key Primary (Foo a) Int+ FooBaz :: Key Candidate (Foo a) Double+ data Tab (Foo a) i = FooTab (i Primary Int) (i Candidate Double)++ fetch FooId = fooId+ fetch FooBaz = fooBaz++ primary = FooId+ primarily FooId r = r++ mkTab f = FooTab <$> f FooId <*> f FooBaz+ forTab (FooTab x y) f = FooTab <$> f FooId x <*> f FooBaz y+ ixTab (FooTab x _) FooId = x+ ixTab (FooTab _ x) FooBaz = x++ autoTab = autoIncrement fooId_++test :: Table (Foo String)+test = [Foo 0 "One" 1.0, Foo 0 "Two" 2.0, Foo 0 "Three" 3.0, Foo 0 "Four" 4.0, Foo 0 "Five" 5.0]^.table
+ src/Data/Table.hs view
@@ -0,0 +1,894 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++#ifndef MIN_VERSION_containers+#define MIN_VERSION_containers(x,y,z) 1+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.Table+-- Copyright : (C) 2012-2013 Edward Kmett,+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- This module provides tables with multiple indices that support a simple+-- API based on the lenses and traversals from the @lens@ package.+----------------------------------------------------------------------------+module Data.Table+ (+ -- * Tables+ Table(..)+ , Tabular(..)+ , Tab(..)+ , Key(..)+ -- ** Table Construction+ , empty+ , singleton+ , table+ , fromList+ -- ** Reading and Writing+ , null+ , count+ , With(..)+ , Withal(..)+ , Group(..)+ , insert+ , delete+ , rows+ , rows'+ -- * Esoterica+ , Auto(..)+ , autoKey+ , auto+ , autoIncrement+ -- * 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.Lens+import Control.Monad+import Control.Monad.Fix+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.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.Set (Set)+import qualified Data.Set as S+import Data.Traversable+import qualified Prelude as P+import Prelude hiding (null)++{-# ANN module "HLint: ignore Reduce duplication" #-}+{-# ANN module "HLint: ignore Eta reduce" #-}++-- | This class describes how to index a user-defined data type.+class Ord (PKT t) => Tabular (t :: *) where+ -- | The primary key type+ type PKT t++ -- | Used to store indices+ data Tab t m++ -- | The type used internally for columns+ data Key (k :: *) t :: * -> *++ -- | Extract the value of a 'Key'+ fetch :: Key k t a -> t -> a++ -- | Every 'Table' has one 'Primary' 'Key'+ primary :: Key Primary t (PKT t)++ -- | ... and so if you find one, it had better be that one!+ primarily :: Key Primary t a -> ((a ~ PKT t) => r) -> r++ -- | Construct a 'Tab' given a function from key to index.+ mkTab :: Applicative h => (forall k a. IsKeyType k a => Key k t a -> h (i k a)) -> h (Tab t i)++ -- | Lookup an index in a 'Tab'+ ixTab :: Tab t i -> Key k t a -> i k a++ -- | Loop over each index in a 'Tab'+ 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)++ -- | Adjust a record using meta-information about the table allowing for auto-increments.+ autoTab :: t -> Maybe (Tab t (AnIndex t) -> t)+ autoTab _ = Nothing+ {-# INLINE autoTab #-}++-- | This lets you define 'autoKey' to increment to 1 greater than the existing maximum key in a table.+--+-- In order to support this you need a numeric primary key, and the ability to update the primary key in a record, indicated by a+-- lens to the field.+--+-- To enable auto-increment for a table with primary key @primaryKeyField@, set:+--+-- @'autoKey' = 'autoIncrement' primaryKeyField@+autoIncrement :: (Tabular t, PKT t ~ Int) => ALens' t Int -> 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+{-# INLINE autoIncrement #-}++-- | This is used to store a single index.+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++-- | Find the primary key index a tab+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+{-# INLINE primaryMap #-}++-- * Overloaded keys++------------------------------------------------------------------------------+-- Table+------------------------------------------------------------------------------++-- | Every 'Table' has a 'Primary' 'key' and may have 'Candidate',+-- 'Supplemental' or 'Inverted' keys, plus their variants.+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++fromListConstr :: Constr+fromListConstr = mkConstr tableDataType "fromList" [] Prefix++tableDataType :: DataType+tableDataType = mkDataType "Data.Table.Table" [fromListConstr]++instance Monoid (Table t) where+ mempty = EmptyTable+ {-# INLINE mempty #-}++ EmptyTable `mappend` r = r+ r `mappend` EmptyTable = r+ r@Table{} `mappend` s = F.foldl' (flip insert) r s+ {-# INLINE mappend #-}++instance Eq t => Eq (Table t) where+ (==) = (==) `on` toList+ {-# INLINE (==) #-}++instance Ord t => Ord (Table t) where+ compare = compare `on` toList+ {-# INLINE compare #-}++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+ {-# INLINE foldMap #-}++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+ ix _ _ EmptyTable = pure EmptyTable+ ix k f (Table m) = Table <$> primaryMap (ix k f) m+ {-# INLINE ix #-}++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+ {-# INLINE at #-}++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 [] 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 ->+ m & at ky . anon [] P.null %~ 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 [] 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 <- S.toList $ 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 <- IS.toList $ 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 <- HS.toList $ 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 (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+{-# INLINE emptyTab #-}++-- * Public API++-- | Construct an empty relation+empty :: Table t+empty = EmptyTable+{-# INLINE empty #-}++-- | Check to see if the relation is empty+null :: Table t -> Bool+null EmptyTable = True+null (Table m) = M.null (m^.primaryMap)+{-# INLINE null #-}++-- | 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+ 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)+{-# 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)+ CandidateHashMap idx -> idx^..ix (fetch k t)+ _ -> []+{-# INLINE collisions #-}++-- | Delete this row from the database. This will remove any row that collides with the specified+-- row on any primary or candidate key.+delete :: t -> Table t -> Table t+delete t m = deleteCollisions m (collisions t m)+{-# INLINE delete #-}++-- | Insert a row into a relation, removing collisions.+insert :: Tabular t => t -> Table 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 = 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 [] 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 (IS.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 #-}++-- | Retrieve a row count.+count :: Table t -> Int+count EmptyTable = 0+count (Table m) = M.size (m^.primaryMap)++-- | Convert a list to and from a 'Table'.+--+-- The real isomorphism laws hold if the original list makes no use of the auto-increment+-- functionality of the table, has no duplicates and is sorted according to the primary key.+--+-- However,+--+-- @'from' 'table' '.' 'table' ≡ 'id'@+--+-- always holds.+table :: Tabular t => Iso' [t] (Table t)+table = iso fromList toList+{-# INLINE table #-}++instance (Tabular b, Applicative f, PKT a ~ PKT b) => Each f (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)++-- | 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)+{-# INLINE rows #-}++class Group f q t i | q -> t i where+ -- | Group by a given key or arbitrary function.+ 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])))+ {-# INLINE group #-}++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+ {-# INLINE group #-}++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+ {-# INLINE group #-}++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+ {-# 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+ SupplementalMap idx -> traverse (\(k,vs) -> indexed f k (fromList vs)) (M.toList idx) <&> mconcat+ {-# INLINE group #-}++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+ {-# 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 (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++-- | Search inverted indices+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+ {-# INLINE deleteWithAny #-}++ deleteWithAll :: q -> s -> Table t -> Table t+ deleteWithAll p as t = set (withAll p as) empty t+ {-# INLINE deleteWithAll #-}++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)+ 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)+ ss = S.fromList as+ {-# INLINE withAll #-}++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 (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+ 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)+ {-# INLINE withAll #-}++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)+ {-# 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+ 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)+ {-# 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)+ {-# 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)++ -- | Delete selected rows from a table+ --+ -- @'deleteWith' p cmp a t ≡ 'set' ('with' p cmp a) 'empty' 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+ {-# INLINE deleteWith #-}++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 (xs^.table) <&> mappend (deleteCollisions r xs)+ {-# INLINE with #-}++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 (xs^.table) <&> mappend (deleteCollisions r xs)+ {-# INLINE with #-}++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 -- 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 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 -- 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 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)+ | lt && eq && gt = f r -- all rows+ | 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 -- 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 SupplementalInt 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+ 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 -- 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 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+{-# INLINE fromList #-}++-- * Lifting terms to types++-- | 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+ 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)++-- | 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++instance Ord a => IsKeyType Primary a where+ keyType _ = Primary+ {-# INLINE keyType #-}++instance Ord a => IsKeyType Candidate a where+ keyType _ = Candidate+ {-# INLINE keyType #-}++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 #-}++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 (Set a) where+ keyType _ = Inverted+ {-# INLINE keyType #-}++instance a ~ [Int] => IsKeyType InvertedInt IntSet where+ keyType _ = InvertedInt+ {-# INLINE keyType #-}++instance (Eq a, Hashable a)=> IsKeyType InvertedHash (HashSet 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++------------------------------------------------------------------------------+-- A simple table with an auto-incremented key+------------------------------------------------------------------------------++-- | Generate a row with an auto-incremented key+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, 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++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 (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++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 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++------------------------------------------------------------------------------+-- 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++-- | Simple (key, value) pairs+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++------------------------------------------------------------------------------+-- 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++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++-----------------------------------------------------------------------------+-- A simple value for set-like tables.+-----------------------------------------------------------------------------++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 Functor f => Each f (Value a) (Value b) a b where+ each f (Value a) = Value <$> indexed f () a++instance Gettable f => Contains f (Value a) where+ contains () pafb _ = coerce (indexed pafb () True)++instance Functor f => Ixed f (Value a) where+ ix () pafb (Value a) = Value <$> indexed pafb () a++instance Wrapped a b (Value a) (Value b) where+ wrapped = iso Value $ \(Value a) -> a++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 (Profunctor p, Functor f, p ~ q) => HasValue p q f (Value a) (Value b) a b where+ value = unwrapped++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
+ tables.cabal view
@@ -0,0 +1,81 @@+name: tables+category: Data, Lenses+version: 0.1+license: BSD3+cabal-version: >= 1.8+license-file: LICENSE+author: Edward A. Kmett+maintainer: Edward A. Kmett <ekmett@gmail.com>+stability: provisional+homepage: http://github.com/ekmett/tables/+bug-reports: http://github.com/ekmett/tables/issues+copyright: Copyright (C) 2012-2013 Edward A. Kmett+synopsis: In-memory storage with multiple keys using lenses and traversals+description:+ In-memory storage with multiple keys using lenses and traversals+ .+ For a quick tour, see <https://github.com/ekmett/tables#examples>++build-type: Custom+tested-with: GHC == 7.4.2+extra-source-files:+ .travis.yml+ .ghci+ .gitignore+ .vim.custom+ travis/config+ travis/cabal-apt-install+ examples/*.hs+ README.markdown+ CHANGELOG.markdown++source-repository head+ type: git+ location: git://github.com/ekmett/tables.git++flag test-properties+ default: True+ manual: True++flag transformers2+ default: False+ manual: False++library+ build-depends:+ base >= 4.3 && < 5,+ comonad >= 3 && < 4,+ containers >= 0.4 && < 0.6,+ hashable >= 1.1 && < 1.3,+ lens >= 3.8 && < 4,+ profunctors >= 3.2 && < 4,+ transformers >= 0.2 && < 0.4,+ transformers-compat >= 0.1 && < 1,+ unordered-containers == 0.2.*++ exposed-modules:+ Data.Table++ if impl(ghc>=7.2)+ other-extensions: Trustworthy+ cpp-options: -DDEFAULT_SIGNATURES=1++ ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields+ hs-source-dirs: src++test-suite doctests+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ build-depends:+ base,+ containers,+ directory >= 1.0,+ doctest >= 0.9.1,+ filepath,+ lens,+ transformers,+ unordered-containers+ ghc-options: -Wall -threaded+ if impl(ghc<7.6.1)+ ghc-options: -Werror+ hs-source-dirs: tests
+ tests/doctests.hs view
@@ -0,0 +1,30 @@+module Main where++import Build_doctests (deps)+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++main :: IO ()+main = getSources >>= \sources -> doctest $+ "-isrc"+ : "-idist/build/autogen"+ : "-optP-include"+ : "-optPdist/build/autogen/cabal_macros.h"+ : "-hide-all-packages"+ : map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+ where+ go dir = do+ (dirs, files) <- getFilesAndDirectories dir+ (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+ c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
+ travis/cabal-apt-install view
@@ -0,0 +1,16 @@+#!/bin/sh+set -eu++sudo apt-get -q update+sudo apt-get -q -y install dctrl-tools++# Try installing some of the build-deps with apt-get for speed.+eval "$(+ printf '%s' "grep-aptavail -n -sPackage '(' -FFALSE -X FALSE ')'"+ 2>/dev/null cabal install "$@" --dry-run -v | \+ sed -nre "s/^([^ ]+)-[0-9.]+ \(.*$/ -o '(' -FPackage -X libghc-\1-dev ')'/p" | \+ xargs -d'\n'+)" | sort -u | xargs -d'\n' sudo apt-get -q -y install -- libghc-quickcheck2-dev++# Install whatever is still needed with cabal.+cabal install "$@"
+ travis/config view
@@ -0,0 +1,16 @@+-- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix+--+-- This is particularly useful for travis-ci to get it to stop complaining+-- about a broken build when everything is still correct on our end.+--+-- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead+--+-- To enable this, uncomment the before_script in .travis.yml++remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive+remote-repo-cache: ~/.cabal/packages+world-file: ~/.cabal/world+build-summary: ~/.cabal/logs/build.log+remote-build-reporting: anonymous+install-dirs user+install-dirs global