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

{-# LANGUAGE UndecidableSuperClasses #-}

-- | Primitives supplying entrypoints declarations and lookup.
module Lorentz.Entrypoints.Core
  ( CanHaveEntrypoints
  , EntrypointsDerivation (..)
  , EpConstructionRes (..)
  , EpCallingDesc (..)
  , EpCallingStep (..)
  , RequireAllUniqueEntrypoints
  , ParameterHasEntrypoints (..)
  , ParameterDeclaresEntrypoints
  , GetParameterEpDerivation
  , pepNotes
  , pepCall
  , pepDescs
  , pepDescsWithDef
  , AllParameterEntrypoints
  , LookupParameterEntrypoint
  , parameterEntrypointsToNotes
  , GetEntrypointArg
  , parameterEntrypointCall
  , GetDefaultEntrypointArg
  , parameterEntrypointCallDefault
  , ForbidExplicitDefaultEntrypoint
  , NoExplicitDefaultEntrypoint
  , sepcCallRootChecked
  , EntrypointRef (..)
  , NiceEntrypointName
  , eprName
  , GetEntrypointArgCustom
  , TrustEpName (..)
  , HasEntrypointArg (..)
  , HasDefEntrypointArg
  , HasEntrypointOfType
  , ParameterContainsEntrypoints
  , parameterEntrypointCallCustom
  , EpdNone
  , (:>)

    -- * Internals
  , RequireAllUniqueEntrypoints'
  ) where

import Data.Constraint ((\\))
import qualified Data.Kind as Kind
import Data.Typeable (typeRep)
import Data.Vinyl (Rec(..))
import Fcf (Eval, Exp)
import qualified Fcf
import qualified Fcf.Utils as Fcf
import Fmt (pretty)

import Michelson.Typed
import qualified Michelson.Untyped as U
import Util.Label
import Util.Type
import Util.TypeLits

import Lorentz.Annotation (FollowEntrypointFlag(..), HasAnnotation, getAnnotation)
import Lorentz.Constraints.Scopes
import Lorentz.Entrypoints.Helpers

-- | Defines a generalized way to declare entrypoints for various parameter types.
--
-- When defining instances of this typeclass, set concrete @deriv@ argument
-- and leave variable @cp@ argument.
-- Also keep in mind, that in presence of explicit default entrypoint, all other
-- 'Or' arms should be callable, though you can put this burden on user if very
-- necessary.
--
-- Methods of this typeclass aim to better type-safety when making up an
-- implementation and they may be not too convenient to use; users should
-- exploit their counterparts.
class EntrypointsDerivation deriv cp where
  -- | Name and argument of each entrypoint.
  -- This may include intermediate ones, even root if necessary.
  --
  -- Touching this type family is costly (@O(N^2)@), don't use it often.
  --
  -- Note [order of entrypoints children]:
  -- If this contains entrypoints referring to indermediate nodes (not leaves)
  -- in @or@ tree, then each such entrypoint should be mentioned eariler than
  -- all of its children.
  type EpdAllEntrypoints deriv cp :: [(Symbol, Kind.Type)]

  -- | Get entrypoint argument by name.
  type EpdLookupEntrypoint deriv cp :: Symbol -> Exp (Maybe Kind.Type)

  -- | Construct parameter annotations corresponding to expected entrypoints set.
  --
  -- This method is implementation detail, for actual notes construction
  -- use 'parameterEntrypointsToNotes'.
  epdNotes :: (Notes (ToT cp), U.RootAnn)

  -- | Construct entrypoint caller.
  --
  -- This does not treat calls to default entrypoint in a special way.
  --
  -- This method is implementation detail, for actual entrypoint lookup
  -- use 'parameterEntrypointCall'.
  epdCall
    :: ParameterScope (ToT cp)
    => Label name
    -> EpConstructionRes (ToT cp) (Eval (EpdLookupEntrypoint deriv cp name))

  -- | Description of how each of the entrypoints is constructed.
  epdDescs :: Rec EpCallingDesc (EpdAllEntrypoints deriv cp)

type RequireAllUniqueEntrypoints' deriv cp =
  RequireAllUnique
    "entrypoint name"
    (Eval (Fcf.Map Fcf.Fst $ EpdAllEntrypoints deriv cp))

-- | Ensure that all declared entrypoints are unique.
type RequireAllUniqueEntrypoints cp =
  RequireAllUniqueEntrypoints' (ParameterEntrypointsDerivation cp) cp

-- | Result of entrypoint lookup at term level.
data EpConstructionRes (param :: T) (marg :: Maybe Kind.Type) where
  EpConstructed
    :: ParameterScope (ToT arg)
    => EpLiftSequence (ToT arg) param -> EpConstructionRes param ('Just arg)
  EpConstructionFailed
    :: EpConstructionRes param 'Nothing

-- | How one of the entrypoints is called.
--
-- Type arguments are name of the constructor which eventually gave
-- name to the entrypoint and this entrypoint's argument.
data EpCallingDesc (info :: (Symbol, Kind.Type)) where
  EpCallingDesc ::
    { EpCallingDesc '(name, arg) -> Proxy arg
epcdArg :: Proxy (arg :: Kind.Type)
      -- ^ Entrypoint argument type.
    , EpCallingDesc '(name, arg) -> EpName
epcdEntrypoint :: EpName
      -- ^ Name of assigned entrypoint.
    , EpCallingDesc '(name, arg) -> [EpCallingStep]
epcdSteps :: [EpCallingStep]
      -- ^ If we emulated entrypoints calling via just wrapping an argument into
      -- constructors until getting the full parameter, how would it look like.
      -- Steps are enlisted in reversed order - top-level constructors go last.
    } -> EpCallingDesc '(name, arg)

deriving stock instance Show (EpCallingDesc info)

data EpCallingStep
  -- | Wrap into constructor with given name.
  = EpsWrapIn Text
  deriving stock (Int -> EpCallingStep -> ShowS
[EpCallingStep] -> ShowS
EpCallingStep -> String
(Int -> EpCallingStep -> ShowS)
-> (EpCallingStep -> String)
-> ([EpCallingStep] -> ShowS)
-> Show EpCallingStep
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EpCallingStep] -> ShowS
$cshowList :: [EpCallingStep] -> ShowS
show :: EpCallingStep -> String
$cshow :: EpCallingStep -> String
showsPrec :: Int -> EpCallingStep -> ShowS
$cshowsPrec :: Int -> EpCallingStep -> ShowS
Show, EpCallingStep -> EpCallingStep -> Bool
(EpCallingStep -> EpCallingStep -> Bool)
-> (EpCallingStep -> EpCallingStep -> Bool) -> Eq EpCallingStep
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EpCallingStep -> EpCallingStep -> Bool
$c/= :: EpCallingStep -> EpCallingStep -> Bool
== :: EpCallingStep -> EpCallingStep -> Bool
$c== :: EpCallingStep -> EpCallingStep -> Bool
Eq)

-- | Which entrypoints given parameter declares.
--
-- Note that usually this function should not be used as constraint, use
-- 'ParameterDeclaresEntrypoints' for this purpose.
class ( EntrypointsDerivation (ParameterEntrypointsDerivation cp) cp
      , RequireAllUniqueEntrypoints cp
      ) =>
      ParameterHasEntrypoints cp where
  type ParameterEntrypointsDerivation cp :: Kind.Type

-- | Parameter declares some entrypoints.
--
-- This is a version of 'ParameterHasEntrypoints' which we actually use in
-- constraints. When given type is a sum type or newtype, we refer to
-- 'ParameterHasEntrypoints' instance, otherwise this instance is not
-- necessary.
type ParameterDeclaresEntrypoints cp =
  ( If (CanHaveEntrypoints cp)
     (ParameterHasEntrypoints cp)
     (() :: Constraint)
  , NiceParameter cp
  , EntrypointsDerivation (GetParameterEpDerivation cp) cp
  )

-- | Version of 'ParameterEntrypointsDerivation' which we actually use in
-- function signatures. When given type is sum type or newtype, we refer to
-- 'ParameterEntrypointsDerivation', otherwise we suppose that no entrypoints
-- are declared.
type GetParameterEpDerivation cp =
  If (CanHaveEntrypoints cp)
     (ParameterEntrypointsDerivation cp)
     EpdNone

-- | Version of 'epdNotes' which we actually use in code.
-- It hides derivations stuff inside, and treats primitive types specially
-- like 'GetParameterEpDerivation' does.
pepNotes :: forall cp. ParameterDeclaresEntrypoints cp => (Notes (ToT cp), U.RootAnn)
pepNotes :: (Notes (ToT cp), RootAnn)
pepNotes = EntrypointsDerivation (GetParameterEpDerivation cp) cp =>
(Notes (ToT cp), RootAnn)
forall k (deriv :: k) cp.
EntrypointsDerivation deriv cp =>
(Notes (ToT cp), RootAnn)
epdNotes @(GetParameterEpDerivation cp) @cp

-- | Version of 'epdCall' which we actually use in code.
-- It hides derivations stuff inside, and treats primitive types specially
-- like 'GetParameterEpDerivation' does.
pepCall
  :: forall cp name.
     (ParameterDeclaresEntrypoints cp, ParameterScope (ToT cp))
  => Label name
  -> EpConstructionRes (ToT cp) (Eval (LookupParameterEntrypoint cp name))
pepCall :: Label name
-> EpConstructionRes
     (ToT cp) (Eval (LookupParameterEntrypoint cp name))
pepCall = forall (name :: Symbol).
(EntrypointsDerivation (GetParameterEpDerivation cp) cp,
 ParameterScope (ToT cp)) =>
Label name
-> EpConstructionRes
     (ToT cp)
     (Eval (EpdLookupEntrypoint (GetParameterEpDerivation cp) cp name))
forall k (deriv :: k) cp (name :: Symbol).
(EntrypointsDerivation deriv cp, ParameterScope (ToT cp)) =>
Label name
-> EpConstructionRes
     (ToT cp) (Eval (EpdLookupEntrypoint deriv cp name))
epdCall @(GetParameterEpDerivation cp) @cp

-- | Version of 'epdDescs' which we actually use in code.
-- It hides derivations stuff inside, and treats primitive types specially
-- like 'GetParameterEpDerivation' does.
pepDescs
  :: forall cp.
     (ParameterDeclaresEntrypoints cp)
  => Rec EpCallingDesc (AllParameterEntrypoints cp)
pepDescs :: Rec EpCallingDesc (AllParameterEntrypoints cp)
pepDescs = EntrypointsDerivation (GetParameterEpDerivation cp) cp =>
Rec
  EpCallingDesc (EpdAllEntrypoints (GetParameterEpDerivation cp) cp)
forall k (deriv :: k) cp.
EntrypointsDerivation deriv cp =>
Rec EpCallingDesc (EpdAllEntrypoints deriv cp)
epdDescs @(GetParameterEpDerivation cp) @cp

-- | Descriptions of how each of the entrypoints is constructed.
--
-- Similar to 'pepDescs', but includes default entrypoint disregard whether it is
-- explicit or not, while 'pepDescs' includes it only if it is explicit.
-- Also this returns list, not 'Rec', for simplicity.
--
-- Note that [order of entrypoints children] property still holds here.
pepDescsWithDef
  :: forall cp.
     (ParameterDeclaresEntrypoints cp)
  => [Some1 EpCallingDesc]
pepDescsWithDef :: [Some1 EpCallingDesc]
pepDescsWithDef = Rec
  EpCallingDesc
  (EpdAllEntrypoints
     (If
        (CanHaveEntrypoints cp)
        (ParameterEntrypointsDerivation cp)
        EpdNone)
     cp)
-> [Some1 EpCallingDesc]
addDefaultIfImplicit (Rec
   EpCallingDesc
   (EpdAllEntrypoints
      (If
         (CanHaveEntrypoints cp)
         (ParameterEntrypointsDerivation cp)
         EpdNone)
      cp)
 -> [Some1 EpCallingDesc])
-> Rec
     EpCallingDesc
     (EpdAllEntrypoints
        (If
           (CanHaveEntrypoints cp)
           (ParameterEntrypointsDerivation cp)
           EpdNone)
        cp)
-> [Some1 EpCallingDesc]
forall a b. (a -> b) -> a -> b
$ ParameterDeclaresEntrypoints cp =>
Rec EpCallingDesc (AllParameterEntrypoints cp)
forall cp.
ParameterDeclaresEntrypoints cp =>
Rec EpCallingDesc (AllParameterEntrypoints cp)
pepDescs @cp
  where
    addDefaultIfImplicit :: Rec
  EpCallingDesc
  (EpdAllEntrypoints
     (If
        (CanHaveEntrypoints cp)
        (ParameterEntrypointsDerivation cp)
        EpdNone)
     cp)
-> [Some1 EpCallingDesc]
addDefaultIfImplicit descsRec :: Rec
  EpCallingDesc
  (EpdAllEntrypoints
     (If
        (CanHaveEntrypoints cp)
        (ParameterEntrypointsDerivation cp)
        EpdNone)
     cp)
descsRec =
      let descs :: [Some1 EpCallingDesc]
descs = Rec
  EpCallingDesc
  (EpdAllEntrypoints
     (If
        (CanHaveEntrypoints cp)
        (ParameterEntrypointsDerivation cp)
        EpdNone)
     cp)
-> [Some1 EpCallingDesc]
forall k (f :: k -> *) (l :: [k]). Rec f l -> [Some1 f]
recordToSomeList Rec
  EpCallingDesc
  (EpdAllEntrypoints
     (If
        (CanHaveEntrypoints cp)
        (ParameterEntrypointsDerivation cp)
        EpdNone)
     cp)
descsRec
          hasDef :: Bool
hasDef =
            (Element [Some1 EpCallingDesc] -> Bool)
-> [Some1 EpCallingDesc] -> Bool
forall t. Container t => (Element t -> Bool) -> t -> Bool
any (\(Some1 EpCallingDesc{..}) -> EpName
epcdEntrypoint EpName -> EpName -> Bool
forall a. Eq a => a -> a -> Bool
== EpName
DefEpName) [Some1 EpCallingDesc]
descs
      in if Bool
hasDef
         then [Some1 EpCallingDesc]
descs
         else EpCallingDesc '(Any, cp) -> Some1 EpCallingDesc
forall k (f :: k -> *) (a :: k). f a -> Some1 f
Some1 $WEpCallingDesc :: forall arg (name :: Symbol).
Proxy arg
-> EpName -> [EpCallingStep] -> EpCallingDesc '(name, arg)
EpCallingDesc
              { epcdArg :: Proxy cp
epcdArg = Proxy cp
forall k (t :: k). Proxy t
Proxy @cp
              , epcdEntrypoint :: EpName
epcdEntrypoint = EpName
DefEpName
              , epcdSteps :: [EpCallingStep]
epcdSteps = []
              } Some1 EpCallingDesc
-> [Some1 EpCallingDesc] -> [Some1 EpCallingDesc]
forall a. a -> [a] -> [a]
: [Some1 EpCallingDesc]
descs

-- Derived methods and type families
----------------------------------------------------------------------------

-- | Get all entrypoints declared for parameter.
type family AllParameterEntrypoints (cp :: Kind.Type)
             :: [(Symbol, Kind.Type)] where
  AllParameterEntrypoints cp =
    EpdAllEntrypoints (GetParameterEpDerivation cp) cp

-- | Lookup for entrypoint type by name.
--
-- Does not treat default entrypoints in a special way.
type family LookupParameterEntrypoint (cp :: Kind.Type)
             :: Symbol -> Exp (Maybe Kind.Type) where
  LookupParameterEntrypoint cp =
    EpdLookupEntrypoint (GetParameterEpDerivation cp) cp

-- | Derive annotations for given parameter.
parameterEntrypointsToNotes
  :: forall cp. ParameterDeclaresEntrypoints cp
  => ParamNotes (ToT cp)
parameterEntrypointsToNotes :: ParamNotes (ToT cp)
parameterEntrypointsToNotes =
  let (notes :: Notes (ToT cp)
notes, ra :: RootAnn
ra) = ParameterDeclaresEntrypoints cp => (Notes (ToT cp), RootAnn)
forall cp.
ParameterDeclaresEntrypoints cp =>
(Notes (ToT cp), RootAnn)
pepNotes @cp
  in case Notes (ToT cp)
-> RootAnn -> Either ParamEpError (ParamNotes (ToT cp))
forall (t :: T).
Notes t -> RootAnn -> Either ParamEpError (ParamNotes t)
mkParamNotes Notes (ToT cp)
notes RootAnn
ra of
       -- Normally this should be valid because
       -- 1. Constraint in superclass of 'ParameterHasEntrypoints' ensures that
       -- no entrypoint is duplicated.
       -- 2. Each entrypoint is callable by laws of 'EntrypointsDerivation'.
       Right n :: ParamNotes (ToT cp)
n -> ParamNotes (ToT cp)
n
       Left e :: ParamEpError
e -> Text -> ParamNotes (ToT cp)
forall a. HasCallStack => Text -> a
error (Text -> ParamNotes (ToT cp)) -> Text -> ParamNotes (ToT cp)
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ "Lorentz unexpectedly compiled into contract with \
          \illegal parameter declaration.\n"
        , "Parameter: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
forall b a. (Show a, IsString b) => a -> b
show (Proxy cp -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy cp
forall k (t :: k). Proxy t
Proxy @cp)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n"
        , "Derived annotations: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Notes (ToT cp) -> Text
forall b a. (Show a, IsString b) => a -> b
show Notes (ToT cp)
notes Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n"
        , "Failure reason: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParamEpError -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ParamEpError
e
        ]

