Base.hs

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

-- TODO: Replace 'Empty' with 'Never' from morley
{-# OPTIONS_GHC -Wno-deprecations #-}

module Lorentz.Contracts.Upgradeable.Common.Base
  ( Version (..)
  , VersionKind
  , KnownContractVersion (..)
  , VerParam
  , VerUStore
  , EmptyContractVersion
  , SomeContractVersion
  , UStore_
  , MigrationScript (..)
  , MigrationScriptFrom
  , MigrationScriptTo
  , UContractRouter (..)
  , SomeUContractRouter
  , UpgradeableEntrypointsKind
  , PermanentImpl (..)
  , SomePermanentImpl
  , PermanentEntrypointsKind
  , mkUContractRouter
  , coerceUContractRouter
  , emptyPermanentImpl
  , mkSmallPermanentImpl

    -- * Re-exports
  , Nat
  , Empty
  , absurd_
  ) where

import Prelude (KnownNat, Num, Typeable, natVal)

import qualified Data.Kind as Kind
import Fmt (Buildable(..))
import GHC.TypeNats (Nat)
import Util.TypeTuple

import Lorentz
import Lorentz.Contracts.Upgradeable.Common.Doc (UpgradeableEntrypointsKind)
import Lorentz.UStore
import Lorentz.UStore.Migration
import Michelson.Typed.Arith

-- Versioning
----------------------------------------------------------------------------

-- | Version of a contract.
--
-- Our current versioning suggests that this type is a term-level reflection
-- of types which have 'KnownContractVersion' instance, so this version item
-- should uniquely identify storage structure and entrypoints set for a given
-- contract for all of its instances.
--
-- The old semantics of this type was that it counts number of given contract
-- instance upgrades, so different contract instances, being upgraded to the
-- recent version, could have different 'Version's. For old contracts we have
-- to follow this behaviour.
newtype Version = Version { unVersion :: Natural }
  deriving stock (Show, Eq, Ord, Generic)
  deriving newtype (Num, IsoValue)
  deriving anyclass HasAnnotation

instance ArithOpHs Add Natural Version where
  type ArithResHs Add Natural Version = Version

instance Buildable Version where
  build (Version v) = "v" <> build v

instance TypeHasDoc Version where
  typeDocMdDescription = "Contract version."

instance ParameterHasEntrypoints Version where
  type ParameterEntrypointsDerivation Version = EpdNone

-- | Kind of type-level contract version.
type VersionKind =
  -- Defining it like this as it is the simplest way to have a custom open kind
  ContractVersionTag -> Kind.Type
data ContractVersionTag

-- | Declare given type as contract version identifier.
--
-- Instances of this typeclass (versions) uniquely identify contract storage
-- scheme and code. Normally the opposite should also hold, i.e.
-- @contract version <-> (contract storage scheme, code)@ relation is a bijection.
--
-- If as part of migration you need to update contract storage without modifying
-- its structure, then contract version should not change, and you should
-- perform an upgrade to the same version as the current one.
--
-- We allow upgrades between arbitrary two versions, so one can not only upgrade
-- to the next adjacent version, but also upgrade a new contract from V0 to the
-- recent version immediately, or leave version the same (as a versatile way
-- to change storage).
class KnownContractVersion (v :: VersionKind) where
  -- | List of entrypoints of given contract version.
  type VerInterface v :: [EntrypointKind]
  -- | Storage template of given contract version.
  type VerUStoreTemplate v :: Kind.Type

  -- | Set of permanent entrypoints (as a sum type).
  --
  -- We tie this type to contract version for convenience, in order not to carry
  -- one more type argument everywhere.
  -- We do not ensure right here that all versions of a contract have the same
  -- permanent entrypoints, but if this does not hold, then (ideally) it will
  -- not be possible to construct migration between such contract versions.
  type VerPermanent v :: Kind.Type
  type VerPermanent _ = Empty

  -- | Get term-level contract version.
  -- Returned value will be stored within the contract designating the current
  -- contract version.
  contractVersion :: Proxy v -> Version
  default contractVersion :: (v ~ cid ver, KnownNat ver) => Proxy v -> Version
  contractVersion (_ :: Proxy (cid ver)) = Version $ natVal (Proxy @ver)

type VerParam v = UParam (VerInterface v)
type VerUStore v = UStore (VerUStoreTemplate v)

-- | Contract with empty interface and storage.
data EmptyContractVersion (perm :: Kind.Type) :: VersionKind
instance KnownContractVersion (EmptyContractVersion perm) where
  type VerInterface (EmptyContractVersion perm) = '[]
  type VerUStoreTemplate (EmptyContractVersion perm) = ()
  type VerPermanent (EmptyContractVersion perm) = perm
  contractVersion _ = 0

-- | Version which forgets about particular interface/storage.
data SomeContractVersion (perm :: Kind.Type) :: VersionKind
instance KnownContractVersion (SomeContractVersion perm) where
  type VerInterface (SomeContractVersion perm) = SomeInterface
  type VerUStoreTemplate (SomeContractVersion perm) = SomeUTemplate
  type VerPermanent (SomeContractVersion perm) = perm
  contractVersion _ = error "Requested version of SomeContractVersion"

-- UParam dispatching
----------------------------------------------------------------------------

-- | Keeps parameter dispatching logic.
newtype UContractRouter (ver :: VersionKind) =
  UContractRouter
    { unUContractRouter
       :: Lambda (VerParam ver, VerUStore ver)
                 ([Operation], VerUStore ver)
    }
  deriving stock (Generic, Show)
  deriving anyclass (IsoValue, HasAnnotation, Wrappable)
  deriving newtype (MapLorentzInstr)

instance ( Typeable ver
         , Typeable (VerInterface ver), Typeable (VerUStoreTemplate ver)
         , TypeHasDoc (VerUStore ver)
         ) =>
         TypeHasDoc (UContractRouter ver) where
  typeDocMdDescription =
    "Parameter dispatching logic, main purpose of this code is to pass control \
    \to an entrypoint carrying the main logic of the contract."
  typeDocMdReference tp = customTypeDocMdReference ("UContractRouter", DType tp) []
  typeDocHaskellRep = homomorphicTypeDocHaskellRep
  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep

type SomeUContractRouter = UContractRouter (SomeContractVersion ())

mkUContractRouter
  :: ([VerParam ver, VerUStore ver] :-> '[([Operation], VerUStore ver)])
  -> UContractRouter ver
mkUContractRouter code = UContractRouter $ do
  unpair
  code

instance ( VerParam ver1 `CanCastTo` VerParam ver2
         , VerUStore ver1 `CanCastTo` VerUStore ver2
         ) =>
         UContractRouter ver1 `CanCastTo` UContractRouter ver2 where
  castDummy = castDummyG

coerceUContractRouter
  :: ( Coercible_ (VerParam s1) (VerParam s2)
     , Coercible_ (VerUStore s1) (VerUStore s2)
     )
  => UContractRouter s1 -> UContractRouter s2
coerceUContractRouter (UContractRouter code) =
  UContractRouter $ checkedCoerce_ # code # checkedCoerce_

-- Permanent entrypoints parameter dispatching
----------------------------------------------------------------------------

-- | Implementation of permanent entrypoints.
--
-- This will be injected into contract storage as one of fields, so make sure
-- that code within does not exceed several instructions; an actual entrypoint
-- logic can be put into 'UStore' and called from within @PermanentImpl@ only
-- when necessary.
--
-- Regarding documentation - this have to provide code pieces wrapped into
-- 'DEntrypoint' with 'PermanentEntrypointsKind', so always use 'entryCase' as
-- implementation of this type /or/ inject documentation of code which does so
-- unless you know what you are doing.
newtype PermanentImpl ver = PermanentImpl
  { unPermanentImpl :: Entrypoint (VerPermanent ver) (VerUStore ver)
  }
  deriving stock (Generic, Show)
  deriving newtype (MapLorentzInstr)
  deriving anyclass (Wrappable)

deriving anyclass instance (WellTypedIsoValue (VerPermanent ver)) => IsoValue (PermanentImpl ver)

instance HasAnnotation (VerPermanent ver) => HasAnnotation (PermanentImpl ver)

instance ( Typeable ver, Typeable (VerUStoreTemplate ver)
         , TypeHasDoc (VerUStore ver)
         , TypeHasDoc (VerPermanent ver), KnownValue (VerPermanent ver)
         ) =>
         TypeHasDoc (PermanentImpl ver) where
  typeDocMdDescription =
    "Implementation of permanent entrypoints."
  typeDocMdReference tp = customTypeDocMdReference ("PermanentImpl", DType tp) []
  typeDocHaskellRep = homomorphicTypeDocHaskellRep
  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep

type SomePermanentImpl perm = PermanentImpl (SomeContractVersion perm)

instance ( VerPermanent ver1 `CanCastTo` VerPermanent ver2
         , VerUStore ver1 `CanCastTo` VerUStore ver2
         ) =>
         PermanentImpl ver1 `CanCastTo` PermanentImpl ver2 where
  castDummy = castDummyG

-- | Common implementation of permanent part in case contract has no such.
emptyPermanentImpl :: (VerPermanent ver ~ Empty) => PermanentImpl ver
emptyPermanentImpl = PermanentImpl $
  docGroup (DEntrypoint @PermanentEntrypointsKind "<No entrypoints>")
    absurd_

-- | Construct implementation of permanent part in a common case;
-- this works similarly to 'entryCase'.
--
-- Use this function only for very small implementations.
mkSmallPermanentImpl
  :: forall ver 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 = PermanentImpl . entryCase (Proxy @PermanentEntrypointsKind)

-- | Common marker for permanent entrypoints.
-- Can be used when parameter for permanent entrypoints is flat, i.e. does not
-- have nested subparameters with multiple entrypoints.
data PermanentEntrypointsKind
instance EntrypointKindHasDoc PermanentEntrypointsKind where
  entrypointKindPos = 1050
  entrypointKindSectionName = "Permanent entrypoints"