{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
-- | This module provides utilities which help ensure that we aren't
-- attempting to de-serialize data that is an older or newer version.
-- The 'WithVersion' utility wraps up a datatype along with a version
-- tag. This version tag can either be provided by the user
-- ('namedVersionConfig'), or use a computed hash
-- ('hashedVersionConfig').
--
-- The magic here is using an SYB traversal ('Data') to get the
-- structure of all the data-types involved. This info is rendered to
-- text and hashed to yield a hash which describes it.
--
-- NOTE that this API is still quite new and so is likely to break
-- compatibility in the future. It should also be expected that the
-- computed hashes may change between major version bumps, though this
-- will be minimized when directly feasible.
module Data.Store.Version
    ( StoreVersion(..)
    , VersionConfig(..)
    , hashedVersionConfig
    , namedVersionConfig
    , encodeWithVersionQ
    , decodeWithVersionQ
    ) where

import           Control.Monad
import           Control.Monad.Trans.State
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64.URL as B64Url
import qualified Data.ByteString.Char8 as BS8
import           Data.Generics hiding (DataType, Generic)
import qualified Data.Map as M
import qualified Data.Set as S
import           Data.Store.Internal
import qualified Data.Text as T
import           Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With)
import           Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.IO as T
import           Data.Word (Word32)
import           GHC.Generics (Generic)
import           Language.Haskell.TH
import           System.Directory
import           System.Environment
import           System.FilePath
import           TH.RelativePaths
import           TH.Utilities

