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

{-# OPTIONS_GHC -Wno-orphans #-}

module Lorentz.Contracts.UpgradeableCounterSdu.V1
  ( counterContract
  , migration
  , counterUpgradeParameters
  , counterDoc

    -- * Internals
  , runGetCounterValue
  , runAdd
  , permImpl
  ) where

import Lorentz
import Prelude (Identity)

import Data.Constraint (Dict(..))

import Lorentz.Contracts.Upgradeable.Common
import Lorentz.Contracts.Upgradeable.StorageDriven
import Lorentz.Contracts.UpgradeableCounterSdu
import Lorentz.UStore

{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}

data UStoreTemplate = UStoreTemplate
  { UStoreTemplate -> UStoreField Natural
counterValue :: UStoreField Natural
  , UStoreTemplate -> UStoreEntrypoint UStoreTemplate ()
epInc :: UStoreEntrypoint UStoreTemplate ()
  , UStoreTemplate -> UStoreEntrypoint UStoreTemplate Natural
epAdd :: UStoreEntrypoint UStoreTemplate Natural
  , UStoreTemplate
-> UStoreEntrypoint UStoreTemplate (Void_ () Natural)
epGetCounterValue :: UStoreEntrypoint UStoreTemplate (Void_ () Natural)
  } deriving stock (UStoreTemplate -> UStoreTemplate -> Bool
(UStoreTemplate -> UStoreTemplate -> Bool)
-> (UStoreTemplate -> UStoreTemplate -> Bool) -> Eq UStoreTemplate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UStoreTemplate -> UStoreTemplate -> Bool
$c/= :: UStoreTemplate -> UStoreTemplate -> Bool
== :: UStoreTemplate -> UStoreTemplate -> Bool
$c== :: UStoreTemplate -> UStoreTemplate -> Bool
Eq, (forall x. UStoreTemplate -> Rep UStoreTemplate x)
-> (forall x. Rep UStoreTemplate x -> UStoreTemplate)
-> Generic UStoreTemplate
forall x. Rep UStoreTemplate x -> UStoreTemplate
forall x. UStoreTemplate -> Rep UStoreTemplate x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UStoreTemplate x -> UStoreTemplate
$cfrom :: forall x. UStoreTemplate -> Rep UStoreTemplate x
Generic)

instance UStoreTemplateHasDoc UStoreTemplate where
  ustoreTemplateDocName :: Text
ustoreTemplateDocName = Text
"V1"
  ustoreTemplateDocDescription :: Markdown
ustoreTemplateDocDescription =
    Markdown
"Template for version 1 of the contract."

type UStorage = UStore UStoreTemplate

type Interface = UStoreEpInterface UStoreTemplate

instance KnownContractVersion (CounterSduV 1) where
  type VerInterface (CounterSduV 1) = Interface
  type VerUStoreTemplate (CounterSduV 1) = UStoreTemplate
  type VerPermanent (CounterSduV 1) = Permanent

_checkInterface :: Dict $ Interface ~
  [ "epInc" ?: ()
  , "epAdd" ?: Natural
  , "epGetCounterValue" ?: Void_ () Natural
  ]
_checkInterface :: Dict
$ (Interface
   ~ '["epInc" ?: (), "epAdd" ?: Natural,
       "epGetCounterValue" ?: Void_ () Natural])
_checkInterface = Dict
$ (Interface
   ~ '["epInc" ?: (), "epAdd" ?: Natural,
       "epGetCounterValue" ?: Void_ () Natural])
forall (a :: Constraint). a => Dict a
Dict

runInc :: Entrypoint () UStorage
runInc :: Entrypoint () UStorage
runInc = do
  forall (s :: [*]). (() : s) :-> s
forall a (s :: [*]). (a : s) :-> s
drop @()
  Label "counterValue"
-> '[UStorage]
   :-> '[GetUStoreField UStoreTemplate "counterValue", UStorage]
forall store (name :: Symbol) (s :: [*]).
FieldAccessC store name =>
Label name
-> (UStore store : s)
   :-> (GetUStoreField store name : UStore store : s)
ustoreGetField Label "counterValue"
forall a. IsLabel "counterValue" a => a
forall (x :: Symbol) a. IsLabel x a => a
#counterValue
  Natural -> '[Natural, UStorage] :-> '[Natural, Natural, UStorage]
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push @Natural Natural
1; '[Natural, Natural, UStorage] :-> '[Natural, UStorage]
forall n m (s :: [*]).
ArithOpHs Add n m =>
(n : m : s) :-> (ArithResHs Add n m : s)
add
  Label "counterValue"
-> '[GetUStoreField UStoreTemplate "counterValue", UStorage]
   :-> '[UStorage]
