-- 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 :: forall contract r.
(HasCallStack, ContractClass contract,
 OriginateFunc contract '[] r) =>
ContractAlias -> ContractStorage contract -> contract -> r
originate = forall contract (props :: [Prop]) r.
(OriginateFunc contract props r, HasCallStack) =>
OriginateData (ContractOriginateType contract) (GetLarge props)
-> r
originate'r @contract @'[] (OriginateData (ContractOriginateType contract) 'NotLarge -> r)
-> (ContractAlias
    -> ContractStorage' (ContractOriginateType contract)
    -> contract
    -> OriginateData (ContractOriginateType contract) 'NotLarge)
-> ContractAlias
-> ContractStorage' (ContractOriginateType contract)
-> contract
-> r
forall a b c. SuperComposition a b c => a -> b -> c
... forall contract.
ContractClass contract =>
ContractAlias
-> ContractStorage contract
-> contract
-> OriginateData (ContractOriginateType contract) 'NotLarge
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 :: forall (large :: LargeOrigination) (m :: * -> *)
       (ot :: OriginationType).
(HasCallStack, Originator large m) =>
OriginateData ot large -> m (OriginationResult ot)
originateFn od :: OriginateData ot large
od@OriginateData{Maybe KeyHash
Mutez
ContractAlias
ODContractAndStorage ot
odContractAndStorage :: forall (oty :: OriginationType) (large :: LargeOrigination).
OriginateData oty large -> ODContractAndStorage oty
odDelegate :: forall (oty :: OriginationType) (large :: LargeOrigination).
OriginateData oty large -> Maybe KeyHash
odBalance :: forall (oty :: OriginationType) (large :: LargeOrigination).
OriginateData oty large -> Mutez
odName :: forall (oty :: OriginationType) (large :: LargeOrigination).
OriginateData oty large -> ContractAlias
odContractAndStorage :: ODContractAndStorage ot
odDelegate :: Maybe KeyHash
odBalance :: Mutez
odName :: ContractAlias
..} = case ODContractAndStorage ot
odContractAndStorage of
  ODContractAndStorageUntyped{} -> OriginateData ot large -> m ContractAddress
forall (large :: LargeOrigination) (m :: * -> *)
       (oty :: OriginationType).
(Originator large m, HasCallStack) =>
OriginateData oty large -> m ContractAddress
doOriginate OriginateData ot large
od
  ODContractAndStorageTyped st
_ T.Contract{} -> ContractAlias -> ContractAddress -> ContractHandle cp st vd
forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) =>
ContractAlias -> ContractAddress -> ContractHandle cp st vd
ContractHandle ContractAlias
odName (ContractAddress -> ContractHandle cp st vd)
-> m ContractAddress -> m (ContractHandle cp st vd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OriginateData ot large -> m ContractAddress
forall (large :: LargeOrigination) (m :: * -> *)
       (oty :: OriginationType).
(Originator large m, HasCallStack) =>
OriginateData oty large -> m ContractAddress
doOriginate OriginateData ot large
od
  ODContractAndStorageLorentz st
_ Contract{} -> ContractAlias -> ContractAddress -> ContractHandle param st vd
forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) =>
ContractAlias -> ContractAddress -> ContractHandle cp st vd
ContractHandle ContractAlias
odName (ContractAddress -> ContractHandle param st vd)
-> m ContractAddress -> m (ContractHandle param st vd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OriginateData ot large -> m ContractAddress
forall (large :: LargeOrigination) (m :: * -> *)
       (oty :: OriginationType).
(Originator large m, HasCallStack) =>
OriginateData oty large -> m ContractAddress
doOriginate OriginateData ot large
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 :: forall (oty :: OriginationType).
HasCallStack =>
OriginateData oty 'NotLarge -> m ContractAddress
doOriginate OriginateData oty 'NotLarge
od = (ClevelandOpsImpl m -> m ContractAddress) -> m ContractAddress
forall (m :: * -> *) a.
MonadOpsInternal m =>
(ClevelandOpsImpl m -> m a) -> m a
withOpsCap \ClevelandOpsImpl m
opsCap ->
    ClevelandOpsImpl m
-> Text
-> OperationInfo ClevelandInput
-> (OperationInfo ClevelandResult -> Maybe ContractAddress)
-> m ContractAddress
forall (m :: * -> *) a.
(HasCallStack, Functor m) =>
ClevelandOpsImpl m
-> Text
-> OperationInfo ClevelandInput
-> (OperationInfo ClevelandResult -> Maybe a)
-> m a
runSingleOperation ClevelandOpsImpl m
opsCap Text
"origination" (OriginationInfo ClevelandInput -> OperationInfo ClevelandInput
forall i. OriginationInfo i -> OperationInfo i
OpOriginate (OriginationInfo ClevelandInput -> OperationInfo ClevelandInput)
-> OriginationInfo ClevelandInput -> OperationInfo ClevelandInput
forall a b. (a -> b) -> a -> b
$ OriginateData oty 'NotLarge -> SomeOriginateData 'NotLarge
forall (oty :: OriginationType) (large :: LargeOrigination).
OriginateData oty large -> SomeOriginateData large
SomeOriginateData OriginateData oty 'NotLarge
od) \case
      OpOriginate OriginationInfo ClevelandResult
addr -> ContractAddress -> Maybe ContractAddress
forall a. a -> Maybe a
Just ContractAddress
OriginationInfo ClevelandResult
addr
      OperationInfo ClevelandResult
_ -> Maybe ContractAddress
forall a. Maybe a
Nothing

instance MonadCleveland caps m => Originator 'IsLarge m where
  doOriginate :: forall (oty :: OriginationType).
HasCallStack =>
OriginateData oty 'IsLarge -> m ContractAddress
doOriginate OriginateData oty 'IsLarge
od = do
    Sender
sender <- Getting Sender caps Sender -> m Sender
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Sender caps Sender
forall caps. HasClevelandCaps caps => Lens' caps Sender
senderL
    (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps ContractAddress)
-> ReaderT caps (ClevelandBaseMonad caps) ContractAddress
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> forall (oty :: OriginationType).
   HasCallStack =>
   Sender
   -> OriginateData oty 'IsLarge
   -> ClevelandBaseMonad caps ContractAddress
forall (m :: * -> *).
ClevelandMiscImpl m
-> forall (oty :: OriginationType).
   HasCallStack =>
   Sender -> OriginateData oty 'IsLarge -> m ContractAddress
cmiOriginateLargeUntyped ClevelandMiscImpl (ClevelandBaseMonad caps)
cap Sender
sender OriginateData oty 'IsLarge
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 :: forall contract.
ContractClass contract =>
ContractAlias
-> ContractStorage contract
-> contract
-> OriginateData (ContractOriginateType contract) 'NotLarge
initialData ContractAlias
name = ContractAlias
-> Mutez
-> Maybe KeyHash
-> ODContractAndStorage (ContractOriginateType contract)
-> OriginateData (ContractOriginateType contract) 'NotLarge
forall (oty :: OriginationType) (large :: LargeOrigination).
ContractAlias
-> Mutez
-> Maybe KeyHash
-> ODContractAndStorage oty
-> OriginateData oty large
OriginateData ContractAlias
name Mutez
zeroMutez Maybe KeyHash
forall a. Maybe a
Nothing (ODContractAndStorage (ContractOriginateType contract)
 -> OriginateData (ContractOriginateType contract) 'NotLarge)
-> (ContractStorage' (ContractOriginateType contract)
    -> contract
    -> ODContractAndStorage (ContractOriginateType contract))
-> ContractStorage' (ContractOriginateType contract)
-> contract
-> OriginateData (ContractOriginateType contract) 'NotLarge
forall a b c. SuperComposition a b c => a -> b -> c
... ContractStorage' (ContractOriginateType contract)
-> contract
-> ODContractAndStorage (ContractOriginateType contract)
forall contract.
ContractClass contract =>
ContractStorage contract
-> contract
-> ODContractAndStorage (ContractOriginateType contract)
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 :: ContractStorage (Contract cp st vd)
-> Contract cp st vd
-> ODContractAndStorage (ContractOriginateType (Contract cp st vd))
initialStorageAndContract = ContractStorage (Contract cp st vd)
-> Contract cp st vd
-> ODContractAndStorage (ContractOriginateType (Contract cp st vd))
forall st param vd.
st
-> Contract param st vd
-> ODContractAndStorage ('OTTypedLorentz param st vd)
ODContractAndStorageLorentz

instance ContractClass U.Contract where
  type ContractOriginateType U.Contract = 'OTUntyped
  initialStorageAndContract :: ContractStorage Contract
-> Contract
-> ODContractAndStorage (ContractOriginateType Contract)
initialStorageAndContract = Value -> Contract -> ODContractAndStorage 'OTUntyped
ContractStorage Contract
-> Contract
-> ODContractAndStorage (ContractOriginateType Contract)
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 :: ContractStorage (TypedContract cp st vd)
-> TypedContract cp st vd
-> ODContractAndStorage
     (ContractOriginateType (TypedContract cp st vd))
initialStorageAndContract ContractStorage (TypedContract cp st vd)
store (TypedContract Contract (ToT cp) (ToT st)
contract) =
    st
-> Contract (ToT cp) (ToT st)
-> ODContractAndStorage ('OTTypedMorley cp st vd)
forall st vd cp.
(NiceStorage st, NiceViewsDescriptor vd, NiceParameter cp) =>
st
-> Contract (ToT cp) (ToT st)
-> ODContractAndStorage ('OTTypedMorley cp st vd)
ODContractAndStorageTyped st
ContractStorage (TypedContract cp st vd)
store Contract (ToT cp) (ToT st)
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 :: HasCallStack =>
OriginateData (ContractOriginateType ct) (GetLarge props)
-> Mutez -> r
originate'r OriginateData (ContractOriginateType ct) (GetLarge props)
initData Mutez
x = forall contract (props :: [Prop]) r.
(OriginateFunc contract props r, HasCallStack) =>
OriginateData (ContractOriginateType contract) (GetLarge props)
-> r
originate'r @ct @('PropBalance : props) (OriginateData
   (ContractOriginateType ct) (GetLarge ('PropBalance : props))
 -> r)
-> OriginateData
     (ContractOriginateType ct) (GetLarge ('PropBalance : props))
-> r
forall a b. (a -> b) -> a -> b
$ OriginateData (ContractOriginateType ct) (GetLarge props)
initData{odBalance :: Mutez
odBalance = Mutez
x}

-- | Set delegate.
instance OFConstraints ct 'PropDelegate props r => OriginateFunc ct props (KeyHash -> r) where
  originate'r :: HasCallStack =>
OriginateData (ContractOriginateType ct) (GetLarge props)
-> KeyHash -> r
originate'r OriginateData (ContractOriginateType ct) (GetLarge props)
initData KeyHash
x = forall contract (props :: [Prop]) r.
(OriginateFunc contract props r, HasCallStack) =>
OriginateData (ContractOriginateType contract) (GetLarge props)
-> r
originate'r @ct @('PropDelegate : props) (OriginateData
   (ContractOriginateType ct) (GetLarge ('PropDelegate : props))
 -> r)
-> OriginateData
     (ContractOriginateType ct) (GetLarge ('PropDelegate : props))
-> r
forall a b. (a -> b) -> a -> b
$ OriginateData (ContractOriginateType ct) (GetLarge props)
initData{odDelegate :: Maybe KeyHash
odDelegate = KeyHash -> Maybe KeyHash
forall a. a -> Maybe a
Just KeyHash
x}

-- | Set large origination.
instance (OFConstraints ct 'PropLarge props r, GetLarge props ~ 'NotLarge)
  => OriginateFunc ct props (Large -> r) where
  originate'r :: HasCallStack =>
OriginateData (ContractOriginateType ct) (GetLarge props)
-> Large -> r
originate'r OriginateData (ContractOriginateType ct) (GetLarge props)
initData Large
Large = forall contract (props :: [Prop]) r.
(OriginateFunc contract props r, HasCallStack) =>
OriginateData (ContractOriginateType contract) (GetLarge props)
-> r
originate'r @ct @('PropLarge ': props) (OriginateData
   (ContractOriginateType ct) (GetLarge ('PropLarge : props))
 -> r)
-> OriginateData
     (ContractOriginateType ct) (GetLarge ('PropLarge : props))
-> r
forall a b. (a -> b) -> a -> b
$ OriginateData (ContractOriginateType ct) 'NotLarge
-> OriginateData (ContractOriginateType ct) 'IsLarge
coerce OriginateData (ContractOriginateType ct) 'NotLarge
OriginateData (ContractOriginateType ct) (GetLarge props)
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 :: HasCallStack =>
OriginateData (ContractOriginateType ct) (GetLarge props)
-> ClevelandOpsBatch a
originate'r = OriginateData (ContractOriginateType ct) (GetLarge props)
-> ClevelandOpsBatch a
forall (large :: LargeOrigination) (m :: * -> *)
       (ot :: OriginationType).
(HasCallStack, Originator large m) =>
OriginateData ot large -> m (OriginationResult ot)
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 :: HasCallStack =>
OriginateData (ContractOriginateType ct) (GetLarge props)
-> ReaderT cap base a
originate'r = OriginateData (ContractOriginateType ct) (GetLarge props)
-> ReaderT cap base a
forall (large :: LargeOrigination) (m :: * -> *)
       (ot :: OriginationType).
(HasCallStack, Originator large m) =>
OriginateData ot large -> m (OriginationResult ot)
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 :: HasCallStack =>
OriginateData (ContractOriginateType ct) (GetLarge props) -> x -> r
originate'r = forall a. Bottom => a
OriginateData (ContractOriginateType ct) (GetLarge props) -> x -> 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