newtype StoreVersion = StoreVersion { StoreVersion -> ByteString
unStoreVersion :: BS.ByteString }
    deriving (StoreVersion -> StoreVersion -> Bool
(StoreVersion -> StoreVersion -> Bool)
-> (StoreVersion -> StoreVersion -> Bool) -> Eq StoreVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StoreVersion -> StoreVersion -> Bool
== :: StoreVersion -> StoreVersion -> Bool
$c/= :: StoreVersion -> StoreVersion -> Bool
/= :: StoreVersion -> StoreVersion -> Bool
Eq, Int -> StoreVersion -> ShowS
[StoreVersion] -> ShowS
StoreVersion -> [Char]
(Int -> StoreVersion -> ShowS)
-> (StoreVersion -> [Char])
-> ([StoreVersion] -> ShowS)
-> Show StoreVersion
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StoreVersion -> ShowS
showsPrec :: Int -> StoreVersion -> ShowS
$cshow :: StoreVersion -> [Char]
show :: StoreVersion -> [Char]
$cshowList :: [StoreVersion] -> ShowS
showList :: [StoreVersion] -> ShowS
Show, Eq StoreVersion
Eq StoreVersion =>
(StoreVersion -> StoreVersion -> Ordering)
-> (StoreVersion -> StoreVersion -> Bool)
-> (StoreVersion -> StoreVersion -> Bool)
-> (StoreVersion -> StoreVersion -> Bool)
-> (StoreVersion -> StoreVersion -> Bool)
-> (StoreVersion -> StoreVersion -> StoreVersion)
-> (StoreVersion -> StoreVersion -> StoreVersion)
-> Ord StoreVersion
StoreVersion -> StoreVersion -> Bool
StoreVersion -> StoreVersion -> Ordering
StoreVersion -> StoreVersion -> StoreVersion
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StoreVersion -> StoreVersion -> Ordering
compare :: StoreVersion -> StoreVersion -> Ordering
$c< :: StoreVersion -> StoreVersion -> Bool
< :: StoreVersion -> StoreVersion -> Bool
$c<= :: StoreVersion -> StoreVersion -> Bool
<= :: StoreVersion -> StoreVersion -> Bool
$c> :: StoreVersion -> StoreVersion -> Bool
> :: StoreVersion -> StoreVersion -> Bool
$c>= :: StoreVersion -> StoreVersion -> Bool
>= :: StoreVersion -> StoreVersion -> Bool
$cmax :: StoreVersion -> StoreVersion -> StoreVersion
max :: StoreVersion -> StoreVersion -> StoreVersion
$cmin :: StoreVersion -> StoreVersion -> StoreVersion
min :: StoreVersion -> StoreVersion -> StoreVersion
Ord, Typeable StoreVersion
Typeable StoreVersion =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> StoreVersion -> c StoreVersion)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c StoreVersion)
-> (StoreVersion -> Constr)
-> (StoreVersion -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c StoreVersion))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c StoreVersion))
-> ((forall b. Data b => b -> b) -> StoreVersion -> StoreVersion)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> StoreVersion -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> StoreVersion -> r)
-> (forall u. (forall d. Data d => d -> u) -> StoreVersion -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> StoreVersion -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion)
-> Data StoreVersion
StoreVersion -> Constr
StoreVersion -> DataType
(forall b. Data b => b -> b) -> StoreVersion -> StoreVersion
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> StoreVersion -> u
forall u. (forall d. Data d => d -> u) -> StoreVersion -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> StoreVersion -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> StoreVersion -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c StoreVersion
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> StoreVersion -> c StoreVersion
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c StoreVersion)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c StoreVersion)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> StoreVersion -> c StoreVersion
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> StoreVersion -> c StoreVersion
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c StoreVersion
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c StoreVersion
$ctoConstr :: StoreVersion -> Constr
toConstr :: StoreVersion -> Constr
$cdataTypeOf :: StoreVersion -> DataType
dataTypeOf :: StoreVersion -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c StoreVersion)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c StoreVersion)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c StoreVersion)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c StoreVersion)
$cgmapT :: (forall b. Data b => b -> b) -> StoreVersion -> StoreVersion
gmapT :: (forall b. Data b => b -> b) -> StoreVersion -> StoreVersion
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> StoreVersion -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> StoreVersion -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> StoreVersion -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> StoreVersion -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> StoreVersion -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> StoreVersion -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> StoreVersion -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> StoreVersion -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
Data, Typeable, (forall x. StoreVersion -> Rep StoreVersion x)
-> (forall x. Rep StoreVersion x -> StoreVersion)
-> Generic StoreVersion
forall x. Rep StoreVersion x -> StoreVersion
forall x. StoreVersion -> Rep StoreVersion x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StoreVersion -> Rep StoreVersion x
from :: forall x. StoreVersion -> Rep StoreVersion x
$cto :: forall x. Rep StoreVersion x -> StoreVersion
to :: forall x. Rep StoreVersion x -> StoreVersion
Generic, Peek StoreVersion
Size StoreVersion
Size StoreVersion
-> (StoreVersion -> Poke ())
-> Peek StoreVersion
-> Store StoreVersion
StoreVersion -> Poke ()
forall a. Size a -> (a -> Poke ()) -> Peek a -> Store a
$csize :: Size StoreVersion
size :: Size StoreVersion
$cpoke :: StoreVersion -> Poke ()
poke :: StoreVersion -> Poke ()
$cpeek :: Peek StoreVersion
peek :: Peek StoreVersion
Store)