-- | Prepare call to given entrypoint.
--
-- This does not treat calls to default entrypoint in a special way.
-- To call default entrypoint properly use 'parameterEntrypointCallDefault'.
parameterEntrypointCall
  :: forall cp name.
     ParameterDeclaresEntrypoints cp
  => Label name
  -> EntrypointCall cp (GetEntrypointArg cp name)
parameterEntrypointCall :: Label name -> EntrypointCall cp (GetEntrypointArg cp name)
parameterEntrypointCall label :: Label name
label@Label name
Label =
  ((KnownValue cp,
  (KnownT (ToT cp), FailOnOperationFound (ContainsOp (ToT cp)),
   FailOnNestedBigMapsFound (ContainsNestedBigMaps (ToT cp))))
 :- (KnownT (ToT cp), HasNoOp (ToT cp),
     HasNoNestedBigMaps (ToT cp)))
-> ((KnownT (ToT cp), HasNoOp (ToT cp),
     HasNoNestedBigMaps (ToT cp)) =>
    EntrypointCallT
      (ToT cp)
      (ToT
         (Eval
            (FromMaybe
               (TypeError ...)
               (Eval
                  (EpdLookupEntrypoint
                     (If
                        (CanHaveEntrypoints cp)
                        (ParameterEntrypointsDerivation cp)
                        EpdNone)
                     cp
                     name))))))
