data-store 0.3.0.4 → 0.3.0.6
raw patch · 15 files changed
+2613/−2240 lines, 15 files
Files
- benchmarks/src/01.hs +340/−219
- benchmarks/src/Common.hs +76/−73
- benchmarks/src/DS/B01.hs +99/−91
- benchmarks/src/TS/B01.hs +114/−103
- data-store.cabal +114/−115
- src/Data/IntSet/Extra.hs +41/−41
- src/Data/Map/Extra.hs +24/−24
- src/Data/Store.hs +120/−6
- src/Data/Store/Internal/Function.hs +328/−293
- src/Data/Store/Internal/Type.hs +590/−560
- src/Data/Store/Lens.hs +33/−33
- src/Data/Store/Selection.hs +235/−235
- src/Data/Store/Storable.hs +110/−110
- tests/Main.hs +14/−14
- tests/Test/Data/Store01.hs +375/−323
benchmarks/src/01.hs view
@@ -1,219 +1,340 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE CPP #-}--module Main-( main-) where--#define BENCH_SMALL-#define BENCH_ESSENTIALS-----------------------------------------------------------------------------------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-----------------------------------------------------------------------------------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 elems100000- , RNF elems200000- , RNF elems400000- , RNF elems800000-- , RNF elems5000x5000- , RNF elems10000x5000-- , RNF ds100000- , RNF ds200000-- , RNF map100000- , RNF map200000- - , RNF is100000- , RNF is200000- - , RNF ts100000- , RNF ts200000-- , RNF elem9999999- , RNF elem2500- ])- -- Insert 1 element into a store of size N. No collisions.- [- {-- C.bgroup "insert (Int) 01 100000"- [ C.bcompare- [ C.bench "DS" $ C.whnf (DS.B01.insert elem9999999) ds100000- , C.bench "DS (Unsafe)" $ C.whnf (DS.B01.insertUnsafe elem9999999) ds100000-#ifndef BENCH_DS- , C.bench "Map" $ C.whnf (insertMap elem9999999) map10000- , C.bench "IS" $ C.whnf (IS.B01.force . IS.B01.insert elem9999999) is100000- , C.bench "TS" $ C.whnf (TS.B01.force . 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.nf (DS.B01.insertUnsafe elem9999999) ds200000-#ifndef BENCH_DS- , C.bench "Map" $ C.whnf (insertMap elem9999999) map20000- , C.bench "IS" $ C.whnf (IS.B01.force . IS.B01.insert elem9999999) is200000- , C.bench "TS" $ C.whnf (TS.B01.force . TS.B01.insert elem9999999) ts200000-#endif- ]- ]- , C.bgroup "insert-collision (Int) 01 100000"- [ C.bcompare- [ C.bench "DS" $ C.whnf (DS.B01.insert elem2500) ds100000-#ifndef BENCH_DS- , C.bench "Map" $ C.whnf (insertMap elem2500) map100000- , C.bench "IS" $ C.whnf (IS.B01.force . IS.B01.insert elem2500) is100000- , C.bench "TS" $ C.whnf (TS.B01.force . TS.B01.insert elem2500) ts100000-#endif- ]- ]- , C.bgroup "insert-collision (Int) 01 200000"- [ C.bcompare- [ C.bench "DS" $ C.whnf (DS.B01.insert elem2500) ds200000-#ifndef BENCH_DS- , C.bench "Map" $ C.whnf (insertMap elem2500) map200000- , C.bench "IS" $ C.whnf (IS.B01.force . IS.B01.insert elem2500) is200000- , C.bench "TS" $ C.whnf (TS.B01.force . TS.B01.insert elem2500) ts200000-#endif- ]- ]- -}- C.bgroup "lookup OO EQ (Int) 01 200000"- [ C.bcompare- [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOOEQ 10000) ds200000- , C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOOEQLens 10000) ds200000-#ifndef BENCH_DS- , C.bench "Map" $ C.nf (Data.Map.lookup 10000) map200000- , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOOEQ 10000) is200000- , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOOEQ 10000) ts200000-#endif- ]- ]- , C.bgroup "lookup OO GE (Int) 01 200000 (500)"- [ C.bcompare- [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOOGE 199500) ds200000- , C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOOGELens 199500) ds200000-#ifndef BENCH_DS- , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOOGE 199500) is200000- , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOOGE 199500) ts200000-#endif- ]- ]- , C.bgroup "lookup OM EQ (Int) 01 200000"- [ C.bcompare- [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOMEQ 200) ds200000- , C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOMEQLens 200) ds200000-#ifndef BENCH_DS- , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOMEQ 200) is200000- , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOMEQ 200) ts200000-#endif- ]- ]- , C.bgroup "lookup OM GE (Int) 01 200000 (500)"- [ C.bcompare- [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOMGE 39900) ds200000- , C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOMGELens 39900) ds200000-#ifndef BENCH_DS- , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOMGE 39900) is200000- , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOMGE 39900) ts200000-#endif- ]- ]- , C.bgroup "lookup MM EQ (Int) 01 200000"- [ C.bcompare- [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupMMEQ 200) ds200000- , C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupMMEQLens 200) ds200000-#ifndef BENCH_DS- , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupMMEQ 200) is200000- , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupMMEQ 200) ts200000-#endif- ]- ]- ]--------insertListDS :: [C01] -> DS.B01.DS -> DS.B01.DS-insertListDS xs s0 = foldl' (flip DS.B01.insert) s0 xs--insertListTS :: [C01] -> TS.B01.TS -> TS.B01.TS-insertListTS xs s0 = snd $!- foldl' (\(n, acc) x -> if n == t- then rnf acc `seq` (0, TS.B01.insert x acc)- else (n + 1, TS.B01.insert x acc)- ) (0 :: Int, s0) xs- where t = 10000--insertListIS :: [C01] -> IS.B01.IS -> IS.B01.IS-insertListIS xs s0 = snd $! - foldl' (\(n, acc) x -> if n == t- then rnf acc `seq` (0, IS.B01.insert x acc)- else (n + 1, IS.B01.insert x acc)- ) (0 :: Int, s0) xs- where t = 10000--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--map100000 :: Data.Map.Map Int C01-map100000 = insertListMap elems100000 Data.Map.empty--map200000 :: Data.Map.Map Int C01-map200000 = insertListMap elems200000 Data.Map.empty---- IS--is100000 :: IS.B01.IS-is100000 = insertListIS elems100000 IS.B01.empty--is200000 :: IS.B01.IS-is200000 = insertListIS elems200000 IS.B01.empty---- DS--ds100000 :: DS.B01.DS-ds100000 = insertListDS elems100000 DS.B01.empty--ds200000 :: DS.B01.DS-ds200000 = insertListDS elems200000 DS.B01.empty---- TS--ts100000 :: TS.B01.TS-ts100000 = insertListTS elems100000 TS.B01.empty--ts200000 :: TS.B01.TS-ts200000 = insertListTS elems200000 TS.B01.empty-+{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} + +module Main +( main +) where + +-- #define BENCH_SMALL +-- #define BENCH_ESSENTIALS + +-------------------------------------------------------------------------------- +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 +-------------------------------------------------------------------------------- + +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 elems200000 + , RNF map200000 + , RNF ds200000 + , RNF is200000 + , RNF ts200000 + +#ifdef BENCH_SMALL + , RNF elems50000 + , RNF elems100000 + + , RNF ds50000 + , RNF ds100000 + + , RNF map50000 + , RNF map100000 + + , RNF is50000 + , RNF is100000 + + , RNF ts50000 + , RNF ts100000 +#endif + + , RNF elem9999999 + , RNF elem2500 + ]) + -- Insert 1 element into a store of size N. No collisions. + [ +#ifdef BENCH_SMALL + C.bgroup "insertLookup (Int) 01 100000" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.insertLookup 9999999 9999999 9999999) ds100000 +#ifndef BENCH_DS + , C.bench "IS" $ C.whnf (forceList . IS.B01.insertLookup 9999999 9999999 9999999) is100000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.insertLookup 9999999 9999999 9999999) ts100000 +#endif + ] + ] , +#endif + C.bgroup "insertLookup (Int) 01 200000" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.insertLookup 9999999 9999999 9999999) ds200000 +#ifndef BENCH_DS + , C.bench "IS" $ C.whnf (forceList . IS.B01.insertLookup 9999999 9999999 9999999) is200000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.insertLookup 9999999 9999999 9999999) ts200000 +#endif + ] + ] +#ifdef BENCH_SMALL + , C.bgroup "insert (Int) 01 100000" + [ C.bcompare + [ C.bench "DS" $ C.whnf (DS.B01.insert elem9999999) ds100000 +#ifndef BENCH_DS + , C.bench "Map" $ C.whnf (insertMap elem9999999) map100000 +#endif + ] + ] +#endif + , C.bgroup "insert (Int) 01 200000" + [ C.bcompare + [ C.bench "DS" $ C.whnf (DS.B01.insert elem9999999) ds200000 +#ifndef BENCH_DS + , C.bench "Map" $ C.whnf (insertMap elem9999999) map200000 +#endif + ] + ] +#ifdef BENCH_SMALL + , C.bgroup "lookup OO EQ (Int) 01 50000" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOOEQ 10000) ds50000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOOEQLens 10000) ds50000 +#ifndef BENCH_DS + , C.bench "Map" $ C.nf (Data.Map.lookup 10000) map50000 + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOOEQ 10000) is50000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOOEQ 10000) ts50000 +#endif + ] + ] + , C.bgroup "lookup OO GE (Int) 01 50000 (500)" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOOGE 49500) ds50000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOOGELens 99500) ds50000 +#ifndef BENCH_DS + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOOGE 49500) is50000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOOGE 49500) ts50000 +#endif + ] + ] + , C.bgroup "lookup OM EQ (Int) 01 50000" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOMEQ 200) ds50000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOMEQLens 200) ds50000 +#ifndef BENCH_DS + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOMEQ 200) is50000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOMEQ 200) ts50000 +#endif + ] + ] + , C.bgroup "lookup OM GE (Int) 01 50000 (500)" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOMGE 9900) ds50000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOMGELens 9900) ds50000 +#ifndef BENCH_DS + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOMGE 9900) is50000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOMGE 9900) ts50000 +#endif + ] + ] + , C.bgroup "lookup MM EQ (Int) 01 50000" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupMMEQ 200) ds50000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupMMEQLens 200) ds50000 +#ifndef BENCH_DS + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupMMEQ 200) is50000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupMMEQ 200) ts50000 +#endif + ] + ] + , C.bgroup "lookup OO EQ (Int) 01 100000" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOOEQ 10000) ds100000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOOEQLens 10000) ds100000 +#ifndef BENCH_DS + , C.bench "Map" $ C.nf (Data.Map.lookup 10000) map100000 + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOOEQ 10000) is100000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOOEQ 10000) ts100000 +#endif + ] + ] + , C.bgroup "lookup OO GE (Int) 01 100000 (500)" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOOGE 99500) ds100000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOOGELens 99500) ds100000 +#ifndef BENCH_DS + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOOGE 99500) is100000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOOGE 99500) ts100000 +#endif + ] + ] + , C.bgroup "lookup OM EQ (Int) 01 100000" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOMEQ 200) ds100000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOMEQLens 200) ds100000 +#ifndef BENCH_DS + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOMEQ 200) is100000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOMEQ 200) ts100000 +#endif + ] + ] + , C.bgroup "lookup OM GE (Int) 01 100000 (500)" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOMGE 19900) ds100000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOMGELens 19900) ds100000 +#ifndef BENCH_DS + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOMGE 19900) is100000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOMGE 19900) ts100000 +#endif + ] + ] + , C.bgroup "lookup MM EQ (Int) 01 100000" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupMMEQ 200) ds100000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupMMEQLens 200) ds100000 +#ifndef BENCH_DS + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupMMEQ 200) is100000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupMMEQ 200) ts100000 +#endif + ] + ] +#endif + , C.bgroup "lookup OO EQ (Int) 01 200000" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOOEQ 10000) ds200000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOOEQLens 10000) ds200000 +#ifndef BENCH_DS + , C.bench "Map" $ C.nf (Data.Map.lookup 10000) map200000 + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOOEQ 10000) is200000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOOEQ 10000) ts200000 +#endif + ] + ] + , C.bgroup "lookup OO GE (Int) 01 200000 (500)" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOOGE 199500) ds200000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOOGELens 199500) ds200000 +#ifndef BENCH_DS + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOOGE 199500) is200000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOOGE 199500) ts200000 +#endif + ] + ] + , C.bgroup "lookup OM EQ (Int) 01 200000" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOMEQ 200) ds200000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOMEQLens 200) ds200000 +#ifndef BENCH_DS + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOMEQ 200) is200000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOMEQ 200) ts200000 +#endif + ] + ] + , C.bgroup "lookup OM GE (Int) 01 200000 (500)" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOMGE 39900) ds200000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOMGELens 39900) ds200000 +#ifndef BENCH_DS + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOMGE 39900) is200000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOMGE 39900) ts200000 +#endif + ] + ] + , C.bgroup "lookup MM EQ (Int) 01 200000" + [ C.bcompare + [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupMMEQ 200) ds200000 + --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupMMEQLens 200) ds200000 +#ifndef BENCH_DS + , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupMMEQ 200) is200000 + , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupMMEQ 200) ts200000 +#endif + ] + ] + ] + + +--- + +insertListDS :: [C01] -> DS.B01.DS -> DS.B01.DS +insertListDS xs s0 = foldl' (flip DS.B01.insert) s0 xs + +insertListTS :: [C01] -> TS.B01.TS -> TS.B01.TS +insertListTS xs s0 = snd $! + foldl' (\(n, acc) x -> if n == t + then rnf acc `seq` (0, TS.B01.insert x acc) + else (n + 1, TS.B01.insert x acc) + ) (0 :: Int, s0) xs + where t = 10000 + +insertListIS :: [C01] -> IS.B01.IS -> IS.B01.IS +insertListIS xs s0 = snd $! + foldl' (\(n, acc) x -> if n == t + then rnf acc `seq` (0, IS.B01.insert x acc) + else (n + 1, IS.B01.insert x acc) + ) (0 :: Int, s0) xs + where t = 10000 + +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 + +#ifdef BENCH_SMALL +map50000 :: Data.Map.Map Int C01 +map50000 = insertListMap elems50000 Data.Map.empty + +map100000 :: Data.Map.Map Int C01 +map100000 = insertListMap elems100000 Data.Map.empty +#endif + +map200000 :: Data.Map.Map Int C01 +map200000 = insertListMap elems200000 Data.Map.empty + +-- IS + +#ifdef BENCH_SMALL +is50000 :: IS.B01.IS +is50000 = insertListIS elems50000 IS.B01.empty + +is100000 :: IS.B01.IS +is100000 = insertListIS elems100000 IS.B01.empty +#endif + +is200000 :: IS.B01.IS +is200000 = insertListIS elems200000 IS.B01.empty + +-- DS + +#ifdef BENCH_SMALL +ds50000 :: DS.B01.DS +ds50000 = insertListDS elems50000 DS.B01.empty + +ds100000 :: DS.B01.DS +ds100000 = insertListDS elems100000 DS.B01.empty +#endif + +ds200000 :: DS.B01.DS +ds200000 = insertListDS elems200000 DS.B01.empty + +-- TS + +#ifdef BENCH_SMALL +ts50000 :: TS.B01.TS +ts50000 = insertListTS elems50000 TS.B01.empty + +ts100000 :: TS.B01.TS +ts100000 = insertListTS elems100000 TS.B01.empty +#endif + +ts200000 :: TS.B01.TS +ts200000 = insertListTS elems200000 TS.B01.empty +
benchmarks/src/Common.hs view
@@ -1,73 +1,76 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} --#define BENCH_ESSENTIALS--module Common-where-----------------------------------------------------------------------------------import Control.DeepSeq (NFData(..))-import Data.Data-----------------------------------------------------------------------------------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--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--#ifdef BENCH_SMALL-elems10000 :: [C01]-elems10000 = generate 0 10000--elems20000 :: [C01]-elems20000 = generate 0 20000--#else-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--forceList :: [a] -> ()-forceList ll = seq (go ll) ()- where- go [] = ()- go (_:xs) = go xs--+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- #define BENCH_ESSENTIALS + +module Common +where + +-------------------------------------------------------------------------------- +import Control.DeepSeq (NFData(..)) +import Data.Data +-------------------------------------------------------------------------------- + +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 + +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 + +-- #ifdef BENCH_SMALL +elems10000 :: [C01] +elems10000 = generate 0 10000 + +elems20000 :: [C01] +elems20000 = generate 0 20000 + +-- #else +elems50000 :: [C01] +elems50000 = generate 0 50000 + +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 + +forceList :: [a] -> () +forceList ll = seq (go ll) () + where + go [] = () + go (_:xs) = go xs + +
benchmarks/src/DS/B01.hs view
@@ -1,91 +1,99 @@-{-# 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 -> [C01]-lookupOOEQLens x o = S.elements (o ^. with (sD1 .== x))--lookupOOGE :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]-lookupOOGE x = S.lookup (sD1 .>= x)--lookupOOGELens :: Int -> DS -> [C01]-lookupOOGELens x o = S.elements (o ^. with (sD1 .>= x))--lookupOMEQ :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]-lookupOMEQ x = S.lookup (sD2 .== x)--lookupOMEQLens :: Int -> DS -> [C01]-lookupOMEQLens x o = S.elements (o ^. with (sD2 .== x))--lookupOMGE :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]-lookupOMGE x = S.lookup (sD2 .>= x)--lookupOMGELens :: Int -> DS -> [C01]-lookupOMGELens x o = S.elements (o ^. with (sD2 .>= x))--lookupMMEQ :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]-lookupMMEQ x = S.lookup (sD3 .== x)--lookupMMEQLens :: Int -> DS -> [C01] -lookupMMEQLens x o = S.elements (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--}+{-# 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 + +insertLookup :: Int -> Int -> Int -> DS -> [(S.RawKey DSKRS DSTS, C01)] +insertLookup d1 d2 d3 s = + S.lookup (sD1 .== d1) new ++ + S.lookup (sD2 .== d2) new ++ + S.lookup (sD3 .== d3) new + where new = snd $! S.insert' (key e) e s + e = C01 d1 d2 [d3] + +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 -> [C01] +lookupOOEQLens x o = S.elements (o ^. with (sD1 .== x)) + +lookupOOGE :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)] +lookupOOGE x = S.lookup (sD1 .>= x) + +lookupOOGELens :: Int -> DS -> [C01] +lookupOOGELens x o = S.elements (o ^. with (sD1 .>= x)) + +lookupOMEQ :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)] +lookupOMEQ x = S.lookup (sD2 .== x) + +lookupOMEQLens :: Int -> DS -> [C01] +lookupOMEQLens x o = S.elements (o ^. with (sD2 .== x)) + +lookupOMGE :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)] +lookupOMGE x = S.lookup (sD2 .>= x) + +lookupOMGELens :: Int -> DS -> [C01] +lookupOMGELens x o = S.elements (o ^. with (sD2 .>= x)) + +lookupMMEQ :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)] +lookupMMEQ x = S.lookup (sD3 .== x) + +lookupMMEQLens :: Int -> DS -> [C01] +lookupMMEQLens x o = S.elements (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
@@ -1,103 +1,114 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} --module TS.B01-where-----------------------------------------------------------------------------------import Control.Applicative-import Control.DeepSeq (NFData(..))-import Control.Lens----------------------------------------------------------------------------------import qualified Data.IntSet-import Data.Foldable (toList)-import Data.Functor.Identity----------------------------------------------------------------------------------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 -> [C01]-lookupOOEQ x o = toList (o ^. T.with D1 (==) x)--lookupOOGE :: Int -> TS -> [C01]-lookupOOGE x o = toList (o ^. T.with D1 (>=) x)--lookupOMEQ :: Int -> TS -> [C01]-lookupOMEQ x o = toList (o ^. T.with D2 (==) x)--lookupOMGE :: Int -> TS -> [C01]-lookupOMGE x o = toList (o ^. T.with D2 (>=) x)--lookupMMEQ :: Int -> TS -> [C01]-lookupMMEQ x o = toList (o ^. T.withAny D3 [x])--empty :: TS-empty = T.empty--force :: TS -> ()-force T.EmptyTable = ()-force (T.Table tab) = seq go ()- where- go :: T.Tab C01 (T.AnIndex C01)- go = runIdentity $! T.forTab tab (\_ i -> Identity $! case i of- T.PrimaryMap m -> m `seq` T.PrimaryMap m- T.CandidateMap m -> m `seq` T.CandidateMap m- T.CandidateIntMap m -> m `seq` T.CandidateIntMap m- T.CandidateHashMap m -> m `seq` T.CandidateHashMap m- T.SupplementalMap m -> m `seq` T.SupplementalMap m- T.SupplementalIntMap m -> m `seq` T.SupplementalIntMap m- T.SupplementalHashMap m -> m `seq` T.SupplementalHashMap m- T.InvertedMap m -> m `seq` T.InvertedMap m- T.InvertedIntMap m -> m `seq` T.InvertedIntMap m- T.InvertedHashMap m -> m `seq` T.InvertedHashMap m)-+{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module TS.B01 +where + +-------------------------------------------------------------------------------- +import Control.Applicative +import Control.DeepSeq (NFData(..)) +import Control.Lens +-------------------------------------------------------------------------------- +import qualified Data.IntSet +import Data.Foldable (toList) +import Data.Functor.Identity +-------------------------------------------------------------------------------- +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 = + let x1 = f D1 d1 + x2 = f D2 d2 + x3 = f D3 d3 + in + C01IX <$> seq x1 x1 + <*> seq x2 x2 + <*> seq x3 x3 + + 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 + +insertLookup :: Int -> Int -> Int -> TS -> [C01] +insertLookup d1 d2 d3 s = + toList (new ^. T.with D1 (==) d1) ++ + toList (new ^. T.with D2 (==) d2) ++ + toList (new ^. T.withAny D3 [d3]) + where new = T.insert (C01 d1 d2 [d3]) s + +lookupOOEQ :: Int -> TS -> [C01] +lookupOOEQ x o = toList (o ^. T.with D1 (==) x) + +lookupOOGE :: Int -> TS -> [C01] +lookupOOGE x o = toList (o ^. T.with D1 (>=) x) + +lookupOMEQ :: Int -> TS -> [C01] +lookupOMEQ x o = toList (o ^. T.with D2 (==) x) + +lookupOMGE :: Int -> TS -> [C01] +lookupOMGE x o = toList (o ^. T.with D2 (>=) x) + +lookupMMEQ :: Int -> TS -> [C01] +lookupMMEQ x o = toList (o ^. T.withAny D3 [x]) + +empty :: TS +empty = T.empty + +force :: TS -> () +force T.EmptyTable = () +force (T.Table tab) = seq go () + where + go :: T.Tab C01 (T.AnIndex C01) + go = runIdentity $! T.forTab tab (\_ i -> Identity $! case i of + T.PrimaryMap m -> m `seq` T.PrimaryMap m + T.CandidateMap m -> m `seq` T.CandidateMap m + T.CandidateIntMap m -> m `seq` T.CandidateIntMap m + T.CandidateHashMap m -> m `seq` T.CandidateHashMap m + T.SupplementalMap m -> m `seq` T.SupplementalMap m + T.SupplementalIntMap m -> m `seq` T.SupplementalIntMap m + T.SupplementalHashMap m -> m `seq` T.SupplementalHashMap m + T.InvertedMap m -> m `seq` T.InvertedMap m + T.InvertedIntMap m -> m `seq` T.InvertedIntMap m + T.InvertedHashMap m -> m `seq` T.InvertedHashMap m) +
data-store.cabal view
@@ -1,115 +1,114 @@-name: data-store-version: 0.3.0.4--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: the.palmik+maintainer@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.5 && < 5- , containers >= 0.4 && < 1- , lens >= 3.9 && < 4- , transformers >= 0.2 && < 0.4- , vector >= 0.10 && < 0.11-- , 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 && < 5- , containers >= 0.4 && < 1- , lens >= 3.9 && < 4- , transformers >= 0.2 && < 0.4- , vector >= 0.10 && < 0.11-- , cereal >= 0.3.5 && < 0.4- , deepseq >= 1.3.0 && < 1.4- , safecopy >= 0.8 && < 0.9-- , 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.6 && < 5- , containers >= 0.5 && < 1- , lens >= 3.9 && < 4- , transformers >= 0.2 && < 0.4- , vector >= 0.10 && < 0.11-- , cereal >= 0.3.5 && < 0.4- , deepseq >= 1.3.0 && < 1.4- , safecopy >= 0.8 && < 0.9-- , 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-+name: data-store +version: 0.3.0.6 + +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 Pilar +maintainer: the.palmik+maintainer@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.5 && < 5 + , containers >= 0.4 && < 1 + , lens >= 3.9 && < 4 + , transformers >= 0.2 && < 0.4 + + , 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 && < 5 + , containers >= 0.4 && < 1 + , lens >= 3.9 && < 4 + , transformers >= 0.2 && < 0.4 + , vector >= 0.10 && < 0.11 + + , cereal >= 0.3.5 && < 0.4 + , deepseq >= 1.3.0 && < 1.4 + , safecopy >= 0.8 && < 0.9 + + , 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.6 && < 5 + , containers >= 0.5 && < 1 + , lens >= 3.9 && < 4 + , transformers >= 0.2 && < 0.4 + , vector >= 0.10 && < 0.11 + + , cereal >= 0.3.5 && < 0.4 + , deepseq >= 1.3.0 && < 1.4 + , safecopy >= 0.8 && < 0.9 + + , 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
@@ -1,41 +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 #-}-+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
@@ -1,24 +1,24 @@-{-# LANGUAGE CPP #-}--module Data.Map.Extra-( insertUnique-) where-----------------------------------------------------------------------------------#if MIN_VERSION_containers(0,5,0)-import qualified Data.Map.Strict as Data.Map-#else-import qualified Data.Map-#endif------------------------------------------------------------------------------------- | 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 #-}-+{-# LANGUAGE CPP #-} + +module Data.Map.Extra +( insertUnique +) where + +-------------------------------------------------------------------------------- +#if MIN_VERSION_containers(0,5,0) +import qualified Data.Map.Strict as Data.Map +#else +import qualified Data.Map +#endif +-------------------------------------------------------------------------------- + +-- | 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
@@ -159,6 +159,9 @@ , toList , elements , keys +, insertList +, insertList' +, unsafeInsertList , fromList , fromList' , unsafeFromList @@ -166,6 +169,8 @@ -- * Querying , size , lookup +, lookupOrderByA +, lookupOrderByD -- ** Selection -- @@ -447,10 +452,60 @@ -- list of (raw key)-element pairs that match the selection. -- -- Complexity: /O(c + s * min(n, W))/ +-- +-- See also: +-- +-- * 'Data.Store.lookupOrderByA' +-- +-- * 'Data.Store.lookupOrderByD' 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.Selection.lookup' sel store@) is +-- list of (raw key)-element pairs that match the selection. +-- The list is sorted in ascending order with respect to the specified dimension. +-- +-- NOTE: The function only works (this is ensured on the type level) with when +-- the ordering is based on dimensions of type one-one and one-many. +-- +-- Complexity: /O(c + (s * log(s)) + s * min(n, W))/ +-- +-- See also: +-- +-- * 'Data.Store.lookupOrderByD' +-- +-- * 'Data.Store.lookup' +lookupOrderByA :: (I.DimensionRelation n krs ts ~ I.O, I.GetDimension n (I.IKey krs ts), IsSelection sel) + => sel tag krs irs ts + -> (tag, n) + -> I.Store tag krs irs ts v + -> [(I.RawKey krs ts, v)] +lookupOrderByA sel (_, n) s = I.genericLookupAsc (resolve sel s) n s +{-# INLINE lookupOrderByA #-} + +-- | The expression (@'Data.Store.Selection.lookup' sel store@) is +-- list of (raw key)-element pairs that match the selection. +-- The list is sorted in descending order with respect to the specified dimension. +-- +-- NOTE: The function only works (this is ensured on the type level) with when +-- the ordering is based on dimensions of type one-one and one-many. +-- +-- Complexity: /O(c + (s * log(s)) + s * min(n, W))/ +-- +-- See also: +-- +-- * 'Data.Store.lookupOrderByA' +-- +-- * 'Data.Store.lookup' +lookupOrderByD :: (I.DimensionRelation n krs ts ~ I.O, I.GetDimension n (I.IKey krs ts), IsSelection sel) + => sel tag krs irs ts + -> (tag, n) + -> I.Store tag krs irs ts v + -> [(I.RawKey krs ts, v)] +lookupOrderByD sel (_, n) s = I.genericLookupDesc (resolve sel s) n s +{-# INLINE lookupOrderByD #-} + -- | The expression (@'Data.Store.size' store@) is the number of elements -- in @store@. size :: I.Store tag krs irs ts v -> Int @@ -630,7 +685,7 @@ keys (I.Store vs _ _) = Data.List.map (I.keyInternalToRaw . fst) $ Data.IntMap.elems vs {-# INLINE keys #-} --- | The expression (@'Data.Store.fromList' kvs@) is either +-- | The expression (@'Data.Store.fromList' kes@) 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 @@ -639,23 +694,63 @@ -- See also: -- -- * 'Data.Store.fromList'' +-- +-- * 'Data.Store.insertList' +-- +-- * 'Data.Store.insertList'' 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 +fromList = insertList I.empty {-# INLINE fromList #-} --- | The expression (@'Data.Store.fromList'' kvs@) is @store@ +-- | The expression (@'Data.Store.fromList' old kes@) is either +-- a) (@Just store@) where @store@ is a store containing exactly the key element pairs of @old@ plus the given +-- key-element pairs @kes@ or; +-- b) @Nothing@ if inserting any of the key-element pairs would +-- cause a collision. +-- +-- See also: +-- +-- * 'Data.Store.insertList'' +-- +-- * 'Data.Store.fromList' +-- +-- * 'Data.Store.fromList'' +insertList :: I.Empty (I.Index irs ts) => I.Store tag krs irs ts v -> [(I.Key krs ts, v)] -> Maybe (I.Store tag krs irs ts v) +insertList = Data.Foldable.foldlM (\s (k, v) -> snd <$> insert k v s) +{-# INLINE insertList #-} + +-- | The expression (@'Data.Store.fromList'' kes@) is @store@ -- containing the given key-element pairs (colliding pairs are not included). -- -- See also: -- -- * 'Data.Store.fromList' +-- +-- * 'Data.Store.insertList'' +-- +-- * 'Data.Store.insertList' 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 +fromList' = insertList' I.empty {-# INLINE fromList' #-} +-- | The expression (@'Data.Store.insertList'' old kes@) is @store@ +-- containing the key-element pairs of @old@ plus the given key-element pairs @kvs@ +-- (colliding pairs are not included and the pairs from @kes@ take precedence). +-- +-- See also: +-- +-- * 'Data.Store.insertList' +-- +-- * 'Data.Store.fromList'' +-- +-- * 'Data.Store.fromList' +insertList' :: I.Empty (I.Index irs ts) => I.Store tag krs irs ts v -> [(I.Key krs ts, v)] -> I.Store tag krs irs ts v +insertList' = Data.List.foldl' (\s (k, v) -> snd $! insert' k v $! s) +{-# INLINE insertList' #-} + -- | UNSAFE! This function can corrupt the store. -- --- The expression (@'Data.Store.fromList'' kvs@) is @store@ +-- The expression (@'Data.Store.unsafeFromList' kes@) is @store@ -- containing the given key-element pairs (colliding pairs cause UNDEFINED BEHAVIOUR). -- -- See also: @@ -664,8 +759,27 @@ -- -- * '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 +unsafeFromList = unsafeInsertList I.empty {-# INLINE unsafeFromList #-} + +-- | UNSAFE! This function can corrupt the store. +-- +-- The expression (@'Data.Store.unsafeInsertList' old kvs@) is @store@ +-- containing the key-element pairs of @old@ plus the given key-element pairs @kvs@ +-- (colliding pairs cause UNDEFINED BEHAVIOUR). +-- +-- See also: +-- +-- * 'Data.Store.insertList' +-- +-- * 'Data.Store.insertList'' +-- +-- * 'Data.Store.fromList' +-- +-- * 'Data.Store.fromList'' +unsafeInsertList :: I.Empty (I.Index irs ts) => I.Store tag krs irs ts v -> [(I.Key krs ts, v)] -> I.Store tag krs irs ts v +unsafeInsertList = Data.Foldable.foldl (\s (k, v) -> snd $ unsafeInsert k v s) +{-# INLINE unsafeInsertList #-} -- INSTANCES
src/Data/Store/Internal/Function.hs view
@@ -1,293 +1,328 @@-{-# 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-#if MIN_VERSION_containers(0,5,0)-import qualified Data.IntMap.Strict as Data.IntMap-import qualified Data.Map.Strict as Data.Map-#else-import qualified Data.IntMap-import qualified Data.Map-#endif-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 #-}-+{-# 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 +#if MIN_VERSION_containers(0,5,0) +import qualified Data.IntMap.Strict as Data.IntMap +import qualified Data.Map.Strict as Data.Map +#else +import qualified Data.IntMap +import qualified Data.Map +#endif +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 #-} + +genericLookupAsc :: I.GetDimension n (I.IKey krs ts) + => Data.IntSet.IntSet + -> n + -> I.Store tag krs irs ts v + -> [(I.RawKey krs ts, v)] +genericLookupAsc ids n (I.Store vs _ _) = + map (\(ik, v) -> (keyInternalToRaw ik, v)) . Data.List.sortBy (lookupSortComparator n) $ + Data.IntSet.foldr (\i acc -> + case Data.IntMap.lookup i vs of + Just (ik, v) -> (ik, v) : acc + _ -> acc + ) [] ids +{-# INLINE genericLookupAsc #-} + +genericLookupDesc :: I.GetDimension n (I.IKey krs ts) + => Data.IntSet.IntSet + -> n + -> I.Store tag krs irs ts v + -> [(I.RawKey krs ts, v)] +genericLookupDesc ids n (I.Store vs _ _) = + map (\(ik, v) -> (keyInternalToRaw ik, v)) . Data.List.sortBy (flip $ lookupSortComparator n) $ + Data.IntSet.foldr (\i acc -> + case Data.IntMap.lookup i vs of + Just (ik, v) -> (ik, v) : acc + _ -> acc + ) [] ids +{-# INLINE genericLookupDesc #-} + +lookupSortComparator :: I.GetDimension n (I.IKey krs ts) => n -> (I.IKey krs ts, e) -> (I.IKey krs ts, e) -> Ordering +lookupSortComparator n (k1, _) (k2, _) = case (I.getDimension n k1, I.getDimension n k2) of + (I.IKeyDimensionO d1, I.IKeyDimensionO d2) -> d1 `compare` d2 + (I.IKeyDimensionM _, I.IKeyDimensionM _) -> error $ + moduleName <> "lookupSortComparator: Comparing keys based on many-one or many-many dimensions is not supported." +{-# INLINEABLE lookupSortComparator #-} + +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
@@ -1,560 +1,590 @@-{-# 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 Data.Monoid ((<>))-#if MIN_VERSION_containers(0,5,0)-import qualified Data.IntMap.Strict as Data.IntMap-import qualified Data.Map.Strict as Data.Map-#else-import qualified Data.IntMap-import qualified Data.Map-#endif-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--+{-# 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 Data.Monoid ((<>)) +#if MIN_VERSION_containers(0,5,0) +import qualified Data.IntMap.Strict as Data.IntMap +import qualified Data.Map.Strict as Data.Map +#else +import qualified Data.IntMap +import qualified Data.Map +#endif +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) +type instance RawDimensionType n (IKey krs ts) = IKeyDimension (DimensionRelation n krs ts) (DimensionType n krs ts) + +type family LookupMap n krs irs ts v :: * +type instance LookupMap n krs irs ts v = + Data.Map.Map (DimensionType n krs ts) (LookupMapElement (DimensionRelation n krs ts) (RawKey krs ts, v)) + +type family LookupMapElement r e :: * +type instance LookupMapElement O e = e +type instance LookupMapElement M e = [e] + +-- | 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] + +type family RawKeyDimension n kspec tspec :: * +type instance RawKeyDimension Z (O :. rt) (t :. tt) = t +type instance RawKeyDimension Z (M :. rt) (t :. tt) = [t] +type instance RawKeyDimension Z O t = t +type instance RawKeyDimension Z M t = [t] +type instance RawKeyDimension (S n) (r :. rt) (t :. tt) = RawKeyDimension n rt tt + +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." + +instance GetDimension Z (IKey O t) where + getDimension _ (K1 kd) = kd + +instance GetDimension Z (IKey M t) where + getDimension _ (K1 kd) = kd + +instance GetDimension Z (IKey (r :. rt) (t :. tt)) where + getDimension _ (KN kd _) = kd + getDimension _ (K1 _) = error $ moduleName <> ".IKey.getDimension: The impossible happened." + +instance GetDimension n (IKey rt tt) => GetDimension (S n) (IKey (r :. rt) (t :. tt)) where + getDimension (S n) (KN _ kt) = getDimension n kt + getDimension _ (K1 _) = error $ moduleName <> ".IKey.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
@@ -1,33 +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-+{-# 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
@@ -1,235 +1,235 @@-{-# 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-#if MIN_VERSION_containers(0,5,0)-import qualified Data.IntMap.Strict as Data.IntMap-import qualified Data.Map.Strict as Data.Map-#else-import qualified Data.IntMap-import qualified Data.Map-#endif----------------------------------------------------------------------------------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- +{-# 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 +#if MIN_VERSION_containers(0,5,0) +import qualified Data.IntMap.Strict as Data.IntMap +import qualified Data.Map.Strict as Data.Map +#else +import qualified Data.IntMap +import qualified Data.Map +#endif +-------------------------------------------------------------------------------- +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
@@ -1,110 +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' #-}-+{-# 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
@@ -1,14 +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- ]+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
@@ -1,323 +1,375 @@-{-# 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 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-+{-# 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 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 "lookupOrderBy1" prop_lookupOrderBy1 + + , 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, lookupOrderByA #1. +prop_lookupOrderBy1 = l1 && l2 + where + l1 :: Bool + l1 = isSortedOM (S.lookupOrderByA (sMM .>= 20) sOM store) && + isSortedOM (S.lookupOrderByA (sMM .<= 50 .&& sOM .== 5) sOM store) && + isSortedOM (S.lookupOrderByA (sOO .>= 20) sOM store) && + isSortedOM (S.lookupOrderByA (sOM .>= 3) sOM store) + + isSortedOM :: [(S.RawKey DSKRS DSTS, D)] -> Bool + isSortedOM [] = True + isSortedOM [_] = True + isSortedOM ((_ :. x1 :. _, _) : (_ :. x2 :. _, _) : t) = x1 <= x2 && isSortedOM t + + l2 :: Bool + l2 = isSortedOO (S.lookupOrderByA (sMM .>= 20) sOO store) && + isSortedOO (S.lookupOrderByA (sMM .<= 50 .&& sOM .== 1) sOO store) && + isSortedOO (S.lookupOrderByA (sOO .>= 20) sOO store) && + isSortedOO (S.lookupOrderByA (sOM .>= 3) sOO store) + + isSortedOO :: [(S.RawKey DSKRS DSTS, D)] -> Bool + isSortedOO [] = True + isSortedOO [_] = True + isSortedOO ((x1 :. _, _) : (x2 :. _, _) : t) = x1 <= x2 && isSortedOO t + + 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` 20) [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..19] + + -- 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 +