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

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

{- | Basic migration primitives.

All primitives in one scheme:


                         MigrationBlocks
                   (batched migrations writing)
                    /|          ||
           muBlock //           || mkUStoreBatchedMigration
                  //            ||
                 //             ||
             MUStore            ||         UStore template value
    (simple migration writing)  ||       (storage initialization)
                    \\          ||         //
                     \\         ||        //
    mkUStoreMigration \\        ||       // fillUStore
                       \|       \/      |/
                         UStoreMigration
                        (whole migration)
                              ||    \\
                              ||     \\
            migrationToScript ||      \\ compileMigration
                              ||       \\                    MigrationBatching
                              ||        \\                (way to slice migration)
                              ||         \\                    //
                              ||          \\                  //
                              ||           \|                |/
                              ||         UStoreMigrationCompiled
                              ||           (sliced migration)
                              ||          //                 \\
                              ||    migrationToScripts        \\ buildMigrationPlan
                              ||        //                     \\ migrationStagesNum
                              ||       //                       \\ ...
                              \/      |/                         \|
                        MigrationScript                    Information about migration
                    (part of migration which            (migration plan, stages number...)
                  fits into Tezos transaction)

-}
module Lorentz.UStore.Migration.Base
  ( -- * 'UStore' utilities
    SomeUTemplate
  , UStore_

    -- * Basic migration primitives
  , MigrationScript (..)
  , maNameL
  , maScriptL
  , maActionsDescL
  , MigrationScriptFrom
  , MigrationScriptTo
  , MigrationScript_
  , MigrationAtom (..)
  , UStoreMigration (..)
  , MigrationBlocks (..)
  , MUStore (..)
  , migrationToLambda
  , mapMigrationCode

    -- ** Simple migrations
  , mkUStoreMigration
  , migrationToScript
  , migrationToScriptI

    -- ** Batched migrations
  , MigrationBatching (..)
  , mbBatchesAsIs
  , mbNoBatching
  , compileMigration
  , UStoreMigrationCompiled (..)
  , mkUStoreBatchedMigration
  , migrationToScripts
  , migrationToScriptsList
  , migrationToInfo
  , migrationStagesNum
  , buildMigrationPlan

    -- * Manual migrations
  , manualWithOldUStore
  , manualWithNewUStore
  , manualConcatMigrationScripts
  , manualMapMigrationScript

    -- * Extras
  , DMigrationActionType (..)
  , DMigrationActionDesc (..)
  , attachMigrationActionName

    -- * Internals
  , formMigrationAtom
  ) where

import Control.Lens (iso, traversed)
import qualified Data.Foldable as Foldable
import qualified Data.Kind as Kind
import Data.Singletons (SingI(..), demote)
import qualified Data.Typeable as Typeable
import Fmt (Buildable(..), Builder, fmt)

import Lorentz.Annotation (HasAnnotation)
import Lorentz.Base
import Lorentz.Coercions
import Lorentz.Doc
import Lorentz.UStore.Doc
import Lorentz.Instr (nop)
import Lorentz.Run
import Lorentz.UStore.Types
import Lorentz.Value
import Michelson.Typed.Haskell.Doc (applyWithinParens)
import Michelson.Typed (ExtInstr(..), Instr(..), T(..))
import Michelson.Typed.Util
import Util.Label (labelToText)
import Util.Lens
import Util.Markdown
import Util.TypeLits

import Lorentz.UStore.Migration.Diff

----------------------------------------------------------------------------
-- UStore utilities
----------------------------------------------------------------------------

-- | Dummy template for 'UStore', use this when you want to forget exact template
-- and make type of store homomorphic.
data SomeUTemplate

-- | UStore with hidden template.
type UStore_ = UStore SomeUTemplate

-- | We allow casting between 'UStore_' and 'UStore' freely.
instance SameUStoreTemplate template1 template2 =>
         UStore template1 `CanCastTo` UStore template2

type family SameUStoreTemplate (template1 :: Kind.Type) (template2 :: Kind.Type)
              :: Constraint where
  SameUStoreTemplate t t = ()  -- case for undeducible but equal types
  SameUStoreTemplate SomeUTemplate _ = ()
  SameUStoreTemplate _ SomeUTemplate = ()
  SameUStoreTemplate t1 t2 = (t1 ~ t2)

instance UStoreTemplateHasDoc SomeUTemplate where
  ustoreTemplateDocName :: Text
ustoreTemplateDocName = "Some"
  ustoreTemplateDocDescription :: Markdown
ustoreTemplateDocDescription =
    "This is a dummy template, usually designates that any format can be used \
    \here."
  ustoreTemplateDocContents :: Markdown
ustoreTemplateDocContents = Markdown -> Markdown
mdItalic "unspecified"
  ustoreTemplateDocDependencies :: [SomeTypeWithDoc]
ustoreTemplateDocDependencies = []

----------------------------------------------------------------------------
-- Migration primitives
----------------------------------------------------------------------------

