{-# 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
-- Copyright   :  PublicDomain
--
-- Maintainer  :  lemmih@gmail.com
-- Portability :  non-portable (uses GHC extensions)
--
-- SafeCopy extends the parsing and serialization capabilities of Data.Binary
-- to include nested version control. Nested version control means that you
-- can change the defintion and binary format of a type nested deep within
-- other types without problems.
--
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)

-- | The central mechanism for dealing with version control.
--
--   This type class specifies what data migrations can happen
--   and how they happen.
class SafeCopy (MigrateFrom a) => Migrate a where
    -- | This is the type we're extending. Each type capable of migration can
    --   only extend one other type.
    type MigrateFrom a

    -- | This method specifies how to migrate from the older type to the newer
    --   one. It will never be necessary to use this function manually as it
    --   all taken care of internally in the library.
    migrate :: MigrateFrom a -> a

-- | This is a wrapper type used migrating backwards in the chain of compatible types.
newtype Reverse a = Reverse { Reverse a -> a
unReverse :: a }

-- | The kind of a data type determines how it is tagged (if at all).
--
--   Primitives kinds (see 'primitive') are not tagged with a version
--   id and hence cannot be extended later.
--
--   Extensions (see 'extension') tell the system that there exists
--   a previous version of the data type which should be migrated if
--   needed.
--
--   There is also a default kind which is neither primitive nor
--   an extension of a previous type.
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 Kind a
Primitive = Bool
True
isPrimitive Kind a
_ = Bool
False

-- | Wrapper for data that was saved without a version tag.
newtype Prim a = Prim { Prim a -> a
getPrimitive :: a }

-- | The centerpiece of this library. Defines a version for a data type
--   together with how it should be serialized/parsed.
--
--   Users should define instances of 'SafeCopy' for their types
--   even though 'getCopy' and 'putCopy' can't be used directly.
--   To serialize/parse a data type using 'SafeCopy', see 'safeGet'
--   and 'safePut'.
class Typeable a => SafeCopy a where
    -- | The version of the type.
    --
    --   Only used as a key so it must be unique (this is checked at run-time)
    --   but doesn't have to be sequential or continuous.
    --
    --   The default version is '0'.
    version :: Version a
    version = Int32 -> Version a
forall a. Int32 -> Version a
Version Int32
0

    -- | The kind specifies how versions are dealt with. By default,
    --   values are tagged with their version id and don't have any
    --   previous versions. See 'extension' and the much less used
    --   'primitive'.
    kind :: Kind a
    kind = Kind a
forall a. Kind a
Base

    -- | This method defines how a value should be parsed without also worrying
    --   about writing out the version tag. This function cannot be used directly.
    --   One should use 'safeGet', instead.
    getCopy  :: Contained (Get a)

    -- | This method defines how a value should be parsed without worrying about
    --   previous versions or migrations. This function cannot be used directly.
    --   One should use 'safePut, instead.
    putCopy  :: a -> Contained Put

    -- | Internal function that should not be overrided.
    --   @Consistent@ iff the version history is consistent
    --   (i.e. there are no duplicate version numbers) and
    --   the chain of migrations is valid.
    --
    --   This function is in the typeclass so that this
    --   information is calculated only once during the program
    --   lifetime, instead of everytime 'safeGet' or 'safePut' is
    --   used.
    internalConsistency :: Consistency a
    internalConsistency = Proxy a -> Consistency a
forall a. SafeCopy a => Proxy a -> Consistency a
computeConsistency Proxy a
forall a. Proxy a
Proxy

    -- | Version profile.
    objectProfile :: Profile a
    objectProfile = Proxy a -> Profile a
forall a. SafeCopy a => Proxy a -> Profile a
mkProfile Proxy a
forall a. Proxy a
Proxy

    -- | The name of the type. This is only used in error message
    -- strings.
    errorTypeName :: Proxy a -> String

    default errorTypeName :: Typeable a => Proxy a -> String
    errorTypeName Proxy a