-- | Configuration for the version checking of a particular type.
data VersionConfig a = VersionConfig
    { forall a. VersionConfig a -> Maybe [Char]
vcExpectedHash :: Maybe String
      -- ^ When set, specifies the hash which is expected to be computed.
    , forall a. VersionConfig a -> Maybe [Char]
vcManualName :: Maybe String
      -- ^ When set, specifies the name to instead use to tag the data.
    , forall a. VersionConfig a -> Set [Char]
vcIgnore :: S.Set String
      -- ^ DataTypes to ignore.
    , forall a. VersionConfig a -> Map [Char] [Char]
vcRenames :: M.Map String String
      -- ^ Allowed renamings of datatypes, useful when they move.
    } deriving (VersionConfig a -> VersionConfig a -> Bool
(VersionConfig a -> VersionConfig a -> Bool)
-> (VersionConfig a -> VersionConfig a -> Bool)
-> Eq (VersionConfig a)
forall a. VersionConfig a -> VersionConfig a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. VersionConfig a -> VersionConfig a -> Bool
== :: VersionConfig a -> VersionConfig a -> Bool
$c/= :: forall a. VersionConfig a -> VersionConfig a -> Bool
/= :: VersionConfig a -> VersionConfig a -> Bool
Eq, Int -> VersionConfig a -> ShowS
[VersionConfig a] -> ShowS
VersionConfig a -> [Char]
(Int -> VersionConfig a -> ShowS)
-> (VersionConfig a -> [Char])
-> ([VersionConfig a] -> ShowS)
-> Show (VersionConfig a)
forall a. Int -> VersionConfig a -> ShowS
forall a. [VersionConfig a] -> ShowS
forall a. VersionConfig a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> VersionConfig a -> ShowS
showsPrec :: Int -> VersionConfig a -> ShowS
$cshow :: forall a. VersionConfig a -> [Char]
show :: VersionConfig a -> [Char]
$cshowList :: forall a. [VersionConfig a] -> ShowS
showList :: [VersionConfig a] -> ShowS
Show, Typeable (VersionConfig a)
Typeable (VersionConfig a) =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> VersionConfig a -> c (VersionConfig a))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (VersionConfig a))
-> (VersionConfig a -> Constr)
-> (VersionConfig a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (VersionConfig a)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (VersionConfig a)))
-> ((forall b. Data b => b -> b)
    -> VersionConfig a -> VersionConfig a)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> VersionConfig a -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> VersionConfig a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> VersionConfig a -> m (VersionConfig a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> VersionConfig a -> m (VersionConfig a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> VersionConfig a -> m (VersionConfig a))
-> Data (VersionConfig a)
VersionConfig a -> Constr
VersionConfig a -> DataType
(forall b. Data b => b -> b) -> VersionConfig a -> VersionConfig a
forall a. Data a => Typeable (VersionConfig a)
forall a. Data a => VersionConfig a -> Constr
forall a. Data a => VersionConfig a -> DataType
forall a.
Data a =>
(forall b. Data b => b -> b) -> VersionConfig a -> VersionConfig a
forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> VersionConfig a -> u
forall a u.
Data a =>
(forall d. Data d => d -> u) -> VersionConfig a -> [u]
forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r
forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (VersionConfig a)
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> VersionConfig a -> c (VersionConfig a)
forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (VersionConfig a))
forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (VersionConfig a))
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> VersionConfig a -> u
forall u. (forall d. Data d => d -> u) -> VersionConfig a -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (VersionConfig a)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> VersionConfig a -> c (VersionConfig a)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (VersionConfig a))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (VersionConfig a))
$cgfoldl :: forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> VersionConfig a -> c (VersionConfig a)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> VersionConfig a -> c (VersionConfig a)
$cgunfold :: forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (VersionConfig a)
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (VersionConfig a)
$ctoConstr :: forall a. Data a => VersionConfig a -> Constr
toConstr :: VersionConfig a -> Constr
$cdataTypeOf :: forall a. Data a => VersionConfig a -> DataType
dataTypeOf :: VersionConfig a -> DataType
$cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (VersionConfig a))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (VersionConfig a))
$cdataCast2 :: forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (VersionConfig a))
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (VersionConfig a))
$cgmapT :: forall a.
Data a =>
(forall b. Data b => b -> b) -> VersionConfig a -> VersionConfig a
gmapT :: (forall b. Data b => b -> b) -> VersionConfig a -> VersionConfig a
$cgmapQl :: forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r
$cgmapQr :: forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r
$cgmapQ :: forall a u.
Data a =>
(forall d. Data d => d -> u) -> VersionConfig a -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> VersionConfig a -> [u]
$cgmapQi :: forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> VersionConfig a -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> VersionConfig a -> u
$cgmapM :: forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
$cgmapMp :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
$cgmapMo :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
Data, Typeable, (forall x. VersionConfig a -> Rep (VersionConfig a) x)
-> (forall x. Rep (VersionConfig a) x -> VersionConfig a)
-> Generic (VersionConfig a)
forall x. Rep (VersionConfig a) x -> VersionConfig a
forall x. VersionConfig a -> Rep (VersionConfig a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (VersionConfig a) x -> VersionConfig a
forall a x. VersionConfig a -> Rep (VersionConfig a) x
$cfrom :: forall a x. VersionConfig a -> Rep (VersionConfig a) x
from :: forall x. VersionConfig a -> Rep (VersionConfig a) x
$cto :: forall a x. Rep (VersionConfig a) x -> VersionConfig a
to :: forall x. Rep (VersionConfig a) x -> VersionConfig a
Generic)