-- | Code of migration for 'UStore'.
--
-- Invariant: preferably should fit into op size / gas limits (quite obvious).
-- Often this stands for exactly one stage of migration (one Tezos transaction).
newtype MigrationScript (oldStore :: Kind.Type) (newStore :: Kind.Type) =
  MigrationScript
  { MigrationScript oldStore newStore -> Lambda UStore_ UStore_
unMigrationScript :: Lambda UStore_ UStore_
  } deriving stock (Int -> MigrationScript oldStore newStore -> ShowS
[MigrationScript oldStore newStore] -> ShowS
MigrationScript oldStore newStore -> String
(Int -> MigrationScript oldStore newStore -> ShowS)
-> (MigrationScript oldStore newStore -> String)
-> ([MigrationScript oldStore newStore] -> ShowS)
-> Show (MigrationScript oldStore newStore)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall oldStore newStore.
Int -> MigrationScript oldStore newStore -> ShowS
forall oldStore newStore.
[MigrationScript oldStore newStore] -> ShowS
forall oldStore newStore.
MigrationScript oldStore newStore -> String
showList :: [MigrationScript oldStore newStore] -> ShowS
$cshowList :: forall oldStore newStore.
[MigrationScript oldStore newStore] -> ShowS
show :: MigrationScript oldStore newStore -> String
$cshow :: forall oldStore newStore.
MigrationScript oldStore newStore -> String
showsPrec :: Int -> MigrationScript oldStore newStore -> ShowS
$cshowsPrec :: forall oldStore newStore.
Int -> MigrationScript oldStore newStore -> ShowS
Show, (forall x.
 MigrationScript oldStore newStore
 -> Rep (MigrationScript oldStore newStore) x)
-> (forall x.
    Rep (MigrationScript oldStore newStore) x
    -> MigrationScript oldStore newStore)
-> Generic (MigrationScript oldStore newStore)
forall x.
Rep (MigrationScript oldStore newStore) x
-> MigrationScript oldStore newStore
forall x.
MigrationScript oldStore newStore
-> Rep (MigrationScript oldStore newStore) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall oldStore newStore x.
Rep (MigrationScript oldStore newStore) x
-> MigrationScript oldStore newStore
forall oldStore newStore x.
MigrationScript oldStore newStore
-> Rep (MigrationScript oldStore newStore) x
$cto :: forall oldStore newStore x.
Rep (MigrationScript oldStore newStore) x
-> MigrationScript oldStore newStore
$cfrom :: forall oldStore newStore x.
MigrationScript oldStore newStore
-> Rep (MigrationScript oldStore newStore) x
Generic)
    deriving anyclass (WellTypedToT (MigrationScript oldStore newStore)
WellTypedToT (MigrationScript oldStore newStore) =>
(MigrationScript oldStore newStore
 -> Value (ToT (MigrationScript oldStore newStore)))
-> (Value (ToT (MigrationScript oldStore newStore))
    -> MigrationScript oldStore newStore)
-> IsoValue (MigrationScript oldStore newStore)
Value (ToT (MigrationScript oldStore newStore))
-> MigrationScript oldStore newStore
MigrationScript oldStore newStore
-> Value (ToT (MigrationScript oldStore newStore))
forall a.
WellTypedToT a =>
(a -> Value (ToT a)) -> (Value (ToT a) -> a) -> IsoValue a
forall oldStore newStore.
WellTypedToT (MigrationScript oldStore newStore)
forall oldStore newStore.
Value (ToT (MigrationScript oldStore newStore))
-> MigrationScript oldStore newStore
forall oldStore newStore.
MigrationScript oldStore newStore
-> Value (ToT (MigrationScript oldStore newStore))
fromVal :: Value (ToT (MigrationScript oldStore newStore))
-> MigrationScript oldStore newStore
$cfromVal :: forall oldStore newStore.
Value (ToT (MigrationScript oldStore newStore))
-> MigrationScript oldStore newStore
toVal :: MigrationScript oldStore newStore
-> Value (ToT (MigrationScript oldStore newStore))
$ctoVal :: forall oldStore newStore.
MigrationScript oldStore newStore
-> Value (ToT (MigrationScript oldStore newStore))
$cp1IsoValue :: forall oldStore newStore.
WellTypedToT (MigrationScript oldStore newStore)
IsoValue, FollowEntrypointFlag
-> Notes (ToT (MigrationScript oldStore newStore))
(FollowEntrypointFlag
 -> Notes (ToT (MigrationScript oldStore newStore)))
-> HasAnnotation (MigrationScript oldStore newStore)
forall a.
(FollowEntrypointFlag -> Notes (ToT a)) -> HasAnnotation a
forall oldStore newStore.
FollowEntrypointFlag
-> Notes (ToT (MigrationScript oldStore newStore))
getAnnotation :: FollowEntrypointFlag
-> Notes (ToT (MigrationScript oldStore newStore))
$cgetAnnotation :: forall oldStore newStore.
FollowEntrypointFlag
-> Notes (ToT (MigrationScript oldStore newStore))
HasAnnotation, ToT (MigrationScript oldStore newStore)
~ ToT (Unwrappable (MigrationScript oldStore newStore))
(ToT (MigrationScript oldStore newStore)
 ~ ToT (Unwrappable (MigrationScript oldStore newStore))) =>
Wrappable (MigrationScript oldStore newStore)
forall s. (ToT s ~ ToT (Unwrappable s)) => Wrappable s
forall oldStore newStore.
ToT (MigrationScript oldStore newStore)
~ ToT (Unwrappable (MigrationScript oldStore newStore))
Wrappable)

instance (Each [Typeable, UStoreTemplateHasDoc] [oldStore, newStore]) =>
         TypeHasDoc (MigrationScript oldStore newStore) where
  typeDocMdDescription :: Markdown
typeDocMdDescription =
    "A code which updates storage in order to make it compliant with the \
    \new version of the contract.\n\
    \It is common to have a group of migration scripts because each of it \
    \is to be used in Tezos transaction and thus should fit into gas and \
    \operation size limits.\
    \"
  typeDocMdReference :: Proxy (MigrationScript oldStore newStore)
-> WithinParens -> Markdown
typeDocMdReference tp :: Proxy (MigrationScript oldStore newStore)
tp wp :: WithinParens
wp =
    WithinParens -> Markdown -> Markdown
