{-# OPTIONS_GHC -Wno-deprecations #-}
module Lorentz.Contracts.Upgradeable.Common.Interface
( EpwUpgradeParameters (..)
, fvUpgrade
, makeOneShotUpgradeParameters
, makeOneShotUpgrade
, makeEpwUpgrade
, UpgradeWay (..)
, SimpleUpgradeWay
, integrationalTestUpgrade
) where
import Data.Constraint ((:-)(..), Constraint, Dict(..), (\\))
import Data.Foldable (toList)
import qualified Data.Kind as Kind
import Lorentz
import Prelude (Identity(..), Traversable, Void, absurd, mapM_, maybe, (<$), (<$>))
import Data.Coerce (coerce)
import Unsafe.Coerce (unsafeCoerce)
import Lorentz.Test
import Util.Instances ()
import Util.Named ((.!))
import Util.TypeLits
import Lorentz.Contracts.Upgradeable.Common.Base
import Lorentz.Contracts.Upgradeable.Common.Contract
data UContractRouterUpdate curVer newVer where
UcrUpdate :: UContractRouter newVer -> UContractRouterUpdate curVer newVer
UcrRetain :: UContractRouterUpdate curVer newVer
data PermanentImplUpdate curVer newVer where
PiUpdate :: PermanentImpl newVer -> PermanentImplUpdate curVer newVer
PiRetain :: PermanentImplUpdate curVer newVer
class RecognizeUpgPiece expected given where
recognizeUpgPiece :: given -> expected
instance (newVerE ~ newVerG) =>
RecognizeUpgPiece
(UContractRouterUpdate curVerE newVerE)
(UContractRouter newVerG) where
recognizeUpgPiece :: UContractRouter newVerG -> UContractRouterUpdate curVerE newVerE
recognizeUpgPiece = UContractRouter newVerG -> UContractRouterUpdate curVerE newVerE
forall k (newVer :: VersionKind) (curVer :: k).
UContractRouter newVer -> UContractRouterUpdate curVer newVer
UcrUpdate
instance ( RequireSameVersionStorageParts curVer newVer
"upgradeable part implementation"
, RequireSameVersionInterfaces curVer newVer
, x ~ Void
) =>
RecognizeUpgPiece (UContractRouterUpdate curVer newVer) (Maybe x) where
recognizeUpgPiece :: Maybe x -> UContractRouterUpdate curVer newVer
recognizeUpgPiece = UContractRouterUpdate curVer newVer
-> (Void -> UContractRouterUpdate curVer newVer)
-> Maybe Void
-> UContractRouterUpdate curVer newVer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UContractRouterUpdate curVer newVer
forall k (curVer :: k) (newVer :: VersionKind).
UContractRouterUpdate curVer newVer
UcrRetain Void -> UContractRouterUpdate curVer newVer
forall a. Void -> a
absurd
instance (newVerE ~ newVerG) =>
RecognizeUpgPiece
(PermanentImplUpdate curVerE newVerE)
(PermanentImpl newVerG) where
recognizeUpgPiece :: PermanentImpl newVerG -> PermanentImplUpdate curVerE newVerE
recognizeUpgPiece = PermanentImpl newVerG -> PermanentImplUpdate curVerE newVerE
forall k (newVer :: VersionKind) (curVer :: k).
PermanentImpl newVer -> PermanentImplUpdate curVer newVer
PiUpdate
instance ( RequireSameVersionStorageParts curVer newVer
"permanent part implementation"
, RequireSameVersionPermanents curVer newVer
, x ~ Void
) =>
RecognizeUpgPiece (PermanentImplUpdate curVer newVer) (Maybe x) where
recognizeUpgPiece :: Maybe x -> PermanentImplUpdate curVer newVer
recognizeUpgPiece = PermanentImplUpdate curVer newVer
-> (Void -> PermanentImplUpdate curVer newVer)
-> Maybe Void
-> PermanentImplUpdate curVer newVer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PermanentImplUpdate curVer newVer
forall k (curVer :: k) (newVer :: VersionKind).
PermanentImplUpdate curVer newVer
PiRetain Void -> PermanentImplUpdate curVer newVer
forall a. Void -> a
absurd
type family RequireSameStorageParts curStore newStore desc :: Constraint where
RequireSameStorageParts store store _ = ()
RequireSameStorageParts curStore newStore desc = TypeError
( 'Text "Leaving " ':<>: 'Text desc ':<>:
'Text " unchanged is not safe when storage format changes" ':$$:
'Text "Old storage is `" ':<>: 'ShowType curStore ':<>: 'Text "`" ':$$:
'Text "while new one is `" ':<>: 'ShowType newStore ':<>: 'Text "`"
)
type RequireSameVersionStorageParts curVer newVer desc =
RequireSameStorageParts
(VerUStoreTemplate curVer)
(VerUStoreTemplate newVer)
desc
type family RequireSameInterfaces curInterface newInterface :: Constraint where
RequireSameInterfaces interface interface = ()
RequireSameInterfaces curInterface newInterface = TypeError
( 'Text "Need to update interface" ':$$:
'Text "Old interface is `" ':<>: 'ShowType curInterface ':<>: 'Text "`" ':$$:
'Text "while new one is `" ':<>: 'ShowType newInterface ':<>: 'Text "`"
)
type RequireSameVersionInterfaces curVer newVer =
RequireSameInterfaces (VerInterface curVer) (VerInterface newVer)
type family RequireSamePermanents (curPerm :: Kind.Type) (newPerm :: Kind.Type)
:: Kind.Constraint where
RequireSamePermanents perm perm = ()
RequireSamePermanents curPerm Empty =
TypeError
( 'Text "Permanent part of contract version is set to default" ':$$:
'Text "while in existing contract version it is `"
':<>: 'ShowType curPerm ':<>: 'Text "`" ':$$:
'Text "Have you set it in KnownContractVersion instance?"
)
RequireSamePermanents curPerm newPerm =
TypeError
( 'Text "Need to update permanent part implementation" ':$$:
'Text "Parameter of previous version part is of type `"
':<>: 'ShowType curPerm ':<>: 'Text "`" ':$$:
'Text "while in new one it is `" ':<>: 'ShowType newPerm ':<>: 'Text "`"
)
type RequireSameVersionPermanents curVer newVer =
RequireSamePermanents (VerPermanent curVer) (VerPermanent newVer)
data EpwUpgradeParameters (t :: Kind.Type -> Kind.Type)
(curVer :: VersionKind)
(newVer :: VersionKind) =
forall code codePerm.
( Traversable t
, KnownContractVersion curVer, KnownContractVersion newVer
, RequireSamePermanents (VerPermanent curVer) (VerPermanent newVer)
, RecognizeUpgPiece (UContractRouterUpdate curVer newVer) code
, RecognizeUpgPiece (PermanentImplUpdate curVer newVer) codePerm
) =>
EpwUpgradeParameters
{ EpwUpgradeParameters t curVer newVer
-> t (MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
upMigrationScripts :: t (MigrationScript (VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
, ()
upNewCode :: code
, ()
upNewPermCode :: codePerm
}
permanentsAreSameEvi
:: RequireSamePermanents (VerPermanent ver1) (VerPermanent ver2)
:- (VerPermanent ver1 ~ VerPermanent ver2)
permanentsAreSameEvi :: RequireSamePermanents (VerPermanent ver1) (VerPermanent ver2)
:- (VerPermanent ver1 ~ VerPermanent ver2)
permanentsAreSameEvi = (RequireSamePermanents (VerPermanent ver1) (VerPermanent ver2) =>
Dict (VerPermanent ver1 ~ VerPermanent ver2))
-> RequireSamePermanents (VerPermanent ver1) (VerPermanent ver2)
:- (VerPermanent ver1 ~ VerPermanent ver2)
forall (a :: Constraint) (b :: Constraint). (a => Dict b) -> a :- b
Sub ((RequireSamePermanents (VerPermanent ver1) (VerPermanent ver2) =>
Dict (VerPermanent ver1 ~ VerPermanent ver2))
-> RequireSamePermanents (VerPermanent ver1) (VerPermanent ver2)
:- (VerPermanent ver1 ~ VerPermanent ver2))
-> (RequireSamePermanents
(VerPermanent ver1) (VerPermanent ver2) =>
Dict (VerPermanent ver1 ~ VerPermanent ver2))
-> RequireSamePermanents (VerPermanent ver1) (VerPermanent ver2)
:- (VerPermanent ver1 ~ VerPermanent ver2)
forall a b. (a -> b) -> a -> b
$
Dict (Integer ~ Integer)
-> Dict (VerPermanent ver1 ~ VerPermanent ver2)
forall a b. a -> b
unsafeCoerce (Dict (Integer ~ Integer)
-> Dict (VerPermanent ver1 ~ VerPermanent ver2))
-> Dict (Integer ~ Integer)
-> Dict (VerPermanent ver1 ~ VerPermanent ver2)
forall a b. (a -> b) -> a -> b
$ (Integer ~ Integer) => Dict (Integer ~ Integer)
forall (a :: Constraint). a => Dict a
Dict @(Integer ~ Integer)
upNewVersion
:: forall t curVer newVer.
EpwUpgradeParameters t curVer newVer -> Version
upNewVersion :: EpwUpgradeParameters t curVer newVer -> Version
upNewVersion EpwUpgradeParameters{} =
Proxy newVer -> Version
forall (v :: VersionKind).
KnownContractVersion v =>
Proxy v -> Version
contractVersion (Proxy newVer
forall k (t :: k). Proxy t
Proxy @newVer)
upCurVersion
:: forall t curVer newVer.
EpwUpgradeParameters t curVer newVer -> Version
upCurVersion :: EpwUpgradeParameters t curVer newVer -> Version
upCurVersion EpwUpgradeParameters{} =
Proxy curVer -> Version
forall (v :: VersionKind).
KnownContractVersion v =>
Proxy v -> Version
contractVersion (Proxy curVer
forall k (t :: k). Proxy t
Proxy @curVer)
upNewCode'
:: forall curVer newVer t.
EpwUpgradeParameters t curVer newVer -> Maybe (UContractRouter newVer)
upNewCode' :: EpwUpgradeParameters t curVer newVer
-> Maybe (UContractRouter newVer)
upNewCode' EpwUpgradeParameters{code
codePerm
t (MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
upNewPermCode :: codePerm
upNewCode :: code
upMigrationScripts :: t (MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
upNewPermCode :: ()
upNewCode :: ()
upMigrationScripts :: forall (t :: * -> *) (curVer :: VersionKind)
(newVer :: VersionKind).
EpwUpgradeParameters t curVer newVer
-> t (MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
..} =
case code -> UContractRouterUpdate curVer newVer
forall expected given.
RecognizeUpgPiece expected given =>
given -> expected
recognizeUpgPiece @(UContractRouterUpdate curVer newVer) code
upNewCode of
UcrUpdate UContractRouter newVer
code -> UContractRouter newVer -> Maybe (UContractRouter newVer)
forall a. a -> Maybe a
Just UContractRouter newVer
code
UContractRouterUpdate curVer newVer
UcrRetain -> Maybe (UContractRouter newVer)
forall a. Maybe a
Nothing
upNewPermCode'
:: forall curVer newVer t.
EpwUpgradeParameters t curVer newVer -> Maybe (PermanentImpl newVer)
upNewPermCode' :: EpwUpgradeParameters t curVer newVer
-> Maybe (PermanentImpl newVer)
upNewPermCode' EpwUpgradeParameters{code
codePerm
t (MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
upNewPermCode :: codePerm
upNewCode :: code
upMigrationScripts :: t (MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
upNewPermCode :: ()
upNewCode :: ()
upMigrationScripts :: forall (t :: * -> *) (curVer :: VersionKind)
(newVer :: VersionKind).
EpwUpgradeParameters t curVer newVer
-> t (MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
..} =
case codePerm -> PermanentImplUpdate curVer newVer
forall expected given.
RecognizeUpgPiece expected given =>
given -> expected
recognizeUpgPiece @(PermanentImplUpdate curVer newVer) codePerm
upNewPermCode of
PiUpdate PermanentImpl newVer
code -> PermanentImpl newVer -> Maybe (PermanentImpl newVer)
forall a. a -> Maybe a
Just PermanentImpl newVer
code
PermanentImplUpdate curVer newVer
PiRetain -> Maybe (PermanentImpl newVer)
forall a. Maybe a
Nothing
fvUpgrade
:: forall ver t.
(KnownContractVersion ver, Traversable t)
=> t (MigrationScript (VerUStoreTemplate ver) (VerUStoreTemplate ver))
-> EpwUpgradeParameters t ver ver
fvUpgrade :: t (MigrationScript (VerUStoreTemplate ver) (VerUStoreTemplate ver))
-> EpwUpgradeParameters t ver ver
fvUpgrade t (MigrationScript (VerUStoreTemplate ver) (VerUStoreTemplate ver))
migrationScripts = EpwUpgradeParameters :: forall (t :: * -> *) (curVer :: VersionKind)
(newVer :: VersionKind) code codePerm.
(Traversable t, KnownContractVersion curVer,
KnownContractVersion newVer,
RequireSamePermanents (VerPermanent curVer) (VerPermanent newVer),
RecognizeUpgPiece (UContractRouterUpdate curVer newVer) code,
RecognizeUpgPiece (PermanentImplUpdate curVer newVer) codePerm) =>
t (MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
-> code -> codePerm -> EpwUpgradeParameters t curVer newVer
EpwUpgradeParameters
{ upMigrationScripts :: t (MigrationScript (VerUStoreTemplate ver) (VerUStoreTemplate ver))
upMigrationScripts = t (MigrationScript (VerUStoreTemplate ver) (VerUStoreTemplate ver))
migrationScripts
, upNewCode :: Maybe Void
upNewCode = Maybe Void
forall a. Maybe a
Nothing
, upNewPermCode :: Maybe Void
upNewPermCode = Maybe Void
forall a. Maybe a
Nothing
}
makeOneShotUpgradeParameters
:: forall curVer newVer.
EpwUpgradeParameters Identity curVer newVer
-> OneShotUpgradeParameters curVer
makeOneShotUpgradeParameters :: EpwUpgradeParameters Identity curVer newVer
-> OneShotUpgradeParameters curVer
makeOneShotUpgradeParameters epw :: EpwUpgradeParameters Identity curVer newVer
epw@EpwUpgradeParameters{} =
( Name "currentVersion"
forall a. IsLabel "currentVersion" a => a
forall (x :: Symbol) a. IsLabel x a => a
#currentVersion Name "currentVersion"
-> Version -> NamedF Identity Version "currentVersion"
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.!
EpwUpgradeParameters Identity curVer newVer -> Version
forall (t :: * -> *) (curVer :: VersionKind)
(newVer :: VersionKind).
EpwUpgradeParameters t curVer newVer -> Version
upCurVersion EpwUpgradeParameters Identity curVer newVer
epw
, Name "newVersion"
forall a. IsLabel "newVersion" a => a
forall (x :: Symbol) a. IsLabel x a => a
#newVersion Name "newVersion"
-> Version -> NamedF Identity Version "newVersion"
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.!
EpwUpgradeParameters Identity curVer newVer -> Version
forall (t :: * -> *) (curVer :: VersionKind)
(newVer :: VersionKind).
EpwUpgradeParameters t curVer newVer -> Version
upNewVersion EpwUpgradeParameters Identity curVer newVer
epw
, Name "migrationScript"
forall a. IsLabel "migrationScript" a => a
forall (x :: Symbol) a. IsLabel x a => a
#migrationScript Name "migrationScript"
-> MigrationScriptFrom (VerUStoreTemplate curVer)
-> NamedF
Identity
(MigrationScriptFrom (VerUStoreTemplate curVer))
"migrationScript"
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.!
MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer)
-> MigrationScriptFrom (VerUStoreTemplate curVer)
forall a b. (CanCastTo a b, Coercible a b) => a -> b
checkedCoerce (Identity
(MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
-> MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer)
forall a. Identity a -> a
runIdentity (Identity
(MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
-> MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
-> Identity
(MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
-> MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer)
forall a b. (a -> b) -> a -> b
$ EpwUpgradeParameters Identity curVer newVer
-> Identity
(MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
forall (t :: * -> *) (curVer :: VersionKind)
(newVer :: VersionKind).
EpwUpgradeParameters t curVer newVer
-> t (MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
upMigrationScripts EpwUpgradeParameters Identity curVer newVer
epw)
, Name "newCode"
forall a. IsLabel "newCode" a => a
forall (x :: Symbol) a. IsLabel x a => a
#newCode Name "newCode"
-> Maybe (UContractRouter (SomeContractVersion ()))
-> NamedF
Identity
(Maybe (UContractRouter (SomeContractVersion ())))
"newCode"
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.! (UContractRouter newVer -> UContractRouter (SomeContractVersion ())
forall (s1 :: VersionKind) (s2 :: VersionKind).
(Coercible_ (VerParam s1) (VerParam s2),
Coercible_ (VerUStore s1) (VerUStore s2)) =>
UContractRouter s1 -> UContractRouter s2
coerceUContractRouter (UContractRouter newVer
-> UContractRouter (SomeContractVersion ()))
-> Maybe (UContractRouter newVer)
-> Maybe (UContractRouter (SomeContractVersion ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EpwUpgradeParameters Identity curVer newVer
-> Maybe (UContractRouter newVer)
forall (curVer :: VersionKind) (newVer :: VersionKind)
(t :: * -> *).
EpwUpgradeParameters t curVer newVer
-> Maybe (UContractRouter newVer)
upNewCode' EpwUpgradeParameters Identity curVer newVer
epw)
, Name "newPermCode"
forall a. IsLabel "newPermCode" a => a
forall (x :: Symbol) a. IsLabel x a => a
#newPermCode Name "newPermCode"
-> Maybe (SomePermanentImpl (VerPermanent newVer))
-> NamedF
Identity
(Maybe (SomePermanentImpl (VerPermanent newVer)))
"newPermCode"
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.! (PermanentImpl newVer -> SomePermanentImpl (VerPermanent newVer)
forall a b. (CanCastTo a b, Coercible a b) => a -> b
checkedCoerce (PermanentImpl newVer -> SomePermanentImpl (VerPermanent newVer))
-> Maybe (PermanentImpl newVer)
-> Maybe (SomePermanentImpl (VerPermanent newVer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EpwUpgradeParameters Identity curVer newVer
-> Maybe (PermanentImpl newVer)
forall (curVer :: VersionKind) (newVer :: VersionKind)
(t :: * -> *).
EpwUpgradeParameters t curVer newVer
-> Maybe (PermanentImpl newVer)
upNewPermCode' EpwUpgradeParameters Identity curVer newVer
epw)
((VerPermanent curVer ~ VerPermanent newVer) =>
NamedF
Identity
(Maybe (PermanentImpl (SomeContractVersion (VerPermanent curVer))))
"newPermCode")
-> (RequireSamePermanents
(VerPermanent curVer) (VerPermanent newVer)
:- (VerPermanent curVer ~ VerPermanent newVer))
-> NamedF
Identity
(Maybe (PermanentImpl (SomeContractVersion (VerPermanent curVer))))
"newPermCode"
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ RequireSamePermanents (VerPermanent curVer) (VerPermanent newVer)
:- (VerPermanent curVer ~ VerPermanent newVer)
forall (ver1 :: VersionKind) (ver2 :: VersionKind).
RequireSamePermanents (VerPermanent ver1) (VerPermanent ver2)
:- (VerPermanent ver1 ~ VerPermanent ver2)
permanentsAreSameEvi @curVer @newVer
)
makeOneShotUpgrade
:: forall oldVer newVer.
(EpwUpgradeParameters Identity oldVer newVer)
-> Parameter oldVer
makeOneShotUpgrade :: EpwUpgradeParameters Identity oldVer newVer -> Parameter oldVer
makeOneShotUpgrade =
OneShotUpgradeParameters oldVer -> Parameter oldVer
forall (ver :: VersionKind).
OneShotUpgradeParameters ver -> Parameter ver
Upgrade (OneShotUpgradeParameters oldVer -> Parameter oldVer)
-> (EpwUpgradeParameters Identity oldVer newVer
-> OneShotUpgradeParameters oldVer)
-> EpwUpgradeParameters Identity oldVer newVer
-> Parameter oldVer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpwUpgradeParameters Identity oldVer newVer
-> OneShotUpgradeParameters oldVer
forall (curVer :: VersionKind) (newVer :: VersionKind).
EpwUpgradeParameters Identity curVer newVer
-> OneShotUpgradeParameters curVer
makeOneShotUpgradeParameters
makeEpwUpgrade
:: forall curVer newVer t.
(EpwUpgradeParameters t curVer newVer)
-> [Parameter curVer]
makeEpwUpgrade :: EpwUpgradeParameters t curVer newVer -> [Parameter curVer]
makeEpwUpgrade epw :: EpwUpgradeParameters t curVer newVer
epw@EpwUpgradeParameters{} =
[[Parameter curVer]] -> [Parameter curVer]
forall a. Monoid a => [a] -> a
mconcat
[ [("current" :! Version, "new" :! Version) -> Parameter curVer
forall (ver :: VersionKind).
("current" :! Version, "new" :! Version) -> Parameter ver
EpwBeginUpgrade (Name "current"
forall a. IsLabel "current" a => a
forall (x :: Symbol) a. IsLabel x a => a
#current Name "current" -> Version -> "current" :! Version
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.! EpwUpgradeParameters t curVer newVer -> Version
forall (t :: * -> *) (curVer :: VersionKind)
(newVer :: VersionKind).
EpwUpgradeParameters t curVer newVer -> Version
upCurVersion EpwUpgradeParameters t curVer newVer
epw, Name "new"
forall a. IsLabel "new" a => a
forall (x :: Symbol) a. IsLabel x a => a
#new Name "new" -> Version -> "new" :! Version
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.! EpwUpgradeParameters t curVer newVer -> Version
forall (t :: * -> *) (curVer :: VersionKind)
(newVer :: VersionKind).
EpwUpgradeParameters t curVer newVer -> Version
upNewVersion EpwUpgradeParameters t curVer newVer
epw)]
, MigrationScriptFrom (VerUStoreTemplate curVer) -> Parameter curVer
forall (ver :: VersionKind).
MigrationScriptFrom (VerUStoreTemplate ver) -> Parameter ver
EpwApplyMigration (MigrationScriptFrom (VerUStoreTemplate curVer)
-> Parameter curVer)
-> (MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer)
-> MigrationScriptFrom (VerUStoreTemplate curVer))
-> MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer)
-> Parameter curVer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer)
-> MigrationScriptFrom (VerUStoreTemplate curVer)
forall a b. (CanCastTo a b, Coercible a b) => a -> b
checkedCoerce (MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer)
-> Parameter curVer)
-> [MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer)]
-> [Parameter curVer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
-> [MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (EpwUpgradeParameters t curVer newVer
-> t (MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
forall (t :: * -> *) (curVer :: VersionKind)
(newVer :: VersionKind).
EpwUpgradeParameters t curVer newVer
-> t (MigrationScript
(VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
upMigrationScripts EpwUpgradeParameters t curVer newVer
epw)
, [UContractRouter (SomeContractVersion ()) -> Parameter curVer
forall (ver :: VersionKind).
UContractRouter (SomeContractVersion ()) -> Parameter ver
EpwSetCode (UContractRouter (SomeContractVersion ()) -> Parameter curVer)
-> UContractRouter (SomeContractVersion ()) -> Parameter curVer
forall a b. (a -> b) -> a -> b
$ UContractRouter newVer -> UContractRouter (SomeContractVersion ())
forall (s1 :: VersionKind) (s2 :: VersionKind).
(Coercible_ (VerParam s1) (VerParam s2),
Coercible_ (VerUStore s1) (VerUStore s2)) =>
UContractRouter s1 -> UContractRouter s2
coerceUContractRouter UContractRouter newVer
code
| Just UContractRouter newVer
code <- Maybe (UContractRouter newVer) -> [Maybe (UContractRouter newVer)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (UContractRouter newVer)
-> [Maybe (UContractRouter newVer)])
-> Maybe (UContractRouter newVer)
-> [Maybe (UContractRouter newVer)]
forall a b. (a -> b) -> a -> b
$ EpwUpgradeParameters t curVer newVer
-> Maybe (UContractRouter newVer)
forall (curVer :: VersionKind) (newVer :: VersionKind)
(t :: * -> *).
EpwUpgradeParameters t curVer newVer
-> Maybe (UContractRouter newVer)
upNewCode' EpwUpgradeParameters t curVer newVer
epw
]
, [SomePermanentImpl (VerPermanent curVer) -> Parameter curVer
forall (ver :: VersionKind).
SomePermanentImpl (VerPermanent ver) -> Parameter ver
EpwSetPermCode (SomePermanentImpl (VerPermanent curVer) -> Parameter curVer)
-> SomePermanentImpl (VerPermanent curVer) -> Parameter curVer
forall a b. (a -> b) -> a -> b
$ PermanentImpl newVer -> SomePermanentImpl (VerPermanent newVer)
forall a b. (CanCastTo a b, Coercible a b) => a -> b
checkedCoerce PermanentImpl newVer
code
| Just PermanentImpl newVer
code <- Maybe (PermanentImpl newVer) -> [Maybe (PermanentImpl newVer)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (PermanentImpl newVer) -> [Maybe (PermanentImpl newVer)])
-> Maybe (PermanentImpl newVer) -> [Maybe (PermanentImpl newVer)]
forall a b. (a -> b) -> a -> b
$ EpwUpgradeParameters t curVer newVer
-> Maybe (PermanentImpl newVer)
forall (curVer :: VersionKind) (newVer :: VersionKind)
(t :: * -> *).
EpwUpgradeParameters t curVer newVer
-> Maybe (PermanentImpl newVer)
upNewPermCode' EpwUpgradeParameters t curVer newVer
epw
]
((VerPermanent curVer ~ VerPermanent newVer) => [Parameter curVer])
-> (RequireSamePermanents
(VerPermanent curVer) (VerPermanent newVer)
:- (VerPermanent curVer ~ VerPermanent newVer))
-> [Parameter curVer]
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ RequireSamePermanents (VerPermanent curVer) (VerPermanent newVer)
:- (VerPermanent curVer ~ VerPermanent newVer)
forall (ver1 :: VersionKind) (ver2 :: VersionKind).
RequireSamePermanents (VerPermanent ver1) (VerPermanent ver2)
:- (VerPermanent ver1 ~ VerPermanent ver2)
permanentsAreSameEvi @curVer @newVer
, [Parameter curVer
forall (ver :: VersionKind). Parameter ver
EpwFinishUpgrade]
]
data UpgradeWay (t :: Kind.Type -> Kind.Type) where
UpgOneShot :: UpgradeWay Identity
UpgEntrypointWise :: UpgradeWay t
deriving stock instance Show (UpgradeWay t)
type SimpleUpgradeWay = UpgradeWay Identity
integrationalTestUpgrade
:: (PermConstraint curVer)
=> EpwUpgradeParameters t curVer newVer
-> UpgradeWay t
-> UTAddress curVer
-> IntegrationalScenarioM (UTAddress newVer)
integrationalTestUpgrade :: EpwUpgradeParameters t curVer newVer
-> UpgradeWay t
-> UTAddress curVer
-> IntegrationalScenarioM (UTAddress newVer)
integrationalTestUpgrade EpwUpgradeParameters t curVer newVer
upgParams UpgradeWay t
way UTAddress curVer
addr =
UTAddress curVer -> UTAddress newVer
coerce UTAddress curVer
addr UTAddress newVer
-> IntegrationalScenarioM ()
-> IntegrationalScenarioM (UTAddress newVer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ case UpgradeWay t
way of
UpgradeWay t
UpgOneShot -> UTAddress curVer -> Parameter curVer -> IntegrationalScenarioM ()
forall cp defEpName defArg addr.
(HasDefEntrypointArg cp defEpName defArg, IsoValue defArg,
ToTAddress cp addr) =>
addr -> defArg -> IntegrationalScenarioM ()
lCallDef UTAddress curVer
addr (EpwUpgradeParameters Identity curVer newVer -> Parameter curVer
forall (oldVer :: VersionKind) (newVer :: VersionKind).
EpwUpgradeParameters Identity oldVer newVer -> Parameter oldVer
makeOneShotUpgrade EpwUpgradeParameters t curVer newVer
EpwUpgradeParameters Identity curVer newVer
upgParams)
UpgradeWay t
UpgEntrypointWise -> (Element [Parameter curVer] -> IntegrationalScenarioM ())
-> [Parameter curVer] -> IntegrationalScenarioM ()
forall t (m :: * -> *) b.
(Container t, Monad m) =>
(Element t -> m b) -> t -> m ()
mapM_ (UTAddress curVer -> Parameter curVer -> IntegrationalScenarioM ()
forall cp defEpName defArg addr.
(HasDefEntrypointArg cp defEpName defArg, IsoValue defArg,
ToTAddress cp addr) =>
addr -> defArg -> IntegrationalScenarioM ()
lCallDef UTAddress curVer
addr) (EpwUpgradeParameters t curVer newVer -> [Parameter curVer]
forall (curVer :: VersionKind) (newVer :: VersionKind)
(t :: * -> *).
EpwUpgradeParameters t curVer newVer -> [Parameter curVer]
makeEpwUpgrade EpwUpgradeParameters t curVer newVer
upgParams)