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

{-# OPTIONS_GHC -Wno-orphans #-}

-- | The first version of a minimal user-upgradeable ledger. It does not
-- offer common ledger functions like Transfer/GetTotalSupply/etc. to
-- demonstrate a concept and keep the code consise.
--
-- Note that the naming in this module is different from
-- Lorentz.Contracts.Upgradeable: by "migration" here we mean the process
-- of transferring the value from an old contract to the new one rather than
-- applying a transformation to storage. Thus, MigrationScript here is a lambda
-- that forges an operation to migrate user's funds rather than a function
-- that upgrades storage in-place.

module Lorentz.Contracts.UserUpgradeable.V1
  ( Parameter(..)
  , Storage(..)
  , mkStorage
  , userUpgradeableContract
  ) where

import Lorentz

import Lorentz.Contracts.UserUpgradeable.Migrations
  (MigrationTarget, callMigrationTarget, initiateMigration)

data Storage = Storage
  { Storage -> BigMap Address Natural
ledger :: BigMap Address Natural
  , Storage -> Address
admin :: Address
  , Storage -> Maybe MigrationTarget
migrationTarget :: Maybe MigrationTarget
  }
  deriving stock (forall x. Storage -> Rep Storage x)
-> (forall x. Rep Storage x -> Storage) -> Generic Storage
forall x. Rep Storage x -> Storage
forall x. Storage -> Rep Storage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Storage x -> Storage
$cfrom :: forall x. Storage -> Rep Storage x
Generic
  deriving anyclass (WellTypedToT Storage
WellTypedToT Storage
-> (Storage -> Value (ToT Storage))
-> (Value (ToT Storage) -> Storage)
-> IsoValue Storage
Value (ToT Storage) -> Storage
Storage -> Value (ToT Storage)
forall a.
WellTypedToT a
-> (a -> Value (ToT a)) -> (Value (ToT a) -> a) -> IsoValue a
fromVal :: Value (ToT Storage) -> Storage
$cfromVal :: Value (ToT Storage) -> Storage
toVal :: Storage -> Value (ToT Storage)
$ctoVal :: Storage -> Value (ToT Storage)
$cp1IsoValue :: WellTypedToT Storage
IsoValue, AnnOptions
FollowEntrypointFlag -> Notes (ToT Storage)
(FollowEntrypointFlag -> Notes (ToT Storage))
-> AnnOptions -> HasAnnotation Storage
forall a.
(FollowEntrypointFlag -> Notes (ToT a))
-> AnnOptions -> HasAnnotation a
annOptions :: AnnOptions
$cannOptions :: AnnOptions
getAnnotation :: FollowEntrypointFlag -> Notes (ToT Storage)
$cgetAnnotation :: FollowEntrypointFlag -> Notes (ToT Storage)
HasAnnotation)

mkStorage :: BigMap Address Natural -> Address -> Storage
mkStorage :: BigMap Address Natural -> Address -> Storage
mkStorage BigMap Address Natural
balances Address
admin = Storage :: BigMap Address Natural
-> Address -> Maybe MigrationTarget -> Storage
Storage
  { ledger :: BigMap Address Natural
ledger = BigMap Address Natural
balances
  , admin :: Address
admin = Address
admin
  , migrationTarget :: Maybe MigrationTarget
migrationTarget = Maybe MigrationTarget
forall a. Maybe a
Nothing
  }

data Parameter
  = InitiateMigration MigrationTarget
  -- ^ Token admin calls this entrypoint and provides a lambda to forge
  -- V2.MigrateFrom operation.
  | MigrateMyTokens Natural
  -- ^ Users are supposed to call this entrypoint if they want to upgrade
  -- their tokens.
  | GetBalance (View Address Natural)
  -- ^ Returns the balance of a holder.
  deriving stock (forall x. Parameter -> Rep Parameter x)
-> (forall x. Rep Parameter x -> Parameter) -> Generic Parameter
forall x. Rep Parameter x -> Parameter
forall x. Parameter -> Rep Parameter x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Parameter x -> Parameter
$cfrom :: forall x. Parameter -> Rep Parameter x
Generic
  deriving anyclass WellTypedToT Parameter
WellTypedToT Parameter
-> (Parameter -> Value (ToT Parameter))
-> (Value (ToT Parameter) -> Parameter)
-> IsoValue Parameter
Value (ToT Parameter) -> Parameter
Parameter -> Value (ToT Parameter)
forall a.
WellTypedToT a
-> (a -> Value (ToT a)) -> (Value (ToT a) -> a) -> IsoValue a
fromVal :: Value (ToT Parameter) -> Parameter
$cfromVal :: Value (ToT Parameter) -> Parameter
toVal :: Parameter -> Value (ToT Parameter)
$ctoVal :: Parameter -> Value (ToT Parameter)
$cp1IsoValue :: WellTypedToT Parameter
IsoValue

instance ParameterHasEntrypoints Parameter where
  type ParameterEntrypointsDerivation Parameter = EpdPlain

type instance ErrorArg "userUpgradable'notEnoughTokens" = ()

instance CustomErrorHasDoc "userUpgradable'notEnoughTokens" where
  customErrClass :: ErrorClass
customErrClass = ErrorClass
ErrClassActionException
  customErrDocMdCause :: Markdown
customErrDocMdCause = Markdown
"Not enough tokens."

userUpgradeableContract :: Contract Parameter Storage
userUpgradeableContract :: Contract Parameter Storage
userUpgradeableContract = ContractCode Parameter Storage -> Contract Parameter Storage
forall cp st.
(NiceParameterFull cp, HasCallStack) =>
ContractCode cp st -> Contract cp st
defaultContract (ContractCode Parameter Storage -> Contract Parameter Storage)
-> ContractCode Parameter Storage -> Contract Parameter Storage
forall a b. (a -> b) -> a -> b
$ do
  '[(Parameter, Storage)] :-> '[Parameter, Storage]
forall a b (s :: [*]). ((a, b) : s) :-> (a : b : s)
unpair
  IsoRecTuple
  (Rec
     (CaseClauseL '[Storage] (ContractOut Storage))
     '[ 'CaseClauseParam
          "InitiateMigration" ('OneField MigrationTarget),
        'CaseClauseParam "MigrateMyTokens" ('OneField Natural),
        'CaseClauseParam "GetBalance" ('OneField (View Address Natural))])
