Address.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{- |

This module introduces several types for safe work with @address@ and
@contract@ types. All available types for that are represented in the following
table:

+------------------------+------------+-------------------+----------------------+
| Type                   | Type safe? | What it refers to | Michelson reflection |
+========================+============+===================+======================+
| Address                | No         | Whole contract    | address              |
+------------------------+------------+-------------------+----------------------+
| EpAddress              | No         | Entrypoint        | address              |
+------------------------+------------+-------------------+----------------------+
| TAddress               | Yes        | Whole contract    | address              |
+------------------------+------------+-------------------+----------------------+
| FutureContract         | Yes        | Entrypoint        | address              |
+------------------------+------------+-------------------+----------------------+
| ContractRef            | Yes        | Entrypoint        | contract             |
+------------------------+------------+-------------------+----------------------+

This module also provides functions for converting between these types in Haskell
and Michelson worlds.
In the latter you can additionally use coercions and dedicated instructions from
"Lorentz.Instr".

-}
module Lorentz.Address
  ( TAddress (..)
  , FutureContract (..)

    -- ** Conversions
  , asAddressOf
  , asAddressOf_
  , callingAddress
  , callingDefAddress
  , callingTAddress
  , callingDefTAddress
  , ToAddress (..)
  , ToTAddress (..)
  , ToTAddress_
  , toTAddress_
  , ToContractRef (..)
  , FromContractRef (..)
  , convertContractRef

    -- * Re-exports
  , Address
  , EpAddress (..)
  , ContractRef (..)
  , M.coerceContractRef
  ) where

import Data.Type.Bool (Not, type (&&))
import Fmt (Buildable)

import Lorentz.Annotation
import Lorentz.Base
import Lorentz.Constraints
import qualified Lorentz.Entrypoints.Core as Ep
import Morley.Michelson.Typed (ContractRef(..), IsoValue(..))
import qualified Morley.Michelson.Typed as M
import Morley.Michelson.Typed.Entrypoints (EpAddress(..))
import Morley.Tezos.Address (Address)
import Morley.Util.Type
import Morley.Util.TypeLits

-- | Address which remembers the parameter and views types of the contract
-- it refers to.
--
-- It differs from Michelson's @contract@ type because it cannot contain
-- entrypoint, and it always refers to entire contract parameter even if this
-- contract has explicit default entrypoint.
newtype TAddress (p :: Type) (vd :: Type) = TAddress { unTAddress :: Address }
  deriving stock (Generic, Show)
  deriving newtype (Eq, Ord, Buildable)
  deriving anyclass (IsoValue, HasAnnotation)

-- | For a contract and an address of its instance, construct a typed address.
asAddressOf :: contract cp st vd -> Address -> TAddress cp vd
asAddressOf _ = TAddress

asAddressOf_ :: contract cp st vd -> Address : s :-> TAddress cp vd : s
asAddressOf_ _ = I M.Nop

-- | Turn 'TAddress' to 'ContractRef' in /Haskell/ world.
--
-- This is an analogy of @address@ to @contract@ convertion in Michelson world,
-- thus you have to supply an entrypoint (or call the default one explicitly).
callingTAddress
  :: forall cp vd mname.
     (NiceParameterFull cp)
  => TAddress cp vd
  -> Ep.EntrypointRef mname
  -> ContractRef (Ep.GetEntrypointArgCustom cp mname)