applyWithinParens WithinParens
wp (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat
      [ Markdown -> DocItemRef 'DocItemInDefinitions 'True -> Markdown
forall anchor. ToAnchor anchor => Markdown -> anchor -> Markdown
mdLocalRef (Markdown -> Markdown
mdTicked "MigrationScript") (DType
-> DocItemRef (DocItemPlacement DType) (DocItemReferenced DType)
forall d.
DocItem d =>
d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
docItemRef (Proxy (MigrationScript oldStore newStore) -> DType
forall a. TypeHasDoc a => Proxy a -> DType
DType Proxy (MigrationScript oldStore newStore)
tp))
      , " "
      , DUStoreTemplate -> Markdown
dUStoreTemplateRef (Proxy oldStore -> DUStoreTemplate
forall template.
UStoreTemplateHasDoc template =>
Proxy template -> DUStoreTemplate
DUStoreTemplate (Proxy oldStore
forall k (t :: k). Proxy t
Proxy @oldStore))
      , " "
      , DUStoreTemplate -> Markdown
dUStoreTemplateRef (Proxy newStore -> DUStoreTemplate
forall template.
UStoreTemplateHasDoc template =>
Proxy template -> DUStoreTemplate
DUStoreTemplate (Proxy newStore
forall k (t :: k). Proxy t
Proxy @newStore))
      ]
  typeDocDependencies :: Proxy (MigrationScript oldStore newStore)
-> [SomeDocDefinitionItem]
typeDocDependencies p :: Proxy (MigrationScript oldStore newStore)
p =
    [ TypeHasDoc (UStore oldStore) => SomeDocDefinitionItem
forall t. TypeHasDoc t => SomeDocDefinitionItem
dTypeDep @(UStore oldStore)
    , TypeHasDoc (UStore newStore) => SomeDocDefinitionItem
forall t. TypeHasDoc t => SomeDocDefinitionItem
dTypeDep @(UStore newStore)
    ] [SomeDocDefinitionItem]
-> [SomeDocDefinitionItem] -> [SomeDocDefinitionItem]
forall a. Semigroup a => a -> a -> a
<> Proxy (MigrationScript oldStore newStore)
-> [SomeDocDefinitionItem]
forall a.
(Generic a, GTypeHasDoc (Rep a)) =>
Proxy a -> [SomeDocDefinitionItem]
genericTypeDocDependencies Proxy (MigrationScript oldStore newStore)
p
  typeDocHaskellRep :: TypeDocHaskellRep (MigrationScript oldStore newStore)
typeDocHaskellRep = TypeDocHaskellRep (MigrationScript oldStore newStore)
forall a. (Generic a, GTypeHasDoc (Rep a)) => TypeDocHaskellRep a
homomorphicTypeDocHaskellRep
  typeDocMichelsonRep :: TypeDocMichelsonRep (MigrationScript oldStore newStore)
typeDocMichelsonRep = TypeDocMichelsonRep (MigrationScript oldStore newStore)
forall a. SingI (ToT a) => TypeDocMichelsonRep a
homomorphicTypeDocMichelsonRep

instance Lambda (UStore ot1) (UStore nt1) `CanCastTo` Lambda (UStore ot2) (UStore nt2) =>
         MigrationScript ot1 nt1 `CanCastTo` MigrationScript ot2 nt2

-- | Corner case of 'MigrationScript' with some type argument unknown.
--
-- You can turn this into 'MigrationScript' using 'checkedCoerce'.
type MigrationScriptFrom oldStore = MigrationScript oldStore SomeUTemplate
type MigrationScriptTo newStore = MigrationScript SomeUTemplate newStore
type MigrationScript_ = MigrationScript SomeUTemplate SomeUTemplate

-- | Manually perform a piece of migration.
manualWithUStore
  :: forall ustore template oldStore newStore.
      (ustore ~ UStore template)
  => ('[ustore] :-> '[ustore]) -> MigrationScript oldStore newStore
manualWithUStore :: ('[ustore] :-> '[ustore]) -> MigrationScript oldStore newStore
manualWithUStore action :: '[ustore] :-> '[ustore]
action = Lambda UStore_ UStore_ -> MigrationScript oldStore newStore
forall oldStore newStore.
Lambda UStore_ UStore_ -> MigrationScript oldStore newStore
MigrationScript (Lambda UStore_ UStore_ -> MigrationScript oldStore newStore)
-> Lambda UStore_ UStore_ -> MigrationScript oldStore newStore
forall a b. (a -> b) -> a -> b
$ ('[ustore] :-> '[ustore]) -> Lambda UStore_ UStore_
forall a b (s :: [*]).
Coercible_ a b =>
((b : s) :-> (b : s)) -> (a : s) :-> (a : s)
checkedCoercing_ '[ustore] :-> '[ustore]
action

manualWithOldUStore
  :: ('[UStore oldStore] :-> '[UStore oldStore]) -> MigrationScript oldStore newStore
manualWithOldUStore :: ('[UStore oldStore] :-> '[UStore oldStore])
-> MigrationScript oldStore newStore
manualWithOldUStore = ('[UStore oldStore] :-> '[UStore oldStore])
-> MigrationScript oldStore newStore
forall ustore template oldStore newStore.
(ustore ~ UStore template) =>
('[ustore] :-> '[ustore]) -> MigrationScript oldStore newStore
manualWithUStore

manualWithNewUStore
  :: ('[UStore newStore] :-> '[UStore newStore]) -> MigrationScript oldStore newStore
manualWithNewUStore :: ('[UStore newStore] :-> '[UStore newStore])
-> MigrationScript oldStore newStore
manualWithNewUStore = ('[UStore newStore] :-> '[UStore newStore])
-> MigrationScript oldStore newStore
forall ustore template oldStore newStore.
(ustore ~ UStore template) =>
('[ustore] :-> '[ustore]) -> MigrationScript oldStore newStore
manualWithUStore

-- | Modify code under given 'MigrationScript'.
--
-- Avoid using this function when constructing a batched migration because
-- batching logic should know size of the code precisely, consider mapping
-- 'UStoreMigration' instead.
manualMapMigrationScript
  :: (('[UStore_] :-> '[UStore_]) -> ('[UStore_] :-> '[UStore_]))
  -> MigrationScript oldStore newStore
  -> MigrationScript oldStore newStore
manualMapMigrationScript :: (Lambda UStore_ UStore_ -> Lambda UStore_ UStore_)
-> MigrationScript oldStore newStore
-> MigrationScript oldStore newStore
manualMapMigrationScript f :: Lambda UStore_ UStore_ -> Lambda UStore_ UStore_
f = Lambda UStore_ UStore_ -> MigrationScript oldStore newStore
forall oldStore newStore.
Lambda UStore_ UStore_ -> MigrationScript oldStore newStore
MigrationScript (Lambda UStore_ UStore_ -> MigrationScript oldStore newStore)
-> (MigrationScript oldStore newStore -> Lambda UStore_ UStore_)
-> MigrationScript oldStore newStore
-> MigrationScript oldStore newStore
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lambda UStore_ UStore_ -> Lambda UStore_ UStore_
f (Lambda UStore_ UStore_ -> Lambda UStore_ UStore_)
-> (MigrationScript oldStore newStore -> Lambda UStore_ UStore_)
-> MigrationScript oldStore newStore
-> Lambda UStore_ UStore_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationScript oldStore newStore -> Lambda UStore_ UStore_
forall oldStore newStore.
MigrationScript oldStore newStore -> Lambda UStore_ UStore_
unMigrationScript

-- | Merge several migration scripts. Used in manual migrations.
--
-- This function is generally unsafe because resulting migration script can fail
-- to fit into operation size limit.
manualConcatMigrationScripts :: [MigrationScript os ns] -> MigrationScript os ns
manualConcatMigrationScripts :: [MigrationScript os ns] -> MigrationScript os ns
manualConcatMigrationScripts =
  Lambda UStore_ UStore_ -> MigrationScript os ns
forall oldStore newStore.
Lambda UStore_ UStore_ -> MigrationScript oldStore newStore
MigrationScript (Lambda UStore_ UStore_ -> MigrationScript os ns)
-> ([MigrationScript os ns] -> Lambda UStore_ UStore_)
-> [MigrationScript os ns]
-> MigrationScript os ns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lambda UStore_ UStore_
 -> Element [Lambda UStore_ UStore_] -> Lambda UStore_ UStore_)
-> Lambda UStore_ UStore_
-> [Lambda UStore_ UStore_]
-> Lambda UStore_ UStore_
forall t b. Container t => (b -> Element t -> b) -> b -> t -> b
foldl' Lambda UStore_ UStore_
-> Element [Lambda UStore_ UStore_] -> Lambda UStore_ UStore_
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
(#) Lambda UStore_ UStore_
forall (s :: [*]). s :-> s
nop ([Lambda UStore_ UStore_] -> Lambda UStore_ UStore_)
-> ([MigrationScript os ns] -> [Lambda UStore_ UStore_])
-> [MigrationScript os ns]
-> Lambda UStore_ UStore_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MigrationScript os ns -> Lambda UStore_ UStore_)
-> [MigrationScript os ns] -> [Lambda UStore_ UStore_]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MigrationScript os ns -> Lambda UStore_ UStore_
forall oldStore newStore.
MigrationScript oldStore newStore -> Lambda UStore_ UStore_
unMigrationScript

-- | An action on storage entry.
data DMigrationActionType
  = DAddAction Text
    -- ^ Some sort of addition: "init", "set", "overwrite", e.t.c.
  | DDelAction
    -- ^ Removal.
  deriving stock Int -> DMigrationActionType -> ShowS
[DMigrationActionType] -> ShowS
DMigrationActionType -> String
(Int -> DMigrationActionType -> ShowS)
-> (DMigrationActionType -> String)
-> ([DMigrationActionType] -> ShowS)
-> Show DMigrationActionType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DMigrationActionType] -> ShowS
$cshowList :: [DMigrationActionType] -> ShowS
show :: DMigrationActionType -> String
$cshow :: DMigrationActionType -> String
showsPrec :: Int -> DMigrationActionType -> ShowS
$cshowsPrec :: Int -> DMigrationActionType -> ShowS
Show

instance Buildable DMigrationActionType where
  build :: DMigrationActionType -> Markdown
build = \case
    DAddAction a :: Text
a -> Text -> Markdown
forall p. Buildable p => p -> Markdown
build Text
a
    DDelAction -> "remove"

-- | Describes single migration action.
--
-- In most cases it is possible to derive reasonable description for migration
-- atom automatically, this datatype exactly carries this information.
data DMigrationActionDesc = DMigrationActionDesc
  { DMigrationActionDesc -> DMigrationActionType
manAction :: DMigrationActionType
    -- ^ Action on field, e.g. "set", "remove", "overwrite".
  , DMigrationActionDesc -> Text
manField :: Text
    -- ^ Name of affected field of 'UStore'.
  , DMigrationActionDesc -> T
manFieldType :: T
    -- ^ Type of affected field of 'UStore' in new storage version.
  } deriving stock Int -> DMigrationActionDesc -> ShowS
[DMigrationActionDesc] -> ShowS
DMigrationActionDesc -> String
(Int -> DMigrationActionDesc -> ShowS)
-> (DMigrationActionDesc -> String)
-> ([DMigrationActionDesc] -> ShowS)
-> Show DMigrationActionDesc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DMigrationActionDesc] -> ShowS
$cshowList :: [DMigrationActionDesc] -> ShowS
show :: DMigrationActionDesc -> String
$cshow :: DMigrationActionDesc -> String
showsPrec :: Int -> DMigrationActionDesc -> ShowS
$cshowsPrec :: Int -> DMigrationActionDesc -> ShowS
Show

