data-store (empty) → 0.3.0
raw patch · 17 files changed
+3046/−0 lines, 17 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, cereal, containers, criterion, deepseq, ixset, lens, mtl, random, safecopy, tables, tagged, test-framework, test-framework-quickcheck2, transformers, unordered-containers, vector
Files
- LICENSE +0/−0
- Setup.hs +2/−0
- benchmarks/src/01.hs +447/−0
- benchmarks/src/Common.hs +28/−0
- benchmarks/src/DS/B01.hs +91/−0
- benchmarks/src/TS/B01.hs +83/−0
- data-store.cabal +107/−0
- src/Data/IntSet/Extra.hs +41/−0
- src/Data/Map/Extra.hs +20/−0
- src/Data/Store.hs +673/−0
- src/Data/Store/Internal/Function.hs +288/−0
- src/Data/Store/Internal/Type.hs +555/−0
- src/Data/Store/Lens.hs +33/−0
- src/Data/Store/Selection.hs +230/−0
- src/Data/Store/Storable.hs +110/−0
- tests/Main.hs +14/−0
- tests/Test/Data/Store01.hs +324/−0
+ LICENSE view
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/src/01.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}++module Main+( main+) where++--------------------------------------------------------------------------------+import Control.DeepSeq (NFData(..))+import Control.Exception.Base (evaluate)+import Control.Monad.Trans (liftIO)+--------------------------------------------------------------------------------+import Data.List+import qualified Data.Map.Strict as Data.Map+--------------------------------------------------------------------------------+import qualified Criterion.Config as C+import qualified Criterion.Main as C+--------------------------------------------------------------------------------+import qualified DS.B01+import qualified TS.B01+import qualified IS.B01+--------------------------------------------------------------------------------+import Common+--------------------------------------------------------------------------------++#define BENCH_SMALL+#define BENCH_ESSENTIALS++data RNF where+ RNF :: NFData a => a -> RNF++instance NFData RNF where+ rnf (RNF x) = rnf x++main :: IO ()+main = C.defaultMainWith C.defaultConfig (liftIO . evaluate $ rnf+ [ RNF elems500+ , RNF elems10000+ , RNF elems20000+#ifndef BENCH_SMALL+ , RNF elems100000+ , RNF elems200000+ , RNF elems400000+ , RNF elems800000+#endif++ , RNF elems5000x5000+ , RNF elems10000x5000++ , RNF ds10000+ , RNF ds20000+#ifndef BENCH_SMALL+ , RNF ds100000+ , RNF ds200000+ --, RNF ds400000+ --, RNF ds800000+#endif++ , RNF map10000+ , RNF map20000+#ifndef BENCH_SMALL+ , RNF map100000+ , RNF map200000+ --, RNF map400000+ --, RNF map800000+#endif+ + , RNF is10000+ , RNF is20000+#ifndef BENCH_SMALL+ , RNF is100000+ , RNF is200000+#endif+ + , RNF ts10000+ , RNF ts20000+#ifndef BENCH_SMALL+ , RNF ts100000+ , RNF ts200000+#endif++ , RNF elem9999999+ , RNF elem2500+ ])+ -- Insert 1 element into a store of size N. No collisions.+ [ {-+ C.bgroup "insert (Int) 01 10000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.insert elem9999999) ds10000+ , C.bench "DS (Unsafe)" $ C.nf (DS.B01.insertUnsafe elem9999999) ds10000+#ifndef BENCH_DS+ , C.bench "Map" $ C.whnf (insertMap elem9999999) map10000+ , C.bench "IS" $ C.nf (IS.B01.insert elem9999999) is10000+ , C.bench "TS" $ C.nf (TS.B01.insert elem9999999) ts10000+#endif+ ]+ ]+ , C.bgroup "insert (Int) 01 20000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.insert elem9999999) ds20000+ , C.bench "DS (Unsafe)" $ C.nf (DS.B01.insertUnsafe elem9999999) ds20000+#ifndef BENCH_DS+ , C.bench "Map" $ C.whnf (insertMap elem9999999) map20000+ , C.bench "IS" $ C.nf (IS.B01.insert elem9999999) is20000+ , C.bench "TS" $ C.nf (TS.B01.insert elem9999999) ts20000+#endif+ ]+ ]+ , C.bgroup "insert-collision (Int) 01 10000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.insert elem2500) ds10000+#ifndef BENCH_DS+ , C.bench "Map" $ C.whnf (insertMap elem2500) map10000+ , C.bench "IS" $ C.nf (IS.B01.insert elem2500) is10000+ , C.bench "TS" $ C.nf (TS.B01.insert elem2500) ts10000+#endif+ ]+ ]+ , C.bgroup "insert-collision (Int) 01 20000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.insert elem2500) ds20000+#ifndef BENCH_DS+ , C.bench "Map" $ C.whnf (insertMap elem2500) map20000+ , C.bench "IS" $ C.nf (IS.B01.insert elem2500) is20000+ , C.bench "TS" $ C.nf (TS.B01.insert elem2500) ts20000+#endif+ ]+ ]+ -}+ C.bgroup "lookup OO EQ (Int) 01 20000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.lookupOOEQ 10000) ds20000+ , C.bench "DS (Lens)" $ C.nf (DS.B01.lookupOOEQLens 10000) ds20000+#ifndef BENCH_DS+ , C.bench "Map" $ C.nf (Data.Map.lookup 10000) map20000+ , C.bench "IS" $ C.nf (IS.B01.lookupOOEQ 10000) is20000+ , C.bench "TS" $ C.nf (TS.B01.lookupOOEQ 10000) ts20000+#endif+ ]+ ]+ , C.bgroup "lookup OO GE (Int) 01 20000 (500)"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.lookupOOGE 19500) ds20000+ , C.bench "DS (Lens)" $ C.nf (DS.B01.lookupOOGELens 19500) ds20000+ , C.bench "DS (Test)" $ C.nf (insertListDSUnsafe elems500) DS.B01.empty+#ifndef BENCH_DS+ , C.bench "IS" $ C.nf (IS.B01.lookupOOGE 19500) is20000+ , C.bench "TS" $ C.nf (TS.B01.lookupOOGE 19500) ts20000+#endif+ ]+ ]+ , C.bgroup "lookup OM EQ (Int) 01 20000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.lookupOMEQ 200) ds20000+ , C.bench "DS (Lens)" $ C.nf (DS.B01.lookupOMEQLens 200) ds20000+#ifndef BENCH_DS+ , C.bench "IS" $ C.nf (IS.B01.lookupOMEQ 200) is20000+ , C.bench "TS" $ C.nf (TS.B01.lookupOMEQ 200) ts20000+#endif+ ]+ ]+ , C.bgroup "lookup OM GE (Int) 01 20000 (500)"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.lookupOMGE 3900) ds20000+ , C.bench "DS (Lens)" $ C.nf (DS.B01.lookupOMGELens 3900) ds20000+#ifndef BENCH_DS+ , C.bench "IS" $ C.nf (IS.B01.lookupOMGE 3900) is20000+ , C.bench "TS" $ C.nf (TS.B01.lookupOMGE 3900) ts20000+#endif+ ]+ ]+ , C.bgroup "lookup MM EQ (Int) 01 20000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.lookupMMEQ 200) ds20000+ , C.bench "DS (Lens)" $ C.nf (DS.B01.lookupMMEQLens 200) ds20000+#ifndef BENCH_DS+ , C.bench "IS" $ C.nf (IS.B01.lookupMMEQ 200) is20000+ , C.bench "TS" $ C.nf (TS.B01.lookupMMEQ 200) ts20000+#endif+ ]+ ]++ -- BIG INPUTS+ -- Insert 1 element into a store of size N. No collisions.+#ifndef BENCH_SMALL + , C.bgroup "insert (Int) 01 100000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.insert elem9999999) ds100000+ , C.bench "DS (Unsafe)" $ C.nf (DS.B01.insertUnsafe elem9999999) ds100000+#ifndef BENCH_DS+ , C.bench "IS" $ C.nf (IS.B01.insert elem9999999) is100000+ , C.bench "Map" $ C.whnf (insertMap elem9999999) map100000+ , C.bench "TS" $ C.nf (TS.B01.insert elem9999999) ts100000+#endif+ ]+ ]+ , C.bgroup "insert (Int) 01 200000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.insert elem9999999) ds200000+ , C.bench "DS (Unsafe)" $ C.whnf (DS.B01.insertUnsafe elem9999999) ds200000+#ifndef BENCH_DS+ , C.bench "IS" $ C.nf (IS.B01.insert elem9999999) is200000+ , C.bench "Map" $ C.whnf (insertMap elem9999999) map200000+ , C.bench "TS" $ C.nf (TS.B01.insert elem9999999) ts200000+#endif+ ]+ ]+ , C.bgroup "insert-collision (Int) 01 100000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.insert elem2500) ds100000+#ifndef BENCH_DS+ , C.bench "IS" $ C.whnf (IS.B01.insert elem2500) is100000+ , C.bench "Map" $ C.nf (insertMap elem2500) map100000+ , C.bench "TS" $ C.nf (TS.B01.insert elem2500) ts100000+#endif+ ]+ ]+ , C.bgroup "insert-collision (Int) 01 200000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.insert elem2500) ds200000+#ifndef BENCH_DS+ , C.bench "IS" $ C.nf (IS.B01.insert elem2500) is200000+ , C.bench "Map" $ C.nf (insertMap elem2500) map200000+ , C.bench "TS" $ C.nf (TS.B01.insert elem2500) ts200000+#endif+ ]+ ]+ , C.bgroup "lookup OO EQ (Int) 01 200000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.lookupOOEQ 2500) ds200000+ , C.bench "DS (Lens)" $ C.nf (DS.B01.lookupOOEQLens 2500) ds200000+#ifndef BENCH_DS+ , C.bench "IS" $ C.nf (IS.B01.lookupOOEQ 2500) is200000+ , C.bench "Map" $ C.whnf (Data.Map.lookup 2500) map200000+ , C.bench "TS" $ C.nf (TS.B01.lookupOOEQ 2500) ts200000+#endif+ ]+ ]+ , C.bgroup "lookup OO GE (Int) 01 200000 (500)"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.lookupOOGE 199000) ds200000+ , C.bench "DS (Lens)" $ C.nf (DS.B01.lookupOOGELens 199000) ds200000+#ifndef BENCH_DS+ , C.bench "IS" $ C.nf (IS.B01.lookupOOGE 199000) is200000+ , C.bench "TS" $ C.nf (TS.B01.lookupOOGE 199500) ts200000+#endif+ ]+ ]+ , C.bgroup "lookup OM EQ (Int) 01 200000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.lookupOMEQ 200) ds200000+ , C.bench "DS (Lens)" $ C.nf (DS.B01.lookupOMEQLens 200) ds200000+#ifndef BENCH_DS+ , C.bench "IS" $ C.nf (IS.B01.lookupOMEQ 200) is200000+ , C.bench "TS" $ C.nf (TS.B01.lookupOMEQ 200) ts200000+#endif+ ]+ ]+ , C.bgroup "lookup OM GE (Int) 01 200000 (500)"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.lookupOMGE 39900) ds200000+ , C.bench "DS (Lens)" $ C.nf (DS.B01.lookupOMGELens 39900) ds200000+#ifndef BENCH_DS+ , C.bench "IS" $ C.nf (IS.B01.lookupOMGE 39900) is200000+ , C.bench "TS" $ C.nf (TS.B01.lookupOMGE 39900) ts200000+#endif+ ]+ ]+ , C.bgroup "lookup MM EQ (Int) 01 200000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (DS.B01.lookupMMEQ 200) ds200000+ , C.bench "DS (Lens)" $ C.nf (DS.B01.lookupMMEQLens 200) ds200000+#ifndef BENCH_DS+ , C.bench "IS" $ C.nf (IS.B01.lookupMMEQ 200) is200000+ , C.bench "TS" $ C.nf (TS.B01.lookupMMEQ 200) ts200000+#endif+ ]+ ]+-- BENCH_SMALL+#endif++{-+#ifndef BENCH_ESSENTIALS+ -- Insert N elements into an empty store (the inserts are accumulative). No collisions.+ , C.bgroup "insert-accum (Int) 01 10000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (insertListDS elems10000) DS.B01.empty+ , C.bench "DS (Unsafe)" $ C.nf (insertListDSUnsafe elems10000) DS.B01.empty+#ifndef BENCH_DS+ , C.bench "TS" $ C.nf (insertListTS elems10000) TS.B01.empty+#endif+ ]+ ]+ + -- Insert N elements into store of the same N elements (the inserts are+ -- accumulative, thus we basically "overwrite" the shole store).+ -- Collisions (obviously).+ , C.bgroup "insert-accum-collisions (Int) 01 10000"+ [ C.bcompare+ [ C.bench "DS" $ C.nf (insertListDS elems10000) ds10000+#ifndef BENCH_DS + , C.bench "TS" $ C.nf (insertListTS elems10000) ts10000+#endif+ ]+ ]+-- ESSENTIALS+#endif+-}+ ]+++---++insertListDS :: [C01] -> DS.B01.DS -> DS.B01.DS+insertListDS xs s0 = foldl' (flip DS.B01.insert) s0 xs++insertListDSUnsafe :: [C01] -> DS.B01.DS -> DS.B01.DS+insertListDSUnsafe xs s0 = foldl' (flip DS.B01.insertUnsafe) s0 xs++insertListTS :: [C01] -> TS.B01.TS -> TS.B01.TS+insertListTS xs s0 = foldl' (flip TS.B01.insert) s0 xs++insertListIS :: [C01] -> IS.B01.IS -> IS.B01.IS+insertListIS xs s0 = foldl' (\s x -> IS.B01.insert x $! s) s0 xs++insertListMap :: [C01] -> Data.Map.Map Int C01 -> Data.Map.Map Int C01+insertListMap xs s0 = foldl' (flip insertMap) s0 xs++insertMap :: C01 -> Data.Map.Map Int C01 -> Data.Map.Map Int C01+insertMap x@(C01 oo _ _) = Data.Map.insert oo x++-- MAP++map10000 :: Data.Map.Map Int C01+map10000 = insertListMap elems10000 Data.Map.empty++map20000 :: Data.Map.Map Int C01+map20000 = insertListMap elems20000 Data.Map.empty++#ifndef BENCH_SMALL+map100000 :: Data.Map.Map Int C01+map100000 = insertListMap elems100000 Data.Map.empty++map200000 :: Data.Map.Map Int C01+map200000 = insertListMap elems200000 Data.Map.empty++map800000 :: Data.Map.Map Int C01+map800000 = insertListMap elems800000 Data.Map.empty+#endif++-- IS++is10000 :: IS.B01.IS+is10000 = insertListIS elems10000 IS.B01.empty++is20000 :: IS.B01.IS+is20000 = insertListIS elems20000 IS.B01.empty++#ifndef BENCH_SMALL+is100000 :: IS.B01.IS+is100000 = insertListIS elems100000 IS.B01.empty++is200000 :: IS.B01.IS+is200000 = insertListIS elems200000 IS.B01.empty+#endif++-- DS++ds10000 :: DS.B01.DS+ds10000 = insertListDS elems10000 DS.B01.empty++ds20000 :: DS.B01.DS+ds20000 = insertListDS elems20000 DS.B01.empty++#ifndef BENCH_SMALL+ds100000 :: DS.B01.DS+ds100000 = insertListDS elems100000 DS.B01.empty++ds200000 :: DS.B01.DS+ds200000 = insertListDS elems200000 DS.B01.empty++ds400000 :: DS.B01.DS+ds400000 = insertListDS elems400000 DS.B01.empty++ds800000 :: DS.B01.DS+ds800000 = insertListDS elems800000 DS.B01.empty+#endif++-- TS++ts10000 :: TS.B01.TS+ts10000 = insertListTS elems10000 TS.B01.empty++ts20000 :: TS.B01.TS+ts20000 = insertListTS elems20000 TS.B01.empty++#ifndef BENCH_SMALL+ts100000 :: TS.B01.TS+ts100000 = insertListTS elems100000 TS.B01.empty++ts200000 :: TS.B01.TS+ts200000 = insertListTS elems200000 TS.B01.empty+#endif++-- ELEM++elem9999999 :: C01+elem9999999 = head $! generate 9999999 1 ++elem2500 :: C01+elem2500 = head $! generate 2500 1 ++elems5000x5000 :: [C01]+elems5000x5000 = generate 5000 5000++elems10000x5000 :: [C01]+elems10000x5000 = generate 10000 5000++elems500 :: [C01]+elems500 = generate 19500 500++elems10000 :: [C01]+elems10000 = generate 0 10000++elems20000 :: [C01]+elems20000 = generate 0 20000++#ifndef BENCH_SMALL+elems100000 :: [C01]+elems100000 = generate 0 100000++elems200000 :: [C01]+elems200000 = generate 0 200000++elems400000 :: [C01]+elems400000 = generate 0 400000++elems800000 :: [C01]+elems800000 = generate 0 800000+#endif++generate :: Int -> Int -> [C01]+generate o n = map (\x -> C01 x (x `div` s) [x .. x + s]) [o .. (n + o) - 1]+ where+ s = 5++
+ benchmarks/src/Common.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} ++module Common+( C01(..)+) where++--------------------------------------------------------------------------------+import Control.DeepSeq (NFData(..))+import Data.Data+--------------------------------------------------------------------------------+import qualified Data.Store.Internal.Type as DS+--------------------------------------------------------------------------------++data C01 = C01 + {-# UNPACK #-} !Int+ {-# UNPACK #-} !Int+ ![Int]+ deriving (Eq, Ord, Show, Typeable)++instance NFData C01 where+ rnf (C01 x y z) = rnf x `seq` rnf y `seq` rnf z+
+ benchmarks/src/DS/B01.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE TypeOperators #-}++module DS.B01+where++--------------------------------------------------------------------------------+import Control.Lens+--------------------------------------------------------------------------------+import Common (C01(..))+--------------------------------------------------------------------------------+import qualified Data.Store as S+import Data.Store (M, O, (.:), (.:.), (:.)(..), (.<), (.<=), (.>), (.>=), (./=), (.==), (.&&), (.||))+import Data.Store.Lens+--------------------------------------------------------------------------------++size :: DS -> Int+size = S.size++data DSTag = DSTag++type DSTS = Int :. Int :. Int+type DSKRS = O :. O :. M+type DSIRS = O :. M :. M++type DS = S.Store DSTag DSKRS DSIRS DSTS C01+type DSKey = S.Key DSKRS DSTS+type DSRawKey = S.RawKey DSKRS DSTS+type DSSel = S.Selection DSTag DSKRS DSIRS DSTS++key :: C01 -> DSKey+key (C01 d1 d2 d3) = S.dimO d1 .: S.dimO d2 .:. S.dimM d3+{-# INLINE key #-}++sD1 :: (DSTag, S.N0)+sD1 = (DSTag, S.n0)+{-# INLINE sD1 #-}++sD2 :: (DSTag, S.N1)+sD2 = (DSTag, S.n1)+{-# INLINE sD2 #-}++sD3 :: (DSTag, S.N2)+sD3 = (DSTag, S.n2)+{-# INLINE sD3 #-}++insert :: C01 -> DS -> DS+insert e s = snd $! S.insert' (key e) e s++insertUnsafe :: C01 -> DS -> DS+insertUnsafe e s = snd $! S.unsafeInsert (key e) e s++lookupOOEQ :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]+lookupOOEQ x = S.lookup (sD1 .== x)++lookupOOEQLens :: Int -> DS -> DS+lookupOOEQLens x o = o ^. with (sD1 .== x) ++lookupOOGE :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]+lookupOOGE x = S.lookup (sD1 .>= x)++lookupOOGELens :: Int -> DS -> DS+lookupOOGELens x o = o ^. with (sD1 .>= x)++lookupOMEQ :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]+lookupOMEQ x = S.lookup (sD2 .== x)++lookupOMEQLens :: Int -> DS -> DS+lookupOMEQLens x o = o ^. with (sD2 .== x)++lookupOMGE :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]+lookupOMGE x = S.lookup (sD2 .>= x)++lookupOMGELens :: Int -> DS -> DS+lookupOMGELens x o = o ^. with (sD2 .>= x)++lookupMMEQ :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]+lookupMMEQ x = S.lookup (sD3 .== x)++lookupMMEQLens :: Int -> DS -> DS +lookupMMEQLens x o = o ^. with (sD3 .== x)++empty :: DS+empty = S.empty++{-+gen n = map (\x -> C01 x (x `div` 5) [x .. x + 5]) [0 .. (n - 1)]+gen' n = map (\x -> C01 (x `div` 2) (x `div` 5) [x .. x + 5]) [0 .. (n - 1)]+store = foldl' (flip DS.B01.insert) empty $! gen 8+newKey (C01 _ d2 d3) = key $ C01 0 d2 d3+storeU = S.updateWithKey' (\_ e -> Just (e, Just $ newKey e)) (sD1 .>= 0) store+-}
+ benchmarks/src/TS/B01.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} ++module TS.B01+where++--------------------------------------------------------------------------------+import Control.Applicative+import Control.DeepSeq (NFData(..))+import Control.Lens+--------------------------------------------------------------------------------+import qualified Data.IntSet+--------------------------------------------------------------------------------+import Common (C01(..))+--------------------------------------------------------------------------------+import qualified Data.Table as T+--------------------------------------------------------------------------------++size :: T.Table t -> Int+size = T.count++instance T.Tabular C01 where+ type PKT C01 = Int+ data Key k C01 b where+ D1 :: T.Key T.Primary C01 Int+ D2 :: T.Key T.SupplementalInt C01 Int+ D3 :: T.Key T.InvertedInt C01 Data.IntSet.IntSet+ data Tab C01 i = C01IX+ { ixd1 :: i T.Primary Int+ , ixd2 :: i T.SupplementalInt Int+ , ixd3 :: i T.InvertedInt Data.IntSet.IntSet+ }++ fetch D1 (C01 x _ _) = x+ fetch D2 (C01 _ x _) = x+ fetch D3 (C01 _ _ x) = Data.IntSet.fromList x++ primary = D1+ primarily D1 r = r++ mkTab f =+ C01IX <$> f D1+ <*> f D2+ <*> f D3+ + forTab (C01IX d1 d2 d3) f =+ C01IX <$> f D1 d1+ <*> f D2 d2+ <*> f D3 d3++ ixTab (C01IX x _ _) D1 = x+ ixTab (C01IX _ x _) D2 = x+ ixTab (C01IX _ _ x) D3 = x++instance NFData (T.Tab C01 (T.AnIndex C01)) where+ rnf (C01IX x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3++type TS = T.Table C01++insert :: C01 -> TS -> TS+insert = T.insert++lookupOOEQ :: Int -> TS -> TS+lookupOOEQ x o = o ^. T.with D1 (==) x ++lookupOOGE :: Int -> TS -> TS+lookupOOGE x o = o ^. T.with D1 (>=) x++lookupOMEQ :: Int -> TS -> TS+lookupOMEQ x o = o ^. T.with D2 (==) x++lookupOMGE :: Int -> TS -> TS+lookupOMGE x o = o ^. T.with D2 (>=) x++lookupMMEQ :: Int -> TS -> TS+lookupMMEQ x o = o ^. T.withAny D3 [x]++empty :: TS+empty = T.empty+
+ data-store.cabal view
@@ -0,0 +1,107 @@+name: data-store+version: 0.3.0++synopsis: Type safe, in-memory dictionary with multidimensional keys.+description: Type safe, in-memory dictionary with multidimensional keys.+ Similar to ixset, higgsset, tables. But offers: type safe interface,+ auto-increment dimensions, specifying the relationships between the key dimension and the elements (one-one, one-many, many-one, many-many), performance. ++homepage: https://github.com/Palmik/data-store ++license: BSD3+license-file: LICENSE++author: Petr Pilař+maintainer: maintainer+the.palmik@gmail.com++category: Data++build-type: Simple+cabal-version: >= 1.8++source-repository head+ type: git+ location: git://github.com/Palmik/data-store.git+ branch: master++library+ hs-source-dirs: src+ exposed-modules:+ Data.Store+ , Data.Store.Selection+ , Data.Store.Storable+ , Data.Store.Lens+ + , Data.Store.Internal.Type+ , Data.Store.Internal.Function+ + other-modules:+ Data.Map.Extra+ , Data.IntSet.Extra++ build-depends:+ base >= 4.6 && < 5+ , containers >= 0.4 && < 1+ , lens >= 3.9 && < 4+ , transformers >= 0.2 && < 0.3+ , vector >= 0.10 && < 0.2++ , cereal >= 0.3.5 && < 0.4+ , deepseq >= 1.3.0 && < 1.4+ , safecopy >= 0.8 && < 0.9+ ghc-options: -O2 -Wall++test-suite data-store-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests, src+ main-is: Main.hs++ other-modules:+ Test.Data.Store01++ , Data.Store + , Data.Store.Lens + + build-depends:+ base >= 4.5+ , vector >= 0.10+ , containers >= 0.4+ , lens >= 3.9+ , transformers >= 0.2+ , tagged >= 0.4++ , test-framework >= 0.8+ , test-framework-quickcheck2 >= 0.3+ , QuickCheck >= 2.4 && < 2.6++benchmark data-store-benchmark-01+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmarks/src, src+ main-is: 01.hs++ other-modules:+ Common+ , DS.B01+ , TS.B01+++ build-depends:+ base >= 4.5+ , vector >= 0.9+ , containers >= 0.4+ , lens >= 3.9+ , transformers >= 0.2+ , unordered-containers >= 0.2+ , tagged >= 0.4+ , mtl >= 2.1++ , ixset+ , tables >= 0.3.1.1+ , lens >= 3.8+ , bytestring + , criterion >= 0.6.2+ , deepseq >= 1.3.0+ , random >= 1.0.1+ + ghc-options: -Wall -O2+
+ src/Data/IntSet/Extra.hs view
@@ -0,0 +1,41 @@+module Data.IntSet.Extra+( foldrM+, foldrM'+, foldlM+, foldlM'+) where++--------------------------------------------------------------------------------+import qualified Data.IntSet+--------------------------------------------------------------------------------++-- TODO: Measure INLINE/SPECIALIZE tradeoff.++-- | Monadic fold over the elements of a `Data.IntSet.IntSet`,+-- associating to the right, i.e. from right to left. +foldrM :: Monad f => (Int -> b -> f b) -> b -> Data.IntSet.IntSet -> f b+foldrM go start = Data.IntSet.foldr (\i acc -> acc >>= go i) (return start)+{-# INLINE foldrM #-}+--{-# SPECIALIZE foldrM :: (Int -> b -> Maybe b) -> b -> Data.IntSet.IntSet -> Maybe b #-}++-- | Strict monadic fold over the elements of a `Data.IntSet.IntSet`,+-- associating to the right, i.e. from right to left. +foldrM' :: Monad f => (Int -> b -> f b) -> b -> Data.IntSet.IntSet -> f b+foldrM' go start = Data.IntSet.foldr' (\i acc -> acc >>= go i) (return start)+{-# INLINE foldrM' #-}+--{-# SPECIALIZE foldrM' :: (Int -> b -> Maybe b) -> b -> Data.IntSet.IntSet -> Maybe b #-}++-- | Monadic fold over the elements of a `Data.IntSet.IntSet`,+-- associating to the left, i.e. from left to right. +foldlM :: Monad f => (b -> Int -> f b) -> b -> Data.IntSet.IntSet -> f b+foldlM go start = Data.IntSet.foldl (\acc i -> acc >>= flip go i) (return start)+{-# INLINE foldlM #-}+--{-# SPECIALIZE foldlM :: (b -> Int -> Maybe b) -> b -> Data.IntSet.IntSet -> Maybe b #-}++-- | Monadic fold over the elements of a `Data.IntSet.IntSet`,+-- associating to the left, i.e. from left to right. +foldlM' :: Monad f => (b -> Int -> f b) -> b -> Data.IntSet.IntSet -> f b+foldlM' go start = Data.IntSet.foldl' (\acc i -> acc >>= flip go i) (return start)+{-# INLINE foldlM' #-}+--{-# SPECIALIZE foldlM' :: (b -> Int -> Maybe b) -> b -> Data.IntSet.IntSet -> Maybe b #-}+
+ src/Data/Map/Extra.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE CPP #-}++module Data.Map.Extra+( insertUnique+) where++--------------------------------------------------------------------------------+import qualified Data.Map.Strict as Data.Map+--------------------------------------------------------------------------------++-- | The expression (@insertUnique k v old@)+-- returns (@Just (Data.Map.insert k v old)@) if the map @old@ did not contain+-- anything under the key @k@, otherwise returns @Nothing@.+insertUnique :: Ord k => k -> a -> Data.Map.Map k a -> Maybe (Data.Map.Map k a)+insertUnique k a m =+ case Data.Map.insertLookupWithKey (\_ _ o' -> o') k a m of+ (Nothing, res) -> Just res+ (Just _, _) -> Nothing+{-# INLINE insertUnique #-}+
+ src/Data/Store.hs view
@@ -0,0 +1,673 @@+{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Store +-- Copyright : (c) Petr Pilar 2012 +-- License : BSD-style +-- +-- Dictionary with multidimensional keys and type-safe interface. +-- +-- These modules are intended to be imported qualified to avoid name +-- clashes with prelude, e.g.: +-- +-- > import qualified Data.Store as S +-- > import Data.Store (M, O, (.:), (.:.), (:.), (.<), (.<=), (.>), (.>=), (./=), (.==), (.&&), (.||)) +-- +-- Throughout out the documentation, the examples will be based on this +-- code: +-- +-- > {-# LANGUAGE TypeOperators #-} +-- > +-- > module Example01 +-- > where +-- > +-- > -------------------------------------------------------------------------------- +-- > import Control.Applicative +-- > import qualified Control.Monad.State as State +-- > -------------------------------------------------------------------------------- +-- > import qualified Data.Store as S +-- > import Data.Store (M, O, (.:), (.:.), (:.)(..), (.<), (.<=), (.>), (.>=), (./=), (.==), (.&&), (.||)) +-- > -------------------------------------------------------------------------------- +-- > +-- > data Content = Content +-- > { contentName :: String +-- > , contentBody :: String +-- > , contentTags :: [String] +-- > , contentRating :: Double +-- > } +-- > +-- > type ContentID = Int +-- > +-- > -- Content has one ID, only one content can have a given ID. +-- > -- Content has one name, only one content can have a given name. +-- > -- Content has one body, many contents can have the same content. +-- > -- Content has many tags, many contents can have the same tag. +-- > -- Content has one rating, many contents can have the same rating. +-- > +-- > data ContentStoreTag = ContentStoreTag +-- > +-- > type ContentStoreTS = ContentID :. String :. String :. String :. Double +-- > type ContentStoreKRS = O :. O :. O :. M :. O +-- > type ContentStoreIRS = O :. O :. M :. M :. M +-- > type ContentStore = S.Store ContentStoreTag ContentStoreKRS ContentStoreIRS ContentStoreTS Content +-- > type ContentStoreKey = S.Key ContentStoreKRS ContentStoreTS +-- > type ContentStoreSelection = S.Selection ContentStoreTag ContentStoreKRS ContentStoreIRS ContentStoreTS +-- > +-- > sContentID :: (ContentStoreTag, S.N0) +-- > sContentID = (ContentStoreTag, S.n0) +-- > +-- > sContentName :: (ContentStoreTag, S.N1) +-- > sContentName = (ContentStoreTag, S.n1) +-- > +-- > sContentBody :: (ContentStoreTag, S.N2) +-- > sContentBody = (ContentStoreTag, S.n2) +-- > +-- > sContentTag :: (ContentStoreTag, S.N3) +-- > sContentTag = (ContentStoreTag, S.n3) +-- > +-- > sContentRating :: (ContentStoreTag, S.N4) +-- > sContentRating = (ContentStoreTag, S.n4) +-- +-- Glossary +-- +-- * Key (type/value) -- refers either to the type or value of a key of the +-- store. +-- +-- * Key dimension -- refers to one dimension of a key (e.g.: article's +-- author, article's tag). Refers to the dimension as a whole, together +-- with its properties, etc. +-- +-- * Key dimension value -- refers to some concrete value from the domain of the +-- dimension. +-- +-- * Element (type/value) -- refers either to the type or value of the elements +-- (in literature, the term \"value\" is usually used, be here it would +-- clash far too often) of the store. +-- +-- The implementation is based on "Data.Map", "Data.Set", "Data.IntMap" and +-- "Data.IntSet". +-- +-- The following variables and constants are used in Big-O notation: +-- +-- * /W/ -- the (constant) number of bits of "Int" (32 or 64). +-- +-- * /d/ -- the (constant) number of dimensions of the store. +-- +-- * /k/ -- the (variable) number of key dimensions values of a key (or +-- maximum of key dimension values over all keys in case of for example +-- @'Data.Store.update'@). +-- +-- * /s/ -- the (variable) size of the output of the operation or the +-- (variable) number of elements affected by the operation. This is +-- of then the number of key-element pairs that correspond to a selection. +-- +-- * /s(sel)/ -- the (variable) number of key-element pairs that correspond +-- to a selection /sel/ if /sel/ would otherwise be ambigious. +-- +-- * /c/ -- the (variable) complexity of selection. +-- +-- * /c/ -- the (variable) complexity of selection /sel/ if /sel/ +-- would otherwise be ambiguous. +module Data.Store +( + -- * Types + I.Store +, I.Key +, I.KeyDimension +, I.RawKey +, I.M +, I.O +, (I.:.)(..) +, I.Auto + + -- * Creating +, I.empty +, singleton + + -- * Inserting +, insert +, insert' +, unsafeInsert + + -- * Updating +, updateWithKey +, updateWithKey' +, update +, update' +, updateElements +, delete + + -- * Traversing +, map + + -- * Folding +, foldr +, foldrWithKey + +, foldl +, foldlWithKey + + -- * List +, toList +, elements +, keys +, fromList +, fromList' +, unsafeFromList + + -- * Querying +, size +, lookup + + -- ** Selection + -- + -- $selection +, Selection +, not +, (.<) +, (.<=) +, (.>) +, (.>=) +, (./=) +, (.==) +, (.&&) +, (.||) + + -- * Constructing Key + -- + -- $constructing-key +, dimA +, dimO +, dimM +, (.:) +, (.:.) + + -- * Utility +, I.S(..) +, I.Z +, I.N0 +, I.N1 +, I.N2 +, I.N3 +, I.N4 +, I.N5 +, I.N6 +, I.N7 +, I.N8 +, I.N9 +, I.N10 +, I.n0 +, I.n1 +, I.n2 +, I.n3 +, I.n4 +, I.n5 +, I.n6 +, I.n7 +, I.n8 +, I.n9 +, I.n10 + + -- * Debugging +, showIndex +, printIndex +, moduleName +) where + +-------------------------------------------------------------------------------- +import Prelude hiding (lookup, map, foldr, foldl, not) +-------------------------------------------------------------------------------- +import Control.Applicative hiding (empty) +-------------------------------------------------------------------------------- +import Data.Monoid +import Data.Maybe +import Data.Functor.Identity +import qualified Data.IntMap.Strict as Data.IntMap +import qualified Data.List +import qualified Data.Foldable +-------------------------------------------------------------------------------- +import qualified Data.Store.Internal.Type as I +import qualified Data.Store.Internal.Function as I +import Data.Store.Selection +-------------------------------------------------------------------------------- + +-- | The name of this module. +moduleName :: String +moduleName = "Data.Store" +{-# INLINE moduleName #-} + +-- INTERFACE + +-- $selection +-- Functions from this category are used to create selections. +-- +-- Example: +-- +-- > -- Select any content with rating between 3 and 4. +-- > let sel1 = sContentRating .> 3 +-- > +-- > -- Select any content that is tagged with "haskell" or "category-theory" +-- > -- and is not tagged with "fluff". +-- > let sel2 = (sContentTag .== "haskell" .|| sContentTag .== "category-theory") .&& not' (sContentTag .== "fluff") +-- > +-- > -- Selection that is intersection of sel1 and sel2. +-- > let sel3 = sel1 .&& sel2 +-- +-- These selections can be then used in functions like lookup, update, +-- delete, etc. +-- +-- >>> lookup sel3 store +-- > -- key-element pairs that match the selection +-- +-- >>> delete (not' sel3) store +-- > -- store with the key-element pairs that do not match the selection +-- +-- >>> updateElements (\v -> Just v { contentRating = 5 }) sel3 store +-- > -- store with the selected key-element pairs updated + + +-- $constructing-key +-- Functions from this category are used to create a key for your store. Function for +-- creating a key for our @Content@ data type could look like this: +-- +-- > makeContentKey :: ContentID -> String -> String -> [String] -> Double -> ContentStoreKey +-- > makeContentKey cid cn cb cts cr = +-- > S.dimO cid .: S.dimO cn .: S.dimO cb .: S.dimM cts .:. S.dimO cr +-- +-- Notice that this function allows you to specify all the dimensions of +-- the key, including the ID dimension. Usually we do not need this level +-- of flexibility a would use function like this instead: +-- +-- > contentKey :: Content -> ContentStoreKey +-- > contentKey (Content cn cb cts cr) = +-- > S.dimA .: S.dimO cn .: S.dimO cb .: S.dimM cts .:. S.dimO cr +-- +-- This function creates a key for given element of type @Content@ (element), the ID +-- dimension is "automatic", which means that the assigned ID will be @succ +-- max@ where @max@ is the value of the maximum ID in the store when +-- inserting. +-- +-- See also: +-- +-- * 'Data.Store.Storable.Storable' + +-- | Function for creating an auto-increment dimension. Can be used instead +-- of (@dimO x@) if the type is an instance of the +-- @'Data.Store.Internal.Auto'@ type-class. +dimA :: I.Auto t => I.KeyDimension I.O t +dimA = I.KeyDimensionA +{-# INLINE dimA #-} + +-- | Function for creating dimensions with the relation +-- \"one-<anything>\". +dimO :: Ord t => t -> I.KeyDimension I.O t +dimO = I.KeyDimensionO +{-# INLINE dimO #-} + +-- | Function for creating dimensions with the relation +-- \"many-<anything>\". +dimM :: Ord t => [t] -> I.KeyDimension I.M t +dimM = I.KeyDimensionM +{-# INLINE dimM #-} + +-- | Function for connecting one dimension and rest of the key. +(.:) :: dim r t + -> I.GenericKey dim rs1 ts1 + -> I.GenericKey dim (r I.:. rs1) (t I.:. ts1) +(.:) = I.KN +{-# INLINE (.:) #-} +infixr 3 .: + +-- | Function for connecting one dimensions with another (most often the +-- last dimension of the key). +(.:.) :: dim r1 t1 + -> dim r2 t2 + -> I.GenericKey dim (r1 I.:. r2) (t1 I.:. t2) +(.:.) d1 d2 = I.KN d1 (I.K1 d2) +{-# INLINE (.:.) #-} +infixr 3 .:. + +-- CREATING + + +-- | The expression (@'Data.Store.singleton' k v@) is store that contains +-- only the @(k, v)@ as a key-element pair. +singleton :: I.Empty (I.Index irs ts) + => I.Key krs ts -> v -> I.Store tag krs irs ts v +singleton k v = snd . fromJust $ insert k v I.empty +{-# INLINE singleton #-} + +-- INSERTING + +-- | The expression (@'Data.Store.insert' k e old@) is either +-- @Nothing@ if inserting the @(k, e)@ key-element pair would cause +-- a collision or (@Just (rk, new)@), where @rk@ is the raw key of +-- @k@ and @new@ is store containing the same key-element pairs as @old@ plus +-- @(k, e)@. +-- +-- Examples: +-- +-- >>> let content = Content "name" "body" ["t1", "t2"] 0.5 +-- >>> insert (contentKey content) content store +-- > Just (1 :. "name" :. "body" :. ["t1", "t2"] :. 0.5, <updated_store>) +-- +-- See also: +-- +-- * 'Data.Store.insert'' +-- * 'Data.Store.Internal.Type.Key' +-- * 'Data.Store.Internal.Type.RawKey' +insert :: I.Key krs ts + -> v + -> I.Store tag krs irs ts v + -> Maybe (I.RawKey krs ts, I.Store tag krs irs ts v) +insert k v old@(I.Store _ index _) = + (\res -> (I.keyInternalToRaw internal, res)) <$> I.genericInsert I.indexInsertID internal v old + where + internal = I.keyToInternal index k + +-- | The expression (@'Data.Store.insert'' k v old@) is @(rk, new)@, +-- where @rk@ is the raw key of @k@ and @new@ is a store that contains +-- the same key-element pairs as @old@ plus @(k, e)@. +-- Any key-value pairs from @old@ colliding with @(k, e)@ are not included in @new@. +-- +-- See also: +-- +-- * 'Data.Store.insert' +-- * 'Data.Store.Internal.Type.Key' +-- * 'Data.Store.Internal.Type.RawKey' +insert' :: I.Key krs ts + -> e + -> I.Store tag krs irs ts e + -> (I.RawKey krs ts, I.Store tag krs irs ts e) +insert' k e old@(I.Store _ index _) = + (I.keyInternalToRaw internal, runIdentity $! I.genericInsert I.indexInsertID' internal e old) + where + internal = I.keyToInternal index k +{-# INLINE insert' #-} + +-- | UNSAFE! This function can corrupt the store. +-- +-- The expression (@'Data.Store.unsafeInsert' k v old@) is @(rk, new)@, +-- where @rk@ is the raw key of @k@ and @new@ is a store that contains +-- the same key-element pairs as @old@ plus @(k, e)@. +-- Any key-value pairs from @old@ colliding with @(k, e)@ will cause UNDEFINED BEHAVIOUR. +-- +-- See also: +-- +-- * 'Data.Store.insert' +-- * 'Data.Store.insert'' +-- * 'Data.Store.Internal.Type.Key' +-- * 'Data.Store.Internal.Type.RawKey' +unsafeInsert :: I.Key krs ts + -> e + -> I.Store tag krs irs ts e + -> (I.RawKey krs ts, I.Store tag krs irs ts e) +unsafeInsert k e old@(I.Store _ index _) = + (I.keyInternalToRaw internal, runIdentity $! I.genericInsert I.indexInsertID'' internal e old) + where + internal = I.keyToInternal index k +{-# INLINE unsafeInsert #-} + +-- TRAVERSING + +-- | The expression @('Data.Store.map' tr old@) is store where every element of +-- @old@ was transformed using the function @tr@. +map :: (v1 -> v2) -> I.Store tag krs irs ts v1 -> I.Store tag krs irs ts v2 +map tr store@(I.Store vs _ _) = store + { I.storeV = Data.IntMap.map (\(ik, v) -> (ik, tr v)) vs + } +{-# INLINE map #-} + +-- QUERYING + +-- | The expression (@'Data.Store.Selection.lookup' sel store@) is +-- list of (raw key)-element pairs that match the selection. +-- +-- Complexity: /O(c + s * min(n, W))/ +lookup :: IsSelection sel => sel tag krs irs ts -> I.Store tag krs irs ts v -> [(I.RawKey krs ts, v)] +lookup sel s = I.genericLookup (resolve sel s) s +{-# INLINE lookup #-} + +-- | The expression (@'Data.Store.size' store@) is the number of elements +-- in @store@. +size :: I.Store tag krs irs ts v -> Int +size (I.Store vs _ _) = Data.IntMap.size vs +{-# INLINE size #-} + +-- UPDATING + +-- | The expression (@'Data.Store.updateWithKey' tr sel old@) +-- is (@Just new@) where @new@ is a store containing the same key-element +-- pairs as @old@ except for any key-element pairs @(k, e)@ that match the +-- selection @sel@, those are updated as follows: +-- +-- * If @(tr k e)@ is @Nothing@ the pair is not included in @new@. +-- * If @(tr k e)@ is (@Just (e', Nothing)@) the pair is replaced by pair @(k, e')@. +-- * If @(tr k e)@ is (@Just (e', Just k')@) the pair is replaced by pair @(k', e')@. +-- +-- If any of the updated key-element pairs would cause a collision, the +-- result is @Nothing@. +-- +-- Complexity: /O(c + s * (min(n, W) + q * log n))/ +-- +-- See also: +-- +-- * 'Data.Store.updateWithKey'' +updateWithKey :: IsSelection sel + => (I.RawKey krs ts -> v -> Maybe (v, Maybe (I.Key krs ts))) + -> sel tag krs irs ts + -> I.Store tag krs irs ts v + -> Maybe (I.Store tag krs irs ts v) +updateWithKey tr sel s = I.genericUpdateWithKey I.indexInsertID tr (resolve sel s) s +{-# INLINE updateWithKey #-} + +-- | The expression (@'Data.Store.updateWithKey'' tr sel old@) +-- is @new@ where @new@ is a store containing the same key-element +-- pairs as @old@ except for any key-element pairs @(k, e)@ that match the +-- selection @sel@, those are updated as follows: +-- +-- * If @(tr k e)@ is @Nothing@ the pair is not included in @new@. +-- * If @(tr k e)@ is (@Just (e', Nothing)@) the pair is replaced by pair @(k, e')@. +-- * If @(tr k e)@ is (@Just (e', Just k')@) the pair is replaced by pair @(k', e')@. +-- +-- Any pairs of the original store @old@ that would, after the update, cause collisons +-- are not included in @new@. +-- +-- Complexity: /O(c + d * s * (min(n, W) + q * log n))/ +-- +-- See also: +-- +-- * 'Data.Store.updateWithKey' +updateWithKey' :: IsSelection sel + => (I.RawKey krs ts -> v -> Maybe (v, Maybe (I.Key krs ts))) + -> sel tag krs irs ts + -> I.Store tag krs irs ts v + -> I.Store tag krs irs ts v +updateWithKey' tr sel s = runIdentity $! I.genericUpdateWithKey I.indexInsertID' tr (resolve sel s) s +{-# INLINE updateWithKey' #-} + +-- | The expression (@'Data.Store.update' tr sel s@) is equivalent +-- to (@'Data.Store.Selection.updateWithKey' tr' sel s@) where +-- (@tr' = (\_ v -> tr v) = const tr@). +-- +-- Complexity: /O(c + s * (min(n, W) + q * log n))/ +update :: IsSelection sel + => (v -> Maybe (v, Maybe (I.Key krs ts))) + -> sel tag krs irs ts + -> I.Store tag krs irs ts v + -> Maybe (I.Store tag krs irs ts v) +update tr = updateWithKey (const tr) +{-# INLINE update #-} + +-- | The expression (@'Data.Store.update'' tr sel s@) is equivalent +-- to (@'Data.Store.Selection.updateWithKey'' tr' sel s@) where +-- (@tr' = (\_ v -> tr v) = const tr@). +-- +-- Complexity: /O(c + d * s * (min(n, W) + q * log n))/ +update' :: IsSelection sel + => (v -> Maybe (v, Maybe (I.Key krs ts))) + -> sel tag krs irs ts + -> I.Store tag krs irs ts v + -> I.Store tag krs irs ts v +update' tr = updateWithKey' (const tr) +{-# INLINE update' #-} + +-- | The expression (@'Data.Store.updateElements' tr sel s@) is equivalent +-- to (@'Data.Store.Selection.update' tr' sel s@) where +-- (@tr' = (maybe Nothing (\v -> Just (v, Nothing)) . tr)@). +-- +-- Complexity: /O(c + s * min(n, W))/ +updateElements :: IsSelection sel + => (v -> Maybe v) + -> sel tag krs irs ts + -> I.Store tag krs irs ts v + -> I.Store tag krs irs ts v +updateElements tr sel s = + runIdentity $! I.genericUpdateWithKey I.indexInsertID'' tr' (resolve sel s) s + where + tr' _ = maybe Nothing (\v -> Just (v, Nothing)) . tr + {-# INLINE tr' #-} +{-# INLINE updateElements #-} + +-- | The expression (@'Data.Store.Selection.delete' sel old@) is +-- equivalent to +-- (@'Data.Store.fromJust' $ 'Data.Store.Selection.update' (const Nothing) sel old@). +-- +-- Complexity: /O(c + s * (min(n, W) + q * log n)/ +delete :: IsSelection sel + => sel tag krs irs ts + -> I.Store tag krs irs ts v + -> I.Store tag krs irs ts v +delete sel s = + runIdentity $! I.genericUpdateWithKey I.indexInsertID'' (\_ _ -> Nothing) (resolve sel s) s +{-# INLINE delete #-} + +-- FOLDING + +-- | The expression (@'Data.Store.foldrWithKey' f z s@) folds the store +-- using the given right-associative operator. +foldrWithKey :: (I.RawKey krs ts -> v -> b -> b) + -> b + -> I.Store tag krs irs ts v + -> b +foldrWithKey accum start (I.Store vs _ _) = + Data.IntMap.foldr (\(ik, v) b -> accum (I.keyInternalToRaw ik) v b) start vs +{-# INLINE foldrWithKey #-} + +-- | The expression (@'Data.Store.foldr' f z s@) folds the store +-- using the given right-associative binary operator. +foldr :: (v -> b -> b) + -> b + -> I.Store tag krs irs ts v + -> b +foldr accum start (I.Store vs _ _) = + Data.IntMap.foldr (\(_, v) b -> accum v b) start vs +{-# INLINE foldr #-} + +-- | The expression (@'Data.Store.foldlWithKey' f z s@) folds the store +-- using the given left-associative operator. +foldlWithKey :: (b -> I.RawKey krs ts -> v -> b) + -> b + -> I.Store tag krs irs ts v + -> b +foldlWithKey accum start (I.Store vs _ _) = + Data.IntMap.foldl (\b (ik, v) -> accum b (I.keyInternalToRaw ik) v) start vs +{-# INLINE foldlWithKey #-} + +-- | The expression (@'Data.Store.foldl' f z s@) folds the store +-- using the given left-associative binary operator. +foldl :: (b -> v -> b) + -> b + -> I.Store tag krs irs ts v + -> b +foldl accum start (I.Store vs _ _) = + Data.IntMap.foldl (\b (_, v) -> accum b v) start vs +{-# INLINE foldl #-} + +-- LISTS + +-- | The expression (@'Data.Store.toList' store@) is a list of key-element pairs that are stored in @store@. +toList :: I.Store tag krs irs ts v -> [(I.RawKey krs ts, v)] +toList (I.Store vs _ _) = Data.List.map (\(ik, v) -> (I.keyInternalToRaw ik, v)) $ Data.IntMap.elems vs +{-# INLINE toList #-} + +-- | The expression (@'Data.Store.elements' store@) is a list of elements that +-- are stored in @store@. +elements :: I.Store tag krs irs ts v -> [v] +elements (I.Store vs _ _) = Data.List.map snd $ Data.IntMap.elems vs +{-# INLINE elements #-} + +-- | The expression (@'Data.Store.keys' store@) is a list of pairs raw +-- keys that are stored in @store@. +keys :: I.Store tag krs irs ts v -> [I.RawKey krs ts] +keys (I.Store vs _ _) = Data.List.map (I.keyInternalToRaw . fst) $ Data.IntMap.elems vs +{-# INLINE keys #-} + +-- | The expression (@'Data.Store.fromList' kvs@) is either +-- a) (@Just store@) where @store@ is a store containing exactly the given +-- key-element pairs or; +-- b) @Nothing@ if inserting any of the key-element pairs would +-- cause a collision. +-- +-- See also: +-- +-- * 'Data.Store.fromList'' +fromList :: I.Empty (I.Index irs ts) => [(I.Key krs ts, v)] -> Maybe (I.Store tag krs irs ts v) +fromList = Data.Foldable.foldlM (\s (k, v) -> snd <$> insert k v s) I.empty +{-# INLINE fromList #-} + +-- | The expression (@'Data.Store.fromList'' kvs@) is @store@ +-- containing the given key-element pairs (colliding pairs are not included). +-- +-- See also: +-- +-- * 'Data.Store.fromList' +fromList' :: I.Empty (I.Index irs ts) => [(I.Key krs ts, v)] -> I.Store tag krs irs ts v +fromList' = Data.List.foldl' (\s (k, v) -> snd $! insert' k v $! s) I.empty +{-# INLINE fromList' #-} + +-- | UNSAFE! This function can corrupt the store. +-- +-- The expression (@'Data.Store.fromList'' kvs@) is @store@ +-- containing the given key-element pairs (colliding pairs cause UNDEFINED BEHAVIOUR). +-- +-- See also: +-- +-- * 'Data.Store.fromList' +-- * 'Data.Store.fromList' +unsafeFromList :: I.Empty (I.Index irs ts) => [(I.Key krs ts, v)] -> I.Store tag krs irs ts v +unsafeFromList = Data.Foldable.foldl (\s (k, v) -> snd $ unsafeInsert k v s) I.empty +{-# INLINE unsafeFromList #-} + +-- INSTANCES + +instance Functor (I.Store tag krs irs ts) where + fmap = map + {-# INLINE fmap #-} + +instance I.Empty (I.Index irs ts) => Monoid (I.Store tag krs irs ts v) where + mempty = I.empty + {-# INLINE mempty #-} + + mappend oldl (I.Store kes _ _) = + Data.IntMap.foldl (\acc (ik, e) -> runIdentity $! I.genericInsert I.indexInsertID' ik e acc) oldl kes + +-- UTILITY + +showIndex :: Show (I.Index irs ts) => I.Store tag krs irs ts v -> String +showIndex (I.Store _ i _) = show i +{-# INLINE showIndex #-} + +printIndex :: Show (I.Index irs ts) => I.Store tag krs irs ts v -> IO () +printIndex = putStrLn . showIndex +{-# INLINE printIndex #-} + +-- INTERNAL
+ src/Data/Store/Internal/Function.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}++module Data.Store.Internal.Function+where++--------------------------------------------------------------------------------+import Control.Applicative hiding (empty)+--------------------------------------------------------------------------------+import Data.Monoid ((<>))+import Data.Functor.Identity +import qualified Data.List+import qualified Data.IntMap.Strict as Data.IntMap+import qualified Data.Map+import qualified Data.IntSet+import qualified Data.IntSet.Extra+--------------------------------------------------------------------------------+import qualified Data.Store.Internal.Type as I+--------------------------------------------------------------------------------++moduleName :: String+moduleName = "Data.Store.Internal.Function"++genericSubset :: I.Empty (I.Index irs ts)+ => Data.IntSet.IntSet+ -> I.Store tag krs irs ts v+ -> I.Store tag krs irs ts v+genericSubset ids (I.Store vs _ _) =+ Data.IntSet.foldr (\i acc ->+ case Data.IntMap.lookup i vs of+ Just (ik, e) -> runIdentity $! genericInsert indexInsertID'' ik e acc+ _ -> acc+ ) I.empty ids+{-# INLINE genericSubset #-}++genericLookup :: Data.IntSet.IntSet+ -> I.Store tag krs irs ts v+ -> [(I.RawKey krs ts, v)]+genericLookup ids (I.Store vs _ _) = {-# SCC "genericLookup" #-} + Data.IntSet.foldr (\i acc ->+ case Data.IntMap.lookup i vs of+ Just (ik, v) -> (keyInternalToRaw ik, v) : acc+ _ -> acc+ ) [] ids+{-# INLINE genericLookup #-}++genericUpdateWithKey :: (Applicative f, Monad f)+ => (I.IKey krs ts -> Int -> I.Store tag krs irs ts e -> f (I.Store tag krs irs ts e))+ -> (I.RawKey krs ts -> e -> Maybe (e, Maybe (I.Key krs ts)))+ -> Data.IntSet.IntSet+ -> I.Store tag krs irs ts e+ -> f (I.Store tag krs irs ts e)+genericUpdateWithKey ins tr ids old = Data.IntSet.Extra.foldlM' accum old ids+ where+ accum store@(I.Store vs ix nid) i =+ case Data.IntMap.lookup i vs of+ Just (ik, v) ->+ case tr (keyInternalToRaw ik) v of+ -- User wants to update the element & key.+ Just (nv, Just nk) -> let nik = mergeKeys nk ik in + if nik /= ik+ -- The keys are different: update the element & key.+ then insertPair i nik nv <$> ins nik i (store { I.storeI = indexDeleteID ik i ix })+ -- The keys are identical: update the element.+ else pure $! insertPair i nik nv store++ -- Update the element.+ Just (nv, Nothing) -> pure $! insertPair i ik nv store++ -- Delete.+ Nothing -> pure I.Store+ { I.storeV = Data.IntMap.delete i vs+ , I.storeI = indexDeleteID ik i ix+ , I.storeNID = nid+ }+ _ -> pure store+ {-# INLINEABLE accum #-}+ + insertPair i' ik' e' s'@(I.Store es' _ _) = s' + { I.storeV = Data.IntMap.insert i' (ik', e') es'+ }+ {-# INLINE insertPair #-}+{-# INLINE genericUpdateWithKey #-}+++mergeKeys :: I.Key krs ts -> I.IKey krs ts -> I.IKey krs ts+mergeKeys (I.K1 I.KeyDimensionA) ik@(I.K1 _) = ik+mergeKeys (I.K1 (I.KeyDimensionO d)) (I.K1 _) = I.K1 (I.IKeyDimensionO d)+mergeKeys (I.K1 (I.KeyDimensionM d)) (I.K1 _) = I.K1 (I.IKeyDimensionM d)+mergeKeys (I.KN I.KeyDimensionA s) (I.KN ik is) = I.KN ik $ mergeKeys s is+mergeKeys (I.KN (I.KeyDimensionO d) s) (I.KN _ is) = I.KN (I.IKeyDimensionO d) $ mergeKeys s is+mergeKeys (I.KN (I.KeyDimensionM d) s) (I.KN _ is) = I.KN (I.IKeyDimensionM d) $ mergeKeys s is+mergeKeys _ _ = error $ moduleName <> ".genericUpdate.mergeKeys: The impossible happened."+{-# INLINEABLE mergeKeys #-}++keyInternalToRaw :: I.IKey krs ts -> I.RawKey krs ts+keyInternalToRaw (I.K1 (I.IKeyDimensionO x)) = x+keyInternalToRaw (I.K1 (I.IKeyDimensionM x)) = x+keyInternalToRaw (I.KN (I.IKeyDimensionO x) s) = x I.:. keyInternalToRaw s+keyInternalToRaw (I.KN (I.IKeyDimensionM x) s) = x I.:. keyInternalToRaw s+{-# INLINE keyInternalToRaw #-}++keyFromInternal :: I.IKey krs ts -> I.Key krs ts+keyFromInternal (I.K1 (I.IKeyDimensionO x)) = I.K1 (I.KeyDimensionO x)+keyFromInternal (I.K1 (I.IKeyDimensionM x)) = I.K1 (I.KeyDimensionM x)+keyFromInternal (I.KN (I.IKeyDimensionO x) s) = I.KN (I.KeyDimensionO x) (keyFromInternal s)+keyFromInternal (I.KN (I.IKeyDimensionM x) s) = I.KN (I.KeyDimensionM x) (keyFromInternal s)++keyToInternal :: I.Index irs ts -> I.Key krs ts -> I.IKey krs ts+keyToInternal (I.I1 ix) (I.K1 I.KeyDimensionA) = I.K1 (I.IKeyDimensionO $! nextKey ix) +keyToInternal (I.I1 _) (I.K1 (I.KeyDimensionO x)) = I.K1 (I.IKeyDimensionO x) +keyToInternal (I.I1 _) (I.K1 (I.KeyDimensionM x)) = I.K1 (I.IKeyDimensionM x) +keyToInternal (I.IN ix is) (I.KN I.KeyDimensionA s) = I.KN (I.IKeyDimensionO $! nextKey ix) $ keyToInternal is s+keyToInternal (I.IN _ is) (I.KN (I.KeyDimensionO x) s) = I.KN (I.IKeyDimensionO x) $ keyToInternal is s+keyToInternal (I.IN _ is) (I.KN (I.KeyDimensionM x) s) = I.KN (I.IKeyDimensionM x) $ keyToInternal is s +keyToInternal _ _ = error $ moduleName <> ".insert.keyToInternal: Impossible happened."+{-# INLINE keyToInternal #-}+ +nextKey :: I.Auto t => I.IndexDimension r t -> t+nextKey i =+ case i of+ (I.IndexDimensionM m) -> nextKey' m+ (I.IndexDimensionO m) -> nextKey' m+ where+ nextKey' m = if Data.Map.null m+ then minBound+ else succ . fst $! Data.Map.findMax m+ {-# INLINE nextKey' #-}+{-# INLINE nextKey #-}++genericInsert :: Applicative f + => (I.IKey krs ts -> Int -> I.Store tag krs irs ts e -> f (I.Store tag krs irs ts e))+ -> I.IKey krs ts+ -> e+ -> I.Store tag krs irs ts e+ -> f (I.Store tag krs irs ts e)+genericInsert ins ik e old@(I.Store _ _ nid) = go <$> ins ik nid old+ where+ go s'@(I.Store es' _ _) = s'+ { I.storeV = Data.IntMap.insert nid (ik, e) es'+ , I.storeNID = nid + 1+ }+ {-# INLINE go #-}+{-# INLINE genericInsert #-}++-- | Inserts the given element identifier into the store's index under the given+-- internal key.+--+-- In case of collisions: returns 'Data.Maybe.Nothing'.+indexInsertID :: I.IKey krs ts+ -> Int+ -> I.Store tag krs irs ts e+ -> Maybe (I.Store tag krs irs ts e)+indexInsertID ik eid old@(I.Store _ index _) =+ if Data.List.null $ findCollisions ik index+ then Just $! runIdentity $! indexInsertID'' ik eid old+ else Nothing+{-# INLINE indexInsertID #-}++-- | Inserts the given element identifier into the store's index under the given+-- internal key.+--+-- In case of collisions: deletes them.+indexInsertID' :: I.IKey krs ts+ -> Int+ -> I.Store tag krs irs ts e+ -> Identity (I.Store tag krs irs ts e)+indexInsertID' ik eid old@(I.Store _ index _) = --{-# SCC "indexInsertID'" #-} + indexInsertID'' ik eid $! Data.IntSet.foldl' go old collisions+ where+ go s'@(I.Store es' ix' _) i =+ case Data.IntMap.updateLookupWithKey (\_ _ -> Nothing) i es' of+ (Just (ik', _), v'') -> s'+ { I.storeV = v''+ , I.storeI = indexDeleteID ik' i ix'+ } + _ -> error $ moduleName <> ".insertInternal'.go: The impossible happened."+ {-# INLINEABLE go #-}++ collisions = Data.IntSet.delete eid $! Data.IntSet.fromList $! findCollisions ik index+ {-# INLINE collisions #-}+{-# INLINE indexInsertID' #-}++-- | UNSAFE. Inserts the given element identifier into the store's index under the given+-- internal key.+-- +-- In case of collisions: ignores them.+indexInsertID'' :: I.IKey krs ts+ -> Int+ -> I.Store tag krs irs ts e+ -> Identity (I.Store tag krs irs ts e)+indexInsertID'' ik eid old@(I.Store _ index _) = --{-# SCC "indexInsertID''" #-}+ zipped `seq` Identity $! old { I.storeI = zipped }+ where+ zipped = zipD ik index++ zipD :: I.IKey krs ts -> I.Index irs ts -> I.Index irs ts+ zipD (I.KN kd kt) (I.IN ixd it) = I.IN (combine kd ixd) $! zipD kt it+ zipD (I.K1 kd) (I.I1 ixd) = I.I1 $! combine kd ixd+ zipD _ _ = error $ moduleName <> ".indexInsertID''.zipD: The impossible happened."+ {-# INLINE zipD #-}++ combine :: I.IKeyDimension krs ts -> I.IndexDimension irs ts -> I.IndexDimension irs ts+ combine kd ixd =+ case (ixd, kd) of+ (I.IndexDimensionO m, I.IKeyDimensionO k) ->+ I.IndexDimensionO $! goO k eid m+ + (I.IndexDimensionO m, I.IKeyDimensionM ks) ->+ I.IndexDimensionO $! Data.List.foldl' (\acc k -> goO k eid acc) m ks ++ (I.IndexDimensionM m, I.IKeyDimensionO k) ->+ I.IndexDimensionM $! goM k eid $! m++ (I.IndexDimensionM m, I.IKeyDimensionM ks) ->+ I.IndexDimensionM $! Data.List.foldl' (\acc k -> goM k eid acc) m ks+ {-# INLINEABLE combine #-}++ goO :: Ord k => k -> Int -> Data.Map.Map k Int -> Data.Map.Map k Int+ goO = Data.Map.insert + {-# INLINE goO #-}++ goM :: Ord k => k -> Int -> Data.Map.Map k Data.IntSet.IntSet -> Data.Map.Map k Data.IntSet.IntSet+ goM k e = Data.Map.insertWith (\_ s -> Data.IntSet.insert e s) k (Data.IntSet.singleton e)+ {-# INLINE goM #-}+{-# INLINE indexInsertID'' #-}++findCollisions :: I.IKey krs ts -> I.Index irs ts -> [Int]+findCollisions ik ix = {-# SCC "findCollisions" #-} zipD ik ix [] + where+ zipD :: I.IKey krs ts -> I.Index irs ts -> [Int] -> [Int]+ zipD (I.KN kd kt) (I.IN ixd it) = combine kd ixd . zipD kt it+ zipD (I.K1 kd) (I.I1 ixd) = combine kd ixd+ zipD _ _ = error $ moduleName <> ".findCollisions.zipD: The impossible happened."++ combine :: I.IKeyDimension krs ts -> I.IndexDimension irs ts -> [Int] -> [Int]+ combine kd ixd = + case (ixd, kd) of+ (I.IndexDimensionO m, I.IKeyDimensionO k) -> goO k m+ (I.IndexDimensionO m, I.IKeyDimensionM ks) -> foldr (\k acc -> goO k m . acc) id ks+ _ -> id+ {-# INLINE combine #-}++ goO :: Ord k => k -> Data.Map.Map k Int -> [Int] -> [Int]+ goO k m =+ case Data.Map.lookup k $! m of+ Nothing -> id+ Just i -> (i:)+ {-# INLINE goO #-}++-- | Deletes EID fron an index.+indexDeleteID :: I.IKey krs ts+ -> Int+ -> I.Index irs ts+ -> I.Index irs ts+indexDeleteID ik eid = zipD ik+ where+ zipD :: I.IKey krs ts -> I.Index irs ts -> I.Index irs ts+ zipD (I.KN kd kt) (I.IN ixd it) = I.IN (combine kd ixd) $! zipD kt it+ zipD (I.K1 kd) (I.I1 ixd) = I.I1 $! combine kd ixd+ zipD _ _ = error $ moduleName <> ".indexDeleteID.zipD: The impossible happened."+ {-# INLINEABLE zipD #-}++ combine :: Ord t => I.IKeyDimension kr t -> I.IndexDimension ir t -> I.IndexDimension ir t+ combine key index =+ case (index, key) of+ (I.IndexDimensionO m, I.IKeyDimensionO k) -> I.IndexDimensionO $! goO m k+ (I.IndexDimensionO m, I.IKeyDimensionM ks) -> I.IndexDimensionO $! Data.List.foldl' goO m ks+ (I.IndexDimensionM m, I.IKeyDimensionO k) -> I.IndexDimensionM $! goM m k+ (I.IndexDimensionM m, I.IKeyDimensionM ks) -> I.IndexDimensionM $! Data.List.foldl' goM m ks+ {-# INLINEABLE combine #-}++ goO :: Ord k => Data.Map.Map k Int -> k -> Data.Map.Map k Int+ goO m k = Data.Map.update (\i' -> if i' == eid then Nothing else Just i') k m+ {-# INLINE goO #-}++ goM :: Ord k => Data.Map.Map k Data.IntSet.IntSet -> k -> Data.Map.Map k Data.IntSet.IntSet+ goM m k = Data.Map.update+ (\ids -> let nids = Data.IntSet.delete eid ids in+ if Data.IntSet.null nids+ then Nothing+ else Just nids+ ) k m+ {-# INLINE goM #-}+{-# INLINE indexDeleteID #-}+
+ src/Data/Store/Internal/Type.hs view
@@ -0,0 +1,555 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}++module Data.Store.Internal.Type+where++--------------------------------------------------------------------------------+import Control.Applicative ((<$>), (<*>))+import Control.DeepSeq (NFData(rnf))+--------------------------------------------------------------------------------+import Data.Data (Typeable, Typeable2)+import qualified Data.Data+import qualified Data.List+import qualified Data.Map.Strict as Data.Map+import Data.Monoid ((<>))+import qualified Data.IntMap.Strict as Data.IntMap+import qualified Data.IntSet+import qualified Data.Foldable as F++import qualified Data.SafeCopy as Ser+import qualified Data.Serialize as Ser (Serialize, get, put)+--------------------------------------------------------------------------------++moduleName :: String+moduleName = "Data.Store.Internal.Type"++-- | This is type-level tag for tagging dimensions of key and the index of a store.+-- You can think of @'Data.Store.Internal.Type.M'@ as an abbreviation for+-- "many".+--+-- * When @'Data.Store.Internal.Type.Key'@ dimension is tagged with+-- @'Data.Store.Internal.Type.M'@, it means that a single element can be+-- indexed under multiple key dimension values. Example: @Content@ (element) has+-- many tags.+--+-- * When @'Data.Store.Internal.Type.Index'@ dimension is tagged with+-- @'Data.Store.Internal.Type.M'@, it means that a multiple elements can be+-- indexed under a single key dimension values. Example: One rating can be shared by+-- many @Content@s (elements).+--+-- See also:+--+-- * 'Data.Store.Internal.Type.O'+--+-- * 'Data.Store.Internal.Type.Key'+--+-- * 'Data.Store.Internal.Type.Store'+data M ++-- | This is type-level tag for tagging dimensions of key and the index of a store.+-- You can think of @'Data.Store.Internal.Type.O'@ as an abbreviation for+-- "one".+--+-- * When @'Data.Store.Internal.Type.Key'@ dimension is tagged with+-- @'Data.Store.Internal.Type.O'@, it means that a single element is indexed+-- under exactly one key dimension value. Example: @Content@ (element) has exactly one title.+--+-- * When @'Data.Store.Internal.Type.Index'@ dimension is tagged with+-- @'Data.Store.Internal.Type.O'@, it means that at most one element can be+-- indexed under one key dimension value. Example: One @ContentID@ corresponds+-- to at most one @Content@ (element).+--+-- See also:+--+-- * 'Data.Store.Internal.Type.M'+--+-- * 'Data.Store.Internal.Type.Key'+--+-- * 'Data.Store.Internal.Type.Store'+data O++-- | Type-level zero.+data Z = Z++-- | Type-level successor of a number.+data S n = S n++type N0 = Z+type N1 = S N0+type N2 = S N1+type N3 = S N2+type N4 = S N3+type N5 = S N4+type N6 = S N5+type N7 = S N6+type N8 = S N7+type N9 = S N8+type N10 = S N9++n0 :: N0+n0 = Z+n1 :: N1+n1 = S n0+n2 :: N2+n2 = S n1+n3 :: N3+n3 = S n2+n4 :: N4+n4 = S n3+n5 :: N5+n5 = S n4+n6 :: N6+n6 = S n5+n7 :: N7+n7 = S n6+n8 :: N8+n8 = S n7+n9 :: N9+n9 = S n8+n10 :: N10+n10 = S n9++type family DimensionRelation n rs ts :: *+type instance DimensionRelation Z O ts = O+type instance DimensionRelation Z M ts = M+type instance DimensionRelation Z (r :. rt) (t :. tt) = r+type instance DimensionRelation (S n) (r :. rt) (t :. tt) = DimensionRelation n rt tt++type family DimensionType n rs ts :: *+type instance DimensionType Z M t = t+type instance DimensionType Z O t = t+type instance DimensionType Z (r :. rt) (t :. tt) = t+type instance DimensionType (S n) (r :. rt) (t :. tt) = DimensionType n rt tt++type family RawDimensionType n a :: *+type instance RawDimensionType n (Index irs ts) = IndexDimension (DimensionRelation n irs ts) (DimensionType n irs ts)++-- | The pupose of the @'Data.Store.Internal.Type.RawKey'@ type family is+-- to derive a type of a \"raw key\" that is easier to pattern match against+-- than @'Data.Store.Internal.Key'@.+--+-- Example:+--+-- > RawKey (O :. O :. O :. M :. O) (ContentID :. String :. String :. String :. Double) ~ (ContentID :. String :. String :. [String] :. Double)+type family RawKey kspec tspec :: *+type instance RawKey (O :. rt) (t :. tt) = t :. RawKey rt tt+type instance RawKey (M :. rt) (t :. tt) = [t] :. RawKey rt tt+type instance RawKey O t = t+type instance RawKey M t = [t]++class (Ord k, Enum k, Bounded k) => Auto k where+instance (Ord k, Enum k, Bounded k) => Auto k where++-- | The store data type has four type arguments that define what and how+-- things are stored.+--+-- The @krs@ (key relation specification) and @irs@ (index relation+-- specification) define the relations between the dimensions of the key+-- and the elements. To that end, we use @'Data.Store.Internal.Type.O'@ and+-- @'Data.Store.Internal.Type.M'@ type-level tags and+-- @'Data.Store.Type.Internal.(:.)'@ data type to create tuple of these+-- tags (to describe all the dimensions).+--+-- The possible relations are as follows:+--+-- * One-one: Every intem is indexed under exactly one key dimension value. One key dimension value+-- corresponds to at most one elements.+--+-- * One-many: Every element is indexed under exactly one key dimension value. One key dimension value can+-- correspond to many elements.+--+-- * Many-one: Every element can be indexed under multiple (zero or more) key dimension values. One key dimension value+-- corresponds to at most one elements.+--+-- * Many-many: Every element cab be indexed under multiple (zero or more) key dimension value. One key dimension value+-- can correspond to many elements.+--+-- The @ts@ (type specification) defines the type of the key's dimensions+-- and finally @v@ is the type of the elements stored.+--+-- In our example with @Content@, we have five dimensions: ID, name, body,+-- tags and rating. We would like our store to have these properties:+--+-- * @Content@ has one ID, only one content can have a given ID.+--+-- * @Content@ has one name, only one content can have a given name.+--+-- * @Content@ has one body, many contents can have the same content.+--+-- * @Content@ has many tags, many contents can have tte same tag.+--+-- * @Content@ has one rating, many contents can have the same rating.+--+-- So in our case, we define:+--+-- > type ContentStoreKRS = O :. O :. O :. M :. O+-- > type ContentStoreIRS = O :. O :. M :. M :. M+-- > type ContentStoreTS = ContentID :. String :. String :. String :. Double+-- > type ContentStore = Store ContentStoreKRS ContentStoreIRS ContentStoreTS Content+--+-- See also:+--+-- * 'Data.Store.Internal.Type.O'+--+-- * 'Data.Store.Internal.Type.M'+--+-- * 'Data.Store.Internal.Type.(:.)'+--+-- * 'Data.Store.Internal.Type.Key'+--+data Store tag krs irs ts v = Store+ { storeV :: !(Data.IntMap.IntMap (IKey krs ts, v))+ , storeI :: !(Index irs ts)+ , storeNID :: {-# UNPACK #-} !Int+ } deriving (Typeable)++instance (Show h, Show t) => Show (h :. t) where+ show (h :. t) = show h <> " :. " <> show t++instance (Ser.Serialize (IKey krs ts), Ser.Serialize (Index irs ts), Ser.Serialize v) => Ser.Serialize (Store tag krs irs ts v) where+ get = Store <$> Ser.get <*> Ser.get <*> Ser.get+ put (Store vs ix nid) = Ser.put vs >> Ser.put ix >> Ser.put nid++instance (Ser.SafeCopy (IKey krs ts), Ser.SafeCopy (Index irs ts), Ser.SafeCopy v) => Ser.SafeCopy (Store tag krs irs ts v) where+ getCopy = Ser.contain $ Store <$> Ser.safeGet <*> Ser.safeGet <*> Ser.safeGet+ putCopy (Store vs ix nid) = Ser.contain $ Ser.safePut vs >> Ser.safePut ix >> Ser.safePut nid++instance (Show (IKey krs ts), Show v) => Show (Store tag krs irs ts v) where+ show (Store vs _ _) = "[" <> go <> "]"+ where+ go = Data.List.intercalate "," $ map (\(ik, v) -> "((" <> show ik <> "), " <> show v <> ")")+ $ F.toList vs++data GenericKey dim rs ts where+ KN :: !(dim r t) -> !(GenericKey dim rt tt) -> GenericKey dim (r :. rt) (t :. tt)+ K1 :: !(dim r t) -> GenericKey dim r t++instance Eq (GenericKey IKeyDimension rs ts) where+ (K1 x) == (K1 y) = x == y+ (KN x xt) == (KN y yt) = x == y && xt == yt+ _ == _ = False ++ (K1 x) /= (K1 y) = x /= y+ (KN x xt) /= (KN y yt) = x /= y || xt /= yt+ _ /= _ = True++{-+instance Eq (dim O t) => Eq (GenericKey dim O t) where+ (K1 x) == (K1 y) = x == y+ (K1 x) /= (K1 y) = x /= y++instance Eq (dim M t) => Eq (GenericKey dim M t) where+ (K1 x) == (K1 y) = x == y+ (K1 x) /= (K1 y) = x /= y++instance (Eq (dim r t), Eq (GenericKey dim rt tt)) => Eq (GenericKey dim (r :. rt) (t :. tt)) where+ (KN x xt) == (KN y yt) = x == y && xt == yt+ _ == _ = False++ (KN x xt) /= (KN y yt) = x /= y || xt /= yt+ _ /= _ = True+-}++instance Ser.Serialize (dim O t) => Ser.Serialize (GenericKey dim O t) where+ get = K1 <$> Ser.get+ put (K1 d) = Ser.put d++instance Ser.Serialize (dim M t) => Ser.Serialize (GenericKey dim M t) where+ get = K1 <$> Ser.get+ put (K1 d) = Ser.put d++instance (Ser.Serialize (GenericKey dim rt tt), Ser.Serialize (dim r t)) => Ser.Serialize (GenericKey dim (r :. rt) (t :. tt)) where+ get = KN <$> Ser.get <*> Ser.get+ put (KN d dt) = Ser.put d >> Ser.put dt+ put (K1 _) = error $ moduleName <> ".GenricKey.put: The impossible happened."++instance Ser.SafeCopy (dim O t) => Ser.SafeCopy (GenericKey dim O t) where+ getCopy = Ser.contain $ K1 <$> Ser.safeGet+ putCopy (K1 d) = Ser.contain $ Ser.safePut d++instance Ser.SafeCopy (dim M t) => Ser.SafeCopy (GenericKey dim M t) where+ getCopy = Ser.contain $ K1 <$> Ser.safeGet+ putCopy (K1 d) = Ser.contain $ Ser.safePut d++instance (Ser.SafeCopy (GenericKey dim rt tt), Ser.SafeCopy (dim r t)) => Ser.SafeCopy (GenericKey dim (r :. rt) (t :. tt)) where+ getCopy = Ser.contain $ KN <$> Ser.safeGet <*> Ser.safeGet+ putCopy (KN d dt) = Ser.contain $ Ser.safePut d >> Ser.safePut dt+ putCopy (K1 _) = error $ moduleName <> ".GenricKey.putCopy: The impossible happened."++instance Typeable2 (GenericKey dim) where+ typeOf2 (K1 _) = Data.Data.mkTyConApp (Data.Data.mkTyCon3 "data-store" moduleName "K1") []+ typeOf2 (KN _ _) = Data.Data.mkTyConApp (Data.Data.mkTyCon3 "data-store" moduleName "KN") []++type Key = GenericKey KeyDimension+type IKey = GenericKey IKeyDimension++instance Show t => Show (Key O t) where+ show (K1 d) = show d ++instance Show t => Show (Key M t) where+ show (K1 d) = show d ++instance (Show t, Show (Key rt tt)) => Show (Key (r :. rt) (t :. tt)) where+ show (KN d k) = show d <> ", " <> show k+ show (K1 _) = error $ moduleName <> ".Key.show: The impossible happened."++instance Show t => Show (IKey O t) where+ show (K1 d) = show d ++instance Show t => Show (IKey M t) where+ show (K1 d) = show d ++instance (Show t, Show (IKey rt tt)) => Show (IKey (r :. rt) (t :. tt)) where+ show (KN d k) = show d <> ", " <> show k+ show (K1 _) = error $ moduleName <> ".IKey.show: The impossible happened."++data Index rs ts where+ IN :: Ord t => !(IndexDimension r t) -> !(Index rt tt) -> Index (r :. rt) (t :. tt)+ I1 :: Ord t => !(IndexDimension r t) -> Index r t++instance (Ord t, Ser.Serialize t) => Ser.Serialize (Index O t) where+ get = I1 <$> Ser.get+ put (I1 ixd) = Ser.put ixd++instance (Ord t, Ser.Serialize t) => Ser.Serialize (Index M t) where+ get = I1 <$> Ser.get+ put (I1 ixd) = Ser.put ixd++instance (Ord t, Ser.Serialize t, Ser.Serialize (Index rt tt)) => Ser.Serialize (Index (O :. rt) (t :. tt)) where+ get = IN <$> Ser.get <*> Ser.get+ put (IN ixd ixt) = Ser.put ixd >> Ser.put ixt+ put (I1 _) = error $ moduleName <> ".Index.put: The impossible happened (#1)."++instance (Ord t, Ser.Serialize t, Ser.Serialize (Index rt tt)) => Ser.Serialize (Index (M :. rt) (t :. tt)) where+ get = IN <$> Ser.get <*> Ser.get+ put (IN ixd ixt) = Ser.put ixd >> Ser.put ixt+ put (I1 _) = error $ moduleName <> ".Index.put: The impossible happened (#2)."++instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (Index O t) where+ getCopy = Ser.contain $ I1 <$> Ser.safeGet+ putCopy (I1 ixd) = Ser.contain $ Ser.safePut ixd++instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (Index M t) where+ getCopy = Ser.contain $ I1 <$> Ser.safeGet+ putCopy (I1 ixd) = Ser.contain $ Ser.safePut ixd++instance (Ord t, Ser.SafeCopy t, Ser.SafeCopy (Index rt tt)) => Ser.SafeCopy (Index (O :. rt) (t :. tt)) where+ getCopy = Ser.contain $ IN <$> Ser.safeGet <*> Ser.safeGet+ putCopy (IN ixd ixt) = Ser.contain $ Ser.safePut ixd >> Ser.safePut ixt+ putCopy (I1 _) = error $ moduleName <> ".Index.putCopy: The impossible happened (#1)."++instance (Ord t, Ser.SafeCopy t, Ser.SafeCopy (Index rt tt)) => Ser.SafeCopy (Index (M :. rt) (t :. tt)) where+ getCopy = Ser.contain $ IN <$> Ser.safeGet <*> Ser.safeGet+ putCopy (IN ixd ixt) = Ser.contain $ Ser.safePut ixd >> Ser.safePut ixt+ putCopy (I1 _) = error $ moduleName <> ".Index.putCopy: The impossible happened (#2)."++instance Typeable2 Index where+ typeOf2 (I1 _) = Data.Data.mkTyConApp (Data.Data.mkTyCon3 "data-store" moduleName "I1") []+ typeOf2 (IN _ _) = Data.Data.mkTyConApp (Data.Data.mkTyCon3 "data-store" moduleName "IN") []++instance Show t => Show (Index O t) where+ show (I1 d) = show d++instance Show t => Show (Index M t) where+ show (I1 d) = show d++instance (Show t, Show (Index rt tt)) => Show (Index (r :. rt) (t :. tt)) where+ show (IN d i) = show d <> "\n" <> show i+ show (I1 _) = error $ moduleName <> ".Index.show: The impossible happened."++data KeyDimension r t where+ KeyDimensionO :: Ord t => t -> KeyDimension O t+ KeyDimensionM :: Ord t => [t] -> KeyDimension M t+ KeyDimensionA :: Auto t => KeyDimension O t++deriving instance Typeable2 KeyDimension++instance Show t => Show (KeyDimension r t) where+ show (KeyDimensionM ts) = show ts+ show (KeyDimensionO t) = show t+ show KeyDimensionA = show "Auto"++data IKeyDimension r t where+ IKeyDimensionO :: Ord t => t -> IKeyDimension O t+ IKeyDimensionM :: Ord t => [t] -> IKeyDimension M t++instance Eq (IKeyDimension r t) where+ (IKeyDimensionM x) == (IKeyDimensionM y) = x == y+ (IKeyDimensionO x) == (IKeyDimensionO y) = x == y+ _ == _ = False++ (IKeyDimensionM x) /= (IKeyDimensionM y) = x /= y+ (IKeyDimensionO x) /= (IKeyDimensionO y) = x /= y+ _ /= _ = True ++deriving instance Typeable2 IKeyDimension++instance (Ord t, Ser.Serialize t) => Ser.Serialize (IKeyDimension O t) where+ get = IKeyDimensionO <$> Ser.get+ put (IKeyDimensionO x) = Ser.put x++instance (Ord t, Ser.Serialize t) => Ser.Serialize (IKeyDimension M t) where+ get = IKeyDimensionM <$> Ser.get+ put (IKeyDimensionM x) = Ser.put x++instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (IKeyDimension O t) where+ getCopy = Ser.contain $ IKeyDimensionO <$> Ser.safeGet+ putCopy (IKeyDimensionO x) = Ser.contain $ Ser.safePut x++instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (IKeyDimension M t) where+ getCopy = Ser.contain $ IKeyDimensionM <$> Ser.safeGet+ putCopy (IKeyDimensionM x) = Ser.contain $ Ser.safePut x++instance Show t => Show (IKeyDimension r t) where+ show (IKeyDimensionM ts) = show ts+ show (IKeyDimensionO t) = show t++data IndexDimension r t where+ IndexDimensionO :: Ord t+ => !(Data.Map.Map t Int)+ -> IndexDimension O t+ + IndexDimensionM :: Ord t+ => !(Data.Map.Map t Data.IntSet.IntSet)+ -> IndexDimension M t++instance (Ord t, Ser.Serialize t) => Ser.Serialize (IndexDimension O t) where+ get = IndexDimensionO <$> Ser.get+ put (IndexDimensionO x) = Ser.put x++instance (Ord t, Ser.Serialize t) => Ser.Serialize (IndexDimension M t) where+ get = IndexDimensionM <$> Ser.get+ put (IndexDimensionM x) = Ser.put x++instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (IndexDimension O t) where+ getCopy = Ser.contain $ IndexDimensionO <$> Ser.safeGet+ putCopy (IndexDimensionO x) = Ser.contain $ Ser.safePut x++instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (IndexDimension M t) where+ getCopy = Ser.contain $ IndexDimensionM <$> Ser.safeGet+ putCopy (IndexDimensionM x) = Ser.contain $ Ser.safePut x++instance Show t => Show (IndexDimension r t) where+ show (IndexDimensionM m) = show $ map (\(k, vs) -> (k, Data.IntSet.toList vs)) $ Data.Map.toList m+ show (IndexDimensionO m) = show $ Data.Map.toList m++class GetDimension n a where+ getDimension :: n -> a -> RawDimensionType n a++instance GetDimension Z (Index O t) where+ getDimension _ (I1 ixd) = ixd++instance GetDimension Z (Index M t) where+ getDimension _ (I1 ixd) = ixd++instance GetDimension Z (Index (r :. rt) (t :. tt)) where+ getDimension _ (IN ixd _) = ixd+ getDimension _ (I1 _) = error $ moduleName <> ".Index.getDimension: The impossible happened."++instance GetDimension n (Index rt tt) => GetDimension (S n) (Index (r :. rt) (t :. tt)) where+ getDimension (S n) (IN _ ixt) = getDimension n ixt+ getDimension _ (I1 _) = error $ moduleName <> ".Index.getDimension: The impossible happened."++data TT+data FF++type family EmptyProxyIsSpecial t :: *+type instance EmptyProxyIsSpecial Int = TT++class Empty a where+ empty :: a++class EmptyProxy flag a where+ emptyProxy :: flag -> a++instance Ord t => Empty (Index O t) where+ empty = I1 (IndexDimensionO Data.Map.empty)++instance Ord t => Empty (Index M t) where+ empty = I1 (IndexDimensionM Data.Map.empty)++instance (Ord t, Empty (Index rt tt)) => Empty (Index (O :. rt) (t :. tt)) where+ empty = IN (IndexDimensionO Data.Map.empty) empty++instance (Ord t, Empty (Index rt tt)) => Empty (Index (M :. rt) (t :. tt)) where+ empty = IN (IndexDimensionM Data.Map.empty) empty++instance Empty (Index irs ts) => Empty (Store tag krs irs ts e) where+ empty = Store+ { storeV = Data.IntMap.empty+ , storeI = empty+ , storeNID = 0+ }+ {-# INLINE empty #-}++-- | Data type for creating tuples, it is used to:+--+-- * Create type-level tuples of relation tags for relation specification of+-- the key and the index of the store.+--+-- > M :. O :. O :. M+--+-- * Create type-level tuples of types for type specification of the key+-- and index of the store.+--+-- > Int :. Double :. String :. String+--+-- * Create value-level tuples to return raw key (with resolved+-- auto-increment dimensions).+--+-- > [1, 2, 3] :. 3.5 :. "Foo" :. ["Bar1", "Bar2"]+data h :. t = h :. t+infixr 3 :.+++-- NFDATA INSTANCES++instance (NFData e, NFData (IKey krs ts), NFData (Index irs ts)) => NFData (Store tag krs irs ts e) where+ rnf (Store ke ix nid) = rnf ke `seq` rnf ix `seq` rnf nid++instance NFData t => NFData (IndexDimension r t) where+ rnf (IndexDimensionO m) = rnf m+ rnf (IndexDimensionM m) = rnf m++instance NFData t => NFData (Index O t) where+ rnf (I1 kd) = rnf kd+ +instance NFData t => NFData (Index M t) where+ rnf (I1 kd) = rnf kd++instance (NFData t, NFData (Index rt tt)) => NFData (Index (r :. rt) (t :. tt)) where+ rnf (IN kd kt) = rnf kd `seq` rnf kt+ rnf (I1 _) = error "Impossible! (Index NFData)"++instance NFData t => NFData (IKeyDimension r t) where+ rnf (IKeyDimensionO x) = rnf x+ rnf (IKeyDimensionM x) = rnf x++instance NFData t => NFData (IKey O t) where+ rnf (K1 kd) = rnf kd+ +instance NFData t => NFData (IKey M t) where+ rnf (K1 kd) = rnf kd++instance (NFData t, NFData (IKey rt tt)) => NFData (IKey (r :. rt) (t :. tt)) where+ rnf (KN kd kt) = rnf kd `seq` rnf kt+ rnf (K1 _) = error "Impossible! (IKey NFData)"++instance (NFData a, NFData b) => NFData (a :. b) where+ rnf (a :. b) = rnf a `seq` rnf b++
+ src/Data/Store/Lens.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Store.Lens+( With(..)+) where++--------------------------------------------------------------------------------+import qualified Control.Lens+--------------------------------------------------------------------------------+import Data.Monoid +import Data.Functor.Identity+--------------------------------------------------------------------------------+import qualified Data.Store.Internal.Type as I+import qualified Data.Store.Internal.Function as I+import qualified Data.Store.Selection as I (IsSelection(resolve))+import qualified Data.Store as I ()+--------------------------------------------------------------------------------++class With sel where+ with :: I.Empty (I.Index irs ts) + => sel tag krs irs ts -> Control.Lens.Lens' (I.Store tag krs irs ts v)+ (I.Store tag krs irs ts v)++instance I.IsSelection sel => With sel where+ with sel tr old =+ fmap (mappend (runIdentity $! I.genericUpdateWithKey I.indexInsertID'' (\_ _ -> Nothing) ids old))+ (tr (I.genericSubset ids old))+ where+ ids = I.resolve sel old+
+ src/Data/Store/Selection.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE CPP #-}++module Data.Store.Selection+( (.<)+, (.<=)+, (.>)+, (.>=)+, (./=)+, (.==)+, (.&&)+, (.||)+, not+, all+, all1D+, any+, any1D+, IsSelection(..)+, Selection+) where++--------------------------------------------------------------------------------+import Prelude hiding (not, all, any)+--------------------------------------------------------------------------------+import Data.Monoid ((<>))+import qualified Data.IntSet+import qualified Data.List+import qualified Data.IntMap.Strict as Data.IntMap+import qualified Data.Map.Strict as Data.Map+--------------------------------------------------------------------------------+import qualified Data.Store.Internal.Type as I+--------------------------------------------------------------------------------++moduleName :: String+moduleName = "Data.Store.Selection"++-- INTERFACE++infix 4 .==, ./=, .<, .<=, .>=, .>+infixr 3 .&&+infixr 2 .||++-- | The expression (@not' sel@) is a selection that includes all values+-- except those that match the selection @sel@. +not :: IsSelection sel => sel tag krs irs ts -> Selection tag krs irs ts+not = SelectionNot+{-# INLINE not #-}++-- | Selection that matches the intersection of all the selections in the+-- list or everything if the list is empty.+all :: [Selection tag krs irs ts] -> Selection tag krs irs ts+all [] = error $ moduleName <> ".all: empty list."+all [s] = s+all (s:rest) = Data.List.foldl' (.&&) s rest -- this way we do not have to intersect with "everything"+{-# INLINE all #-}++-- | The expression (@'Data.Store.Selection.all1D' d ss@) is equivalent to (@'Data.Store.Selection.all'' $ map ($ d) ss@).+all1D :: (tag, n) -> [(tag, n) -> Selection tag krs irs ts] -> Selection tag krs irs ts+all1D _ [] = error $ moduleName <> ".all1D: empty list."+all1D d [h] = h d+all1D d (h:rest) = Data.List.foldl' (\acc f -> acc .&& f d) (h d) rest -- this way we do not have to intersect with "everything"+{-# INLINE all1D #-}++-- | Selection that matches the union of all the selections in the+-- list or nothing if the list is empty.+any :: [Selection tag krs irs ts] -> Selection tag krs irs ts+any [] = error $ moduleName <> ".any: empty list."+any (x:xs) = Data.List.foldl' (.||) x xs+{-# INLINE any #-}++-- | The expression (@'Data.Store.Selection.any1D' d ss@) is equivalent to (@'Data.Store.Selection.any'' $ map ($ d) ss@).+any1D :: (tag, n) -> [(tag, n) -> Selection tag krs irs ts] -> Selection tag krs irs ts+any1D _ [] = error $ moduleName <> ".any1D: empty list."+any1D d (x:xs) = Data.List.foldl' (\acc f -> acc .|| f d) (x d) xs+{-# INLINE any1D #-}++-- | The expression (@sDim .< c@) is a selection that includes value+-- @x@ if and only if it is indexed in the @sDim@ dimension with a key @k@+-- such that @k < c@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(log n + k)/+(.<) :: I.GetDimension n (I.Index irs ts) => (tag, n) -> I.DimensionType n irs ts -> Selection tag krs irs ts+(.<) (_, n) = SelectionType . SelectionDimension n (Condition True False False)+{-# INLINE (.<) #-}++-- | The expression (@sDim .<= c@) is a selection that includes value+-- @x@ if and only if it is indexed in the @sDim@ dimension with a key @k@+-- such that @k <= c@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(log n + k)/+(.<=) :: I.GetDimension n (I.Index irs ts) => (tag, n) -> I.DimensionType n irs ts -> Selection tag krs irs ts+(.<=) (_, n) = SelectionType . SelectionDimension n (Condition True True False)+{-# INLINE (.<=) #-}++-- | The expression (@sDim .> c@) is a selection that includes value+-- @x@ if and only if it is indexed in the @sDim@ dimension with a key @k@+-- such that @k > c@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(log n + k)/+(.>) :: I.GetDimension n (I.Index irs ts) => (tag, n) -> I.DimensionType n irs ts -> Selection tag krs irs ts+(.>) (_, n) = SelectionType . SelectionDimension n (Condition False False True)+{-# INLINE (.>) #-}++-- | The expression (@sDim .>= c@) is a selection that includes value+-- @x@ if and only if it is indexed in the @sDim@ dimension with a key @k@+-- such that @k >= c@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(log n + k)/+(.>=) :: I.GetDimension n (I.Index irs ts) => (tag, n) -> I.DimensionType n irs ts -> Selection tag krs irs ts+(.>=) (_, n) = SelectionType . SelectionDimension n (Condition False True True)+{-# INLINE (.>=) #-}++-- | The expression (@sDim ./= c@) is a selection that includes value+-- @x@ if and only if it is indexed in the @sDim@ dimension with a key @k@+-- such that @k /= c@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(n)/+(./=) :: I.GetDimension n (I.Index irs ts) => (tag, n) -> I.DimensionType n irs ts -> Selection tag krs irs ts+(./=) (_, n) = SelectionType . SelectionDimension n (Condition True False True)+{-# INLINE (./=) #-}++-- | The expression (@sDim .== c@) is a selection that includes value+-- @x@ if and only if it is indexed in the @sDim@ dimension with a key @k@+-- such that @k == c@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(log n)/+(.==) :: I.GetDimension n (I.Index irs ts) => (tag, n) -> I.DimensionType n irs ts -> Selection tag krs irs ts+(.==) (_, n) = SelectionType . SelectionDimension n (Condition False True False)+{-# INLINE (.==) #-}++-- | The expression (@s1 .&& s2@) is a selection that includes the+-- intersection of the selections @s1@ and @s2@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(c(s1) + c(s2) + s(s1) + s(s2)/+(.&&) :: (IsSelection s1, IsSelection s2)+ => s1 tag krs irs ts -> s2 tag krs irs ts -> Selection tag krs irs ts+(.&&) = SelectionA+{-# INLINE (.&&) #-}++-- | The expression (@s1 .|| s2@) is a selection that includes the+-- union of the selections @s1@ and @s2@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(c(s1) + c(s2) + s(s1) + s(s2)/+(.||) :: (IsSelection s1, IsSelection s2)+ => s1 tag krs irs ts -> s2 tag krs irs ts -> Selection tag krs irs ts+(.||) = SelectionO+{-# INLINE (.||) #-}++-- IMPLEMENTATION++instance IsSelection Selection where+ resolve (SelectionType sel) s = resolve sel s+ resolve (SelectionA s1 s2) s = Data.IntSet.intersection (resolve s1 s) (resolve s2 s)+ resolve (SelectionO s1 s2) s = Data.IntSet.union (resolve s1 s) (resolve s2 s)+ resolve (SelectionNot sel) s@(I.Store vs _ _) =+ Data.IntSet.difference (Data.IntMap.keysSet vs) (resolve sel s)+ {-# INLINE resolve #-}++instance IsSelection (SelectionDimension n) where+ resolve = resolveSD+ {-# INLINE resolve #-}++resolveSD :: forall tag n krs irs ts v . SelectionDimension n tag krs irs ts + -> I.Store tag krs irs ts v+ -> Data.IntSet.IntSet+resolveSD (SelectionDimension _ (Condition False False False) _) _ = {-# SCC "resolveSD" #-} Data.IntSet.empty+resolveSD (SelectionDimension _ (Condition True True True) _) (I.Store vs _ _) = {-# SCC "resolveSD" #-} Data.IntSet.fromList $ Data.IntMap.keys vs+resolveSD (SelectionDimension n (Condition lt eq gt) v) (I.Store _ ix _) = {-# SCC "resolveSD" #-} + go $! I.getDimension n ix+ where+ go (I.IndexDimensionO m) = m `seq` case Data.Map.splitLookup v m of+ (lk, ek, gk) -> (if lt then trO lk else Data.IntSet.empty) <>+ (if eq then trMaybeO ek else Data.IntSet.empty) <>+ (if gt then trO gk else Data.IntSet.empty) + go (I.IndexDimensionM m) = m `seq` case Data.Map.splitLookup v m of+ (lk, ek, gk) -> (if lt then trM lk else Data.IntSet.empty) <>+ (if eq then trMaybeM ek else Data.IntSet.empty) <>+ (if gt then trM gk else Data.IntSet.empty)+ {-# INLINEABLE go #-}++ trO :: Data.Map.Map k Int -> Data.IntSet.IntSet+ trO xs = {-# SCC "resolveSD.trO" #-} Data.Map.foldl' ins Data.IntSet.empty xs+ where ins acc i = Data.IntSet.insert i acc+ {-# INLINE trO #-}++ trMaybeO :: Maybe Int -> Data.IntSet.IntSet+ trMaybeO (Just x) = Data.IntSet.singleton x+ trMaybeO _ = Data.IntSet.empty+ {-# INLINE trMaybeO #-}++ trM :: Data.Map.Map k Data.IntSet.IntSet -> Data.IntSet.IntSet+ trM = Data.Map.foldl' Data.IntSet.union Data.IntSet.empty+ {-# INLINE trM #-}++ trMaybeM :: Maybe Data.IntSet.IntSet -> Data.IntSet.IntSet+ trMaybeM (Just x) = x+ trMaybeM _ = Data.IntSet.empty+ {-# INLINE trMaybeM #-}+{-# INLINE resolveSD #-}++-- | TYPE++data SelectionDimension n tag krs irs ts where+ SelectionDimension :: I.GetDimension n (I.Index irs ts)+ => n+ -> Condition+ -> I.DimensionType n irs ts+ -> SelectionDimension n tag krs irs ts++data Selection tag krs irs ts where+ SelectionType :: IsSelection sel => sel tag krs irs ts -> Selection tag krs irs ts ++ SelectionA :: (IsSelection s1, IsSelection s2)+ => s1 tag krs irs ts -> s2 tag krs irs ts -> Selection tag krs irs ts++ SelectionO :: (IsSelection s1, IsSelection s2)+ => s1 tag krs irs ts -> s2 tag krs irs ts -> Selection tag krs irs ts++ SelectionNot :: IsSelection sel => sel tag krs irs ts -> Selection tag krs irs ts++data Condition = Condition !Bool !Bool !Bool++class IsSelection sel where+ resolve :: sel tag krs irs ts -> I.Store tag krs irs ts v -> Data.IntSet.IntSet+
+ src/Data/Store/Storable.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}++module Data.Store.Storable+( Storable(..)++, insert+, insert'+, updateWithKey+, updateWithKey'+, update+, update'+, fromList+, fromList'+) where++--------------------------------------------------------------------------------+import qualified Data.Store.Internal.Type as I +import qualified Data.Store as S +import qualified Data.Store.Selection as S (IsSelection()) +--------------------------------------------------------------------------------++-- | This type-class facilitates the common use case where the key under+-- which given values is to be indexed can be derived from the value.+--+-- Example:+--+-- The @Storable@ type-class instance for our @Content@ data type would look+-- like this:+--+-- > instance Storable Content where+-- > type StoreKRS Content = O :. O :. O :. M :. O +-- > type StoreIRS Content = O :. O :. M :. M :. M+-- > type StoreTS Content = ContentID :. String :. String :. String :. Double+-- >+-- > key (Content cn cb cts cr) = +-- > S.dimA .: S.dimO cn .: S.dimO cb .: S.dimM cts .:. S.dimO cr+class Storable v where+ type StoreKRS t :: *+ type StoreIRS t :: *+ type StoreTS t :: *+ + key :: v -> S.Key (StoreKRS v) (StoreTS v)++-- | See @'Data.Store.insert'@.+insert :: Storable v+ => v+ -> S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v+ -> Maybe (S.RawKey (StoreKRS v) (StoreTS v), S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v)+insert v = S.insert (key v) v+{-# INLINE insert #-}++-- | See @'Data.Store.insert''@.+insert' :: Storable v+ => v+ -> S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v+ -> (S.RawKey (StoreKRS v) (StoreTS v), S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v)+insert' v = S.insert' (key v) v+{-# INLINE insert' #-}++-- | See @'Data.Store.update'@.+update :: (Storable v, S.IsSelection sel)+ => (v -> Maybe v)+ -> sel tag (StoreKRS v) (StoreIRS v) (StoreTS v)+ -> S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v+ -> Maybe (S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v)+update tr = S.update (maybe Nothing (\v -> Just (v, Just $! key v)) . tr)+{-# INLINE update #-}++-- | See @'Data.Store.update''@.+update' :: (Storable v, S.IsSelection sel)+ => (v -> Maybe v)+ -> sel tag (StoreKRS v) (StoreIRS v) (StoreTS v)+ -> S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v+ -> S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v+update' tr = S.update' (maybe Nothing (\v -> Just (v, Just $! key v)) . tr)+{-# INLINE update' #-}++-- | See @'Data.Store.updateWithKey'@.+updateWithKey :: (Storable v, S.IsSelection sel)+ => (S.RawKey (StoreKRS v) (StoreTS v) -> v -> Maybe v)+ -> sel tag (StoreKRS v) (StoreIRS v) (StoreTS v)+ -> S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v+ -> Maybe (S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v)+updateWithKey tr = S.updateWithKey (\rk vv -> maybe Nothing (\v -> Just (v, Just $! key v)) $ tr rk vv)+{-# INLINE updateWithKey #-}++-- | See @'Data.Store.updateWithKey''@.+updateWithKey' :: (Storable v, S.IsSelection sel)+ => (S.RawKey (StoreKRS v) (StoreTS v) -> v -> Maybe v)+ -> sel tag (StoreKRS v) (StoreIRS v) (StoreTS v)+ -> S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v+ -> S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v+updateWithKey' tr = S.updateWithKey' (\rk vv -> maybe Nothing (\v -> Just (v, Just $! key v)) $ tr rk vv)+{-# INLINE updateWithKey' #-}++-- | See @'Data.Store.fromList'@.+fromList :: (I.Empty (I.Index (StoreIRS v) (StoreTS v)), Storable v)+ => [v]+ -> Maybe (S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v)+fromList = S.fromList . map (\v -> (key v, v))+{-# INLINE fromList #-}++-- | See @'Data.Store.fromList''@.+fromList' :: (I.Empty (I.Index (StoreIRS v) (StoreTS v)), Storable v)+ => [v]+ -> I.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v+fromList' = S.fromList' . map (\v -> (key v, v))+{-# INLINE fromList' #-}+
+ tests/Main.hs view
@@ -0,0 +1,14 @@+module Main+( main+) where++------------------------------------------------------------------------------+import Test.Framework (defaultMain, testGroup)+------------------------------------------------------------------------------+import qualified Test.Data.Store01+------------------------------------------------------------------------------++main :: IO ()+main = defaultMain+ [ testGroup "Data.Store01" Test.Data.Store01.tests+ ]
+ tests/Test/Data/Store01.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE TypeOperators #-}++module Test.Data.Store01+( tests+) where++--------------------------------------------------------------------------------+import Control.Arrow+import Control.Applicative+--------------------------------------------------------------------------------+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+--------------------------------------------------------------------------------+import qualified Data.List as L+import Data.Maybe+import Data.Proxy+import qualified Data.Foldable+import qualified Data.Set+import qualified Data.IntSet+--------------------------------------------------------------------------------+import qualified Data.Store as S+import Data.Store (M, O, (.:), (.:.), (:.)(..), (.<), (.<=), (.>), (.>=), (./=), (.==), (.&&), (.||))+--------------------------------------------------------------------------------++data D = D+ { dOM :: Int+ , dMO :: [Int]+ , dMM :: [Int]+ } deriving (Eq, Ord, Show)++type DID = Int++data DStoreTag = DStoreTag++type DSTS = DID :. Int :. Int :. Int+type DSKRS = O :. O :. M :. M +type DSIRS = O :. M :. O :. M +type DS = S.Store DStoreTag DSKRS DSIRS DSTS D+type DSKey = S.Key DSKRS DSTS+type DSSelection = S.Selection DStoreTag DSKRS DSIRS DSTS++sOO :: (DStoreTag, S.N0)+sOO = (DStoreTag, S.n0)++sOM :: (DStoreTag, S.N1)+sOM = (DStoreTag, S.n1)++sMO :: (DStoreTag, S.N2)+sMO = (DStoreTag, S.n2)++sMM :: (DStoreTag, S.N3)+sMM = (DStoreTag, S.n3)++makeKey :: Int -> Int -> [Int] -> [Int] -> DSKey+makeKey oo om mo mm = + S.dimO oo .: S.dimO om .: S.dimM mo .:. S.dimM mm++vkey :: D -> DSKey+vkey (D om mo mm) = + S.dimA .: S.dimO om .: S.dimM mo .:. S.dimM mm+++vkey' :: Int -> D -> DSKey+vkey' i (D om mo mm) = + S.dimO i .: S.dimO om .: S.dimM mo .:. S.dimM mm++tests :: [Test]+tests =+ [ testProperty "insert1" prop_insert1+ , testProperty "insert2" prop_insert2+ + , testProperty "insert'1" prop_insert'1++ , testProperty "lookup1" prop_lookup1+ + , testProperty "update1" prop_update1+ , testProperty "update2" prop_update2+ , testProperty "update3" prop_update3+ ]++-- | Tests insert (auto-incrementation) #1.+prop_insert1 (D om mo mm) =+ case S.insert (vkey v) v emptyS of+ Just (i :. _, store) -> (i == minBound) && (S.size store == 1)+ _ -> False++ where+ emptyS :: DS+ emptyS = S.empty++ v = D om (L.nub mo) (L.nub mm)++-- | Tests insert (auto-incrementation) #2.+prop_insert2 = ids == map fst inserts+ where+ (i0 :. _, s0) = fromJust $ S.insert (vkey $ mval 0) (mval 0) S.empty++ inserts :: [(Int, DS)]+ inserts =+ foldl (\acc@((_, s') : _) v -> let (i :. _, s) = fromJust $ S.insert (vkey v) v s'+ in (i, s) : acc+ ) [(i0, s0)] ds++ ids :: [Int]+ ids = reverse . take 100 $ iterate succ minBound++ ds :: [D]+ ds = map mval [1..99]++ mval :: Int -> D+ mval i = D i [i] [i]++-- | Tests insert' (deleting collisions)+prop_insert'1 xs =+ (Data.Set.fromList (S.elements store1) == Data.Set.fromList (S.elements store2)) &&+ checkLookup sOO oos &&+ checkLookup sOM oms &&+ checkLookup sMO mos &&+ checkLookup sMM mms+ where+ lookupSet :: DSSelection -> DS -> Data.Set.Set D+ lookupSet sel s = Data.Set.fromList $ map snd $ S.lookup sel s++ checkLookup dim xs =+ all (\x -> lookupSet (dim .== x) store1 == lookupSet (dim .== x) store2) xs++ kes :: [(DSKey, D)]+ kes = zipWith (\i x -> (vkey' i x, x)) [0 ..] xs++ oos :: [Int]+ oos = [ 0 .. 5000 ]++ oms :: [Int]+ oms = Data.IntSet.toList $+ foldr (\(D om _ _) acc -> Data.IntSet.insert om acc) Data.IntSet.empty xs++ mos :: [Int]+ mos = Data.IntSet.toList $+ foldr (\(D _ mo _) acc -> Data.IntSet.union (Data.IntSet.fromList mo) acc) Data.IntSet.empty xs++ mms :: [Int]+ mms = Data.IntSet.toList $+ foldr (\(D _ _ mm) acc -> Data.IntSet.union (Data.IntSet.fromList mm) acc) Data.IntSet.empty xs++ store1 :: DS+ store1 = S.fromList' kes+ + store2 :: DS+ store2 = foldl (\acc (k, x) -> snd $ S.insert' k x acc) store1 kes++-- | Tests insert, lookup (EQ, LT, GT, NEQ) #1.+prop_lookup1 = byOO_EQ && byOM_EQ && byMO_EQ && byMM_EQ &&+ byOO_LT && byOM_LT && byMO_LT && byMM_LT &&+ byOO_GT && byOM_GT && byMO_GT && byMM_GT &&+ byOO_NEQ && byOM_NEQ && byMO_NEQ && byMM_NEQ+ where+ byOO_EQ :: Bool+ byOO_EQ = all (\r -> length r == 1) $+ map (\k -> S.lookup (sOO .== k) store) oos++ byOM_EQ :: Bool+ byOM_EQ = all (\r -> length r == 50) $+ map (\k -> S.lookup (sOM .== k) store) oms++ byMO_EQ :: Bool+ byMO_EQ = all (\r -> length r == 1) $+ map (\k -> S.lookup (sMO .== k) store) mos++ byMM_EQ :: Bool+ byMM_EQ = all (\(k, r) -> length r == (100 - k)) $+ map (\k -> (k, S.lookup (sMM .== k) store)) mms++ byOO_LT :: Bool+ byOO_LT = all (\(k, r) -> length r == (k + minBound)) $+ map (\k -> (k, S.lookup (sOO .< k) store)) oos++ byOM_LT :: Bool+ byOM_LT = all (\(k, r) -> length r == (k * 50)) $+ map (\k -> (k, S.lookup (sOM .< k) store)) oms++ byMO_LT :: Bool+ byMO_LT = all (\(k, r) -> length r == k) $+ map (\k -> (k, S.lookup (sMO .< k) store)) mos++ byMM_LT :: Bool+ byMM_LT = all (\(k, r) -> length r == (if k == 0 then 0 else 100)) $+ map (\k -> (k, S.lookup (sMM .< k) store)) mms++ byOO_GT :: Bool+ byOO_GT = all (\(k, r) -> length r == (99 - k + minBound)) $+ map (\k -> (k, S.lookup (sOO .> k) store)) oos++ byOM_GT :: Bool+ byOM_GT = all (\(k, r) -> length r == ((1 - k) * 50)) $+ map (\k -> (k, S.lookup (sOM .> k) store)) oms++ byMO_GT :: Bool+ byMO_GT = all (\(k, r) -> length r == (99 - k)) $+ map (\k -> (k, S.lookup (sMO .> k) store)) mos++ byMM_GT :: Bool+ byMM_GT = all (\(k, r) -> length r == (99 - k)) $+ map (\k -> (k, S.lookup (sMM .> k) store)) mms+ + byOO_NEQ :: Bool+ byOO_NEQ = all (\(k, r) -> length r == 99) $+ map (\k -> (k, S.lookup (sOO ./= k) store)) oos++ byOM_NEQ :: Bool+ byOM_NEQ = all (\(k, r) -> length r == 50) $+ map (\k -> (k, S.lookup (sOM ./= k) store)) oms++ byMO_NEQ :: Bool+ byMO_NEQ = all (\(k, r) -> length r == 99) $+ map (\k -> (k, S.lookup (sMO ./= k) store)) mos++ byMM_NEQ :: Bool+ byMM_NEQ = all (\(k, r) -> length r == (if k == 0 then 99 else 100)) $+ map (\k -> (k, S.lookup (sMM ./= k) store)) mms+ + store :: DS+ store = foldl (\s v -> snd . fromJust $ S.insert (vkey v) v s) S.empty ds++ ds :: [D]+ ds = map mval [0..99]++ mval :: Int -> D+ mval i = D (i `mod` 2) [i] [0..i]++ -- Every key in this list corresponds to exactly 1 d.+ oos :: [Int]+ oos = take 100 $ iterate succ minBound++ -- Every key in this list corresponds to exactly 50 ds.+ oms :: [Int]+ oms = [0, 1]++ -- Every key in this list corresponds to exactly 1 d.+ mos :: [Int]+ mos = [0..99]++ -- Every key 'k' in this list corresponds to exactly '100 - k'+ -- ds.+ mms :: [Int]+ mms = [0..99]++-- | Tests insert, delete #1+prop_update1 = deleteMM+ where+ deleteMM :: Bool+ deleteMM = all (\(k, s, l) -> S.size s == k && length l == 0) $+ map (\k -> let res = S.delete (sMM .== k) store+ in (k, res, S.lookup (sMM .== k) res)+ ) mms ++ store :: DS+ store = foldl (\s v -> snd . fromJust $ S.insert (vkey v) v s) S.empty ds++ ds :: [D]+ ds = map mval [0..99]++ mval :: Int -> D+ mval i = D (i `mod` 2) [i] [0..i]+ + mms :: [Int]+ mms = [0..99]++-- | Tests insert, delete #2+prop_update2 = test1+ where+ test1 :: Bool+ test1 = lookupRes1 == [v2] &&+ lookupRes2 == [v3] &&+ S.size res == 2+ where+ res = S.delete ((sOM .== 1) .&& (sMM .== 1)) store+ lookupRes1 = map snd $ S.lookup (sOM .== 1) res+ lookupRes2 = map snd $ S.lookup (sMM .== 1) res++ store :: DS+ store = foldl (\s v -> snd . fromJust $ S.insert (vkey v) v s) S.empty ds++ ds :: [D]+ ds = [v1, v2, v3]++ v1 = D 1 [1] [1]+ v2 = D 1 [2] [2, 3]+ v3 = D 2 [3] [1, 2]+ +-- | Tests insert, update (changing key)+prop_update3 = test1+ where+ test1 :: Bool+ test1 = lookupRes1 == [v2] &&+ lookupRes2 == [v3] &&+ lookupRes3 == [v1] &&+ lookupRes4 == [v1] &&+ lookupRes5 == [v1] &&+ S.size res == 3+ where+ res = fromJust $ S.update (\v -> Just (v, Just $ makeKey 0 0 [0] [0])) (sOO .== minBound) store+ lookupRes1 = map snd $ S.lookup (sOM .== 1) res+ lookupRes2 = map snd $ S.lookup (sMM .== 1) res+ lookupRes3 = map snd $ S.lookup (sOM .== 0) res+ lookupRes4 = map snd $ S.lookup (sMO .== 0) res+ lookupRes5 = map snd $ S.lookup (sMM .== 0) res++ store :: DS+ store = foldl (\s v -> snd . fromJust $ S.insert (vkey v) v s) S.empty ds++ ds :: [D]+ ds = [v1, v2, v3]++ v1 = D 1 [1] [1]+ v2 = D 1 [2] [2, 3]+ v3 = D 2 [3] [1, 2]++--------------------------------------------------------------------------------+-- | QuickCheck machinery.++instance Arbitrary D where+ arbitrary = (\(om, mo, mm) -> D om (L.nub mo) (L.nub mm)) <$> arbitrary+