Originate.hs

-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# OPTIONS_HADDOCK not-home #-}

-- | Machinery for the variadic 'originate' function.
module Test.Cleveland.Internal.Actions.Originate
  ( module Test.Cleveland.Internal.Actions.Originate
  ) where

import Lorentz (Contract(..), NiceViewsDescriptor)

import Data.Coerce (coerce)
import Data.Constraint (Bottom(..))
import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)

import Morley.Client.Types
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Address.Alias
import Morley.Tezos.Core
import Morley.Tezos.Crypto (KeyHash)
import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Actions.Helpers
import Test.Cleveland.Internal.Actions.MonadOpsInternal
import Test.Cleveland.Lorentz.Types

-- | Originate a new contract with given data.
--
-- Can accept untypted or Lorentz contracts as-is. With typed Michelson contracts,
-- you need to wrap the contract in 'TypedContract' specifying its Haskell-land
-- parameter, storage types and view descriptors, e.g.
--
-- > originate "typed contract" defaultStorage $ TypedContract @Param @Storage @() michelsonContract
--
-- Storage type can be auto-deduced in most cases, so you can skip it with @\@_@.
--
-- After the mandatory arguments, you can add 'Large' or a 'Mutez' value, e.g.
-- by using @tz@ quasi-quoter:
--
-- > originate "contract" initialStorage contract Large
-- > originate "contract" initialStorage contract [tz|123micro|]
-- > originate "contract" initialStorage contract [tz|123micro|] Large
--
-- The order is arbitrary, but each can be specified at most once.
originate
  :: forall contract r.
    ( HasCallStack, ContractClass contract, OriginateFunc contract '[] r)
  => ContractAlias -> ContractStorage contract -> contract -> r
originate = originate'r @contract @'[] ... initialData @contract

----------------------------------------------------------------------------
-- Main origination implementations
----------------------------------------------------------------------------

type OriginationResult :: OriginationType -> Type
type family OriginationResult a where
  OriginationResult 'OTUntyped = ContractAddress
  OriginationResult ('OTTypedMorley cp st vd) = ContractHandle cp st vd
  OriginationResult ('OTTypedLorentz cp st vd) = ContractHandle cp st vd

-- | Low-level polymorphic origination function. It takes arbitrary
-- 'OriginateData', and, depending on whether the data is typed or not, returns
-- respectively a 'ContractHandle', or a t'ContractAddress', in a suitable
-- monad (or an applicative functor in case of batched originations).
originateFn
  :: (HasCallStack, Originator large m)
  => OriginateData ot large -> m (OriginationResult ot)
originateFn od@OriginateData{..} = case odContractAndStorage of
  ODContractAndStorageUntyped{} -> doOriginate od
  ODContractAndStorageTyped _ T.Contract{} -> ContractHandle odName <$> doOriginate od
  ODContractAndStorageLorentz _ Contract{} -> ContractHandle odName <$> doOriginate od

-- | Class doing actual origination.
class MonadOpsInternal m => Originator large m where
  doOriginate :: HasCallStack => OriginateData oty large -> m ContractAddress

instance MonadOpsInternal m => Originator 'NotLarge m where
  doOriginate od = withOpsCap \opsCap ->
    runSingleOperation opsCap "origination" (OpOriginate $ SomeOriginateData od) \case
      OpOriginate addr -> Just addr
      _ -> Nothing

instance MonadCleveland caps m => Originator 'IsLarge m where
  doOriginate od = do
    sender <- view senderL
    withCap getMiscCap \cap -> cmiOriginateLargeUntyped cap sender od

----------------------------------------------------------------------------
-- ContractClass
----------------------------------------------------------------------------

type ContractStorage contract = ContractStorage' (ContractOriginateType contract)

type ContractStorage' :: OriginationType -> Type
type family ContractStorage' contract where
  ContractStorage' 'OTUntyped = U.Value
  ContractStorage' ('OTTypedMorley _ st _) = st
  ContractStorage' ('OTTypedLorentz _ st _) = st

initialData
  :: ContractClass contract
  => ContractAlias
  -> ContractStorage contract
  -> contract
  -> OriginateData (ContractOriginateType contract) 'NotLarge
initialData name = OriginateData name zeroMutez Nothing ... initialStorageAndContract

-- | Type class that abstracts different contract types for the purpose of
-- origination.
class ContractClass contract where
  type ContractOriginateType contract :: OriginationType
  initialStorageAndContract
    :: ContractStorage contract -> contract -> ODContractAndStorage (ContractOriginateType contract)

instance ContractClass (Contract cp st vd) where
  type ContractOriginateType (Contract cp st vd) = 'OTTypedLorentz cp st vd
  initialStorageAndContract = ODContractAndStorageLorentz

instance ContractClass U.Contract where
  type ContractOriginateType U.Contract = 'OTUntyped
  initialStorageAndContract = ODContractAndStorageUntyped

instance (NiceStorage st, NiceViewsDescriptor vd, NiceParameter cp)
  => ContractClass (TypedContract cp st vd) where
  type ContractOriginateType (TypedContract cp st vd) = 'OTTypedMorley cp st vd
  initialStorageAndContract store (TypedContract contract) =
    ODContractAndStorageTyped store contract

----------------------------------------------------------------------------
-- "The printf trick"
----------------------------------------------------------------------------

-- | The class implementing a guarded "printf trick" for the 'originate' function.
--
-- If you see GHC asking for this constraint, you most likely need to add
-- 'MonadOriginate' constraint on the return monad instead.
class OriginateFunc contract (props :: [Prop]) r where
  originate'r
    :: HasCallStack
    => OriginateData (ContractOriginateType contract) (GetLarge props) -> r

-- | Enum for props we track duplicates of.
data Prop = PropBalance | PropDelegate | PropLarge

-- | Pretty prop name.
type PropName :: Prop -> Symbol
type family PropName a where
  PropName 'PropBalance = "Balance"
  PropName 'PropDelegate = "Delegate"
  PropName 'PropLarge = "Large"

-- | Convert a list of props into 'LargeOrigination'.
type GetLarge :: [Prop] -> LargeOrigination
type family GetLarge a where
  GetLarge ('PropLarge ': _) = 'IsLarge
  GetLarge (_ ': xs) = GetLarge xs
  GetLarge '[] = 'NotLarge

-- | Type family raising a type error if element is in list. Used to improve
-- error reporting for 'OriginateFunc' instances with equality constraints.
type CheckDupProp :: Prop -> [Prop] -> Constraint
type family CheckDupProp name props where
  CheckDupProp name (name ': _) =
    TypeError ('Text (PropName name) ':<>: 'Text " is specified more than once.")
  CheckDupProp name (_ ': xs) = CheckDupProp name xs
  CheckDupProp _ '[] = ()

-- | Convenience synonym for constraints used in OriginateFunc instances.
type OFConstraints ct prop props r =
  ( OriginateFunc ct (prop ': props) r
  , CheckDupProp prop props)

-- | Set balance.
instance OFConstraints ct 'PropBalance props r => OriginateFunc ct props (Mutez -> r) where
  originate'r initData x = originate'r @ct @('PropBalance : props) $ initData{odBalance = x}

-- | Set delegate.
instance OFConstraints ct 'PropDelegate props r => OriginateFunc ct props (KeyHash -> r) where
  originate'r initData x = originate'r @ct @('PropDelegate : props) $ initData{odDelegate = Just x}

-- | Set large origination.
instance (OFConstraints ct 'PropLarge props r, GetLarge props ~ 'NotLarge)
  => OriginateFunc ct props (Large -> r) where
  originate'r initData Large = originate'r @ct @('PropLarge ': props) $ coerce initData

-- | Common constraints for terminating 'OriginateFunc' cases.
type TerminatingOFConstraints ct props m a =
  (Originator (GetLarge props) m, a ~ OriginationResult (ContractOriginateType ct))

-- | The terminating case for batched transfer.
instance TerminatingOFConstraints ct props ClevelandOpsBatch a
  => OriginateFunc ct props (ClevelandOpsBatch a) where
  originate'r = originateFn

-- | The terminating case for Cleveland monads.
instance TerminatingOFConstraints ct props (ReaderT cap base) a
  => OriginateFunc ct props (ReaderT cap base a) where
  originate'r = originateFn

-- | A convenient synonym class to require the terminating instance for a given
-- monad without leaking too much implementation detail.
class (MonadOpsInternal m
  , forall ct props a. TerminatingOFConstraints ct props m a => OriginateFunc ct props (m a)
  ) => MonadOriginate m
instance (MonadOpsInternal m
  , forall ct props a. TerminatingOFConstraints ct props m a => OriginateFunc ct props (m a)
  ) => MonadOriginate m

-- | Catchall incoherent instance to report argument errors.
instance {-# INCOHERENT #-}
    ( TypeError ('Text "Incorrect argument for the 'originate' function: " ':<>: 'ShowType x ':$$:
     'Text "If in doubt, try adding a type annotation.")
    , Bottom)
  => OriginateFunc ct props (x -> r) where
  originate'r = no

----------------------------------------------------------------------------
-- Applying modifiers to the initial data
----------------------------------------------------------------------------

-- | Mark a contract that doesn't fit into the origination size limit.
-- This will execute multiple origination steps.
--
-- Such origination cannot be batched (it simply may not fit).
data Large = Large