-- Sad that we need to write this useless documentation instance, probably it's
-- worth generalizing @doc_group@ and @doc_item@ instructions so that they
-- could serve as multi-purpose markers.
instance DocItem DMigrationActionDesc where
  docItemPos :: Natural
docItemPos = 105010
  docItemSectionName :: Maybe Text
docItemSectionName = Maybe Text
forall a. Maybe a
Nothing
  docItemToMarkdown :: HeaderLevel -> DMigrationActionDesc -> Markdown
docItemToMarkdown _ _ = "Migration action"

-- | Add description of action, it will be used in rendering migration plan and
-- some batching implementations.
attachMigrationActionName
  :: SingI (ToT fieldTy)
  => DMigrationActionType
  -> Label fieldName
  -> Proxy fieldTy
  -> s :-> s
attachMigrationActionName :: DMigrationActionType -> Label fieldName -> Proxy fieldTy -> s :-> s
attachMigrationActionName action :: DMigrationActionType
action label :: Label fieldName
label (Proxy fieldTy
_ :: Proxy fieldTy) =
  DMigrationActionDesc -> s :-> s
forall di (s :: [*]). DocItem di => di -> s :-> s
doc (DMigrationActionDesc -> s :-> s)
-> DMigrationActionDesc -> s :-> s
forall a b. (a -> b) -> a -> b
$ $WDMigrationActionDesc :: DMigrationActionType -> Text -> T -> DMigrationActionDesc
DMigrationActionDesc
  { manAction :: DMigrationActionType
manAction = DMigrationActionType
action
  , manField :: Text
manField = Label fieldName -> Text
forall (name :: Symbol). Label name -> Text
labelToText Label fieldName
label
  , manFieldType :: T
manFieldType = (SingKind T, SingI (ToT fieldTy)) => Demote T
forall k (a :: k). (SingKind k, SingI a) => Demote k
demote @(ToT fieldTy)
  }

-- | Minimal possible piece of migration script.
--
-- Different atoms can be arbitrarily reordered and separated across migration
-- stages, but each single atom is treated as a whole.
--
-- Splitting migration into atoms is responsibility of migration writer.
data MigrationAtom = MigrationAtom
  { MigrationAtom -> Text
maName :: Text
  , MigrationAtom -> MigrationScript_
maScript :: MigrationScript_
  , MigrationAtom -> [DMigrationActionDesc]
maActionsDesc :: [DMigrationActionDesc]
  } deriving stock (Int -> MigrationAtom -> ShowS
[MigrationAtom] -> ShowS
MigrationAtom -> String
(Int -> MigrationAtom -> ShowS)
-> (MigrationAtom -> String)
-> ([MigrationAtom] -> ShowS)
-> Show MigrationAtom
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MigrationAtom] -> ShowS
$cshowList :: [MigrationAtom] -> ShowS
show :: MigrationAtom -> String
$cshow :: MigrationAtom -> String
showsPrec :: Int -> MigrationAtom -> ShowS
$cshowsPrec :: Int -> MigrationAtom -> ShowS
Show)

makeLensesWith postfixLFields ''MigrationAtom

-- | Keeps information about migration between 'UStore's with two given
-- templates.
data UStoreMigration (oldTempl :: Kind.Type) (newTempl :: Kind.Type) where
  UStoreMigration
    :: [MigrationAtom]
    -> UStoreMigration oldTempl newTempl

-- | Turn 'Migration' into a whole piece of code for transforming storage.
--
-- This is not want you'd want to use for contract deployment because of
-- gas and operation size limits that Tezos applies to transactions.
migrationToLambda
  :: UStoreMigration oldTemplate newTemplate
  -> Lambda (UStore oldTemplate) (UStore newTemplate)
migrationToLambda :: UStoreMigration oldTemplate newTemplate
-> Lambda (UStore oldTemplate) (UStore newTemplate)
migrationToLambda (UStoreMigration atoms :: [MigrationAtom]
atoms) =
  '[UStore oldTemplate] :-> '[UStore_]
forall a b (s :: [*]). Castable_ a b => (a : s) :-> (b : s)
checkedCoerce_ ('[UStore oldTemplate] :-> '[UStore_])
-> Lambda UStore_ UStore_ -> '[UStore oldTemplate] :-> '[UStore_]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (Element [MigrationAtom] -> Lambda UStore_ UStore_)
-> [MigrationAtom] -> Lambda UStore_ UStore_
forall t m. (Container t, Monoid m) => (Element t -> m) -> t -> m
foldMap (MigrationScript_ -> Lambda UStore_ UStore_
forall oldStore newStore.
MigrationScript oldStore newStore -> Lambda UStore_ UStore_
unMigrationScript (MigrationScript_ -> Lambda UStore_ UStore_)
-> (MigrationAtom -> MigrationScript_)
-> MigrationAtom
-> Lambda UStore_ UStore_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationAtom -> MigrationScript_
maScript) [MigrationAtom]
atoms ('[UStore oldTemplate] :-> '[UStore_])
-> ('[UStore_] :-> '[UStore newTemplate])
-> Lambda (UStore oldTemplate) (UStore newTemplate)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[UStore_] :-> '[UStore newTemplate]
forall a b (s :: [*]). Castable_ a b => (a : s) :-> (b : s)
checkedCoerce_

instance MapLorentzInstr (UStoreMigration os ns) where
  mapLorentzInstr :: (forall (i :: [*]) (o :: [*]). (i :-> o) -> i :-> o)
-> UStoreMigration os ns -> UStoreMigration os ns
mapLorentzInstr f :: forall (i :: [*]) (o :: [*]). (i :-> o) -> i :-> o
f (UStoreMigration atoms :: [MigrationAtom]
atoms) =
    [MigrationAtom] -> UStoreMigration os ns
forall oldTempl newTempl.
[MigrationAtom] -> UStoreMigration oldTempl newTempl
UStoreMigration ([MigrationAtom] -> UStoreMigration os ns)
-> [MigrationAtom] -> UStoreMigration os ns
forall a b. (a -> b) -> a -> b
$
      [MigrationAtom]
atoms [MigrationAtom]
-> ([MigrationAtom] -> [MigrationAtom]) -> [MigrationAtom]
forall a b. a -> (a -> b) -> b
& (MigrationAtom -> Identity MigrationAtom)
-> [MigrationAtom] -> Identity [MigrationAtom]
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed ((MigrationAtom -> Identity MigrationAtom)
 -> [MigrationAtom] -> Identity [MigrationAtom])
-> ((Lambda UStore_ UStore_ -> Identity (Lambda UStore_ UStore_))
    -> MigrationAtom -> Identity MigrationAtom)
-> (Lambda UStore_ UStore_ -> Identity (Lambda UStore_ UStore_))
-> [MigrationAtom]
-> Identity [MigrationAtom]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MigrationScript_ -> Identity MigrationScript_)
-> MigrationAtom -> Identity MigrationAtom
Lens' MigrationAtom MigrationScript_
maScriptL ((MigrationScript_ -> Identity MigrationScript_)
 -> MigrationAtom -> Identity MigrationAtom)
-> ((Lambda UStore_ UStore_ -> Identity (Lambda UStore_ UStore_))
    -> MigrationScript_ -> Identity MigrationScript_)
-> (Lambda UStore_ UStore_ -> Identity (Lambda UStore_ UStore_))
-> MigrationAtom
-> Identity MigrationAtom
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lambda UStore_ UStore_ -> Identity (Lambda UStore_ UStore_))
-> MigrationScript_ -> Identity MigrationScript_
forall oldStore newStore oldStore newStore.
(Lambda UStore_ UStore_ -> Identity (Lambda UStore_ UStore_))
-> MigrationScript oldStore newStore
-> Identity (MigrationScript oldStore newStore)
wrapped ((Lambda UStore_ UStore_ -> Identity (Lambda UStore_ UStore_))
 -> [MigrationAtom] -> Identity [MigrationAtom])