-> '[Parameter, Storage] :-> ContractOut Storage
forall dt (out :: [*]) (inp :: [*]) clauses.
CaseTC dt out inp clauses =>
IsoRecTuple clauses -> (dt : inp) :-> out
caseT @Parameter
    ( Label "cInitiateMigration"
forall a. IsLabel "cInitiateMigration" a => a
forall (x :: Symbol) a. IsLabel x a => a
#cInitiateMigration Label "cInitiateMigration"
-> ('[MigrationTarget, Storage] :-> ContractOut Storage)
-> CaseClauseL
     '[Storage]
     (ContractOut Storage)
     ('CaseClauseParam "InitiateMigration" ('OneField MigrationTarget))
forall (name :: Symbol) body clause.
CaseArrow name body clause =>
Label name -> body -> clause
/-> '[MigrationTarget, Storage] :-> ContractOut Storage
forall storage.
(HasAdmin storage, HasMigrationTarget storage) =>
'[MigrationTarget, storage] :-> '[([Operation], storage)]
initiateMigration
    , Label "cMigrateMyTokens"
forall a. IsLabel "cMigrateMyTokens" a => a
forall (x :: Symbol) a. IsLabel x a => a
#cMigrateMyTokens Label "cMigrateMyTokens"
-> ('[Natural, Storage] :-> ContractOut Storage)
-> CaseClauseL
     '[Storage]
     (ContractOut Storage)
     ('CaseClauseParam "MigrateMyTokens" ('OneField Natural))
forall (name :: Symbol) body clause.
CaseArrow name body clause =>
Label name -> body -> clause
/-> do '[Natural, Storage] :-> '[Natural, Natural, Storage]
forall a (s :: [*]). (a : s) :-> (a : a : s)
dup; ('[Natural, Storage] :-> '[Storage])
-> '[Natural, Natural, Storage] :-> '[Natural, Storage]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip '[Natural, Storage] :-> '[Storage]
burnFromSender; '[Natural, Storage] :-> ContractOut Storage
forall storage.
HasMigrationTarget storage =>
'[Natural, storage] :-> '[([Operation], storage)]
callMigrationTarget
    , Label "cGetBalance"
forall a. IsLabel "cGetBalance" a => a
forall (x :: Symbol) a. IsLabel x a => a
#cGetBalance Label "cGetBalance"
-> ('[View Address Natural, Storage] :-> ContractOut Storage)
-> CaseClauseL
     '[Storage]
     (ContractOut Storage)
     ('CaseClauseParam "GetBalance" ('OneField (View Address Natural)))
forall (name :: Symbol) body clause.
CaseArrow name body clause =>
Label name -> body -> clause
/-> (forall (s0 :: [*]). (Address : Storage : s0) :-> (Natural : s0))
-> '[View Address Natural, Storage] :-> ContractOut Storage
forall r a storage (s :: [*]).
NiceParameter r =>
(forall (s0 :: [*]). (a : storage : s0) :-> (r : s0))
-> (View a r : storage : s) :-> (([Operation], storage) : s)
view_ ((forall (s0 :: [*]). (Address : Storage : s0) :-> (Natural : s0))
 -> '[View Address Natural, Storage] :-> ContractOut Storage)
-> (forall (s0 :: [*]).
    (Address : Storage : s0) :-> (Natural : s0))
-> '[View Address Natural, Storage] :-> ContractOut Storage
forall a b. (a -> b) -> a -> b
$ do
        ((Storage : s0) :-> (BigMap Address Natural : s0))
-> (Address : Storage : s0)
   :-> (Address : BigMap Address Natural : s0)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (Label "ledger"
-> (Storage : s0) :-> (GetFieldType Storage "ledger" : s0)
forall dt (name :: Symbol) (st :: [*]).
InstrGetFieldC dt name =>
Label name -> (dt : st) :-> (GetFieldType dt name : st)
toField Label "ledger"
forall a. IsLabel "ledger" a => a
forall (x :: Symbol) a. IsLabel x a => a
#ledger); (Address : BigMap Address Natural : s0) :-> (Maybe Natural : s0)
forall c (s :: [*]).
(GetOpHs c, KnownValue (GetOpValHs c)) =>
(GetOpKeyHs c : c : s) :-> (Maybe (GetOpValHs c) : s)
get; ((Natural : s0) :-> (Natural : s0))
-> (s0 :-> (Natural : s0))
-> (Maybe Natural : s0) :-> (Natural : s0)
forall a (s :: [*]) (s' :: [*]).
((a : s) :-> s') -> (s :-> s') -> (Maybe a : s) :-> s'
ifSome (Natural : s0) :-> (Natural : s0)
forall (s :: [*]). s :-> s
nop (Natural -> s0 :-> (Natural : s0)
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push Natural
0)
    )

-- | Burns tokens from the sender
burnFromSender :: '[Natural, Storage] :-> '[Storage]
burnFromSender :: '[Natural, Storage] :-> '[Storage]
burnFromSender = do
  ('[Storage] :-> '[Natural, Storage])
-> '[Natural, Storage] :-> '[Natural, Natural, Storage]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (('[Storage] :-> '[Natural, Storage])
 -> '[Natural, Storage] :-> '[Natural, Natural, Storage])
-> ('[Storage] :-> '[Natural, Storage])
-> '[Natural, Storage] :-> '[Natural, Natural, Storage]
forall a b. (a -> b) -> a -> b
$ do
    Label "ledger"
-> '[Storage] :-> '[GetFieldType Storage "ledger", Storage]
forall dt (name :: Symbol) (st :: [*]).
InstrGetFieldC dt name =>
Label name -> (dt : st) :-> (GetFieldType dt name : dt : st)
getField Label "ledger"
forall a. IsLabel "ledger" a => a
forall (x :: Symbol) a. IsLabel x a => a
#ledger
    '[BigMap Address Natural, Storage]
:-> '[Address, BigMap Address Natural, Storage]
forall (s :: [*]). s :-> (Address : s)
sender
    '[Address, BigMap Address Natural, Storage]
:-> '[Maybe Natural, Storage]
forall c (s :: [*]).
(GetOpHs c, KnownValue (GetOpValHs c)) =>
(GetOpKeyHs c : c : s) :-> (Maybe (GetOpValHs c) : s)
get
    ('[Natural, Storage] :-> '[Natural, Storage])
-> ('[Storage] :-> '[Natural, Storage])
-> '[Maybe Natural, Storage] :-> '[Natural, Storage]
forall a (s :: [*]) (s' :: [*]).
((a : s) :-> s') -> (s :-> s') -> (Maybe a : s) :-> s'
ifSome '[Natural, Storage] :-> '[Natural, Storage]
forall (s :: [*]). s :-> s
nop (('[Storage] :-> '[Natural, Storage])
 -> '[Maybe Natural, Storage] :-> '[Natural, Storage])
-> ('[Storage] :-> '[Natural, Storage])
-> '[Maybe Natural, Storage] :-> '[Natural, Storage]
forall a b. (a -> b) -> a -> b
$ Label "userUpgradable'notEnoughTokens"
-> '[Storage] :-> '[Natural, Storage]
forall (tag :: Symbol) (s :: [*]) (any :: [*]).
(MustHaveErrorArg tag (MText, ()), CustomErrorHasDoc tag) =>
Label tag -> s :-> any
failCustom_ Label "userUpgradable'notEnoughTokens"
forall a. IsLabel "userUpgradable'notEnoughTokens" a => a
forall (x :: Symbol) a. IsLabel x a => a
#userUpgradable'notEnoughTokens
  '[Natural, Natural, Storage] :-> '[Natural, Natural, Storage]
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
swap
  '[Natural, Natural, Storage] :-> '[Natural, Natural, Storage]
forall (s :: [*]). s :-> s
stackType @('[Natural, Natural, Storage])
  '[Natural, Natural, Storage] :-> '[Integer, Storage]
forall n m (s :: [*]).
ArithOpHs Sub n m =>
(n : m : s) :-> (ArithResHs Sub n m : s)
sub
  '[Integer, Storage] :-> '[Maybe Natural, Storage]
forall (s :: [*]). (Integer : s) :-> (Maybe Natural : s)
isNat
  ('[Natural, Storage] :-> '[Natural, Storage])
-> ('[Storage] :-> '[Natural, Storage])
-> '[Maybe Natural, Storage] :-> '[Natural, Storage]
forall a (s :: [*]) (s' :: [*]).
((a : s) :-> s') -> (s :-> s') -> (Maybe a : s) :-> s'
ifSome '[Natural, Storage] :-> '[Natural, Storage]
forall (s :: [*]). s :-> s
nop (('[Storage] :-> '[Natural, Storage])
 -> '[Maybe Natural, Storage] :-> '[Natural, Storage])
-> ('[Storage] :-> '[Natural, Storage])
-> '[Maybe Natural, Storage] :-> '[Natural, Storage]
forall a b. (a -> b) -> a -> b
$ Label "userUpgradable'notEnoughTokens"
-> '[Storage] :-> '[Natural, Storage]
forall (tag :: Symbol) (s :: [*]) (any :: [*]).
(MustHaveErrorArg tag (MText, ()), CustomErrorHasDoc tag) =>
Label tag -> s :-> any
failCustom_ Label "userUpgradable'notEnoughTokens"
forall a. IsLabel "userUpgradable'notEnoughTokens" a => a
forall (x :: Symbol) a. IsLabel x a => a
#userUpgradable'notEnoughTokens
  '[Natural, Storage] :-> '[Natural, Natural, Storage]
forall a (s :: [*]). (a : s) :-> (a : a : s)
dup; Natural
-> '[Natural, Natural, Storage]
   :-> '[Natural, Natural, Natural, Storage]
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push @Natural Natural
0
  if Condition
  '[Natural, Natural, Natural, Storage]
  '[Natural, Storage]
  '[Natural, Storage]
  '[Maybe Natural, Storage]
  '[Maybe Natural, Storage]
forall a (argl :: [*]) (outb :: [*]).
NiceComparable a =>
Condition (a : a : argl) argl argl outb outb
IsEq
  then '[Natural, Storage] :-> '[Storage]
forall a (s :: [*]). (a : s) :-> s
drop ('[Natural, Storage] :-> '[Storage])
-> ('[Storage] :-> '[Maybe Natural, Storage])
-> '[Natural, Storage] :-> '[Maybe Natural, Storage]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[Storage] :-> '[Maybe Natural, Storage]
forall a (s :: [*]). KnownValue a => s :-> (Maybe a : s)
none
  else '[Natural, Storage] :-> '[Maybe Natural, Storage]
forall a (s :: [*]). (a : s) :-> (Maybe a : s)
some
  '[Maybe Natural, Storage] :-> '[Maybe Natural, Storage]
forall (s :: [*]). s :-> s
stackType @('[Maybe Natural, Storage])
  ('[Storage] :-> '[BigMap Address Natural, Storage])
-> '[Maybe Natural, Storage]
   :-> '[Maybe Natural, BigMap Address Natural, Storage]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (Label "ledger"
-> '[Storage] :-> '[GetFieldType Storage "ledger", Storage]
forall dt (name :: Symbol) (st :: [*]).
InstrGetFieldC dt name =>
Label name -> (dt : st) :-> (GetFieldType dt name : dt : st)
getField Label "ledger"
forall a. IsLabel "ledger" a => a
forall (x :: Symbol) a. IsLabel x a => a
#ledger);
  '[Maybe Natural, BigMap Address Natural, Storage]
:-> '[Address, Maybe Natural, BigMap Address Natural, Storage]
forall (s :: [*]). s :-> (Address : s)
sender; '[Address, Maybe Natural, BigMap Address Natural, Storage]
:-> '[BigMap Address Natural, Storage]
forall c (s :: [*]).
UpdOpHs c =>
(UpdOpKeyHs c : UpdOpParamsHs c : c : s) :-> (c : s)
update; Label "ledger"
-> '[GetFieldType Storage "ledger", Storage] :-> '[Storage]
forall dt (name :: Symbol) (st :: [*]).
InstrSetFieldC dt name =>
Label name -> (GetFieldType dt name : dt : st) :-> (dt : st)
setField Label "ledger"
forall a. IsLabel "ledger" a => a
forall (x :: Symbol) a. IsLabel x a => a
#ledger