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

{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Elemental building blocks for migrations.
module Lorentz.UStore.Migration.Blocks
  ( -- * General
    mustoreToOld
  , MigrationFinishCheckPosition (..)

    -- * Elemental steps
  , migrateCoerceUnsafe
  , migrateGetField
  , migrateAddField
  , migrateRemoveField
  , migrateExtractField
  , migrateOverwriteField
  , migrateModifyField

    -- * Migration batches
  , muBlock
  , muBlockNamed
  , (<-->)
  , ($:)
  ) where

import Lorentz.Base
import Lorentz.Coercions
import Lorentz.Instr (dip)
import Lorentz.UStore.Instr
import Lorentz.UStore.Migration.Base
import Lorentz.UStore.Migration.Diff
import Lorentz.UStore.Types
import Util.Label (Label)
import Util.Type
import Util.TypeLits

-- | Helper for 'mustoreToOld' which ensures that given store hasn't been
-- (partially) migrated yet.
type family RequireBeInitial (touched :: [Symbol]) :: Constraint where
  RequireBeInitial '[] = ()
  RequireBeInitial _ =
    TypeError ('Text "Migration has already been started over this store")

type family RequireUntouched (field :: Symbol) (wasTouched :: Bool)
             :: Constraint where
  RequireUntouched _ 'False = ()
  RequireUntouched field 'True = TypeError
    ('Text ("Field `" `AppendSymbol` field `AppendSymbol` "` has already been \
            \migrated and cannot be read")
    )

-- | Cast field or submap pretending that its value fits to the new type.
--
-- Useful when type of field, e.g. lambda or set of lambdas, is polymorphic
-- over storage type.
migrateCoerceUnsafe
  :: forall field oldTempl newTempl diff touched newDiff newDiff0 _1 _2 s.
     ( '(_1, newDiff0) ~ CoverDiff 'DcRemove field diff
     , '(_2, newDiff) ~ CoverDiff 'DcAdd field newDiff0
     )
  => Label field
  -> MUStore oldTempl newTempl diff touched : s
  :-> MUStore oldTempl newTempl newDiff touched : s
migrateCoerceUnsafe :: Label field
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (MUStore oldTempl newTempl newDiff touched : s)
migrateCoerceUnsafe _ =
  (MUStore oldTempl newTempl diff touched : s)
:-> (MUStore oldTempl newTempl newDiff touched : s)
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_

-- Migrating fields
----------------------------------------------------------------------------

-- | Get a field present in old version of 'UStore'.
migrateGetField
  :: forall field oldTempl newTempl diff touched fieldTy s.
     ( HasUField field fieldTy oldTempl
     , RequireUntouched field (field `IsElem` touched)
     )
  => Label field
  -> MUStore oldTempl newTempl diff touched : s
  :-> fieldTy : MUStore oldTempl newTempl diff touched : s
migrateGetField :: Label field
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
migrateGetField label :: Label field
label =
  forall (s :: [*]).
MichelsonCoercible
  (MUStore oldTempl newTempl diff touched) (UStore oldTempl) =>
(MUStore oldTempl newTempl diff touched & s)
:-> (UStore oldTempl & s)
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_ @_ @(UStore oldTempl) ((MUStore oldTempl newTempl diff touched : s)
 :-> (UStore oldTempl & s))
-> ((UStore oldTempl & s) :-> (fieldTy & (UStore oldTempl & s)))
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy & (UStore oldTempl & s))
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label field
-> (UStore oldTempl & s)
   :-> (GetUStoreField oldTempl field : (UStore oldTempl & s))
forall store (name :: Symbol) (s :: [*]).
FieldAccessC store name =>
Label name
-> (UStore store : s)
   :-> (GetUStoreField store name : UStore store : s)
ustoreGetField Label field
label ((MUStore oldTempl newTempl diff touched : s)
 :-> (fieldTy & (UStore oldTempl & s)))
-> ((fieldTy & (UStore oldTempl & s))
    :-> (fieldTy : MUStore oldTempl newTempl diff touched : s))
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# ((UStore oldTempl & s)
 :-> (MUStore oldTempl newTempl diff touched : s))