hashedVersionConfig :: String -> VersionConfig a
hashedVersionConfig :: forall a. [Char] -> VersionConfig a
hashedVersionConfig [Char]
hash = VersionConfig
    { vcExpectedHash :: Maybe [Char]
vcExpectedHash = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
hash
    , vcManualName :: Maybe [Char]
vcManualName = Maybe [Char]
forall a. Maybe a
Nothing
    , vcIgnore :: Set [Char]
vcIgnore = Set [Char]
forall a. Set a
S.empty
    , vcRenames :: Map [Char] [Char]
vcRenames = Map [Char] [Char]
forall k a. Map k a
M.empty
    }

namedVersionConfig :: String -> String -> VersionConfig a
namedVersionConfig :: forall a. [Char] -> [Char] -> VersionConfig a
namedVersionConfig [Char]
name [Char]
hash = VersionConfig
    { vcExpectedHash :: Maybe [Char]
vcExpectedHash = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
hash
    , vcManualName :: Maybe [Char]
vcManualName = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
name
    , vcIgnore :: Set [Char]
vcIgnore = Set [Char]
forall a. Set a
S.empty
    , vcRenames :: Map [Char] [Char]
vcRenames = Map [Char] [Char]
forall k a. Map k a
M.empty
    }

encodeWithVersionQ :: Data a => VersionConfig a -> Q Exp
encodeWithVersionQ :: forall a. Data a => VersionConfig a -> Q Exp
encodeWithVersionQ = WhichFunc -> VersionConfig a -> Q Exp
forall a. Data a => WhichFunc -> VersionConfig a -> Q Exp
impl WhichFunc
Encode

decodeWithVersionQ :: Data a => VersionConfig a -> Q Exp
decodeWithVersionQ :: forall a. Data a => VersionConfig a -> Q Exp
decodeWithVersionQ = WhichFunc -> VersionConfig a -> Q Exp
forall a. Data a => WhichFunc -> VersionConfig a -> Q Exp
impl WhichFunc
Decode

data WhichFunc = Encode | Decode

impl :: forall a. Data a => WhichFunc -> VersionConfig a -> Q Exp
impl :: forall a. Data a => WhichFunc -> VersionConfig a -> Q Exp
impl WhichFunc
wf VersionConfig a
vc = do
    let proxy :: Proxy a
proxy = Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a
        info :: ByteString
info = Text -> ByteString
encodeUtf8 ([Char] -> Text
T.pack (Set [Char] -> Map [Char] [Char] -> Proxy a -> [Char]
forall a.
Data a =>
Set [Char] -> Map [Char] [Char] -> Proxy a -> [Char]
getStructureInfo (VersionConfig a -> Set [Char]
forall a. VersionConfig a -> Set [Char]
vcIgnore VersionConfig a
vc) (VersionConfig a -> Map [Char] [Char]
forall a. VersionConfig a -> Map [Char] [Char]
vcRenames VersionConfig a
vc) Proxy a
proxy))
        hash :: ByteString
hash = ByteString -> ByteString
SHA1.hash ByteString
info
        hashb64 :: [Char]
hashb64 = ByteString -> [Char]
BS8.unpack (ByteString -> ByteString
B64Url.encode ByteString
hash)
        version :: Q Exp
version = case VersionConfig a -> Maybe [Char]
forall a. VersionConfig a -> Maybe [Char]
vcManualName VersionConfig a
vc of
            Maybe [Char]
Nothing -> [e| StoreVersion hash |]
            Just [Char]
name -> [e| StoreVersion name |]
    case VersionConfig a -> Maybe [Char]
forall a. VersionConfig a -> Maybe [Char]
vcExpectedHash VersionConfig a
vc of
        Maybe [Char]
Nothing -> () -> Q ()
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just [Char]
expectedHash -> do
            let shownType :: [Char]
shownType = Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep (VersionConfig a -> Map [Char] [Char]
forall a. VersionConfig a -> Map [Char] [Char]
vcRenames VersionConfig a
vc) Int
0 (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy a
proxy) [Char]
""
            [Char]
path <- [Char] -> Q [Char]
storeVersionedPath [Char]
expectedHash
            if [Char]
hashb64 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
expectedHash
                then [Char] -> [Char] -> ByteString -> Q ()
writeVersionInfo [Char]
path [Char]
shownType ByteString
info
                else do
                    [Char]
