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(..), NiceParameter, NiceStorage, NiceViewsDescriptor, toMichelsonContract)

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

import Morley.Client.Types
import Morley.Michelson.Typed (convertContract, toVal, untypeValue)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
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.MonadOps

-- | 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
----------------------------------------------------------------------------

-- | Class implementing actual origination.
class Originator od res where
  -- | Low-level polymorphic origination function.
  -- It takes 'UntypedOriginateData', 'TypedOriginateData' or 'OriginateData',
  -- and returns correspondingly an 'Address', or a 'ContractHandle', in a
  -- suitable monad.
  originateFn :: HasCallStack => od -> res

instance (a ~ ContractHandle cp st vd, MonadOpsInternal m
  , Originator (UntypedOriginateData large) (m ContractAddress))
  => Originator (OriginateData cp st vd large) (m a) where
  originateFn od@OriginateData{ odContract=Contract{}, ..} = do
    let uod = UntypedOriginateData @large
          odName
          odBalance
          (untypeValue (toVal odStorage))
          (convertContract $ toMichelsonContract (odContract od))
          odDelegate
    ContractHandle odName <$> originateFn uod

instance (a ~ ContractHandle cp st vd, MonadOpsInternal m
  , Originator (UntypedOriginateData large) (m ContractAddress)
  , NiceStorage st, NiceViewsDescriptor vd, NiceParameter cp)
  => Originator (TypedOriginateData cp st vd large) (m a) where
  originateFn tod@TypedOriginateData{todContract = T.Contract{}, ..} = do
    let uod = UntypedOriginateData @large
          todName
          todBalance
          (untypeValue (toVal todStorage))
          (convertContract (todContract tod))
          todDelegate
    ContractHandle todName <$> originateFn uod

instance (a ~ ContractAddress, MonadOpsInternal m)
  => Originator (UntypedOriginateData 'NotLarge) (m a) where
  originateFn uod = withOpsCap \opsCap ->
    runSingleOperation opsCap "origination" (OpOriginate uod) \case
      OpOriginate addr -> Just addr
      _ -> Nothing

instance (HasClevelandCaps caps, base ~ ClevelandBaseMonad caps, a ~ ContractAddress) =>
  Originator (UntypedOriginateData 'IsLarge) (ReaderT caps base a) where
  originateFn uod = do
    sender <- view senderL
    withCap getMiscCap \cap -> cmiOriginateLargeUntyped cap sender uod

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

-- | Type class that abstracts different contract types for the purpose of
-- origination.
class ContractClass contract where
  type ContractStorage contract
  type ContractOriginateData contract :: LargeOrigination -> Type
  initialData
    :: ContractAlias -> ContractStorage contract -> contract
    -> ContractOriginateData contract 'NotLarge

instance ContractClass (Contract cp st vd) where
  type ContractStorage (Contract cp st vd) = st
  type ContractOriginateData (Contract cp st vd) = OriginateData cp st vd
  initialData name store contract = OriginateData name zeroMutez store contract Nothing

instance ContractClass U.Contract where
  type ContractStorage U.Contract = U.Value
  type ContractOriginateData U.Contract = UntypedOriginateData
  initialData name store contract = UntypedOriginateData name zeroMutez store contract Nothing

instance ContractClass (TypedContract cp st vd) where
  type ContractStorage (TypedContract cp st vd) = st
  type ContractOriginateData (TypedContract cp st vd) = TypedOriginateData cp st vd
  initialData name store (TypedContract contract) =
    TypedOriginateData
      { todName = name
      , todBalance = zeroMutez
      , todStorage = store
      , todContract = contract
      , todDelegate = Nothing
      }

----------------------------------------------------------------------------
-- "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 => ContractOriginateData contract (GetLarge props) -> r
  default originate'r
    :: (HasCallStack, Originator (ContractOriginateData contract (GetLarge props)) r)
    => ContractOriginateData contract (GetLarge props) -> r
  originate'r = originateFn

-- | 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 =
  ( ModifyOriginationData (ContractOriginateData ct)
  , 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) $ setBalance x initData

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

-- | 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) $ setLarge initData

-- | The terminating case for batched transfer.
instance Originator (ContractOriginateData ct (GetLarge props)) (ClevelandOpsBatch a)
  => OriginateFunc ct props (ClevelandOpsBatch a)

-- | The terminating case for Cleveland monads.
instance Originator (ContractOriginateData ct (GetLarge props)) (ReaderT cap base a)
  => OriginateFunc ct props (ReaderT cap base a)

-- | 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. Originator (ContractOriginateData ct (GetLarge props)) (m a)
      => OriginateFunc ct props (m a))
  => MonadOriginate m
instance (MonadOpsInternal m
  , forall ct props a. Originator (ContractOriginateData ct (GetLarge 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

-- | Type class implementing modifications to origination data.
class ModifyOriginationData od where
  setBalance :: Mutez -> od large -> od large
  setDelegate :: KeyHash -> od large -> od large
  setLarge :: od 'NotLarge -> od 'IsLarge

instance ModifyOriginationData (OriginateData cp st vd) where
  setBalance bal od = od {odBalance = bal}
  setDelegate kh od = od {odDelegate = Just kh}
  setLarge OriginateData{..} = OriginateData{..}

instance ModifyOriginationData (UntypedOriginateData) where
  setBalance bal od = od {uodBalance = bal}
  setDelegate kh od = od {uodDelegate = Just kh}
  setLarge UntypedOriginateData{..} = UntypedOriginateData{..}

instance ModifyOriginationData (TypedOriginateData cp st vd) where
  setBalance bal od = od {todBalance = bal}
  setDelegate kh od = od {todDelegate = Just kh}
  setLarge TypedOriginateData{..} = TypedOriginateData{..}