popkey (empty) → 0.0.0.1
raw patch · 9 files changed
+1161/−0 lines, 9 filesdep +QuickCheckdep +basedep +bitvec
Dependencies added: QuickCheck, base, bitvec, bytestring, containers, hspec, hw-bits, hw-prim, hw-rankselect, hw-rankselect-base, popkey, profunctors, store, text, vector
Files
- CHANGELOG.md +6/−0
- LICENSE +20/−0
- popkey.cabal +80/−0
- src/PopKey.hs +156/−0
- src/PopKey/Encoding.hs +413/−0
- src/PopKey/Internal1.hs +94/−0
- src/PopKey/Internal2.hs +146/−0
- src/PopKey/Internal3.hs +214/−0
- test/Spec.hs +32/−0
+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# Revision history for popkey++## 0.0.0.1++- Initial release+
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2020 Identical Snowflake++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ popkey.cabal view
@@ -0,0 +1,80 @@+cabal-version: 2.4+name: popkey+version: 0.0.0.1+synopsis: Static key-value storage backed by poppy+description: Static key-value storage backed by poppy.+homepage: https://github.com/identicalsnowflake/popkey+bug-reports: https://github.com/identicalsnowflake/popkey/issues+license: MIT+license-file: LICENSE+author: Identical Snowflake+maintainer: identicalsnowflake@protonmail.com+copyright: 2020+category: Data+extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/identicalsnowflake/popkey++library+ exposed-modules:+ PopKey+ PopKey.Encoding+ PopKey.Internal1+ PopKey.Internal2+ PopKey.Internal3+ -- other-modules:+ build-depends: base >= 4.12.0.0 && < 5+ , bitvec >= 1.0.2.0 && < 2.0.0.0+ , bytestring >= 0.10.10.0 && < 0.11+ , containers >= 0.6.2.1 && < 0.7+ , hw-bits >= 0.7.1.5+ , hw-prim >= 0.6.3.0+ , hw-rankselect >= 0.13.4.0 && < 0.14+ , hw-rankselect-base >= 0.3.4.0+ , profunctors >= 5.5.2 && < 5.6+ , store >= 0.7.2 && < 0.8+ , text >= 1.2.4.0 && < 1.3+ , vector >= 0.12.1.2 && < 0.13+ hs-source-dirs: src+ ghc-options: -Wall -Wextra+ default-language: Haskell2010+ default-extensions: BangPatterns+ , BlockArguments+ , DefaultSignatures+ , DeriveAnyClass+ , DeriveFunctor+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GeneralizedNewtypeDeriving+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ , ViewPatterns+ +test-suite spec+ ghc-options: -threaded -rtsopts -Wall -Wextra+ type: exitcode-stdio-1.0+ main-is: test/Spec.hs+ build-depends: base+ , containers+ , hspec >= 2 && < 3+ , popkey+ , QuickCheck >= 2.13.2 && < 2.14+ build-tool-depends: hspec-discover:hspec-discover+ default-language: Haskell2010+ default-extensions: BlockArguments+ , DeriveFunctor+ , DeriveGeneric+ , FlexibleInstances+ , ScopedTypeVariables+ , ViewPatterns
+ src/PopKey.hs view
@@ -0,0 +1,156 @@+-- | PopKey gives you a static key-value storage structure backed by poppy indices. Construction is slow (multiple passes are made over the data to choose a good indexing structure), but querying should be fast, and space overhead should be much lower than Data.Map—on the data set I'm working with, Data.Map has 8.3x more overhead than PopKey—and the raw data transparently lives in an mmap'd region if you use @storage@, meaning the actual memory needed for usage is very low.+--+-- To construct, you will need @PopKeyEncoding@ instances. You may choose the granularity by which you encode your data types by choosing one of two auto-deriving patterns. The first, implicitly derived via GHC Generics, will use a granular encoding, indexing fields separately internally, while the second, derived via the @StoreBlob@ newtype, will encode the data as a single unit. Which is better depends on the situation, but as a general rule you should pack your constant-size structures into a single blob while letting your variable-sized fields use the granular encoding.+--+-- @+-- -- Encode @MyType@ with separate indices for the @[ String ]@ and @String@ fields.+-- data MyType = MyType [ String ] String+-- deriving (Generic,PopKeyEncoding)+-- @+-- +-- @+-- -- Encode @Point@ as a blob, with all 3 @Int@ fields stored contiguously.+-- data Point = Point Int Int Int+-- deriving (Generic,Store) -- @Store@ here is from Data.Store+-- deriving PopKeyEncoding via StoreBlob Point+-- @+--+-- Reading from and storing to disk come pre-packaged, in such a way that loading your structure from the disk will strictly load the small index metadata while leaving the large raw data to be backed by mmap. You may use this functionality as follows:+--+-- @+-- myData :: PopKeyStore Point MyType+-- myData = storage "myindex.poppy"+-- +-- main :: IO ()+-- main = do+-- -- your data+-- let dat :: [ (Point , MyType) ] = ...+-- +-- -- store the indexed data to disk+-- storePopKey myData dat+-- +-- -- load the indexed data from disk+-- pk :: PopKey Point MyType <- loadPopKey myData+-- +-- ...+-- @+--+-- Poppy natively supports array-style indexing, so if your "key" set is simply the dense set of integers @[ 0 .. n - 1 ]@ where @n@ is the number of items in your data set, key storage may be left implicit and elided entirely. In this API, when the distinction is necessary, working with such an implicit index is signified by a trailing ', e.g., @storage@ vs @storage'@.++module PopKey+ ( type PopKey+ , module PopKey+ , StoreBlob(..)+ , PopKeyEncoding+ , PopKeyStore+ , PopKeyStore'+ , StorePopKey(..)+ ) where++import Data.Bifunctor+import qualified Data.ByteString as BS+import Data.List (sortOn)+import Data.Store (encode , decodeEx)+import GHC.Word+import HaskellWorks.Data.FromForeignRegion+import System.IO++import PopKey.Internal2+import PopKey.Internal3+import PopKey.Encoding+++{-# INLINE (!) #-}+-- | Lookup by a key known to be in the structure.+(!) :: PopKey k v -> k -> v+(!) (PopKeyInt p vd ke) k = vd do rawq (ke k) p+(!) (PopKeyAny pv vd ke pk) k =+ vd do rawq (bin_search2 pk (ke k) 0 (flength pk - 1)) pv++{-# INLINE lookup #-}+-- | Lookup by a key which may or may not be in the structure.+lookup :: PopKey k v -> k -> Maybe v+lookup s@(PopKeyInt p vd ke) (ke -> i) = if i >= 0 && i < length s+ then Just (vd do rawq i p)+ else Nothing+lookup (PopKeyAny pv vd ke pk) k = do+ let i = bin_search2 pk (ke k) 0 (flength pk - 1)+ if i == -1+ then Nothing+ else Just (vd do rawq i pv)++{-# INLINE makePopKey #-}+-- | Create a poppy-backed key-value storage structure.+makePopKey :: forall f k v . (Foldable f , PopKeyEncoding k , PopKeyEncoding v) => f (k , v) -> PopKey k v+makePopKey =+ makePopKeyWithEncoding (shape @k) (pkEncode @k) (shape @v) (pkEncode @v) (pkDecode @v)+ where+ makePopKeyWithEncoding :: Foldable f+ => I s1 -> (k -> F' s1 BS.ByteString)+ -> I s2 -> (v -> F' s2 BS.ByteString) -> (F' s2 BS.ByteString -> v)+ -> f (k , v)+ -> PopKey k v+ makePopKeyWithEncoding ik ek iv ev dv xs = do+ let (ks , vs) = unzip (lastv $ sortOn fst (foldr ((:) . first ek) [] xs))+ PopKeyAny do construct iv ev vs+ do dv+ do ek+ do construct ik id ks+ where+ -- for duplicate keys, use the last value+ lastv :: forall a b . Ord a => [(a,b)] -> [(a,b)]+ lastv [] = []+ lastv [ x ] = [ x ]+ lastv (x : ys@(y : _)) =+ if fst x == fst y+ then lastv ys+ else x : lastv ys++-- | Create a poppy-backed structure with elements implicitly indexed by their position.+{-# INLINE makePopKey' #-}+makePopKey' :: forall f v . (Foldable f , PopKeyEncoding v) => f v -> PopKey Int v+makePopKey' = go (shape @v) (pkEncode @v) (pkDecode @v) . foldr (:) []+ where+ go :: I s -> (a -> F' s BS.ByteString) -> (F' s BS.ByteString -> a) -> [ a ] -> PopKey Int a+ go i e d xs =+ PopKeyInt do construct i e xs+ do d+ do id++-- | You may use @storage@ to gain a pair of operations to serialize and read your structure from disk. This will be more efficient than if you naively serialize and store the data, as it strictly reads index metadata into memory while leaving the larger raw chunks to be backed by mmap.+storage :: (PopKeyEncoding k , PopKeyEncoding v)+ => FilePath -> PopKeyStore k v+storage p =+ PopKeyStore+ do \d -> do+ let (b1,b2) = bencode (toSPopKey (makePopKey d))+ withBinaryFile p WriteMode \fh -> do+ BS.hPut fh (encode (fromIntegral (BS.length b1) :: Word64))+ BS.hPut fh b1+ BS.hPut fh b2+ do fh <- openBinaryFile p ReadMode+ w64 :: Word64 <- decodeEx <$> BS.hGet fh 8+ let s = fromIntegral w64+ b1 <- BS.hGet fh s+ hClose fh+ b2 <- BS.drop (8 + s) <$> mmapFromForeignRegion p+ pure (fromSPopKey (bdecode (b1,b2)))++-- | Like @storage@, but for canonical integer keys.+storage' :: PopKeyEncoding v+ => FilePath -> PopKeyStore' v+storage' p = PopKeyStore'+ do \d -> do+ let (b1,b2) = bencode (toSPopKey (makePopKey' d))+ withBinaryFile p WriteMode \fh -> do+ BS.hPut fh (encode (fromIntegral (BS.length b1) :: Word64))+ BS.hPut fh b1+ BS.hPut fh b2+ do fh <- openBinaryFile p ReadMode+ w64 :: Word64 <- decodeEx <$> BS.hGet fh 8+ let s = fromIntegral w64+ b1 <- BS.hGet fh s+ hClose fh+ b2 <- BS.drop (8 + s) <$> mmapFromForeignRegion p+ pure (fromSPopKey' (bdecode (b1,b2)))+
+ src/PopKey/Encoding.hs view
@@ -0,0 +1,413 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_HADDOCK hide #-}++module PopKey.Encoding where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Store as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT++import PopKey.Internal2++-- for instance decls only+import Data.Functor.Const+import Data.Functor.Identity+import Data.Graph (Graph)+import Data.IntMap (IntMap)+import Data.IntSet (IntSet)+import Data.Map (Map)+import Data.Proxy+import Data.Ratio+import Data.Semigroup+import Data.Sequence (Seq)+import Data.Set (Set)+-- import Data.Tree (Tree) - no store instance available+import GHC.Generics+import GHC.Natural+import GHC.Int+import GHC.Word+++-- | A simple wrapper to declare you do not want this data to be granularly partitioned by poppy.+newtype StoreBlob a = StoreBlob { unStoreBlob :: a }+ deriving (Generic,Eq,Ord,Show,Bounded)+ deriving newtype Enum+++-- | Inverse law: @pkDecode . pkEncode = id@. Note that this encoding is explicitly for use with poppy - use your discretion (or better, test!) to decide the granularity with which you wish to use this encoding as opposed to the standard store encoding. Relying more on PopKeyEncoding will probably use less space, but at the cost of storing items in less contiguous memory.+class PopKeyEncoding a where+ type Shape a+ type Shape a = GShape (Rep a)+ shape :: I (Shape a)+ default shape :: (GPopKeyEncoding a (Rep a) , GShape (Rep a) ~ Shape a) => I (Shape a)+ shape = gshape @a @(Rep a)+ + pkEncode :: a -> F' (Shape a) BS.ByteString+ default pkEncode :: (Generic a , GPopKeyEncoding a (Rep a) , GShape (Rep a) ~ Shape a) => a -> F' (Shape a) BS.ByteString+ pkEncode = gpkEncode @a @(Rep a) . from+ + pkDecode :: F' (Shape a) BS.ByteString -> a+ default pkDecode :: (Generic a , GPopKeyEncoding a (Rep a) , GShape (Rep a) ~ Shape a) => F' (Shape a) BS.ByteString -> a+ pkDecode = to . gpkDecode @a @(Rep a)++class GPopKeyEncoding s f where+ type GShape f+ gshape :: I (GShape f)++ gpkEncode :: f a -> F' (GShape f) BS.ByteString+ gpkDecode :: F' (GShape f) BS.ByteString -> f a++instance GPopKeyEncoding s U1 where+ type GShape U1 = ()+ {-# INLINE gshape #-}+ gshape = ISingle+ {-# INLINE gpkEncode #-}+ gpkEncode = const (Single' mempty)+ {-# INLINE gpkDecode #-}+ gpkDecode = const U1+++instance PopKeyEncoding a => GPopKeyEncoding s (K1 i a) where+ type GShape (K1 i a) = Shape a+ {-# INLINE gshape #-}+ gshape = shape @a+ {-# INLINE gpkEncode #-}+ gpkEncode (K1 x) = pkEncode x+ {-# INLINE gpkDecode #-}+ gpkDecode = K1 . pkDecode++instance (GPopKeyEncoding s a , GPopKeyEncoding s b) => GPopKeyEncoding s (a :*: b) where+ type GShape (a :*: b) = (GShape a , GShape b)+ {-# INLINE gshape #-}+ gshape = IProd (gshape @s @a) (gshape @s @b)+ {-# INLINE gpkEncode #-}+ gpkEncode (a :*: b) = Prod' (gpkEncode @s a) (gpkEncode @s b)+ {-# INLINE gpkDecode #-}+ gpkDecode (Prod' a b) = gpkDecode @s a :*: gpkDecode @s b++instance (GPopKeyEncoding s a , GPopKeyEncoding s b) => GPopKeyEncoding s (a :+: b) where+ type GShape (a :+: b) = Either (GShape a) (GShape b)+ {-# INLINE gshape #-}+ gshape = ISum (gshape @s @a) (gshape @s @b)+ {-# INLINE gpkEncode #-}+ gpkEncode (L1 x) = Sum' (Left (gpkEncode @s x))+ gpkEncode (R1 x) = Sum' (Right (gpkEncode @s x))+ {-# INLINE gpkDecode #-}+ gpkDecode (Sum' x)= case x of+ Left l -> L1 (gpkDecode @s l)+ Right r -> R1 (gpkDecode @s r)++instance GPopKeyEncoding s f => GPopKeyEncoding s (M1 i t f) where+ type GShape (M1 i t f) = GShape f+ {-# INLINE gshape #-}+ gshape = gshape @s @f+ {-# INLINE gpkEncode #-}+ gpkEncode (M1 x) = gpkEncode @s x+ {-# INLINE gpkDecode #-}+ gpkDecode = M1 . gpkDecode @s++---------------+-- INSTANCES --+---------------++instance S.Store a => PopKeyEncoding (StoreBlob a) where+ type Shape (StoreBlob a) = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode . unStoreBlob+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = StoreBlob do S.decodeEx x++instance PopKeyEncoding BS.ByteString where+ type Shape BS.ByteString = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single'+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = x++instance PopKeyEncoding LBS.ByteString where+ type Shape LBS.ByteString = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . LBS.toStrict+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = LBS.fromStrict x++instance S.Store a => PopKeyEncoding [ a ] where+ type Shape [ a ] = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = case S.size @a of+ S.ConstSize _ -> Single' . BS.concat . fmap S.encode+ _ -> Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode = \(Single' r) -> case S.size @a of+ S.ConstSize k -> S.decodeEx <$> chunks k r+ _ -> S.decodeEx r+ where+ chunks :: Int -> BS.ByteString -> [ BS.ByteString ]+ chunks i b+ | BS.length b == 0 = []+ | otherwise = let (x , xs) = BS.splitAt i b in x : chunks i xs++-- override text store instance since it uses Haskell's bloaded UTF16 encoding, which in this+-- context would be a terrible choice.+instance PopKeyEncoding T.Text where+ type Shape T.Text = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . T.encodeUtf8+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = T.decodeUtf8 x++instance PopKeyEncoding LT.Text where+ type Shape LT.Text = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . LBS.toStrict . LT.encodeUtf8+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = LT.decodeUtf8 (LBS.fromStrict x)++instance PopKeyEncoding Char where+ type Shape Char = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Double where+ type Shape Double = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Float where+ type Shape Float = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Int8 where+ type Shape Int8 = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Int16 where+ type Shape Int16 = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Int32 where+ type Shape Int32 = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Int64 where+ type Shape Int64 = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Int where+ type Shape Int = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Word8 where+ type Shape Word8 = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Word16 where+ type Shape Word16 = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Word32 where+ type Shape Word32 = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Word64 where+ type Shape Word64 = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Word where+ type Shape Word = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Integer where+ type Shape Integer = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Natural where+ type Shape Natural = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode . toInteger+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = fromInteger do S.decodeEx x++instance PopKeyEncoding Rational where+ type Shape Rational = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance S.Store a => PopKeyEncoding (Ratio a) where+ type Shape (Ratio a) = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding Graph where+ type Shape Graph = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance S.Store a => PopKeyEncoding (IntMap a) where+ type Shape (IntMap a) = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance PopKeyEncoding IntSet where+ type Shape IntSet = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x++instance (Ord a , S.Store a , S.Store b) => PopKeyEncoding (Map a b) where+ type Shape (Map a b) = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x ++instance S.Store a => PopKeyEncoding (Seq a) where+ type Shape (Seq a) = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x ++instance (Ord a , S.Store a) => PopKeyEncoding (Set a) where+ type Shape (Set a) = ()+ {-# INLINE shape #-}+ shape = ISingle+ {-# INLINE pkEncode #-}+ pkEncode = Single' . S.encode+ {-# INLINE pkDecode #-}+ pkDecode (Single' x) = S.decodeEx x ++instance PopKeyEncoding ()+instance PopKeyEncoding (Proxy a)+instance PopKeyEncoding Bool+instance PopKeyEncoding a => PopKeyEncoding (Maybe a)+instance PopKeyEncoding a => PopKeyEncoding (Min a)+instance PopKeyEncoding a => PopKeyEncoding (Max a)+instance PopKeyEncoding a => PopKeyEncoding (First a)+instance PopKeyEncoding a => PopKeyEncoding (Last a)+instance PopKeyEncoding a => PopKeyEncoding (Option a)+instance PopKeyEncoding a => PopKeyEncoding (Identity a)+instance PopKeyEncoding a => PopKeyEncoding (Sum a)+instance PopKeyEncoding a => PopKeyEncoding (Product a)+instance PopKeyEncoding a => PopKeyEncoding (Const a b)++instance (PopKeyEncoding a , PopKeyEncoding b) => PopKeyEncoding (Arg a b)+instance (PopKeyEncoding a , PopKeyEncoding b) => PopKeyEncoding (Either a b)++instance (PopKeyEncoding a , PopKeyEncoding b) => PopKeyEncoding (a , b)+instance (PopKeyEncoding a , PopKeyEncoding b , PopKeyEncoding c) => PopKeyEncoding (a , b , c)+instance (PopKeyEncoding a , PopKeyEncoding b , PopKeyEncoding c , PopKeyEncoding d) => PopKeyEncoding (a , b , c , d)+instance (PopKeyEncoding a , PopKeyEncoding b , PopKeyEncoding c , PopKeyEncoding d , PopKeyEncoding e) => PopKeyEncoding (a , b , c , d , e)++
+ src/PopKey/Internal1.hs view
@@ -0,0 +1,94 @@+{-# OPTIONS_HADDOCK hide #-}++module PopKey.Internal1 where++import Control.Monad.ST+import Data.Bit as B+import qualified Data.ByteString as BS+import Data.Foldable+import Data.STRef+import qualified Data.Vector.Storable as SV+import qualified Data.Vector.Unboxed as UV+import qualified Data.Vector.Unboxed.Mutable as MUV+import GHC.Generics (Generic)+import GHC.Word+import HaskellWorks.Data.Bits.PopCount.PopCount1+import qualified HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Data.RankSelect.CsPoppy+import Unsafe.Coerce+++data PKPrim =+ ConstSize !BS.ByteString {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 -- raw / item size / item count+ | Var !CsPoppy !BS.ByteString {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 -- poppy / raw / min size / step size+ deriving (Generic,Eq)+++-- 0-based indexing, for my sanity+{-# INLINE select1' #-}+select1' :: CsPoppy -> Int -> Int+select1' p i =+ fromIntegral (HaskellWorks.Data.RankSelect.Base.Select1.select1 p (fromIntegral i + 1)) - 1++{-# INLINABLE pkLength #-}+pkLength :: PKPrim -> Int+pkLength (ConstSize _ _ l) = fromIntegral l+pkLength (Var p _ _ _) = (fromIntegral . (\x -> x - 1) . popCount1) p++{-# INLINABLE pkIndex #-}+pkIndex :: PKPrim -> Int -> BS.ByteString+pkIndex (ConstSize r (fromIntegral -> s) _) i = if s == 0 then mempty else BS.take s (BS.drop (i * s) r)+pkIndex (Var p r (fromIntegral -> minSize) (fromIntegral -> step)) i = do+ let o :: Int = select1' p i+ d :: Int = select1' p (i + 1) - o++ BS.take (minSize + step * (d - 1)) (BS.drop (step * (o - i) + i * minSize) r)++makePK :: [ BS.ByteString ] -> PKPrim+makePK [] = ConstSize mempty 0 0+makePK bs = runST do+ let minSize = minimum (BS.length <$> bs)+ step = foldl' (\a x -> gcd (BS.length x - minSize) a) (BS.length (head bs) - minSize) bs++ if all ((minSize==) . BS.length) bs+ then pure do ConstSize (BS.concat bs) (fromIntegral minSize) (fromIntegral do length bs)+ else do+ -- raw indexing vector+ bv :: UV.Vector Bit <- do+ v <- MUV.new do 1 + foldl' (\a x -> a + 1 + (BS.length x - minSize) `div` step) 0 bs+ MUV.unsafeWrite v 0 1++ base_ref <- newSTRef 0++ for_ bs \x -> do+ let d = ((BS.length x - minSize) `div` step) + 1+ b <- readSTRef base_ref+ MUV.unsafeWrite v (b + d) 1+ writeSTRef base_ref (b + d)++ UV.unsafeFreeze v++ let uv64 :: UV.Vector Word64 = unsafeCoerce do cloneToWords bv+ sv64 :: SV.Vector Word64 = SV.convert uv64++ ppy :: CsPoppy = makeCsPoppy sv64++ pure $ Var ppy (BS.concat bs) (fromIntegral minSize) (fromIntegral step)++-- returns @-1@ if not found+{-# INLINABLE bin_search #-}+bin_search :: PKPrim -> BS.ByteString -> Int -> Int -> Int+bin_search vs q = go+ where+ go :: Int -> Int -> Int+ go l r+ | r >= l = do+ let m = l + (r - l) `div` 2+ p = pkIndex vs m+ if p > q+ then go l (m - 1)+ else if p == q+ then m+ else go (m + 1) r+ | otherwise = -1+
+ src/PopKey/Internal2.hs view
@@ -0,0 +1,146 @@+{-# OPTIONS_HADDOCK hide #-}++module PopKey.Internal2 where++import Control.Monad.ST+import Data.Bit as B+import qualified Data.ByteString as BS+import Data.Either+import Data.Foldable+import HaskellWorks.Data.RankSelect.CsPoppy+import qualified Data.Vector.Storable as SV+import qualified Data.Vector.Unboxed as UV+import qualified Data.Vector.Unboxed.Mutable as MUV+import GHC.Word+import HaskellWorks.Data.Bits.BitWise ((.?.))+import HaskellWorks.Data.RankSelect.Base.Rank0+import HaskellWorks.Data.RankSelect.Base.Rank1+import Unsafe.Coerce++import PopKey.Internal1+++data F s a where+ Single :: !a -> F () a+ Prod :: !(F s1 a) -> !(F s2 a) -> F (s1 , s2) a+ Sum :: {-# UNPACK #-} !Word32 -> CsPoppy -> !(F s1 a) -> !(F s2 a) -> F (Either s1 s2) a+ -- cardinality / poppy ; poppy undefined if cardinality = 0+ -- 0 indicates storage in the left / 1 indicates storage in the right++data F' s a where+ Single' :: a -> F' () a+ Prod' :: (F' s1 a) -> (F' s2 a) -> F' (s1 , s2) a+ Sum' :: (Either (F' s1 a) (F' s2 a)) -> F' (Either s1 s2) a++instance Eq a => Eq (F' s a) where+ {-# INLINEABLE (==) #-}+ (==) (Single' x) (Single' y) = x == y+ (==) (Prod' x1 y1) (Prod' x2 y2) = (x1 == x2) && (y1 == y2)+ (==) (Sum' s1) (Sum' s2) = s1 == s2++instance Ord a => Ord (F' s a) where+ {-# INLINABLE (<=) #-}+ (<=) (Single' x) (Single' y) = x <= y+ (<=) (Prod' x1 y1) (Prod' x2 y2) = (x1 , y1) <= (x2 , y2)+ (<=) (Sum' s1) (Sum' s2) = s1 <= s2++flength :: F s PKPrim -> Int+flength (Single a) = pkLength a+flength (Prod x _) = flength x+flength (Sum l _ _ _) = fromIntegral l++data I s where+ ISingle :: I ()+ IProd :: I s1 -> I s2 -> I (s1 , s2)+ ISum :: I s1 -> I s2 -> I (Either s1 s2)++-- index must be valid+rawq :: Int -> F s PKPrim -> F' s BS.ByteString+rawq i = go+ where+ go :: F s PKPrim -> F' s BS.ByteString+ go (Single pk) = Single' (pkIndex pk i)+ go (Prod x y) = Prod' (go x) (go y)+ go (Sum _ pk l r) = do+ let b1pos = fromIntegral i + 1+ if pk .?. b1pos+ then Sum' (Right (rawq (fromIntegral (rank1 pk (fromIntegral b1pos) - 1)) r))+ else Sum' (Left (rawq (fromIntegral (rank0 pk (fromIntegral b1pos) - 1)) l))++-- returns @-1@ if not found+{-# INLINABLE bin_search2 #-}+bin_search2 :: F s PKPrim -> F' s BS.ByteString -> Int -> Int -> Int+bin_search2 vs q = go+ where+ go :: Int -> Int -> Int+ go l r+ | r >= l = do+ let m = l + (r - l) `div` 2+ p = rawq m vs+ if p > q+ then go l (m - 1)+ else if p == q+ then m+ else go (m + 1) r+ | otherwise = -1++{-# INLINE query #-}+query :: forall a s . (F' s BS.ByteString -> a) -> F s PKPrim -> Int -> a+query d pk i = d (rawq i pk)++{-# INLINABLE construct #-}+construct :: forall a s f . Foldable f+ => I s+ -> (a -> F' s BS.ByteString) + -> f a+ -> F s PKPrim+construct = \s e f -> if length f == 0+ then fancyZero s+ else go s (foldr ((:) . e) mempty f)+ where+ fancyZero :: forall t . I t -> F t PKPrim+ fancyZero ISingle = Single (ConstSize mempty 0 0)+ fancyZero (IProd x y) = Prod (fancyZero x) (fancyZero y)+ fancyZero (ISum x y) = Sum 0 undefined (fancyZero x) (fancyZero y)++ go :: forall t . I t -> [ F' t BS.ByteString ] -> F t PKPrim+ go ISingle = \ys -> Single (makePK (fromSingle <$> ys))+ where+ fromSingle :: F' () BS.ByteString -> BS.ByteString+ fromSingle (Single' x) = x+ go (IProd s1 s2) = \ys -> do+ let (as , bs) = unzip (fromProd <$> ys)+ Prod (go s1 as) (go s2 bs)+ where+ fromProd :: forall s1 s2 . F' (s1 , s2) BS.ByteString+ -> (F' s1 BS.ByteString , F' s2 BS.ByteString)+ fromProd (Prod' x y) = (x , y)+ go (ISum s1 s2) = \ys -> do+ let zs = fromSum <$> ys+ l = length ys++ bv :: UV.Vector Bit = runST do+ v <- MUV.new l++ for_ (zip [ 0 .. ] zs) \(i,x) -> case x of+ Left _ -> pure ()+ Right _ -> MUV.unsafeWrite v i 1++ UV.unsafeFreeze v++ uv64 :: UV.Vector Word64 = unsafeCoerce do cloneToWords bv+ sv64 :: SV.Vector Word64 = SV.convert uv64++ !(ppy :: CsPoppy) = makeCsPoppy sv64++ (as , bs) = partitionEithers zs+ + Sum (fromIntegral l) ppy (f s1 as) (f s2 bs)+ where+ f s [] = fancyZero s+ f s xs = go s xs+ + fromSum :: forall s1 s2 . F' (Either s1 s2) BS.ByteString+ -> Either (F' s1 BS.ByteString) (F' s2 BS.ByteString)+ fromSum (Sum' x) = x+
+ src/PopKey/Internal3.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++{-# OPTIONS_HADDOCK hide #-}++module PopKey.Internal3 where++import qualified Data.ByteString as BS+import HaskellWorks.Data.RankSelect.CsPoppy+import qualified HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha0 as A0+import qualified HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha1 as A1+import Data.Profunctor+import Data.Store (encode , decodeEx)+import GHC.Generics hiding (R)+import GHC.Word+import Unsafe.Coerce++import PopKey.Internal1+import PopKey.Internal2+import PopKey.Encoding+++data PopKey k v =+ forall s . PopKeyInt !(F s PKPrim) (F' s BS.ByteString -> v) (k -> Int)+ | forall s1 s2 . PopKeyAny !(F s1 PKPrim) (F' s1 BS.ByteString -> v) (k -> F' s2 BS.ByteString) !(F s2 PKPrim)++instance Functor (PopKey k) where+ {-# INLINE fmap #-}+ fmap f (PopKeyInt p d e) = PopKeyInt p (f . d) e+ fmap f (PopKeyAny pv d e pk) = PopKeyAny pv (f . d) e pk++instance Profunctor PopKey where+ {-# INLINE dimap #-}+ dimap f g (PopKeyInt p d e) = PopKeyInt p (g . d) (e . f)+ dimap f g (PopKeyAny pv d e pk) = PopKeyAny pv (g . d) (e . f) pk++instance Foldable (PopKey k) where+ {-# INLINE foldr #-}+ foldr f z p@(PopKeyInt pr vd _) = foldr (\i -> f (vd do rawq i pr)) z [ 0 .. (length p - 1) ]+ foldr f z p@(PopKeyAny pr vd _ _) = foldr (\i -> f (vd do rawq i pr)) z [ 0 .. (length p - 1) ]++ {-# INLINE length #-}+ length (PopKeyInt p _ _) = flength p+ length (PopKeyAny _ _ _ p) = flength p++-------------------------------------------+-- PopKey serialization for mmap loading --+-------------------------------------------++class BiSerialize a where+ bencode :: a -> (BS.ByteString , BS.ByteString)+ default bencode :: (Generic a , GBiSerialize a (Rep a)) => a -> (BS.ByteString , BS.ByteString)+ bencode = gbencode @a @(Rep a) . from+ + bdecode :: (BS.ByteString , BS.ByteString) -> a+ default bdecode :: (Generic a , GBiSerialize a (Rep a)) => (BS.ByteString , BS.ByteString) -> a+ bdecode = to . gbdecode @a @(Rep a)++class GBiSerialize s f where+ gbencode :: f a -> (BS.ByteString , BS.ByteString)+ gbdecode :: (BS.ByteString , BS.ByteString) -> f a++instance GBiSerialize s U1 where+ {-# INLINE gbencode #-}+ gbencode = const mempty+ {-# INLINE gbdecode #-}+ gbdecode = const mempty++instance BiSerialize a => GBiSerialize s (K1 i a) where+ {-# INLINE gbencode #-}+ gbencode (K1 x) = bencode x+ {-# INLINE gbdecode #-}+ gbdecode = K1 . bdecode++instance (GBiSerialize s a , GBiSerialize s b) => GBiSerialize s (a :*: b) where+ {-# INLINE gbencode #-}+ gbencode (a :*: b) = do+ let (a1 , a2) = gbencode @s a+ (b1 , b2) = gbencode @s b+ (encode (a1 , b1) , encode (a2 , b2))+ {-# INLINE gbdecode #-}+ gbdecode (r1 , r2) = do+ let (a1 , b1) = decodeEx r1+ (a2 , b2) = decodeEx r2+ gbdecode @s (a1 , a2) :*: gbdecode @s (b1 , b2)++instance (GBiSerialize s a , GBiSerialize s b) => GBiSerialize s (a :+: b) where+ gbencode (L1 x) = do+ let (b1 , b2) = gbencode @s x+ (encode False <> b1 , b2)+ gbencode (R1 x) = do+ let (b1 , b2) = gbencode @s x+ (encode True <> b1 , b2)+ gbdecode ((BS.splitAt 1 -> (b , b1)) , b2) =+ if decodeEx b+ then R1 (gbdecode @s (b1 , b2))+ else L1 (gbdecode @s (b1 , b2))++instance GBiSerialize s f => GBiSerialize s (M1 i t f) where+ {-# INLINE gbencode #-}+ gbencode (M1 x) = gbencode @s x+ {-# INLINE gbdecode #-}+ gbdecode = M1 . gbdecode @s++instance BiSerialize CsPoppy where+ bencode (CsPoppy bv (A0.CsPoppyIndex a01 a02) (A1.CsPoppyIndex a11 a12)) =+ (,) do encode (a01 , a02 , a11 , a12)+ do encode bv+ bdecode (bs , bv) = do+ let (a01 , a02 , a11 , a12) = decodeEx bs+ CsPoppy (decodeEx bv) (A0.CsPoppyIndex a01 a02) (A1.CsPoppyIndex a11 a12)++-- newtype L a = L a deriving (Generic)+-- newtype R a = R a deriving (Generic)++-- instance Store a => BiSerialize (L a) where+-- {-# INLINE bencode #-}+-- bencode (L x) = (encode x , mempty)+-- {-# INLINE bdecode #-}+-- bdecode (b , _) = L do decodeEx b++-- instance Store a => BiSerialize (R a) where+-- {-# INLINE bencode #-}+-- bencode (R x) = (mempty , encode x)+-- {-# INLINE bdecode #-}+-- bdecode (_ , b) = R do decodeEx b++instance BiSerialize BS.ByteString where+ {-# INLINE bencode #-}+ bencode x = (mempty , x)+ {-# INLINE bdecode #-}+ bdecode (_ , x) = x++instance BiSerialize Word32 where+ {-# INLINE bencode #-}+ bencode x = (encode x , mempty)+ {-# INLINE bdecode #-}+ bdecode (x , _) = decodeEx x++instance BiSerialize PKPrim+instance BiSerialize a => BiSerialize (Maybe a)+instance (BiSerialize a , BiSerialize b) => BiSerialize (a , b)++-- poppy is undefined here if the first value is 0+data Custom = Custom {-# UNPACK #-} !Word32 CsPoppy++instance BiSerialize Custom where+ bencode (Custom l ppy) = do+ let x :: Maybe (Word32 , CsPoppy) =+ if l == 0+ then Nothing+ else Just (l , ppy)+ bencode x+ bdecode r = case bdecode r of+ Nothing -> Custom 0 undefined+ Just (l , ppy) -> Custom l ppy++-- serializable format for F+data SF a =+ SSingle a+ | SProd !(SF a) !(SF a)+ | SSum !Custom !(SF a) !(SF a)+ deriving (Generic,BiSerialize)++fromF :: F s a -> SF a+fromF (Single x) = SSingle x+fromF (Prod x y) = SProd (fromF x) (fromF y)+fromF (Sum l ppy x y) = SSum (Custom l ppy) (fromF x) (fromF y)++-- there's a reason this module is internal+toF :: SF a -> F s a+toF (SSingle x) = unsafeCoerce do Single x+toF (SProd x y) = unsafeCoerce do Prod (toF x) (toF y)+toF (SSum (Custom l ppy) x y) = unsafeCoerce do Sum l ppy (toF x) (toF y)++data SPopKey k v =+ SPopKeyInt !(SF PKPrim)+ | SPopKeyAny !(SF PKPrim) !(SF PKPrim)+ deriving (Generic,BiSerialize)++toSPopKey :: PopKey k v -> SPopKey k v+toSPopKey (PopKeyInt p _ _) = SPopKeyInt (fromF p)+toSPopKey (PopKeyAny p1 _ _ p2) = SPopKeyAny (fromF p1) (fromF p2)++fromSPopKey :: forall k v . (PopKeyEncoding k , PopKeyEncoding v) => SPopKey k v -> PopKey k v+fromSPopKey (SPopKeyInt p) = PopKeyInt (toF p) (pkDecode @v) (unsafeCoerce id)+fromSPopKey (SPopKeyAny pv pk) = PopKeyAny (toF pv) (pkDecode @v) (pkEncode @k) (toF pk)++fromSPopKey' :: PopKeyEncoding v => SPopKey Int v -> PopKey Int v+fromSPopKey' (SPopKeyInt p) = PopKeyInt (toF p) pkDecode (unsafeCoerce id)+fromSPopKey' _ = error "Incorrect PopKey type: expected Int."++data PopKeyStore k v =+ PopKeyStore (forall f . Foldable f => f (k , v) -> IO ())+ (IO (PopKey k v))++data PopKeyStore' v =+ PopKeyStore' (forall f . Foldable f => f v -> IO ())+ (IO (PopKey Int v))++class StorePopKey k v f | f -> k , f -> v where+ type Input f+ storePopKey :: Foldable t => f -> t (Input f) -> IO ()+ loadPopKey :: f -> IO (PopKey k v)++instance StorePopKey k v (PopKeyStore k v) where+ type Input (PopKeyStore k v) = (k , v)+ storePopKey (PopKeyStore a _) = a+ loadPopKey (PopKeyStore _ b) = b++instance StorePopKey Int v (PopKeyStore' v) where+ type Input (PopKeyStore' v) = v+ storePopKey (PopKeyStore' a _) = a+ loadPopKey (PopKeyStore' _ b) = b+
+ test/Spec.hs view
@@ -0,0 +1,32 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++import Data.Foldable+import qualified Data.Map as M+import GHC.Word+import Test.Hspec+import Test.QuickCheck++import PopKey+++main :: IO ()+main = hspec $ do+ describe "PopKey" $ do+ it "sanity checks for fixed-size data" $ property \(xs :: [ Int ]) ->+ toList (makePopKey' xs) == xs++ it "sanity checks for fixed-size data" $ property \(xs :: [ (Int , Word8) ]) ->+ toList (makePopKey' xs) == xs++ it "sanity checks for var-size data" $ property \(xs :: [ [ Int ] ]) ->+ toList (makePopKey' xs) == xs++ it "sanity checks for var-size data" $ property \(xs :: [ String ]) ->+ toList (makePopKey' xs) == xs++ it "sanity checks for key data" $ property \(xs :: [ (Int , Word8) ]) -> do+ let m = M.fromList xs+ pk = makePopKey xs+ ks = fst <$> xs+ all (\k -> m M.! k == pk ! k) ks+