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

{-# OPTIONS_HADDOCK not-home #-}

-- | On-chain view utilities.
module Test.Cleveland.Internal.Actions.View
  ( module Test.Cleveland.Internal.Actions.View
  ) where

import Data.Constraint (pattern Dict)
import Fmt ((+|), (|+))

import Lorentz (Contract(..), HasView, Label, NiceViewable, toVal)
import Lorentz qualified as L
import Morley.AsRPC
import Morley.Client.Types (awaAddress)
import Morley.Michelson.Typed (pattern (:#))
import Morley.Michelson.Typed qualified as T
import Morley.Tezos.Address
import Morley.Util.TypeLits (KnownSymbol, symbolValT')
import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Actions.Assertions (failure)
import Test.Cleveland.Internal.Actions.Misc
import Test.Cleveland.Lorentz.Types

-- | Call an on-chain view by name. The existence of the view is checked at
-- compile time. If you don't have compile-time information about views, see
-- 'unsafeCallView'.
--
-- Example:
--
-- > callView contract #sum (123, -321)
callView
  :: forall name arg ret cp st vd m caps.
    ( MonadCleveland caps m, HasView vd name arg ret
    , NiceParameter arg, NiceViewable ret, NiceStorage ret
    , NiceParameter cp, KnownSymbol name, HasRPCRepr ret
    , T.IsoValue (AsRPC ret))
  => ContractHandle cp st vd -- ^ Contract to call.
  -> Label name -- ^ View name. Use @OverloadedLabels@ syntax.
  -> arg -- ^ Parameter to pass to the view.
  -> m (AsRPC ret)
callView :: forall (name :: Symbol) arg ret cp st vd (m :: * -> *) caps.
(MonadCleveland caps m, HasView vd name arg ret, NiceParameter arg,
 NiceViewable ret, NiceStorage ret, NiceParameter cp,
 KnownSymbol name, HasRPCRepr ret, IsoValue (AsRPC ret)) =>
ContractHandle cp st vd -> Label name -> arg -> m (AsRPC ret)
callView = forall ret arg (name :: Symbol) addr (m :: * -> *) caps.
(MonadCleveland caps m, NiceParameter arg, NiceViewable ret,
 NiceStorage ret, KnownSymbol name, HasRPCRepr ret,
 IsoValue (AsRPC ret), ToContractAddress addr) =>
addr -> Label name -> arg -> m (AsRPC ret)
unsafeCallView @ret
  where Dict (HasView vd name arg ret)
_ = forall (a :: Constraint). a => Dict a
Dict @(HasView vd name arg ret) -- silence redundant constraint warning

-- | Version of 'callView' that doesn't check if the view exists in the type.
-- You'll have to specify the return type. You can use @TypeApplications@ syntax
-- for that.
--
-- If the view doesn't exist or has incorrect type, a test failure will be
-- thrown.
--
-- Note that first type argument is return type, the second is parameter type.
-- The reason for this inversion is you often only need to specify the return
-- type, while the parameter type can be either inferred or explicitly specified
-- with a type annotation on the parameter argument value.
--
-- Examples:
--
-- > unsafeCallView @() contract #id ()
-- Calls view @id@ with argument @unit@ and return type @unit@.
--
-- > unsafeCallView @(Integer, MText) contract #query [mt|hello|]
-- Calls view @query@ with argument @string@ and return type @pair int string@.
--
-- > unsafeCallView @Integer contract #sum (123 :: Natural, -321 :: Integer)
-- Calls view @sum@ with argument @pair nat int@ and return type @int@. Type
-- annotations are required due to polymorphic numeric literals.
--
-- This last example could also be written as
--
-- > unsafeCallView @Integer @(Natural, Integer) contract #sum (123, -321)
unsafeCallView
  :: forall ret arg name addr m caps.
    ( MonadCleveland caps m, NiceParameter arg, NiceViewable ret
    , NiceStorage ret, KnownSymbol name
    , HasRPCRepr ret, T.IsoValue (AsRPC ret)
    , ToContractAddress addr)
  => addr -- ^ Contract to call.
  -> Label name -- ^ View name. Use @OverloadedLabels@ syntax.
  -> arg -- ^ Parameter to pass to the view.
  -> m (AsRPC ret)
unsafeCallView :: forall ret arg (name :: Symbol) addr (m :: * -> *) caps.
(MonadCleveland caps m, NiceParameter arg, NiceViewable ret,
 NiceStorage ret, KnownSymbol name, HasRPCRepr ret,
 IsoValue (AsRPC ret), ToContractAddress addr) =>
addr -> Label name -> arg -> m (AsRPC ret)
unsafeCallView (addr -> ContractAddress
forall addr. ToContractAddress addr => addr -> ContractAddress
toContractAddress -> ContractAddress
ch) Label name
_ arg
arg = do
  Sender ImplicitAddressWithAlias
sender' <- Getting Sender caps Sender -> m Sender
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
Prelude.view Getting Sender caps Sender
forall caps. HasClevelandCaps caps => Lens' caps Sender
senderL
  Mutez
contractBalance <- ContractAddress -> m Mutez
forall caps (m :: * -> *) addr.
(HasCallStack, MonadCleveland caps m, ToL1Address addr) =>
addr -> m Mutez
getBalance ContractAddress
ch
  let ct :: Contract arg (Maybe ret) ()
ct = forall (name :: Symbol) arg ret.
(NiceParameter arg, NiceViewable ret, NiceStorage ret,
 KnownSymbol name) =>
ContractAddress -> Contract arg (Maybe ret) ()
runnerContract @name @arg @ret ContractAddress
ch
      callFail :: m (AsRPC ret)
callFail = Builder -> m (AsRPC ret)
forall a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Builder -> m a
failure (Builder -> m (AsRPC ret)) -> Builder -> m (AsRPC ret)
forall a b. (a -> b) -> a -> b
$ Builder
"Failed to call view " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| forall (s :: Symbol). KnownSymbol s => Text
symbolValT' @name Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+
        Builder
": either it doesn't exist or types don't match."
  Maybe (AsRPC ret)
res <- RunCode arg (Maybe ret) () -> m (AsRPC (Maybe ret))
forall caps (m :: * -> *) st cp vd.
(HasCallStack, MonadCleveland caps m, HasRPCRepr st,
 IsoValue (AsRPC st)) =>
RunCode cp st vd -> m (AsRPC st)
runCode RunCode :: forall cp st vd.
Contract cp st vd
-> Value
-> Value
-> Mutez
-> Maybe Natural
-> Maybe Timestamp
-> Mutez
-> Maybe ImplicitAddress
-> RunCode cp st vd
RunCode
    { rcAmount :: Mutez
rcAmount = Mutez
0
    , rcBalance :: Mutez
rcBalance = Mutez
contractBalance
    , rcSource :: Maybe ImplicitAddress
rcSource = ImplicitAddress -> Maybe ImplicitAddress
forall a. a -> Maybe a
Just (ImplicitAddress -> Maybe ImplicitAddress)
-> ImplicitAddress -> Maybe ImplicitAddress
forall a b. (a -> b) -> a -> b
$ ImplicitAddressWithAlias -> ImplicitAddress
forall (kind :: AddressKind).
AddressWithAlias kind -> KindedAddress kind
awaAddress ImplicitAddressWithAlias
sender'
    , rcContract :: Contract arg (Maybe ret) ()
rcContract = Contract arg (Maybe ret) ()
ct
    , rcParameter :: Value
rcParameter = Value' Instr (ToT arg) -> Value
forall (t :: T). HasNoOp t => Value' Instr t -> Value
T.untypeValue (Value' Instr (ToT arg) -> Value)
-> Value' Instr (ToT arg) -> Value
forall a b. (a -> b) -> a -> b
$ arg -> Value' Instr (ToT arg)
forall a. IsoValue a => a -> Value (ToT a)
T.toVal arg
arg
    , rcStorage :: Value
rcStorage = Value' Instr ('TOption (ToT ret)) -> Value
forall (t :: T). HasNoOp t => Value' Instr t -> Value
T.untypeValue (Value' Instr ('TOption (ToT ret)) -> Value)
-> Value' Instr ('TOption (ToT ret)) -> Value
forall a b. (a -> b) -> a -> b
$ Maybe ret -> Value (ToT (Maybe ret))
forall a. IsoValue a => a -> Value (ToT a)
T.toVal (Maybe ret
forall a. Maybe a
Nothing :: Maybe ret)
    , rcLevel :: Maybe Natural
rcLevel = Maybe Natural
forall a. Maybe a
Nothing
    , rcNow :: Maybe Timestamp
rcNow = Maybe Timestamp
forall a. Maybe a
Nothing
    }
  m (AsRPC ret)
-> (AsRPC ret -> m (AsRPC ret))
-> Maybe (AsRPC ret)
-> m (AsRPC ret)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m (AsRPC ret)
callFail AsRPC ret -> m (AsRPC ret)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (AsRPC ret)
res

-- | Contract that calls a view and saves the result to storage.
runnerContract
  :: forall name arg ret. (NiceParameter arg, NiceViewable ret, NiceStorage ret, KnownSymbol name)
  => ContractAddress -> Contract arg (Maybe ret) ()
runnerContract :: forall (name :: Symbol) arg ret.
(NiceParameter arg, NiceViewable ret, NiceStorage ret,
 KnownSymbol name) =>
ContractAddress -> Contract arg (Maybe ret) ()
runnerContract ContractAddress
ch = (Contract' Instr (ToT arg) ('TOption (ToT ret))
 -> ContractCode arg (Maybe ret) -> Contract arg (Maybe ret) ())
-> ContractCode arg (Maybe ret)
-> Contract' Instr (ToT arg) ('TOption (ToT ret))
-> Contract arg (Maybe ret) ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Contract' Instr (ToT arg) ('TOption (ToT ret))
-> ContractCode arg (Maybe ret) -> Contract arg (Maybe ret) ()
forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) =>
Contract (ToT cp) (ToT st)
-> ContractCode cp st -> Contract cp st vd
Contract ContractCode arg (Maybe ret)
forall {cp} {st}. ContractCode cp st
fakeDoc (Contract' Instr (ToT arg) ('TOption (ToT ret))
 -> Contract arg (Maybe ret) ())
