-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- TODO: Replace 'Empty' with 'Never' from morley
{-# OPTIONS_GHC -Wno-deprecations #-}

-- | Type-safe interface for constructing contract upgrades.
--
-- Use this module as follows:
-- 1. Construct 'EpwUpgradeParameters';
-- 2. Use one of the respective functions to convert it to an actual upgrade,
--    one-shot or entrypoint-wise, for tests or production.
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

----------------------------------------------------------------------------
-- Particular pieces updates
----------------------------------------------------------------------------

-- These datatypes are not part of the interface, they only keep
-- information about upgrade and respective invariants
data UContractRouterUpdate curVer newVer where
  -- | Do update.
  UcrUpdate :: UContractRouter newVer -> UContractRouterUpdate curVer newVer
  -- | Retain the same 'UContractRouter'.
  UcrRetain :: UContractRouterUpdate curVer newVer

data PermanentImplUpdate curVer newVer where
  -- | Do update.
  PiUpdate :: PermanentImpl newVer -> PermanentImplUpdate curVer newVer
  -- | Retain the same 'PermanentImpl'.
  PiRetain :: PermanentImplUpdate curVer newVer

-- Interface conveniences
----------------------------------------------------------------------------

-- | Helps to provide a pleasant interface, it would be inconvenient for
-- user to use 'UcrUpdate' and stuff.
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 errors
----------------------------------------------------------------------------

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 "`"
    )
    -- Updates which error tells about are not safe because old code may refer
    -- to a field which was removed in new version of storage.

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)

----------------------------------------------------------------------------
-- Exposed interface
----------------------------------------------------------------------------

-- | Type-safe upgrade construction.
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))
    -- ^ Storage migration script.
    -- Supply this field with result of 'migrationToScriptI' or
    -- 'migrationToScripts' call.

  , ()
upNewCode :: code
    -- ^ Updated parameter dispatching logic.
    -- Pass 'UContractRouter' or 'Nothing'.

  , ()
upNewPermCode :: codePerm
    -- ^ Updates implementation of permanent part.
    -- Pass 'PermanentImpl' or 'Nothing'.
  }

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)

-- | New version getter.
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)

-- | The current version getter.
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)

-- | New 'UContractRouter' getter.
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

-- | New 'PermanentImpl' getter.
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

-- | Make up a "fixed version" upgrade.
-- As argument you supply result of 'migrationToScriptI' or 'migrationToScripts'
-- and entrypoint-wise migration will be used inside.
--
-- Use this method in case you need to authoritatively perform arbitrary
-- modifications of contract storage.
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
  }

-- | Construct 'OneShotUpgradeParameters'.
--
-- Naturally, you can construct this kind of upgrade only if your migration
-- has exactly one stage; for batched migrations use 'makeEpwUpgrade'.
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
  )

-- | Construct a call which should be performed in order to perform migration.
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

-- | Construct calls which should be performed in order to perform full
-- entrypoint-wise migration.
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]
  ]

-- | Way of performing an upgrade.
data UpgradeWay (t :: Kind.Type -> Kind.Type) where
  -- | Perform upgrade in a single transaction.
  -- This, naturally, cannot be used with batched migrations.
  UpgOneShot :: UpgradeWay Identity

  -- | Perform upgrade calling one entrypoint per transaction.
  UpgEntrypointWise :: UpgradeWay t

deriving stock instance Show (UpgradeWay t)

-- | 'UpgradeWay' which can be used with simple (non-batched) migrations.
type SimpleUpgradeWay = UpgradeWay Identity

-- | Perform a contract upgrade in an integrational test scenario.
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)