forall store (name :: Symbol) (s :: [*]).
FieldAccessC store name =>
Label name
-> (GetUStoreField store name : UStore store : s)
   :-> (UStore store : s)
ustoreSetField Label "counterValue"
forall a. IsLabel "counterValue" a => a
forall (x :: Symbol) a. IsLabel x a => a
#counterValue
  '[UStorage] :-> '[List Operation, UStorage]
forall p (s :: [*]). KnownValue p => s :-> (List p : s)
nil; '[List Operation, UStorage] :-> '[(List Operation, UStorage)]
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair

runAdd :: Entrypoint Natural UStorage
runAdd :: Entrypoint Natural UStorage
runAdd = do
  ('[UStorage] :-> '[Natural, UStorage])
-> '[Natural, UStorage] :-> '[Natural, Natural, UStorage]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (('[UStorage] :-> '[Natural, UStorage])
 -> '[Natural, UStorage] :-> '[Natural, Natural, UStorage])
-> ('[UStorage] :-> '[Natural, UStorage])
-> '[Natural, UStorage] :-> '[Natural, Natural, UStorage]
forall a b. (a -> b) -> a -> b
$ Label "counterValue"
-> '[UStorage]
   :-> '[GetUStoreField UStoreTemplate "counterValue", UStorage]
forall store (name :: Symbol) (s :: [*]).
FieldAccessC store name =>
Label name
-> (UStore store : s)
   :-> (GetUStoreField store name : UStore store : s)
ustoreGetField Label "counterValue"
forall a. IsLabel "counterValue" a => a
forall (x :: Symbol) a. IsLabel x a => a
#counterValue
  '[Natural, Natural, UStorage] :-> '[Natural, UStorage]
forall n m (s :: [*]).
ArithOpHs Add n m =>
(n : m : s) :-> (ArithResHs Add n m : s)
add
  Label "counterValue"
-> '[GetUStoreField UStoreTemplate "counterValue", UStorage]
   :-> '[UStorage]
forall store (name :: Symbol) (s :: [*]).
FieldAccessC store name =>
Label name
-> (GetUStoreField store name : UStore store : s)
   :-> (UStore store : s)
ustoreSetField Label "counterValue"
forall a. IsLabel "counterValue" a => a
forall (x :: Symbol) a. IsLabel x a => a
#counterValue
  '[UStorage] :-> '[List Operation, UStorage]
forall p (s :: [*]). KnownValue p => s :-> (List p : s)
nil; '[List Operation, UStorage] :-> '[(List Operation, UStorage)]
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair

