diff --git a/benchmarks/src/01.hs b/benchmarks/src/01.hs --- a/benchmarks/src/01.hs +++ b/benchmarks/src/01.hs @@ -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 + diff --git a/benchmarks/src/Common.hs b/benchmarks/src/Common.hs --- a/benchmarks/src/Common.hs +++ b/benchmarks/src/Common.hs @@ -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 + + diff --git a/benchmarks/src/DS/B01.hs b/benchmarks/src/DS/B01.hs --- a/benchmarks/src/DS/B01.hs +++ b/benchmarks/src/DS/B01.hs @@ -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 +-} diff --git a/benchmarks/src/TS/B01.hs b/benchmarks/src/TS/B01.hs --- a/benchmarks/src/TS/B01.hs +++ b/benchmarks/src/TS/B01.hs @@ -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) + diff --git a/data-store.cabal b/data-store.cabal --- a/data-store.cabal +++ b/data-store.cabal @@ -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 + diff --git a/src/Data/IntSet/Extra.hs b/src/Data/IntSet/Extra.hs --- a/src/Data/IntSet/Extra.hs +++ b/src/Data/IntSet/Extra.hs @@ -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 #-} + diff --git a/src/Data/Map/Extra.hs b/src/Data/Map/Extra.hs --- a/src/Data/Map/Extra.hs +++ b/src/Data/Map/Extra.hs @@ -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 #-} + diff --git a/src/Data/Store.hs b/src/Data/Store.hs --- a/src/Data/Store.hs +++ b/src/Data/Store.hs @@ -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 diff --git a/src/Data/Store/Internal/Function.hs b/src/Data/Store/Internal/Function.hs --- a/src/Data/Store/Internal/Function.hs +++ b/src/Data/Store/Internal/Function.hs @@ -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 #-} + diff --git a/src/Data/Store/Internal/Type.hs b/src/Data/Store/Internal/Type.hs --- a/src/Data/Store/Internal/Type.hs +++ b/src/Data/Store/Internal/Type.hs @@ -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 + + diff --git a/src/Data/Store/Lens.hs b/src/Data/Store/Lens.hs --- a/src/Data/Store/Lens.hs +++ b/src/Data/Store/Lens.hs @@ -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 + diff --git a/src/Data/Store/Selection.hs b/src/Data/Store/Selection.hs --- a/src/Data/Store/Selection.hs +++ b/src/Data/Store/Selection.hs @@ -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 + diff --git a/src/Data/Store/Storable.hs b/src/Data/Store/Storable.hs --- a/src/Data/Store/Storable.hs +++ b/src/Data/Store/Storable.hs @@ -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' #-} + diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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 + ] diff --git a/tests/Test/Data/Store01.hs b/tests/Test/Data/Store01.hs --- a/tests/Test/Data/Store01.hs +++ b/tests/Test/Data/Store01.hs @@ -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 +