{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Data.SafeCopy.SafeCopy where
import Control.Monad
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Fail as Fail
import Control.Monad.Trans.State as State (evalStateT, modify, StateT)
import qualified Control.Monad.Trans.State as State (get)
import Control.Monad.Trans.RWS as RWS (evalRWST, modify, RWST, tell)
import qualified Control.Monad.Trans.RWS as RWS (get)
import Data.Bits (shiftR)
import Data.Int (Int32)
import Data.List
import Data.Map as Map (Map, lookup, insert)
import Data.Serialize
import Data.Set as Set (insert, member, Set)
import Data.Typeable (Typeable, TypeRep, typeOf, typeRep)
import Data.Word (Word8)
import GHC.Generics
import Generic.Data as G (Constructors, gconIndex, gconNum)
import Unsafe.Coerce (unsafeCoerce)
class SafeCopy (MigrateFrom a) => Migrate a where
type MigrateFrom a
migrate :: MigrateFrom a -> a
newtype Reverse a = Reverse { Reverse a -> a
unReverse :: a }
data Kind a where
Primitive :: Kind a
Base :: Kind a
Extends :: (Migrate a) => Proxy (MigrateFrom a) -> Kind a
Extended :: (Migrate (Reverse a)) => Kind a -> Kind a
isPrimitive :: Kind a -> Bool
isPrimitive :: Kind a -> Bool
isPrimitive Primitive = Bool
True
isPrimitive _ = Bool
False
newtype Prim a = Prim { Prim a -> a
getPrimitive :: a }
class SafeCopy a where
version :: Version a
version = Int32 -> Version a
forall a. Int32 -> Version a
Version 0
kind :: Kind a
kind = Kind a
forall a. Kind a
Base
getCopy :: Contained (Get a)
putCopy :: a -> Contained Put
internalConsistency :: Consistency a
internalConsistency = Proxy a -> Consistency a
forall a. SafeCopy a => Proxy a -> Consistency a
computeConsistency Proxy a
forall a. Proxy a
Proxy
objectProfile :: Profile a
objectProfile = Proxy a -> Profile a
forall a. SafeCopy a => Proxy a -> Profile a
mkProfile Proxy a
forall a. Proxy a
Proxy
errorTypeName :: Proxy a -> String
default errorTypeName :: Typeable a => Proxy a -> String
errorTypeName _ = TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall a. Proxy a
Proxy @a))
default putCopy :: (GPutCopy (Rep a) DatatypeInfo, Constructors a) => a -> Contained Put
putCopy a :: a
a = (Put -> Contained Put
forall a. a -> Contained a
contain (Put -> Contained Put) -> (a -> Put) -> a -> Contained Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeInfo -> Rep a DatatypeInfo -> Put
forall (f :: * -> *) p. GPutCopy f p => p -> f p -> Put
gputCopy (Word8 -> Word8 -> DatatypeInfo
ConstructorInfo (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Constructors a => Int
forall a. Constructors a => Int
gconNum @a)) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int
forall a. Constructors a => a -> Int
gconIndex a
a))) (Rep a DatatypeInfo -> Put)
-> (a -> Rep a DatatypeInfo) -> a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a DatatypeInfo
forall a x. Generic a => a -> Rep a x
from) a
a
default getCopy :: (GGetCopy (Rep a) DatatypeInfo, Constructors a) => Contained (Get a)
getCopy = Get a -> Contained (Get a)
forall a. a -> Contained a
contain (Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> Get (Rep a Any) -> Get a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> Get (Rep a Any)
forall (f :: * -> *) p a. GGetCopy f p => p -> Get (f a)
ggetCopy (Word8 -> DatatypeInfo
ConstructorCount (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Constructors a => Int
forall a. Constructors a => Int
gconNum @a))))
class GPutCopy f p where
gputCopy :: p -> f p -> Put
instance GPutCopy a p => GPutCopy (M1 D c a) p where
gputCopy :: p -> M1 D c a p -> Put
gputCopy p :: p
p (M1 a :: a p
a) = p -> a p -> Put
forall (f :: * -> *) p. GPutCopy f p => p -> f p -> Put
gputCopy p
p a p
a
{-# INLINE gputCopy #-}
instance (GPutCopy f p, GPutCopy g p) => GPutCopy (f :+: g) p where
gputCopy :: p -> (:+:) f g p -> Put
gputCopy p :: p
p (L1 x :: f p
x) = p -> f p -> Put
forall (f :: * -> *) p. GPutCopy f p => p -> f p -> Put
gputCopy @f p
p f p
x
gputCopy p :: p
p (R1 x :: g p
x) = p -> g p -> Put
forall (f :: * -> *) p. GPutCopy f p => p -> f p -> Put
gputCopy @g p
p g p
x
{-# INLINE gputCopy #-}
type SafeCopy' a = (SafeCopy a, Typeable a)
instance (GPutFields a p, p ~ DatatypeInfo) => GPutCopy (M1 C c a) p where
gputCopy :: p -> M1 C c a p -> Put
gputCopy p :: p
p (M1 x :: a p
x) =
(Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DatatypeInfo -> Word8
_size p
DatatypeInfo
p Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= 2) (Putter Word8
putWord8 (Word8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DatatypeInfo -> Word8
_code p
DatatypeInfo
p)))) Put -> Put -> Put
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
(do Put
putter <- ([Put] -> Put
forall a. Monoid a => [a] -> a
mconcat ([Put] -> Put) -> (((), [Put]) -> [Put]) -> ((), [Put]) -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), [Put]) -> [Put]
forall a b. (a, b) -> b
snd) (((), [Put]) -> Put) -> PutM ((), [Put]) -> PutM Put
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RWST () [Put] (Set TypeRep) PutM ()
-> () -> Set TypeRep -> PutM ((), [Put])
forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> r -> s -> m (a, w)
evalRWST (p -> a p -> RWST () [Put] (Set TypeRep) PutM ()
forall (f :: * -> *) p.
GPutFields f p =>
p -> f p -> RWST () [Put] (Set TypeRep) PutM ()
gputFields p
p a p
x) () Set TypeRep
forall a. Monoid a => a
mempty)
Put
putter)
{-# INLINE gputCopy #-}
class GPutFields f p where
gputFields :: p -> f p -> RWST () [Put] (Set TypeRep) PutM ()
instance (GPutFields f p, GPutFields g p) => GPutFields (f :*: g) p where
gputFields :: p -> (:*:) f g p -> RWST () [Put] (Set TypeRep) PutM ()
gputFields p :: p
p (a :: f p
a :*: b :: g p
b) = p -> f p -> RWST () [Put] (Set TypeRep) PutM ()
forall (f :: * -> *) p.
GPutFields f p =>
p -> f p -> RWST () [Put] (Set TypeRep) PutM ()
gputFields p
p f p
a RWST () [Put] (Set TypeRep) PutM ()
-> RWST () [Put] (Set TypeRep) PutM ()
-> RWST () [Put] (Set TypeRep) PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> p -> g p -> RWST () [Put] (Set TypeRep) PutM ()
forall (f :: * -> *) p.
GPutFields f p =>
p -> f p -> RWST () [Put] (Set TypeRep) PutM ()
gputFields p
p g p
b
{-# INLINE gputFields #-}
instance GPutFields f p => GPutFields (M1 S c f) p where
gputFields :: p -> M1 S c f p -> RWST () [Put] (Set TypeRep) PutM ()
gputFields p :: p
p (M1 a :: f p
a) = p -> f p -> RWST () [Put] (Set TypeRep) PutM ()
forall (f :: * -> *) p.
GPutFields f p =>
p -> f p -> RWST () [Put] (Set TypeRep) PutM ()
gputFields p
p f p
a
{-# INLINE gputFields #-}
instance SafeCopy' a => GPutFields (K1 R a) p where
gputFields :: p -> K1 R a p -> RWST () [Put] (Set TypeRep) PutM ()
gputFields _ (K1 a :: a
a) = do
(a -> Contained Put) -> a -> RWST () [Put] (Set TypeRep) PutM ()
forall a.
SafeCopy' a =>
(a -> Contained Put) -> a -> RWST () [Put] (Set TypeRep) PutM ()
getSafePutGeneric a -> Contained Put
forall a. SafeCopy a => a -> Contained Put
putCopy a
a
{-# INLINE gputFields #-}
instance GPutFields U1 p where
gputFields :: p -> U1 p -> RWST () [Put] (Set TypeRep) PutM ()
gputFields _ _ =
() -> RWST () [Put] (Set TypeRep) PutM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# INLINE gputFields #-}
instance GPutFields V1 p where
gputFields :: p -> V1 p -> RWST () [Put] (Set TypeRep) PutM ()
gputFields _ _ = RWST () [Put] (Set TypeRep) PutM ()
forall a. HasCallStack => a
undefined
{-# INLINE gputFields #-}
class GGetCopy f p where
ggetCopy :: p -> Get (f a)
instance (GGetCopy f p, p ~ DatatypeInfo) => GGetCopy (M1 D d f) p where
ggetCopy :: p -> Get (M1 D d f a)
ggetCopy p :: p
p
| DatatypeInfo -> Word8
_size p
DatatypeInfo
p Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 = do
!Word8
code <- Get Word8
getWord8
f a -> M1 D d f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 D d f a) -> Get (f a) -> Get (M1 D d f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> Get (f a)
forall (f :: * -> *) p a. GGetCopy f p => p -> Get (f a)
ggetCopy (Word8 -> Word8 -> DatatypeInfo
ConstructorInfo (DatatypeInfo -> Word8
_size p
DatatypeInfo
p) Word8
code)
| Bool
otherwise = f a -> M1 D d f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 D d f a) -> Get (f a) -> Get (M1 D d f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> Get (f a)
forall (f :: * -> *) p a. GGetCopy f p => p -> Get (f a)
ggetCopy (Word8 -> Word8 -> DatatypeInfo
ConstructorInfo (DatatypeInfo -> Word8
_size p
DatatypeInfo
p) 0)
{-# INLINE ggetCopy #-}
instance (GGetCopy f p, GGetCopy g p, p ~ DatatypeInfo) => GGetCopy (f :+: g) p where
ggetCopy :: p -> Get ((:+:) f g a)
ggetCopy p :: p
p = do
let sizeL :: Word8
sizeL = DatatypeInfo -> Word8
_size p
DatatypeInfo
p Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` 1
sizeR :: Word8
sizeR = DatatypeInfo -> Word8
_size p
DatatypeInfo
p Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
sizeL
case DatatypeInfo -> Word8
_code p
DatatypeInfo
p Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
sizeL of
True -> f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f a -> (:+:) f g a) -> Get (f a) -> Get ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> Get (f a)
forall (f :: * -> *) p a. GGetCopy f p => p -> Get (f a)
ggetCopy @f (Word8 -> Word8 -> DatatypeInfo
ConstructorInfo Word8
sizeL (DatatypeInfo -> Word8
_code p
DatatypeInfo
p))
False -> g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g a -> (:+:) f g a) -> Get (g a) -> Get ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> Get (g a)
forall (f :: * -> *) p a. GGetCopy f p => p -> Get (f a)
ggetCopy @g (Word8 -> Word8 -> DatatypeInfo
ConstructorInfo Word8
sizeR (DatatypeInfo -> Word8
_code p
DatatypeInfo
p Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
sizeL))
{-# INLINE ggetCopy #-}
instance GGetFields f p => GGetCopy (M1 C c f) p where
ggetCopy :: p -> Get (M1 C c f a)
ggetCopy p :: p
p = do
f a -> M1 C c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 C c f a) -> Get (f a) -> Get (M1 C c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (Get (f a)) -> Get (f a)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (StateT (Map TypeRep Int32) Get (Get (f a))
-> Map TypeRep Int32 -> Get (Get (f a))
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (p -> StateT (Map TypeRep Int32) Get (Get (f a))
forall (f :: * -> *) p a.
GGetFields f p =>
p -> StateT (Map TypeRep Int32) Get (Get (f a))
ggetFields p
p) Map TypeRep Int32
forall a. Monoid a => a
mempty)
{-# INLINE ggetCopy #-}
class GGetFields f p where
ggetFields :: p -> StateT (Map TypeRep Int32) Get (Get (f a))
instance (GGetFields f p, GGetFields g p) => GGetFields (f :*: g) p where
ggetFields :: p -> StateT (Map TypeRep Int32) Get (Get ((:*:) f g a))
ggetFields p :: p
p = do
Get (f a)
fgetter <- p -> StateT (Map TypeRep Int32) Get (Get (f a))
forall (f :: * -> *) p a.
GGetFields f p =>
p -> StateT (Map TypeRep Int32) Get (Get (f a))
ggetFields @f p
p
Get (g a)
ggetter <- p -> StateT (Map TypeRep Int32) Get (Get (g a))
forall (f :: * -> *) p a.
GGetFields f p =>
p -> StateT (Map TypeRep Int32) Get (Get (f a))
ggetFields @g p
p
Get ((:*:) f g a)
-> StateT (Map TypeRep Int32) Get (Get ((:*:) f g a))
forall (m :: * -> *) a. Monad m => a -> m a
return (f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f a -> g a -> (:*:) f g a)
-> Get (f a) -> Get (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (f a)
fgetter Get (g a -> (:*:) f g a) -> Get (g a) -> Get ((:*:) f g a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (g a)
ggetter)
{-# INLINE ggetFields #-}
instance GGetFields f p => GGetFields (M1 S c f) p where
ggetFields :: p -> StateT (Map TypeRep Int32) Get (Get (M1 S c f a))
ggetFields p :: p
p = do
Get (f a)
getter <- p -> StateT (Map TypeRep Int32) Get (Get (f a))
forall (f :: * -> *) p a.
GGetFields f p =>
p -> StateT (Map TypeRep Int32) Get (Get (f a))
ggetFields p
p
Get (M1 S c f a)
-> StateT (Map TypeRep Int32) Get (Get (M1 S c f a))
forall (m :: * -> *) a. Monad m => a -> m a
return (f a -> M1 S c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 S c f a) -> Get (f a) -> Get (M1 S c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (f a)
getter)
{-# INLINE ggetFields #-}
instance SafeCopy' a => GGetFields (K1 R a) p where
ggetFields :: p -> StateT (Map TypeRep Int32) Get (Get (K1 R a a))
ggetFields _ = do
Get a
getter <- StateT (Map TypeRep Int32) Get (Get a)
forall a. SafeCopy' a => StateT (Map TypeRep Int32) Get (Get a)
getSafeGetGeneric
Get (K1 R a a) -> StateT (Map TypeRep Int32) Get (Get (K1 R a a))
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> K1 R a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 R a a) -> Get a -> Get (K1 R a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a
getter)
{-# INLINE ggetFields #-}
instance GGetFields U1 p where
ggetFields :: p -> StateT (Map TypeRep Int32) Get (Get (U1 a))
ggetFields _p :: p
_p = Get (U1 a) -> StateT (Map TypeRep Int32) Get (Get (U1 a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (U1 a -> Get (U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1)
{-# INLINE ggetFields #-}
instance GGetFields V1 p where
ggetFields :: p -> StateT (Map TypeRep Int32) Get (Get (V1 a))
ggetFields _p :: p
_p = StateT (Map TypeRep Int32) Get (Get (V1 a))
forall a. HasCallStack => a
undefined
{-# INLINE ggetFields #-}
data DatatypeInfo =
ConstructorCount {DatatypeInfo -> Word8
_size :: Word8}
| ConstructorInfo {_size :: Word8, DatatypeInfo -> Word8
_code :: Word8}
deriving Int -> DatatypeInfo -> ShowS
[DatatypeInfo] -> ShowS
DatatypeInfo -> String
(Int -> DatatypeInfo -> ShowS)
-> (DatatypeInfo -> String)
-> ([DatatypeInfo] -> ShowS)
-> Show DatatypeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DatatypeInfo] -> ShowS
$cshowList :: [DatatypeInfo] -> ShowS
show :: DatatypeInfo -> String
$cshow :: DatatypeInfo -> String
showsPrec :: Int -> DatatypeInfo -> ShowS
$cshowsPrec :: Int -> DatatypeInfo -> ShowS
Show
getSafeGetGeneric ::
forall a. SafeCopy' a
=> StateT (Map TypeRep Int32) Get (Get a)
getSafeGetGeneric :: StateT (Map TypeRep Int32) Get (Get a)
getSafeGetGeneric
= Proxy a
-> StateT (Map TypeRep Int32) Get (Get a)
-> StateT (Map TypeRep Int32) Get (Get a)
forall a (m :: * -> *) b.
(SafeCopy a, MonadFail m) =>
Proxy a -> m b -> m b
checkConsistency Proxy a
proxy (StateT (Map TypeRep Int32) Get (Get a)
-> StateT (Map TypeRep Int32) Get (Get a))
-> StateT (Map TypeRep Int32) Get (Get a)
-> StateT (Map TypeRep Int32) Get (Get a)
forall a b. (a -> b) -> a -> b
$
case Proxy a -> Kind a
forall a. SafeCopy a => Proxy a -> Kind a
kindFromProxy Proxy a
proxy of
Primitive -> Get a -> StateT (Map TypeRep Int32) Get (Get a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Get a -> StateT (Map TypeRep Int32) Get (Get a))
-> Get a -> StateT (Map TypeRep Int32) Get (Get a)
forall a b. (a -> b) -> a -> b
$ Contained (Get a) -> Get a
forall a. Contained a -> a
unsafeUnPack Contained (Get a)
forall a. SafeCopy a => Contained (Get a)
getCopy
a_kind :: Kind a
a_kind -> do let rep :: TypeRep
rep = Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall a. Proxy a
Proxy :: Proxy a)
Map TypeRep Int32
reps <- StateT (Map TypeRep Int32) Get (Map TypeRep Int32)
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
Int32
v <- StateT (Map TypeRep Int32) Get Int32
-> (Int32 -> StateT (Map TypeRep Int32) Get Int32)
-> Maybe Int32
-> StateT (Map TypeRep Int32) Get Int32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Get Int32 -> StateT (Map TypeRep Int32) Get Int32
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Int32
forall t. Serialize t => Get t
get) Int32 -> StateT (Map TypeRep Int32) Get Int32
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeRep -> Map TypeRep Int32 -> Maybe Int32
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeRep
rep Map TypeRep Int32
reps)
case Version a -> Kind a -> Either String (Get a)
forall a.
SafeCopy a =>
Version a -> Kind a -> Either String (Get a)
constructGetterFromVersion (Int32 -> Version a
forall a b. a -> b
unsafeCoerce Int32
v) Kind a
a_kind of
Right getter :: Get a
getter -> (Map TypeRep Int32 -> Map TypeRep Int32)
-> StateT (Map TypeRep Int32) Get ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (TypeRep -> Int32 -> Map TypeRep Int32 -> Map TypeRep Int32
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeRep
rep Int32
v) StateT (Map TypeRep Int32) Get ()
-> StateT (Map TypeRep Int32) Get (Get a)
-> StateT (Map TypeRep Int32) Get (Get a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Get a -> StateT (Map TypeRep Int32) Get (Get a)
forall (m :: * -> *) a. Monad m => a -> m a
return Get a
getter
Left msg :: String
msg -> String -> StateT (Map TypeRep Int32) Get (Get a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
where proxy :: Proxy a
proxy = Proxy a
forall a. Proxy a
Proxy :: Proxy a
getSafePutGeneric ::
forall a. SafeCopy' a
=> (a -> Contained Put)
-> a
-> RWST () [Put] (Set TypeRep) PutM ()
getSafePutGeneric :: (a -> Contained Put) -> a -> RWST () [Put] (Set TypeRep) PutM ()
getSafePutGeneric cput :: a -> Contained Put
cput a :: a
a
= Proxy a
-> RWST () [Put] (Set TypeRep) PutM ()
-> RWST () [Put] (Set TypeRep) PutM ()
forall a b. SafeCopy a => Proxy a -> b -> b
unpureCheckConsistency Proxy a
proxy (RWST () [Put] (Set TypeRep) PutM ()
-> RWST () [Put] (Set TypeRep) PutM ())
-> RWST () [Put] (Set TypeRep) PutM ()
-> RWST () [Put] (Set TypeRep) PutM ()
forall a b. (a -> b) -> a -> b
$
case Proxy a -> Kind a
forall a. SafeCopy a => Proxy a -> Kind a
kindFromProxy Proxy a
proxy of
Primitive -> [Put] -> RWST () [Put] (Set TypeRep) PutM ()
forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
tell [Contained Put -> Put
forall a. Contained a -> a
unsafeUnPack (a -> Contained Put
cput (a -> Contained Put) -> a -> Contained Put
forall a b. (a -> b) -> a -> b
$ a -> Proxy a -> a
forall a. a -> Proxy a -> a
asProxyType a
a Proxy a
proxy)]
_ -> do Set TypeRep
reps <- RWST () [Put] (Set TypeRep) PutM (Set TypeRep)
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
RWS.get
let typ :: TypeRep
typ = a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a
Bool
-> RWST () [Put] (Set TypeRep) PutM ()
-> RWST () [Put] (Set TypeRep) PutM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (TypeRep -> Set TypeRep -> Bool
forall a. Ord a => a -> Set a -> Bool
member TypeRep
typ Set TypeRep
reps)) (RWST () [Put] (Set TypeRep) PutM ()
-> RWST () [Put] (Set TypeRep) PutM ())
-> RWST () [Put] (Set TypeRep) PutM ()
-> RWST () [Put] (Set TypeRep) PutM ()
forall a b. (a -> b) -> a -> b
$ do
Put -> RWST () [Put] (Set TypeRep) PutM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Putter (Version a)
forall t. Serialize t => Putter t
put (Proxy a -> Version a
forall a. SafeCopy a => Proxy a -> Version a
versionFromProxy Proxy a
proxy))
(Set TypeRep -> Set TypeRep) -> RWST () [Put] (Set TypeRep) PutM ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
RWS.modify (TypeRep -> Set TypeRep -> Set TypeRep
forall a. Ord a => a -> Set a -> Set a
Set.insert TypeRep
typ)
[Put] -> RWST () [Put] (Set TypeRep) PutM ()
forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
tell [Contained Put -> Put
forall a. Contained a -> a
unsafeUnPack (a -> Contained Put
cput (a -> Contained Put) -> a -> Contained Put
forall a b. (a -> b) -> a -> b
$ a -> Proxy a -> a
forall a. a -> Proxy a -> a
asProxyType a
a Proxy a
proxy)]
where proxy :: Proxy a
proxy = Proxy a
forall a. Proxy a
Proxy :: Proxy a
type GSafeCopy a = (SafeCopy' a, Generic a, GPutCopy (Rep a) DatatypeInfo, Constructors a)
safePutGeneric :: forall a. GSafeCopy a => a -> Put
safePutGeneric :: a -> Put
safePutGeneric a :: a
a = do
Put
putter <- ([Put] -> Put
forall a. Monoid a => [a] -> a
mconcat ([Put] -> Put) -> (((), [Put]) -> [Put]) -> ((), [Put]) -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), [Put]) -> [Put]
forall a b. (a, b) -> b
snd) (((), [Put]) -> Put) -> PutM ((), [Put]) -> PutM Put
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST () [Put] (Set TypeRep) PutM ()
-> () -> Set TypeRep -> PutM ((), [Put])
forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> r -> s -> m (a, w)
evalRWST ((a -> Contained Put) -> a -> RWST () [Put] (Set TypeRep) PutM ()
forall a.
SafeCopy' a =>
(a -> Contained Put) -> a -> RWST () [Put] (Set TypeRep) PutM ()
getSafePutGeneric a -> Contained Put
forall a. GSafeCopy a => a -> Contained Put
putCopyDefault a
a) () Set TypeRep
forall a. Monoid a => a
mempty
Put
putter
putCopyDefault :: forall a. GSafeCopy a => a -> Contained Put
putCopyDefault :: a -> Contained Put
putCopyDefault a :: a
a = (Put -> Contained Put
forall a. a -> Contained a
contain (Put -> Contained Put) -> (a -> Put) -> a -> Contained Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeInfo -> Rep a DatatypeInfo -> Put
forall (f :: * -> *) p. GPutCopy f p => p -> f p -> Put
gputCopy (Word8 -> Word8 -> DatatypeInfo
ConstructorInfo (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Constructors a => Int
forall a. Constructors a => Int
gconNum @a)) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int
forall a. Constructors a => a -> Int
gconIndex a
a))) (Rep a DatatypeInfo -> Put)
-> (a -> Rep a DatatypeInfo) -> a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a DatatypeInfo
forall a x. Generic a => a -> Rep a x
from) a
a
constructGetterFromVersion :: SafeCopy a => Version a -> Kind a -> Either String (Get a)
constructGetterFromVersion :: Version a -> Kind a -> Either String (Get a)
constructGetterFromVersion diskVersion :: Version a
diskVersion orig_kind :: Kind a
orig_kind =
Bool -> Version a -> Kind a -> Either String (Get a)
forall a.
SafeCopy a =>
Bool -> Version a -> Kind a -> Either String (Get a)
worker Bool
False Version a
diskVersion Kind a
orig_kind
where
worker :: forall a. SafeCopy a => Bool -> Version a -> Kind a -> Either String (Get a)
worker :: Bool -> Version a -> Kind a -> Either String (Get a)
worker fwd :: Bool
fwd thisVersion :: Version a
thisVersion thisKind :: Kind a
thisKind
| Version a
forall a. SafeCopy a => Version a
version Version a -> Version a -> Bool
forall a. Eq a => a -> a -> Bool
== Version a
thisVersion = Get a -> Either String (Get a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Get a -> Either String (Get a)) -> Get a -> Either String (Get a)
forall a b. (a -> b) -> a -> b
$ Contained (Get a) -> Get a
forall a. Contained a -> a
unsafeUnPack Contained (Get a)
forall a. SafeCopy a => Contained (Get a)
getCopy
| Bool
otherwise =
case Kind a
thisKind of
Primitive -> String -> Either String (Get a)
forall a b. a -> Either a b
Left (String -> Either String (Get a))
-> String -> Either String (Get a)
forall a b. (a -> b) -> a -> b
$ Kind a -> ShowS
forall a. SafeCopy a => Kind a -> ShowS
errorMsg Kind a
thisKind "Cannot migrate from primitive types."
Base -> String -> Either String (Get a)
forall a b. a -> Either a b
Left (String -> Either String (Get a))
-> String -> Either String (Get a)
forall a b. (a -> b) -> a -> b
$ Kind a -> ShowS
forall a. SafeCopy a => Kind a -> ShowS
errorMsg Kind a
thisKind String
versionNotFound
Extends b_proxy :: Proxy (MigrateFrom a)
b_proxy -> do
Get (MigrateFrom a)
previousGetter <- Bool
-> Version (MigrateFrom a)
-> Kind (MigrateFrom a)
-> Either String (Get (MigrateFrom a))
forall a.
SafeCopy a =>
Bool -> Version a -> Kind a -> Either String (Get a)
worker Bool
fwd (Version a -> Version (MigrateFrom a)
forall a b. Version a -> Version b
castVersion Version a
diskVersion) (Proxy (MigrateFrom a) -> Kind (MigrateFrom a)
forall a. SafeCopy a => Proxy a -> Kind a
kindFromProxy Proxy (MigrateFrom a)
b_proxy)
Get a -> Either String (Get a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Get a -> Either String (Get a)) -> Get a -> Either String (Get a)
forall a b. (a -> b) -> a -> b
$ (MigrateFrom a -> a) -> Get (MigrateFrom a) -> Get a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MigrateFrom a -> a
forall a. Migrate a => MigrateFrom a -> a
migrate Get (MigrateFrom a)
previousGetter
Extended{} | Bool
fwd -> String -> Either String (Get a)
forall a b. a -> Either a b
Left (String -> Either String (Get a))
-> String -> Either String (Get a)
forall a b. (a -> b) -> a -> b
$ Kind a -> ShowS
forall a. SafeCopy a => Kind a -> ShowS
errorMsg Kind a
thisKind String
versionNotFound
Extended a_kind :: Kind a
a_kind -> do
let rev_proxy :: Proxy (MigrateFrom (Reverse a))
rev_proxy :: Proxy (MigrateFrom (Reverse a))
rev_proxy = Proxy (MigrateFrom (Reverse a))
forall a. Proxy a
Proxy
forwardGetter :: Either String (Get a)
forwardGetter :: Either String (Get a)
forwardGetter = (Get (MigrateFrom (Reverse a)) -> Get a)
-> Either String (Get (MigrateFrom (Reverse a)))
-> Either String (Get a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((MigrateFrom (Reverse a) -> a)
-> Get (MigrateFrom (Reverse a)) -> Get a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Reverse a -> a
forall a. Reverse a -> a
unReverse (Reverse a -> a)
-> (MigrateFrom (Reverse a) -> Reverse a)
-> MigrateFrom (Reverse a)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrateFrom (Reverse a) -> Reverse a
forall a. Migrate a => MigrateFrom a -> a
migrate)) (Either String (Get (MigrateFrom (Reverse a)))
-> Either String (Get a))
-> Either String (Get (MigrateFrom (Reverse a)))
-> Either String (Get a)
forall a b. (a -> b) -> a -> b
$ Bool
-> Version (MigrateFrom (Reverse a))
-> Kind (MigrateFrom (Reverse a))
-> Either String (Get (MigrateFrom (Reverse a)))
forall a.
SafeCopy a =>
Bool -> Version a -> Kind a -> Either String (Get a)
worker Bool
True (Version a -> Version (MigrateFrom (Reverse a))
forall a b. Version a -> Version b
castVersion Version a
thisVersion) (Proxy (MigrateFrom (Reverse a)) -> Kind (MigrateFrom (Reverse a))
forall a. SafeCopy a => Proxy a -> Kind a
kindFromProxy Proxy (MigrateFrom (Reverse a))
rev_proxy)
previousGetter :: Either String (Get a)
previousGetter :: Either String (Get a)
previousGetter = Bool -> Version a -> Kind a -> Either String (Get a)
forall a.
SafeCopy a =>
Bool -> Version a -> Kind a -> Either String (Get a)
worker Bool
fwd (Version a -> Version a
forall a b. Version a -> Version b
castVersion Version a
thisVersion) Kind a
a_kind
case Either String (Get a)
forwardGetter of
Left{} -> Either String (Get a)
previousGetter
Right val :: Get a
val -> Get a -> Either String (Get a)
forall a b. b -> Either a b
Right Get a
val
versionNotFound :: String
versionNotFound = "Cannot find getter associated with this version number: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version a -> String
forall a. Show a => a -> String
show Version a
diskVersion
errorMsg :: Kind a -> ShowS
errorMsg fail_kind :: Kind a
fail_kind msg :: String
msg =
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "safecopy: "
, Proxy a -> String
forall a. SafeCopy a => Proxy a -> String
errorTypeName (Kind a -> Proxy a
forall a. Kind a -> Proxy a
proxyFromKind Kind a
fail_kind)
, ": "
, String
msg
]
safeGet :: SafeCopy a => Get a
safeGet :: Get a
safeGet
= Get (Get a) -> Get a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Get (Get a)
forall a. SafeCopy a => Get (Get a)
getSafeGet
getSafeGet :: forall a. SafeCopy a => Get (Get a)
getSafeGet :: Get (Get a)
getSafeGet
= Proxy a -> Get (Get a) -> Get (Get a)
forall a (m :: * -> *) b.
(SafeCopy a, MonadFail m) =>
Proxy a -> m b -> m b
checkConsistency Proxy a
proxy (Get (Get a) -> Get (Get a)) -> Get (Get a) -> Get (Get a)
forall a b. (a -> b) -> a -> b
$
case Proxy a -> Kind a
forall a. SafeCopy a => Proxy a -> Kind a
kindFromProxy Proxy a
proxy of
Primitive -> Get a -> Get (Get a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Get a -> Get (Get a)) -> Get a -> Get (Get a)
forall a b. (a -> b) -> a -> b
$ Contained (Get a) -> Get a
forall a. Contained a -> a
unsafeUnPack Contained (Get a)
forall a. SafeCopy a => Contained (Get a)
getCopy
a_kind :: Kind a
a_kind -> do Version a
v <- Get (Version a)
forall t. Serialize t => Get t
get
case Version a -> Kind a -> Either String (Get a)
forall a.
SafeCopy a =>
Version a -> Kind a -> Either String (Get a)
constructGetterFromVersion Version a
v Kind a
a_kind of
Right getter :: Get a
getter -> Get a -> Get (Get a)
forall (m :: * -> *) a. Monad m => a -> m a
return Get a
getter
Left msg :: String
msg -> String -> Get (Get a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
where proxy :: Proxy a
proxy = Proxy a
forall a. Proxy a
Proxy :: Proxy a
safePut :: SafeCopy a => a -> Put
safePut :: a -> Put
safePut a :: a
a
= do a -> Put
putter <- PutM (a -> Put)
forall a. SafeCopy a => PutM (a -> Put)
getSafePut
a -> Put
putter a
a
getSafePut :: forall a. SafeCopy a => PutM (a -> Put)
getSafePut :: PutM (a -> Put)
getSafePut
= Proxy a -> PutM (a -> Put) -> PutM (a -> Put)
forall a b. SafeCopy a => Proxy a -> b -> b
unpureCheckConsistency Proxy a
proxy (PutM (a -> Put) -> PutM (a -> Put))
-> PutM (a -> Put) -> PutM (a -> Put)
forall a b. (a -> b) -> a -> b
$
case Proxy a -> Kind a
forall a. SafeCopy a => Proxy a -> Kind a
kindFromProxy Proxy a
proxy of
Primitive -> (a -> Put) -> PutM (a -> Put)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> Put) -> PutM (a -> Put)) -> (a -> Put) -> PutM (a -> Put)
forall a b. (a -> b) -> a -> b
$ \a :: a
a -> Contained Put -> Put
forall a. Contained a -> a
unsafeUnPack (a -> Contained Put
forall a. SafeCopy a => a -> Contained Put
putCopy (a -> Contained Put) -> a -> Contained Put
forall a b. (a -> b) -> a -> b
$ a -> Proxy a -> a
forall a. a -> Proxy a -> a
asProxyType a
a Proxy a
proxy)
_ -> do Putter (Version a)
forall t. Serialize t => Putter t
put (Proxy a -> Version a
forall a. SafeCopy a => Proxy a -> Version a
versionFromProxy Proxy a
proxy)
(a -> Put) -> PutM (a -> Put)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> Put) -> PutM (a -> Put)) -> (a -> Put) -> PutM (a -> Put)
forall a b. (a -> b) -> a -> b
$ \a :: a
a -> Contained Put -> Put
forall a. Contained a -> a
unsafeUnPack (a -> Contained Put
forall a. SafeCopy a => a -> Contained Put
putCopy (a -> Contained Put) -> a -> Contained Put
forall a b. (a -> b) -> a -> b
$ a -> Proxy a -> a
forall a. a -> Proxy a -> a
asProxyType a
a Proxy a
proxy)
where proxy :: Proxy a
proxy = Proxy a
forall a. Proxy a
Proxy :: Proxy a
extended_extension :: (Migrate a, Migrate (Reverse a)) => Kind a
extended_extension :: Kind a
extended_extension = Kind a -> Kind a
forall a. Migrate (Reverse a) => Kind a -> Kind a
Extended Kind a
forall a. Migrate a => Kind a
extension
extended_base :: (Migrate (Reverse a)) => Kind a
extended_base :: Kind a
extended_base = Kind a -> Kind a
forall a. Migrate (Reverse a) => Kind a -> Kind a
Extended Kind a
forall a. Kind a
base
extension :: Migrate a => Kind a
extension :: Kind a
extension = Proxy (MigrateFrom a) -> Kind a
forall a. Migrate a => Proxy (MigrateFrom a) -> Kind a
Extends Proxy (MigrateFrom a)
forall a. Proxy a
Proxy
base :: Kind a
base :: Kind a
base = Kind a
forall a. Kind a
Base
primitive :: Kind a
primitive :: Kind a
primitive = Kind a
forall a. Kind a
Primitive
newtype Version a = Version {Version a -> Int32
unVersion :: Int32} deriving (ReadPrec [Version a]
ReadPrec (Version a)
Int -> ReadS (Version a)
ReadS [Version a]
(Int -> ReadS (Version a))
-> ReadS [Version a]
-> ReadPrec (Version a)
-> ReadPrec [Version a]
-> Read (Version a)
forall a. ReadPrec [Version a]
forall a. ReadPrec (Version a)
forall a. Int -> ReadS (Version a)
forall a. ReadS [Version a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Version a]
$creadListPrec :: forall a. ReadPrec [Version a]
readPrec :: ReadPrec (Version a)
$creadPrec :: forall a. ReadPrec (Version a)
readList :: ReadS [Version a]
$creadList :: forall a. ReadS [Version a]
readsPrec :: Int -> ReadS (Version a)
$creadsPrec :: forall a. Int -> ReadS (Version a)
Read,Int -> Version a -> ShowS
[Version a] -> ShowS
Version a -> String
(Int -> Version a -> ShowS)
-> (Version a -> String)
-> ([Version a] -> ShowS)
-> Show (Version a)
forall a. Int -> Version a -> ShowS
forall a. [Version a] -> ShowS
forall a. Version a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Version a] -> ShowS
$cshowList :: forall a. [Version a] -> ShowS
show :: Version a -> String
$cshow :: forall a. Version a -> String
showsPrec :: Int -> Version a -> ShowS
$cshowsPrec :: forall a. Int -> Version a -> ShowS
Show,Version a -> Version a -> Bool
(Version a -> Version a -> Bool)
-> (Version a -> Version a -> Bool) -> Eq (Version a)
forall a. Version a -> Version a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Version a -> Version a -> Bool
$c/= :: forall a. Version a -> Version a -> Bool
== :: Version a -> Version a -> Bool
$c== :: forall a. Version a -> Version a -> Bool
Eq)
castVersion :: Version a -> Version b
castVersion :: Version a -> Version b
castVersion (Version a :: Int32
a) = Int32 -> Version b
forall a. Int32 -> Version a
Version Int32
a
instance Num (Version a) where
Version a :: Int32
a + :: Version a -> Version a -> Version a
+ Version b :: Int32
b = Int32 -> Version a
forall a. Int32 -> Version a
Version (Int32
aInt32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+Int32
b)
Version a :: Int32
a - :: Version a -> Version a -> Version a
- Version b :: Int32
b = Int32 -> Version a
forall a. Int32 -> Version a
Version (Int32
aInt32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
-Int32
b)
Version a :: Int32
a * :: Version a -> Version a -> Version a
* Version b :: Int32
b = Int32 -> Version a
forall a. Int32 -> Version a
Version (Int32
aInt32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
*Int32
b)
negate :: Version a -> Version a
negate (Version a :: Int32
a) = Int32 -> Version a
forall a. Int32 -> Version a
Version (Int32 -> Int32
forall a. Num a => a -> a
negate Int32
a)
abs :: Version a -> Version a
abs (Version a :: Int32
a) = Int32 -> Version a
forall a. Int32 -> Version a
Version (Int32 -> Int32
forall a. Num a => a -> a
abs Int32
a)
signum :: Version a -> Version a
signum (Version a :: Int32
a) = Int32 -> Version a
forall a. Int32 -> Version a
Version (Int32 -> Int32
forall a. Num a => a -> a
signum Int32
a)
fromInteger :: Integer -> Version a
fromInteger i :: Integer
i = Int32 -> Version a
forall a. Int32 -> Version a
Version (Integer -> Int32
forall a. Num a => Integer -> a
fromInteger Integer
i)
instance Serialize (Version a) where
get :: Get (Version a)
get = (Int32 -> Version a) -> Get Int32 -> Get (Version a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int32 -> Version a
forall a. Int32 -> Version a
Version Get Int32
forall t. Serialize t => Get t
get
put :: Putter (Version a)
put = Putter Int32
forall t. Serialize t => Putter t
put Putter Int32 -> (Version a -> Int32) -> Putter (Version a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version a -> Int32
forall a. Version a -> Int32
unVersion
newtype Contained a = Contained {Contained a -> a
unsafeUnPack :: a}
contain :: a -> Contained a
contain :: a -> Contained a
contain = a -> Contained a
forall a. a -> Contained a
Contained
data Profile a =
PrimitiveProfile |
InvalidProfile String |
Profile
{ Profile a -> Int32
profileCurrentVersion :: Int32
, Profile a -> [Int32]
profileSupportedVersions :: [Int32]
} deriving (Int -> Profile a -> ShowS
[Profile a] -> ShowS
Profile a -> String
(Int -> Profile a -> ShowS)
-> (Profile a -> String)
-> ([Profile a] -> ShowS)
-> Show (Profile a)
forall a. Int -> Profile a -> ShowS
forall a. [Profile a] -> ShowS
forall a. Profile a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Profile a] -> ShowS
$cshowList :: forall a. [Profile a] -> ShowS
show :: Profile a -> String
$cshow :: forall a. Profile a -> String
showsPrec :: Int -> Profile a -> ShowS
$cshowsPrec :: forall a. Int -> Profile a -> ShowS
Show)
mkProfile :: SafeCopy a => Proxy a -> Profile a
mkProfile :: Proxy a -> Profile a
mkProfile a_proxy :: Proxy a
a_proxy =
case Proxy a -> Consistency a
forall a. SafeCopy a => Proxy a -> Consistency a
computeConsistency Proxy a
a_proxy of
NotConsistent msg :: String
msg -> String -> Profile a
forall a. String -> Profile a
InvalidProfile String
msg
Consistent | Kind a -> Bool
forall a. Kind a -> Bool
isPrimitive (Proxy a -> Kind a
forall a. SafeCopy a => Proxy a -> Kind a
kindFromProxy Proxy a
a_proxy) -> Profile a
forall a. Profile a
PrimitiveProfile
Consistent ->
Profile :: forall a. Int32 -> [Int32] -> Profile a
Profile{ profileCurrentVersion :: Int32
profileCurrentVersion = Version a -> Int32
forall a. Version a -> Int32
unVersion (Proxy a -> Version a
forall a. SafeCopy a => Proxy a -> Version a
versionFromProxy Proxy a
a_proxy)
, profileSupportedVersions :: [Int32]
profileSupportedVersions = Proxy a -> [Int32]
forall a. SafeCopy a => Proxy a -> [Int32]
availableVersions Proxy a
a_proxy
}
data Consistency a = Consistent | NotConsistent String
availableVersions :: SafeCopy a => Proxy a -> [Int32]
availableVersions :: Proxy a -> [Int32]
availableVersions a_proxy :: Proxy a
a_proxy =
Bool -> Kind a -> [Int32]
forall b. SafeCopy b => Bool -> Kind b -> [Int32]
worker Bool
True (Proxy a -> Kind a
forall a. SafeCopy a => Proxy a -> Kind a
kindFromProxy Proxy a
a_proxy)
where
worker :: SafeCopy b => Bool -> Kind b -> [Int32]
worker :: Bool -> Kind b -> [Int32]
worker fwd :: Bool
fwd b_kind :: Kind b
b_kind =
case Kind b
b_kind of
Primitive -> []
Base -> [Version b -> Int32
forall a. Version a -> Int32
unVersion (Kind b -> Version b
forall a. SafeCopy a => Kind a -> Version a
versionFromKind Kind b
b_kind)]
Extends b_proxy :: Proxy (MigrateFrom b)
b_proxy -> Version b -> Int32
forall a. Version a -> Int32
unVersion (Kind b -> Version b
forall a. SafeCopy a => Kind a -> Version a
versionFromKind Kind b
b_kind) Int32 -> [Int32] -> [Int32]
forall a. a -> [a] -> [a]
: Bool -> Kind (MigrateFrom b) -> [Int32]
forall b. SafeCopy b => Bool -> Kind b -> [Int32]
worker Bool
False (Proxy (MigrateFrom b) -> Kind (MigrateFrom b)
forall a. SafeCopy a => Proxy a -> Kind a
kindFromProxy Proxy (MigrateFrom b)
b_proxy)
Extended sub_kind :: Kind b
sub_kind | Bool
fwd -> Bool -> Kind (MigrateFrom (Reverse b)) -> [Int32]
forall b. SafeCopy b => Bool -> Kind b -> [Int32]
worker Bool
False (Kind b -> Kind (MigrateFrom (Reverse b))
forall a.
Migrate (Reverse a) =>
Kind a -> Kind (MigrateFrom (Reverse a))
getForwardKind Kind b
sub_kind)
Extended sub_kind :: Kind b
sub_kind -> Bool -> Kind b -> [Int32]
forall b. SafeCopy b => Bool -> Kind b -> [Int32]
worker Bool
False Kind b
sub_kind
getForwardKind :: (Migrate (Reverse a)) => Kind a -> Kind (MigrateFrom (Reverse a))
getForwardKind :: Kind a -> Kind (MigrateFrom (Reverse a))
getForwardKind _ = Kind (MigrateFrom (Reverse a))
forall a. SafeCopy a => Kind a
kind
validChain :: SafeCopy a => Proxy a -> Bool
validChain :: Proxy a -> Bool
validChain a_proxy :: Proxy a
a_proxy =
Kind a -> Bool
forall a. Kind a -> Bool
worker (Proxy a -> Kind a
forall a. SafeCopy a => Proxy a -> Kind a
kindFromProxy Proxy a
a_proxy)
where
worker :: Kind a -> Bool
worker Primitive = Bool
True
worker Base = Bool
True
worker (Extends b_proxy :: Proxy (MigrateFrom a)
b_proxy) = Kind (MigrateFrom a) -> Bool
forall b. SafeCopy b => Kind b -> Bool
check (Proxy (MigrateFrom a) -> Kind (MigrateFrom a)
forall a. SafeCopy a => Proxy a -> Kind a
kindFromProxy Proxy (MigrateFrom a)
b_proxy)
worker (Extended a_kind :: Kind a
a_kind) = Kind a -> Bool
worker Kind a
a_kind
check :: SafeCopy b => Kind b -> Bool
check :: Kind b -> Bool
check b_kind :: Kind b
b_kind
= case Kind b
b_kind of
Primitive -> Bool
False
Base -> Bool
True
Extends c_proxy :: Proxy (MigrateFrom b)
c_proxy -> Kind (MigrateFrom b) -> Bool
forall b. SafeCopy b => Kind b -> Bool
check (Proxy (MigrateFrom b) -> Kind (MigrateFrom b)
forall a. SafeCopy a => Proxy a -> Kind a
kindFromProxy Proxy (MigrateFrom b)
c_proxy)
Extended sub_kind :: Kind b
sub_kind -> Kind b -> Bool
forall b. SafeCopy b => Kind b -> Bool
check Kind b
sub_kind
checkConsistency :: (SafeCopy a, Fail.MonadFail m) => Proxy a -> m b -> m b
checkConsistency :: Proxy a -> m b -> m b
checkConsistency proxy :: Proxy a
proxy ks :: m b
ks
= case Proxy a -> Consistency a
forall a. SafeCopy a => Proxy a -> Consistency a
consistentFromProxy Proxy a
proxy of
NotConsistent msg :: String
msg -> String -> m b
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
msg
Consistent -> m b
ks
unpureCheckConsistency :: SafeCopy a => Proxy a -> b -> b
unpureCheckConsistency :: Proxy a -> b -> b
unpureCheckConsistency proxy :: Proxy a
proxy ks :: b
ks
= case Proxy a -> Consistency a
forall a. SafeCopy a => Proxy a -> Consistency a
consistentFromProxy Proxy a
proxy of
NotConsistent msg :: String
msg -> String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ "unpureCheckConsistency: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg
Consistent -> b
ks
{-# INLINE computeConsistency #-}
computeConsistency :: SafeCopy a => Proxy a -> Consistency a
computeConsistency :: Proxy a -> Consistency a
computeConsistency proxy :: Proxy a
proxy
| Kind a -> Bool
forall a. Kind a -> Bool
isObviouslyConsistent (Proxy a -> Kind a
forall a. SafeCopy a => Proxy a -> Kind a
kindFromProxy Proxy a
proxy)
= Consistency a
forall a. Consistency a
Consistent
| [Int32]
versions [Int32] -> [Int32] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Int32] -> [Int32]
forall a. Eq a => [a] -> [a]
nub [Int32]
versions
= String -> Consistency a
forall a. String -> Consistency a
NotConsistent (String -> Consistency a) -> String -> Consistency a
forall a b. (a -> b) -> a -> b
$ "Duplicate version tags: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Int32] -> String
forall a. Show a => a -> String
show [Int32]
versions
| Bool -> Bool
not (Proxy a -> Bool
forall a. SafeCopy a => Proxy a -> Bool
validChain Proxy a
proxy)
= String -> Consistency a
forall a. String -> Consistency a
NotConsistent "Primitive types cannot be extended as they have no version tag."
| Bool
otherwise
= Consistency a
forall a. Consistency a
Consistent
where versions :: [Int32]
versions = Proxy a -> [Int32]
forall a. SafeCopy a => Proxy a -> [Int32]
availableVersions Proxy a
proxy
isObviouslyConsistent :: Kind a -> Bool
isObviouslyConsistent :: Kind a -> Bool
isObviouslyConsistent Primitive = Bool
True
isObviouslyConsistent Base = Bool
True
isObviouslyConsistent _ = Bool
False
proxyFromConsistency :: Consistency a -> Proxy a
proxyFromConsistency :: Consistency a -> Proxy a
proxyFromConsistency _ = Proxy a
forall a. Proxy a
Proxy
proxyFromKind :: Kind a -> Proxy a
proxyFromKind :: Kind a -> Proxy a
proxyFromKind _ = Proxy a
forall a. Proxy a
Proxy
consistentFromProxy :: SafeCopy a => Proxy a -> Consistency a
consistentFromProxy :: Proxy a -> Consistency a
consistentFromProxy _ = Consistency a
forall a. SafeCopy a => Consistency a
internalConsistency
versionFromProxy :: SafeCopy a => Proxy a -> Version a
versionFromProxy :: Proxy a -> Version a
versionFromProxy _ = Version a
forall a. SafeCopy a => Version a
version
versionFromKind :: (SafeCopy a) => Kind a -> Version a
versionFromKind :: Kind a -> Version a
versionFromKind _ = Version a
forall a. SafeCopy a => Version a
version
versionFromReverseKind :: (SafeCopy (MigrateFrom (Reverse a))) => Kind a -> Version (MigrateFrom (Reverse a))
versionFromReverseKind :: Kind a -> Version (MigrateFrom (Reverse a))
versionFromReverseKind _ = Version (MigrateFrom (Reverse a))
forall a. SafeCopy a => Version a
version
kindFromProxy :: SafeCopy a => Proxy a -> Kind a
kindFromProxy :: Proxy a -> Kind a
kindFromProxy _ = Kind a
forall a. SafeCopy a => Kind a
kind
data Proxy a = Proxy
mkProxy :: a -> Proxy a
mkProxy :: a -> Proxy a
mkProxy _ = Proxy a
forall a. Proxy a
Proxy
asProxyType :: a -> Proxy a -> a
asProxyType :: a -> Proxy a -> a
asProxyType a :: a
a _ = a
a