_ = 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 = (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 (M1 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 (L1 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 (R1 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 #-}

-- | A constraint that combines 'SafeCopy' and 'Typeable'.
type SafeCopy' a = SafeCopy a
{-# DEPRECATED SafeCopy' "SafeCopy' is now equivalent to SafeCopy " #-}

-- To get the current safecopy behavior we need to emulate the
-- template haskell code here - collect the (a -> Put) values for all
-- the fields and then run them in order.o
instance (GPutFields a p, p ~ DatatypeInfo) => GPutCopy (M1 C c a) p where
    gputCopy :: p -> M1 C c a p -> Put
gputCopy p
p (M1 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
>= Word8
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
*>
        -- This is how I tried it first, and it works well but the
        -- result is not the same as deriveSafeCopy.
        -- mconcat (fmap join (gputFields p x))
        -- join (mconcat <$> sequence (fmap snd (gputFields p x)))
      (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 #-}

-- | gputFields traverses the fields of a constructor and returns a put
-- for the safecopy versions and a put for the field values.
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 (f p
a :*: 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 (M1 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 p
_ (K1 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 #-}

-- This corresponds to ggetFields, but does it match deriveSafeCopy?
instance GPutFields U1 p where
    gputFields :: p -> U1 p -> RWST () [Put] (Set TypeRep) PutM ()
gputFields p
_ U1 p
_ =
      () -> RWST () [Put] (Set TypeRep) PutM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-
-- This outputs the version tag for (), which is 1.
instance (GPutFields (K1 R ()) p) => GPutFields U1 p where
    gputFields p _ =
      gputFields p (K1 () :: K1 R () p)
-}
    {-# INLINE gputFields #-}

instance GPutFields V1 p where
    gputFields :: p -> V1 p -> RWST () [Put] (Set TypeRep) PutM ()
gputFields p
_ V1 p
_ = RWST () [Put] (Set TypeRep) PutM ()
forall a. HasCallStack => a
undefined
    {-# INLINE gputFields #-}

------------------------------------------------------------------------

class GGetCopy f p where
    ggetCopy :: p -> Get (f a)

-- | The M1 type has a fourth type parameter p:
--
--     newtype M1 i (c :: Meta) (f :: k -> *) (p :: k) = M1 {unM1 :: f p}
--
-- Note that the type of the M1 field is @f p@, so in order to express this
-- type we add a parameter of type p that we can apply to values of type f.
instance (GGetCopy f p, p ~ DatatypeInfo) => GGetCopy (M1 D d f) p where
    ggetCopy :: p -> Get (M1 D d f a)
ggetCopy p
p
      | DatatypeInfo -> Word8
_size p
DatatypeInfo
p Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
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) Word8
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 = do
      -- choose the left or right branch of the constructor types
      -- based on whether the code is in the left or right half of the
      -- remaining constructor count.
      let sizeL :: Word8
sizeL = DatatypeInfo -> Word8
_size p
DatatypeInfo
p Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` Int
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
        Bool
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))
        Bool
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 = 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 #-}

-- append constructor fields
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 = 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 = 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 p
_ = 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 = 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 = 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

-- | Whereas the other 'getSafeGet' is only run when we know we need a
-- version, this one is run for every field and must decide whether to
-- read a version or not.  It constructs a Map TypeRep Int32 and reads
-- when the new TypeRep is not in the map.
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
        Kind a
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
        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 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 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

-- | This version returns (Put, Put), the collected version tags and
-- the collected serialized fields.  The original 'getSafePut' result
-- type prevents doing this because each fields may have a different
-- type.  Maybe you can show me a better way
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 a -> Contained Put
cput 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
        Kind a
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)]
        Kind a
_         -> 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)

-- | Generic only version of safePut. Instead of calling 'putCopy' it
-- calls 'putCopyDefault', a copy of the implementation of the
-- 'SafeCopy' default method for 'putCopy'.
safePutGeneric :: forall a. GSafeCopy a => a -> Put
safePutGeneric :: a -> Put
safePutGeneric 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

-- | See 'safePutGeneric'.  A copy of the code in the default
-- implementation of the putCopy method.
putCopyDefault :: forall a. GSafeCopy a => a -> Contained Put
putCopyDefault :: a -> Contained Put
putCopyDefault 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 (MigrateFrom (Reverse a)) -> Get (Get a)
constructGetterFromVersion :: SafeCopy a => Version a -> Kind a -> Either String (Get a)
constructGetterFromVersion :: Version a -> Kind a -> Either String (Get a)
constructGetterFromVersion Version a
diskVersion 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 Bool
fwd Version a
thisVersion 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
          Kind a
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 String
"Cannot migrate from primitive types."
          Kind a
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 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 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 Get a
val -> Get a -> Either String (Get a)
forall a b. b -> Either a b
Right Get a
val
    versionNotFound :: String
versionNotFound   = String
"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 Kind a
fail_kind String
msg =
        [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
         [ String
"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
": "
         , String
msg
         ]

-------------------------------------------------
-- The public interface. These functions are used
-- to parse/serialize and to create new parsers &
-- serialisers.

-- | Parse a version tagged data type and then migrate it to the desired type.
--   Any serialized value has been extended by the return type can be parsed.
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

-- | Parse a version tag and return the corresponding migrated parser. This is
--   useful when you can prove that multiple values have the same version.
--   See 'getSafePut'.
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
        Kind a
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
        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 Get a
getter -> Get a -> Get (Get a)
forall (m :: * -> *) a. Monad m => a -> m a
return Get a
getter
                          Left 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

-- | Serialize a data type by first writing out its version tag. This is much
--   simpler than the corresponding 'safeGet' since previous versions don't
--   come into play.
safePut :: SafeCopy a => a -> Put
safePut :: a -> Put
safePut a
a
    = do a -> Put
putter <- PutM (a -> Put)
forall a. SafeCopy a => PutM (a -> Put)
getSafePut
         a -> Put
putter a
a

-- | Serialize the version tag and return the associated putter. This is useful
--   when serializing multiple values with the same version. See 'getSafeGet'.
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
        Kind a
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 -> 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)
        Kind a
_         -> 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 -> 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

-- | The extended_extension kind lets the system know that there is
--   at least one previous and one future version of this type.
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

-- | The extended_base kind lets the system know that there is
--   at least one future version of this type.
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

-- | The extension kind lets the system know that there is
--   at least one previous version of this type. A given data type
--   can only extend a single other data type. However, it is
--   perfectly fine to build chains of extensions. The migrations
--   between each step is handled automatically.
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

-- | The default kind. Does not extend any type.
base :: Kind a
base :: Kind a
base = Kind a
forall a. Kind a
Base

-- | Primitive kinds aren't version tagged. This kind is used for small or built-in
--   types that won't change such as 'Int' or 'Bool'.
primitive :: Kind a
primitive :: Kind a
primitive = Kind a
forall a. Kind a
Primitive

-------------------------------------------------
-- Data type versions. Essentially just a unique
-- identifier used to lookup the corresponding
-- parser function.

-- | A simple numeric version id.
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 Int32
a) = Int32 -> Version b
forall a. Int32 -> Version a
Version Int32
a

instance Num (Version a) where
    Version Int32
a + :: Version a -> Version a -> Version a
+ Version 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 Int32
a - :: Version a -> Version a -> Version a
- Version 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 Int32
a * :: Version a -> Version a -> Version a
* Version 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 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 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 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 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

-------------------------------------------------
-- Container type to control the access to the
-- parsers/putters.

-- | To ensure that no-one reads or writes values without handling versions
--   correctly, it is necessary to restrict access to 'getCopy' and 'putCopy'.
--   This is where 'Contained' enters the picture. It allows you to put
--   values in to a container but not to take them out again.
newtype Contained a = Contained {Contained a -> a
unsafeUnPack :: a}

-- | Place a value in an unbreakable container.
contain :: a -> Contained a
contain :: a -> Contained a
contain = a -> Contained a
forall a. a -> Contained a
Contained

-------------------------------------------------
-- Consistency checking

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 Proxy a
a_proxy =
  case Proxy a -> Consistency a
forall a. SafeCopy a => Proxy a -> Consistency a
computeConsistency Proxy a
a_proxy of
    NotConsistent String
msg -> String -> Profile a
forall a. String -> Profile a
InvalidProfile String
msg
    Consistency a
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
    Consistency a
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 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 Bool
fwd Kind b
b_kind =
      case Kind b
b_kind of
        Kind b
Primitive         -> []
        Kind b
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 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 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 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 a
_ = Kind (MigrateFrom (Reverse a))
forall a. SafeCopy a => Kind a
kind

-- Extend chains must end in a Base kind. Ending in a Primitive is an error.
validChain :: SafeCopy a => Proxy a -> Bool
validChain :: Proxy a -> Bool
validChain 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 Kind a
Primitive         = Bool
True
    worker Kind a
Base              = Bool
True
    worker (Extends 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 Kind a
a_kind)   = Kind a -> Bool
worker Kind a
a_kind
    check :: SafeCopy b => Kind b -> Bool
    check :: Kind b -> Bool
check Kind b
b_kind
              = case Kind b
b_kind of
                  Kind b
Primitive       -> Bool
False
                  Kind b
Base            -> Bool
True
                  Extends 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 Kind b
sub_kind   -> Kind b -> Bool
forall b. SafeCopy b => Kind b -> Bool
check Kind b
sub_kind

-- Verify that the SafeCopy instance is consistent.
checkConsistency :: (SafeCopy a, Fail.MonadFail m) => Proxy a -> m b -> m b
checkConsistency :: Proxy a -> m b -> m b
checkConsistency Proxy a
proxy m b
ks
    = case Proxy a -> Consistency a
forall a. SafeCopy a => Proxy a -> Consistency a
consistentFromProxy Proxy a
proxy of
        NotConsistent String
msg -> String -> m b
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
msg
        Consistency a
Consistent        -> m b
ks

-- | PutM doesn't have reasonable 'fail' implementation.
-- It just throws an unpure exception anyway.
unpureCheckConsistency :: SafeCopy a => Proxy a -> b -> b
unpureCheckConsistency :: Proxy a -> b -> b
unpureCheckConsistency Proxy a
proxy b
ks
    = case Proxy a -> Consistency a
forall a. SafeCopy a => Proxy a -> Consistency a
consistentFromProxy Proxy a
proxy of
        NotConsistent String
msg -> String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ String
"unpureCheckConsistency: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg
        Consistency a
Consistent        -> b
ks

{-# INLINE computeConsistency #-}
computeConsistency :: forall a. SafeCopy a => Proxy a -> Consistency a
computeConsistency :: Proxy a -> Consistency a
computeConsistency Proxy a
proxy
    -- Match a few common cases before falling through to the general case.
    -- This allows use to generate nearly all consistencies at compile-time.
    | 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
$ String
"Duplicate version tags for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ 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)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " 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 String
"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 Kind a
Primitive = Bool
True
isObviouslyConsistent Kind a
Base      = Bool
True
isObviouslyConsistent Kind a
_         = Bool
False

-------------------------------------------------
-- Small utility functions that mean we don't
-- have to depend on ScopedTypeVariables.

proxyFromConsistency :: Consistency a -> Proxy a
proxyFromConsistency :: Consistency a -> Proxy a
proxyFromConsistency Consistency a
_ = Proxy a
forall a. Proxy a
Proxy

proxyFromKind :: Kind a -> Proxy a
proxyFromKind :: Kind a -> Proxy a
proxyFromKind Kind a
_ = Proxy a
forall a. Proxy a
Proxy

consistentFromProxy :: SafeCopy a => Proxy a -> Consistency a
consistentFromProxy :: Proxy a -> Consistency a
consistentFromProxy Proxy a
_ = Consistency a
forall a. SafeCopy a => Consistency a
internalConsistency

versionFromProxy :: SafeCopy a => Proxy a -> Version a
versionFromProxy :: Proxy a -> Version a
versionFromProxy Proxy a
_ = Version a
forall a. SafeCopy a => Version a
version

versionFromKind :: (SafeCopy a) => Kind a -> Version a
versionFromKind :: Kind a -> Version a
versionFromKind Kind a
_ = 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 Kind a
_ = Version (MigrateFrom (Reverse a))
forall a. SafeCopy a => Version a
version

kindFromProxy :: SafeCopy a => Proxy a -> Kind a
kindFromProxy :: Proxy a -> Kind a
kindFromProxy Proxy a
_ = Kind a
forall a. SafeCopy a => Kind a
kind

-------------------------------------------------
-- Type proxies

data Proxy a = Proxy

mkProxy :: a -> Proxy a
mkProxy :: a -> Proxy a
mkProxy a
_ = Proxy a
forall a. Proxy a
Proxy

asProxyType :: a -> Proxy a -> a
asProxyType :: a -> Proxy a -> a
asProxyType a
a Proxy a
_ = a
a