Originate.hs

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

-- | 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, niceStorageEvi,
  toMichelsonContract)

import Data.Constraint ((\\))
import GHC.TypeLits (ErrorMessage(..), 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 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, OriginateFunc contract 'NoBalance 'NotLarge r)
          => ContractAlias -> ContractStorage contract -> contract -> r
originate = originate'r @contract @'NoBalance @'NotLarge ... 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) \\ niceStorageEvi @st)
          (convertContract $ toMichelsonContract (odContract od))
    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))
    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 = flip OriginateData zeroMutez

instance ContractClass U.Contract where
  type ContractStorage U.Contract = U.Value
  type ContractOriginateData U.Contract = UntypedOriginateData
  initialData = flip UntypedOriginateData zeroMutez

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
      }

----------------------------------------------------------------------------
-- "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 ContractClass contract => OriginateFunc contract (bal :: HasBalance) isLarge r where
  originate'r :: HasCallStack => ContractOriginateData contract isLarge -> r
  default originate'r
    :: (HasCallStack, Originator (ContractOriginateData contract isLarge) r)
    => ContractOriginateData contract isLarge -> r
  originate'r = originateFn

-- | Simple flag to track duplicate balance specification.
data HasBalance = NoBalance | HasBalance

-- | Type family raising a type error on 'HasBalance' argument. Used to improve
-- error reporting for 'OriginateFunc' instances with equality constraints.
type family CheckDupBalance mod :: Constraint where
  CheckDupBalance 'HasBalance = TypeError ('Text "Balance is specified more than once.")
  CheckDupBalance 'NoBalance = ()

instance
   ( ModifyOriginationData (ContractOriginateData ct)
   , OriginateFunc ct 'HasBalance isLarge r
   , CheckDupBalance bal, bal ~ 'NoBalance)
  => OriginateFunc ct bal isLarge (Mutez -> r) where
  originate'r initData x = originate'r @ct @'HasBalance $ setBalance x initData

-- | Type family raising a type error on 'IsLarge' argument. Used to improve
-- error reporting for 'OriginateFunc' instances with equality constraints.
type family CheckDupLarge mod :: Constraint where
  CheckDupLarge 'IsLarge = TypeError ('Text "Large is specified more than once.")
  CheckDupLarge 'NotLarge = ()

instance (ModifyOriginationData (ContractOriginateData ct)
   , OriginateFunc ct bal 'IsLarge r
   , CheckDupLarge isLarge, isLarge ~ 'NotLarge)
  => OriginateFunc ct bal isLarge (Large -> r) where
  originate'r initData Large = originate'r @ct @bal $ setLarge initData

-- | Convenience synonym.
type OFConstraint ct large r =
  ( ContractClass ct, Originator (ContractOriginateData ct large) r)

-- | The terminating case for batched transfer.
instance OFConstraint ct large (ClevelandOpsBatch a)
  => OriginateFunc ct bal large (ClevelandOpsBatch a)

-- | The terminating case for Cleveland monads.
instance OFConstraint ct large (ReaderT cap base a)
  => OriginateFunc ct bal large (ReaderT cap base a)

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

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

----------------------------------------------------------------------------
-- 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
  setLarge :: od 'NotLarge -> od 'IsLarge

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

instance ModifyOriginationData (UntypedOriginateData) where
  setBalance bal od = od {uodBalance = bal}
  setLarge UntypedOriginateData{..} = UntypedOriginateData{..}

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