{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Store.Impl where
import Control.Applicative
import Control.Exception (try)
import Control.Monad
import qualified Data.ByteString as BS
import Data.Functor.Contravariant (Contravariant(..))
import Data.Proxy
import Data.Store.Core
import Data.Typeable (Typeable, typeRep)
import Data.Word
import Foreign.Storable (Storable, sizeOf)
import GHC.Exts (Constraint)
import GHC.Generics
import GHC.TypeLits
import Prelude
import System.IO.Unsafe (unsafePerformIO)
class Store a where
size :: Size a
poke :: a -> Poke ()
peek :: Peek a
default size :: (Generic a, GStoreSize (Rep a)) => Size a
size = forall a. (Generic a, GStoreSize (Rep a)) => Size a
genericSize
default poke :: (Generic a, GStorePoke (Rep a)) => a -> Poke ()
poke = forall a. (Generic a, GStorePoke (Rep a)) => a -> Poke ()
genericPoke
default peek :: (Generic a , GStorePeek (Rep a)) => Peek a
peek = forall a. (Generic a, GStorePeek (Rep a)) => Peek a
genericPeek
encode :: Store a => a -> BS.ByteString
encode :: forall a. Store a => a -> ByteString
encode a
x = Poke () -> Int -> ByteString
unsafeEncodeWith (forall a. Store a => a -> Poke ()
poke a
x) (forall a. Store a => a -> Int
getSize a
x)
decode :: Store a => BS.ByteString -> Either PeekException a
decode :: forall a. Store a => ByteString -> Either PeekException a
decode = forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => IO a -> IO (Either e a)
try forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Store a => ByteString -> IO a
decodeIO
decodeEx :: Store a => BS.ByteString -> a
decodeEx :: forall a. Store a => ByteString -> a
decodeEx = forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Store a => ByteString -> IO a
decodeIO
decodeIO :: Store a => BS.ByteString -> IO a
decodeIO :: forall a. Store a => ByteString -> IO a
decodeIO = forall a. Peek a -> ByteString -> IO a
decodeIOWith forall a. Store a => Peek a
peek
data Size a
= VarSize (a -> Int)
| ConstSize !Int
deriving Typeable
instance Contravariant Size where
contramap :: forall a' a. (a' -> a) -> Size a -> Size a'
contramap a' -> a
f Size a
sz = case Size a
sz of
ConstSize Int
n -> forall a. Int -> Size a
ConstSize Int
n
VarSize a -> Int
g -> forall a. (a -> Int) -> Size a
VarSize (\a'
x -> a -> Int
g (a' -> a
f a'
x))
getSize :: Store a => a -> Int
getSize :: forall a. Store a => a -> Int
getSize = forall a. Size a -> a -> Int
getSizeWith forall a. Store a => Size a
size
{-# INLINE getSize #-}
getSizeWith :: Size a -> a -> Int
getSizeWith :: forall a. Size a -> a -> Int
getSizeWith (VarSize a -> Int
f) a
x = a -> Int
f a
x
getSizeWith (ConstSize Int
n) a
_ = Int
n
{-# INLINE getSizeWith #-}
combineSize :: forall a b c. (Store a, Store b) => (c -> a) -> (c -> b) -> Size c
combineSize :: forall a b c. (Store a, Store b) => (c -> a) -> (c -> b) -> Size c
combineSize c -> a
toA c -> b
toB = forall a b c. (c -> a) -> (c -> b) -> Size a -> Size b -> Size c
combineSizeWith c -> a
toA c -> b
toB forall a. Store a => Size a
size forall a. Store a => Size a
size
{-# INLINE combineSize #-}
combineSizeWith :: forall a b c. (c -> a) -> (c -> b) -> Size a -> Size b -> Size c
combineSizeWith :: forall a b c. (c -> a) -> (c -> b) -> Size a -> Size b -> Size c
combineSizeWith c -> a
toA c -> b
toB Size a
sizeA Size b
sizeB =
case (Size a
sizeA, Size b
sizeB) of
(VarSize a -> Int
f, VarSize b -> Int
g) -> forall a. (a -> Int) -> Size a
VarSize (\c
x -> a -> Int
f (c -> a
toA c
x) forall a. Num a => a -> a -> a
+ b -> Int
g (c -> b
toB c
x))
(VarSize a -> Int
f, ConstSize Int
m) -> forall a. (a -> Int) -> Size a
VarSize (\c
x -> a -> Int
f (c -> a
toA c
x) forall a. Num a => a -> a -> a
+ Int
m)
(ConstSize Int
n, VarSize b -> Int
g) -> forall a. (a -> Int) -> Size a
VarSize (\c
x -> Int
n forall a. Num a => a -> a -> a
+ b -> Int
g (c -> b
toB c
x))
(ConstSize Int
n, ConstSize Int
m) -> forall a. Int -> Size a
ConstSize (Int
n forall a. Num a => a -> a -> a
+ Int
m)
{-# INLINE combineSizeWith #-}
addSize :: Int -> Size a -> Size a
addSize :: forall a. Int -> Size a -> Size a
addSize Int
x (ConstSize Int
n) = forall a. Int -> Size a
ConstSize (Int
x forall a. Num a => a -> a -> a
+ Int
n)
addSize Int
x (VarSize a -> Int
f) = forall a. (a -> Int) -> Size a
VarSize ((Int
x forall a. Num a => a -> a -> a
+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
f)
{-# INLINE addSize #-}
sizeStorable :: forall a. (Storable a, Typeable a) => Size a
sizeStorable :: forall a. (Storable a, Typeable a) => Size a
sizeStorable = forall a. Storable a => String -> Size a
sizeStorableTy (forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)))
{-# INLINE sizeStorable #-}
sizeStorableTy :: forall a. Storable a => String -> Size a
sizeStorableTy :: forall a. Storable a => String -> Size a
sizeStorableTy String
ty = forall a. Int -> Size a
ConstSize (forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => String -> a
error String
msg :: a))
where
msg :: String
msg = String
"In Data.Store.storableSize: " forall a. [a] -> [a] -> [a]
++ String
ty forall a. [a] -> [a] -> [a]
++ String
"'s sizeOf evaluated its argument."
{-# INLINE sizeStorableTy #-}
genericSize :: (Generic a, GStoreSize (Rep a)) => Size a
genericSize :: forall a. (Generic a, GStoreSize (Rep a)) => Size a
genericSize = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall a x. Generic a => a -> Rep a x
from forall (f :: * -> *) a. GStoreSize f => Size (f a)
gsize
{-# INLINE genericSize #-}
genericPoke :: (Generic a, GStorePoke (Rep a)) => a -> Poke ()
genericPoke :: forall a. (Generic a, GStorePoke (Rep a)) => a -> Poke ()
genericPoke = forall (f :: * -> *) a. GStorePoke f => f a -> Poke ()
gpoke forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from
{-# INLINE genericPoke #-}
genericPeek :: (Generic a , GStorePeek (Rep a)) => Peek a
genericPeek :: forall a. (Generic a, GStorePeek (Rep a)) => Peek a
genericPeek = forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GStorePeek f => Peek (f a)
gpeek
{-# INLINE genericPeek #-}
type family SumArity (a :: * -> *) :: Nat where
SumArity (C1 c a) = 1
SumArity (x :+: y) = SumArity x + SumArity y
class GStoreSize f where gsize :: Size (f a)
class GStorePoke f where gpoke :: f a -> Poke ()
class GStorePeek f where gpeek :: Peek (f a)
instance GStoreSize f => GStoreSize (M1 i c f) where
gsize :: forall a. Size (M1 i c f a)
gsize = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 forall (f :: * -> *) a. GStoreSize f => Size (f a)
gsize
{-# INLINE gsize #-}
instance GStorePoke f => GStorePoke (M1 i c f) where
gpoke :: forall a. M1 i c f a -> Poke ()
gpoke = forall (f :: * -> *) a. GStorePoke f => f a -> Poke ()
gpoke forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
{-# INLINE gpoke #-}
instance GStorePeek f => GStorePeek (M1 i c f) where
gpeek :: forall a. Peek (M1 i c f a)
gpeek = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a. GStorePeek f => Peek (f a)
gpeek
{-# INLINE gpeek #-}
instance Store a => GStoreSize (K1 i a) where
gsize :: forall a. Size (K1 i a a)
gsize = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall k i c (p :: k). K1 i c p -> c
unK1 forall a. Store a => Size a
size
{-# INLINE gsize #-}
instance Store a => GStorePoke (K1 i a) where
gpoke :: forall a. K1 i a a -> Poke ()
gpoke = forall a. Store a => a -> Poke ()
poke forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). K1 i c p -> c
unK1
{-# INLINE gpoke #-}
instance Store a => GStorePeek (K1 i a) where
gpeek :: forall a. Peek (K1 i a a)
gpeek = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i c (p :: k). c -> K1 i c p
K1 forall a. Store a => Peek a
peek
{-# INLINE gpeek #-}
instance GStoreSize U1 where
gsize :: forall a. Size (U1 a)
gsize = forall a. Int -> Size a
ConstSize Int
0
{-# INLINE gsize #-}
instance GStorePoke U1 where
gpoke :: forall a. U1 a -> Poke ()
gpoke U1 a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# INLINE gpoke #-}
instance GStorePeek U1 where
gpeek :: forall a. Peek (U1 a)
gpeek = forall (m :: * -> *) a. Monad m => a -> m a
return forall k (p :: k). U1 p
U1
{-# INLINE gpeek #-}
instance GStoreSize V1 where
gsize :: forall a. Size (V1 a)
gsize = forall a. Int -> Size a
ConstSize Int
0
{-# INLINE gsize #-}
instance GStorePoke V1 where
gpoke :: forall a. V1 a -> Poke ()
gpoke V1 a
x = case V1 a
x of {}
{-# INLINE gpoke #-}
instance GStorePeek V1 where
gpeek :: forall a. Peek (V1 a)
gpeek = forall a. HasCallStack => a
undefined
{-# INLINE gpeek #-}
instance (GStoreSize a, GStoreSize b) => GStoreSize (a :*: b) where
gsize :: forall a. Size ((:*:) a b a)
gsize = forall a b c. (c -> a) -> (c -> b) -> Size a -> Size b -> Size c
combineSizeWith (\(a a
x :*: b a
_) -> a a
x) (\(a a
_ :*: b a
y) -> b a
y) forall (f :: * -> *) a. GStoreSize f => Size (f a)
gsize forall (f :: * -> *) a. GStoreSize f => Size (f a)
gsize
{-# INLINE gsize #-}
instance (GStorePoke a, GStorePoke b) => GStorePoke (a :*: b) where
gpoke :: forall a. (:*:) a b a -> Poke ()
gpoke (a a
a :*: b a
b) = forall (f :: * -> *) a. GStorePoke f => f a -> Poke ()
gpoke a a
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. GStorePoke f => f a -> Poke ()
gpoke b a
b
{-# INLINE gpoke #-}
instance (GStorePeek a, GStorePeek b) => GStorePeek (a :*: b) where
gpeek :: forall a. Peek ((:*:) a b a)
gpeek = forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GStorePeek f => Peek (f a)
gpeek forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. GStorePeek f => Peek (f a)
gpeek
{-# INLINE gpeek #-}
instance (FitsInByte (SumArity (a :+: b)), GStoreSizeSum 0 (a :+: b))
=> GStoreSize (a :+: b) where
gsize :: forall a. Size ((:+:) a b a)
gsize = forall a. (a -> Int) -> Size a
VarSize forall a b. (a -> b) -> a -> b
$ \(:+:) a b a
x -> forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: Word8) forall a. Num a => a -> a -> a
+ forall (n :: Nat) (f :: * -> *) a.
GStoreSizeSum n f =>
f a -> Proxy n -> Int
gsizeSum (:+:) a b a
x (forall {k} (t :: k). Proxy t
Proxy :: Proxy 0)
{-# INLINE gsize #-}
instance (FitsInByte (SumArity (a :+: b)), GStorePokeSum 0 (a :+: b))
=> GStorePoke (a :+: b) where
gpoke :: forall a. (:+:) a b a -> Poke ()
gpoke (:+:) a b a
x = forall (n :: Nat) (f :: * -> *) p.
GStorePokeSum n f =>
f p -> Proxy n -> Poke ()
gpokeSum (:+:) a b a
x (forall {k} (t :: k). Proxy t
Proxy :: Proxy 0)
{-# INLINE gpoke #-}
instance (FitsInByte (SumArity (a :+: b)), GStorePeekSum 0 (a :+: b))
=> GStorePeek (a :+: b) where
gpeek :: forall a. Peek ((:+:) a b a)
gpeek = do
Word8
tag <- forall a. (Storable a, Typeable a) => Peek a
peekStorable
forall (n :: Nat) (f :: * -> *) p.
GStorePeekSum n f =>
Word8 -> Proxy n -> Peek (f p)
gpeekSum Word8
tag (forall {k} (t :: k). Proxy t
Proxy :: Proxy 0)
{-# INLINE gpeek #-}
type FitsInByte n = FitsInByteResult (n <=? 255)
type family FitsInByteResult (b :: Bool) :: Constraint where
FitsInByteResult 'True = ()
FitsInByteResult 'False = TypeErrorMessage
"Generic deriving of Store instances can only be used on datatypes with fewer than 256 constructors."
type family TypeErrorMessage (a :: Symbol) :: Constraint where
#if MIN_VERSION_base(4,9,0)
TypeErrorMessage a = TypeError ('Text a)
#elif __GLASGOW_HASKELL__ < 800
TypeErrorMessage a = a ~ ""
#endif
class KnownNat n => GStoreSizeSum (n :: Nat) (f :: * -> *) where gsizeSum :: f a -> Proxy n -> Int
class KnownNat n => GStorePokeSum (n :: Nat) (f :: * -> *) where gpokeSum :: f p -> Proxy n -> Poke ()
class KnownNat n => GStorePeekSum (n :: Nat) (f :: * -> *) where gpeekSum :: Word8 -> Proxy n -> Peek (f p)
instance (GStoreSizeSum n a, GStoreSizeSum (n + SumArity a) b, KnownNat n)
=> GStoreSizeSum n (a :+: b) where
gsizeSum :: forall a. (:+:) a b a -> Proxy n -> Int
gsizeSum (L1 a a
l) Proxy n
_ = forall (n :: Nat) (f :: * -> *) a.
GStoreSizeSum n f =>
f a -> Proxy n -> Int
gsizeSum a a
l (forall {k} (t :: k). Proxy t
Proxy :: Proxy n)
gsizeSum (R1 b a
r) Proxy n
_ = forall (n :: Nat) (f :: * -> *) a.
GStoreSizeSum n f =>
f a -> Proxy n -> Int
gsizeSum b a
r (forall {k} (t :: k). Proxy t
Proxy :: Proxy (n + SumArity a))
{-# INLINE gsizeSum #-}
instance (GStorePokeSum n a, GStorePokeSum (n + SumArity a) b, KnownNat n)
=> GStorePokeSum n (a :+: b) where
gpokeSum :: forall p. (:+:) a b p -> Proxy n -> Poke ()
gpokeSum (L1 a p
l) Proxy n
_ = forall (n :: Nat) (f :: * -> *) p.
GStorePokeSum n f =>
f p -> Proxy n -> Poke ()
gpokeSum a p
l (forall {k} (t :: k). Proxy t
Proxy :: Proxy n)
gpokeSum (R1 b p
r) Proxy n
_ = forall (n :: Nat) (f :: * -> *) p.
GStorePokeSum n f =>
f p -> Proxy n -> Poke ()
gpokeSum b p
r (forall {k} (t :: k). Proxy t
Proxy :: Proxy (n + SumArity a))
{-# INLINE gpokeSum #-}
instance (GStorePeekSum n a, GStorePeekSum (n + SumArity a) b, KnownNat n)
=> GStorePeekSum n (a :+: b) where
gpeekSum :: forall p. Word8 -> Proxy n -> Peek ((:+:) a b p)
gpeekSum Word8
tag Proxy n
proxyL
| Word8
tag forall a. Ord a => a -> a -> Bool
< Word8
sizeL = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (n :: Nat) (f :: * -> *) p.
GStorePeekSum n f =>
Word8 -> Proxy n -> Peek (f p)
gpeekSum Word8
tag Proxy n
proxyL
| Bool
otherwise = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (n :: Nat) (f :: * -> *) p.
GStorePeekSum n f =>
Word8 -> Proxy n -> Peek (f p)
gpeekSum Word8
tag (forall {k} (t :: k). Proxy t
Proxy :: Proxy (n + SumArity a))
where
sizeL :: Word8
sizeL = forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy (n + SumArity a)))
{-# INLINE gpeekSum #-}
instance (GStoreSize a, KnownNat n) => GStoreSizeSum n (C1 c a) where
gsizeSum :: forall a. C1 c a a -> Proxy n -> Int
gsizeSum C1 c a a
x Proxy n
_ = forall a. Size a -> a -> Int
getSizeWith forall (f :: * -> *) a. GStoreSize f => Size (f a)
gsize C1 c a a
x
{-# INLINE gsizeSum #-}
instance (GStorePoke a, KnownNat n) => GStorePokeSum n (C1 c a) where
gpokeSum :: forall p. C1 c a p -> Proxy n -> Poke ()
gpokeSum C1 c a p
x Proxy n
_ = do
forall a. Storable a => a -> Poke ()
pokeStorable (forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy n)) :: Word8)
forall (f :: * -> *) a. GStorePoke f => f a -> Poke ()
gpoke C1 c a p
x
{-# INLINE gpokeSum #-}
instance (GStorePeek a, KnownNat n) => GStorePeekSum n (C1 c a) where
gpeekSum :: forall p. Word8 -> Proxy n -> Peek (C1 c a p)
gpeekSum Word8
tag Proxy n
_
| Word8
tag forall a. Eq a => a -> a -> Bool
== Word8
cur = forall (f :: * -> *) a. GStorePeek f => Peek (f a)
gpeek
| Word8
tag forall a. Ord a => a -> a -> Bool
> Word8
cur = forall a. Text -> Peek a
peekException Text
"Sum tag invalid"
| Bool
otherwise = forall a. Text -> Peek a
peekException Text
"Error in implementation of Store Generics"
where
cur :: Word8
cur = forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy n))
{-# INLINE gpeekSum #-}