packages feed

data-store 0.3.0.6 → 0.3.0.7

raw patch · 16 files changed

+3408/−3300 lines, 16 files

Files

LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Petr Pilař++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Petr Pilař nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
benchmarks/src/01.hs view
@@ -1,340 +1,358 @@-{-# 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
-
+{-# 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 "insertLookup-collision(1) (Int) 01 100000"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.insertLookup 20000 9999999 9999999) ds100000+#ifndef BENCH_DS+      , C.bench "TS" $ C.whnf (forceList . TS.B01.insertLookup 20000 9999999 9999999) ts100000+#endif+      ]+    ]+#endif+  , C.bgroup "insertLookup-collision(1) (Int) 01 200000"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.insertLookup 20000 9999999 9999999) ds200000+#ifndef BENCH_DS+      , C.bench "TS" $ C.whnf (forceList . TS.B01.insertLookup 20000 9999999 9999999) ts200000+#endif+      ]+    ]+#ifdef BENCH_SMALL+  , C.bgroup "insert (Int) 01 100000"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (DS.B01.insert elem9999999) ds100000+#ifndef BENCH_DS+      , C.bench "Map" $ C.whnf (insertMap elem9999999) map100000+#endif+      ]+    ]+#endif+  , C.bgroup "insert (Int) 01 200000"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (DS.B01.insert elem9999999) ds200000+#ifndef BENCH_DS+      , C.bench "Map" $ C.whnf (insertMap elem9999999) map200000+#endif+      ]+    ]+#ifdef BENCH_SMALL+  , C.bgroup "lookup OO EQ (Int) 01 50000"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOOEQ 10000) ds50000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOOEQLens 10000) ds50000+#ifndef BENCH_DS+      , C.bench "Map" $ C.nf (Data.Map.lookup 10000) map50000+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOOEQ 10000) is50000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOOEQ 10000) ts50000+#endif+      ]+    ]+  , C.bgroup "lookup OO GE (Int) 01 50000 (500)"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOOGE 49500) ds50000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOOGELens 99500) ds50000+#ifndef BENCH_DS+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOOGE 49500) is50000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOOGE 49500) ts50000+#endif+      ]+    ]+  , C.bgroup "lookup OM EQ (Int) 01 50000"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOMEQ 200) ds50000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOMEQLens 200) ds50000+#ifndef BENCH_DS+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOMEQ 200) is50000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOMEQ 200) ts50000+#endif+      ]+    ]+  , C.bgroup "lookup OM GE (Int) 01 50000 (500)"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOMGE 9900) ds50000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOMGELens 9900) ds50000+#ifndef BENCH_DS+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOMGE 9900) is50000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOMGE 9900) ts50000+#endif+      ]+    ]+  , C.bgroup "lookup MM EQ (Int) 01 50000"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupMMEQ 200) ds50000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupMMEQLens 200) ds50000+#ifndef BENCH_DS+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupMMEQ 200) is50000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupMMEQ 200) ts50000+#endif+      ]+    ]+  , C.bgroup "lookup OO EQ (Int) 01 100000"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOOEQ 10000) ds100000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOOEQLens 10000) ds100000+#ifndef BENCH_DS+      , C.bench "Map" $ C.nf (Data.Map.lookup 10000) map100000+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOOEQ 10000) is100000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOOEQ 10000) ts100000+#endif+      ]+    ]+  , C.bgroup "lookup OO GE (Int) 01 100000 (500)"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOOGE 99500) ds100000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOOGELens 99500) ds100000+#ifndef BENCH_DS+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOOGE 99500) is100000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOOGE 99500) ts100000+#endif+      ]+    ]+  , C.bgroup "lookup OM EQ (Int) 01 100000"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOMEQ 200) ds100000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOMEQLens 200) ds100000+#ifndef BENCH_DS+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOMEQ 200) is100000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOMEQ 200) ts100000+#endif+      ]+    ]+  , C.bgroup "lookup OM GE (Int) 01 100000 (500)"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOMGE 19900) ds100000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOMGELens 19900) ds100000+#ifndef BENCH_DS+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOMGE 19900) is100000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOMGE 19900) ts100000+#endif+      ]+    ]+  , C.bgroup "lookup MM EQ (Int) 01 100000"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupMMEQ 200) ds100000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupMMEQLens 200) ds100000+#ifndef BENCH_DS+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupMMEQ 200) is100000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupMMEQ 200) ts100000+#endif+      ]+    ]+#endif+  , C.bgroup "lookup OO EQ (Int) 01 200000"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOOEQ 10000) ds200000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOOEQLens 10000) ds200000+#ifndef BENCH_DS+      , C.bench "Map" $ C.nf (Data.Map.lookup 10000) map200000+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOOEQ 10000) is200000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOOEQ 10000) ts200000+#endif+      ]+    ]+  , C.bgroup "lookup OO GE (Int) 01 200000 (500)"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOOGE 199500) ds200000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOOGELens 199500) ds200000+#ifndef BENCH_DS+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOOGE 199500) is200000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOOGE 199500) ts200000+#endif+      ]+    ]+  , C.bgroup "lookup OM EQ (Int) 01 200000"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOMEQ 200) ds200000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOMEQLens 200) ds200000+#ifndef BENCH_DS+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOMEQ 200) is200000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOMEQ 200) ts200000+#endif+      ]+    ]+  , C.bgroup "lookup OM GE (Int) 01 200000 (500)"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupOMGE 39900) ds200000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupOMGELens 39900) ds200000+#ifndef BENCH_DS+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupOMGE 39900) is200000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupOMGE 39900) ts200000+#endif+      ]+    ]+  , C.bgroup "lookup MM EQ (Int) 01 200000"+    [ C.bcompare+      [ C.bench "DS" $ C.whnf (forceList . DS.B01.lookupMMEQ 200) ds200000+      --, C.bench "DS (Lens)" $ C.whnf (forceList . DS.B01.lookupMMEQLens 200) ds200000+#ifndef BENCH_DS+      , C.bench "IS" $ C.whnf (forceList . IS.B01.lookupMMEQ 200) is200000+      , C.bench "TS" $ C.whnf (forceList . TS.B01.lookupMMEQ 200) ts200000+#endif+      ]+    ]+  ]+++---++insertListDS :: [C01] -> DS.B01.DS -> DS.B01.DS+insertListDS xs s0 = foldl' (flip DS.B01.insert) s0 xs++insertListTS :: [C01] -> TS.B01.TS -> TS.B01.TS+insertListTS xs s0 = snd $!+  foldl' (\(n, acc) x -> if n == t+                           then rnf acc `seq` (0, TS.B01.insert x acc)+                           else (n + 1, TS.B01.insert x acc)+         ) (0 :: Int, s0) xs+  where t = 10000++insertListIS :: [C01] -> IS.B01.IS -> IS.B01.IS+insertListIS xs s0 = snd $! +  foldl' (\(n, acc) x -> if n == t+                           then rnf acc `seq` (0, IS.B01.insert x acc)+                           else (n + 1, IS.B01.insert x acc)+         ) (0 :: Int, s0) xs+  where t = 10000++insertListMap :: [C01] -> Data.Map.Map Int C01 -> Data.Map.Map Int C01+insertListMap xs s0 = foldl' (flip insertMap) s0 xs++insertMap :: C01 -> Data.Map.Map Int C01 -> Data.Map.Map Int C01+insertMap x@(C01 oo _ _) = Data.Map.insert oo x++-- MAP++#ifdef BENCH_SMALL+map50000 :: Data.Map.Map Int C01+map50000 = insertListMap elems50000 Data.Map.empty++map100000 :: Data.Map.Map Int C01+map100000 = insertListMap elems100000 Data.Map.empty+#endif++map200000 :: Data.Map.Map Int C01+map200000 = insertListMap elems200000 Data.Map.empty++-- IS++#ifdef BENCH_SMALL+is50000 :: IS.B01.IS+is50000 = insertListIS elems50000 IS.B01.empty++is100000 :: IS.B01.IS+is100000 = insertListIS elems100000 IS.B01.empty+#endif++is200000 :: IS.B01.IS+is200000 = insertListIS elems200000 IS.B01.empty++-- DS++#ifdef BENCH_SMALL+ds50000 :: DS.B01.DS+ds50000 = insertListDS elems50000 DS.B01.empty++ds100000 :: DS.B01.DS+ds100000 = insertListDS elems100000 DS.B01.empty+#endif++ds200000 :: DS.B01.DS+ds200000 = insertListDS elems200000 DS.B01.empty++-- TS++#ifdef BENCH_SMALL+ts50000 :: TS.B01.TS+ts50000 = insertListTS elems50000 TS.B01.empty++ts100000 :: TS.B01.TS+ts100000 = insertListTS elems100000 TS.B01.empty+#endif++ts200000 :: TS.B01.TS+ts200000 = insertListTS elems200000 TS.B01.empty+
benchmarks/src/Common.hs view
@@ -1,76 +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
-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
-
-
+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} ++-- #define BENCH_ESSENTIALS++module Common+where++--------------------------------------------------------------------------------+import           Control.DeepSeq (NFData(..))+import           Data.Data+--------------------------------------------------------------------------------++data C01 = C01 +    {-# UNPACK #-} !Int+    {-# UNPACK #-} !Int+                   ![Int]+    deriving (Eq, Ord, Show, Typeable)++instance NFData C01 where+    rnf (C01 x y z) = rnf x `seq` rnf y `seq` rnf z++elem9999999 :: C01+elem9999999 = head $! generate 9999999 1 ++elem2500 :: C01+elem2500 = head $! generate 2500 1 ++elems5000x5000 :: [C01]+elems5000x5000 = generate 5000 5000++elems10000x5000 :: [C01]+elems10000x5000 = generate 10000 5000++-- #ifdef BENCH_SMALL+elems10000 :: [C01]+elems10000 = generate 0 10000++elems20000 :: [C01]+elems20000 = generate 0 20000++-- #else+elems50000 :: [C01]+elems50000 = generate 0 50000++elems100000 :: [C01]+elems100000 = generate 0 100000++elems200000 :: [C01]+elems200000 = generate 0 200000++elems400000 :: [C01]+elems400000 = generate 0 400000++elems800000 :: [C01]+elems800000 = generate 0 800000+-- #endif++generate :: Int -> Int -> [C01]+generate o n = map (\x -> C01 x (x `div` s) [x .. x + s]) [o .. (n + o) - 1]+  where+    s = 5++forceList :: [a] -> ()+forceList ll = seq (go ll) ()+  where+    go [] = ()+    go (_:xs) = go xs++
benchmarks/src/DS/B01.hs view
@@ -1,99 +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
-
-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
--}
+{-# LANGUAGE TypeOperators #-}++module DS.B01+where++--------------------------------------------------------------------------------+import Control.Lens+--------------------------------------------------------------------------------+import Common (C01(..))+--------------------------------------------------------------------------------+import qualified Data.Store as S+import           Data.Store (M, O, (.:), (.:.), (:.)(..), (.>=), (.==))+import           Data.Store.Lens+--------------------------------------------------------------------------------++size :: DS -> Int+size = S.size++data DSTag = DSTag++type DSTS  = Int :. Int :. Int+type DSKRS = O   :. O   :. M+type DSIRS = O   :. M   :. M++type DS    = S.Store DSTag DSKRS DSIRS DSTS C01+type DSKey = S.Key DSKRS DSTS+type DSRawKey = S.RawKey DSKRS DSTS+type DSSel = S.Selection DSTag DSKRS DSIRS DSTS++key :: C01 -> DSKey+key (C01 d1 d2 d3) = S.dimO d1 .: S.dimO d2 .:. S.dimM d3+{-# INLINE key #-}++sD1 :: (DSTag, S.N0)+sD1 = (DSTag, S.n0)+{-# INLINE sD1 #-}++sD2 :: (DSTag, S.N1)+sD2 = (DSTag, S.n1)+{-# INLINE sD2 #-}++sD3 :: (DSTag, S.N2)+sD3 = (DSTag, S.n2)+{-# INLINE sD3 #-}++insert :: C01 -> DS -> DS+insert e s = snd $! S.insert' (key e) e s++insertLookup :: Int -> Int -> Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]+insertLookup d1 d2 d3 s =+  S.lookup (sD1 .== d1) new +++  S.lookup (sD2 .== d2) new +++  S.lookup (sD3 .== d3) new+  where new = snd $! S.insert' (key e) e s+        e   = C01 d1 d2 [d3]++insertUnsafe :: C01 -> DS -> DS+insertUnsafe e s = snd $! S.unsafeInsert (key e) e s++lookupOOEQ :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]+lookupOOEQ x = S.lookup (sD1 .== x)++lookupOOEQLens :: Int -> DS -> [C01]+lookupOOEQLens x o = S.elements (o ^. with (sD1 .== x))++lookupOOGE :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]+lookupOOGE x = S.lookup (sD1 .>= x)++lookupOOGELens :: Int -> DS -> [C01]+lookupOOGELens x o = S.elements (o ^. with (sD1 .>= x))++lookupOMEQ :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]+lookupOMEQ x = S.lookup (sD2 .== x)++lookupOMEQLens :: Int -> DS -> [C01]+lookupOMEQLens x o = S.elements (o ^. with (sD2 .== x))++lookupOMGE :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]+lookupOMGE x = S.lookup (sD2 .>= x)++lookupOMGELens :: Int -> DS -> [C01]+lookupOMGELens x o = S.elements (o ^. with (sD2 .>= x))++lookupMMEQ :: Int -> DS -> [(S.RawKey DSKRS DSTS, C01)]+lookupMMEQ x = S.lookup (sD3 .== x)++lookupMMEQLens :: Int -> DS -> [C01] +lookupMMEQLens x o = S.elements (o ^. with (sD3 .== x))++empty :: DS+empty = S.empty++{-+gen  n = map (\x -> C01 x (x `div` 5) [x .. x + 5]) [0 .. (n - 1)]+gen' n = map (\x -> C01 (x `div` 2) (x `div` 5) [x .. x + 5]) [0 .. (n - 1)]+store = foldl' (flip DS.B01.insert) empty $! gen 8+newKey (C01 _ d2 d3) = key $ C01 0 d2 d3+storeU = S.updateWithKey' (\_ e -> Just (e, Just $ newKey e)) (sD1 .>= 0) store+-}
benchmarks/src/TS/B01.hs view
@@ -1,114 +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 =
-    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)
-
+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} ++module TS.B01+where++--------------------------------------------------------------------------------+import Control.Applicative+import Control.DeepSeq (NFData(..))+import Control.Lens+--------------------------------------------------------------------------------+import qualified Data.IntSet+import           Data.Foldable (toList)+import           Data.Functor.Identity+--------------------------------------------------------------------------------+import Common (C01(..))+--------------------------------------------------------------------------------+import qualified Data.Table as T+--------------------------------------------------------------------------------++size :: T.Table t -> Int+size = T.count++instance T.Tabular C01 where+  type PKT C01 = Int+  data Key k C01 b where+    D1 :: T.Key T.Primary         C01 Int+    D2 :: T.Key T.SupplementalInt C01 Int+    D3 :: T.Key T.InvertedInt     C01 Data.IntSet.IntSet+  data Tab C01 i = C01IX+    { ixd1 :: i T.Primary         Int+    , ixd2 :: i T.SupplementalInt Int+    , ixd3 :: i T.InvertedInt     Data.IntSet.IntSet+    }++  fetch D1 (C01 x _ _) = x+  fetch D2 (C01 _ x _) = x+  fetch D3 (C01 _ _ x) = Data.IntSet.fromList x++  primary = D1+  primarily D1 r = r++  mkTab f =+    C01IX <$> f D1+          <*> f D2+          <*> f D3+  +  forTab (C01IX d1 d2 d3) f =+    let x1 = f D1 d1+        x2 = f D2 d2+        x3 = f D3 d3+    in+    C01IX <$> seq x1 x1 +          <*> seq x2 x2+          <*> seq x3 x3++  ixTab (C01IX x _ _) D1 = x+  ixTab (C01IX _ x _) D2 = x+  ixTab (C01IX _ _ x) D3 = x++instance NFData (T.Tab C01 (T.AnIndex C01)) where+    rnf (C01IX x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3++type TS = T.Table C01++insert :: C01 -> TS -> TS+insert = T.insert++insertLookup :: Int -> Int -> Int -> TS -> [C01]+insertLookup d1 d2 d3 s = +  toList (new ^. T.with D1 (==) d1) +++  toList (new ^. T.with D2 (==) d2) +++  toList (new ^. T.withAny D3 [d3])+  where new = T.insert (C01 d1 d2 [d3]) s++lookupOOEQ :: Int -> TS -> [C01]+lookupOOEQ x o = toList (o ^. T.with D1 (==) x)++lookupOOGE :: Int -> TS -> [C01]+lookupOOGE x o = toList (o ^. T.with D1 (>=) x)++lookupOMEQ :: Int -> TS -> [C01]+lookupOMEQ x o = toList (o ^. T.with D2 (==) x)++lookupOMGE :: Int -> TS -> [C01]+lookupOMGE x o = toList (o ^. T.with D2 (>=) x)++lookupMMEQ :: Int -> TS -> [C01]+lookupMMEQ x o = toList (o ^. T.withAny D3 [x])++empty :: TS+empty = T.empty++force :: TS -> ()+force T.EmptyTable = ()+force (T.Table tab) = seq go ()+  where+    go :: T.Tab C01 (T.AnIndex C01)+    go = runIdentity $! T.forTab tab (\_ i -> Identity $! case i of+      T.PrimaryMap m -> m `seq` T.PrimaryMap m+      T.CandidateMap m -> m `seq` T.CandidateMap m+      T.CandidateIntMap m -> m `seq` T.CandidateIntMap m+      T.CandidateHashMap m -> m `seq` T.CandidateHashMap m+      T.SupplementalMap m -> m `seq` T.SupplementalMap m+      T.SupplementalIntMap m -> m `seq` T.SupplementalIntMap m+      T.SupplementalHashMap m -> m `seq` T.SupplementalHashMap m+      T.InvertedMap m -> m `seq` T.InvertedMap m+      T.InvertedIntMap m -> m `seq` T.InvertedIntMap m+      T.InvertedHashMap m -> m `seq` T.InvertedHashMap m)+
data-store.cabal view
@@ -1,114 +1,114 @@-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
-
+name:                data-store+version:             0.3.0.7++synopsis:    Type safe, in-memory dictionary with multidimensional keys.+description: Type safe, in-memory dictionary with multidimensional keys.+  Similar to ixset, higgsset, tables. But offers: type safe interface,+  auto-increment dimensions, specifying the relationships between the key dimension and the elements (one-one, one-many, many-one, many-many), performance. ++homepage: https://github.com/Palmik/data-store           ++license:             BSD3+license-file:        LICENSE++author:              Petr Pilar+maintainer:          the.palmik+maintainer@gmail.com++category:            Data++build-type:          Simple+cabal-version:       >= 1.8++source-repository head+  type: git+  location: git://github.com/Palmik/data-store.git+  branch: master++library+  hs-source-dirs:      src+  exposed-modules:+      Data.Store+    , Data.Store.Selection+    , Data.Store.Storable+    , Data.Store.Lens+    +    , Data.Store.Internal.Type+    , Data.Store.Internal.Function+  +  other-modules:+      Data.Map.Extra+    , Data.IntSet.Extra++  build-depends:+      base         >= 4.5 && < 5+    , containers   >= 0.4 && < 1+    , lens         >= 3.9 && < 4+    , transformers >= 0.2 && < 0.4++    , cereal     >= 0.3.5 && < 0.4+    , deepseq    >= 1.3.0 && < 1.4+    , safecopy   >= 0.8 && < 0.9+  ghc-options: -O2 -Wall++test-suite data-store-tests+  type:           exitcode-stdio-1.0+  hs-source-dirs: tests, src+  main-is:        Main.hs++  other-modules:+      Test.Data.Store01++    , Data.Store    +    , Data.Store.Lens    +  +  build-depends:+      base         >= 4.5 && < 5+    , containers   >= 0.4 && < 1+    , lens         >= 3.9 && < 4+    , transformers >= 0.2 && < 0.4+    , vector       >= 0.10 && < 0.11++    , cereal     >= 0.3.5 && < 0.4+    , deepseq    >= 1.3.0 && < 1.4+    , safecopy   >= 0.8 && < 0.9++    , test-framework             >= 0.8+    , test-framework-quickcheck2 >= 0.3+    , QuickCheck                 >= 2.4 && < 2.6++benchmark data-store-benchmark-01+  type:           exitcode-stdio-1.0+  hs-source-dirs: benchmarks/src, src+  main-is:        01.hs++  other-modules:+      Common+    , DS.B01+    , TS.B01+++  build-depends:+      base         >= 4.6 && < 5+    , containers   >= 0.5 && < 1+    , lens         >= 3.9 && < 4+    , transformers >= 0.2 && < 0.4+    , vector       >= 0.10 && < 0.11++    , cereal     >= 0.3.5 && < 0.4+    , deepseq    >= 1.3.0 && < 1.4+    , safecopy   >= 0.8 && < 0.9++    , unordered-containers >= 0.2+    , tagged     >= 0.4+    , mtl        >= 2.1++    , ixset+    , tables     >= 0.3.1.1+    , lens       >= 3.8+    , bytestring +    , criterion  >= 0.6.2+    , deepseq    >= 1.3.0+    , random     >= 1.0.1+  +  ghc-options: -Wall -O2+
src/Data/IntSet/Extra.hs view
@@ -1,41 +1,41 @@-module Data.IntSet.Extra
-( foldrM
-, foldrM'
-, foldlM
-, foldlM'
-) where
-
---------------------------------------------------------------------------------
-import qualified Data.IntSet
---------------------------------------------------------------------------------
-
--- TODO: Measure INLINE/SPECIALIZE tradeoff.
-
--- | Monadic fold over the elements of a `Data.IntSet.IntSet`,
--- associating to the right, i.e. from right to left. 
-foldrM :: Monad f => (Int -> b -> f b) -> b -> Data.IntSet.IntSet -> f b
-foldrM go start = Data.IntSet.foldr (\i acc -> acc >>= go i) (return start)
-{-# INLINE foldrM #-}
---{-# SPECIALIZE foldrM :: (Int -> b -> Maybe b) -> b -> Data.IntSet.IntSet -> Maybe b #-}
-
--- | Strict monadic fold over the elements of a `Data.IntSet.IntSet`,
--- associating to the right, i.e. from right to left. 
-foldrM' :: Monad f => (Int -> b -> f b) -> b -> Data.IntSet.IntSet -> f b
-foldrM' go start = Data.IntSet.foldr' (\i acc -> acc >>= go i) (return start)
-{-# INLINE foldrM' #-}
---{-# SPECIALIZE foldrM' :: (Int -> b -> Maybe b) -> b -> Data.IntSet.IntSet -> Maybe b #-}
-
--- | Monadic fold over the elements of a `Data.IntSet.IntSet`,
--- associating to the left, i.e. from left to right. 
-foldlM :: Monad f => (b -> Int -> f b) -> b -> Data.IntSet.IntSet -> f b
-foldlM go start = Data.IntSet.foldl (\acc i -> acc >>= flip go i) (return start)
-{-# INLINE foldlM #-}
---{-# SPECIALIZE foldlM :: (b -> Int -> Maybe b) -> b -> Data.IntSet.IntSet -> Maybe b #-}
-
--- | Monadic fold over the elements of a `Data.IntSet.IntSet`,
--- associating to the left, i.e. from left to right. 
-foldlM' :: Monad f => (b -> Int -> f b) -> b -> Data.IntSet.IntSet -> f b
-foldlM' go start = Data.IntSet.foldl' (\acc i -> acc >>= flip go i) (return start)
-{-# INLINE foldlM' #-}
---{-# SPECIALIZE foldlM' :: (b -> Int -> Maybe b) -> b -> Data.IntSet.IntSet -> Maybe b #-}
-
+module Data.IntSet.Extra+( foldrM+, foldrM'+, foldlM+, foldlM'+) where++--------------------------------------------------------------------------------+import qualified Data.IntSet+--------------------------------------------------------------------------------++-- TODO: Measure INLINE/SPECIALIZE tradeoff.++-- | Monadic fold over the elements of a `Data.IntSet.IntSet`,+-- associating to the right, i.e. from right to left. +foldrM :: Monad f => (Int -> b -> f b) -> b -> Data.IntSet.IntSet -> f b+foldrM go start = Data.IntSet.foldr (\i acc -> acc >>= go i) (return start)+{-# INLINE foldrM #-}+--{-# SPECIALIZE foldrM :: (Int -> b -> Maybe b) -> b -> Data.IntSet.IntSet -> Maybe b #-}++-- | Strict monadic fold over the elements of a `Data.IntSet.IntSet`,+-- associating to the right, i.e. from right to left. +foldrM' :: Monad f => (Int -> b -> f b) -> b -> Data.IntSet.IntSet -> f b+foldrM' go start = Data.IntSet.foldr' (\i acc -> acc >>= go i) (return start)+{-# INLINE foldrM' #-}+--{-# SPECIALIZE foldrM' :: (Int -> b -> Maybe b) -> b -> Data.IntSet.IntSet -> Maybe b #-}++-- | Monadic fold over the elements of a `Data.IntSet.IntSet`,+-- associating to the left, i.e. from left to right. +foldlM :: Monad f => (b -> Int -> f b) -> b -> Data.IntSet.IntSet -> f b+foldlM go start = Data.IntSet.foldl (\acc i -> acc >>= flip go i) (return start)+{-# INLINE foldlM #-}+--{-# SPECIALIZE foldlM :: (b -> Int -> Maybe b) -> b -> Data.IntSet.IntSet -> Maybe b #-}++-- | Monadic fold over the elements of a `Data.IntSet.IntSet`,+-- associating to the left, i.e. from left to right. +foldlM' :: Monad f => (b -> Int -> f b) -> b -> Data.IntSet.IntSet -> f b+foldlM' go start = Data.IntSet.foldl' (\acc i -> acc >>= flip go i) (return start)+{-# INLINE foldlM' #-}+--{-# SPECIALIZE foldlM' :: (b -> Int -> Maybe b) -> b -> Data.IntSet.IntSet -> Maybe b #-}+
src/Data/Map/Extra.hs view
@@ -1,24 +1,24 @@-{-# LANGUAGE CPP #-}
-
-module Data.Map.Extra
-( insertUnique
-) where
-
---------------------------------------------------------------------------------
-#if MIN_VERSION_containers(0,5,0)
-import qualified Data.Map.Strict as Data.Map
-#else
-import qualified Data.Map
-#endif
---------------------------------------------------------------------------------
-
--- | The expression (@insertUnique k v old@)
--- returns (@Just (Data.Map.insert k v old)@) if the map @old@ did not contain
--- anything under the key @k@, otherwise returns @Nothing@.
-insertUnique :: Ord k => k -> a -> Data.Map.Map k a -> Maybe (Data.Map.Map k a)
-insertUnique k a m =
-    case Data.Map.insertLookupWithKey (\_ _ o' -> o') k a m of
-        (Nothing, res) -> Just res
-        (Just _,  _) -> Nothing
-{-# INLINE insertUnique #-}
-
+{-# LANGUAGE CPP #-}++module Data.Map.Extra+( insertUnique+) where++--------------------------------------------------------------------------------+#if MIN_VERSION_containers(0,5,0)+import qualified Data.Map.Strict as Data.Map+#else+import qualified Data.Map+#endif+--------------------------------------------------------------------------------++-- | The expression (@insertUnique k v old@)+-- returns (@Just (Data.Map.insert k v old)@) if the map @old@ did not contain+-- anything under the key @k@, otherwise returns @Nothing@.+insertUnique :: Ord k => k -> a -> Data.Map.Map k a -> Maybe (Data.Map.Map k a)+insertUnique k a m =+    case Data.Map.insertLookupWithKey (\_ _ o' -> o') k a m of+        (Nothing, res) -> Just res+        (Just _,  _) -> Nothing+{-# INLINE insertUnique #-}+
src/Data/Store.hs view
@@ -1,807 +1,822 @@-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE TypeFamilies        #-}
-{-# LANGUAGE TypeOperators       #-}
-{-# LANGUAGE CPP                 #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-} 
-
---------------------------------------------------------------------------------
--- |
---
--- Module : Data.Store
--- Copyright : (c) Petr Pilar 2012
--- License : BSD-style
---
--- Dictionary with multidimensional keys and type-safe interface.
---
--- These modules are intended to be imported qualified to avoid name
--- clashes with prelude, e.g.:
---
--- > import qualified Data.Store as S
--- > import           Data.Store (M, O, (.:), (.:.), (:.), (.<), (.<=), (.>), (.>=), (./=), (.==), (.&&), (.||))
---
--- Throughout out the documentation, the examples will be based on this
--- code:
---
--- > {-# LANGUAGE TypeOperators #-}
--- > 
--- > module Example01
--- > where
--- > 
--- > --------------------------------------------------------------------------------
--- > import           Control.Applicative
--- > import qualified Control.Monad.State as State
--- > --------------------------------------------------------------------------------
--- > import qualified Data.Store as S
--- > import           Data.Store (M, O, (.:), (.:.), (:.)(..), (.<), (.<=), (.>), (.>=), (./=), (.==), (.&&), (.||))
--- > --------------------------------------------------------------------------------
--- > 
--- > data Content = Content
--- >     { contentName :: String  
--- >     , contentBody :: String  
--- >     , contentTags :: [String]
--- >     , contentRating :: Double
--- >     }
--- > 
--- > type ContentID = Int
--- > 
--- > -- Content has one ID, only one content can have a given ID.
--- > -- Content has one name, only one content can have a given name.
--- > -- Content has one body, many contents can have the same content.
--- > -- Content has many tags, many contents can have the same tag.
--- > -- Content has one rating, many contents can have the same rating.
--- > 
--- > data ContentStoreTag = ContentStoreTag
--- > 
--- > type ContentStoreTS  = ContentID :. String :. String :. String :. Double
--- > type ContentStoreKRS = O         :. O      :. O      :. M      :. O
--- > type ContentStoreIRS = O         :. O      :. M      :. M      :. M
--- > type ContentStore = S.Store ContentStoreTag ContentStoreKRS ContentStoreIRS ContentStoreTS Content
--- > type ContentStoreKey = S.Key ContentStoreKRS ContentStoreTS
--- > type ContentStoreSelection = S.Selection ContentStoreTag ContentStoreKRS ContentStoreIRS ContentStoreTS
--- > 
--- > sContentID :: (ContentStoreTag, S.N0)
--- > sContentID = (ContentStoreTag, S.n0)
--- > 
--- > sContentName :: (ContentStoreTag, S.N1)
--- > sContentName = (ContentStoreTag, S.n1)
--- > 
--- > sContentBody :: (ContentStoreTag, S.N2)
--- > sContentBody = (ContentStoreTag, S.n2)
--- > 
--- > sContentTag :: (ContentStoreTag, S.N3)
--- > sContentTag = (ContentStoreTag, S.n3)
--- > 
--- > sContentRating :: (ContentStoreTag, S.N4)
--- > sContentRating = (ContentStoreTag, S.n4)
---
--- Glossary
---
--- * Key (type/value) -- refers either to the type or value of a key of the
--- store.
---
--- * Key dimension -- refers to one dimension of a key (e.g.: article's
--- author, article's tag). Refers to the dimension as a whole, together
--- with its properties, etc.
---
--- * Key dimension value -- refers to some concrete value from the domain of the
--- dimension.
---
--- * Element (type/value) -- refers either to the type or value of the elements
--- (in literature, the term \"value\" is usually used, be here it would
--- clash far too often) of the store.
---
--- The implementation is based on "Data.Map", "Data.Set", "Data.IntMap" and
--- "Data.IntSet".
---
--- The following variables and constants are used in Big-O notation:
---
--- * /W/ -- the (constant) number of bits of "Int" (32 or 64).
--- 
--- * /d/ -- the (constant) number of dimensions of the store.
--- 
--- * /k/ -- the (variable) number of key dimensions values of a key (or
--- maximum of the number of key dimension values over all keys in case of for example
--- @'Data.Store.updateWithKey'@).
---
--- * /s/ -- the (variable) size of the output of the operation or the
--- (variable) number of elements affected by the operation. This is
--- often the number of key-element pairs that correspond to some selection.
--- 
--- * /s(sel)/ -- the (variable) number of key-element pairs that correspond
--- to a selection /sel/ if /s/ would otherwise be ambigious.
---
--- * /c/ -- the (variable) complexity of selection.
---
--- * /c(sel)/ -- the (variable) complexity of resolving the selection /sel/ if /c/
--- would otherwise be ambiguous.
-module Data.Store
-(
-  -- * Types
-  I.Store
-, I.Key
-, I.KeyDimension
-, I.RawKey
-, I.M
-, I.O
-, (I.:.)(..)
-, I.Auto
-
-  -- * Creating
-, I.empty
-, singleton
-
-  -- * Inserting
-, insert
-, insert'
-, unsafeInsert
-
-  -- * Updating
-, updateWithKey
-, updateWithKey'
-, update
-, update'
-, updateElements
-, delete
-
-  -- * Traversing
-, map
-
-  -- * Folding
-, foldr
-, foldrWithKey
-
-, foldl
-, foldlWithKey
-
-  -- * List
-, toList
-, elements
-, keys
-, insertList
-, insertList'
-, unsafeInsertList
-, fromList
-, fromList'
-, unsafeFromList
-
-  -- * Querying
-, size
-, lookup
-, lookupOrderByA
-, lookupOrderByD
-
-  -- ** Selection
-  --
-  -- $selection
-, Selection
-, not
-, (.<)
-, (.<=)
-, (.>)
-, (.>=)
-, (./=)
-, (.==)
-, (.&&)
-, (.||)
-
-  -- * Constructing Key
-  -- 
-  -- $constructing-key
-, dimA
-, dimO
-, dimM
-, (.:)
-, (.:.)
-
-  -- * Utility
-, I.S(..)
-, I.Z
-, I.N0
-, I.N1
-, I.N2
-, I.N3
-, I.N4
-, I.N5
-, I.N6
-, I.N7
-, I.N8
-, I.N9
-, I.N10
-, I.n0
-, I.n1
-, I.n2
-, I.n3
-, I.n4
-, I.n5
-, I.n6
-, I.n7
-, I.n8
-, I.n9
-, I.n10
-
-  -- * Debugging
-, showIndex
-, printIndex
-, moduleName
-) where
-
---------------------------------------------------------------------------------
-import           Prelude hiding (lookup, map, foldr, foldl, not)
---------------------------------------------------------------------------------
-import           Control.Applicative hiding (empty)
---------------------------------------------------------------------------------
-import           Data.Monoid
-import           Data.Maybe
-import           Data.Functor.Identity
-#if MIN_VERSION_containers(0,5,0)
-import qualified Data.IntMap.Strict as Data.IntMap
-#else
-import qualified Data.IntMap
-#endif
-import qualified Data.List
-import qualified Data.Foldable
---------------------------------------------------------------------------------
-import qualified Data.Store.Internal.Type     as I
-import qualified Data.Store.Internal.Function as I
-import           Data.Store.Selection 
---------------------------------------------------------------------------------
-
--- | The name of this module.
-moduleName :: String
-moduleName = "Data.Store"
-{-# INLINE moduleName #-}
-
--- INTERFACE
-
--- $selection
--- Functions from this category are used to create selections.
---
--- Example:
---
--- > -- Select any content with rating between 3 and 4.
--- > let sel1 = sContentRating .> 3
--- >
--- > -- Select any content that is tagged with "haskell" or "category-theory"
--- > -- and is not tagged with "fluff".
--- > let sel2 = (sContentTag .== "haskell" .|| sContentTag .== "category-theory") .&& not' (sContentTag .== "fluff")
--- >
--- > -- Selection that is intersection of sel1 and sel2.
--- > let sel3 = sel1 .&& sel2
---
--- These selections can be then used in functions like lookup, update,
--- delete, etc.
---  
--- >>> lookup sel3 store
--- > -- key-element pairs that match the selection
---
--- >>> delete (not' sel3) store
--- > -- store with the key-element pairs that do not match the selection
---
--- >>> updateElements (\v -> Just v { contentRating = 5 }) sel3 store
--- > -- store with the selected key-element pairs updated 
-
-
--- $constructing-key
--- Functions from this category are used to create a key for your store. Function for
--- creating a key for our @Content@ data type could look like this:
---
--- > makeContentKey :: ContentID -> String -> String -> [String] -> Double -> ContentStoreKey
--- > makeContentKey cid cn cb cts cr =
--- >    S.dimO cid .: S.dimO cn .: S.dimO cb .: S.dimM cts .:. S.dimO cr
---
--- Notice that this function allows you to specify all the dimensions of
--- the key, including the ID dimension. Usually we do not need this level
--- of flexibility a would use function like this instead:
---
--- > contentKey :: Content -> ContentStoreKey
--- > contentKey (Content cn cb cts cr) =
--- >    S.dimA .: S.dimO cn .: S.dimO cb .: S.dimM cts .:. S.dimO cr
---
--- This function creates a key for given element of type @Content@ (element), the ID
--- dimension is "automatic", which means that the assigned ID will be @succ
--- max@ where @max@ is the value of the maximum ID in the store when
--- inserting.
---
--- See also:
---
--- * 'Data.Store.Storable.Storable'
-
--- | Function for creating an auto-increment dimension. Can be used instead
--- of (@dimO x@) if the type is an instance of the
--- @'Data.Store.Internal.Auto'@ type-class.
-dimA :: I.Auto t => I.KeyDimension I.O t
-dimA = I.KeyDimensionA
-{-# INLINE dimA #-}
-
--- | Function for creating dimensions with the relation
--- \"one-<anything>\".
-dimO :: Ord t => t -> I.KeyDimension I.O t
-dimO = I.KeyDimensionO
-{-# INLINE dimO #-}
-
--- | Function for creating dimensions with the relation
--- \"many-<anything>\".
-dimM :: Ord t => [t] -> I.KeyDimension I.M t
-dimM = I.KeyDimensionM
-{-# INLINE dimM #-}
-
--- | Function for connecting one dimension and rest of the key.
-(.:) :: dim r t
-     -> I.GenericKey dim rs1 ts1 
-     -> I.GenericKey dim (r I.:. rs1) (t I.:. ts1)
-(.:) = I.KN
-{-# INLINE (.:) #-}
-infixr 3 .:
-
--- | Function for connecting one dimensions with another (most often the
--- last dimension of the key).
-(.:.) :: dim r1 t1
-      -> dim r2 t2
-      -> I.GenericKey dim (r1 I.:. r2) (t1 I.:. t2)
-(.:.) d1 d2 = I.KN d1 (I.K1 d2)
-{-# INLINE (.:.) #-}
-infixr 3 .:.
-
--- CREATING
-
-
--- | The expression (@'Data.Store.singleton' k v@) is store that contains
--- only the @(k, v)@ as a key-element pair.
-singleton :: I.Empty (I.Index irs ts)
-          => I.Key krs ts -> v -> I.Store tag krs irs ts v
-singleton k v = snd . fromJust $ insert k v I.empty
-{-# INLINE singleton #-}
-
--- INSERTING
-
--- | The expression (@'Data.Store.insert' k e old@) is either
--- @Nothing@ if inserting the @(k, e)@ key-element pair would cause
--- a collision or (@Just (rk, new)@), where @rk@ is the raw key of
--- @k@ and @new@ is store containing the same key-element pairs as @old@ plus
--- @(k, e)@. 
---
--- Examples:
---
--- >>> let content = Content "name" "body" ["t1", "t2"] 0.5
--- >>> insert (contentKey content) content store
--- > Just (1 :. "name" :. "body" :. ["t1", "t2"] :. 0.5, <updated_store>)
---
--- Complexity: /O(min(n, W) + k * (log n + min(n, W)))/
---
--- See also:
---
--- * 'Data.Store.insert''
---
--- * 'Data.Store.Internal.Type.Key'
---
--- * 'Data.Store.Internal.Type.RawKey'
-insert :: I.Key krs ts
-       -> v
-       -> I.Store tag krs irs ts v
-       -> Maybe (I.RawKey krs ts, I.Store tag krs irs ts v)
-insert k v old@(I.Store _ index _) =
-    (\res -> (I.keyInternalToRaw internal, res)) <$> I.genericInsert I.indexInsertID internal v old
-    where
-      internal = I.keyToInternal index k
-
--- | The expression (@'Data.Store.insert'' k v old@) is @(rk, new)@,
--- where @rk@ is the raw key of @k@ and @new@ is a store that contains
--- the same key-element pairs as @old@ plus @(k, e)@.
--- Any key-value pairs from @old@ colliding with @(k, e)@ are not included in @new@.
---
--- Complexity: /O(min(n, W) + k * (log n + min(n, W)))/
---
--- See also:
---
--- * 'Data.Store.insert'
---
--- * 'Data.Store.Internal.Type.Key'
---
--- * 'Data.Store.Internal.Type.RawKey'
-insert' :: I.Key krs ts
-        -> e
-        -> I.Store tag krs irs ts e
-        -> (I.RawKey krs ts, I.Store tag krs irs ts e)
-insert' k e old@(I.Store _ index _) =
-    (I.keyInternalToRaw internal, runIdentity $! I.genericInsert I.indexInsertID' internal e old)
-    where
-      internal = I.keyToInternal index k
-{-# INLINE insert' #-}
-
--- | UNSAFE! This function can corrupt the store.
---
--- The expression (@'Data.Store.unsafeInsert' k v old@) is @(rk, new)@,
--- where @rk@ is the raw key of @k@ and @new@ is a store that contains
--- the same key-element pairs as @old@ plus @(k, e)@.
--- Any key-value pairs from @old@ colliding with @(k, e)@ will cause UNDEFINED BEHAVIOUR.
---
--- See also:
---
--- * 'Data.Store.insert'
---
--- * 'Data.Store.insert''
---
--- * 'Data.Store.Internal.Type.Key'
---
--- * 'Data.Store.Internal.Type.RawKey'
-unsafeInsert :: I.Key krs ts
-             -> e
-             -> I.Store tag krs irs ts e
-             -> (I.RawKey krs ts, I.Store tag krs irs ts e)
-unsafeInsert k e old@(I.Store _ index _) =
-    (I.keyInternalToRaw internal, runIdentity $! I.genericInsert I.indexInsertID'' internal e old)
-    where
-      internal = I.keyToInternal index k
-{-# INLINE unsafeInsert #-}
-
--- TRAVERSING
-
--- | The expression @('Data.Store.map' tr old@) is store where every element of
--- @old@ was transformed using the function @tr@.
-map :: (v1 -> v2) -> I.Store tag krs irs ts v1 -> I.Store tag krs irs ts v2
-map tr store@(I.Store vs _ _) = store
-    { I.storeV = Data.IntMap.map (\(ik, v) -> (ik, tr v)) vs
-    }
-{-# INLINE map #-}
-
--- QUERYING
-
--- | The expression (@'Data.Store.Selection.lookup' sel store@) is
--- list of (raw key)-element pairs that match the selection.
--- 
--- Complexity: /O(c + s * min(n, W))/
---
--- 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
-size (I.Store vs _ _) = Data.IntMap.size vs
-{-# INLINE size #-}
-
--- UPDATING
-
--- | The expression (@'Data.Store.updateWithKey' tr sel old@)
--- is (@Just new@) where @new@ is a store containing the same key-element
--- pairs as @old@ except for any key-element pairs @(k, e)@ that match the
--- selection @sel@, those are updated as follows:
---
--- * If @(tr k e)@ is @Nothing@ the pair is not included in @new@.
---
--- * If @(tr k e)@ is (@Just (e', Nothing)@) the pair is replaced by pair @(k, e')@.
---
--- * If @(tr k e)@ is (@Just (e', Just k')@) the pair is replaced by pair @(k', e')@.
---
--- If any of the updated key-element pairs would cause a collision, the
--- result is @Nothing@.
---
--- Complexity: /O(c + s * (min(n, W) + k * (log n + min(n, W))))/
---
--- See also:
---
---   * 'Data.Store.updateWithKey''
-updateWithKey :: IsSelection sel
-              => (I.RawKey krs ts -> v -> Maybe (v, Maybe (I.Key krs ts)))
-              -> sel tag krs irs ts
-              -> I.Store tag krs irs ts v
-              -> Maybe (I.Store tag krs irs ts v)
-updateWithKey tr sel s = I.genericUpdateWithKey I.indexInsertID tr (resolve sel s) s
-{-# INLINE updateWithKey #-}
-
--- | The expression (@'Data.Store.updateWithKey'' tr sel old@)
--- is @new@ where @new@ is a store containing the same key-element
--- pairs as @old@ except for any key-element pairs @(k, e)@ that match the
--- selection @sel@, those are updated as follows:
---
--- * If @(tr k e)@ is @Nothing@ the pair is not included in @new@.
---
--- * If @(tr k e)@ is (@Just (e', Nothing)@) the pair is replaced by pair @(k, e')@.
---
--- * If @(tr k e)@ is (@Just (e', Just k')@) the pair is replaced by pair @(k', e')@.
---
--- Any pairs of the original store @old@ that would, after the update, cause collisons
--- are not included in @new@. 
---
--- Complexity: /O(c + s * d * (min(n, W) + k * (log n + min(n, W))))/
---
--- See also:
---
---   * 'Data.Store.updateWithKey'
-updateWithKey' :: IsSelection sel
-               => (I.RawKey krs ts -> v -> Maybe (v, Maybe (I.Key krs ts)))
-               -> sel tag krs irs ts
-               -> I.Store tag krs irs ts v
-               -> I.Store tag krs irs ts v
-updateWithKey' tr sel s = runIdentity $! I.genericUpdateWithKey I.indexInsertID' tr (resolve sel s) s
-{-# INLINE updateWithKey' #-}
-
--- | The expression (@'Data.Store.update' tr sel s@) is equivalent
--- to (@'Data.Store.Selection.updateWithKey' tr' sel s@) where
--- (@tr' = (\_ v -> tr v) = const tr@).
---
--- Complexity: /O(c + s * (min(n, W) + q * log n))/ 
-update :: IsSelection sel
-       => (v -> Maybe (v, Maybe (I.Key krs ts)))
-       -> sel tag krs irs ts
-       -> I.Store tag krs irs ts v
-       -> Maybe (I.Store tag krs irs ts v)
-update tr = updateWithKey (const tr)
-{-# INLINE update #-}
-
--- | The expression (@'Data.Store.update'' tr sel s@) is equivalent
--- to (@'Data.Store.Selection.updateWithKey'' tr' sel s@) where
--- (@tr' = (\_ v -> tr v) = const tr@).
---
--- Complexity: /O(c + d * s * (min(n, W) + q * log n))/ 
-update' :: IsSelection sel
-        => (v -> Maybe (v, Maybe (I.Key krs ts)))
-        -> sel tag krs irs ts
-        -> I.Store tag krs irs ts v
-        -> I.Store tag krs irs ts v
-update' tr = updateWithKey' (const tr)
-{-# INLINE update' #-}
-
--- | The expression (@'Data.Store.updateElements' tr sel s@) is equivalent
--- to (@'Data.Store.Selection.update' tr' sel s@) where
--- (@tr' = (maybe Nothing (\v -> Just (v, Nothing)) . tr)@).
---
--- Complexity: /O(c + s * min(n, W))/ 
-updateElements :: IsSelection sel
-               => (v -> Maybe v)
-               -> sel tag krs irs ts
-               -> I.Store tag krs irs ts v
-               -> I.Store tag krs irs ts v
-updateElements tr sel s =
-  runIdentity $! I.genericUpdateWithKey I.indexInsertID'' tr' (resolve sel s) s
-  where
-    tr' _ = maybe Nothing (\v -> Just (v, Nothing)) . tr
-    {-# INLINE tr' #-}
-{-# INLINE updateElements #-}             
-
--- | The expression (@'Data.Store.Selection.delete' sel old@) is
--- equivalent to
--- (@'Data.Store.fromJust' $ 'Data.Store.Selection.update' (const Nothing) sel old@).
---
--- Complexity: /O(c + s * (min(n, W) + q * log n)/ 
-delete :: IsSelection sel
-       => sel tag krs irs ts
-       -> I.Store tag krs irs ts v
-       -> I.Store tag krs irs ts v
-delete sel s =
-  runIdentity $! I.genericUpdateWithKey I.indexInsertID'' (\_ _ -> Nothing) (resolve sel s) s
-{-# INLINE delete #-}
-
--- FOLDING
-
--- | The expression (@'Data.Store.foldrWithKey' f z s@) folds the store
--- using the given right-associative operator.
-foldrWithKey :: (I.RawKey krs ts -> v -> b -> b)
-             -> b
-             -> I.Store tag krs irs ts v
-             -> b
-foldrWithKey accum start (I.Store vs _ _) =
-    Data.IntMap.foldr (\(ik, v) b -> accum (I.keyInternalToRaw ik) v b) start vs
-{-# INLINE foldrWithKey #-}
-
--- | The expression (@'Data.Store.foldr' f z s@) folds the store
--- using the given right-associative binary operator.
-foldr :: (v -> b -> b)
-      -> b
-      -> I.Store tag krs irs ts v
-      -> b
-foldr accum start (I.Store vs _ _) =
-    Data.IntMap.foldr (\(_, v) b -> accum v b) start vs
-{-# INLINE foldr #-}
-
--- | The expression (@'Data.Store.foldlWithKey' f z s@) folds the store
--- using the given left-associative operator.
-foldlWithKey :: (b -> I.RawKey krs ts -> v -> b)
-              -> b 
-              -> I.Store tag krs irs ts v
-              -> b
-foldlWithKey accum start (I.Store vs _ _) =
-    Data.IntMap.foldl (\b (ik, v) -> accum b (I.keyInternalToRaw ik) v) start vs
-{-# INLINE foldlWithKey #-}
-
--- | The expression (@'Data.Store.foldl' f z s@) folds the store
--- using the given left-associative binary operator.
-foldl :: (b -> v -> b)
-      -> b
-      -> I.Store tag krs irs ts v
-      -> b
-foldl accum start (I.Store vs _ _) =
-    Data.IntMap.foldl (\b (_, v) -> accum b v) start vs
-{-# INLINE foldl #-}
-
--- LISTS
-
--- | The expression (@'Data.Store.toList' store@) is a list of key-element pairs that are stored in @store@.
-toList :: I.Store tag krs irs ts v -> [(I.RawKey krs ts, v)]
-toList (I.Store vs _ _) = Data.List.map (\(ik, v) -> (I.keyInternalToRaw ik, v)) $ Data.IntMap.elems vs
-{-# INLINE toList #-}
-
--- | The expression (@'Data.Store.elements' store@) is a list of elements that
--- are stored in @store@.
-elements :: I.Store tag krs irs ts v -> [v]
-elements (I.Store vs _ _) = Data.List.map snd $ Data.IntMap.elems vs
-{-# INLINE elements #-}
-
--- | The expression (@'Data.Store.keys' store@) is a list of pairs raw
--- keys that are stored in @store@.
-keys :: I.Store tag krs irs ts v -> [I.RawKey krs ts]
-keys (I.Store vs _ _) = Data.List.map (I.keyInternalToRaw . fst) $ Data.IntMap.elems vs
-{-# INLINE keys #-}
-
--- | The expression (@'Data.Store.fromList' 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
--- cause a collision.
---
--- 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 = insertList I.empty
-{-# INLINE fromList #-}
-
--- | 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' = 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.unsafeFromList' kes@) is @store@
--- containing the given key-element pairs (colliding pairs cause UNDEFINED BEHAVIOUR).
---
--- See also:
---
--- * 'Data.Store.fromList'
---
--- * 'Data.Store.fromList'
-unsafeFromList :: I.Empty (I.Index irs ts) => [(I.Key krs ts, v)] -> I.Store tag krs irs ts v
-unsafeFromList = 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
-
-instance Functor (I.Store tag krs irs ts) where
-    fmap = map
-    {-# INLINE fmap #-}
-
-instance I.Empty (I.Index irs ts) => Monoid (I.Store tag krs irs ts v) where
-    mempty = I.empty
-    {-# INLINE mempty #-}
-
-    mappend oldl (I.Store kes _ _) =
-      Data.IntMap.foldl (\acc (ik, e) -> runIdentity $! I.genericInsert I.indexInsertID' ik e acc) oldl kes
-
--- UTILITY
-
-showIndex :: Show (I.Index irs ts) => I.Store tag krs irs ts v -> String
-showIndex (I.Store _ i _) = show i
-{-# INLINE showIndex #-}
-
-printIndex :: Show (I.Index irs ts) => I.Store tag krs irs ts v -> IO ()
-printIndex = putStrLn . showIndex
-{-# INLINE printIndex #-}
-
--- INTERNAL
+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE CPP                 #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} ++--------------------------------------------------------------------------------+-- |+--+-- Module : Data.Store+-- Copyright : (c) Petr Pilar 2012+-- License : BSD-style+--+-- Dictionary with multidimensional keys and type-safe interface.+--+-- These modules are intended to be imported qualified to avoid name+-- clashes with prelude, e.g.:+--+-- > import qualified Data.Store as S+-- > import           Data.Store (M, O, (.:), (.:.), (:.), (.<), (.<=), (.>), (.>=), (./=), (.==), (.&&), (.||))+--+-- Throughout out the documentation, the examples will be based on this+-- code:+--+-- > {-# LANGUAGE TypeOperators #-}+-- > +-- > module Example01+-- > where+-- > +-- > --------------------------------------------------------------------------------+-- > import           Control.Applicative+-- > import qualified Control.Monad.State as State+-- > --------------------------------------------------------------------------------+-- > import qualified Data.Store as S+-- > import           Data.Store (M, O, (.:), (.:.), (:.)(..), (.<), (.<=), (.>), (.>=), (./=), (.==), (.&&), (.||))+-- > --------------------------------------------------------------------------------+-- > +-- > data Content = Content+-- >     { contentName :: String  +-- >     , contentBody :: String  +-- >     , contentTags :: [String]+-- >     , contentRating :: Double+-- >     }+-- > +-- > type ContentID = Int+-- > +-- > -- Content has one ID, only one content can have a given ID.+-- > -- Content has one name, only one content can have a given name.+-- > -- Content has one body, many contents can have the same content.+-- > -- Content has many tags, many contents can have the same tag.+-- > -- Content has one rating, many contents can have the same rating.+-- > +-- > data ContentStoreTag = ContentStoreTag+-- > +-- > type ContentStoreTS  = ContentID :. String :. String :. String :. Double+-- > type ContentStoreKRS = O         :. O      :. O      :. M      :. O+-- > type ContentStoreIRS = O         :. O      :. M      :. M      :. M+-- > type ContentStore = S.Store ContentStoreTag ContentStoreKRS ContentStoreIRS ContentStoreTS Content+-- > type ContentStoreKey = S.Key ContentStoreKRS ContentStoreTS+-- > type ContentStoreSelection = S.Selection ContentStoreTag ContentStoreKRS ContentStoreIRS ContentStoreTS+-- > +-- > sContentID :: (ContentStoreTag, S.N0)+-- > sContentID = (ContentStoreTag, S.n0)+-- > +-- > sContentName :: (ContentStoreTag, S.N1)+-- > sContentName = (ContentStoreTag, S.n1)+-- > +-- > sContentBody :: (ContentStoreTag, S.N2)+-- > sContentBody = (ContentStoreTag, S.n2)+-- > +-- > sContentTag :: (ContentStoreTag, S.N3)+-- > sContentTag = (ContentStoreTag, S.n3)+-- > +-- > sContentRating :: (ContentStoreTag, S.N4)+-- > sContentRating = (ContentStoreTag, S.n4)+--+-- Glossary+--+-- * Key (type/value) -- refers either to the type or value of a key of the+-- store.+--+-- * Key dimension -- refers to one dimension of a key (e.g.: article's+-- author, article's tag). Refers to the dimension as a whole, together+-- with its properties, etc.+--+-- * Key dimension value -- refers to some concrete value from the domain of the+-- dimension.+--+-- * Element (type/value) -- refers either to the type or value of the elements+-- (in literature, the term \"value\" is usually used, be here it would+-- clash far too often) of the store.+--+-- The implementation is based on "Data.Map", "Data.Set", "Data.IntMap" and+-- "Data.IntSet".+--+-- The following variables and constants are used in Big-O notation:+--+-- * /W/ -- the (constant) number of bits of "Int" (32 or 64).+-- +-- * /d/ -- the (constant) number of dimensions of the store.+-- +-- * /k/ -- the (variable) number of key dimensions values of a key (or+-- maximum of the number of key dimension values over all keys in case of for example+-- @'Data.Store.updateWithKey'@).+--+-- * /s/ -- the (variable) size of the output of the operation or the+-- (variable) number of elements affected by the operation. This is+-- often the number of key-element pairs that correspond to some selection.+-- +-- * /s(sel)/ -- the (variable) number of key-element pairs that correspond+-- to a selection /sel/ if /s/ would otherwise be ambigious.+--+-- * /c/ -- the (variable) complexity of selection.+--+-- * /c(sel)/ -- the (variable) complexity of resolving the selection /sel/ if /c/+-- would otherwise be ambiguous.+module Data.Store+(+  -- * Types+  I.Store+, I.Key+, I.KeyDimension+, I.RawKey+, I.M+, I.O+, (I.:.)(..)+, I.Auto++  -- * Creating+, I.empty+, singleton++  -- * Inserting+, insert+, insert'+, unsafeInsert++  -- * Updating+, updateWithKey+, updateWithKey'+, update+, update'+, updateElements+, delete++  -- * Traversing+, map++  -- * Folding+, foldr+, foldrWithKey++, foldl+, foldlWithKey++  -- * List+, toList+, elements+, keys+, insertList+, insertList'+, unsafeInsertList+, fromList+, fromList'+, unsafeFromList++  -- * Querying+, size+, lookup+, lookupOrderByA+, lookupOrderByD++  -- ** Selection+  --+  -- $selection+, Selection+, not+, (.<)+, (.<=)+, (.>)+, (.>=)+, (./=)+, (.==)+, (.&&)+, (.||)++  -- * Constructing Key+  -- +  -- $constructing-key+, dimA+, dimO+, dimM+, (.:)+, (.:.)++  -- * Utility+, I.S(..)+, I.Z+, I.N0+, I.N1+, I.N2+, I.N3+, I.N4+, I.N5+, I.N6+, I.N7+, I.N8+, I.N9+, I.N10+, I.n0+, I.n1+, I.n2+, I.n3+, I.n4+, I.n5+, I.n6+, I.n7+, I.n8+, I.n9+, I.n10++  -- * Debugging+, showIndex+, printIndex+, moduleName+) where++--------------------------------------------------------------------------------+import           Prelude hiding (lookup, map, foldr, foldl, not)+--------------------------------------------------------------------------------+import           Control.Applicative hiding (empty)+--------------------------------------------------------------------------------+import           Data.Monoid+import           Data.Maybe+import           Data.Functor.Identity+#if MIN_VERSION_containers(0,5,0)+import qualified Data.IntMap.Strict as Data.IntMap+#else+import qualified Data.IntMap+#endif+import qualified Data.List+import qualified Data.Foldable+--------------------------------------------------------------------------------+import qualified Data.Store.Internal.Type     as I+import qualified Data.Store.Internal.Function as I+import           Data.Store.Selection +--------------------------------------------------------------------------------++-- | The name of this module.+moduleName :: String+moduleName = "Data.Store"+{-# INLINE moduleName #-}++-- INTERFACE++-- $selection+-- Functions from this category are used to create selections.+--+-- Example:+--+-- > -- Select any content with rating between 3 and 4.+-- > let sel1 = sContentRating .> 3+-- >+-- > -- Select any content that is tagged with "haskell" or "category-theory"+-- > -- and is not tagged with "fluff".+-- > let sel2 = (sContentTag .== "haskell" .|| sContentTag .== "category-theory") .&& not' (sContentTag .== "fluff")+-- >+-- > -- Selection that is intersection of sel1 and sel2.+-- > let sel3 = sel1 .&& sel2+--+-- These selections can be then used in functions like lookup, update,+-- delete, etc.+--  +-- >>> lookup sel3 store+-- > -- key-element pairs that match the selection+--+-- >>> delete (not' sel3) store+-- > -- store with the key-element pairs that do not match the selection+--+-- >>> updateElements (\v -> Just v { contentRating = 5 }) sel3 store+-- > -- store with the selected key-element pairs updated +++-- $constructing-key+-- Functions from this category are used to create a key for your store. Function for+-- creating a key for our @Content@ data type could look like this:+--+-- > makeContentKey :: ContentID -> String -> String -> [String] -> Double -> ContentStoreKey+-- > makeContentKey cid cn cb cts cr =+-- >    S.dimO cid .: S.dimO cn .: S.dimO cb .: S.dimM cts .:. S.dimO cr+--+-- Notice that this function allows you to specify all the dimensions of+-- the key, including the ID dimension. Usually we do not need this level+-- of flexibility a would use function like this instead:+--+-- > contentKey :: Content -> ContentStoreKey+-- > contentKey (Content cn cb cts cr) =+-- >    S.dimA .: S.dimO cn .: S.dimO cb .: S.dimM cts .:. S.dimO cr+--+-- This function creates a key for given element of type @Content@ (element), the ID+-- dimension is "automatic", which means that the assigned ID will be @succ+-- max@ where @max@ is the value of the maximum ID in the store when+-- inserting.+--+-- See also:+--+-- * 'Data.Store.Storable.Storable'++-- | Function for creating an auto-increment dimension. Can be used instead+-- of (@dimO x@) if the type is an instance of the+-- @'Data.Store.Internal.Auto'@ type-class.+dimA :: I.Auto t => I.KeyDimension I.O t+dimA = I.KeyDimensionA+{-# INLINE dimA #-}++-- | Function for creating dimensions with the relation+-- \"one-<anything>\".+dimO :: Ord t => t -> I.KeyDimension I.O t+dimO = I.KeyDimensionO+{-# INLINE dimO #-}++-- | Function for creating dimensions with the relation+-- \"many-<anything>\".+dimM :: Ord t => [t] -> I.KeyDimension I.M t+dimM = I.KeyDimensionM+{-# INLINE dimM #-}++-- | Function for connecting one dimension and rest of the key.+(.:) :: dim r t+     -> I.GenericKey dim rs1 ts1 +     -> I.GenericKey dim (r I.:. rs1) (t I.:. ts1)+(.:) = I.KN+{-# INLINE (.:) #-}+infixr 3 .:++-- | Function for connecting one dimensions with another (most often the+-- last dimension of the key).+(.:.) :: dim r1 t1+      -> dim r2 t2+      -> I.GenericKey dim (r1 I.:. r2) (t1 I.:. t2)+(.:.) d1 d2 = I.KN d1 (I.K1 d2)+{-# INLINE (.:.) #-}+infixr 3 .:.++-- CREATING+++-- | The expression (@'Data.Store.singleton' k v@) is store that contains+-- only the @(k, v)@ as a key-element pair.+singleton :: I.Empty (I.Index irs ts)+          => I.Key krs ts -> v -> I.Store tag krs irs ts v+singleton k v = snd . fromJust $ insert k v I.empty+{-# INLINE singleton #-}++-- INSERTING++-- | The expression (@'Data.Store.insert' k e old@) is either+-- @Nothing@ if inserting the @(k, e)@ key-element pair would cause+-- a collision or (@Just (rk, new)@), where @rk@ is the raw key of+-- @k@ and @new@ is store containing the same key-element pairs as @old@ plus+-- @(k, e)@. +--+-- Examples:+--+-- >>> let content = Content "name" "body" ["t1", "t2"] 0.5+-- >>> insert (contentKey content) content store+-- > Just (1 :. "name" :. "body" :. ["t1", "t2"] :. 0.5, <updated_store>)+--+-- Complexity: /O(min(n, W) + k * (log n + min(n, W)))/+--+-- See also:+--+-- * 'Data.Store.insert''+--+-- * 'Data.Store.Internal.Type.Key'+--+-- * 'Data.Store.Internal.Type.RawKey'+insert :: I.Key krs ts+       -> v+       -> I.Store tag krs irs ts v+       -> Maybe (I.RawKey krs ts, I.Store tag krs irs ts v)+insert k v old@(I.Store _ index _) =+    (\res -> (I.keyInternalToRaw internal, res)) <$> I.genericInsert I.indexInsertID internal v old+    where+      internal = I.keyToInternal index k++-- | The expression (@'Data.Store.insert'' k v old@) is @(rk, new)@,+-- where @rk@ is the raw key of @k@ and @new@ is a store that contains+-- the same key-element pairs as @old@ plus @(k, e)@.+-- Any key-value pairs from @old@ colliding with @(k, e)@ are not included in @new@.+--+-- Complexity: /O(min(n, W) + k * (log n + min(n, W)))/+--+-- See also:+--+-- * 'Data.Store.insert'+--+-- * 'Data.Store.Internal.Type.Key'+--+-- * 'Data.Store.Internal.Type.RawKey'+insert' :: I.Key krs ts+        -> e+        -> I.Store tag krs irs ts e+        -> (I.RawKey krs ts, I.Store tag krs irs ts e)+insert' k e old@(I.Store _ index _) =+    (I.keyInternalToRaw internal, runIdentity $! I.genericInsert I.indexInsertID' internal e old)+    where+      internal = I.keyToInternal index k+{-# INLINE insert' #-}++-- | UNSAFE! This function can corrupt the store.+--+-- The expression (@'Data.Store.unsafeInsert' k v old@) is @(rk, new)@,+-- where @rk@ is the raw key of @k@ and @new@ is a store that contains+-- the same key-element pairs as @old@ plus @(k, e)@.+-- Any key-value pairs from @old@ colliding with @(k, e)@ will cause UNDEFINED BEHAVIOUR.+--+-- See also:+--+-- * 'Data.Store.insert'+--+-- * 'Data.Store.insert''+--+-- * 'Data.Store.Internal.Type.Key'+--+-- * 'Data.Store.Internal.Type.RawKey'+unsafeInsert :: I.Key krs ts+             -> e+             -> I.Store tag krs irs ts e+             -> (I.RawKey krs ts, I.Store tag krs irs ts e)+unsafeInsert k e old@(I.Store _ index _) =+    (I.keyInternalToRaw internal, runIdentity $! I.genericInsert I.indexInsertID'' internal e old)+    where+      internal = I.keyToInternal index k+{-# INLINE unsafeInsert #-}++-- TRAVERSING++-- | The expression @('Data.Store.map' tr old@) is store where every element of+-- @old@ was transformed using the function @tr@.+--+-- NOTE: This function does not affect the keys of the updated elements. In+-- case you need to update the elements as well as the keys, see+-- @'Data.Store.updateWithKey'@, @'Data.Store.updateWithKey''@ and+-- @'Data.Store.Storable'@ for available options.+map :: (v1 -> v2) -> I.Store tag krs irs ts v1 -> I.Store tag krs irs ts v2+map tr store@(I.Store vs _ _) = store+    { I.storeV = Data.IntMap.map (\(ik, v) -> (ik, tr v)) vs+    }+{-# INLINE map #-}++-- QUERYING++-- | The expression (@'Data.Store.Selection.lookup' sel store@) is+-- list of (raw key)-element pairs that match the selection.+-- +-- Complexity: /O(c + s * min(n, W))/+--+-- 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+size (I.Store vs _ _) = Data.IntMap.size vs+{-# INLINE size #-}++-- UPDATING++-- | The expression (@'Data.Store.updateWithKey' tr sel old@)+-- is (@Just new@) where @new@ is a store containing the same key-element+-- pairs as @old@ except for any key-element pairs @(k, e)@ that match the+-- selection @sel@, those are updated as follows:+--+-- * If @(tr k e)@ is @Nothing@ the pair is not included in @new@.+--+-- * If @(tr k e)@ is (@Just (e', Nothing)@) the pair is replaced by pair @(k, e')@.+--+-- * If @(tr k e)@ is (@Just (e', Just k')@) the pair is replaced by pair @(k', e')@.+--+-- If any of the updated key-element pairs would cause a collision, the+-- result is @Nothing@.+--+-- Complexity: /O(c + s * (min(n, W) + k * (log n + min(n, W))))/+--+-- See also:+--+--   * 'Data.Store.updateWithKey''+updateWithKey :: IsSelection sel+              => (I.RawKey krs ts -> v -> Maybe (v, Maybe (I.Key krs ts)))+              -> sel tag krs irs ts+              -> I.Store tag krs irs ts v+              -> Maybe (I.Store tag krs irs ts v)+updateWithKey tr sel s = I.genericUpdateWithKey I.indexInsertID tr (resolve sel s) s+{-# INLINE updateWithKey #-}++-- | The expression (@'Data.Store.updateWithKey'' tr sel old@)+-- is @new@ where @new@ is a store containing the same key-element+-- pairs as @old@ except for any key-element pairs @(k, e)@ that match the+-- selection @sel@, those are updated as follows:+--+-- * If @(tr k e)@ is @Nothing@ the pair is not included in @new@.+--+-- * If @(tr k e)@ is (@Just (e', Nothing)@) the pair is replaced by pair @(k, e')@.+--+-- * If @(tr k e)@ is (@Just (e', Just k')@) the pair is replaced by pair @(k', e')@.+--+-- Any pairs of the original store @old@ that would, after the update, cause collisons+-- are not included in @new@. +--+-- Complexity: /O(c + s * d * (min(n, W) + k * (log n + min(n, W))))/+--+-- See also:+--+--   * 'Data.Store.updateWithKey'+updateWithKey' :: IsSelection sel+               => (I.RawKey krs ts -> v -> Maybe (v, Maybe (I.Key krs ts)))+               -> sel tag krs irs ts+               -> I.Store tag krs irs ts v+               -> I.Store tag krs irs ts v+updateWithKey' tr sel s = runIdentity $! I.genericUpdateWithKey I.indexInsertID' tr (resolve sel s) s+{-# INLINE updateWithKey' #-}++-- | The expression (@'Data.Store.update' tr sel s@) is equivalent+-- to (@'Data.Store.Selection.updateWithKey' tr' sel s@) where+-- (@tr' = (\_ v -> tr v) = const tr@).+--+-- Complexity: /O(c + s * (min(n, W) + q * log n))/ +--+-- NOTE: This function does not affect the keys of the updated elements. In+-- case you need to update the elements as well as the keys, see+-- @'Data.Store.updateWithKey'@, @'Data.Store.updateWithKey''@ and+-- @'Data.Store.Storable'@ for available options.+update :: IsSelection sel+       => (v -> Maybe (v, Maybe (I.Key krs ts)))+       -> sel tag krs irs ts+       -> I.Store tag krs irs ts v+       -> Maybe (I.Store tag krs irs ts v)+update tr = updateWithKey (const tr)+{-# INLINE update #-}++-- | The expression (@'Data.Store.update'' tr sel s@) is equivalent+-- to (@'Data.Store.Selection.updateWithKey'' tr' sel s@) where+-- (@tr' = (\_ v -> tr v) = const tr@).+--+-- Complexity: /O(c + d * s * (min(n, W) + q * log n))/ +--+-- NOTE: This function does not affect the keys of the updated elements. In+-- case you need to update the elements as well as the keys, see+-- @'Data.Store.updateWithKey'@, @'Data.Store.updateWithKey''@ and+-- @'Data.Store.Storable'@ for available options.+update' :: IsSelection sel+        => (v -> Maybe (v, Maybe (I.Key krs ts)))+        -> sel tag krs irs ts+        -> I.Store tag krs irs ts v+        -> I.Store tag krs irs ts v+update' tr = updateWithKey' (const tr)+{-# INLINE update' #-}++-- | The expression (@'Data.Store.updateElements' tr sel s@) is equivalent+-- to (@'Data.Store.Selection.update' tr' sel s@) where+-- (@tr' = (maybe Nothing (\v -> Just (v, Nothing)) . tr)@).+--+-- Complexity: /O(c + s * min(n, W))/ +updateElements :: IsSelection sel+               => (v -> Maybe v)+               -> sel tag krs irs ts+               -> I.Store tag krs irs ts v+               -> I.Store tag krs irs ts v+updateElements tr sel s =+  runIdentity $! I.genericUpdateWithKey I.indexInsertID'' tr' (resolve sel s) s+  where+    tr' _ = maybe Nothing (\v -> Just (v, Nothing)) . tr+    {-# INLINE tr' #-}+{-# INLINE updateElements #-}             ++-- | The expression (@'Data.Store.Selection.delete' sel old@) is+-- equivalent to+-- (@'Data.Store.fromJust' $ 'Data.Store.Selection.update' (const Nothing) sel old@).+--+-- Complexity: /O(c + s * (min(n, W) + q * log n)/ +delete :: IsSelection sel+       => sel tag krs irs ts+       -> I.Store tag krs irs ts v+       -> I.Store tag krs irs ts v+delete sel s =+  runIdentity $! I.genericUpdateWithKey I.indexInsertID'' (\_ _ -> Nothing) (resolve sel s) s+{-# INLINE delete #-}++-- FOLDING++-- | The expression (@'Data.Store.foldrWithKey' f z s@) folds the store+-- using the given right-associative operator.+foldrWithKey :: (I.RawKey krs ts -> v -> b -> b)+             -> b+             -> I.Store tag krs irs ts v+             -> b+foldrWithKey accum start (I.Store vs _ _) =+    Data.IntMap.foldr (\(ik, v) b -> accum (I.keyInternalToRaw ik) v b) start vs+{-# INLINE foldrWithKey #-}++-- | The expression (@'Data.Store.foldr' f z s@) folds the store+-- using the given right-associative binary operator.+foldr :: (v -> b -> b)+      -> b+      -> I.Store tag krs irs ts v+      -> b+foldr accum start (I.Store vs _ _) =+    Data.IntMap.foldr (\(_, v) b -> accum v b) start vs+{-# INLINE foldr #-}++-- | The expression (@'Data.Store.foldlWithKey' f z s@) folds the store+-- using the given left-associative operator.+foldlWithKey :: (b -> I.RawKey krs ts -> v -> b)+              -> b +              -> I.Store tag krs irs ts v+              -> b+foldlWithKey accum start (I.Store vs _ _) =+    Data.IntMap.foldl (\b (ik, v) -> accum b (I.keyInternalToRaw ik) v) start vs+{-# INLINE foldlWithKey #-}++-- | The expression (@'Data.Store.foldl' f z s@) folds the store+-- using the given left-associative binary operator.+foldl :: (b -> v -> b)+      -> b+      -> I.Store tag krs irs ts v+      -> b+foldl accum start (I.Store vs _ _) =+    Data.IntMap.foldl (\b (_, v) -> accum b v) start vs+{-# INLINE foldl #-}++-- LISTS++-- | The expression (@'Data.Store.toList' store@) is a list of key-element pairs that are stored in @store@.+toList :: I.Store tag krs irs ts v -> [(I.RawKey krs ts, v)]+toList (I.Store vs _ _) = Data.List.map (\(ik, v) -> (I.keyInternalToRaw ik, v)) $ Data.IntMap.elems vs+{-# INLINE toList #-}++-- | The expression (@'Data.Store.elements' store@) is a list of elements that+-- are stored in @store@.+elements :: I.Store tag krs irs ts v -> [v]+elements (I.Store vs _ _) = Data.List.map snd $ Data.IntMap.elems vs+{-# INLINE elements #-}++-- | The expression (@'Data.Store.keys' store@) is a list of pairs raw+-- keys that are stored in @store@.+keys :: I.Store tag krs irs ts v -> [I.RawKey krs ts]+keys (I.Store vs _ _) = Data.List.map (I.keyInternalToRaw . fst) $ Data.IntMap.elems vs+{-# INLINE keys #-}++-- | The expression (@'Data.Store.fromList' 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+-- cause a collision.+--+-- 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 = insertList I.empty+{-# INLINE fromList #-}++-- | 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' = 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.unsafeFromList' kes@) is @store@+-- containing the given key-element pairs (colliding pairs cause UNDEFINED BEHAVIOUR).+--+-- See also:+--+-- * 'Data.Store.fromList'+--+-- * 'Data.Store.fromList'+unsafeFromList :: I.Empty (I.Index irs ts) => [(I.Key krs ts, v)] -> I.Store tag krs irs ts v+unsafeFromList = 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++instance Functor (I.Store tag krs irs ts) where+    fmap = map+    {-# INLINE fmap #-}++instance I.Empty (I.Index irs ts) => Monoid (I.Store tag krs irs ts v) where+    mempty = I.empty+    {-# INLINE mempty #-}++    mappend oldl (I.Store kes _ _) =+      Data.IntMap.foldl (\acc (ik, e) -> runIdentity $! I.genericInsert I.indexInsertID' ik e acc) oldl kes++-- UTILITY++showIndex :: Show (I.Index irs ts) => I.Store tag krs irs ts v -> String+showIndex (I.Store _ i _) = show i+{-# INLINE showIndex #-}++printIndex :: Show (I.Index irs ts) => I.Store tag krs irs ts v -> IO ()+printIndex = putStrLn . showIndex+{-# INLINE printIndex #-}++-- INTERNAL
src/Data/Store/Internal/Function.hs view
@@ -1,328 +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 #-}
-
-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 #-}
-
+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}++module Data.Store.Internal.Function+where++--------------------------------------------------------------------------------+import           Control.Applicative hiding (empty)+--------------------------------------------------------------------------------+import           Data.Monoid ((<>))+import           Data.Functor.Identity +import qualified Data.List+#if MIN_VERSION_containers(0,5,0)+import qualified Data.IntMap.Strict as Data.IntMap+import qualified Data.Map.Strict as Data.Map+#else+import qualified Data.IntMap+import qualified Data.Map+#endif+import qualified Data.IntSet+import qualified Data.IntSet.Extra+--------------------------------------------------------------------------------+import qualified Data.Store.Internal.Type as I+--------------------------------------------------------------------------------++moduleName :: String+moduleName = "Data.Store.Internal.Function"++genericSubset :: I.Empty (I.Index irs ts)+              => Data.IntSet.IntSet+              -> I.Store tag krs irs ts v+              -> I.Store tag krs irs ts v+genericSubset ids (I.Store vs _ _) =+  Data.IntSet.foldr (\i acc ->+    case Data.IntMap.lookup i vs of+      Just (ik, e) -> runIdentity $ genericInsert indexInsertID'' ik e acc+      _ -> acc+    ) I.empty ids+{-# INLINE genericSubset #-}++genericLookup :: Data.IntSet.IntSet+              -> I.Store tag krs irs ts v+              -> [(I.RawKey krs ts, v)]+genericLookup ids (I.Store vs _ _) = {-# SCC "genericLookup" #-} +  Data.IntSet.foldr (\i acc ->+    case Data.IntMap.lookup i vs of+      Just (ik, v) -> (keyInternalToRaw ik, v) : acc+      _ -> acc+    ) [] ids+{-# INLINE genericLookup #-}++genericLookupAsc :: I.GetDimension n (I.IKey krs ts)+                 => Data.IntSet.IntSet+                 -> n+                 -> I.Store tag krs irs ts v+                 -> [(I.RawKey krs ts, v)]+genericLookupAsc ids n (I.Store vs _ _) =+  map (\(ik, v) -> (keyInternalToRaw ik, v)) . Data.List.sortBy (lookupSortComparator n) $+  Data.IntSet.foldr (\i acc ->+    case Data.IntMap.lookup i vs of+      Just (ik, v) -> (ik, v) : acc+      _ -> acc+    ) [] ids+{-# INLINE genericLookupAsc #-}++genericLookupDesc :: I.GetDimension n (I.IKey krs ts)+                  => Data.IntSet.IntSet+                  -> n+                  -> I.Store tag krs irs ts v+                  -> [(I.RawKey krs ts, v)]+genericLookupDesc ids n (I.Store vs _ _) =+  map (\(ik, v) -> (keyInternalToRaw ik, v)) . Data.List.sortBy (flip $ lookupSortComparator n) $+  Data.IntSet.foldr (\i acc ->+    case Data.IntMap.lookup i vs of+      Just (ik, v) -> (ik, v) : acc+      _ -> acc+    ) [] ids+{-# INLINE genericLookupDesc #-}++lookupSortComparator :: I.GetDimension n (I.IKey krs ts) => n -> (I.IKey krs ts, e) -> (I.IKey krs ts, e) -> Ordering+lookupSortComparator n (k1, _) (k2, _) = case (I.getDimension n k1, I.getDimension n k2) of+  (I.IKeyDimensionO d1, I.IKeyDimensionO d2) -> d1 `compare` d2+  (I.IKeyDimensionM  _, I.IKeyDimensionM  _) -> error $+    moduleName <> "lookupSortComparator: Comparing keys based on many-one or many-many dimensions is not supported."+{-# INLINEABLE lookupSortComparator #-}++genericUpdateWithKey :: (Applicative f, Monad f)+                     => (I.IKey krs ts -> Int -> I.Store tag krs irs ts e -> f (I.Store tag krs irs ts e))+                     -> (I.RawKey krs ts -> e -> Maybe (e, Maybe (I.Key krs ts)))+                     -> Data.IntSet.IntSet+                     -> I.Store tag krs irs ts e+                     -> f (I.Store tag krs irs ts e)+genericUpdateWithKey ins tr ids old = Data.IntSet.Extra.foldlM' accum old ids+    where+      accum store@(I.Store vs ix nid) i =+          case Data.IntMap.lookup i vs of+            Just (ik, v) ->+                case tr (keyInternalToRaw ik) v of+                  -- User wants to update the element & key.+                  Just (nv, Just nk) -> let nik = mergeKeys nk ik in +                    if nik /= ik+                       -- The keys are different: update the element & key.+                       then insertPair i nik nv <$> ins nik i (store { I.storeI = indexDeleteID ik i ix })+                       -- The keys are identical: update the element.+                       else pure $! insertPair i nik nv store++                  -- Update the element.+                  Just (nv, Nothing) -> pure $! insertPair i ik nv store++                  -- Delete.+                  Nothing -> pure I.Store+                    { I.storeV = Data.IntMap.delete i vs+                    , I.storeI = indexDeleteID ik i ix+                    , I.storeNID = nid+                    }+            _ -> pure store+      {-# INLINEABLE accum #-}+      +      insertPair i' ik' e' s'@(I.Store es' _ _) = s' +        { I.storeV = Data.IntMap.insert i' (ik', e') es'+        }+      {-# INLINE insertPair #-}+{-# INLINE genericUpdateWithKey #-}+++mergeKeys :: I.Key krs ts -> I.IKey krs ts -> I.IKey krs ts+mergeKeys (I.K1 I.KeyDimensionA) ik@(I.K1 _) = ik+mergeKeys (I.K1 (I.KeyDimensionO d))   (I.K1 _)   = I.K1 (I.IKeyDimensionO d)+mergeKeys (I.K1 (I.KeyDimensionM d))   (I.K1 _)   = I.K1 (I.IKeyDimensionM d)+mergeKeys (I.KN I.KeyDimensionA s) (I.KN ik is) = I.KN ik $ mergeKeys s is+mergeKeys (I.KN (I.KeyDimensionO d) s) (I.KN _ is) = I.KN (I.IKeyDimensionO d) $ mergeKeys s is+mergeKeys (I.KN (I.KeyDimensionM d) s) (I.KN _ is) = I.KN (I.IKeyDimensionM d) $ mergeKeys s is+mergeKeys _ _ = error $ moduleName <> ".genericUpdate.mergeKeys: The impossible happened."+{-# INLINEABLE mergeKeys #-}++keyInternalToRaw :: I.IKey krs ts -> I.RawKey krs ts+keyInternalToRaw (I.K1 (I.IKeyDimensionO x)) = x+keyInternalToRaw (I.K1 (I.IKeyDimensionM x)) = x+keyInternalToRaw (I.KN (I.IKeyDimensionO x) s) = x I.:. keyInternalToRaw s+keyInternalToRaw (I.KN (I.IKeyDimensionM x) s) = x I.:. keyInternalToRaw s+{-# INLINE keyInternalToRaw #-}++keyFromInternal :: I.IKey krs ts -> I.Key krs ts+keyFromInternal (I.K1 (I.IKeyDimensionO x)) = I.K1 (I.KeyDimensionO x)+keyFromInternal (I.K1 (I.IKeyDimensionM x)) = I.K1 (I.KeyDimensionM x)+keyFromInternal (I.KN (I.IKeyDimensionO x) s) = I.KN (I.KeyDimensionO x) (keyFromInternal s)+keyFromInternal (I.KN (I.IKeyDimensionM x) s) = I.KN (I.KeyDimensionM x) (keyFromInternal s)++keyToInternal :: I.Index irs ts -> I.Key krs ts -> I.IKey krs ts+keyToInternal (I.I1 ix) (I.K1 I.KeyDimensionA) = I.K1 (I.IKeyDimensionO $! nextKey ix) +keyToInternal (I.I1 _) (I.K1 (I.KeyDimensionO x)) = I.K1 (I.IKeyDimensionO x) +keyToInternal (I.I1 _) (I.K1 (I.KeyDimensionM x)) = I.K1 (I.IKeyDimensionM x) +keyToInternal (I.IN ix is) (I.KN I.KeyDimensionA s) = I.KN (I.IKeyDimensionO $! nextKey ix) $ keyToInternal is s+keyToInternal (I.IN _ is) (I.KN (I.KeyDimensionO x) s) = I.KN (I.IKeyDimensionO x) $ keyToInternal is s+keyToInternal (I.IN _ is) (I.KN (I.KeyDimensionM x) s) = I.KN (I.IKeyDimensionM x) $ keyToInternal is s +keyToInternal _ _ = error $ moduleName <> ".insert.keyToInternal: Impossible happened."+{-# INLINE keyToInternal #-}+      +nextKey :: I.Auto t => I.IndexDimension r t -> t+nextKey i =+  case i of+    (I.IndexDimensionM m) -> nextKey' m+    (I.IndexDimensionO m) -> nextKey' m+  where+    nextKey' m = if Data.Map.null m+                   then minBound+                   else succ . fst $! Data.Map.findMax m+    {-# INLINE nextKey' #-}+{-# INLINE nextKey #-}++genericInsert :: Applicative f +              => (I.IKey krs ts -> Int -> I.Store tag krs irs ts e -> f (I.Store tag krs irs ts e))+              -> I.IKey krs ts+              -> e+              -> I.Store tag krs irs ts e+              -> f (I.Store tag krs irs ts e)+genericInsert ins ik e old@(I.Store _ _ nid) = go <$> ins ik nid old+  where+    go s'@(I.Store es' _ _) = s'+      { I.storeV = Data.IntMap.insert nid (ik, e) es'+      , I.storeNID = nid + 1+      }+    {-# INLINE go #-}+{-# INLINE genericInsert #-}++-- | Inserts the given element identifier into the store's index under the given+-- internal key.+--+-- In case of collisions: returns 'Data.Maybe.Nothing'.+indexInsertID :: I.IKey krs ts+              -> Int+              -> I.Store tag krs irs ts e+              -> Maybe (I.Store tag krs irs ts e)+indexInsertID ik eid old@(I.Store _ index _) =+  if Data.List.null $ findCollisions ik index+    then Just $! runIdentity $! indexInsertID'' ik eid old+    else Nothing+{-# INLINE indexInsertID #-}++-- | Inserts the given element identifier into the store's index under the given+-- internal key.+--+-- In case of collisions: deletes them.+indexInsertID' :: I.IKey krs ts+               -> Int+               -> I.Store tag krs irs ts e+               -> Identity (I.Store tag krs irs ts e)+indexInsertID' ik eid old@(I.Store _ index _) = --{-# SCC "indexInsertID'" #-} +  indexInsertID'' ik eid $! Data.IntSet.foldl' go old collisions+  where+    go s'@(I.Store es' ix' _) i =+      case Data.IntMap.updateLookupWithKey (\_ _ -> Nothing) i es' of+        (Just (ik', _), v'') -> s'+          { I.storeV = v''+          , I.storeI = indexDeleteID ik' i ix'+          } +        _ -> error $ moduleName <> ".insertInternal'.go: The impossible happened."+    {-# INLINEABLE go #-}++    collisions = Data.IntSet.delete eid $! Data.IntSet.fromList $! findCollisions ik index+    {-# INLINE collisions #-}+{-# INLINE indexInsertID' #-}++-- | UNSAFE. Inserts the given element identifier into the store's index under the given+-- internal key.+-- +-- In case of collisions: ignores them.+indexInsertID'' :: I.IKey krs ts+                -> Int+                -> I.Store tag krs irs ts e+                -> Identity (I.Store tag krs irs ts e)+indexInsertID'' ik eid old@(I.Store _ index _) = --{-# SCC "indexInsertID''" #-}+  zipped `seq` Identity $! old { I.storeI = zipped }+  where+    zipped = zipD ik index++    zipD :: I.IKey krs ts -> I.Index irs ts -> I.Index irs ts+    zipD (I.KN kd kt) (I.IN ixd it) = I.IN (combine kd ixd) $! zipD kt it+    zipD (I.K1 kd) (I.I1 ixd) = I.I1 $! combine kd ixd+    zipD _ _ = error $ moduleName <> ".indexInsertID''.zipD: The impossible happened."+    {-# INLINE zipD #-}++    combine :: I.IKeyDimension krs ts -> I.IndexDimension irs ts -> I.IndexDimension irs ts+    combine kd ixd =+      case (ixd, kd) of+        (I.IndexDimensionO m, I.IKeyDimensionO k)  ->+          I.IndexDimensionO $! goO k eid m+        +        (I.IndexDimensionO m, I.IKeyDimensionM ks) ->+          I.IndexDimensionO $! Data.List.foldl' (\acc k -> goO k eid acc) m ks ++        (I.IndexDimensionM m, I.IKeyDimensionO k)  ->+          I.IndexDimensionM $! goM k eid $! m++        (I.IndexDimensionM m, I.IKeyDimensionM ks) ->+          I.IndexDimensionM $! Data.List.foldl' (\acc k -> goM k eid acc) m ks+    {-# INLINEABLE combine #-}++    goO :: Ord k => k -> Int -> Data.Map.Map k Int -> Data.Map.Map k Int+    goO = Data.Map.insert +    {-# INLINE goO #-}++    goM :: Ord k => k -> Int -> Data.Map.Map k Data.IntSet.IntSet -> Data.Map.Map k Data.IntSet.IntSet+    goM k e = Data.Map.insertWith (\_ s -> Data.IntSet.insert e s) k (Data.IntSet.singleton e)+    {-# INLINE goM #-}+{-# INLINE indexInsertID'' #-}++findCollisions :: I.IKey krs ts -> I.Index irs ts -> [Int]+findCollisions ik ix = {-# SCC "findCollisions" #-} zipD ik ix [] +  where+    zipD :: I.IKey krs ts -> I.Index irs ts -> [Int] -> [Int]+    zipD (I.KN kd kt) (I.IN ixd it) = combine kd ixd . zipD kt it+    zipD (I.K1 kd) (I.I1 ixd) = combine kd ixd+    zipD _ _ = error $ moduleName <> ".findCollisions.zipD: The impossible happened."++    combine :: I.IKeyDimension krs ts -> I.IndexDimension irs ts -> [Int] -> [Int]+    combine kd ixd = +      case (ixd, kd) of+        (I.IndexDimensionO m, I.IKeyDimensionO k)  -> goO k m+        (I.IndexDimensionO m, I.IKeyDimensionM ks) -> foldr (\k acc -> goO k m . acc) id ks+        _ -> id+    {-# INLINE combine #-}++    goO :: Ord k => k -> Data.Map.Map k Int -> [Int] -> [Int]+    goO k m =+      case Data.Map.lookup k $! m of+        Nothing -> id+        Just  i -> (i:)+    {-# INLINE goO #-}++-- | Deletes EID fron an index.+indexDeleteID :: I.IKey krs ts+              -> Int+              -> I.Index irs ts+              -> I.Index irs ts+indexDeleteID ik eid = zipD ik+  where+    zipD :: I.IKey krs ts -> I.Index irs ts -> I.Index irs ts+    zipD (I.KN kd kt) (I.IN ixd it) = I.IN (combine kd ixd) $! zipD kt it+    zipD (I.K1 kd) (I.I1 ixd) = I.I1 $! combine kd ixd+    zipD _ _ = error $ moduleName <> ".indexDeleteID.zipD: The impossible happened."+    {-# INLINEABLE zipD #-}++    combine :: Ord t => I.IKeyDimension kr t -> I.IndexDimension ir t -> I.IndexDimension ir t+    combine key index =+      case (index, key) of+        (I.IndexDimensionO m, I.IKeyDimensionO k)  -> I.IndexDimensionO $! goO m k+        (I.IndexDimensionO m, I.IKeyDimensionM ks) -> I.IndexDimensionO $! Data.List.foldl' goO m ks+        (I.IndexDimensionM m, I.IKeyDimensionO k)  -> I.IndexDimensionM $! goM m k+        (I.IndexDimensionM m, I.IKeyDimensionM ks) -> I.IndexDimensionM $! Data.List.foldl' goM m ks+    {-# INLINEABLE combine #-}++    goO :: Ord k => Data.Map.Map k Int -> k -> Data.Map.Map k Int+    goO m k = Data.Map.update (\i' -> if i' == eid then Nothing else Just i') k m+    {-# INLINE goO #-}++    goM :: Ord k => Data.Map.Map k Data.IntSet.IntSet -> k -> Data.Map.Map k Data.IntSet.IntSet+    goM m k = Data.Map.update+      (\ids -> let nids = Data.IntSet.delete eid ids in+        if Data.IntSet.null nids+          then Nothing+          else Just nids+      ) k m+    {-# INLINE goM #-}+{-# INLINE indexDeleteID #-}+
src/Data/Store/Internal/Type.hs view
@@ -1,590 +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)
-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
-
-
+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}++module Data.Store.Internal.Type+where++--------------------------------------------------------------------------------+import           Control.Applicative ((<$>), (<*>))+import           Control.DeepSeq (NFData(rnf))+--------------------------------------------------------------------------------+import           Data.Data (Typeable, Typeable2)+import qualified Data.Data+import qualified Data.List+import           Data.Monoid ((<>))+#if MIN_VERSION_containers(0,5,0)+import qualified Data.IntMap.Strict as Data.IntMap+import qualified Data.Map.Strict    as Data.Map+#else+import qualified Data.IntMap+import qualified Data.Map+#endif+import qualified Data.IntSet+import qualified Data.Foldable as F++import qualified Data.SafeCopy  as Ser+import qualified Data.Serialize as Ser (Serialize, get, put)+--------------------------------------------------------------------------------++moduleName :: String+moduleName = "Data.Store.Internal.Type"++-- | This is type-level tag for tagging dimensions of key and the index of a store.+-- You can think of @'Data.Store.Internal.Type.M'@ as an abbreviation for+-- "many".+--+-- * When @'Data.Store.Internal.Type.Key'@ dimension is tagged with+-- @'Data.Store.Internal.Type.M'@, it means that a single element can be+-- indexed under multiple key dimension values. Example: @Content@ (element) has+-- many tags.+--+-- * When @'Data.Store.Internal.Type.Index'@ dimension is tagged with+-- @'Data.Store.Internal.Type.M'@, it means that a multiple elements can be+-- indexed under a single key dimension values. Example: One rating can be shared by+-- many @Content@s (elements).+--+-- See also:+--+-- * 'Data.Store.Internal.Type.O'+--+-- * 'Data.Store.Internal.Type.Key'+--+-- * 'Data.Store.Internal.Type.Store'+data M ++-- | This is type-level tag for tagging dimensions of key and the index of a store.+-- You can think of @'Data.Store.Internal.Type.O'@ as an abbreviation for+-- "one".+--+-- * When @'Data.Store.Internal.Type.Key'@ dimension is tagged with+-- @'Data.Store.Internal.Type.O'@, it means that a single element is indexed+-- under exactly one key dimension value. Example: @Content@ (element) has exactly one title.+--+-- * When @'Data.Store.Internal.Type.Index'@ dimension is tagged with+-- @'Data.Store.Internal.Type.O'@, it means that at most one element can be+-- indexed under one key dimension value. Example: One @ContentID@ corresponds+-- to at most one @Content@ (element).+--+-- See also:+--+-- * 'Data.Store.Internal.Type.M'+--+-- * 'Data.Store.Internal.Type.Key'+--+-- * 'Data.Store.Internal.Type.Store'+data O++-- | Type-level zero.+data Z = Z++-- | Type-level successor of a number.+data S n = S n++type N0 = Z+type N1 = S N0+type N2 = S N1+type N3 = S N2+type N4 = S N3+type N5 = S N4+type N6 = S N5+type N7 = S N6+type N8 = S N7+type N9 = S N8+type N10 = S N9++n0 :: N0+n0 = Z+n1 :: N1+n1 = S n0+n2 :: N2+n2 = S n1+n3 :: N3+n3 = S n2+n4 :: N4+n4 = S n3+n5 :: N5+n5 = S n4+n6 :: N6+n6 = S n5+n7 :: N7+n7 = S n6+n8 :: N8+n8 = S n7+n9 :: N9+n9 = S n8+n10 :: N10+n10 = S n9++type family   DimensionRelation n rs ts :: *+type instance DimensionRelation Z O ts = O+type instance DimensionRelation Z M ts = M+type instance DimensionRelation Z (r :. rt) (t :. tt) = r+type instance DimensionRelation (S n) (r :. rt) (t :. tt) = DimensionRelation n rt tt++type family   DimensionType n rs ts :: *+type instance DimensionType Z M t = t+type instance DimensionType Z O t = t+type instance DimensionType Z (r :. rt) (t :. tt) = t+type instance DimensionType (S n) (r :. rt) (t :. tt) = DimensionType n rt tt++type family   RawDimensionType n a :: *+type instance RawDimensionType n (Index irs ts) = IndexDimension (DimensionRelation n irs ts) (DimensionType n irs ts)+type instance RawDimensionType n (IKey krs ts) = IKeyDimension (DimensionRelation n krs ts) (DimensionType n krs ts)++type family   LookupMap n krs irs ts v :: *+type instance LookupMap n krs irs ts v =+  Data.Map.Map (DimensionType n krs ts) (LookupMapElement (DimensionRelation n krs ts) (RawKey krs ts, v))++type family   LookupMapElement r e :: *+type instance LookupMapElement O e = e+type instance LookupMapElement M e = [e]++-- | The pupose of the @'Data.Store.Internal.Type.RawKey'@ type family is+-- to derive a type of a \"raw key\" that is easier to pattern match against+-- than @'Data.Store.Internal.Key'@.+--+-- Example:+--+-- > RawKey (O :. O :. O :. M :. O) (ContentID :. String :. String :. String :. Double) ~ (ContentID :. String :. String :. [String] :. Double)+type family   RawKey kspec tspec :: *+type instance RawKey (O :. rt) (t :. tt) =  t  :. RawKey rt tt+type instance RawKey (M :. rt) (t :. tt) = [t] :. RawKey rt tt+type instance RawKey O t =  t+type instance RawKey M t = [t]++type family   RawKeyDimension n kspec tspec :: *+type instance RawKeyDimension Z (O :. rt) (t :. tt) = t+type instance RawKeyDimension Z (M :. rt) (t :. tt) = [t]+type instance RawKeyDimension Z O t = t+type instance RawKeyDimension Z M t = [t]+type instance RawKeyDimension (S n) (r :. rt) (t :. tt) = RawKeyDimension n rt tt++class (Ord k, Enum k, Bounded k) => Auto k where+instance (Ord k, Enum k, Bounded k) => Auto k where++-- | The store data type has four type arguments that define what and how+-- things are stored.+--+-- The @krs@ (key relation specification) and @irs@ (index relation+-- specification) define the relations between the dimensions of the key+-- and the elements. To that end, we use @'Data.Store.Internal.Type.O'@ and+-- @'Data.Store.Internal.Type.M'@ type-level tags and+-- @'Data.Store.Type.Internal.(:.)'@ data type to create tuple of these+-- tags (to describe all the dimensions).+--+-- The possible relations are as follows:+--+-- * One-one: Every intem is indexed under exactly one key dimension value. One key dimension value+-- corresponds to at most one elements.+--+-- * One-many: Every element is indexed under exactly one key dimension value. One key dimension value can+-- correspond to many elements.+--+-- * Many-one: Every element can be indexed under multiple (zero or more) key dimension values. One key dimension value+-- corresponds to at most one elements.+--+-- * Many-many: Every element cab be indexed under multiple (zero or more) key dimension value. One key dimension value+-- can correspond to many elements.+--+-- The @ts@ (type specification) defines the type of the key's dimensions+-- and finally @v@ is the type of the elements stored.+--+-- In our example with @Content@, we have five dimensions: ID, name, body,+-- tags and rating. We would like our store to have these properties:+--+-- * @Content@ has one ID, only one content can have a given ID.+--+-- * @Content@ has one name, only one content can have a given name.+--+-- * @Content@ has one body, many contents can have the same content.+--+-- * @Content@ has many tags, many contents can have tte same tag.+--+-- * @Content@ has one rating, many contents can have the same rating.+--+-- So in our case, we define:+--+-- > type ContentStoreKRS = O         :. O      :. O      :. M      :. O+-- > type ContentStoreIRS = O         :. O      :. M      :. M      :. M+-- > type ContentStoreTS  = ContentID :. String :. String :. String :. Double+-- > type ContentStore = Store ContentStoreKRS ContentStoreIRS ContentStoreTS Content+--+-- See also:+--+-- * 'Data.Store.Internal.Type.O'+--+-- * 'Data.Store.Internal.Type.M'+--+-- * 'Data.Store.Internal.Type.(:.)'+--+-- * 'Data.Store.Internal.Type.Key'+--+data Store tag krs irs ts v = Store+    { storeV :: !(Data.IntMap.IntMap (IKey krs ts, v))+    , storeI :: !(Index irs ts)+    , storeNID :: {-# UNPACK #-} !Int+    } deriving (Typeable)++instance (Show h, Show t) => Show (h :. t) where+    show (h :. t) = show h <> " :. " <> show t++instance (Ser.Serialize (IKey krs ts), Ser.Serialize (Index irs ts), Ser.Serialize v) => Ser.Serialize (Store tag krs irs ts v) where+    get = Store <$> Ser.get <*> Ser.get <*> Ser.get+    put (Store vs ix nid) = Ser.put vs >> Ser.put ix >> Ser.put nid++instance (Ser.SafeCopy (IKey krs ts), Ser.SafeCopy (Index irs ts), Ser.SafeCopy v) => Ser.SafeCopy (Store tag krs irs ts v) where+    getCopy = Ser.contain $ Store <$> Ser.safeGet <*> Ser.safeGet <*> Ser.safeGet+    putCopy (Store vs ix nid) = Ser.contain $ Ser.safePut vs >> Ser.safePut ix >> Ser.safePut nid++instance (Show (IKey krs ts), Show v) => Show (Store tag krs irs ts v) where+    show (Store vs _ _) = "[" <> go <> "]"+      where+        go = Data.List.intercalate "," $ map (\(ik, v) -> "((" <> show ik <> "), " <> show v <> ")")+                                       $ F.toList vs++data GenericKey dim rs ts where+    KN :: !(dim r t) -> !(GenericKey dim rt tt) -> GenericKey dim (r :. rt) (t :. tt)+    K1 :: !(dim r t) -> GenericKey dim r t++instance Eq (GenericKey IKeyDimension rs ts) where+    (K1 x) == (K1 y) = x == y+    (KN x xt) == (KN y yt) = x == y && xt == yt+    _ == _ = False    ++    (K1 x) /= (K1 y) = x /= y+    (KN x xt) /= (KN y yt) = x /= y || xt /= yt+    _ /= _ = True++{-+instance Eq (dim O t) => Eq (GenericKey dim O t) where+    (K1 x) == (K1 y) = x == y+    (K1 x) /= (K1 y) = x /= y++instance Eq (dim M t) => Eq (GenericKey dim M t) where+    (K1 x) == (K1 y) = x == y+    (K1 x) /= (K1 y) = x /= y++instance (Eq (dim r t), Eq (GenericKey dim rt tt)) => Eq (GenericKey dim (r :. rt) (t :. tt)) where+    (KN x xt) == (KN y yt) = x == y && xt == yt+    _ == _ = False++    (KN x xt) /= (KN y yt) = x /= y || xt /= yt+    _ /= _ = True+-}++instance Ser.Serialize (dim O t) => Ser.Serialize (GenericKey dim O t) where+    get = K1 <$> Ser.get+    put (K1 d) = Ser.put d++instance Ser.Serialize (dim M t) => Ser.Serialize (GenericKey dim M t) where+    get = K1 <$> Ser.get+    put (K1 d) = Ser.put d++instance (Ser.Serialize (GenericKey dim rt tt), Ser.Serialize (dim r t)) => Ser.Serialize (GenericKey dim (r :. rt) (t :. tt)) where+    get = KN <$> Ser.get <*> Ser.get+    put (KN d dt) = Ser.put d >> Ser.put dt+    put (K1 _) = error $ moduleName <> ".GenricKey.put: The impossible happened."++instance Ser.SafeCopy (dim O t) => Ser.SafeCopy (GenericKey dim O t) where+    getCopy = Ser.contain $ K1 <$> Ser.safeGet+    putCopy (K1 d) = Ser.contain $ Ser.safePut d++instance Ser.SafeCopy (dim M t) => Ser.SafeCopy (GenericKey dim M t) where+    getCopy = Ser.contain $ K1 <$> Ser.safeGet+    putCopy (K1 d) = Ser.contain $ Ser.safePut d++instance (Ser.SafeCopy (GenericKey dim rt tt), Ser.SafeCopy (dim r t)) => Ser.SafeCopy (GenericKey dim (r :. rt) (t :. tt)) where+    getCopy = Ser.contain $ KN <$> Ser.safeGet <*> Ser.safeGet+    putCopy (KN d dt) = Ser.contain $ Ser.safePut d >> Ser.safePut dt+    putCopy (K1 _) = error $ moduleName <> ".GenricKey.putCopy: The impossible happened."++instance Typeable2 (GenericKey dim) where+    typeOf2 (K1 _) = Data.Data.mkTyConApp (Data.Data.mkTyCon3 "data-store" moduleName "K1") []+    typeOf2 (KN _ _) = Data.Data.mkTyConApp (Data.Data.mkTyCon3 "data-store" moduleName "KN") []++type  Key = GenericKey  KeyDimension+type IKey = GenericKey IKeyDimension++instance Show t => Show (Key O t) where+    show (K1 d) = show d ++instance Show t => Show (Key M t) where+    show (K1 d) = show d ++instance (Show t, Show (Key rt tt)) => Show (Key (r :. rt) (t :. tt)) where+    show (KN d k) = show d <> ", " <> show k+    show (K1 _) = error $ moduleName <> ".Key.show: The impossible happened."++instance Show t => Show (IKey O t) where+    show (K1 d) = show d ++instance Show t => Show (IKey M t) where+    show (K1 d) = show d ++instance (Show t, Show (IKey rt tt)) => Show (IKey (r :. rt) (t :. tt)) where+    show (KN d k) = show d <> ", " <> show k+    show (K1 _) = error $ moduleName <> ".IKey.show: The impossible happened."++data Index rs ts where+    IN :: Ord t => !(IndexDimension r t) -> !(Index rt tt) -> Index (r :. rt) (t :. tt)+    I1 :: Ord t => !(IndexDimension r t) -> Index r t++instance (Ord t, Ser.Serialize t) => Ser.Serialize (Index O t) where+    get = I1 <$> Ser.get+    put (I1 ixd) = Ser.put ixd++instance (Ord t, Ser.Serialize t) => Ser.Serialize (Index M t) where+    get = I1 <$> Ser.get+    put (I1 ixd) = Ser.put ixd++instance (Ord t, Ser.Serialize t, Ser.Serialize (Index rt tt)) => Ser.Serialize (Index (O :. rt) (t :. tt)) where+    get = IN <$> Ser.get <*> Ser.get+    put (IN ixd ixt) = Ser.put ixd >> Ser.put ixt+    put (I1 _) = error $ moduleName <> ".Index.put: The impossible happened (#1)."++instance (Ord t, Ser.Serialize t, Ser.Serialize (Index rt tt)) => Ser.Serialize (Index (M :. rt) (t :. tt)) where+    get = IN <$> Ser.get <*> Ser.get+    put (IN ixd ixt) = Ser.put ixd >> Ser.put ixt+    put (I1 _) = error $ moduleName <> ".Index.put: The impossible happened (#2)."++instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (Index O t) where+    getCopy = Ser.contain $ I1 <$> Ser.safeGet+    putCopy (I1 ixd) = Ser.contain $ Ser.safePut ixd++instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (Index M t) where+    getCopy = Ser.contain $ I1 <$> Ser.safeGet+    putCopy (I1 ixd) = Ser.contain $ Ser.safePut ixd++instance (Ord t, Ser.SafeCopy t, Ser.SafeCopy (Index rt tt)) => Ser.SafeCopy (Index (O :. rt) (t :. tt)) where+    getCopy = Ser.contain $ IN <$> Ser.safeGet <*> Ser.safeGet+    putCopy (IN ixd ixt) = Ser.contain $ Ser.safePut ixd >> Ser.safePut ixt+    putCopy (I1 _) = error $ moduleName <> ".Index.putCopy: The impossible happened (#1)."++instance (Ord t, Ser.SafeCopy t, Ser.SafeCopy (Index rt tt)) => Ser.SafeCopy (Index (M :. rt) (t :. tt)) where+    getCopy = Ser.contain $ IN <$> Ser.safeGet <*> Ser.safeGet+    putCopy (IN ixd ixt) = Ser.contain $ Ser.safePut ixd >> Ser.safePut ixt+    putCopy (I1 _) = error $ moduleName <> ".Index.putCopy: The impossible happened (#2)."++instance Typeable2 Index where+    typeOf2 (I1 _) = Data.Data.mkTyConApp (Data.Data.mkTyCon3 "data-store" moduleName "I1") []+    typeOf2 (IN _ _) = Data.Data.mkTyConApp (Data.Data.mkTyCon3 "data-store" moduleName "IN") []++instance Show t => Show (Index O t) where+    show (I1 d) = show d++instance Show t => Show (Index M t) where+    show (I1 d) = show d++instance (Show t, Show (Index rt tt)) => Show (Index (r :. rt) (t :. tt)) where+    show (IN d i) = show d <> "\n" <> show i+    show (I1 _) = error $ moduleName <> ".Index.show: The impossible happened."++data KeyDimension r t where+    KeyDimensionO :: Ord t =>  t  -> KeyDimension O t+    KeyDimensionM :: Ord t => [t] -> KeyDimension M t+    KeyDimensionA :: Auto t => KeyDimension O t++deriving instance Typeable2 KeyDimension++instance Show t => Show (KeyDimension r t) where+    show (KeyDimensionM ts) = show ts+    show (KeyDimensionO t)  = show t+    show  KeyDimensionA     = show "Auto"++data IKeyDimension r t where+    IKeyDimensionO :: Ord t => t  -> IKeyDimension O t+    IKeyDimensionM :: Ord t => [t] -> IKeyDimension M t++instance Eq (IKeyDimension r t) where+    (IKeyDimensionM x) == (IKeyDimensionM y) = x == y+    (IKeyDimensionO x) == (IKeyDimensionO y) = x == y+    _ == _ = False++    (IKeyDimensionM x) /= (IKeyDimensionM y) = x /= y+    (IKeyDimensionO x) /= (IKeyDimensionO y) = x /= y+    _ /= _ = True    ++deriving instance Typeable2 IKeyDimension++instance (Ord t, Ser.Serialize t) => Ser.Serialize (IKeyDimension O t) where+    get = IKeyDimensionO <$> Ser.get+    put (IKeyDimensionO x) = Ser.put x++instance (Ord t, Ser.Serialize t) => Ser.Serialize (IKeyDimension M t) where+    get = IKeyDimensionM <$> Ser.get+    put (IKeyDimensionM x) = Ser.put x++instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (IKeyDimension O t) where+    getCopy = Ser.contain $ IKeyDimensionO <$> Ser.safeGet+    putCopy (IKeyDimensionO x)  = Ser.contain $ Ser.safePut x++instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (IKeyDimension M t) where+    getCopy = Ser.contain $ IKeyDimensionM <$> Ser.safeGet+    putCopy (IKeyDimensionM x)  = Ser.contain $ Ser.safePut x++instance Show t => Show (IKeyDimension r t) where+    show (IKeyDimensionM ts) = show ts+    show (IKeyDimensionO t)  = show t++data IndexDimension r t where+    IndexDimensionO :: Ord t+                    => !(Data.Map.Map t Int)+                    -> IndexDimension O t+    +    IndexDimensionM :: Ord t+                    => !(Data.Map.Map t Data.IntSet.IntSet)+                    -> IndexDimension M t++instance (Ord t, Ser.Serialize t) => Ser.Serialize (IndexDimension O t) where+    get = IndexDimensionO <$> Ser.get+    put (IndexDimensionO x) = Ser.put x++instance (Ord t, Ser.Serialize t) => Ser.Serialize (IndexDimension M t) where+    get = IndexDimensionM <$> Ser.get+    put (IndexDimensionM x) = Ser.put x++instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (IndexDimension O t) where+    getCopy = Ser.contain $ IndexDimensionO <$> Ser.safeGet+    putCopy (IndexDimensionO x)  = Ser.contain $ Ser.safePut x++instance (Ord t, Ser.SafeCopy t) => Ser.SafeCopy (IndexDimension M t) where+    getCopy = Ser.contain $ IndexDimensionM <$> Ser.safeGet+    putCopy (IndexDimensionM x)  = Ser.contain $ Ser.safePut x++instance Show t => Show (IndexDimension r t) where+    show (IndexDimensionM m) = show $ map (\(k, vs) -> (k, Data.IntSet.toList vs)) $ Data.Map.toList m+    show (IndexDimensionO m) = show $ Data.Map.toList m++class GetDimension n a where+    getDimension :: n -> a -> RawDimensionType n a++instance GetDimension Z (Index O t) where+    getDimension _ (I1 ixd) = ixd++instance GetDimension Z (Index M t) where+    getDimension _ (I1 ixd) = ixd++instance GetDimension Z (Index (r :. rt) (t :. tt)) where+    getDimension _ (IN ixd _) = ixd+    getDimension _ (I1 _) = error $ moduleName <> ".Index.getDimension: The impossible happened."++instance GetDimension n (Index rt tt) => GetDimension (S n) (Index (r :. rt) (t :. tt)) where+    getDimension (S n) (IN _ ixt) = getDimension n ixt+    getDimension _ (I1 _) = error $ moduleName <> ".Index.getDimension: The impossible happened."++instance GetDimension Z (IKey O t) where+    getDimension _ (K1 kd) = kd++instance GetDimension Z (IKey M t) where+    getDimension _ (K1 kd) = kd++instance GetDimension Z (IKey (r :. rt) (t :. tt)) where+    getDimension _ (KN kd _) = kd+    getDimension _ (K1 _) = error $ moduleName <> ".IKey.getDimension: The impossible happened."++instance GetDimension n (IKey rt tt) => GetDimension (S n) (IKey (r :. rt) (t :. tt)) where+    getDimension (S n) (KN _ kt) = getDimension n kt+    getDimension _ (K1 _) = error $ moduleName <> ".IKey.getDimension: The impossible happened."++data TT+data FF++type family   EmptyProxyIsSpecial t :: *+type instance EmptyProxyIsSpecial Int = TT++class Empty a where+    empty :: a++class EmptyProxy flag a where+    emptyProxy :: flag -> a++instance Ord t => Empty (Index O t) where+    empty = I1 (IndexDimensionO Data.Map.empty)++instance Ord t => Empty (Index M t) where+    empty = I1 (IndexDimensionM Data.Map.empty)++instance (Ord t, Empty (Index rt tt)) => Empty (Index (O :. rt) (t :. tt)) where+    empty = IN (IndexDimensionO Data.Map.empty) empty++instance (Ord t, Empty (Index rt tt)) => Empty (Index (M :. rt) (t :. tt)) where+    empty = IN (IndexDimensionM Data.Map.empty) empty++instance Empty (Index irs ts) => Empty (Store tag krs irs ts e) where+    empty = Store+        { storeV = Data.IntMap.empty+        , storeI = empty+        , storeNID = 0+        }+    {-# INLINE empty #-}++-- | Data type for creating tuples, it is used to:+--+-- * Create type-level tuples of relation tags for relation specification of+-- the key and the index of the store.+--+-- > M :. O :. O :. M+--+-- * Create type-level tuples of types for type specification of the key+-- and index of the store.+--+-- > Int :. Double :. String :. String+--+-- * Create value-level tuples to return raw key (with resolved+-- auto-increment dimensions).+--+-- > [1, 2, 3] :. 3.5 :. "Foo" :. ["Bar1", "Bar2"]+data h :. t = h :. t+infixr 3 :.+++-- NFDATA INSTANCES++instance (NFData e, NFData (IKey krs ts), NFData (Index irs ts)) => NFData (Store tag krs irs ts e) where+    rnf (Store ke ix nid) = rnf ke `seq` rnf ix `seq` rnf nid++instance NFData t => NFData (IndexDimension r t) where+    rnf (IndexDimensionO m) = rnf m+    rnf (IndexDimensionM m) = rnf m++instance NFData t => NFData (Index O t) where+    rnf (I1 kd) = rnf kd+     +instance NFData t => NFData (Index M t) where+    rnf (I1 kd) = rnf kd++instance (NFData t, NFData (Index rt tt)) => NFData (Index (r :. rt) (t :. tt)) where+    rnf (IN kd kt) = rnf kd `seq` rnf kt+    rnf (I1 _) = error "Impossible! (Index NFData)"++instance NFData t => NFData (IKeyDimension r t) where+    rnf (IKeyDimensionO x) = rnf x+    rnf (IKeyDimensionM x) = rnf x++instance NFData t => NFData (IKey O t) where+    rnf (K1 kd) = rnf kd+     +instance NFData t => NFData (IKey M t) where+    rnf (K1 kd) = rnf kd++instance (NFData t, NFData (IKey rt tt)) => NFData (IKey (r :. rt) (t :. tt)) where+    rnf (KN kd kt) = rnf kd `seq` rnf kt+    rnf (K1 _) = error "Impossible! (IKey NFData)"++instance (NFData a, NFData b) => NFData (a :. b) where+    rnf (a :. b) = rnf a `seq` rnf b++
src/Data/Store/Lens.hs view
@@ -1,33 +1,33 @@-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Data.Store.Lens
-( With(..)
-) where
-
---------------------------------------------------------------------------------
-import qualified Control.Lens
---------------------------------------------------------------------------------
-import           Data.Monoid 
-import           Data.Functor.Identity
---------------------------------------------------------------------------------
-import qualified Data.Store.Internal.Type     as I
-import qualified Data.Store.Internal.Function as I
-import qualified Data.Store.Selection         as I (IsSelection(resolve))
-import qualified Data.Store                   as I ()
---------------------------------------------------------------------------------
-
-class With sel where
-    with :: I.Empty (I.Index irs ts) 
-         => sel tag krs irs ts -> Control.Lens.Lens' (I.Store tag krs irs ts v)
-                                                     (I.Store tag krs irs ts v)
-
-instance I.IsSelection sel => With sel where
-    with sel tr old =
-      fmap (mappend (runIdentity $! I.genericUpdateWithKey I.indexInsertID'' (\_ _ -> Nothing) ids old))
-           (tr (I.genericSubset ids old))
-      where
-        ids = I.resolve sel old
-
+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Store.Lens+( With(..)+) where++--------------------------------------------------------------------------------+import qualified Control.Lens+--------------------------------------------------------------------------------+import           Data.Monoid +import           Data.Functor.Identity+--------------------------------------------------------------------------------+import qualified Data.Store.Internal.Type     as I+import qualified Data.Store.Internal.Function as I+import qualified Data.Store.Selection         as I (IsSelection(resolve))+import qualified Data.Store                   as I ()+--------------------------------------------------------------------------------++class With sel where+    with :: I.Empty (I.Index irs ts) +         => sel tag krs irs ts -> Control.Lens.Lens' (I.Store tag krs irs ts v)+                                                     (I.Store tag krs irs ts v)++instance I.IsSelection sel => With sel where+    with sel tr old =+      fmap (mappend (runIdentity $! I.genericUpdateWithKey I.indexInsertID'' (\_ _ -> Nothing) ids old))+           (tr (I.genericSubset ids old))+      where+        ids = I.resolve sel old+
src/Data/Store/Selection.hs view
@@ -1,235 +1,243 @@-{-# 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.+--+-- NOTE: Expects nonempty list.+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@).+--+-- NOTE: Expects nonempty list.+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.+--+-- NOTE: Expects nonempty list.+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@).+--+-- NOTE: Expects nonempty list.+any1D :: (tag, n) -> [(tag, n) -> Selection tag krs irs ts] -> Selection tag krs irs ts+any1D _ [] = error $ moduleName <> ".any1D: empty list."+any1D d (x:xs) = Data.List.foldl' (\acc f -> acc .|| f d) (x d) xs+{-# INLINE any1D #-}++-- | The expression (@sDim .< c@) is a selection that includes value+-- @x@ if and only if it is indexed in the @sDim@ dimension with a key @k@+-- such that @k < c@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(log n + k)/+(.<) :: I.GetDimension n (I.Index irs ts) => (tag, n) -> I.DimensionType n irs ts -> Selection tag krs irs ts+(.<) (_, n) = SelectionType . SelectionDimension n (Condition True False False)+{-# INLINE (.<) #-}++-- | The expression (@sDim .<= c@) is a selection that includes value+-- @x@ if and only if it is indexed in the @sDim@ dimension with a key @k@+-- such that @k <= c@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(log n + k)/+(.<=) :: I.GetDimension n (I.Index irs ts) => (tag, n) -> I.DimensionType n irs ts -> Selection tag krs irs ts+(.<=) (_, n) = SelectionType . SelectionDimension n (Condition True True False)+{-# INLINE (.<=) #-}++-- | The expression (@sDim .> c@) is a selection that includes value+-- @x@ if and only if it is indexed in the @sDim@ dimension with a key @k@+-- such that @k > c@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(log n + k)/+(.>) :: I.GetDimension n (I.Index irs ts) => (tag, n) -> I.DimensionType n irs ts -> Selection tag krs irs ts+(.>) (_, n) = SelectionType . SelectionDimension n (Condition False False True)+{-# INLINE (.>) #-}++-- | The expression (@sDim .>= c@) is a selection that includes value+-- @x@ if and only if it is indexed in the @sDim@ dimension with a key @k@+-- such that @k >= c@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(log n + k)/+(.>=) :: I.GetDimension n (I.Index irs ts) => (tag, n) -> I.DimensionType n irs ts -> Selection tag krs irs ts+(.>=) (_, n) = SelectionType . SelectionDimension n (Condition False True True)+{-# INLINE (.>=) #-}++-- | The expression (@sDim ./= c@) is a selection that includes value+-- @x@ if and only if it is indexed in the @sDim@ dimension with a key @k@+-- such that @k /= c@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(n)/+(./=) :: I.GetDimension n (I.Index irs ts) => (tag, n) -> I.DimensionType n irs ts -> Selection tag krs irs ts+(./=) (_, n) = SelectionType . SelectionDimension n (Condition True False True)+{-# INLINE (./=) #-}++-- | The expression (@sDim .== c@) is a selection that includes value+-- @x@ if and only if it is indexed in the @sDim@ dimension with a key @k@+-- such that @k == c@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(log n)/+(.==) :: I.GetDimension n (I.Index irs ts) => (tag, n) -> I.DimensionType n irs ts -> Selection tag krs irs ts+(.==) (_, n) = SelectionType . SelectionDimension n (Condition False True False)+{-# INLINE (.==) #-}++-- | The expression (@s1 .&& s2@) is a selection that includes the+-- intersection of the selections @s1@ and @s2@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(c(s1) + c(s2) + s(s1) + s(s2)/+(.&&) :: (IsSelection s1, IsSelection s2)+      => s1 tag krs irs ts -> s2 tag krs irs ts -> Selection tag krs irs ts+(.&&) = SelectionA+{-# INLINE (.&&) #-}++-- | The expression (@s1 .|| s2@) is a selection that includes the+-- union of the selections @s1@ and @s2@.+--+-- Complexity of @'Data.Store.Selection.resolve'@: /O(c(s1) + c(s2) + s(s1) + s(s2)/+(.||) :: (IsSelection s1, IsSelection s2)+      => s1 tag krs irs ts -> s2 tag krs irs ts -> Selection tag krs irs ts+(.||) = SelectionO+{-# INLINE (.||) #-}++-- IMPLEMENTATION++instance IsSelection Selection where+    resolve (SelectionType sel) s = resolve sel s+    resolve (SelectionA s1 s2) s = Data.IntSet.intersection (resolve s1 s) (resolve s2 s)+    resolve (SelectionO s1 s2) s = Data.IntSet.union (resolve s1 s) (resolve s2 s)+    resolve (SelectionNot sel) s@(I.Store vs _ _) =+        Data.IntSet.difference (Data.IntMap.keysSet vs) (resolve sel s)+    {-# INLINE resolve #-}++instance IsSelection (SelectionDimension n) where+    resolve = resolveSD+    {-# INLINE resolve #-}++resolveSD :: forall tag n krs irs ts v . SelectionDimension n tag krs irs ts +          -> I.Store tag krs irs ts v+          -> Data.IntSet.IntSet+resolveSD (SelectionDimension _ (Condition False False False) _) _ = {-# SCC "resolveSD" #-} Data.IntSet.empty+resolveSD (SelectionDimension _ (Condition True True True) _) (I.Store vs _ _) = {-# SCC "resolveSD" #-}  Data.IntSet.fromList $ Data.IntMap.keys vs+resolveSD (SelectionDimension n (Condition lt eq gt) v) (I.Store _ ix _) = {-# SCC "resolveSD" #-} +    go $! I.getDimension n ix+    where+      go (I.IndexDimensionO m) = m `seq` case Data.Map.splitLookup v m of+          (lk, ek, gk) -> (if lt then trO lk else Data.IntSet.empty) <>+                          (if eq then trMaybeO ek else Data.IntSet.empty) <>+                          (if gt then trO gk else Data.IntSet.empty)                         +      go (I.IndexDimensionM m) = m `seq` case Data.Map.splitLookup v m of+          (lk, ek, gk) -> (if lt then trM lk else Data.IntSet.empty) <>+                          (if eq then trMaybeM ek else Data.IntSet.empty) <>+                          (if gt then trM gk else Data.IntSet.empty)+      {-# INLINEABLE go #-}++      trO :: Data.Map.Map k Int -> Data.IntSet.IntSet+      trO xs = {-# SCC "resolveSD.trO" #-} Data.Map.foldl' ins Data.IntSet.empty xs+        where ins acc i = Data.IntSet.insert i acc+      {-# INLINE trO #-}++      trMaybeO :: Maybe Int -> Data.IntSet.IntSet+      trMaybeO (Just x) = Data.IntSet.singleton x+      trMaybeO _ = Data.IntSet.empty+      {-# INLINE trMaybeO #-}++      trM :: Data.Map.Map k Data.IntSet.IntSet -> Data.IntSet.IntSet+      trM = Data.Map.foldl' Data.IntSet.union Data.IntSet.empty+      {-# INLINE trM #-}++      trMaybeM :: Maybe Data.IntSet.IntSet -> Data.IntSet.IntSet+      trMaybeM (Just x) = x+      trMaybeM _ = Data.IntSet.empty+      {-# INLINE trMaybeM #-}+{-# INLINE resolveSD #-}++-- | TYPE++data SelectionDimension n tag krs irs ts where+    SelectionDimension :: I.GetDimension n (I.Index irs ts)+                       => n+                       -> Condition+                       -> I.DimensionType n irs ts+                       -> SelectionDimension n tag krs irs ts++data Selection tag krs irs ts where+    SelectionType :: IsSelection sel => sel tag krs irs ts -> Selection tag krs irs ts    ++    SelectionA :: (IsSelection s1, IsSelection s2)+               => s1 tag krs irs ts -> s2 tag krs irs ts -> Selection tag krs irs ts++    SelectionO :: (IsSelection s1, IsSelection s2)+               => s1 tag krs irs ts -> s2 tag krs irs ts -> Selection tag krs irs ts++    SelectionNot :: IsSelection sel => sel tag krs irs ts -> Selection tag krs irs ts++data Condition = Condition !Bool !Bool !Bool++class IsSelection sel where+    resolve :: sel tag krs irs ts -> I.Store tag krs irs ts v -> Data.IntSet.IntSet+
src/Data/Store/Storable.hs view
@@ -1,110 +1,147 @@-{-# 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 CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}++module Data.Store.Storable+( Storable(..)++, map+, insert+, insert'+, updateWithKey+, updateWithKey'+, update+, update'+, fromList+, fromList'+) where++--------------------------------------------------------------------------------+import           Data.Functor.Identity +import qualified Data.List (map)+--------------------------------------------------------------------------------+import qualified Data.Store.Internal.Type as I +import qualified Data.Store.Internal.Function as I +import qualified Data.Store as S +import qualified Data.Store.Selection as S (IsSelection())+#if MIN_VERSION_containers(0,5,0)+import qualified Data.IntMap.Strict as Data.IntMap+#else+import qualified Data.IntMap+#endif+import Prelude hiding (map)+--------------------------------------------------------------------------------++-- | 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+-- +-- NOTE: Using functions outside of this module to update the store may+-- cause inconsistencies with respect to the user defined+-- @'Data.Store.Storable.Storable'@ instance.+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'@ (the key of the inserted element is obtained using the+-- @'Data.Store.Storable.Storable.key'@ function).+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''@ (the key of the inserted element is obtained using the+-- @'Data.Store.Storable.Storable.key'@ function).+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.Storable.update''@ (the keys of the updated elements are obtained using the+-- @'Data.Store.Storable.Storable.key'@ function).+map :: Storable v+    => (v -> v)+    -> S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v+    -> S.Store tag (StoreKRS v) (StoreIRS v) (StoreTS v) v+map tr s@(I.Store values _ _) = runIdentity $! I.genericUpdateWithKey+  I.indexInsertID'+  (\_ e -> let tre = tr e in Just (tre, Just $! key tre))+  (Data.IntMap.keysSet values)+  s+{-# INLINE map #-}++-- | See @'Data.Store.update'@ (the keys of the updated elements are obtained using the+-- @'Data.Store.Storable.Storable.key'@ function).+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''@ (the keys of the updated elements are obtained using the+-- @'Data.Store.Storable.Storable.key'@ function).+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'@ (the keys of the updated elements are obtained using the+-- @'Data.Store.Storable.Storable.key'@ function).+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''@ (the keys of the updated elements are obtained using the+-- @'Data.Store.Storable.Storable.key'@ function).+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'@ (the keys of the elements are obtained using the+-- @'Data.Store.Storable.Storable.key'@ function).+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 . Data.List.map (\v -> (key v, v))+{-# INLINE fromList #-}++-- | See @'Data.Store.fromList''@ (the keys of the elements are obtained using the+-- @'Data.Store.Storable.Storable.key'@ function).+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' . Data.List.map (\v -> (key v, v))+{-# INLINE fromList' #-}+
tests/Main.hs view
@@ -1,14 +1,14 @@-module Main
-( main
-) where
-
-------------------------------------------------------------------------------
-import Test.Framework (defaultMain, testGroup)
-------------------------------------------------------------------------------
-import qualified Test.Data.Store01
-------------------------------------------------------------------------------
-
-main :: IO ()
-main = defaultMain
-    [ testGroup "Data.Store01" Test.Data.Store01.tests
-    ]
+module Main+( main+) where++------------------------------------------------------------------------------+import Test.Framework (defaultMain, testGroup)+------------------------------------------------------------------------------+import qualified Test.Data.Store01+------------------------------------------------------------------------------++main :: IO ()+main = defaultMain+    [ testGroup "Data.Store01" Test.Data.Store01.tests+    ]
tests/Test/Data/Store01.hs view
@@ -1,375 +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 "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
-
+{-# 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+