-> Contract' Instr (ToT arg) ('TOption (ToT ret))
-> Contract arg (Maybe ret) ()
forall a b. (a -> b) -> a -> b
$ (IsNotInView =>
 Instr
   (ContractInp (ToT arg) ('TOption (ToT ret)))
   (ContractOut ('TOption (ToT ret))))
-> Contract' Instr (ToT arg) ('TOption (ToT ret))
forall (cp :: T) (st :: T) (instr :: [T] -> [T] -> *).
(ParameterScope cp, StorageScope st) =>
(IsNotInView => instr (ContractInp cp st) (ContractOut st))
-> Contract' instr cp st
T.defaultContract ((IsNotInView =>
  Instr
    (ContractInp (ToT arg) ('TOption (ToT ret)))
    (ContractOut ('TOption (ToT ret))))
 -> Contract' Instr (ToT arg) ('TOption (ToT ret)))
-> (IsNotInView =>
    Instr
      (ContractInp (ToT arg) ('TOption (ToT ret)))
      (ContractOut ('TOption (ToT ret))))
-> Contract' Instr (ToT arg) ('TOption (ToT ret))
forall a b. (a -> b) -> a -> b
$
  -- NB: It's not a Lorentz contract to avoid requiring NiceParameterFull and
  -- NiceStorageFull on arg and ret respectively.
  Instr (ContractInp (ToT arg) ('TOption (ToT ret))) '[ToT arg]
forall {inp :: [T]} {out :: [T]} (a :: T) (b :: T) (s :: [T]).
(inp ~ ('TPair a b : s), out ~ (a : s)) =>
Instr inp out
T.CAR Instr (ContractInp (ToT arg) ('TOption (ToT ret))) '[ToT arg]
-> Instr '[ToT arg] (ContractOut ('TOption (ToT ret)))
-> Instr
     (ContractInp (ToT arg) ('TOption (ToT ret)))
     (ContractOut ('TOption (ToT ret)))
forall (a :: [T]) (c :: [T]) (b :: [T]).
Instr a b -> Instr b c -> Instr a c
:# Instr '[] '[ 'TAddress] -> Instr '[ToT arg] '[ToT arg, 'TAddress]
forall (a :: [T]) (c :: [T]) (b :: T).
Instr a c -> Instr (b : a) (b : c)
T.DIP (Value' Instr 'TAddress -> Instr '[] '[ 'TAddress]
forall {inp :: [T]} {out :: [T]} (t :: T) (s :: [T]).
(inp ~ s, out ~ (t : s), ConstantScope t) =>
Value' Instr t -> Instr inp out
T.PUSH (Value' Instr 'TAddress -> Instr '[] '[ 'TAddress])
-> Value' Instr 'TAddress -> Instr '[] '[ 'TAddress]
forall a b. (a -> b) -> a -> b
$ Address -> Value (ToT Address)
forall a. IsoValue a => a -> Value (ToT a)
toVal (Address -> Value (ToT Address)) -> Address -> Value (ToT Address)
forall a b. (a -> b) -> a -> b
$ ContractAddress -> Address
forall a. ToAddress a => a -> Address
toAddress ContractAddress
ch)
    Instr '[ToT arg] '[ToT arg, 'TAddress]
-> Instr '[ToT arg, 'TAddress] (ContractOut ('TOption (ToT ret)))
-> Instr '[ToT arg] (ContractOut ('TOption (ToT ret)))
forall (a :: [T]) (c :: [T]) (b :: [T]).
Instr a b -> Instr b c -> Instr a c
:# ViewName -> Instr '[ToT arg, 'TAddress] '[ 'TOption (ToT ret)]
forall {inp :: [T]} {out :: [T]} (arg :: T) (ret :: T) (s :: [T]).
(inp ~ (arg : 'TAddress : s), out ~ ('TOption ret : s), SingI arg,
 ViewableScope ret) =>
ViewName -> Instr inp out
T.VIEW (Text -> ViewName
T.UnsafeViewName (Text -> ViewName) -> Text -> ViewName
forall a b. (a -> b) -> a -> b
$ forall (s :: Symbol). KnownSymbol s => Text
symbolValT' @name)
    Instr '[ToT arg, 'TAddress] '[ 'TOption (ToT ret)]
-> Instr '[ 'TOption (ToT ret)] (ContractOut ('TOption (ToT ret)))
-> Instr '[ToT arg, 'TAddress] (ContractOut ('TOption (ToT ret)))
forall (a :: [T]) (c :: [T]) (b :: [T]).
Instr a b -> Instr b c -> Instr a c
:# Instr
  '[ 'TOption (ToT ret)] '[ 'TList 'TOperation, 'TOption (ToT ret)]
forall {inp :: [T]} {out :: [T]} (p :: T) (s :: [T]).
(inp ~ s, out ~ ('TList p : s), SingI p) =>
Instr inp out
T.NIL Instr
  '[ 'TOption (ToT ret)] '[ 'TList 'TOperation, 'TOption (ToT ret)]
-> Instr
     '[ 'TList 'TOperation, 'TOption (ToT ret)]
     (ContractOut ('TOption (ToT ret)))
-> Instr '[ 'TOption (ToT ret)] (ContractOut ('TOption (ToT ret)))
forall (a :: [T]) (c :: [T]) (b :: [T]).
Instr a b -> Instr b c -> Instr a c
:# Instr
  '[ 'TList 'TOperation, 'TOption (ToT ret)]
  (ContractOut ('TOption (ToT ret)))
forall {inp :: [T]} {out :: [T]} (a :: T) (b :: T) (s :: [T]).
(inp ~ (a : b : s), out ~ ('TPair a b : s)) =>
Instr inp out
T.PAIR
  where
    fakeDoc :: ContractCode cp st
fakeDoc = ('[(cp, st)] :-> ContractOut st) -> ContractCode cp st
forall cp st.
('[(cp, st)] :-> ContractOut st) -> ContractCode cp st
L.ContractCode (('[(cp, st)] :-> ContractOut st) -> ContractCode cp st)
-> ('[(cp, st)] :-> ContractOut st) -> ContractCode cp st
forall a b. (a -> b) -> a -> b
$ (Any :-> Any) -> '[(cp, st)] :-> ContractOut st
forall (s1 :: [*]) (s2 :: [*]) (s1' :: [*]) (s2' :: [*]).
(s1 :-> s2) -> s1' :-> s2'
L.fakeCoercing Any :-> Any
forall (s :: [*]). s :-> s
L.nop