{-# 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 Data.Vinyl.Derived (Label)

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.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 _ =
  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 =
  forcedCoerce_ @_ @(UStore oldTempl) # ustoreGetField label # dip 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 =
  attachMigrationActionName (DAddAction "add") label (Proxy @fieldTy) #
  dip (forcedCoerce_ @_ @(UStore newTempl)) # ustoreSetField label # 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 =
  attachMigrationActionName DDelAction label (Proxy @fieldTy) #
  forcedCoerce_ @_ @(UStore oldTempl) # ustoreRemoveFieldUnsafe label # 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 =
  attachMigrationActionName DDelAction label (Proxy @fieldTy) #
  migrateGetField label # dip (migrateRemoveField 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 =
  attachMigrationActionName (DAddAction "overwrite") label (Proxy @fieldTy) #
  dip (forcedCoerce_ @_ @(UStore newTempl)) # ustoreSetField label # 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 =
  attachMigrationActionName (DAddAction "modify") label (Proxy @fieldTy) #
  dip (forcedCoerce_ @_ @(UStore oldTempl)) # ustoreSetField label # 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 code =
  MigrationBlocks . one . formMigrationAtom Nothing $
    forcedCoerce_ # code # 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 name code =
  MigrationBlocks . one . formMigrationAtom (Just name) $
    forcedCoerce_ # code # 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 <--> MigrationBlocks blocks2 =
  MigrationBlocks (blocks1 <> 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
($:) = ($)
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 = 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 = 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 []