-> (fieldTy & (UStore oldTempl & s))
   :-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a & s) :-> (a & s')
dip (UStore oldTempl & s)
:-> (MUStore oldTempl newTempl diff touched : s)
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_

-- | Add a field which was not present before.
-- This covers one addition from the diff and any removals of field with given
-- name.
--
-- This function cannot overwrite existing field with the same name, if this
-- is necessary use 'migrateOverwriteField' which would declare removal
-- explicitly.
migrateAddField
  :: forall field oldTempl newTempl diff touched fieldTy newDiff marker s.
     ( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcAdd field diff
     , HasUField field fieldTy newTempl
     )
  => Label field
  -> fieldTy : MUStore oldTempl newTempl diff touched : s
  :-> MUStore oldTempl newTempl newDiff (field ': touched) : s
migrateAddField :: Label field
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (MUStore oldTempl newTempl newDiff (field : touched) : s)
migrateAddField label :: Label field
label =
  DMigrationActionType
-> Label field
-> Proxy fieldTy
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
forall fieldTy (fieldName :: Symbol) (s :: [*]).
SingI (ToT fieldTy) =>
DMigrationActionType -> Label fieldName -> Proxy fieldTy -> s :-> s
attachMigrationActionName (Text -> DMigrationActionType
DAddAction "add") Label field
label (Proxy fieldTy
forall k (t :: k). Proxy t
Proxy @fieldTy) ((fieldTy : MUStore oldTempl newTempl diff touched : s)
 :-> (fieldTy : MUStore oldTempl newTempl diff touched : s))
-> ((fieldTy : MUStore oldTempl newTempl diff touched : s)
    :-> (fieldTy & (UStore newTempl & s)))
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy & (UStore newTempl & s))
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  ((MUStore oldTempl newTempl diff touched : s)
 :-> (UStore newTempl & s))
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy & (UStore newTempl & s))
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a & s) :-> (a & s')
dip (forall (s :: [*]).
MichelsonCoercible
  (MUStore oldTempl newTempl diff touched) (UStore newTempl) =>
(MUStore oldTempl newTempl diff touched & s)
:-> (UStore newTempl & s)
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_ @_ @(UStore newTempl)) ((fieldTy : MUStore oldTempl newTempl diff touched : s)
 :-> (fieldTy & (UStore newTempl & s)))
-> ((fieldTy & (UStore newTempl & s)) :-> (UStore newTempl & s))
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (UStore newTempl & s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label field
-> (GetUStoreField newTempl field : (UStore newTempl & s))
   :-> (UStore newTempl & s)
forall store (name :: Symbol) (s :: [*]).
FieldAccessC store name =>
Label name
-> (GetUStoreField store name : UStore store : s)
   :-> (UStore store : s)
ustoreSetField Label field
label ((fieldTy : MUStore oldTempl newTempl diff touched : s)
 :-> (UStore newTempl & s))
-> ((UStore newTempl & s)
    :-> (MUStore oldTempl newTempl newDiff (field : touched) : s))
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (MUStore oldTempl newTempl newDiff (field : touched) : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (UStore newTempl & s)
:-> (MUStore oldTempl newTempl newDiff (field : touched) : s)
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_

-- | Remove a field which should not be present in new version of storage.
-- This covers one removal from the diff.
--
-- In fact, this action could be performed automatically, but since
-- removal is a destructive operation, being explicit about it seems
-- like a good thing.
migrateRemoveField
  :: forall field oldTempl newTempl diff touched fieldTy newDiff marker s.
     ( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcRemove field diff
     , HasUField field fieldTy oldTempl
     )
  => Label field
  -> MUStore oldTempl newTempl diff touched : s
  :-> MUStore oldTempl newTempl newDiff (field ': touched) : s
migrateRemoveField :: Label field
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (MUStore oldTempl newTempl newDiff (field : touched) : s)
migrateRemoveField label :: Label field
label =
  DMigrationActionType
-> Label field
-> Proxy fieldTy
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (MUStore oldTempl newTempl diff touched : s)
forall fieldTy (fieldName :: Symbol) (s :: [*]).
SingI (ToT fieldTy) =>
DMigrationActionType -> Label fieldName -> Proxy fieldTy -> s :-> s
attachMigrationActionName DMigrationActionType
DDelAction Label field
label (Proxy fieldTy
forall k (t :: k). Proxy t
Proxy @fieldTy) ((MUStore oldTempl newTempl diff touched : s)
 :-> (MUStore oldTempl newTempl diff touched : s))
-> ((MUStore oldTempl newTempl diff touched : s)
    :-> (UStore oldTempl & s))
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (UStore oldTempl & s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  forall (s :: [*]).
MichelsonCoercible
  (MUStore oldTempl newTempl diff touched) (UStore oldTempl) =>
(MUStore oldTempl newTempl diff touched & s)
:-> (UStore oldTempl & s)
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_ @_ @(UStore oldTempl) ((MUStore oldTempl newTempl diff touched : s)
 :-> (UStore oldTempl & s))
-> ((UStore oldTempl & s) :-> (UStore oldTempl & s))
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (UStore oldTempl & s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label field -> (UStore oldTempl & s) :-> (UStore oldTempl & s)
forall store (name :: Symbol) (s :: [*]).
FieldAccessC store name =>
Label name -> (UStore store : s) :-> (UStore store : s)
ustoreRemoveFieldUnsafe Label field
label ((MUStore oldTempl newTempl diff touched : s)
 :-> (UStore oldTempl & s))
-> ((UStore oldTempl & s)
    :-> (MUStore oldTempl newTempl newDiff (field : touched) : s))
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (MUStore oldTempl newTempl newDiff (field : touched) : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (UStore oldTempl & s)
:-> (MUStore oldTempl newTempl newDiff (field : touched) : s)
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_

-- | Get and remove a field from old version of 'UStore'.
--
-- You probably want to use this more often than plain 'migrateRemoveField'.
migrateExtractField
  :: forall field oldTempl newTempl diff touched fieldTy newDiff marker s.
     ( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcRemove field diff
     , HasUField field fieldTy oldTempl
     , RequireUntouched field (field `IsElem` touched)
     )
  => Label field
  -> MUStore oldTempl newTempl diff touched : s
  :-> fieldTy : MUStore oldTempl newTempl newDiff (field ': touched) : s
migrateExtractField :: Label field
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy
          : MUStore oldTempl newTempl newDiff (field : touched) : s)
migrateExtractField label :: Label field
label =
  DMigrationActionType
-> Label field
-> Proxy fieldTy
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (MUStore oldTempl newTempl diff touched : s)
forall fieldTy (fieldName :: Symbol) (s :: [*]).
SingI (ToT fieldTy) =>
DMigrationActionType -> Label fieldName -> Proxy fieldTy -> s :-> s
attachMigrationActionName DMigrationActionType
DDelAction Label field
label (Proxy fieldTy
forall k (t :: k). Proxy t
Proxy @fieldTy) ((MUStore oldTempl newTempl diff touched : s)
 :-> (MUStore oldTempl newTempl diff touched : s))
-> ((MUStore oldTempl newTempl diff touched : s)
    :-> (fieldTy : MUStore oldTempl newTempl diff touched : s))
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  Label field
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
forall (field :: Symbol) oldTempl newTempl (diff :: [DiffItem])
       (touched :: [Symbol]) fieldTy (s :: [*]).
(HasUField field fieldTy oldTempl,
 RequireUntouched field (IsElem field touched)) =>
Label field
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
migrateGetField Label field
label ((MUStore oldTempl newTempl diff touched : s)
 :-> (fieldTy : MUStore oldTempl newTempl diff touched : s))
-> ((fieldTy : MUStore oldTempl newTempl diff touched : s)
    :-> (fieldTy
           : MUStore oldTempl newTempl newDiff (field : touched) : s))
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy
          : MUStore oldTempl newTempl newDiff (field : touched) : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# ((MUStore oldTempl newTempl diff touched : s)
 :-> (MUStore oldTempl newTempl newDiff (field : touched) : s))
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy
          : MUStore oldTempl newTempl newDiff (field : touched) : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a & s) :-> (a & s')
dip (Label field
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (MUStore oldTempl newTempl newDiff (field : touched) : s)
forall (field :: Symbol) oldTempl newTempl (diff :: [DiffItem])
       (touched :: [Symbol]) fieldTy (newDiff :: [DiffItem])
       (marker :: UStoreMarkerType) (s :: [*]).
('(UStoreFieldExt marker fieldTy, newDiff)
 ~ CoverDiff 'DcRemove field diff,
 HasUField field fieldTy oldTempl) =>
Label field
-> (MUStore oldTempl newTempl diff touched : s)
   :-> (MUStore oldTempl newTempl newDiff (field : touched) : s)
migrateRemoveField Label field
label)

-- | Remove field and write new one in place of it.
--
-- This is semantically equivalent to
-- @dip (migrateRemoveField label) >> migrateAddField label@,
-- but is cheaper.
migrateOverwriteField
  :: forall field oldTempl newTempl diff touched fieldTy oldFieldTy
            marker oldMarker newDiff newDiff0 s.
     ( '(UStoreFieldExt oldMarker oldFieldTy, newDiff0) ~ CoverDiff 'DcRemove field diff
     , '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcAdd field newDiff0
     , HasUField field fieldTy newTempl
     )
  => Label field
  -> fieldTy : MUStore oldTempl newTempl diff touched : s
  :-> MUStore oldTempl newTempl newDiff (field ': touched) : s
migrateOverwriteField :: Label field
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (MUStore oldTempl newTempl newDiff (field : touched) : s)
migrateOverwriteField label :: Label field
label =
  DMigrationActionType
-> Label field
-> Proxy fieldTy
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
forall fieldTy (fieldName :: Symbol) (s :: [*]).
SingI (ToT fieldTy) =>
DMigrationActionType -> Label fieldName -> Proxy fieldTy -> s :-> s
attachMigrationActionName (Text -> DMigrationActionType
DAddAction "overwrite") Label field
label (Proxy fieldTy
forall k (t :: k). Proxy t
Proxy @fieldTy) ((fieldTy : MUStore oldTempl newTempl diff touched : s)
 :-> (fieldTy : MUStore oldTempl newTempl diff touched : s))
-> ((fieldTy : MUStore oldTempl newTempl diff touched : s)
    :-> (fieldTy & (UStore newTempl & s)))
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy & (UStore newTempl & s))
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  ((MUStore oldTempl newTempl diff touched : s)
 :-> (UStore newTempl & s))
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy & (UStore newTempl & s))
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a & s) :-> (a & s')
dip (forall (s :: [*]).
MichelsonCoercible
  (MUStore oldTempl newTempl diff touched) (UStore newTempl) =>
(MUStore oldTempl newTempl diff touched & s)
:-> (UStore newTempl & s)
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_ @_ @(UStore newTempl)) ((fieldTy : MUStore oldTempl newTempl diff touched : s)
 :-> (fieldTy & (UStore newTempl & s)))
-> ((fieldTy & (UStore newTempl & s)) :-> (UStore newTempl & s))
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (UStore newTempl & s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label field
-> (GetUStoreField newTempl field : (UStore newTempl & s))
   :-> (UStore newTempl & s)
forall store (name :: Symbol) (s :: [*]).
FieldAccessC store name =>
Label name
-> (GetUStoreField store name : UStore store : s)
   :-> (UStore store : s)
ustoreSetField Label field
label ((fieldTy : MUStore oldTempl newTempl diff touched : s)
 :-> (UStore newTempl & s))
-> ((UStore newTempl & s)
    :-> (MUStore oldTempl newTempl newDiff (field : touched) : s))
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (MUStore oldTempl newTempl newDiff (field : touched) : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (UStore newTempl & s)
:-> (MUStore oldTempl newTempl newDiff (field : touched) : s)
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_

-- | Modify field which should stay in new version of storage.
-- This does not affect remaining diff.
migrateModifyField
  :: forall field oldTempl newTempl diff touched fieldTy s.
     ( HasUField field fieldTy oldTempl
     , HasUField field fieldTy newTempl
     )
  => Label field
  -> fieldTy : MUStore oldTempl newTempl diff touched : s
  :-> MUStore oldTempl newTempl diff touched : s
migrateModifyField :: Label field
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (MUStore oldTempl newTempl diff touched : s)
migrateModifyField label :: Label field
label =
  DMigrationActionType
-> Label field
-> Proxy fieldTy
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
forall fieldTy (fieldName :: Symbol) (s :: [*]).
SingI (ToT fieldTy) =>
DMigrationActionType -> Label fieldName -> Proxy fieldTy -> s :-> s
attachMigrationActionName (Text -> DMigrationActionType
DAddAction "modify") Label field
label (Proxy fieldTy
forall k (t :: k). Proxy t
Proxy @fieldTy) ((fieldTy : MUStore oldTempl newTempl diff touched : s)
 :-> (fieldTy : MUStore oldTempl newTempl diff touched : s))
-> ((fieldTy : MUStore oldTempl newTempl diff touched : s)
    :-> (fieldTy & (UStore oldTempl & s)))
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy & (UStore oldTempl & s))
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  ((MUStore oldTempl newTempl diff touched : s)
 :-> (UStore oldTempl & s))
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (fieldTy & (UStore oldTempl & s))
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a & s) :-> (a & s')
dip (forall (s :: [*]).
MichelsonCoercible
  (MUStore oldTempl newTempl diff touched) (UStore oldTempl) =>
(MUStore oldTempl newTempl diff touched & s)
:-> (UStore oldTempl & s)
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_ @_ @(UStore oldTempl)) ((fieldTy : MUStore oldTempl newTempl diff touched : s)
 :-> (fieldTy & (UStore oldTempl & s)))
-> ((fieldTy & (UStore oldTempl & s)) :-> (UStore oldTempl & s))
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (UStore oldTempl & s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label field
-> (GetUStoreField oldTempl field : (UStore oldTempl & s))
   :-> (UStore oldTempl & s)
forall store (name :: Symbol) (s :: [*]).
FieldAccessC store name =>
Label name
-> (GetUStoreField store name : UStore store : s)
   :-> (UStore store : s)
ustoreSetField Label field
label ((fieldTy : MUStore oldTempl newTempl diff touched : s)
 :-> (UStore oldTempl & s))
-> ((UStore oldTempl & s)
    :-> (MUStore oldTempl newTempl diff touched : s))
-> (fieldTy : MUStore oldTempl newTempl diff touched : s)
   :-> (MUStore oldTempl newTempl diff touched : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (UStore oldTempl & s)
:-> (MUStore oldTempl newTempl diff touched : s)
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_

-- Migrating virtual submaps (strict migration)
----------------------------------------------------------------------------

{- For now we do not support this kind of migration.

"Strict" means that we want to modify maps right here rather than signal to
do modification of each entry on first access to it (which would be simpler
in some sense).

Implementing this is slightly less trivial than migrating individial fields.
1. One needs current value of UStore picked from the contract, because it's
not possible to iterate over big_map from within a contract in the current mainnet.
Even if it was, we can't assume that iteration of the whole submap would fit
into gas limit of single transaction, thus iteration should be performed
from outside of the contract by someone who knows the current storage.

2. We need to split migration in batches smartly. Too big batches would hit
operation size limit, while small ones would cause high overhead of
contract/storage deserialization.
Will be resolved in TM-330.
-}

----------------------------------------------------------------------------
-- Blocks for batched migrations
----------------------------------------------------------------------------

-- | Define a migration atom.
--
-- It will be named automatically according to the set of actions it performs
-- (via 'DMigrationActionDesc's).
-- This may be want you want for small sequences of actions, but for complex ones
-- consider using 'muBlockNamed'.
-- Names are used in rendering migration plan.
muBlock
  :: ('[MUStore o n d1 t1] :-> '[MUStore o n d2 t2])
  -> MigrationBlocks o n d1 t1 d2 t2
muBlock :: ('[MUStore o n d1 t1] :-> '[MUStore o n d2 t2])
-> MigrationBlocks o n d1 t1 d2 t2
muBlock code :: '[MUStore o n d1 t1] :-> '[MUStore o n d2 t2]
code =
  [MigrationAtom] -> MigrationBlocks o n d1 t1 d2 t2
forall oldTemplate newTemplate (preRemDiff :: [DiffItem])
       (preTouched :: [Symbol]) (postRemDiff :: [DiffItem])
       (postTouched :: [Symbol]).
[MigrationAtom]
-> MigrationBlocks
     oldTemplate
     newTemplate
     preRemDiff
     preTouched
     postRemDiff
     postTouched
MigrationBlocks ([MigrationAtom] -> MigrationBlocks o n d1 t1 d2 t2)
-> (Lambda UStore_ UStore_ -> [MigrationAtom])
-> Lambda UStore_ UStore_
-> MigrationBlocks o n d1 t1 d2 t2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationAtom -> [MigrationAtom]
forall x. One x => OneItem x -> x
one (MigrationAtom -> [MigrationAtom])
-> (Lambda UStore_ UStore_ -> MigrationAtom)
-> Lambda UStore_ UStore_
-> [MigrationAtom]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Lambda UStore_ UStore_ -> MigrationAtom
formMigrationAtom Maybe Text
forall a. Maybe a
Nothing (Lambda UStore_ UStore_ -> MigrationBlocks o n d1 t1 d2 t2)
-> Lambda UStore_ UStore_ -> MigrationBlocks o n d1 t1 d2 t2
forall a b. (a -> b) -> a -> b
$
    (UStore_ & '[]) :-> '[MUStore o n d1 t1]
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_ ((UStore_ & '[]) :-> '[MUStore o n d1 t1])
-> ('[MUStore o n d1 t1] :-> '[MUStore o n d2 t2])
-> (UStore_ & '[]) :-> '[MUStore o n d2 t2]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[MUStore o n d1 t1] :-> '[MUStore o n d2 t2]
code ((UStore_ & '[]) :-> '[MUStore o n d2 t2])
-> ('[MUStore o n d2 t2] :-> (UStore_ & '[]))
-> Lambda UStore_ UStore_
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[MUStore o n d2 t2] :-> (UStore_ & '[])
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_

-- | Define a migration atom with given name.
--
-- Name will be used when rendering migration plan.
muBlockNamed
  :: Text
  -> ('[MUStore o n d1 t1] :-> '[MUStore o n d2 t2])
  -> MigrationBlocks o n d1 t1 d2 t2
muBlockNamed :: Text
-> ('[MUStore o n d1 t1] :-> '[MUStore o n d2 t2])
-> MigrationBlocks o n d1 t1 d2 t2
muBlockNamed name :: Text
name code :: '[MUStore o n d1 t1] :-> '[MUStore o n d2 t2]
code =
  [MigrationAtom] -> MigrationBlocks o n d1 t1 d2 t2
forall oldTemplate newTemplate (preRemDiff :: [DiffItem])
       (preTouched :: [Symbol]) (postRemDiff :: [DiffItem])
       (postTouched :: [Symbol]).
[MigrationAtom]
-> MigrationBlocks
     oldTemplate
     newTemplate
     preRemDiff
     preTouched
     postRemDiff
     postTouched
MigrationBlocks ([MigrationAtom] -> MigrationBlocks o n d1 t1 d2 t2)
-> (Lambda UStore_ UStore_ -> [MigrationAtom])
-> Lambda UStore_ UStore_
-> MigrationBlocks o n d1 t1 d2 t2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationAtom -> [MigrationAtom]
forall x. One x => OneItem x -> x
one (MigrationAtom -> [MigrationAtom])
-> (Lambda UStore_ UStore_ -> MigrationAtom)
-> Lambda UStore_ UStore_
-> [MigrationAtom]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Lambda UStore_ UStore_ -> MigrationAtom
formMigrationAtom (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name) (Lambda UStore_ UStore_ -> MigrationBlocks o n d1 t1 d2 t2)
-> Lambda UStore_ UStore_ -> MigrationBlocks o n d1 t1 d2 t2
forall a b. (a -> b) -> a -> b
$
    (UStore_ & '[]) :-> '[MUStore o n d1 t1]
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_ ((UStore_ & '[]) :-> '[MUStore o n d1 t1])
-> ('[MUStore o n d1 t1] :-> '[MUStore o n d2 t2])
-> (UStore_ & '[]) :-> '[MUStore o n d2 t2]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[MUStore o n d1 t1] :-> '[MUStore o n d2 t2]
code ((UStore_ & '[]) :-> '[MUStore o n d2 t2])
-> ('[MUStore o n d2 t2] :-> (UStore_ & '[]))
-> Lambda UStore_ UStore_
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[MUStore o n d2 t2] :-> (UStore_ & '[])
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_

-- | Composition of migration blocks.
(<-->)
  :: MigrationBlocks o n d1 t1 d2 t2
  -> MigrationBlocks o n d2 t2 d3 t3
  -> MigrationBlocks o n d1 t1 d3 t3
MigrationBlocks blocks1 :: [MigrationAtom]
blocks1 <--> :: MigrationBlocks o n d1 t1 d2 t2
-> MigrationBlocks o n d2 t2 d3 t3
-> MigrationBlocks o n d1 t1 d3 t3
<--> MigrationBlocks blocks2 :: [MigrationAtom]
blocks2 =
  [MigrationAtom] -> MigrationBlocks o n d1 t1 d3 t3
forall oldTemplate newTemplate (preRemDiff :: [DiffItem])
       (preTouched :: [Symbol]) (postRemDiff :: [DiffItem])
       (postTouched :: [Symbol]).
[MigrationAtom]
-> MigrationBlocks
     oldTemplate
     newTemplate
     preRemDiff
     preTouched
     postRemDiff
     postTouched
MigrationBlocks ([MigrationAtom]
blocks1 [MigrationAtom] -> [MigrationAtom] -> [MigrationAtom]
forall a. Semigroup a => a -> a -> a
<> [MigrationAtom]
blocks2)
infixl 2 <-->

{- | This is '$' operator with priority higher than '<-->'.

It allows you writing

@
mkUStoreBatchedMigration =
  muBlock $: do
    migrateAddField ...
  <-->
  muBlock $: do
    migrateRemoveField ...
@

Alternatively, @BlockArguments@ extension can be used.
-}
($:) :: (a -> b) -> a -> b
$: :: (a -> b) -> a -> b
($:) = (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($)
infixr 7 $:

----------------------------------------------------------------------------
-- Common
----------------------------------------------------------------------------

-- | Get the old version of storage.
--
-- This can be applied only in the beginning of migration.
--
-- In fact this function is not very useful, all required operations should
-- be available for 'MUStore', but leaving it here just in case.
mustoreToOld
  :: RequireBeInitial touched
  => MUStore oldTemplate newTemplate remDiff touched : s
  :-> UStore oldTemplate : s
mustoreToOld :: (MUStore oldTemplate newTemplate remDiff touched : s)
:-> (UStore oldTemplate : s)
mustoreToOld = (MUStore oldTemplate newTemplate remDiff touched : s)
:-> (UStore oldTemplate : s)
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_

class MigrationFinishCheckPosition a where
  -- | Put this in the end of migration script to get a human-readable message
  -- about remaining diff which yet should be covered.
  -- Use of this function in migration is fully optional.
  --
  -- This function is not part of 'mkUStoreMigration' for the sake of
  -- proper error messages ordering, during development
  -- you probably want errors in migration script to be located earlier
  -- in code than errors about not fully covered diff (if you used
  -- to fix errors in the same order in which they appear).
  migrationFinish :: a

-- | This version can be used in 'mkUStoreMigration'.
instance ( i ~ (MUStore oldTempl newTempl diff touched : s)
         , o ~ (MUStore oldTempl newTempl '[] touched : s)
         , RequireEmptyDiff diff
         ) =>
         MigrationFinishCheckPosition (i :-> o) where
  migrationFinish :: i :-> o
migrationFinish = i :-> o
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_

-- | This version can be used in 'mkUStoreMultiMigration' as the last migration
-- block.
instance (RequireEmptyDiff d1, t1 ~ t2) =>
         MigrationFinishCheckPosition (MigrationBlocks o n d1 t1 '[] t2) where
  migrationFinish :: MigrationBlocks o n d1 t1 '[] t2
migrationFinish = [MigrationAtom] -> MigrationBlocks o n d1 t1 '[] t2
forall oldTemplate newTemplate (preRemDiff :: [DiffItem])
       (preTouched :: [Symbol]) (postRemDiff :: [DiffItem])
       (postTouched :: [Symbol]).
[MigrationAtom]
-> MigrationBlocks
     oldTemplate
     newTemplate
     preRemDiff
     preTouched
     postRemDiff
     postTouched
MigrationBlocks []