newPath <- [Char] -> Q [Char]
storeVersionedPath [Char]
hashb64
                    [Char] -> [Char] -> ByteString -> Q ()
writeVersionInfo [Char]
newPath [Char]
shownType ByteString
info
                    Bool
exists <- IO Bool -> Q Bool
forall a. IO a -> Q a
runIO (IO Bool -> Q Bool) -> IO Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist [Char]
path
                    [Char]
extraMsg <- if Bool -> Bool
not Bool
exists
                        then [Char] -> Q [Char]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
", but no file found with previously stored structural info."
                        else [Char] -> Q [Char]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
", use something like the following to compare with the old structural info:\n\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                                     [Char]
"diff -u " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
path [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
newPath)
                    [Char] -> Q ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q ()) -> [Char] -> Q ()
forall a b. (a -> b) -> a -> b
$
                        [Char]
"For " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
shownType [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
",\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                        [Char]
"Data.Store.Version expected hash " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
hashb64 [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                        [Char]
", but " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
expectedHash [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is specified.\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                        [Char]
"The data used to construct the hash has been written to " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
newPath [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                        [Char]
extraMsg [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
    let atype :: Q Type
atype = TypeRep -> Q Type
typeRepToType (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy a
proxy)
    case WhichFunc
wf of
        WhichFunc
Encode -> [e| \x -> ( getSize markEncodedVersion + getSize $(Q Exp
version) + getSize x
                            , poke markEncodedVersion >> poke $(Q Exp
version) >> poke (x :: $(Q Type
atype))) |]
        WhichFunc
Decode -> [e| do
            peekMagic "version tag" markEncodedVersion
            gotVersion <- peek
            if gotVersion /= $(Q Exp
version)
                then fail (displayVersionError $(Q Exp
version) gotVersion)
                else peek :: Peek $(Q Type
atype) |]

{-
                            txtWithComments <- runIO $ T.readFile path
                            let txt = T.unlines $ dropWhile ("--" `T.isPrefixOf`) $ T.lines txtWithComments
                                storedHash = BS8.unpack (B64Url.encode (SHA1.hash (encodeUtf8 txt)))
                            if storedHash == expectedHash
                                then return (", compare with the structural info that matches the hash, found in " ++ show path)
                                else return (", but the old file found also doesn't match the hash.")
-}

writeVersionInfo :: FilePath -> String -> BS.ByteString -> Q ()
writeVersionInfo :: [Char] -> [Char] -> ByteString -> Q ()
writeVersionInfo [Char]
path [Char]
shownType ByteString
info = IO () -> Q ()
forall a. IO a -> Q a
runIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory [Char]
path)
    [Char] -> Text -> IO ()
T.writeFile [Char]
path (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        [ [Char] -> Text
T.pack ([Char]
"-- Structural info for type " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
shownType)
        , Text
"-- Generated by an invocation of functions in Data.Store.Version"
        ] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Text -> [Text]
T.lines (ByteString -> Text
decodeUtf8 ByteString
info)

storeVersionedPath :: String -> Q FilePath
storeVersionedPath :: [Char] -> Q [Char]
storeVersionedPath [Char]
filename = do
    Maybe [Char]
mstack <- IO (Maybe [Char]) -> Q (Maybe [Char])
forall a. IO a -> Q a
runIO ([Char] -> IO (Maybe [Char])
lookupEnv [Char]
"STACK_EXE")
    let dirName :: [Char]
dirName = case Maybe [Char]
mstack of
            Just [Char]
_ -> [Char]
".stack-work"
            Maybe [Char]
Nothing -> [Char]
"dist"
    [Char] -> Q [Char]
pathRelativeToCabalPackage ([Char]
dirName [Char] -> ShowS
</> [Char]
"store-versioned" [Char] -> ShowS
</> [Char]
filename)

-- Implementation details

data S = S
    { S -> Map [Char] [Char]
sResults :: M.Map String String
    , S -> [Char]
sCurResult :: String
    , S -> [[Char]]
sFieldNames :: [String]
    }

getStructureInfo :: forall a. Data a => S.Set String -> M.Map String String -> Proxy a -> String
getStructureInfo :: forall a.
Data a =>
Set [Char] -> Map [Char] [Char] -> Proxy a -> [Char]
getStructureInfo Set [Char]
ignore Map [Char] [Char]
renames = Map [Char] [Char] -> [Char]
renderResults (Map [Char] [Char] -> [Char])
-> (Proxy a -> Map [Char] [Char]) -> Proxy a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S -> Map [Char] [Char]
sResults (S -> Map [Char] [Char])
-> (Proxy a -> S) -> Proxy a -> Map [Char] [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State S () -> S -> S) -> S -> State S () -> S
forall a b c. (a -> b -> c) -> b -> a -> c
flip State S () -> S -> S
forall s a. State s a -> s -> s
execState (Map [Char] [Char] -> [Char] -> [[Char]] -> S
S Map [Char] [Char]
forall k a. Map k a
M.empty [Char]
"" []) (State S () -> S) -> (Proxy a -> State S ()) -> Proxy a -> S
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set [Char] -> Map [Char] [Char] -> Proxy a -> State S ()
forall a.
Data a =>
Set [Char] -> Map [Char] [Char] -> Proxy a -> State S ()
getStructureInfo' Set [Char]
ignore Map [Char] [Char]
renames
  where
    renderResults :: Map [Char] [Char] -> [Char]
renderResults = [[Char]] -> [Char]
unlines ([[Char]] -> [Char])
-> (Map [Char] [Char] -> [[Char]]) -> Map [Char] [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\([Char]
k, [Char]
v) -> [Char]
k [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
v) ([([Char], [Char])] -> [[Char]])
-> (Map [Char] [Char] -> [([Char], [Char])])
-> Map [Char] [Char]
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map [Char] [Char] -> [([Char], [Char])]
forall k a. Map k a -> [(k, a)]
M.toAscList

getStructureInfo' :: forall a. Data a => S.Set String -> M.Map String String -> Proxy a -> State S ()
getStructureInfo' :: forall a.
Data a =>
Set [Char] -> Map [Char] [Char] -> Proxy a -> State S ()
getStructureInfo' Set [Char]
ignore Map [Char] [Char]
renames Proxy a
_ = do
    S
s0 <- StateT S Identity S
forall (m :: * -> *) s. Monad m => StateT s m s
get
    Bool -> State S () -> State S ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char] -> Map [Char] [Char] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember [Char]
label (S -> Map [Char] [Char]
sResults S
s0)) (State S () -> State S ()) -> State S () -> State S ()
forall a b. (a -> b) -> a -> b
$
        if [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member [Char]
shownType Set [Char]
ignore
            then [Char] -> State S ()
forall {m :: * -> *}. Monad m => [Char] -> StateT S m ()
setResult [Char]
" ignored\n"
            else case DataType -> DataRep
dataTypeRep (a -> DataType
forall a. Data a => a -> DataType
dataTypeOf (a
forall a. HasCallStack => a
undefined :: a)) of
                AlgRep [Constr]
cs -> do
                    [Char] -> State S ()
forall {m :: * -> *}. Monad m => [Char] -> StateT S m ()
setResult [Char]
""
                    ((Bool, Constr) -> State S ()) -> [(Bool, Constr)] -> State S ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool, Constr) -> State S ()
goConstr ([Bool] -> [Constr] -> [(Bool, Constr)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False) [Constr]
cs)
                    [Char]
result <- (S -> [Char]) -> StateT S Identity [Char]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets S -> [Char]
sCurResult
                    [Char] -> State S ()
forall {m :: * -> *}. Monad m => [Char] -> StateT S m ()
setResult (if [Constr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Constr]
cs then [Char]
result [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" else [Char]
result)
                DataRep
IntRep -> [Char] -> State S ()
forall {m :: * -> *}. Monad m => [Char] -> StateT S m ()
setResult [Char]
" has IntRep\n"
                DataRep
FloatRep -> [Char] -> State S ()
forall {m :: * -> *}. Monad m => [Char] -> StateT S m ()
setResult [Char]
" has FloatRep\n"
                DataRep
CharRep -> [Char] -> State S ()
forall {m :: * -> *}. Monad m => [Char] -> StateT S m ()
setResult [Char]
" has CharRep\n"
                DataRep
NoRep
                    | [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member [Char]
shownType Set [Char]
ignore -> [Char] -> State S ()
forall {m :: * -> *}. Monad m => [Char] -> StateT S m ()
setResult [Char]
" has NoRep\n"
                    | Bool
otherwise -> [Char] -> State S ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> State S ()) -> [Char] -> State S ()
forall a b. (a -> b) -> a -> b
$
                        [Char]
"\nNoRep in Data.Store.Version for " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
shownType [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                        [Char]
".\nIn the future it will be possible to statically " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                        [Char]
"declare a global serialization version for this type. " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                        [Char]
"\nUntil then you will need to use 'vcIgnore', and " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                        [Char]
"understand that serialization changes for affected types " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                        [Char]
"will not be detected.\n"
  where
    setResult :: [Char] -> StateT S m ()
setResult [Char]
x =
         (S -> S) -> StateT S m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\S
s -> S
             { sResults :: Map [Char] [Char]
sResults = [Char] -> [Char] -> Map [Char] [Char] -> Map [Char] [Char]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [Char]
label [Char]
x (S -> Map [Char] [Char]
sResults S
s)
             , sCurResult :: [Char]
sCurResult = [Char]
""
             , sFieldNames :: [[Char]]
sFieldNames = []
             })
    label :: [Char]
label = [Char]
"data-type " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
shownType
    shownType :: [Char]
shownType = Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
0 (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) [Char]
""
    goConstr :: (Bool, Constr) -> State S ()
    goConstr :: (Bool, Constr) -> State S ()
goConstr (Bool
isFirst, Constr
c) = do
        (S -> S) -> State S ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\S
s -> S
s
            { sFieldNames = constrFields c ++ map (\Int
ix -> [Char]
"slot " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
ix :: Int)) [0..]
            , sCurResult = sCurResult s ++ (if isFirst then "\n  = " else "  | ") ++ showConstr c ++ " {\n"
            })
        StateT S Identity a -> State S ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((forall d. Data d => StateT S Identity d)
-> Constr -> StateT S Identity a
forall (m :: * -> *) a.
(Monad m, Data a) =>
(forall d. Data d => m d) -> Constr -> m a
fromConstrM State S d
forall d. Data d => StateT S Identity d
goField Constr
c :: State S a)
        (S -> S) -> State S ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\S
s -> S
s { sCurResult = sCurResult s ++ "  }\n" })
    goField :: forall b. Data b => State S b
    goField :: forall d. Data d => StateT S Identity d
goField = do
        S
s <- StateT S Identity S
forall (m :: * -> *) s. Monad m => StateT s m s
get
        case S -> [[Char]]
sFieldNames S
s of
            [] -> [Char] -> State S b
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible case in getStructureInfo'"
            ([Char]
name:[[Char]]
names) -> do
                Set [Char] -> Map [Char] [Char] -> Proxy b -> State S ()
forall a.
Data a =>
Set [Char] -> Map [Char] [Char] -> Proxy a -> State S ()
getStructureInfo' Set [Char]
ignore Map [Char] [Char]
renames (Proxy b
forall {k} (t :: k). Proxy t
Proxy :: Proxy b)
                S
s' <- StateT S Identity S
forall (m :: * -> *) s. Monad m => StateT s m s
get
                S -> State S ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put S
s
                    { sResults = sResults s'
                    , sCurResult = sCurResult s ++ "    " ++ name ++ " :: " ++ showsQualTypeRep renames 0 (typeRep (Proxy :: Proxy b)) "\n"
                    , sFieldNames = names
                    }
                b -> State S b
forall a. a -> StateT S Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"unexpected evaluation")

showsQualTypeRep :: M.Map String String -> Int -> TypeRep -> ShowS
showsQualTypeRep :: Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
p TypeRep
tyrep =
  let (TyCon
tycon, [TypeRep]
tys) = TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
tyrep
  in case [TypeRep]
tys of
        [] -> Map [Char] [Char] -> TyCon -> ShowS
showsQualTyCon Map [Char] [Char]
renames TyCon
tycon
        [TypeRep
x] | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tcList -> Char -> ShowS
showChar Char
'[' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
0 TypeRep
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
']'
          where
        [TypeRep
a,TypeRep
r] | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tcFun  -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
8) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
                                     Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