-> EntrypointCallT
     (ToT cp)
     (ToT
        (Eval
           (FromMaybe
              (TypeError ...)
              (Eval
                 (EpdLookupEntrypoint
                    (If
                       (CanHaveEntrypoints cp)
                       (ParameterEntrypointsDerivation cp)
                       EpdNone)
                    cp
                    name)))))
forall (c :: Constraint) e r. HasDict c e => e -> (c => r) -> r
withDict ((KnownValue cp,
 (KnownT (ToT cp), FailOnOperationFound (ContainsOp (ToT cp)),
  FailOnNestedBigMapsFound (ContainsNestedBigMaps (ToT cp))))
:- (KnownT (ToT cp), HasNoOp (ToT cp), HasNoNestedBigMaps (ToT cp))
forall a. NiceParameter a :- ParameterScope (ToT a)
niceParameterEvi @cp) (((KnownT (ToT cp), HasNoOp (ToT cp),
   HasNoNestedBigMaps (ToT cp)) =>
  EntrypointCallT
    (ToT cp)
    (ToT
       (Eval
          (FromMaybe
             (TypeError ...)
             (Eval
                (EpdLookupEntrypoint
                   (If
                      (CanHaveEntrypoints cp)
                      (ParameterEntrypointsDerivation cp)
                      EpdNone)
                   cp
                   name))))))
 -> EntrypointCall cp (GetEntrypointArg cp name))