-> (Lambda UStore_ UStore_ -> Lambda UStore_ UStore_)
-> [MigrationAtom]
-> [MigrationAtom]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Lambda UStore_ UStore_ -> Lambda UStore_ UStore_
forall (i :: [*]) (o :: [*]). (i :-> o) -> i :-> o
f
    where
      wrapped :: (Lambda UStore_ UStore_ -> Identity (Lambda UStore_ UStore_))
-> MigrationScript oldStore newStore
-> Identity (MigrationScript oldStore newStore)
wrapped = (MigrationScript oldStore newStore -> Lambda UStore_ UStore_)
-> (Lambda UStore_ UStore_ -> MigrationScript oldStore newStore)
-> Iso
     (MigrationScript oldStore newStore)
     (MigrationScript oldStore newStore)
     (Lambda UStore_ UStore_)
     (Lambda UStore_ UStore_)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso MigrationScript oldStore newStore -> Lambda UStore_ UStore_
forall oldStore newStore.
MigrationScript oldStore newStore -> Lambda UStore_ UStore_
unMigrationScript Lambda UStore_ UStore_ -> MigrationScript oldStore newStore
forall oldStore newStore.
Lambda UStore_ UStore_ -> MigrationScript oldStore newStore
MigrationScript

-- | Modify all code in migration.
mapMigrationCode
  :: (forall i o. (i :-> o) -> (i :-> o))
  -> UStoreMigration os ns
  -> UStoreMigration os ns
mapMigrationCode :: (forall (i :: [*]) (o :: [*]). (i :-> o) -> i :-> o)
-> UStoreMigration os ns -> UStoreMigration os ns
mapMigrationCode = (forall (i :: [*]) (o :: [*]). (i :-> o) -> i :-> o)
-> UStoreMigration os ns -> UStoreMigration os ns
forall instr.
MapLorentzInstr instr =>
(forall (i :: [*]) (o :: [*]). (i :-> o) -> i :-> o)
-> instr -> instr
mapLorentzInstr
{-# DEPRECATED mapMigrationCode "Use 'hoistLorentzInstr' instead" #-}

-- | A bunch of migration atoms produced by migration writer.
newtype MigrationBlocks (oldTemplate :: Kind.Type) (newTemplate :: Kind.Type)
                        (preRemDiff :: [DiffItem]) (preTouched :: [Symbol])
                        (postRemDiff :: [DiffItem]) (postTouched :: [Symbol]) =
  MigrationBlocks [MigrationAtom]

{- | Wrapper over 'UStore' which is currently being migrated.

In type-level arguments it keeps

* Old and new 'UStore' templates - mostly for convenience of the implementation.

* Remaining diff which yet should be covered. Here we track migration progress.
Once remaining diff is empty, migration is finished.

* Names of fields which have already been touched by migration.
Required to make getters safe.
-}
newtype MUStore (oldTemplate :: Kind.Type) (newTemplate :: Kind.Type)
                (remDiff :: [DiffItem]) (touched :: [Symbol]) =
  MUStoreUnsafe (UStore oldTemplate)
  deriving stock (forall x.
 MUStore oldTemplate newTemplate remDiff touched
 -> Rep (MUStore oldTemplate newTemplate remDiff touched) x)
-> (forall x.
    Rep (MUStore oldTemplate newTemplate remDiff touched) x
    -> MUStore oldTemplate newTemplate remDiff touched)
-> Generic (MUStore oldTemplate newTemplate remDiff touched)
forall x.
Rep (MUStore oldTemplate newTemplate remDiff touched) x
-> MUStore oldTemplate newTemplate remDiff touched
forall x.
MUStore oldTemplate newTemplate remDiff touched
-> Rep (MUStore oldTemplate newTemplate remDiff touched) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall oldTemplate newTemplate (remDiff :: [DiffItem])
       (touched :: [Symbol]) x.
Rep (MUStore oldTemplate newTemplate remDiff touched) x
-> MUStore oldTemplate newTemplate remDiff touched
forall oldTemplate newTemplate (remDiff :: [DiffItem])
       (touched :: [Symbol]) x.
MUStore oldTemplate newTemplate remDiff touched
-> Rep (MUStore oldTemplate newTemplate remDiff touched) x
$cto :: forall oldTemplate newTemplate (remDiff :: [DiffItem])
       (touched :: [Symbol]) x.
Rep (MUStore oldTemplate newTemplate remDiff touched) x
-> MUStore oldTemplate newTemplate remDiff touched
$cfrom :: forall oldTemplate newTemplate (remDiff :: [DiffItem])
       (touched :: [Symbol]) x.
MUStore oldTemplate newTemplate remDiff touched
-> Rep (MUStore oldTemplate newTemplate remDiff touched) x
Generic
  deriving anyclass WellTypedToT (MUStore oldTemplate newTemplate remDiff touched)
WellTypedToT (MUStore oldTemplate newTemplate remDiff touched) =>
(MUStore oldTemplate newTemplate remDiff touched
 -> Value (ToT (MUStore oldTemplate newTemplate remDiff touched)))
-> (Value (ToT (MUStore oldTemplate newTemplate remDiff touched))
    -> MUStore oldTemplate newTemplate remDiff touched)
-> IsoValue (MUStore oldTemplate newTemplate remDiff touched)
Value (ToT (MUStore oldTemplate newTemplate remDiff touched))
-> MUStore oldTemplate newTemplate remDiff touched
MUStore oldTemplate newTemplate remDiff touched
-> Value (ToT (MUStore oldTemplate newTemplate remDiff touched))
forall a.
WellTypedToT a =>
(a -> Value (ToT a)) -> (Value (ToT a) -> a) -> IsoValue a
forall oldTemplate newTemplate (remDiff :: [DiffItem])
       (touched :: [Symbol]).
WellTypedToT (MUStore oldTemplate newTemplate remDiff touched)
forall oldTemplate newTemplate (remDiff :: [DiffItem])
       (touched :: [Symbol]).
Value (ToT (MUStore oldTemplate newTemplate remDiff touched))
-> MUStore oldTemplate newTemplate remDiff touched
forall oldTemplate newTemplate (remDiff :: [DiffItem])
       (touched :: [Symbol]).
MUStore oldTemplate newTemplate remDiff touched
-> Value (ToT (MUStore oldTemplate newTemplate remDiff touched))
fromVal :: Value (ToT (MUStore oldTemplate newTemplate remDiff touched))
-> MUStore oldTemplate newTemplate remDiff touched
$cfromVal :: forall oldTemplate newTemplate (remDiff :: [DiffItem])
       (touched :: [Symbol]).
Value (ToT (MUStore oldTemplate newTemplate remDiff touched))
-> MUStore oldTemplate newTemplate remDiff touched
toVal :: MUStore oldTemplate newTemplate remDiff touched
-> Value (ToT (MUStore oldTemplate newTemplate remDiff touched))
$ctoVal :: forall oldTemplate newTemplate (remDiff :: [DiffItem])
       (touched :: [Symbol]).
MUStore oldTemplate newTemplate remDiff touched
-> Value (ToT (MUStore oldTemplate newTemplate remDiff touched))
$cp1IsoValue :: forall oldTemplate newTemplate (remDiff :: [DiffItem])
       (touched :: [Symbol]).
WellTypedToT (MUStore oldTemplate newTemplate remDiff touched)
IsoValue

-- | Create migration atom from code.
--
-- This is an internal function, should not be used for writing migrations.
formMigrationAtom
  :: Maybe Text
  -> Lambda UStore_ UStore_
  -> MigrationAtom
formMigrationAtom :: Maybe Text -> Lambda UStore_ UStore_ -> MigrationAtom
formMigrationAtom mname :: Maybe Text
mname code :: Lambda UStore_ UStore_
code =
  $WMigrationAtom :: Text -> MigrationScript_ -> [DMigrationActionDesc] -> MigrationAtom
MigrationAtom
  { maName :: Text
maName = Text
name
  , maScript :: MigrationScript_
maScript = Lambda UStore_ UStore_ -> MigrationScript_
forall oldStore newStore.
Lambda UStore_ UStore_ -> MigrationScript oldStore newStore
MigrationScript (Lambda UStore_ UStore_ -> Lambda UStore_ UStore_
forall a b (s :: [*]).
Coercible_ a b =>
((b : s) :-> (b : s)) -> (a : s) :-> (a : s)
checkedCoercing_ Lambda UStore_ UStore_
code)
  , maActionsDesc :: [DMigrationActionDesc]
maActionsDesc = [DMigrationActionDesc]
actionsDescs
  }
  where
    name :: Text
name = case Maybe Text
mname of
      Just n :: Text
n -> Text
n
      Nothing ->
        Markdown -> Text
forall b. FromBuilder b => Markdown -> b
fmt (Markdown -> Text)
-> ([Markdown] -> Markdown) -> [Markdown] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat ([Markdown] -> Text) -> [Markdown] -> Text
forall a b. (a -> b) -> a -> b
$ Markdown -> [Markdown] -> [Markdown]
forall a. a -> [a] -> [a]
intersperse ", "
          [ DMigrationActionType -> Markdown
forall p. Buildable p => p -> Markdown
build DMigrationActionType
action Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> " \"" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Text -> Markdown
forall p. Buildable p => p -> Markdown
build Text
field Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "\""
          | DMigrationActionDesc action :: DMigrationActionType
action field :: Text
field _type :: T
_type <- [DMigrationActionDesc]
actionsDescs
          ]

    actionsDescs :: [DMigrationActionDesc]
actionsDescs =
      let instr :: Instr (ToTs '[UStore_]) (ToTs '[UStore_])
instr = Lambda UStore_ UStore_ -> Instr (ToTs '[UStore_]) (ToTs '[UStore_])
forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> Instr (ToTs inp) (ToTs out)
compileLorentz Lambda UStore_ UStore_
code
          (_, actions :: [DMigrationActionDesc]
actions) = DfsSettings [DMigrationActionDesc]
-> (forall (i :: [T]) (o :: [T]).
    Instr i o -> (Instr i o, [DMigrationActionDesc]))
-> Instr '[ 'TBigMap 'TBytes 'TBytes] '[ 'TBigMap 'TBytes 'TBytes]
-> (Instr
      '[ 'TBigMap 'TBytes 'TBytes] '[ 'TBigMap 'TBytes 'TBytes],
    [DMigrationActionDesc])
