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

-- | Contract that facilitates tickets emission.
module Test.Cleveland.Lorentz.Ticketer
  ( ticketerContract'
  , ticketerContract
  , callViaTicketer
  ) where

import Lorentz
import Prelude (HasCallStack)

import Test.Cleveland
import Test.Cleveland.Internal.Actions.Transfer

-- | A contract that emits the desired tickets.
--
-- It has one entrypoint - a 'View_' where you supply ticket
-- data and tokens amount, and a callback contract that
-- should receive an argument with the ticket.
--
-- You also have to supply a lambda that attaches a payload
-- to the ticket, since tickets are usually attached to some
-- other data.
ticketerContract'
  :: ( NiceComparable td
     , NiceParameterFull (View_ (payload, (Natural, td)) callbackArg)
     , NiceParameter callbackArg
     )
  => [payload, Ticket td] :-> '[callbackArg]
  -> Contract (View_ (payload, (Natural, td)) callbackArg) () ()
ticketerContract' :: forall td payload callbackArg.
(NiceComparable td,
 NiceParameterFull (View_ (payload, (Natural, td)) callbackArg),
 NiceParameter callbackArg) =>
('[payload, Ticket td] :-> '[callbackArg])
-> Contract (View_ (payload, (Natural, td)) callbackArg) () ()
ticketerContract' '[payload, Ticket td] :-> '[callbackArg]
mkCallbackArg = (IsNotInView =>
 '[(View_ (payload, (Natural, td)) callbackArg, ())]
 :-> ContractOut ())