-> ((KnownT (ToT cp), HasNoOp (ToT cp),
     HasNoNestedBigMaps (ToT cp)) =>
    EntrypointCallT
      (ToT cp)
      (ToT
         (Eval
            (FromMaybe
               (TypeError ...)
               (Eval
                  (EpdLookupEntrypoint
                     (If
                        (CanHaveEntrypoints cp)
                        (ParameterEntrypointsDerivation cp)
                        EpdNone)
                     cp
                     name))))))
-> EntrypointCall cp (GetEntrypointArg cp name)
forall a b. (a -> b) -> a -> b
$
  case Label name
-> EpConstructionRes
     (ToT cp) (Eval (LookupParameterEntrypoint cp name))
forall cp (name :: Symbol).
(ParameterDeclaresEntrypoints cp, ParameterScope (ToT cp)) =>
Label name
-> EpConstructionRes
     (ToT cp) (Eval (LookupParameterEntrypoint cp name))
pepCall @cp Label name
label of
    EpConstructed liftSeq :: EpLiftSequence (ToT arg) (ToT cp)
liftSeq -> $WEntrypointCall :: forall (param :: T) (arg :: T).
ParameterScope arg =>
EpName
-> Proxy param
-> EpLiftSequence arg param
-> EntrypointCallT param arg
EntrypointCall
      { epcName :: EpName
epcName = (KnownSymbol name, HasCallStack) => EpName
forall (ctor :: Symbol). (KnownSymbol ctor, HasCallStack) => EpName
ctorNameToEp @name
      , epcParamProxy :: Proxy (ToT cp)
epcParamProxy = Proxy (ToT cp)
forall k (t :: k). Proxy t
Proxy
      , epcLiftSequence :: EpLiftSequence (ToT arg) (ToT cp)
epcLiftSequence = EpLiftSequence (ToT arg) (ToT cp)
liftSeq
      }
    EpConstructionFailed ->
      -- Not possible by 'GetEntrypointArg' constraint.
      Text