forall x (inp :: [T]) (out :: [T]).
Semigroup x =>
DfsSettings x
-> (forall (i :: [T]) (o :: [T]). Instr i o -> (Instr i o, x))
-> Instr inp out
-> (Instr inp out, x)
dfsInstr DfsSettings [DMigrationActionDesc]
forall a. Default a => a
def (\i :: Instr i o
i -> (Instr i o
i, Instr i o -> [DMigrationActionDesc]
forall (i :: [T]) (o :: [T]). Instr i o -> [DMigrationActionDesc]
pickActionDescs Instr i o
i)) Instr '[ 'TBigMap 'TBytes 'TBytes] '[ 'TBigMap 'TBytes 'TBytes]
Instr (ToTs '[UStore_]) (ToTs '[UStore_])
instr
      in [DMigrationActionDesc]
actions

    pickActionDescs :: Instr i o -> [DMigrationActionDesc]
    pickActionDescs :: Instr i o -> [DMigrationActionDesc]
pickActionDescs i :: Instr i o
i = case Instr i o
i of
      Ext (DOC_ITEM (SomeDocItem di :: d
di)) ->
        [ DMigrationActionDesc
d
        | Just d :: DMigrationActionDesc
d@DMigrationActionDesc{} <- Maybe DMigrationActionDesc -> [Maybe DMigrationActionDesc]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DMigrationActionDesc -> [Maybe DMigrationActionDesc])
-> Maybe DMigrationActionDesc -> [Maybe DMigrationActionDesc]
forall a b. (a -> b) -> a -> b
$ d -> Maybe DMigrationActionDesc
forall a b. (Typeable a, Typeable b) => a -> Maybe b
Typeable.cast d
di
        ]
      _ -> []

-- | Way of distributing migration atoms among batches.
--
-- This also participates in describing migration plan and should contain
-- information which would clarify to a user why migration is splitted
-- such a way. Objects of type @batchInfo@ stand for information corresponding to
-- a batch and may include e.g. names of taken actions and gas consumption.
--
-- Type argument @structure@ stands for container where batches will be put to
-- and is usually a list ('[]').
--
-- When writing an instance of this datatype, you should tend to produce
-- as few batches as possible because Tezos transaction execution overhead
-- is quite high; though these batches should still preferably fit into gas limit.
--
-- Note that we never fail here because reaching perfect consistency with Tezos
-- gas model is beyond dreams for now, even if our model predicts that some
-- migration atom cannot be fit into gas limit, Tezos node can think differently
-- and accept the migration.
-- If your batching function can make predictions about fitting into gas limit,
-- consider including this information in @batchInfo@ type.
--
-- See batching implementations in "Lorentz.UStore.Migration.Batching" module.
data MigrationBatching (structure :: Kind.Type -> Kind.Type) (batchInfo :: Kind.Type) =
  MigrationBatching ([MigrationAtom] -> structure (batchInfo, MigrationScript_))

-- | Put each migration atom to a separate batch.
--
-- In most cases this is not what you want, but may be useful if e.g. you write
-- your migration manually.
mbBatchesAsIs :: MigrationBatching [] Text
mbBatchesAsIs :: MigrationBatching [] Text
mbBatchesAsIs = ([MigrationAtom] -> [(Text, MigrationScript_)])
-> MigrationBatching [] Text
forall (structure :: * -> *) batchInfo.
([MigrationAtom] -> structure (batchInfo, MigrationScript_))
-> MigrationBatching structure batchInfo
MigrationBatching (([MigrationAtom] -> [(Text, MigrationScript_)])
 -> MigrationBatching [] Text)
-> ([MigrationAtom] -> [(Text, MigrationScript_)])
-> MigrationBatching [] Text
forall a b. (a -> b) -> a -> b
$
  (MigrationAtom -> (Text, MigrationScript_))