9 TypeRep
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                     [Char] -> ShowS
showString [Char]
" -> " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                     Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
8 TypeRep
r
        [TypeRep]
xs | TyCon -> Bool
isTupleTyCon TyCon
tycon -> Map [Char] [Char] -> [TypeRep] -> ShowS
showTuple Map [Char] [Char]
renames [TypeRep]
xs
           | Bool
otherwise         ->
                Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
                Map [Char] [Char] -> TyCon -> ShowS
showsQualTyCon Map [Char] [Char]
renames TyCon
tycon ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                Char -> ShowS
showChar Char
' '      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                Map [Char] [Char] -> ShowS -> [TypeRep] -> ShowS
showArgs Map [Char] [Char]
renames (Char -> ShowS
showChar Char
' ') [TypeRep]
tys

showsQualTyCon :: M.Map String String -> TyCon -> ShowS
showsQualTyCon :: Map [Char] [Char] -> TyCon -> ShowS
showsQualTyCon Map [Char] [Char]
renames TyCon
tc = [Char] -> ShowS
showString ([Char] -> [Char] -> Map [Char] [Char] -> [Char]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [Char]
name [Char]
name Map [Char] [Char]
renames)
  where
    name :: [Char]
name = TyCon -> [Char]
tyConModule TyCon
tc [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"." [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ TyCon -> [Char]
tyConName TyCon
tc

isTupleTyCon :: TyCon -> Bool
isTupleTyCon :: TyCon -> Bool
isTupleTyCon TyCon
tc
  | (Char
'(':Char
',':[Char]
_) <- TyCon -> [Char]
tyConName TyCon
tc = Bool
True
  | Bool
otherwise                   = Bool
False

showArgs :: M.Map String String -> ShowS -> [TypeRep] -> ShowS
showArgs :: Map [Char] [Char] -> ShowS -> [TypeRep] -> ShowS
showArgs Map [Char] [Char]
_       ShowS
_   []     = ShowS
forall a. a -> a
id
showArgs Map [Char] [Char]
renames ShowS
_   [TypeRep
a]    = Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
10 TypeRep
a
showArgs Map [Char] [Char]
renames ShowS
sep (TypeRep
a:[TypeRep]
as) = Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
10 TypeRep
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
sep ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map [Char] [Char] -> ShowS -> [TypeRep] -> ShowS
showArgs Map [Char] [Char]
renames ShowS
sep [TypeRep]
as

showTuple :: M.Map String String -> [TypeRep] -> ShowS
showTuple :: Map [Char] [Char] -> [TypeRep] -> ShowS
showTuple Map [Char] [Char]
renames [TypeRep]
args
    = Char -> ShowS
showChar Char
'('
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map [Char] [Char] -> ShowS -> [TypeRep] -> ShowS
showArgs Map [Char] [Char]
renames (Char -> ShowS
showChar Char
',') [TypeRep]
args
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
')'

tcList :: TyCon
tcList :: TyCon
tcList = Proxy [()] -> TyCon
forall a. Typeable a => Proxy a -> TyCon
tyConOf (Proxy [()]
forall {k} (t :: k). Proxy t
Proxy :: Proxy [()])

tcFun :: TyCon
tcFun :: TyCon
tcFun = Proxy (Int -> Int) -> TyCon
forall a. Typeable a => Proxy a -> TyCon
tyConOf (Proxy (Int -> Int)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Int -> Int))

tyConOf :: Typeable a => Proxy a -> TyCon
tyConOf :: forall a. Typeable a => Proxy a -> TyCon
tyConOf = TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> (Proxy a -> TypeRep) -> Proxy a -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep

displayVersionError :: StoreVersion -> StoreVersion -> String
displayVersionError :: StoreVersion -> StoreVersion -> [Char]
displayVersionError StoreVersion
expectedVersion StoreVersion
receivedVersion =
    [Char]
"Mismatch detected by Data.Store.Version - expected " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
    Text -> [Char]
T.unpack (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (StoreVersion -> ByteString
unStoreVersion StoreVersion
expectedVersion)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" but got " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
    Text -> [Char]
T.unpack (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (StoreVersion -> ByteString
unStoreVersion StoreVersion
receivedVersion))

markEncodedVersion :: Word32
markEncodedVersion :: Word32
markEncodedVersion = Word32
3908297288