-> EntrypointCallT
     (ToT cp)
     (ToT
        (Eval
           (FromMaybe
              (TypeError ...)
              (Eval
                 (EpdLookupEntrypoint
                    (If
                       (CanHaveEntrypoints cp)
                       (ParameterEntrypointsDerivation cp)
                       EpdNone)
                    cp
                    name)))))
forall a. HasCallStack => Text -> a
error "impossible"

-- | Get type of entrypoint with given name, fail if not found.
type GetEntrypointArg cp name = Eval
  ( Fcf.LiftM2
      Fcf.FromMaybe
      (Fcf.TError ('Text "Entrypoint not found: " ':<>: 'ShowType name ':$$:
                   'Text "In contract parameter `" ':<>: 'ShowType cp ':<>: 'Text "`"))
      (LookupParameterEntrypoint cp name)
  )

type DefaultEpName = "Default"

-- | Call the default entrypoint.
parameterEntrypointCallDefault
  :: forall cp.
     (ParameterDeclaresEntrypoints cp)
  => EntrypointCall cp (GetDefaultEntrypointArg cp)
parameterEntrypointCallDefault :: EntrypointCall cp (GetDefaultEntrypointArg cp)
parameterEntrypointCallDefault =
  ((KnownValue cp,
  (KnownT (ToT cp), FailOnOperationFound (ContainsOp (ToT cp)),
   FailOnNestedBigMapsFound (ContainsNestedBigMaps (ToT cp))))
 :- (KnownT (ToT cp), HasNoOp (ToT cp),
     HasNoNestedBigMaps (ToT cp)))
-> ((KnownT (ToT cp), HasNoOp (ToT cp),
     HasNoNestedBigMaps (ToT cp)) =>
    EntrypointCallT
      (ToT cp)
      (ToT
         (Eval
            (FromMaybe
               cp
               (Eval
                  (EpdLookupEntrypoint
                     (If
                        (CanHaveEntrypoints cp)
                        (ParameterEntrypointsDerivation cp)
                        EpdNone)
                     cp
                     DefaultEpName))))))
-> EntrypointCallT
     (ToT cp)
     (ToT
        (Eval
           (FromMaybe
              cp
              (Eval
                 (EpdLookupEntrypoint
                    (If
                       (CanHaveEntrypoints cp)
                       (ParameterEntrypointsDerivation cp)
                       EpdNone)
                    cp
                    DefaultEpName)))))
forall (c :: Constraint) e r. HasDict c e => e -> (c => r) -> r
withDict ((KnownValue cp,
 (KnownT (ToT cp), FailOnOperationFound (ContainsOp (ToT cp)),
  FailOnNestedBigMapsFound (ContainsNestedBigMaps (ToT cp))))
:- (KnownT (ToT cp), HasNoOp (ToT cp), HasNoNestedBigMaps (ToT cp))
forall a. NiceParameter a :- ParameterScope (ToT a)
niceParameterEvi @cp) (((KnownT (ToT cp), HasNoOp (ToT cp),
   HasNoNestedBigMaps (ToT cp)) =>
  EntrypointCallT
    (ToT cp)
    (ToT
       (Eval
          (FromMaybe
             cp
             (Eval
                (EpdLookupEntrypoint
                   (If
                      (CanHaveEntrypoints cp)
                      (ParameterEntrypointsDerivation cp)
                      EpdNone)
                   cp
                   DefaultEpName))))))
 -> EntrypointCall cp (GetDefaultEntrypointArg cp))
-> ((KnownT (ToT cp), HasNoOp (ToT cp),
     HasNoNestedBigMaps (ToT cp)) =>
    EntrypointCallT
      (ToT cp)
      (ToT
         (Eval
            (FromMaybe
               cp
               (Eval
                  (EpdLookupEntrypoint
                     (If
                        (CanHaveEntrypoints cp)
                        (ParameterEntrypointsDerivation cp)
                        EpdNone)
                     cp
                     DefaultEpName))))))
-> EntrypointCall cp (GetDefaultEntrypointArg cp)
forall a b. (a -> b) -> a -> b
$
  case Label DefaultEpName
-> EpConstructionRes
     (ToT cp) (Eval (LookupParameterEntrypoint cp DefaultEpName))
forall cp (name :: Symbol).
(ParameterDeclaresEntrypoints cp, ParameterScope (ToT cp)) =>
Label name
-> EpConstructionRes
     (ToT cp) (Eval (LookupParameterEntrypoint cp name))
pepCall @cp (forall a. IsLabel DefaultEpName a => a
forall (x :: Symbol) a. IsLabel x a => a
fromLabel @DefaultEpName) of
    EpConstructed liftSeq :: EpLiftSequence (ToT arg) (ToT cp)
liftSeq -> $WEntrypointCall :: forall (param :: T) (arg :: T).
ParameterScope arg =>
EpName
-> Proxy param
-> EpLiftSequence arg param
-> EntrypointCallT param arg
EntrypointCall
      { epcName :: EpName
epcName = EpName
DefEpName
      , epcParamProxy :: Proxy (ToT cp)
epcParamProxy = Proxy (ToT cp)
forall k (t :: k). Proxy t
Proxy
      , epcLiftSequence :: EpLiftSequence (ToT arg) (ToT cp)
epcLiftSequence = EpLiftSequence (ToT arg) (ToT cp)
liftSeq
      }
    EpConstructionFailed ->
      $WEntrypointCall :: forall (param :: T) (arg :: T).
ParameterScope arg =>
EpName
-> Proxy param
-> EpLiftSequence arg param
-> EntrypointCallT param arg
EntrypointCall
      { epcName :: EpName
epcName = EpName
DefEpName
      , epcParamProxy :: Proxy (ToT cp)
epcParamProxy = Proxy (ToT cp)
forall k (t :: k). Proxy t
Proxy
      , epcLiftSequence :: EpLiftSequence (ToT cp) (ToT cp)
epcLiftSequence = EpLiftSequence (ToT cp) (ToT cp)
forall (arg :: T). EpLiftSequence arg arg
EplArgHere
      }

-- | Get type of entrypoint with given name, fail if not found.
type GetDefaultEntrypointArg cp = Eval
  ( Fcf.LiftM2
      Fcf.FromMaybe
      (Fcf.Pure cp)
      (LookupParameterEntrypoint cp DefaultEpName)
  )

-- | Ensure that there is no explicit "default" entrypoint.
type ForbidExplicitDefaultEntrypoint cp = Eval
  (Fcf.LiftM3
      Fcf.UnMaybe
      (Fcf.Pure (Fcf.Pure (() :: Constraint)))
      (Fcf.TError
         ('Text "Parameter used here must have no explicit \"default\" entrypoint" ':$$:
          'Text "In parameter type `" ':<>: 'ShowType cp ':<>: 'Text "`"
         )
      )
      (LookupParameterEntrypoint cp DefaultEpName)
  )

-- | Similar to 'ForbidExplicitDefaultEntrypoint', but in a version which
-- the compiler can work with (and which produces errors confusing for users :/)
type NoExplicitDefaultEntrypoint cp =
  Eval (LookupParameterEntrypoint cp DefaultEpName) ~ 'Nothing

-- | Call root entrypoint safely.
sepcCallRootChecked
  :: forall cp.
     (NiceParameter cp, ForbidExplicitDefaultEntrypoint cp)
  => SomeEntrypointCall cp
sepcCallRootChecked :: SomeEntrypointCall cp
sepcCallRootChecked = (KnownT (ToT cp), HasNoOp (ToT cp), HasNoNestedBigMaps (ToT cp)) =>
SomeEntrypointCall cp
forall (param :: T).
ParameterScope param =>
SomeEntrypointCallT param
sepcCallRootUnsafe ((KnownT (ToT cp), HasNoOp (ToT cp),
  HasNoNestedBigMaps (ToT cp)) =>
 SomeEntrypointCall cp)
-> ((KnownValue cp,
     (KnownT (ToT cp), FailOnOperationFound (ContainsOp (ToT cp)),
      FailOnNestedBigMapsFound (ContainsNestedBigMaps (ToT cp))))
    :- (KnownT (ToT cp), HasNoOp (ToT cp),
        HasNoNestedBigMaps (ToT cp)))
-> SomeEntrypointCall cp
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ (KnownValue cp,
 (KnownT (ToT cp), FailOnOperationFound (ContainsOp (ToT cp)),
  FailOnNestedBigMapsFound (ContainsNestedBigMaps (ToT cp))))
:- (KnownT (ToT cp), HasNoOp (ToT cp), HasNoNestedBigMaps (ToT cp))
forall a. NiceParameter a :- ParameterScope (ToT a)
niceParameterEvi @cp
  where
    -- Avoiding redundant-constraints warning.
    _validUsage :: Dict (ForbidExplicitDefaultEntrypoint cp)
_validUsage = ForbidExplicitDefaultEntrypoint cp =>
Dict (ForbidExplicitDefaultEntrypoint cp)
forall (a :: Constraint). a => Dict a
Dict @(ForbidExplicitDefaultEntrypoint cp)

-- | Which entrypoint to call.
--
-- We intentionally distinguish default and non-default cases because
-- this makes API more details-agnostic.
data EntrypointRef (mname :: Maybe Symbol) where
  -- | Call the default entrypoint, or root if no explicit default is assigned.
  CallDefault :: EntrypointRef 'Nothing

  -- | Call the given entrypoint; calling default is not treated specially.
  -- You have to provide entrypoint name via passing it as type argument.
  --
  -- Unfortunatelly, here we cannot accept a label because in most cases our
  -- entrypoints begin from capital letter (being derived from constructor name),
  -- while labels must start from a lower-case letter, and there is no way to
  -- make a conversion at type-level.
  Call :: NiceEntrypointName name => EntrypointRef ('Just name)

-- | Constraint on type-level entrypoint name specifier.
type NiceEntrypointName name = (KnownSymbol name, ForbidDefaultName name)

type family ForbidDefaultName (name :: Symbol) :: Constraint where
  ForbidDefaultName "Default" =
    TypeError ('Text "Calling `Default` entrypoint is not allowed here")
  ForbidDefaultName _ = ()

eprName :: forall mname. EntrypointRef mname -> EpName
eprName :: EntrypointRef mname -> EpName
eprName = \case
  CallDefault -> EpName
DefEpName
  Call | (_ :: Proxy ('Just name)) <- Proxy mname
forall k (t :: k). Proxy t
Proxy @mname ->
    FieldAnn -> Maybe EpName
epNameFromParamAnn ((KnownSymbol name, HasCallStack) => FieldAnn
forall (ctor :: Symbol).
(KnownSymbol ctor, HasCallStack) =>
FieldAnn
ctorNameToAnn @name)
    Maybe EpName -> EpName -> EpName
forall a. Maybe a -> a -> a
?: Text -> EpName
forall a. HasCallStack => Text -> a
error "Empty constructor-entrypoint name"

-- | Universal entrypoint calling.
parameterEntrypointCallCustom
  :: forall cp mname.
     (ParameterDeclaresEntrypoints cp)
  => EntrypointRef mname
  -> EntrypointCall cp (GetEntrypointArgCustom cp mname)
parameterEntrypointCallCustom :: EntrypointRef mname
-> EntrypointCall cp (GetEntrypointArgCustom cp mname)
parameterEntrypointCallCustom = \case
  CallDefault ->
    ParameterDeclaresEntrypoints cp =>
EntrypointCall cp (GetDefaultEntrypointArg cp)
forall cp.
ParameterDeclaresEntrypoints cp =>
EntrypointCall cp (GetDefaultEntrypointArg cp)
parameterEntrypointCallDefault @cp
  Call | (_ :: Proxy ('Just name)) <- Proxy mname
forall k (t :: k). Proxy t
Proxy @mname ->
    Label name -> EntrypointCall cp (GetEntrypointArg cp name)
forall cp (name :: Symbol).
ParameterDeclaresEntrypoints cp =>
Label name -> EntrypointCall cp (GetEntrypointArg cp name)
parameterEntrypointCall @cp (forall a. IsLabel name a => a
forall (x :: Symbol) a. IsLabel x a => a
fromLabel @name)

-- | Universal entrypoint lookup.
type family GetEntrypointArgCustom cp mname :: Kind.Type where
  GetEntrypointArgCustom cp 'Nothing = GetDefaultEntrypointArg cp
  GetEntrypointArgCustom cp ('Just name) = GetEntrypointArg cp name

----------------------------------------------------------------------------
-- Type class for functions that take entrypoint name as argument
----------------------------------------------------------------------------

-- | When we call a Lorentz contract we should pass entrypoint name
-- and corresponding argument. Ideally we want to statically check
-- that parameter has entrypoint with given name and
-- argument. Constraint defined by this type class holds for contract
-- with parameter @cp@ that have entrypoint matching @name@ with type
-- @arg@.
--
-- In order to check this property statically, we need to know entrypoint
-- name in compile time, 'EntrypointRef' type serves this purpose.
-- If entrypoint name is not known, one can use 'TrustEpName' wrapper
-- to take responsibility for presence of this entrypoint.
--
-- If you want to call a function which has this constraint, you have
-- two options:
-- 1. Pass contract parameter @cp@ using type application, pass 'EntrypointRef'
-- as a value and pass entrypoint argument. Type system will check that
-- @cp@ has an entrypoint with given reference and type.
-- 2. Pass 'EpName' wrapped into 'TrustEpName' and entrypoint argument.
-- In this case passing contract parameter is not necessary, you do not even
-- have to know it.
class HasEntrypointArg cp name arg where
  -- | Data returned by this method may look somewhat arbitrary.
  -- 'EpName' is obviously needed because @name@ can be
  -- 'EntrypointRef' or 'TrustEpName'.  @Dict@ is returned because in
  -- 'EntrypointRef' case we get this evidence for free and don't want
  -- to use it. We seem to always need it anyway.
  useHasEntrypointArg :: name -> (Dict (ParameterScope (ToT arg)), EpName)

-- | 'HasEntrypointArg' constraint specialized to default entrypoint.
type HasDefEntrypointArg cp defEpName defArg =
  ( defEpName ~ EntrypointRef 'Nothing
  , HasEntrypointArg cp defEpName defArg
  )

instance
  (GetEntrypointArgCustom cp mname ~ arg, ParameterDeclaresEntrypoints cp) =>
  HasEntrypointArg cp (EntrypointRef mname) arg where
  useHasEntrypointArg :: EntrypointRef mname -> (Dict (ParameterScope (ToT arg)), EpName)
useHasEntrypointArg epRef :: EntrypointRef mname
epRef =
    ((KnownValue cp,
  (KnownT (ToT cp), FailOnOperationFound (ContainsOp (ToT cp)),
   FailOnNestedBigMapsFound (ContainsNestedBigMaps (ToT cp))))
 :- (KnownT (ToT cp), HasNoOp (ToT cp),
     HasNoNestedBigMaps (ToT cp)))
-> ((KnownT (ToT cp), HasNoOp (ToT cp),
     HasNoNestedBigMaps (ToT cp)) =>
    (Dict (ParameterScope (ToT arg)), EpName))
-> (Dict (ParameterScope (ToT arg)), EpName)
forall (c :: Constraint) e r. HasDict c e => e -> (c => r) -> r
withDict ((KnownValue cp,
 (KnownT (ToT cp), FailOnOperationFound (ContainsOp (ToT cp)),
  FailOnNestedBigMapsFound (ContainsNestedBigMaps (ToT cp))))
:- (KnownT (ToT cp), HasNoOp (ToT cp), HasNoNestedBigMaps (ToT cp))
forall a. NiceParameter a :- ParameterScope (ToT a)
niceParameterEvi @cp) (((KnownT (ToT cp), HasNoOp (ToT cp),
   HasNoNestedBigMaps (ToT cp)) =>
  (Dict (ParameterScope (ToT arg)), EpName))
 -> (Dict (ParameterScope (ToT arg)), EpName))
-> ((KnownT (ToT cp), HasNoOp (ToT cp),
     HasNoNestedBigMaps (ToT cp)) =>
    (Dict (ParameterScope (ToT arg)), EpName))
-> (Dict (ParameterScope (ToT arg)), EpName)
forall a b. (a -> b) -> a -> b
$
    case EntrypointRef mname
-> EntrypointCall cp (GetEntrypointArgCustom cp mname)
forall cp (mname :: Maybe Symbol).
ParameterDeclaresEntrypoints cp =>
EntrypointRef mname
-> EntrypointCall cp (GetEntrypointArgCustom cp mname)
parameterEntrypointCallCustom @cp EntrypointRef mname
epRef of
      EntrypointCall{} -> (Dict (ParameterScope (ToT arg))
forall (a :: Constraint). a => Dict a
Dict, EntrypointRef mname -> EpName
forall (mname :: Maybe Symbol). EntrypointRef mname -> EpName
eprName EntrypointRef mname
epRef)

-- | This wrapper allows to pass untyped 'EpName' and bypass checking
-- that entrypoint with given name and type exists.
newtype TrustEpName = TrustEpName EpName

instance (NiceParameter arg) =>
  HasEntrypointArg cp TrustEpName arg where
  useHasEntrypointArg :: TrustEpName -> (Dict (ParameterScope (ToT arg)), EpName)
useHasEntrypointArg (TrustEpName epName :: EpName
epName) = (Dict (ParameterScope (ToT arg))
forall (a :: Constraint). a => Dict a
Dict, EpName
epName) (ParameterScope (ToT arg) =>
 (Dict (ParameterScope (ToT arg)), EpName))
-> (NiceParameter arg :- ParameterScope (ToT arg))
-> (Dict (ParameterScope (ToT arg)), EpName)
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ NiceParameter arg :- ParameterScope (ToT arg)
forall a. NiceParameter a :- ParameterScope (ToT a)
niceParameterEvi @arg

-- | Checks that the given parameter consists of some specific entrypoint. Similar as
-- `HasEntrypointArg` but ensures that the argument matches the following datatype.
type HasEntrypointOfType param con exp
  = (GetEntrypointArgCustom param ('Just con) ~ exp, ParameterDeclaresEntrypoints param)

-- | A helper datatype which prettifies interface for `ParameterContainsEntrypoints`.
data NamedEp = NamedEp Symbol Kind.Type
type n :> ty = 'NamedEp n ty
infixr 0 :>

-- | Check that the given entrypoint has some fields inside.
-- This interface allows for an abstraction of contract parameter so
-- that it requires some *minimal* specification, but not a concrete one.
type family
    ParameterContainsEntrypoints param (fields :: [NamedEp]) :: Constraint
  where
  ParameterContainsEntrypoints _ '[] = ()
  ParameterContainsEntrypoints param ((n :> ty) ': rest) =
    (HasEntrypointOfType param n ty, ParameterContainsEntrypoints param rest)

----------------------------------------------------------------------------
-- Trivial implementation
----------------------------------------------------------------------------

-- | No entrypoints declared, parameter type will serve as argument type
-- of the only existing entrypoint (default one).
data EpdNone
instance (HasAnnotation cp) => EntrypointsDerivation EpdNone cp where
  type EpdAllEntrypoints EpdNone cp = '[]
  type EpdLookupEntrypoint EpdNone cp = Fcf.ConstFn 'Nothing
  epdNotes :: (Notes (ToT cp), RootAnn)
epdNotes = (FollowEntrypointFlag -> Notes (ToT cp)
forall a. HasAnnotation a => FollowEntrypointFlag -> Notes (ToT a)
getAnnotation @cp FollowEntrypointFlag
FollowEntrypoint, RootAnn
forall k (a :: k). Annotation a
U.noAnn)
  epdCall :: Label name
-> EpConstructionRes
     (ToT cp) (Eval (EpdLookupEntrypoint EpdNone cp name))
epdCall _ = EpConstructionRes
  (ToT cp) (Eval (EpdLookupEntrypoint EpdNone cp name))
forall (param :: T). EpConstructionRes param 'Nothing
EpConstructionFailed
  epdDescs :: Rec EpCallingDesc (EpdAllEntrypoints EpdNone cp)
epdDescs = Rec EpCallingDesc (EpdAllEntrypoints EpdNone cp)
forall u (a :: u -> *). Rec a '[]
RNil