{-# 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') tells 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 is
--   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 Primitive = Bool
True
isPrimitive _ = 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 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 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 'safeGet', 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 _ = 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 #-}

-- | A constraint that combines 'SafeCopy' and 'Typeable'.
type SafeCopy' a = (SafeCopy a, Typeable a)

-- 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
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
*>
        -- 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
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 #-}

-- This corresponds to ggetFields, but does it match deriveSafeCopy?
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 ()
{-
-- 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 _ _ = 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
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
      -- 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` 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 #-}

-- 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
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

-- | 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
-- whent he 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
        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

-- | 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 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)

-- | 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
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
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 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
         ]

-------------------------------------------------
-- 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
        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

-- | 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
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
        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

-- | 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 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

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

-- | To ensure that no-one reads or writes values without handling versions
--   correct, 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 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

-- 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 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

-- 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 :: 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

-- | PutM doesn't have reasonable 'fail' implementation.
-- It just throws unpure exception anyway.
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
    -- 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
$ "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

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

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

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

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