V1.hs

-- 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
  { counterValue :: UStoreField Natural
  , epInc :: UStoreEntrypoint UStoreTemplate ()
  , epAdd :: UStoreEntrypoint UStoreTemplate Natural
  , epGetCounterValue :: UStoreEntrypoint UStoreTemplate (Void_ () Natural)
  } deriving stock (Eq, Generic)

instance UStoreTemplateHasDoc UStoreTemplate where
  ustoreTemplateDocName = "V1"
  ustoreTemplateDocDescription =
    "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

runInc :: Entrypoint () UStorage
runInc = do
  drop @()
  ustoreGetField #counterValue
  push @Natural 1; add
  ustoreSetField #counterValue
  nil; pair

runAdd :: Entrypoint Natural UStorage
runAdd = do
  dip $ ustoreGetField #counterValue
  add
  ustoreSetField #counterValue
  nil; pair

runGetCounterValue :: Entrypoint (Void_ () Natural) UStorage
runGetCounterValue = void_ $ do
  drop @()
  ustoreGetField #counterValue
  dip drop

counterContract :: UContractRouter (CounterSduV 1)
counterContract = mkSduContract sduFallbackFail

permImpl :: PermanentImpl (CounterSduV 1)
permImpl = mkSmallPermanentImpl
  ( #cGetCounter /-> void_ $ do
      drop @(); ustoreToField #counterValue; int
  , #cGetNothing /-> absurd_
  )

mkStorage :: UStoreTemplate
mkStorage = UStoreTemplate
  { counterValue = UStoreField 0
  , epInc = mkUStoreEntrypoint runInc
  , epAdd = mkUStoreEntrypoint runAdd
  , epGetCounterValue = mkUStoreEntrypoint 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 = fillUStore mkStorage

counterUpgradeParameters :: EpwUpgradeParameters Identity (CounterSduV 0) (CounterSduV 1)
counterUpgradeParameters = EpwUpgradeParameters
  { upMigrationScripts = migrationToScriptI migration
  , upNewCode = counterContract
  , upNewPermCode = permImpl
  }


-- TODO: come up with a proper way to include documentation to the
-- storage-driven upgradeable contracts
counterDoc :: '[()] :-> '[()]
counterDoc =
  docGroup (DName "Upgradeable counter (SDU)") $ do
    contractGeneralDefault

    doc $ DDescription
      "Sample of storage-driven upgradeable contract."
    sduContractDoc
      (sduAddEntrypointDoc (Proxy @UpgradeableEntrypointsKind) mkStorage)
      permImpl