runGetCounterValue :: Entrypoint (Void_ () Natural) UStorage
runGetCounterValue :: Entrypoint (Void_ () Natural) UStorage
runGetCounterValue = ('[(), UStorage] :-> '[Natural])
-> Entrypoint (Void_ () Natural) UStorage
forall a b (s :: [*]) (s' :: [*]) (anything :: [*]).
(IsError (VoidResult b), NiceConstant b) =>
((a : s) :-> (b : s')) -> (Void_ a b : s) :-> anything
void_ (('[(), UStorage] :-> '[Natural])
 -> Entrypoint (Void_ () Natural) UStorage)
-> ('[(), UStorage] :-> '[Natural])
-> Entrypoint (Void_ () Natural) UStorage
forall a b. (a -> b) -> a -> b
$ do
  forall (s :: [*]). (() : s) :-> s
forall a (s :: [*]). (a : s) :-> s
drop @()
  Label "counterValue"
-> '[UStorage]
   :-> '[GetUStoreField UStoreTemplate "counterValue", UStorage]
forall store (name :: Symbol) (s :: [*]).
FieldAccessC store name =>
Label name
-> (UStore store : s)
   :-> (GetUStoreField store name : UStore store : s)
ustoreGetField Label "counterValue"
forall a. IsLabel "counterValue" a => a
forall (x :: Symbol) a. IsLabel x a => a
#counterValue
  ('[UStorage] :-> '[]) -> '[Natural, UStorage] :-> '[Natural]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip '[UStorage] :-> '[]
forall a (s :: [*]). (a : s) :-> s
drop

counterContract :: UContractRouter (CounterSduV 1)
counterContract :: UContractRouter (CounterSduV 1)
counterContract = SduFallback (VerUStoreTemplate (CounterSduV 1))
-> UContractRouter (CounterSduV 1)
forall (ver :: VersionKind).
Typeable (VerUStoreTemplate ver) =>
SduFallback (VerUStoreTemplate ver) -> UContractRouter ver
mkSduContract SduFallback (VerUStoreTemplate (CounterSduV 1))
forall store. SduFallback store
sduFallbackFail

permImpl :: PermanentImpl (CounterSduV 1)
permImpl :: PermanentImpl (CounterSduV 1)
permImpl = IsoRecTuple
  (Rec
     (CaseClauseL '[UStorage] '[(List Operation, UStorage)])
     '[ 'CaseClauseParam "GetCounter" ('OneField (Void_ () Integer)),
        'CaseClauseParam "GetNothing" ('OneField Empty)])
-> PermanentImpl (CounterSduV 1)
forall (ver :: VersionKind) dt (out :: [*]) (inp :: [*]) clauses.
(CaseTC dt out inp clauses,
 DocumentEntrypoints PermanentEntrypointsKind dt,
 dt ~ VerPermanent ver, inp ~ '[VerUStore ver],
 out ~ ContractOut (VerUStore ver)) =>
IsoRecTuple clauses -> PermanentImpl ver
mkSmallPermanentImpl
  ( Label "cGetCounter"
forall a. IsLabel "cGetCounter" a => a
forall (x :: Symbol) a. IsLabel x a => a
#cGetCounter Label "cGetCounter"
-> ('[Void_ () Integer, UStorage]
    :-> '[(List Operation, UStorage)])
-> CaseClauseL
     '[UStorage]
     '[(List Operation, UStorage)]
     ('CaseClauseParam "GetCounter" ('OneField (Void_ () Integer)))
forall (name :: Symbol) body clause.
CaseArrow name body clause =>
Label name -> body -> clause
/-> ('[(), UStorage] :-> '[Integer])
-> '[Void_ () Integer, UStorage] :-> '[(List Operation, UStorage)]
forall a b (s :: [*]) (s' :: [*]) (anything :: [*]).
(IsError (VoidResult b), NiceConstant b) =>
((a : s) :-> (b : s')) -> (Void_ a b : s) :-> anything
void_ (('[(), UStorage] :-> '[Integer])
 -> '[Void_ () Integer, UStorage] :-> '[(List Operation, UStorage)])
-> ('[(), UStorage] :-> '[Integer])
-> '[Void_ () Integer, UStorage] :-> '[(List Operation, UStorage)]
forall a b. (a -> b) -> a -> b
$ do
      forall (s :: [*]). (() : s) :-> s
forall a (s :: [*]). (a : s) :-> s
drop @(); Label "counterValue"
-> '[UStorage] :-> '[GetUStoreField UStoreTemplate "counterValue"]
forall store (name :: Symbol) (s :: [*]).
FieldAccessC store name =>
Label name
-> (UStore store : s) :-> (GetUStoreField store name : s)
ustoreToField Label "counterValue"
forall a. IsLabel "counterValue" a => a
forall (x :: Symbol) a. IsLabel x a => a
#counterValue; '[Natural] :-> '[Integer]
forall i (s :: [*]).
ToIntegerArithOpHs i =>
(i : s) :-> (Integer : s)
int
  , Label "cGetNothing"
forall a. IsLabel "cGetNothing" a => a
forall (x :: Symbol) a. IsLabel x a => a
#cGetNothing Label "cGetNothing"
-> ('[Empty, UStorage] :-> '[(List Operation, UStorage)])
-> CaseClauseL
     '[UStorage]
     '[(List Operation, UStorage)]
     ('CaseClauseParam "GetNothing" ('OneField Empty))
forall (name :: Symbol) body clause.
CaseArrow name body clause =>
Label name -> body -> clause
/-> '[Empty, UStorage] :-> '[(List Operation, UStorage)]
forall (s :: [*]) (s' :: [*]). (Empty : s) :-> s'
absurd_
  )

mkStorage :: UStoreTemplate
mkStorage :: UStoreTemplate
mkStorage = UStoreTemplate :: UStoreField Natural
-> UStoreEntrypoint UStoreTemplate ()
-> UStoreEntrypoint UStoreTemplate Natural
-> UStoreEntrypoint UStoreTemplate (Void_ () Natural)
-> UStoreTemplate
UStoreTemplate
  { counterValue :: UStoreField Natural
counterValue = Natural -> UStoreField Natural
forall (m :: UStoreMarkerType) v. v -> UStoreFieldExt m v
UStoreField Natural
0
  , epInc :: UStoreEntrypoint UStoreTemplate ()
epInc = Entrypoint () UStorage -> UStoreEntrypoint UStoreTemplate ()
forall arg store.
NiceUnpackedValue arg =>
Entrypoint arg (UStore store) -> UStoreEntrypoint store arg
mkUStoreEntrypoint Entrypoint () UStorage
runInc
  , epAdd :: UStoreEntrypoint UStoreTemplate Natural
epAdd = Entrypoint Natural UStorage
-> UStoreEntrypoint UStoreTemplate Natural
forall arg store.
NiceUnpackedValue arg =>
Entrypoint arg (UStore store) -> UStoreEntrypoint store arg
mkUStoreEntrypoint Entrypoint Natural UStorage
runAdd
  , epGetCounterValue :: UStoreEntrypoint UStoreTemplate (Void_ () Natural)
epGetCounterValue = Entrypoint (Void_ () Natural) UStorage
-> UStoreEntrypoint UStoreTemplate (Void_ () Natural)
forall arg store.
NiceUnpackedValue arg =>
Entrypoint arg (UStore store) -> UStoreEntrypoint store arg
mkUStoreEntrypoint Entrypoint (Void_ () Natural) UStorage
runGetCounterValue
  }

-- | This function migrates the storage from an empty one to UStorage,
--   i.e. it populates the empty BigMap with initial values for each field
--   and entrypoints.
--   The result is expected to adhere to V1.UStoreTemplate.
migration :: UStoreMigration () UStoreTemplate
migration :: UStoreMigration () UStoreTemplate
migration = UStoreTemplate -> UStoreMigration () UStoreTemplate
forall template.
UStoreTraversable FillUStoreTW template =>
template -> UStoreMigration () template
fillUStore UStoreTemplate
mkStorage

counterUpgradeParameters :: EpwUpgradeParameters Identity (CounterSduV 0) (CounterSduV 1)
counterUpgradeParameters :: EpwUpgradeParameters Identity (CounterSduV 0) (CounterSduV 1)
counterUpgradeParameters = EpwUpgradeParameters :: forall (t :: * -> *) (curVer :: VersionKind)
       (newVer :: VersionKind) code codePerm.
(Traversable t, KnownContractVersion curVer,
 KnownContractVersion newVer,
 RequireSamePermanents (VerPermanent curVer) (VerPermanent newVer),
 RecognizeUpgPiece (UContractRouterUpdate curVer newVer) code,
 RecognizeUpgPiece (PermanentImplUpdate curVer newVer) codePerm) =>
t (MigrationScript
     (VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
-> code -> codePerm -> EpwUpgradeParameters t curVer newVer
EpwUpgradeParameters
  { upMigrationScripts :: Identity
  (MigrationScript
     (VerUStoreTemplate (CounterSduV 0))
     (VerUStoreTemplate (CounterSduV 1)))
upMigrationScripts = UStoreMigration () UStoreTemplate
-> Identity (MigrationScript () UStoreTemplate)
forall os ns.
UStoreMigration os ns -> Identity (MigrationScript os ns)
migrationToScriptI UStoreMigration () UStoreTemplate
migration
  , upNewCode :: UContractRouter (CounterSduV 1)
upNewCode = UContractRouter (CounterSduV 1)
counterContract
  , upNewPermCode :: PermanentImpl (CounterSduV 1)
upNewPermCode = PermanentImpl (CounterSduV 1)
permImpl
  }


-- TODO: come up with a proper way to include documentation to the
-- storage-driven upgradeable contracts
counterDoc :: '[()] :-> '[()]
counterDoc :: '[()] :-> '[()]
counterDoc =
  (SubDoc -> DName) -> ('[()] :-> '[()]) -> '[()] :-> '[()]
forall di (inp :: [*]) (out :: [*]).
DocItem di =>
(SubDoc -> di) -> (inp :-> out) -> inp :-> out
docGroup (Text -> SubDoc -> DName
DName Text
"Upgradeable counter (SDU)") (('[()] :-> '[()]) -> '[()] :-> '[()])
-> ('[()] :-> '[()]) -> '[()] :-> '[()]
forall a b. (a -> b) -> a -> b
$ do
    '[()] :-> '[()]
forall (s :: [*]). s :-> s
contractGeneralDefault

    DDescription -> '[()] :-> '[()]
forall di (s :: [*]). DocItem di => di -> s :-> s
doc (DDescription -> '[()] :-> '[()])
-> DDescription -> '[()] :-> '[()]
forall a b. (a -> b) -> a -> b
$ Markdown -> DDescription
DDescription
      Markdown
"Sample of storage-driven upgradeable contract."
    UStoreTemplate -> PermanentImpl (CounterSduV 1) -> '[()] :-> '[()]
forall utemplate (ver :: VersionKind).
(NiceVersion ver, KnownContractVersion ver,
 UStoreTraversable SduDocumentTW utemplate, PermConstraint ver) =>
utemplate -> PermanentImpl ver -> '[()] :-> '[()]
sduContractDoc
      (Proxy UpgradeableEntrypointsKind
-> UStoreTemplate -> UStoreTemplate
forall template epKind.
(UStoreTraversable SduAddEntrypointDocTW template,
 DocItem (DEntrypoint epKind)) =>
Proxy epKind -> template -> template
sduAddEntrypointDoc (Proxy UpgradeableEntrypointsKind
forall k (t :: k). Proxy t
Proxy @UpgradeableEntrypointsKind) UStoreTemplate
mkStorage)
      PermanentImpl (CounterSduV 1)
permImpl