-> [MigrationAtom] -> [(Text, MigrationScript_)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (MigrationAtom -> Text
maName (MigrationAtom -> Text)
-> (MigrationAtom -> MigrationScript_)
-> MigrationAtom
-> (Text, MigrationScript_)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& MigrationAtom -> MigrationScript_
maScript)

-- | Put the whole migration into one batch.
mbNoBatching :: MigrationBatching Identity Text
mbNoBatching :: MigrationBatching Identity Text
mbNoBatching = ([MigrationAtom] -> Identity (Text, MigrationScript_))
-> MigrationBatching Identity Text
forall (structure :: * -> *) batchInfo.
([MigrationAtom] -> structure (batchInfo, MigrationScript_))
-> MigrationBatching structure batchInfo
MigrationBatching (([MigrationAtom] -> Identity (Text, MigrationScript_))
 -> MigrationBatching Identity Text)
-> ([MigrationAtom] -> Identity (Text, MigrationScript_))
-> MigrationBatching Identity Text
forall a b. (a -> b) -> a -> b
$
  (Text, MigrationScript_) -> Identity (Text, MigrationScript_)
forall a. a -> Identity a
Identity ((Text, MigrationScript_) -> Identity (Text, MigrationScript_))
-> ([MigrationAtom] -> (Text, MigrationScript_))
-> [MigrationAtom]
-> Identity (Text, MigrationScript_)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \atoms :: [MigrationAtom]
atoms ->
    ( [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse ", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ MigrationAtom -> Text
maName (MigrationAtom -> Text) -> [MigrationAtom] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MigrationAtom]
atoms
    , [MigrationScript_] -> MigrationScript_
forall os ns. [MigrationScript os ns] -> MigrationScript os ns
manualConcatMigrationScripts (MigrationAtom -> MigrationScript_
maScript (MigrationAtom -> MigrationScript_)
-> [MigrationAtom] -> [MigrationScript_]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MigrationAtom]
atoms)
    )

-- | Version of 'mkUStoreMigration' which allows splitting migration in batches.
--
-- Here you supply a sequence of migration blocks which then are automatically
-- distributed among migration stages.
mkUStoreBatchedMigration
  :: MigrationBlocks oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] _1
  -> UStoreMigration oldTempl newTempl
mkUStoreBatchedMigration :: MigrationBlocks
  oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] _1
-> UStoreMigration oldTempl newTempl
mkUStoreBatchedMigration (MigrationBlocks blocks :: [MigrationAtom]
blocks) = [MigrationAtom] -> UStoreMigration oldTempl newTempl
forall oldTempl newTempl.
[MigrationAtom] -> UStoreMigration oldTempl newTempl
UStoreMigration [MigrationAtom]
blocks

-- | Safe way to create migration scripts for 'UStore'.
--
-- You have to supply a code which would transform 'MUStore',
-- coverring required diff step-by-step.
-- All basic instructions work, also use @migrate*@ functions
-- from this module to operate with 'MUStore'.
--
-- This method produces a whole migration, it cannot be splitted in batches.
-- In case if your migration is too big to be applied within a single
-- transaction, use 'mkUStoreBatchedMigration'.
mkUStoreMigration
  :: Lambda
       (MUStore oldTempl newTempl (BuildDiff oldTempl newTempl) '[])
       (MUStore oldTempl newTempl '[] _1)
  -> UStoreMigration oldTempl newTempl
mkUStoreMigration :: Lambda
  (MUStore oldTempl newTempl (BuildDiff oldTempl newTempl) '[])
  (MUStore oldTempl newTempl '[] _1)
-> UStoreMigration oldTempl newTempl
mkUStoreMigration code :: Lambda
  (MUStore oldTempl newTempl (BuildDiff oldTempl newTempl) '[])
  (MUStore oldTempl newTempl '[] _1)
code =
  MigrationBlocks
  oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] Any
-> UStoreMigration oldTempl newTempl
forall oldTempl newTempl (_1 :: [Symbol]).
MigrationBlocks
  oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] _1
-> UStoreMigration oldTempl newTempl
mkUStoreBatchedMigration (MigrationBlocks
   oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] Any
 -> UStoreMigration oldTempl newTempl)
-> MigrationBlocks
     oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] Any
-> UStoreMigration oldTempl newTempl
forall a b. (a -> b) -> a -> b
$
    [MigrationAtom]
-> MigrationBlocks
     oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] Any
forall oldTemplate newTemplate (preRemDiff :: [DiffItem])
       (preTouched :: [Symbol]) (postRemDiff :: [DiffItem])
       (postTouched :: [Symbol]).
[MigrationAtom]
-> MigrationBlocks
     oldTemplate
     newTemplate
     preRemDiff
     preTouched
     postRemDiff
     postTouched
MigrationBlocks ([MigrationAtom]
 -> MigrationBlocks
      oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] Any)
-> (Lambda UStore_ UStore_ -> [MigrationAtom])
-> Lambda UStore_ UStore_
-> MigrationBlocks
     oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] Any
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 "Migration") (Lambda UStore_ UStore_
 -> MigrationBlocks
      oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] Any)
-> Lambda UStore_ UStore_
-> MigrationBlocks
     oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] Any
forall a b. (a -> b) -> a -> b
$
      '[UStore_]