callingTAddress = callingAddress @cp @vd
{-# DEPRECATED callingTAddress "Use `callingAddress`" #-}

-- | Specification of 'callingTAddress' to call the default entrypoint.
callingDefTAddress
  :: forall cp vd.
     (NiceParameterFull cp)
  => TAddress cp vd
  -> ContractRef (Ep.GetDefaultEntrypointArg cp)
callingDefTAddress taddr = callingTAddress taddr Ep.CallDefault
{-# DEPRECATED callingDefTAddress "Use `callingDefAddress`" #-}

-- | Generalization of 'callingTAddress' to any typed address.
callingAddress
  :: forall cp vd addr mname.
     (ToTAddress cp vd addr, NiceParameterFull cp)
  => addr
  -> Ep.EntrypointRef mname
  -> ContractRef (Ep.GetEntrypointArgCustom cp mname)
callingAddress (toTAddress @cp @vd -> TAddress addr) epRef =
  withDict (niceParameterEvi @cp) $
  case Ep.parameterEntrypointCallCustom @cp epRef of
    epc@M.EntrypointCall{} -> ContractRef addr (M.SomeEpc epc)

-- | Generalization of 'callingDefTAddress' to any typed address.
callingDefAddress
  :: forall cp vd addr.
     (ToTAddress cp vd addr, NiceParameterFull cp)
  => addr
  -> ContractRef (Ep.GetDefaultEntrypointArg cp)
callingDefAddress addr = callingAddress @cp @vd addr Ep.CallDefault

-- | Something coercible to 'TAddress cp'.
type ToTAddress_ cp vd addr = (ToTAddress cp vd addr, ToT addr ~ ToT Address)

-- | Cast something appropriate to 'TAddress'.
toTAddress_
  :: forall cp addr vd s.
     (ToTAddress_ cp vd addr)
  => addr : s :-> TAddress cp vd : s
toTAddress_ = I M.Nop

-- | Address associated with value of @contract arg@ type.
--
-- Places where 'ContractRef' can appear are now severely limited,
-- this type gives you type-safety of 'ContractRef' but still can be used
-- everywhere.
-- This type is not a full-featured one rather a helper; in particular, once
-- pushing it on stack, you cannot return it back to Haskell world.
--
-- Note that it refers to an entrypoint of the contract, not just the contract
-- as a whole. In this sense this type differs from 'TAddress'.
--
-- Unlike with 'ContractRef', having this type you still cannot be sure that
-- the referred contract exists and need to perform a lookup before calling it.
newtype FutureContract arg = FutureContract { unFutureContract :: ContractRef arg }

instance IsoValue (FutureContract arg) where
  type ToT (FutureContract arg) = ToT EpAddress
  toVal (FutureContract contract) = toVal $ M.contractRefToAddr contract
  fromVal = error "Fetching 'FutureContract' back from Michelson is impossible"

instance HasAnnotation (FutureContract a) where
  getAnnotation _ = M.starNotes

-- | Convert something to 'Address' in /Haskell/ world.
--
-- Use this when you want to access state of the contract and are not interested
-- in calling it.
class ToAddress a where
  toAddress :: a -> Address

instance ToAddress Address where
  toAddress = id

instance ToAddress EpAddress where
  toAddress = eaAddress

instance ToAddress (TAddress cp vd) where
  toAddress = unTAddress

instance ToAddress (FutureContract cp) where
  toAddress = toAddress . unFutureContract

instance ToAddress (ContractRef cp) where
  toAddress = crAddress

-- | Convert something referring to a contract (not specific entrypoint)
-- to 'TAddress' in /Haskell/ world.
class ToTAddress (cp :: Type) (vd :: Type) (a :: Type) where
  toTAddress :: a -> TAddress cp vd

instance ToTAddress cp vd Address where
  toTAddress = TAddress

instance (cp ~ cp', vd ~ vd') => ToTAddress cp vd (TAddress cp' vd') where
  toTAddress = id

-- | Convert something to 'ContractRef' in /Haskell/ world.
class ToContractRef (cp :: Type) (contract :: Type) where
  toContractRef :: HasCallStack => contract -> ContractRef cp

instance (cp ~ cp') => ToContractRef cp (ContractRef cp') where
  toContractRef = id

instance (NiceParameter cp, cp ~ cp') => ToContractRef cp (FutureContract cp') where
  toContractRef = unFutureContract

instance ( FailWhen cond msg
         , cond ~
            ( Ep.CanHaveEntrypoints cp &&
              Not (Ep.ParameterEntrypointsDerivation cp == Ep.EpdNone)
            )
         , msg ~
            ( 'Text "Cannot apply `ToContractRef` to `TAddress`" ':$$:
              'Text "Consider using call(Def)TAddress first`" ':$$:
              'Text "(or if you know your parameter type is primitive," ':$$:
              'Text " make sure typechecker also knows about that)" ':$$:
              'Text "For parameter `" ':<>: 'ShowType cp ':<>: 'Text "`"
            )
         , cp ~ arg, NiceParameter arg
           -- These constraints should naturally derive from ones above,
           -- but proving that is not worth the effort
         , NiceParameterFull cp, Ep.GetDefaultEntrypointArg cp ~ cp
         ) =>
         ToContractRef arg (TAddress cp vd) where
  toContractRef = callingDefTAddress

-- | Convert something from 'ContractRef' in /Haskell/ world.
class FromContractRef (cp :: Type) (contract :: Type) where
  fromContractRef :: ContractRef cp -> contract

instance (cp ~ cp') => FromContractRef cp (ContractRef cp') where
  fromContractRef = id

instance (cp ~ cp') => FromContractRef cp (FutureContract cp') where
  fromContractRef = FutureContract . fromContractRef

instance FromContractRef cp EpAddress where
  fromContractRef = M.contractRefToAddr

instance FromContractRef cp Address where
  fromContractRef = crAddress

convertContractRef
  :: forall cp contract2 contract1.
     (ToContractRef cp contract1, FromContractRef cp contract2)
  => contract1 -> contract2
convertContractRef = fromContractRef @cp . toContractRef