-> Contract (View_ (payload, (Natural, td)) callbackArg) () ()
forall cp st.
(NiceParameterFull cp, NiceStorageFull st) =>
(IsNotInView => '[(cp, st)] :-> ContractOut st)
-> Contract cp st ()
defaultContract ((IsNotInView =>
  '[(View_ (payload, (Natural, td)) callbackArg, ())]
  :-> ContractOut ())
 -> Contract (View_ (payload, (Natural, td)) callbackArg) () ())
-> (IsNotInView =>
    '[(View_ (payload, (Natural, td)) callbackArg, ())]
    :-> ContractOut ())
-> Contract (View_ (payload, (Natural, td)) callbackArg) () ()
forall a b. (a -> b) -> a -> b
$
  '[(View_ (payload, (Natural, td)) callbackArg, ())]
:-> '[View_ (payload, (Natural, td)) callbackArg, ()]
forall a b (s :: [*]). ((a, b) : s) :-> (a : b : s)
unpair ('[(View_ (payload, (Natural, td)) callbackArg, ())]
 :-> '[View_ (payload, (Natural, td)) callbackArg, ()])
-> ('[View_ (payload, (Natural, td)) callbackArg, ()]
    :-> ContractOut ())
-> '[(View_ (payload, (Natural, td)) callbackArg, ())]
   :-> ContractOut ()
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (forall (s0 :: [*]).
 ((payload, (Natural, td)) : () : s0) :-> (callbackArg : s0))
-> '[View_ (payload, (Natural, td)) callbackArg, ()]
   :-> ContractOut ()
forall r storage a (s :: [*]).
(NiceParameter r, Dupable storage, IsNotInView) =>
(forall (s0 :: [*]). (a : storage : s0) :-> (r : s0))
-> (View_ a r : storage : s) :-> ((List Operation, storage) : s)
view_
    ( ((() : s0) :-> s0)
-> ((payload, (Natural, td)) : () : s0)
   :-> ((payload, (Natural, td)) : s0)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (forall a (s :: [*]). (a : s) :-> s
drop @()) (((payload, (Natural, td)) : () : s0)
 :-> ((payload, (Natural, td)) : s0))
-> (((payload, (Natural, td)) : s0)
    :-> (payload : (Natural, td) : s0))
-> ((payload, (Natural, td)) : () : s0)
   :-> (payload : (Natural, td) : s0)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# ((payload, (Natural, td)) : s0) :-> (payload : (Natural, td) : s0)
forall a b (s :: [*]). ((a, b) : s) :-> (a : b : s)
unpair (((payload, (Natural, td)) : () : s0)
 :-> (payload : (Natural, td) : s0))
-> ((payload : (Natural, td) : s0) :-> (payload : Ticket td : s0))
-> ((payload, (Natural, td)) : () : s0)
   :-> (payload : Ticket td : s0)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      (((Natural, td) : s0) :-> (Ticket td : s0))
-> (payload : (Natural, td) : s0) :-> (payload : Ticket td : s0)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (((Natural, td) : s0) :-> (Natural : td : s0)
forall a b (s :: [*]). ((a, b) : s) :-> (a : b : s)
unpair (((Natural, td) : s0) :-> (Natural : td : s0))
-> ((Natural : td : s0) :-> (td : Natural : s0))
-> ((Natural, td) : s0) :-> (td : Natural : s0)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (Natural : td : s0) :-> (td : Natural : s0)
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
swap (((Natural, td) : s0) :-> (td : Natural : s0))
-> ((td : Natural : s0) :-> (Maybe (Ticket td) : s0))
-> ((Natural, td) : s0) :-> (Maybe (Ticket td) : s0)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (td : Natural : s0) :-> (Maybe (Ticket td) : s0)
forall a (s :: [*]).
NiceComparable a =>
(a : Natural : s) :-> (Maybe (Ticket a) : s)
ticket (((Natural, td) : s0) :-> (Maybe (Ticket td) : s0))
-> ((Maybe (Ticket td) : s0) :-> (Ticket td : s0))
-> ((Natural, td) : s0) :-> (Ticket td : s0)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# forall err a (s :: [*]).
IsError err =>
err -> (Maybe a : s) :-> (a : s)
assertSome @MText MText
"Zero amount tickets are not allowed") (((payload, (Natural, td)) : () : s0)
 :-> (payload : Ticket td : s0))
-> ((payload : Ticket td : s0) :-> (callbackArg : s0))
-> ((payload, (Natural, td)) : () : s0) :-> (callbackArg : s0)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      ('[payload, Ticket td] :-> '[callbackArg])
-> ('[payload, Ticket td] ++ s0) :-> ('[callbackArg] ++ s0)
forall (s :: [*]) (i :: [*]) (o :: [*]).
(KnownList i, KnownList o) =>
(i :-> o) -> (i ++ s) :-> (o ++ s)
framed '[payload, Ticket td] :-> '[callbackArg]
mkCallbackArg
    )

-- | A simpler version of 'ticketerContract\'' where the target
-- contract will always receive a pair of payload and ticket.
ticketerContract
  :: ( NiceComparable td
     , callbackArg ~ (payload, Ticket td)
     , NiceParameterFull (View_ (payload, (Natural, td)) callbackArg)
     , NiceParameter callbackArg
     )
  => Contract (View_ (payload, (Natural, td)) callbackArg) () ()
ticketerContract :: forall td callbackArg payload.
(NiceComparable td, callbackArg ~ (payload, Ticket td),
 NiceParameterFull (View_ (payload, (Natural, td)) callbackArg),
 NiceParameter callbackArg) =>
Contract (View_ (payload, (Natural, td)) callbackArg) () ()
ticketerContract = ('[payload, Ticket td] :-> '[(payload, Ticket td)])
-> Contract
     (View_ (payload, (Natural, td)) (payload, Ticket td)) () ()
forall td payload callbackArg.
(NiceComparable td,
 NiceParameterFull (View_ (payload, (Natural, td)) callbackArg),
 NiceParameter callbackArg) =>
('[payload, Ticket td] :-> '[callbackArg])
-> Contract (View_ (payload, (Natural, td)) callbackArg) () ()
ticketerContract' '[payload, Ticket td] :-> '[(payload, Ticket td)]
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair

-- | Run a contract indirectly via calling the given ticketer contract.
--
-- The target contract will receive a ticket and some payload. The exact
-- structure of the passed argument is determined by the ticketer contract.
callViaTicketer
  :: forall targetArg payload td targetAddr ticketerParam ticketerAddr m.
     ( HasCallStack
     , MonadTransfer m
     , ticketerParam ~ View_ (payload, (Natural, td)) targetArg
     , ToL1TAddress ticketerParam () ticketerAddr
     , ToContractRef targetArg targetAddr
     , NiceParameterFull ticketerParam
     )
  => ticketerAddr  -- ^ Address of ticketer contract
  -> Natural       -- ^ Desired ticket amount
  -> td            -- ^ Desired ticket data
  -> targetAddr    -- ^ Contract to call indirectly
  -> payload       -- ^ Main argument passed to the ticketer
  -> m ()
callViaTicketer :: forall targetArg payload td targetAddr ticketerParam ticketerAddr
       (m :: * -> *).
(HasCallStack, MonadTransfer m,
 ticketerParam ~ View_ (payload, (Natural, td)) targetArg,
 ToL1TAddress ticketerParam () ticketerAddr,
 ToContractRef targetArg targetAddr,
 NiceParameterFull ticketerParam) =>
ticketerAddr -> Natural -> td -> targetAddr -> payload -> m ()
callViaTicketer ticketerAddr
ticketer Natural
ticketAmount td
ticketData targetAddr
target payload
payload =
  L1TAddress ticketerParam ()
-> GenericCall
     ('Checked (View_ (payload, (Natural, td)) targetArg))
-> m ()
forall addr r.
(HasCallStack,
 TransferFunc
   ('Incomplete (InitialTransferMode addr))
   'TransferIgnoreResult
   'HasNoAmount
   r,
 ToL1Address addr) =>
addr -> r
transfer (forall cp vd addr.
ToL1TAddress cp vd addr =>
addr -> L1TAddress cp vd
toL1TAddress @ticketerParam @() ticketerAddr
ticketer) (GenericCall ('Checked (View_ (payload, (Natural, td)) targetArg))
 -> m ())
-> GenericCall
     ('Checked (View_ (payload, (Natural, td)) targetArg))
-> m ()
forall a b. (a -> b) -> a -> b
$ EntrypointRef 'Nothing
-> forall epArg param.
   (NiceParameter epArg,
    HasEntrypointArg param (EntrypointRef 'Nothing) epArg) =>
   epArg -> GenericCall ('Checked param)
forall (mname :: Maybe Symbol).
EntrypointRef mname
-> forall epArg param.
   (NiceParameter epArg,
    HasEntrypointArg param (EntrypointRef mname) epArg) =>
   epArg -> GenericCall ('Checked param)
calling EntrypointRef 'Nothing
forall a. Default a => a
def (View_ (payload, (Natural, td)) targetArg
 -> GenericCall
      ('Checked (View_ (payload, (Natural, td)) targetArg)))
-> View_ (payload, (Natural, td)) targetArg
-> GenericCall
     ('Checked (View_ (payload, (Natural, td)) targetArg))
forall a b. (a -> b) -> a -> b
$
    (payload, (Natural, td))
-> targetAddr -> View_ (payload, (Natural, td)) targetArg
forall r contract a.
ToContractRef r contract =>
a -> contract -> View_ a r
mkView_ (payload
payload, (Natural
ticketAmount, td
ticketData)) targetAddr
target