:-> (MUStore oldTempl newTempl (BuildDiff oldTempl newTempl) '[]
     & '[])
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_ ('[UStore_]
 :-> (MUStore oldTempl newTempl (BuildDiff oldTempl newTempl) '[]
      & '[]))
-> Lambda
     (MUStore oldTempl newTempl (BuildDiff oldTempl newTempl) '[])
     (MUStore oldTempl newTempl '[] _1)
-> '[UStore_] :-> '[MUStore oldTempl newTempl '[] _1]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Lambda
  (MUStore oldTempl newTempl (BuildDiff oldTempl newTempl) '[])
  (MUStore oldTempl newTempl '[] _1)
code ('[UStore_] :-> '[MUStore oldTempl newTempl '[] _1])
-> ('[MUStore oldTempl newTempl '[] _1] :-> '[UStore_])
-> Lambda UStore_ UStore_
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[MUStore oldTempl newTempl '[] _1] :-> '[UStore_]
forall a b (s :: [*]).
MichelsonCoercible a b =>
(a & s) :-> (b & s)
forcedCoerce_

-- | Migration script splitted in batches.
--
-- This is an intermediate form of migration content and needed because
-- compiling 'UStoreMigration' is a potentially heavyweight operation,
-- and after compilation is performed you may need to get various information like
-- number of migration steps, migration script, migration plan and other.
newtype UStoreMigrationCompiled
          (oldStore :: Kind.Type) (newStore :: Kind.Type)
          (structure :: Kind.Type -> Kind.Type) (batchInfo :: Kind.Type) =
  UStoreMigrationCompiled
  { UStoreMigrationCompiled oldStore newStore structure batchInfo
-> structure (batchInfo, MigrationScript oldStore newStore)
compiledMigrationContent
     :: structure (batchInfo, MigrationScript oldStore newStore)
  }

-- | Compile migration for use in production.
compileMigration
  :: (Functor t)
  => MigrationBatching t batchInfo
  -> UStoreMigration ot nt
  -> UStoreMigrationCompiled ot nt t batchInfo
compileMigration :: MigrationBatching t batchInfo
-> UStoreMigration ot nt
-> UStoreMigrationCompiled ot nt t batchInfo
compileMigration (MigrationBatching toBatches :: [MigrationAtom] -> t (batchInfo, MigrationScript_)
toBatches) (UStoreMigration blks :: [MigrationAtom]
blks) =
  t (batchInfo, MigrationScript ot nt)
-> UStoreMigrationCompiled ot nt t batchInfo
forall oldStore newStore (structure :: * -> *) batchInfo.
structure (batchInfo, MigrationScript oldStore newStore)
-> UStoreMigrationCompiled oldStore newStore structure batchInfo
UStoreMigrationCompiled ((MigrationScript_ -> MigrationScript ot nt)
-> (batchInfo, MigrationScript_)
-> (batchInfo, MigrationScript ot nt)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second MigrationScript_ -> MigrationScript ot nt
forall a b. Coercible a b => a -> b
forcedCoerce ((batchInfo, MigrationScript_)
 -> (batchInfo, MigrationScript ot nt))
-> t (batchInfo, MigrationScript_)
-> t (batchInfo, MigrationScript ot nt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MigrationAtom] -> t (batchInfo, MigrationScript_)
toBatches [MigrationAtom]
blks)

-- | Get migration scripts, each to be executed in separate Tezos transaction.
migrationToScripts
  :: Traversable t
  => UStoreMigrationCompiled os ns t batchInfo
  -> t (MigrationScript os ns)
migrationToScripts :: UStoreMigrationCompiled os ns t batchInfo
-> t (MigrationScript os ns)
migrationToScripts = ((batchInfo, MigrationScript os ns) -> MigrationScript os ns)
-> t (batchInfo, MigrationScript os ns)
-> t (MigrationScript os ns)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (batchInfo, MigrationScript os ns) -> MigrationScript os ns
forall a b. (a, b) -> b
snd (t (batchInfo, MigrationScript os ns) -> t (MigrationScript os ns))
-> (UStoreMigrationCompiled os ns t batchInfo
    -> t (batchInfo, MigrationScript os ns))
-> UStoreMigrationCompiled os ns t batchInfo
-> t (MigrationScript os ns)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UStoreMigrationCompiled os ns t batchInfo
-> t (batchInfo, MigrationScript os ns)
forall oldStore newStore (structure :: * -> *) batchInfo.
UStoreMigrationCompiled oldStore newStore structure batchInfo
-> structure (batchInfo, MigrationScript oldStore newStore)
compiledMigrationContent

-- | Get migration scripts as list.
migrationToScriptsList
  :: Traversable t
  => UStoreMigrationCompiled os ns t batchInfo
  -> [MigrationScript os ns]
migrationToScriptsList :: UStoreMigrationCompiled os ns t batchInfo
-> [MigrationScript os ns]
migrationToScriptsList = t (MigrationScript os ns) -> [MigrationScript os ns]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (t (MigrationScript os ns) -> [MigrationScript os ns])
-> (UStoreMigrationCompiled os ns t batchInfo
    -> t (MigrationScript os ns))
-> UStoreMigrationCompiled os ns t batchInfo
-> [MigrationScript os ns]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UStoreMigrationCompiled os ns t batchInfo
-> t (MigrationScript os ns)
forall (t :: * -> *) os ns batchInfo.
Traversable t =>
UStoreMigrationCompiled os ns t batchInfo
-> t (MigrationScript os ns)
migrationToScripts

-- | Get migration script in case of simple (non-batched) migration.
migrationToScriptI
  :: UStoreMigration os ns
  -> Identity (MigrationScript os ns)
migrationToScriptI :: UStoreMigration os ns -> Identity (MigrationScript os ns)
migrationToScriptI =
  UStoreMigrationCompiled os ns Identity Text
-> Identity (MigrationScript os ns)
forall (t :: * -> *) os ns batchInfo.
Traversable t =>
UStoreMigrationCompiled os ns t batchInfo
-> t (MigrationScript os ns)
migrationToScripts (UStoreMigrationCompiled os ns Identity Text
 -> Identity (MigrationScript os ns))
-> (UStoreMigration os ns
    -> UStoreMigrationCompiled os ns Identity Text)
-> UStoreMigration os ns
-> Identity (MigrationScript os ns)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationBatching Identity Text
-> UStoreMigration os ns
-> UStoreMigrationCompiled os ns Identity Text
forall (t :: * -> *) batchInfo ot nt.
Functor t =>
MigrationBatching t batchInfo
-> UStoreMigration ot nt
-> UStoreMigrationCompiled ot nt t batchInfo
compileMigration MigrationBatching Identity Text
mbNoBatching

-- | Get migration script in case of simple (non-batched) migration.
migrationToScript
  :: UStoreMigration os ns
  -> MigrationScript os ns
migrationToScript :: UStoreMigration os ns -> MigrationScript os ns
migrationToScript =
  Identity (MigrationScript os ns) -> MigrationScript os ns
forall a. Identity a -> a
runIdentity (Identity (MigrationScript os ns) -> MigrationScript os ns)
-> (UStoreMigration os ns -> Identity (MigrationScript os ns))
-> UStoreMigration os ns
-> MigrationScript os ns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UStoreMigration os ns -> Identity (MigrationScript os ns)
forall os ns.
UStoreMigration os ns -> Identity (MigrationScript os ns)
migrationToScriptI

-- | Get information about each batch.
migrationToInfo
  :: Traversable t
  => UStoreMigrationCompiled ot nt t batchInfo
  -> t batchInfo
migrationToInfo :: UStoreMigrationCompiled ot nt t batchInfo -> t batchInfo
migrationToInfo = ((batchInfo, MigrationScript ot nt) -> batchInfo)
-> t (batchInfo, MigrationScript ot nt) -> t batchInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (batchInfo, MigrationScript ot nt) -> batchInfo
forall a b. (a, b) -> a
fst (t (batchInfo, MigrationScript ot nt) -> t batchInfo)
-> (UStoreMigrationCompiled ot nt t batchInfo
    -> t (batchInfo, MigrationScript ot nt))
-> UStoreMigrationCompiled ot nt t batchInfo
-> t batchInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UStoreMigrationCompiled ot nt t batchInfo
-> t (batchInfo, MigrationScript ot nt)
forall oldStore newStore (structure :: * -> *) batchInfo.
UStoreMigrationCompiled oldStore newStore structure batchInfo
-> structure (batchInfo, MigrationScript oldStore newStore)
compiledMigrationContent

-- | Number of stages in migration.
migrationStagesNum
  :: Traversable t
  => UStoreMigrationCompiled ot nt t batchInfo -> Int
migrationStagesNum :: UStoreMigrationCompiled ot nt t batchInfo -> Int
migrationStagesNum = t (MigrationScript ot nt) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Foldable.length (t (MigrationScript ot nt) -> Int)
-> (UStoreMigrationCompiled ot nt t batchInfo
    -> t (MigrationScript ot nt))
-> UStoreMigrationCompiled ot nt t batchInfo
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UStoreMigrationCompiled ot nt t batchInfo
-> t (MigrationScript ot nt)
forall (t :: * -> *) os ns batchInfo.
Traversable t =>
UStoreMigrationCompiled os ns t batchInfo
-> t (MigrationScript os ns)
migrationToScripts

-- | Render migration plan.
buildMigrationPlan
  :: (Traversable t, Buildable batchInfo)
  => UStoreMigrationCompiled ot nt t batchInfo -> Builder
buildMigrationPlan :: UStoreMigrationCompiled ot nt t batchInfo -> Markdown
buildMigrationPlan content :: UStoreMigrationCompiled ot nt t batchInfo
content =
  let infos :: [batchInfo]
infos = t batchInfo -> [batchInfo]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (t batchInfo -> [batchInfo]) -> t batchInfo -> [batchInfo]
forall a b. (a -> b) -> a -> b
$ UStoreMigrationCompiled ot nt t batchInfo -> t batchInfo
forall (t :: * -> *) ot nt batchInfo.
Traversable t =>
UStoreMigrationCompiled ot nt t batchInfo -> t batchInfo
migrationToInfo UStoreMigrationCompiled ot nt t batchInfo
content
  in [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat
     [ "Migration stages:\n"
     , [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat ([Markdown] -> Markdown) -> [Markdown] -> Markdown
forall a b. (a -> b) -> a -> b
$ [Int] -> [batchInfo] -> [(Int, batchInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [1..] [batchInfo]
infos [(Int, batchInfo)] -> ((Int, batchInfo) -> Markdown) -> [Markdown]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Int
i :: Int, info :: batchInfo
info) ->
        Int -> Markdown
forall p. Buildable p => p -> Markdown
build Int
i Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> ") " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> batchInfo -> Markdown
forall p. Buildable p => p -> Markdown
build batchInfo
info Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "\n"
     ]