{-# LANGUAGE AllowAmbiguousTypes #-}

{-# OPTIONS_HADDOCK hide #-}

module PopKey.Internal3 where

import Data.Bifunctor
import qualified Data.ByteString as BS
import Data.Functor.Contravariant
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.Foldable
import Data.List (sortOn)
import Data.Store
import GHC.Generics hiding (R)
import GHC.Word
import Unsafe.Coerce

import PopKey.Internal1
import PopKey.Internal2
import PopKey.Encoding


-- Bool here is whether the decoding function is the canonical decoding function from when
-- the index was first built. it allows the Store instance to skip re-building the structure
-- before serialization. the Functor instance should still be observably-valid from the safe public API,
-- at least modulo bottoms and the fact that mapping the identity will cause performance artefacts.
data PopKey k v where
  PopKeyInt :: forall s v . Bool -> !(F s PKPrim) -> (F' s BS.ByteString -> v) -> PopKey Int v
  PopKeyAny :: forall s k v . Bool -> !(F s PKPrim) -> (F' s BS.ByteString -> v) -> !(F (Shape k) PKPrim) -> PopKey k v

instance Functor (PopKey k) where
  {-# INLINE fmap #-}
  fmap :: forall a b. (a -> b) -> PopKey k a -> PopKey k b
fmap a -> b
f (PopKeyInt Bool
_ F s PKPrim
p F' s ByteString -> a
d) = forall s1 v.
Bool -> F s1 PKPrim -> (F' s1 ByteString -> v) -> PopKey Int v
PopKeyInt Bool
False F s PKPrim
p (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. F' s ByteString -> a
d)
  fmap a -> b
f (PopKeyAny Bool
_ F s PKPrim
pv F' s ByteString -> a
d F (Shape k) PKPrim
pk) = forall s1 k v.
Bool
-> F s1 PKPrim
-> (F' s1 ByteString -> v)
-> F (Shape k) PKPrim
-> PopKey k v
PopKeyAny Bool
False F s PKPrim
pv (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. F' s ByteString -> a
d) F (Shape k) PKPrim
pk

instance Foldable (PopKey k) where
  {-# INLINE foldr #-}
  foldr :: forall a b. (a -> b -> b) -> b -> PopKey k a -> b
foldr a -> b -> b
f b
z p :: PopKey k a
p@(PopKeyInt Bool
_ F s PKPrim
pr F' s ByteString -> a
vd) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Int
i -> a -> b -> b
f (F' s ByteString -> a
vd do forall s. Int -> F s PKPrim -> F' s ByteString
rawq Int
i F s PKPrim
pr)) b
z [ Int
0 .. (forall (t :: * -> *) a. Foldable t => t a -> Int
length PopKey k a
p forall a. Num a => a -> a -> a
- Int
1) ]
  foldr a -> b -> b
f b
z p :: PopKey k a
p@(PopKeyAny Bool
_ F s PKPrim
pr F' s ByteString -> a
vd F (Shape k) PKPrim
_) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Int
i -> a -> b -> b
f (F' s ByteString -> a
vd do forall s. Int -> F s PKPrim -> F' s ByteString
rawq Int
i F s PKPrim
pr)) b
z [ Int
0 .. (forall (t :: * -> *) a. Foldable t => t a -> Int
length PopKey k a
p forall a. Num a => a -> a -> a
- Int
1) ]

  {-# INLINE length #-}
  length :: forall a. PopKey k a -> Int
length (PopKeyInt Bool
_ F s PKPrim
p F' s ByteString -> a
_) = forall s. F s PKPrim -> Int
flength F s PKPrim
p
  length (PopKeyAny Bool
_ F s PKPrim
_ F' s ByteString -> a
_ F (Shape k) PKPrim
p) = forall s. F s PKPrim -> Int
flength F (Shape k) PKPrim
p

{-# INLINABLE foldrWithKey #-}
foldrWithKey :: PopKeyEncoding k => (k -> v -> b -> b) -> b -> PopKey k v -> b
foldrWithKey :: forall k v b.
PopKeyEncoding k =>
(k -> v -> b -> b) -> b -> PopKey k v -> b
foldrWithKey k -> v -> b -> b
f b
z p :: PopKey k v
p@(PopKeyInt Bool
_ F s PKPrim
pr F' s ByteString -> v
vd) =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr do \k
i -> k -> v -> b -> b
f k
i (F' s ByteString -> v
vd do forall s. Int -> F s PKPrim -> F' s ByteString
rawq k
i F s PKPrim
pr)
        do b
z
        do [ k
0 .. (forall (t :: * -> *) a. Foldable t => t a -> Int
length PopKey k v
p forall a. Num a => a -> a -> a
- k
1) ]
foldrWithKey k -> v -> b -> b
f b
z p :: PopKey k v
p@(PopKeyAny Bool
_ F s PKPrim
pr F' s ByteString -> v
vd F (Shape k) PKPrim
pk) =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr do \Int
i -> k -> v -> b -> b
f (forall a. PopKeyEncoding a => F' (Shape a) ByteString -> a
pkDecode forall a b. (a -> b) -> a -> b
$ forall s. Int -> F s PKPrim -> F' s ByteString
rawq Int
i F (Shape k) PKPrim
pk) (F' s ByteString -> v
vd do forall s. Int -> F s PKPrim -> F' s ByteString
rawq Int
i F s PKPrim
pr)
        do b
z
        do [ Int
0 .. (forall (t :: * -> *) a. Foldable t => t a -> Int
length PopKey k v
p forall a. Num a => a -> a -> a
- Int
1) ]

{-# INLINABLE foldlWithKey' #-}
foldlWithKey' :: PopKeyEncoding k => (a -> k -> v -> a) -> a -> PopKey k v -> a
foldlWithKey' :: forall k a v.
PopKeyEncoding k =>
(a -> k -> v -> a) -> a -> PopKey k v -> a
foldlWithKey' a -> k -> v -> a
f a
z p :: PopKey k v
p@(PopKeyInt Bool
_ F s PKPrim
pr F' s ByteString -> v
vd) =
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' do \a
a k
i -> a -> k -> v -> a
f a
a k
i (F' s ByteString -> v
vd do forall s. Int -> F s PKPrim -> F' s ByteString
rawq k
i F s PKPrim
pr)
         do a
z
         do [ k
0 .. (forall (t :: * -> *) a. Foldable t => t a -> Int
length PopKey k v
p forall a. Num a => a -> a -> a
- k
1) ]
foldlWithKey' a -> k -> v -> a
f a
z p :: PopKey k v
p@(PopKeyAny Bool
_ F s PKPrim
pr F' s ByteString -> v
vd F (Shape k) PKPrim
pk) =
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' do \a
a Int
i -> a -> k -> v -> a
f a
a (forall a. PopKeyEncoding a => F' (Shape a) ByteString -> a
pkDecode forall a b. (a -> b) -> a -> b
$ forall s. Int -> F s PKPrim -> F' s ByteString
rawq Int
i F (Shape k) PKPrim
pk) (F' s ByteString -> v
vd do forall s. Int -> F s PKPrim -> F' s ByteString
rawq Int
i F s PKPrim
pr)
         do a
z
         do [ Int
0 .. (forall (t :: * -> *) a. Foldable t => t a -> Int
length PopKey k v
p forall a. Num a => a -> a -> a
- Int
1) ]  

-------------------------------------------
-- 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 = forall s (f :: * -> *) a.
GBiSerialize s f =>
f a -> (ByteString, ByteString)
gbencode @a @(Rep a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from
  
  bdecode :: (BS.ByteString , BS.ByteString) -> a
  default bdecode :: (Generic a , GBiSerialize a (Rep a)) => (BS.ByteString , BS.ByteString) -> a
  bdecode = forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (f :: * -> *) a.
GBiSerialize s f =>
(ByteString, ByteString) -> f a
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 :: forall a. U1 a -> (ByteString, ByteString)
gbencode = forall a b. a -> b -> a
const forall a. Monoid a => a
mempty
  {-# INLINE gbdecode #-}
  gbdecode :: forall a. (ByteString, ByteString) -> U1 a
gbdecode = forall a b. a -> b -> a
const forall a. Monoid a => a
mempty

instance BiSerialize a => GBiSerialize s (K1 i a) where
  {-# INLINE gbencode #-}
  gbencode :: forall a. K1 i a a -> (ByteString, ByteString)
gbencode (K1 a
x) = forall a. BiSerialize a => a -> (ByteString, ByteString)
bencode a
x
  {-# INLINE gbdecode #-}
  gbdecode :: forall a. (ByteString, ByteString) -> K1 i a a
gbdecode = forall k i c (p :: k). c -> K1 i c p
K1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. BiSerialize a => (ByteString, ByteString) -> a
bdecode

instance (GBiSerialize s a , GBiSerialize s b) => GBiSerialize s (a :*: b) where
  {-# INLINE gbencode #-}
  gbencode :: forall a. (:*:) a b a -> (ByteString, ByteString)
gbencode (a a
a :*: b a
b) = do
    let (ByteString
a1 , ByteString
a2) = forall s (f :: * -> *) a.
GBiSerialize s f =>
f a -> (ByteString, ByteString)
gbencode @s a a
a
        (ByteString
b1 , ByteString
b2) = forall s (f :: * -> *) a.
GBiSerialize s f =>
f a -> (ByteString, ByteString)
gbencode @s b a
b
    (forall a. Store a => a -> ByteString
encode (ByteString
a1 , ByteString
b1) , forall a. Store a => a -> ByteString
encode (ByteString
a2 , ByteString
b2))
  {-# INLINE gbdecode #-}
  gbdecode :: forall a. (ByteString, ByteString) -> (:*:) a b a
gbdecode (ByteString
r1 , ByteString
r2) = do
    let (ByteString
a1 , ByteString
b1) = forall a. Store a => ByteString -> a
decodeEx ByteString
r1
        (ByteString
a2 , ByteString
b2) = forall a. Store a => ByteString -> a
decodeEx ByteString
r2
    forall s (f :: * -> *) a.
GBiSerialize s f =>
(ByteString, ByteString) -> f a
gbdecode @s (ByteString
a1 , ByteString
a2) forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall s (f :: * -> *) a.
GBiSerialize s f =>
(ByteString, ByteString) -> f a
gbdecode @s (ByteString
b1 , ByteString
b2)

instance (GBiSerialize s a , GBiSerialize s b) => GBiSerialize s (a :+: b) where
  gbencode :: forall a. (:+:) a b a -> (ByteString, ByteString)
gbencode (L1 a a
x) = do
    let (ByteString
b1 , ByteString
b2) = forall s (f :: * -> *) a.
GBiSerialize s f =>
f a -> (ByteString, ByteString)
gbencode @s a a
x
    (forall a. Store a => a -> ByteString
encode Bool
False forall a. Semigroup a => a -> a -> a
<> ByteString
b1 , ByteString
b2)
  gbencode (R1 b a
x) = do
    let (ByteString
b1 , ByteString
b2) = forall s (f :: * -> *) a.
GBiSerialize s f =>
f a -> (ByteString, ByteString)
gbencode @s b a
x
    (forall a. Store a => a -> ByteString
encode Bool
True forall a. Semigroup a => a -> a -> a
<> ByteString
b1 , ByteString
b2)
  gbdecode :: forall a. (ByteString, ByteString) -> (:+:) a b a
gbdecode ((Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
1 -> (ByteString
b , ByteString
b1)) , ByteString
b2) =
    if forall a. Store a => ByteString -> a
decodeEx ByteString
b
       then forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (forall s (f :: * -> *) a.
GBiSerialize s f =>
(ByteString, ByteString) -> f a
gbdecode @s (ByteString
b1 , ByteString
b2))
       else forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (forall s (f :: * -> *) a.
GBiSerialize s f =>
(ByteString, ByteString) -> f a
gbdecode @s (ByteString
b1 , ByteString
b2))

instance GBiSerialize s f => GBiSerialize s (M1 i t f) where
  {-# INLINE gbencode #-}
  gbencode :: forall a. M1 i t f a -> (ByteString, ByteString)
gbencode (M1 f a
x) = forall s (f :: * -> *) a.
GBiSerialize s f =>
f a -> (ByteString, ByteString)
gbencode @s f a
x
  {-# INLINE gbdecode #-}
  gbdecode :: forall a. (ByteString, ByteString) -> M1 i t f a
gbdecode = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (f :: * -> *) a.
GBiSerialize s f =>
(ByteString, ByteString) -> f a
gbdecode @s

instance BiSerialize CsPoppy where
  bencode :: CsPoppy -> (ByteString, ByteString)
bencode (CsPoppy Vector Word64
bv (A0.CsPoppyIndex Vector Word64
a01 Vector Word64
a02) (A1.CsPoppyIndex Vector Word64
a11 Vector Word64
a12)) =
    (,) do forall a. Store a => a -> ByteString
encode (Vector Word64
a01 , Vector Word64
a02 , Vector Word64
a11 , Vector Word64
a12)
        do forall a. Store a => a -> ByteString
encode Vector Word64
bv
  bdecode :: (ByteString, ByteString) -> CsPoppy
bdecode (ByteString
bs , ByteString
bv) = do
    let (Vector Word64
a01 , Vector Word64
a02 , Vector Word64
a11 , Vector Word64
a12) = forall a. Store a => ByteString -> a
decodeEx ByteString
bs
    Vector Word64 -> CsPoppyIndex -> CsPoppyIndex -> CsPoppy
CsPoppy (forall a. Store a => ByteString -> a
decodeEx ByteString
bv) (Vector Word64 -> Vector Word64 -> CsPoppyIndex
A0.CsPoppyIndex Vector Word64
a01 Vector Word64
a02) (Vector Word64 -> Vector Word64 -> CsPoppyIndex
A1.CsPoppyIndex Vector Word64
a11 Vector Word64
a12)

instance BiSerialize BS.ByteString where
  {-# INLINE bencode #-}
  bencode :: ByteString -> (ByteString, ByteString)
bencode ByteString
x = (forall a. Monoid a => a
mempty , ByteString
x)
  {-# INLINE bdecode #-}
  bdecode :: (ByteString, ByteString) -> ByteString
bdecode (ByteString
_ , ByteString
x) = ByteString
x

instance BiSerialize Word32 where
  {-# INLINE bencode #-}
  bencode :: Word32 -> (ByteString, ByteString)
bencode Word32
x = (forall a. Store a => a -> ByteString
encode Word32
x , forall a. Monoid a => a
mempty)
  {-# INLINE bdecode #-}
  bdecode :: (ByteString, ByteString) -> Word32
bdecode (ByteString
x , ByteString
_) = forall a. Store a => ByteString -> a
decodeEx ByteString
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 -> (ByteString, ByteString)
bencode (Custom Word32
l CsPoppy
ppy) = do
    let Maybe (Word32, CsPoppy)
x :: Maybe (Word32 , CsPoppy) =
          if Word32
l forall a. Eq a => a -> a -> Bool
== Word32
0
             then forall a. Maybe a
Nothing
             else forall a. a -> Maybe a
Just (Word32
l , CsPoppy
ppy)
    forall a. BiSerialize a => a -> (ByteString, ByteString)
bencode Maybe (Word32, CsPoppy)
x
  bdecode :: (ByteString, ByteString) -> Custom
bdecode (ByteString, ByteString)
r = case forall a. BiSerialize a => (ByteString, ByteString) -> a
bdecode (ByteString, ByteString)
r of
    Maybe (Word32, CsPoppy)
Nothing -> Word32 -> CsPoppy -> Custom
Custom Word32
0 forall a. HasCallStack => a
undefined
    Just (Word32
l , CsPoppy
ppy) -> Word32 -> CsPoppy -> Custom
Custom Word32
l CsPoppy
ppy

-- serializable format for F
data SF a =
    SSingle a
  | SProd !(SF a) !(SF a)
  | SSum !Custom !(SF a) !(SF a)
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (SF a) x -> SF a
forall a x. SF a -> Rep (SF a) x
$cto :: forall a x. Rep (SF a) x -> SF a
$cfrom :: forall a x. SF a -> Rep (SF a) x
Generic,forall a. BiSerialize a => (ByteString, ByteString) -> SF a
forall a. BiSerialize a => SF a -> (ByteString, ByteString)
forall a.
(a -> (ByteString, ByteString))
-> ((ByteString, ByteString) -> a) -> BiSerialize a
bdecode :: (ByteString, ByteString) -> SF a
$cbdecode :: forall a. BiSerialize a => (ByteString, ByteString) -> SF a
bencode :: SF a -> (ByteString, ByteString)
$cbencode :: forall a. BiSerialize a => SF a -> (ByteString, ByteString)
BiSerialize)

fromF :: F s a -> SF a
fromF :: forall s a. F s a -> SF a
fromF (Single a
x) = forall a. a -> SF a
SSingle a
x
fromF (Prod F s1 a
x F s2 a
y) = forall a. SF a -> SF a -> SF a
SProd (forall s a. F s a -> SF a
fromF F s1 a
x) (forall s a. F s a -> SF a
fromF F s2 a
y)
fromF (Sum Word32
l CsPoppy
ppy F s1 a
x F s2 a
y) = forall a. Custom -> SF a -> SF a -> SF a
SSum (Word32 -> CsPoppy -> Custom
Custom Word32
l CsPoppy
ppy) (forall s a. F s a -> SF a
fromF F s1 a
x) (forall s a. F s a -> SF a
fromF F s2 a
y)

-- there's a reason this module is internal
toF :: SF a -> F s a
toF :: forall a s. SF a -> F s a
toF (SSingle a
x) = forall a b. a -> b
unsafeCoerce do forall a. a -> F () a
Single a
x
toF (SProd SF a
x SF a
y) = forall a b. a -> b
unsafeCoerce do forall s1 a s2. F s1 a -> F s2 a -> F (s1, s2) a
Prod (forall a s. SF a -> F s a
toF SF a
x) (forall a s. SF a -> F s a
toF SF a
y)
toF (SSum (Custom Word32
l CsPoppy
ppy) SF a
x SF a
y) = forall a b. a -> b
unsafeCoerce do forall s1 a s2.
Word32 -> CsPoppy -> F s1 a -> F s2 a -> F (Either s1 s2) a
Sum Word32
l CsPoppy
ppy (forall a s. SF a -> F s a
toF SF a
x) (forall a s. SF a -> F s a
toF SF a
y)

data SPopKey k v =
    SPopKeyInt !(SF PKPrim)
  | SPopKeyAny !(SF PKPrim) !(SF PKPrim)
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k v x. Rep (SPopKey k v) x -> SPopKey k v
forall k v x. SPopKey k v -> Rep (SPopKey k v) x
$cto :: forall k v x. Rep (SPopKey k v) x -> SPopKey k v
$cfrom :: forall k v x. SPopKey k v -> Rep (SPopKey k v) x
Generic,forall a.
(a -> (ByteString, ByteString))
-> ((ByteString, ByteString) -> a) -> BiSerialize a
forall k v. (ByteString, ByteString) -> SPopKey k v
forall k v. SPopKey k v -> (ByteString, ByteString)
bdecode :: (ByteString, ByteString) -> SPopKey k v
$cbdecode :: forall k v. (ByteString, ByteString) -> SPopKey k v
bencode :: SPopKey k v -> (ByteString, ByteString)
$cbencode :: forall k v. SPopKey k v -> (ByteString, ByteString)
BiSerialize)

toSPopKey :: PopKey k v -> SPopKey k v
toSPopKey :: forall k v. PopKey k v -> SPopKey k v
toSPopKey (PopKeyInt Bool
_ F s PKPrim
p F' s ByteString -> v
_) = forall k v. SF PKPrim -> SPopKey k v
SPopKeyInt (forall s a. F s a -> SF a
fromF F s PKPrim
p)
toSPopKey (PopKeyAny Bool
_ F s PKPrim
p1 F' s ByteString -> v
_ F (Shape k) PKPrim
p2) = forall k v. SF PKPrim -> SF PKPrim -> SPopKey k v
SPopKeyAny (forall s a. F s a -> SF a
fromF F s PKPrim
p1) (forall s a. F s a -> SF a
fromF F (Shape k) PKPrim
p2)

fromSPopKey :: forall k v . (PopKeyEncoding k , PopKeyEncoding v) => SPopKey k v -> PopKey k v
fromSPopKey :: forall k v.
(PopKeyEncoding k, PopKeyEncoding v) =>
SPopKey k v -> PopKey k v
fromSPopKey (SPopKeyInt SF PKPrim
p) = forall a b. a -> b
unsafeCoerce (forall s1 v.
Bool -> F s1 PKPrim -> (F' s1 ByteString -> v) -> PopKey Int v
PopKeyInt Bool
True (forall a s. SF a -> F s a
toF SF PKPrim
p) (forall a. PopKeyEncoding a => F' (Shape a) ByteString -> a
pkDecode @v))
fromSPopKey (SPopKeyAny SF PKPrim
pv SF PKPrim
pk) = forall s1 k v.
Bool
-> F s1 PKPrim
-> (F' s1 ByteString -> v)
-> F (Shape k) PKPrim
-> PopKey k v
PopKeyAny Bool
True (forall a s. SF a -> F s a
toF SF PKPrim
pv) (forall a. PopKeyEncoding a => F' (Shape a) ByteString -> a
pkDecode @v) (forall a s. SF a -> F s a
toF SF PKPrim
pk)

fromSPopKey' :: PopKeyEncoding v => SPopKey Int v -> PopKey Int v
fromSPopKey' :: forall v. PopKeyEncoding v => SPopKey Int v -> PopKey Int v
fromSPopKey' (SPopKeyInt SF PKPrim
p) = forall s1 v.
Bool -> F s1 PKPrim -> (F' s1 ByteString -> v) -> PopKey Int v
PopKeyInt Bool
True (forall a s. SF a -> F s a
toF SF PKPrim
p) forall a. PopKeyEncoding a => F' (Shape a) ByteString -> a
pkDecode
fromSPopKey' SPopKey Int v
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Incorrect PopKey type: expected Int."

-- re-encode using whatever the current value encoding is
{-# INLINABLE normalise #-}
normalise :: (PopKeyEncoding k , PopKeyEncoding v) => PopKey k v -> PopKey k v
normalise :: forall k v.
(PopKeyEncoding k, PopKeyEncoding v) =>
PopKey k v -> PopKey k v
normalise p :: PopKey k v
p@(PopKeyInt Bool
True F s PKPrim
_ F' s ByteString -> v
_) = PopKey k v
p
normalise p :: PopKey k v
p@(PopKeyInt Bool
_ F s PKPrim
_ F' s ByteString -> v
_) =
  forall (f :: * -> *) v.
(Foldable f, PopKeyEncoding v) =>
f v -> PopKey Int v
makePopKey' (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList PopKey k v
p)
normalise p :: PopKey k v
p@(PopKeyAny Bool
True F s PKPrim
_ F' s ByteString -> v
_ F (Shape k) PKPrim
_) = PopKey k v
p
normalise p :: PopKey k v
p@(PopKeyAny Bool
_ F s PKPrim
_ F' s ByteString -> v
_ F (Shape k) PKPrim
_) =
  forall (f :: * -> *) k v.
(Foldable f, PopKeyEncoding k, PopKeyEncoding v) =>
f (k, v) -> PopKey k v
makePopKey (forall k v b.
PopKeyEncoding k =>
(k -> v -> b -> b) -> b -> PopKey k v -> b
foldrWithKey (\k
k v
v -> (:) (k
k,v
v)) [] PopKey k v
p)

toStoreEnc :: (PopKeyEncoding k , PopKeyEncoding v) => PopKey k v -> (Bool , BS.ByteString , BS.ByteString)
toStoreEnc :: forall k v.
(PopKeyEncoding k, PopKeyEncoding v) =>
PopKey k v -> (Bool, ByteString, ByteString)
toStoreEnc (forall k v.
(PopKeyEncoding k, PopKeyEncoding v) =>
PopKey k v -> PopKey k v
normalise -> PopKey k v
p) = do
  let (ByteString
b1 , ByteString
b2) = forall a. BiSerialize a => a -> (ByteString, ByteString)
bencode (forall k v. PopKey k v -> SPopKey k v
toSPopKey PopKey k v
p)
  case PopKey k v
p of
    PopKeyInt Bool
_ F s PKPrim
_ F' s ByteString -> v
_ -> (Bool
True , ByteString
b1 , ByteString
b2)
    PopKeyAny Bool
_ F s PKPrim
_ F' s ByteString -> v
_ F (Shape k) PKPrim
_ -> (Bool
False , ByteString
b1 , ByteString
b2)

fromStoreEnc :: forall k v . (PopKeyEncoding k , PopKeyEncoding v) => (Bool , BS.ByteString , BS.ByteString) -> PopKey k v
fromStoreEnc :: forall k v.
(PopKeyEncoding k, PopKeyEncoding v) =>
(Bool, ByteString, ByteString) -> PopKey k v
fromStoreEnc (Bool
True , ByteString
b1 , ByteString
b2) = forall a b. a -> b
unsafeCoerce (forall v. PopKeyEncoding v => SPopKey Int v -> PopKey Int v
fromSPopKey' (forall a. BiSerialize a => (ByteString, ByteString) -> a
bdecode (ByteString
b1 , ByteString
b2) :: SPopKey Int v))
fromStoreEnc (Bool
False , ByteString
b1 , ByteString
b2) = forall k v.
(PopKeyEncoding k, PopKeyEncoding v) =>
SPopKey k v -> PopKey k v
fromSPopKey (forall a. BiSerialize a => (ByteString, ByteString) -> a
bdecode (ByteString
b1 , ByteString
b2))

instance (PopKeyEncoding k , PopKeyEncoding v) => Store (PopKey k v) where
  size :: Size (PopKey k v)
size = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall k v.
(PopKeyEncoding k, PopKeyEncoding v) =>
PopKey k v -> (Bool, ByteString, ByteString)
toStoreEnc forall a. Store a => Size a
size
  peek :: Peek (PopKey k v)
peek = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k v.
(PopKeyEncoding k, PopKeyEncoding v) =>
(Bool, ByteString, ByteString) -> PopKey k v
fromStoreEnc forall a. Store a => Peek a
peek
  poke :: PopKey k v -> Poke ()
poke = forall a. Store a => a -> Poke ()
poke forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v.
(PopKeyEncoding k, PopKeyEncoding v) =>
PopKey k v -> (Bool, ByteString, ByteString)
toStoreEnc

{-# 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 :: forall (f :: * -> *) k v.
(Foldable f, PopKeyEncoding k, PopKeyEncoding v) =>
f (k, v) -> PopKey k v
makePopKey =
  forall s.
Foldable f =>
I (Shape k)
-> I s
-> (v -> F' s ByteString)
-> (F' s ByteString -> v)
-> f (k, v)
-> PopKey k v
makePopKeyWithEncoding (forall a. PopKeyEncoding a => I (Shape a)
shape @k) (forall a. PopKeyEncoding a => I (Shape a)
shape @v) (forall a. PopKeyEncoding a => a -> F' (Shape a) ByteString
pkEncode @v) (forall a. PopKeyEncoding a => F' (Shape a) ByteString -> a
pkDecode @v)
  where
    makePopKeyWithEncoding :: Foldable f
                           => I (Shape k)
                           -> I s -> (v -> F' s BS.ByteString) -> (F' s BS.ByteString -> v)
                           -> f (k , v)
                           -> PopKey k v
    makePopKeyWithEncoding :: forall s.
Foldable f =>
I (Shape k)
-> I s
-> (v -> F' s ByteString)
-> (F' s ByteString -> v)
-> f (k, v)
-> PopKey k v
makePopKeyWithEncoding I (Shape k)
ik I s
iv v -> F' s ByteString
ev F' s ByteString -> v
dv f (k, v)
xs = do
      let ([F' (Shape k) ByteString]
ks , [v]
vs) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. Ord a => [(a, b)] -> [(a, b)]
lastv forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. PopKeyEncoding a => a -> F' (Shape a) ByteString
pkEncode) [] f (k, v)
xs))
      forall s1 k v.
Bool
-> F s1 PKPrim
-> (F' s1 ByteString -> v)
-> F (Shape k) PKPrim
-> PopKey k v
PopKeyAny do Bool
True
                do forall a s (f :: * -> *).
Foldable f =>
I s -> (a -> F' s ByteString) -> f a -> F s PKPrim
construct I s
iv v -> F' s ByteString
ev [v]
vs
                do F' s ByteString -> v
dv
                do forall a s (f :: * -> *).
Foldable f =>
I s -> (a -> F' s ByteString) -> f a -> F s PKPrim
construct I (Shape k)
ik forall a. a -> a
id [F' (Shape k) ByteString]
ks
      where
        -- for duplicate keys, use the last value
        lastv :: forall a b . Ord a => [(a,b)] -> [(a,b)]
        lastv :: forall a b. Ord a => [(a, b)] -> [(a, b)]
lastv [] = []
        lastv [ (a, b)
x ] = [ (a, b)
x ]
        lastv ((a, b)
x : ys :: [(a, b)]
ys@((a, b)
y : [(a, b)]
_)) =
          if forall a b. (a, b) -> a
fst (a, b)
x forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> a
fst (a, b)
y
             then forall a b. Ord a => [(a, b)] -> [(a, b)]
lastv [(a, b)]
ys
             else (a, b)
x forall a. a -> [a] -> [a]
: forall a b. Ord a => [(a, b)] -> [(a, b)]
lastv [(a, b)]
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' :: forall (f :: * -> *) v.
(Foldable f, PopKeyEncoding v) =>
f v -> PopKey Int v
makePopKey' = forall s a.
I s
-> (a -> F' s ByteString)
-> (F' s ByteString -> a)
-> [a]
-> PopKey Int a
go (forall a. PopKeyEncoding a => I (Shape a)
shape @v) (forall a. PopKeyEncoding a => a -> F' (Shape a) ByteString
pkEncode @v) (forall a. PopKeyEncoding a => F' (Shape a) ByteString -> a
pkDecode @v) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) []
  where
    go :: I s -> (a -> F' s BS.ByteString) -> (F' s BS.ByteString -> a) -> [ a ] -> PopKey Int a
    go :: forall s a.
I s
-> (a -> F' s ByteString)
-> (F' s ByteString -> a)
-> [a]
-> PopKey Int a
go I s
i a -> F' s ByteString
e F' s ByteString -> a
d [a]
xs =
      forall s1 v.
Bool -> F s1 PKPrim -> (F' s1 ByteString -> v) -> PopKey Int v
PopKeyInt do Bool
True
                do forall a s (f :: * -> *).
Foldable f =>
I s -> (a -> F' s ByteString) -> f a -> F s PKPrim
construct I s
i a -> F' s ByteString
e [a]
xs
                do F' s ByteString -> a
d

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 :: forall (t :: * -> *).
Foldable t =>
PopKeyStore k v -> t (Input (PopKeyStore k v)) -> IO ()
storePopKey (PopKeyStore forall (f :: * -> *). Foldable f => f (k, v) -> IO ()
a IO (PopKey k v)
_) = forall (f :: * -> *). Foldable f => f (k, v) -> IO ()
a
  loadPopKey :: PopKeyStore k v -> IO (PopKey k v)
loadPopKey (PopKeyStore forall (f :: * -> *). Foldable f => f (k, v) -> IO ()
_ IO (PopKey k v)
b) = IO (PopKey k v)
b

instance StorePopKey Int v (PopKeyStore' v) where
  type Input (PopKeyStore' v) = v
  storePopKey :: forall (t :: * -> *).
Foldable t =>
PopKeyStore' v -> t (Input (PopKeyStore' v)) -> IO ()
storePopKey (PopKeyStore' forall (f :: * -> *). Foldable f => f v -> IO ()
a IO (PopKey Int v)
_) = forall (f :: * -> *). Foldable f => f v -> IO ()
a
  loadPopKey :: PopKeyStore' v -> IO (PopKey Int v)
loadPopKey (PopKeyStore' forall (f :: * -> *). Foldable f => f v -> IO ()
_ IO (PopKey Int v)
b) = IO (PopKey Int v)
b