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

-- | Utilities for lightweight entrypoints support.
module Michelson.Typed.Entrypoints
  ( EpAddress (..)
  , ParseEpAddressError (..)
  , formatEpAddress
  , mformatEpAddress
  , parseEpAddress
  , unsafeParseEpAddress
  , parseEpAddressRaw
  , unsafeParseEpAddressRaw
  , ParamNotes (..)
  , pattern ParamNotes
  , starParamNotes
  , ArmCoord (..)
  , ArmCoords
  , ParamEpError (..)
  , mkParamNotes

  , EpLiftSequence (..)
  , EntrypointCallT (..)
  , epcPrimitive
  , unsafeEpcCallRoot
  , SomeEntrypointCallT (..)
  , unsafeSepcCallRoot
  , sepcPrimitive
  , sepcName
  , ForbidOr
  , MkEntrypointCallRes (..)
  , mkEntrypointCall

  , tyImplicitAccountParam

    -- * Re-exports
  , EpName (..)
  , pattern DefEpName
  , epNameFromParamAnn
  , epNameToParamAnn
  , epNameFromRefAnn
  , epNameToRefAnn
  , EpNameFromRefAnnError (..)
  ) where

import Control.Monad.Except (throwError)
import qualified Data.ByteString as BS
import Data.Constraint (Dict(..))
import Data.Singletons (withSingI)
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import Fmt (Buildable(..), hexF, pretty, (+|), (|+))
import Text.PrettyPrint.Leijen.Text ((<+>), int, squotes, punctuate, textStrict)

import Michelson.Text
import Michelson.Typed.Annotation
import Michelson.Typed.Scope
import Michelson.Typed.Sing
import Michelson.Typed.T
import Michelson.Printer.Util (RenderDoc(..), renderAnyBuildable, buildRenderDoc)
import Michelson.Untyped.Annotation
import Michelson.Untyped.Entrypoints
import Tezos.Address
import Tezos.Crypto (keyHashLengthBytes)
import Util.TH
import Util.Typeable
import Util.TypeLits

----------------------------------------------------------------------------
-- Primitives
----------------------------------------------------------------------------
--
-- EpAddress
----------------------------------------------------------------------------

-- | Address with optional entrypoint name attached to it.
-- TODO: come up with better name?
data EpAddress = EpAddress
  { EpAddress -> Address
eaAddress :: Address
    -- ^ Address itself
  , EpAddress -> EpName
eaEntrypoint :: EpName
    -- ^ Entrypoint name (might be empty)
  } deriving stock (Int -> EpAddress -> ShowS
[EpAddress] -> ShowS
EpAddress -> String
(Int -> EpAddress -> ShowS)
-> (EpAddress -> String)
-> ([EpAddress] -> ShowS)
-> Show EpAddress
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EpAddress] -> ShowS
$cshowList :: [EpAddress] -> ShowS
show :: EpAddress -> String
$cshow :: EpAddress -> String
showsPrec :: Int -> EpAddress -> ShowS
$cshowsPrec :: Int -> EpAddress -> ShowS
Show, EpAddress -> EpAddress -> Bool
(EpAddress -> EpAddress -> Bool)
-> (EpAddress -> EpAddress -> Bool) -> Eq EpAddress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EpAddress -> EpAddress -> Bool
$c/= :: EpAddress -> EpAddress -> Bool
== :: EpAddress -> EpAddress -> Bool
$c== :: EpAddress -> EpAddress -> Bool
Eq, Eq EpAddress
Eq EpAddress
-> (EpAddress -> EpAddress -> Ordering)
-> (EpAddress -> EpAddress -> Bool)
-> (EpAddress -> EpAddress -> Bool)
-> (EpAddress -> EpAddress -> Bool)
-> (EpAddress -> EpAddress -> Bool)
-> (EpAddress -> EpAddress -> EpAddress)
-> (EpAddress -> EpAddress -> EpAddress)
-> Ord EpAddress
EpAddress -> EpAddress -> Bool
EpAddress -> EpAddress -> Ordering
EpAddress -> EpAddress -> EpAddress
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EpAddress -> EpAddress -> EpAddress
$cmin :: EpAddress -> EpAddress -> EpAddress
max :: EpAddress -> EpAddress -> EpAddress
$cmax :: EpAddress -> EpAddress -> EpAddress
>= :: EpAddress -> EpAddress -> Bool
$c>= :: EpAddress -> EpAddress -> Bool
> :: EpAddress -> EpAddress -> Bool
$c> :: EpAddress -> EpAddress -> Bool
<= :: EpAddress -> EpAddress -> Bool
$c<= :: EpAddress -> EpAddress -> Bool
< :: EpAddress -> EpAddress -> Bool
$c< :: EpAddress -> EpAddress -> Bool
compare :: EpAddress -> EpAddress -> Ordering
$ccompare :: EpAddress -> EpAddress -> Ordering
$cp1Ord :: Eq EpAddress
Ord, (forall x. EpAddress -> Rep EpAddress x)
-> (forall x. Rep EpAddress x -> EpAddress) -> Generic EpAddress
forall x. Rep EpAddress x -> EpAddress
forall x. EpAddress -> Rep EpAddress x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EpAddress x -> EpAddress
$cfrom :: forall x. EpAddress -> Rep EpAddress x
Generic)

instance Buildable EpAddress where
  build :: EpAddress -> Builder
build = Text -> Builder
forall p. Buildable p => p -> Builder
build (Text -> Builder) -> (EpAddress -> Text) -> EpAddress -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpAddress -> Text
formatEpAddress

instance NFData EpAddress

formatEpAddress :: EpAddress -> Text
formatEpAddress :: EpAddress -> Text
formatEpAddress (EpAddress Address
addr EpName
ep)
  | EpName -> Bool
isDefEpName EpName
ep = Address -> Text
formatAddress Address
addr
  | Bool
otherwise = Address -> Text
formatAddress Address
addr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"%" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EpName -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty EpName
ep

mformatEpAddress :: EpAddress -> MText
mformatEpAddress :: EpAddress -> MText
mformatEpAddress EpAddress
ea =
  let t :: Text
t = EpAddress -> Text
formatEpAddress EpAddress
ea
     -- Should be safe because set of characters allowed in annotations
     -- (and thus in 'EpName') is subset of characters allowed in Michelson strings.
  in HasCallStack => Text -> MText
Text -> MText
unsafeMkMText Text
t

data ParseEpAddressError
  = ParseEpAddressBadAddress ParseAddressError
  | ParseEpAddressRawBadAddress ParseAddressRawError
  | ParseEpAddressBadEntryopint ByteString UnicodeException
  | ParseEpAddressBadRefAnn Text
  | ParseEpAddressRefAnnError EpNameFromRefAnnError
  | ParseEpAddressInvalidLength Int
  deriving stock (Int -> ParseEpAddressError -> ShowS
[ParseEpAddressError] -> ShowS
ParseEpAddressError -> String
(Int -> ParseEpAddressError -> ShowS)
-> (ParseEpAddressError -> String)
-> ([ParseEpAddressError] -> ShowS)
-> Show ParseEpAddressError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseEpAddressError] -> ShowS
$cshowList :: [ParseEpAddressError] -> ShowS
show :: ParseEpAddressError -> String
$cshow :: ParseEpAddressError -> String
showsPrec :: Int -> ParseEpAddressError -> ShowS
$cshowsPrec :: Int -> ParseEpAddressError -> ShowS
Show, ParseEpAddressError -> ParseEpAddressError -> Bool
(ParseEpAddressError -> ParseEpAddressError -> Bool)
-> (ParseEpAddressError -> ParseEpAddressError -> Bool)
-> Eq ParseEpAddressError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseEpAddressError -> ParseEpAddressError -> Bool
$c/= :: ParseEpAddressError -> ParseEpAddressError -> Bool
== :: ParseEpAddressError -> ParseEpAddressError -> Bool
$c== :: ParseEpAddressError -> ParseEpAddressError -> Bool
Eq, (forall x. ParseEpAddressError -> Rep ParseEpAddressError x)
-> (forall x. Rep ParseEpAddressError x -> ParseEpAddressError)
-> Generic ParseEpAddressError
forall x. Rep ParseEpAddressError x -> ParseEpAddressError
forall x. ParseEpAddressError -> Rep ParseEpAddressError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ParseEpAddressError x -> ParseEpAddressError
$cfrom :: forall x. ParseEpAddressError -> Rep ParseEpAddressError x
Generic)

instance NFData ParseEpAddressError

instance Buildable ParseEpAddressError where
  build :: ParseEpAddressError -> Builder
build = ParseEpAddressError -> Builder
forall a. RenderDoc a => a -> Builder
buildRenderDoc

instance RenderDoc ParseEpAddressError where
  renderDoc :: RenderContext -> ParseEpAddressError -> Doc
renderDoc RenderContext
context = \case
    ParseEpAddressBadAddress ParseAddressError
err -> RenderContext -> ParseAddressError -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
context ParseAddressError
err
    ParseEpAddressRawBadAddress ParseAddressRawError
err -> RenderContext -> ParseAddressRawError -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
context ParseAddressRawError
err
    ParseEpAddressBadEntryopint ByteString
addr UnicodeException
exception ->
      Doc
"Invalid entrypoint given for raw adddress" Doc -> Doc -> Doc
<+> (Builder -> Doc
forall a. Buildable a => a -> Doc
renderAnyBuildable (Builder -> Doc) -> Builder -> Doc
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
forall a. FormatAsHex a => a -> Builder
hexF ByteString
addr)Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
      Doc
" and failed with" Doc -> Doc -> Doc
<+> (Text -> Doc
textStrict (UnicodeException -> Text
forall b a. (Show a, IsString b) => a -> b
show @Text UnicodeException
exception))
    ParseEpAddressBadRefAnn Text
txt -> Doc
"Invalid reference annotation:" Doc -> Doc -> Doc
<+> (Text -> Doc
textStrict Text
txt)
    ParseEpAddressRefAnnError EpNameFromRefAnnError
err -> RenderContext -> EpNameFromRefAnnError -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
context EpNameFromRefAnnError
err
    ParseEpAddressInvalidLength Int
len ->
      Doc
"Given raw entrypoint address has invalid length:" Doc -> Doc -> Doc
<+> Int -> Doc
int Int
len

-- | Parse an address which can be suffixed with entrypoint name
-- (e.g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU%entrypoint").
parseEpAddress :: Text -> Either ParseEpAddressError EpAddress
parseEpAddress :: Text -> Either ParseEpAddressError EpAddress
parseEpAddress Text
txt =
  let (Text
addrTxt, Text
mannotTxt) = Text -> Text -> (Text, Text)
T.breakOn Text
"%" Text
txt
  in case Text
mannotTxt of
    Text
"" -> do
      Address
addr <- (ParseAddressError -> ParseEpAddressError)
-> Either ParseAddressError Address
-> Either ParseEpAddressError Address
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseAddressError -> ParseEpAddressError
ParseEpAddressBadAddress (Either ParseAddressError Address
 -> Either ParseEpAddressError Address)
-> Either ParseAddressError Address
-> Either ParseEpAddressError Address
forall a b. (a -> b) -> a -> b
$ Text -> Either ParseAddressError Address
parseAddress Text
addrTxt
      return $ Address -> EpName -> EpAddress
EpAddress Address
addr EpName
DefEpName
    Text
annotTxt' -> do
      Address
addr <- (ParseAddressError -> ParseEpAddressError)
-> Either ParseAddressError Address
-> Either ParseEpAddressError Address
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseAddressError -> ParseEpAddressError
ParseEpAddressBadAddress (Either ParseAddressError Address
 -> Either ParseEpAddressError Address)
-> Either ParseAddressError Address
-> Either ParseEpAddressError Address
forall a b. (a -> b) -> a -> b
$ Text -> Either ParseAddressError Address
parseAddress Text
addrTxt
      Annotation FieldTag
annot <- (Text -> ParseEpAddressError)
-> Either Text (Annotation FieldTag)
-> Either ParseEpAddressError (Annotation FieldTag)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> ParseEpAddressError
ParseEpAddressBadRefAnn (Either Text (Annotation FieldTag)
 -> Either ParseEpAddressError (Annotation FieldTag))
-> Either Text (Annotation FieldTag)
-> Either ParseEpAddressError (Annotation FieldTag)
forall a b. (a -> b) -> a -> b
$ case Text -> Text -> Maybe Text
T.stripPrefix Text
"%" Text
annotTxt' of
        Maybe Text
Nothing -> Text -> Either Text (Annotation FieldTag)
forall a. HasCallStack => Text -> a
error Text
"impossible"
        Just Text
a -> Text -> Either Text (Annotation FieldTag)
forall k (a :: k). Text -> Either Text (Annotation a)
mkAnnotation Text
a
      EpName
epName <- (EpNameFromRefAnnError -> ParseEpAddressError)
-> Either EpNameFromRefAnnError EpName
-> Either ParseEpAddressError EpName
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first EpNameFromRefAnnError -> ParseEpAddressError
ParseEpAddressRefAnnError (Either EpNameFromRefAnnError EpName
 -> Either ParseEpAddressError EpName)
-> Either EpNameFromRefAnnError EpName
-> Either ParseEpAddressError EpName
forall a b. (a -> b) -> a -> b
$ Annotation FieldTag -> Either EpNameFromRefAnnError EpName
epNameFromRefAnn Annotation FieldTag
annot
      return $ Address -> EpName -> EpAddress
EpAddress Address
addr EpName
epName

unsafeParseEpAddress :: HasCallStack => Text -> EpAddress
unsafeParseEpAddress :: Text -> EpAddress
unsafeParseEpAddress = (ParseEpAddressError -> EpAddress)
-> (EpAddress -> EpAddress)
-> Either ParseEpAddressError EpAddress
-> EpAddress
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> EpAddress
forall a. HasCallStack => Text -> a
error (Text -> EpAddress)
-> (ParseEpAddressError -> Text)
-> ParseEpAddressError
-> EpAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseEpAddressError -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty) EpAddress -> EpAddress
forall a. a -> a
id (Either ParseEpAddressError EpAddress -> EpAddress)
-> (Text -> Either ParseEpAddressError EpAddress)
-> Text
-> EpAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either ParseEpAddressError EpAddress
parseEpAddress

-- | Parses byte representation of entrypoint address.
--
-- For every address
--
-- @
-- KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh%foo%bar
-- @
--
-- we get the following byte representation
--
-- @
-- 01afab866e7f1e74f9bba388d66b246276ce50bf4700666f6f25626172
-- \________________________________________/\/\____/\/\____/
--               address                     %   ep1  % ep2
-- @
--
parseEpAddressRaw :: ByteString -> Either ParseEpAddressError EpAddress
parseEpAddressRaw :: ByteString -> Either ParseEpAddressError EpAddress
parseEpAddressRaw ByteString
raw = do
  let (ByteString
bytes, ByteString
eps) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (Int
forall n. Integral n => n
keyHashLengthBytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) ByteString
raw
  Address
eaAddress <- (ParseAddressRawError -> ParseEpAddressError)
-> Either ParseAddressRawError Address
-> Either ParseEpAddressError Address
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseAddressRawError -> ParseEpAddressError
ParseEpAddressRawBadAddress (Either ParseAddressRawError Address
 -> Either ParseEpAddressError Address)
-> Either ParseAddressRawError Address
-> Either ParseEpAddressError Address
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ParseAddressRawError Address
parseAddressRaw ByteString
bytes
  Text
decodedEntrypoint <- (UnicodeException -> ParseEpAddressError)
-> Either UnicodeException Text -> Either ParseEpAddressError Text
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ByteString -> UnicodeException -> ParseEpAddressError
ParseEpAddressBadEntryopint ByteString
raw) (Either UnicodeException Text -> Either ParseEpAddressError Text)
-> Either UnicodeException Text -> Either ParseEpAddressError Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
eps
  Annotation FieldTag
decodedAnnotation <- (Text -> ParseEpAddressError)
-> Either Text (Annotation FieldTag)
-> Either ParseEpAddressError (Annotation FieldTag)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> ParseEpAddressError
ParseEpAddressBadRefAnn (Either Text (Annotation FieldTag)
 -> Either ParseEpAddressError (Annotation FieldTag))
-> Either Text (Annotation FieldTag)
-> Either ParseEpAddressError (Annotation FieldTag)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Annotation FieldTag)
forall k (a :: k). Text -> Either Text (Annotation a)
mkAnnotation Text
decodedEntrypoint
  EpName
eaEntrypoint <- (EpNameFromRefAnnError -> ParseEpAddressError)
-> Either EpNameFromRefAnnError EpName
-> Either ParseEpAddressError EpName
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first EpNameFromRefAnnError -> ParseEpAddressError
ParseEpAddressRefAnnError (Either EpNameFromRefAnnError EpName
 -> Either ParseEpAddressError EpName)
-> Either EpNameFromRefAnnError EpName
-> Either ParseEpAddressError EpName
forall a b. (a -> b) -> a -> b
$ Annotation FieldTag -> Either EpNameFromRefAnnError EpName
epNameFromRefAnn Annotation FieldTag
decodedAnnotation
  pure $ EpAddress :: Address -> EpName -> EpAddress
EpAddress {EpName
Address
eaEntrypoint :: EpName
eaAddress :: Address
eaEntrypoint :: EpName
eaAddress :: Address
..}

unsafeParseEpAddressRaw :: ByteString -> EpAddress
unsafeParseEpAddressRaw :: ByteString -> EpAddress
unsafeParseEpAddressRaw = (ParseEpAddressError -> EpAddress)
-> (EpAddress -> EpAddress)
-> Either ParseEpAddressError EpAddress
-> EpAddress
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> EpAddress
forall a. HasCallStack => Text -> a
error (Text -> EpAddress)
-> (ParseEpAddressError -> Text)
-> ParseEpAddressError
-> EpAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseEpAddressError -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty) EpAddress -> EpAddress
forall a. a -> a
id (Either ParseEpAddressError EpAddress -> EpAddress)
-> (ByteString -> Either ParseEpAddressError EpAddress)
-> ByteString
-> EpAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ParseEpAddressError EpAddress
parseEpAddressRaw

-- ParamNotes
----------------------------------------------------------------------------

-- | Annotations for contract parameter declaration.
--
-- Following the Michelson specification, this type has the following invariants:
-- 1. No entrypoint name is duplicated.
-- 2. If @default@ entrypoint is explicitly assigned, no "arm" remains uncallable.
data ParamNotes (t :: T) = UnsafeParamNotes
  { ParamNotes t -> Notes t
pnNotes   :: Notes t
  , ParamNotes t -> Annotation FieldTag
pnRootAnn :: RootAnn
  } deriving stock (Int -> ParamNotes t -> ShowS
[ParamNotes t] -> ShowS
ParamNotes t -> String
(Int -> ParamNotes t -> ShowS)
-> (ParamNotes t -> String)
-> ([ParamNotes t] -> ShowS)
-> Show (ParamNotes t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (t :: T). Int -> ParamNotes t -> ShowS
forall (t :: T). [ParamNotes t] -> ShowS
forall (t :: T). ParamNotes t -> String
showList :: [ParamNotes t] -> ShowS
$cshowList :: forall (t :: T). [ParamNotes t] -> ShowS
show :: ParamNotes t -> String
$cshow :: forall (t :: T). ParamNotes t -> String
showsPrec :: Int -> ParamNotes t -> ShowS
$cshowsPrec :: forall (t :: T). Int -> ParamNotes t -> ShowS
Show, ParamNotes t -> ParamNotes t -> Bool
(ParamNotes t -> ParamNotes t -> Bool)
-> (ParamNotes t -> ParamNotes t -> Bool) -> Eq (ParamNotes t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (t :: T). ParamNotes t -> ParamNotes t -> Bool
/= :: ParamNotes t -> ParamNotes t -> Bool
$c/= :: forall (t :: T). ParamNotes t -> ParamNotes t -> Bool
== :: ParamNotes t -> ParamNotes t -> Bool
$c== :: forall (t :: T). ParamNotes t -> ParamNotes t -> Bool
Eq, (forall x. ParamNotes t -> Rep (ParamNotes t) x)
-> (forall x. Rep (ParamNotes t) x -> ParamNotes t)
-> Generic (ParamNotes t)
forall x. Rep (ParamNotes t) x -> ParamNotes t
forall x. ParamNotes t -> Rep (ParamNotes t) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (t :: T) x. Rep (ParamNotes t) x -> ParamNotes t
forall (t :: T) x. ParamNotes t -> Rep (ParamNotes t) x
$cto :: forall (t :: T) x. Rep (ParamNotes t) x -> ParamNotes t
$cfrom :: forall (t :: T) x. ParamNotes t -> Rep (ParamNotes t) x
Generic)
    deriving anyclass (ParamNotes t -> ()
(ParamNotes t -> ()) -> NFData (ParamNotes t)
forall a. (a -> ()) -> NFData a
forall (t :: T). ParamNotes t -> ()
rnf :: ParamNotes t -> ()
$crnf :: forall (t :: T). ParamNotes t -> ()
NFData)

pattern ParamNotes :: Notes t -> RootAnn -> ParamNotes t
pattern $mParamNotes :: forall r (t :: T).
ParamNotes t
-> (Notes t -> Annotation FieldTag -> r) -> (Void# -> r) -> r
ParamNotes t f <- UnsafeParamNotes t f
{-# COMPLETE ParamNotes #-}

-- | Parameter without annotations.
starParamNotes :: SingI t => ParamNotes t
starParamNotes :: ParamNotes t
starParamNotes = Notes t -> Annotation FieldTag -> ParamNotes t
forall (t :: T). Notes t -> Annotation FieldTag -> ParamNotes t
UnsafeParamNotes Notes t
forall (t :: T). SingI t => Notes t
starNotes Annotation FieldTag
forall k (a :: k). Annotation a
noAnn

-- | Coordinates of "arm" in Or tree, used solely in error messages.
type ArmCoords = [ArmCoord]
data ArmCoord = AcLeft | AcRight
  deriving stock (Int -> ArmCoord -> ShowS
[ArmCoord] -> ShowS
ArmCoord -> String
(Int -> ArmCoord -> ShowS)
-> (ArmCoord -> String) -> ([ArmCoord] -> ShowS) -> Show ArmCoord
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArmCoord] -> ShowS
$cshowList :: [ArmCoord] -> ShowS
show :: ArmCoord -> String
$cshow :: ArmCoord -> String
showsPrec :: Int -> ArmCoord -> ShowS
$cshowsPrec :: Int -> ArmCoord -> ShowS
Show, ArmCoord -> ArmCoord -> Bool
(ArmCoord -> ArmCoord -> Bool)
-> (ArmCoord -> ArmCoord -> Bool) -> Eq ArmCoord
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArmCoord -> ArmCoord -> Bool
$c/= :: ArmCoord -> ArmCoord -> Bool
== :: ArmCoord -> ArmCoord -> Bool
$c== :: ArmCoord -> ArmCoord -> Bool
Eq, (forall x. ArmCoord -> Rep ArmCoord x)
-> (forall x. Rep ArmCoord x -> ArmCoord) -> Generic ArmCoord
forall x. Rep ArmCoord x -> ArmCoord
forall x. ArmCoord -> Rep ArmCoord x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ArmCoord x -> ArmCoord
$cfrom :: forall x. ArmCoord -> Rep ArmCoord x
Generic)

instance NFData ArmCoord

instance Buildable ArmCoord where
  build :: ArmCoord -> Builder
build = ArmCoord -> Builder
forall a. RenderDoc a => a -> Builder
buildRenderDoc

instance RenderDoc ArmCoord where
  renderDoc :: RenderContext -> ArmCoord -> Doc
renderDoc RenderContext
_ = \case
    ArmCoord
AcLeft -> Doc
"left"
    ArmCoord
AcRight -> Doc
"right"


-- | Errors specific to parameter type declaration (entrypoints).
data ParamEpError
  = ParamEpDuplicatedNames (NonEmpty EpName)
  | ParamEpUncallableArm ArmCoords
  deriving stock (Int -> ParamEpError -> ShowS
[ParamEpError] -> ShowS
ParamEpError -> String
(Int -> ParamEpError -> ShowS)
-> (ParamEpError -> String)
-> ([ParamEpError] -> ShowS)
-> Show ParamEpError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParamEpError] -> ShowS
$cshowList :: [ParamEpError] -> ShowS
show :: ParamEpError -> String
$cshow :: ParamEpError -> String
showsPrec :: Int -> ParamEpError -> ShowS
$cshowsPrec :: Int -> ParamEpError -> ShowS
Show, ParamEpError -> ParamEpError -> Bool
(ParamEpError -> ParamEpError -> Bool)
-> (ParamEpError -> ParamEpError -> Bool) -> Eq ParamEpError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParamEpError -> ParamEpError -> Bool
$c/= :: ParamEpError -> ParamEpError -> Bool
== :: ParamEpError -> ParamEpError -> Bool
$c== :: ParamEpError -> ParamEpError -> Bool
Eq, (forall x. ParamEpError -> Rep ParamEpError x)
-> (forall x. Rep ParamEpError x -> ParamEpError)
-> Generic ParamEpError
forall x. Rep ParamEpError x -> ParamEpError
forall x. ParamEpError -> Rep ParamEpError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ParamEpError x -> ParamEpError
$cfrom :: forall x. ParamEpError -> Rep ParamEpError x
Generic)

instance NFData ParamEpError

instance Buildable ParamEpError where
  build :: ParamEpError -> Builder
build = ParamEpError -> Builder
forall a. RenderDoc a => a -> Builder
buildRenderDoc

instance RenderDoc ParamEpError where
  renderDoc :: RenderContext -> ParamEpError -> Doc
renderDoc RenderContext
context = \case
    ParamEpDuplicatedNames NonEmpty EpName
names -> [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat
      [ Doc
"Duplicated entrypoint names: "
      , [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
", " ([Doc] -> [Doc]) -> ([EpName] -> [Doc]) -> [EpName] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EpName -> Doc) -> [EpName] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Doc -> Doc
squotes (Doc -> Doc) -> (EpName -> Doc) -> EpName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpName -> Doc
forall a. Buildable a => a -> Doc
renderAnyBuildable) ([EpName] -> [Doc]) -> [EpName] -> [Doc]
forall a b. (a -> b) -> a -> b
$ NonEmpty EpName -> [Element (NonEmpty EpName)]
forall t. Container t => t -> [Element t]
toList NonEmpty EpName
names
      ]
    ParamEpUncallableArm [ArmCoord]
arm -> [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat
      [ Doc
"Due to presence of 'default' entrypoint, one of contract \"arms\" \
        \cannot be called: \""
      , [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse Doc
" - " ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (ArmCoord -> Doc) -> [ArmCoord] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (RenderContext -> ArmCoord -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
context) [ArmCoord]
arm
      , Doc
"\""
      , if [ArmCoord] -> Int
forall t. Container t => t -> Int
length [ArmCoord]
arm Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then Doc
" (in top-to-bottom order)" else Doc
""
      ]

-- | Check whether given notes are valid parameter notes.
verifyParamNotes :: Notes t -> RootAnn -> Either ParamEpError ()
verifyParamNotes :: Notes t -> Annotation FieldTag -> Either ParamEpError ()
verifyParamNotes Notes t
notes Annotation FieldTag
ra = do
  let allEps :: [EpName]
allEps = Endo [EpName] -> [EpName] -> [EpName]
forall a. Endo a -> a -> a
appEndo (Notes t -> Endo [EpName]
forall (t :: T). Notes t -> Endo [EpName]
gatherEntrypoints Notes t
notes) []
      duplicatedEps :: [EpName]
duplicatedEps
        = (NonEmpty EpName -> Maybe EpName) -> [NonEmpty EpName] -> [EpName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([EpName] -> Maybe EpName
forall t. Container t => t -> Maybe (Element t)
safeHead ([EpName] -> Maybe EpName)
-> (NonEmpty EpName -> [EpName]) -> NonEmpty EpName -> Maybe EpName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty EpName -> [EpName]
forall a. NonEmpty a -> [a]
tail)
        ([NonEmpty EpName] -> [EpName])
-> ([EpName] -> [NonEmpty EpName]) -> [EpName] -> [EpName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EpName] -> [NonEmpty EpName]
forall (f :: * -> *) a. (Foldable f, Eq a) => f a -> [NonEmpty a]
NE.group
        ([EpName] -> [NonEmpty EpName])
-> ([EpName] -> [EpName]) -> [EpName] -> [NonEmpty EpName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EpName] -> [EpName]
forall a. Ord a => [a] -> [a]
sort
        ([EpName] -> [EpName]) -> [EpName] -> [EpName]
forall a b. (a -> b) -> a -> b
$ [EpName] -> (EpName -> [EpName]) -> Maybe EpName -> [EpName]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [EpName]
allEps (EpName -> [EpName] -> [EpName]
forall a. a -> [a] -> [a]
: [EpName]
allEps) (Annotation FieldTag -> Maybe EpName
epNameFromParamAnn Annotation FieldTag
ra)

  Maybe (NonEmpty EpName)
-> (NonEmpty EpName -> Either ParamEpError ())
-> Either ParamEpError ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust ([EpName] -> Maybe (NonEmpty EpName)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [EpName]
duplicatedEps) ((NonEmpty EpName -> Either ParamEpError ())
 -> Either ParamEpError ())
-> (NonEmpty EpName -> Either ParamEpError ())
-> Either ParamEpError ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty EpName
dups ->
    ParamEpError -> Either ParamEpError ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParamEpError -> Either ParamEpError ())
-> ParamEpError -> Either ParamEpError ()
forall a b. (a -> b) -> a -> b
$ NonEmpty EpName -> ParamEpError
ParamEpDuplicatedNames NonEmpty EpName
dups

  -- In case contract have explicit root entrypoint, we assume that everything is
  -- callable.
  Bool -> Either ParamEpError () -> Either ParamEpError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Annotation FieldTag
ra Annotation FieldTag -> Annotation FieldTag -> Bool
forall a. Eq a => a -> a -> Bool
== Annotation FieldTag
forall k (a :: k). Annotation a
noAnn) (Either ParamEpError () -> Either ParamEpError ())
-> Either ParamEpError () -> Either ParamEpError ()
forall a b. (a -> b) -> a -> b
$ Either ParamEpError Bool -> Either ParamEpError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
    (Either ParamEpError Bool -> Either ParamEpError ())
-> Either ParamEpError Bool -> Either ParamEpError ()
forall a b. (a -> b) -> a -> b
$ ([ArmCoord] -> ParamEpError)
-> Either [ArmCoord] Bool -> Either ParamEpError Bool
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [ArmCoord] -> ParamEpError
ParamEpUncallableArm
    (Either [ArmCoord] Bool -> Either ParamEpError Bool)
-> Either [ArmCoord] Bool -> Either ParamEpError Bool
forall a b. (a -> b) -> a -> b
$ Notes t -> Either [ArmCoord] Bool
forall (t :: T). Notes t -> Either [ArmCoord] Bool
ensureAllCallable Notes t
notes
  where
    gatherEntrypoints :: Notes t -> Endo [EpName]
    gatherEntrypoints :: Notes t -> Endo [EpName]
gatherEntrypoints = \case
      NTOr TypeAnn
_ Annotation FieldTag
fn1 Annotation FieldTag
fn2 Notes p
l Notes q
r -> [Endo [EpName]] -> Endo [EpName]
forall a. Monoid a => [a] -> a
mconcat
        [ ([EpName] -> [EpName]) -> Endo [EpName]
forall a. (a -> a) -> Endo a
Endo (([EpName] -> [EpName]) -> Endo [EpName])
-> ([EpName] -> [EpName]) -> Endo [EpName]
forall a b. (a -> b) -> a -> b
$ ([EpName] -> [EpName])
-> (EpName -> [EpName] -> [EpName])
-> Maybe EpName
-> [EpName]
-> [EpName]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [EpName] -> [EpName]
forall a. a -> a
id (:) (Annotation FieldTag -> Maybe EpName
epNameFromParamAnn Annotation FieldTag
fn1)
        , ([EpName] -> [EpName]) -> Endo [EpName]
forall a. (a -> a) -> Endo a
Endo (([EpName] -> [EpName]) -> Endo [EpName])
-> ([EpName] -> [EpName]) -> Endo [EpName]
forall a b. (a -> b) -> a -> b
$ ([EpName] -> [EpName])
-> (EpName -> [EpName] -> [EpName])
-> Maybe EpName
-> [EpName]
-> [EpName]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [EpName] -> [EpName]
forall a. a -> a
id (:) (Annotation FieldTag -> Maybe EpName
epNameFromParamAnn Annotation FieldTag
fn2)
        , Notes p -> Endo [EpName]
forall (t :: T). Notes t -> Endo [EpName]
gatherEntrypoints Notes p
l
        , Notes q -> Endo [EpName]
forall (t :: T). Notes t -> Endo [EpName]
gatherEntrypoints Notes q
r
        ]
      Notes t
_ -> Endo [EpName]
forall a. Monoid a => a
mempty

    -- Here we can assume that there is no more than one @default@ entrypoint,
    -- because duplications check occurs earlier.
    --
    -- In case when multiple entrypoints are uncallable, the reference
    -- implementation prefers displaying (in error message) arms which are
    -- closer to the root, but here we don't do this because that would be
    -- some more complex to implement and not sure how much does it worth that.
    ensureAllCallable :: Notes t -> Either ArmCoords Bool
    ensureAllCallable :: Notes t -> Either [ArmCoord] Bool
ensureAllCallable = \case
      NTOr TypeAnn
_ Annotation FieldTag
fnL Annotation FieldTag
fnR Notes p
l Notes q
r -> do
        let epNameL :: Maybe EpName
epNameL = Annotation FieldTag -> Maybe EpName
epNameFromParamAnn Annotation FieldTag
fnL
        let epNameR :: Maybe EpName
epNameR = Annotation FieldTag -> Maybe EpName
epNameFromParamAnn Annotation FieldTag
fnR
        Bool
haveDefLL <- ([ArmCoord] -> [ArmCoord])
-> Either [ArmCoord] Bool -> Either [ArmCoord] Bool
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ArmCoord
AcLeft  ArmCoord -> [ArmCoord] -> [ArmCoord]
forall a. a -> [a] -> [a]
:) (Either [ArmCoord] Bool -> Either [ArmCoord] Bool)
-> Either [ArmCoord] Bool -> Either [ArmCoord] Bool
forall a b. (a -> b) -> a -> b
$ Notes p -> Either [ArmCoord] Bool
forall (t :: T). Notes t -> Either [ArmCoord] Bool
ensureAllCallable Notes p
l
        Bool
haveDefRR <- ([ArmCoord] -> [ArmCoord])
-> Either [ArmCoord] Bool -> Either [ArmCoord] Bool
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ArmCoord
AcRight ArmCoord -> [ArmCoord] -> [ArmCoord]
forall a. a -> [a] -> [a]
:) (Either [ArmCoord] Bool -> Either [ArmCoord] Bool)
-> Either [ArmCoord] Bool -> Either [ArmCoord] Bool
forall a b. (a -> b) -> a -> b
$ Notes q -> Either [ArmCoord] Bool
forall (t :: T). Notes t -> Either [ArmCoord] Bool
ensureAllCallable Notes q
r

        let haveDefL :: Bool
haveDefL = [Bool] -> Bool
forall t. (Container t, Element t ~ Bool) => t -> Bool
or [Bool
haveDefLL, Bool -> (EpName -> Bool) -> Maybe EpName -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False EpName -> Bool
isDefEpName Maybe EpName
epNameL]
        let haveDefR :: Bool
haveDefR = [Bool] -> Bool
forall t. (Container t, Element t ~ Bool) => t -> Bool
or [Bool
haveDefRR, Bool -> (EpName -> Bool) -> Maybe EpName -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False EpName -> Bool
isDefEpName Maybe EpName
epNameR]

        Bool -> Either [ArmCoord] () -> Either [ArmCoord] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
haveDefL (Either [ArmCoord] () -> Either [ArmCoord] ())
-> Either [ArmCoord] () -> Either [ArmCoord] ()
forall a b. (a -> b) -> a -> b
$ ([ArmCoord] -> [ArmCoord])
-> Either [ArmCoord] () -> Either [ArmCoord] ()
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ArmCoord
AcRight ArmCoord -> [ArmCoord] -> [ArmCoord]
forall a. a -> [a] -> [a]
:) (Either [ArmCoord] () -> Either [ArmCoord] ())
-> Either [ArmCoord] () -> Either [ArmCoord] ()
forall a b. (a -> b) -> a -> b
$ Maybe EpName -> Notes q -> Either [ArmCoord] ()
forall (t :: T). Maybe EpName -> Notes t -> Either [ArmCoord] ()
checkAllEpsNamed Maybe EpName
epNameR Notes q
r
        Bool -> Either [ArmCoord] () -> Either [ArmCoord] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
haveDefR (Either [ArmCoord] () -> Either [ArmCoord] ())
-> Either [ArmCoord] () -> Either [ArmCoord] ()
forall a b. (a -> b) -> a -> b
$ ([ArmCoord] -> [ArmCoord])
-> Either [ArmCoord] () -> Either [ArmCoord] ()
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ArmCoord
AcLeft  ArmCoord -> [ArmCoord] -> [ArmCoord]
forall a. a -> [a] -> [a]
:) (Either [ArmCoord] () -> Either [ArmCoord] ())
-> Either [ArmCoord] () -> Either [ArmCoord] ()
forall a b. (a -> b) -> a -> b
$ Maybe EpName -> Notes p -> Either [ArmCoord] ()
forall (t :: T). Maybe EpName -> Notes t -> Either [ArmCoord] ()
checkAllEpsNamed Maybe EpName
epNameL Notes p
l

        return $ [Bool] -> Bool
forall t. (Container t, Element t ~ Bool) => t -> Bool
or [Bool
haveDefL, Bool
haveDefR]

      Notes t
_ -> Bool -> Either [ArmCoord] Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    checkAllEpsNamed :: Maybe EpName -> Notes t -> Either ArmCoords ()
    checkAllEpsNamed :: Maybe EpName -> Notes t -> Either [ArmCoord] ()
checkAllEpsNamed Maybe EpName
epNameRoot
      | Maybe EpName -> Bool
forall a. Maybe a -> Bool
isJust Maybe EpName
epNameRoot = \Notes t
_ -> Either [ArmCoord] ()
forall (f :: * -> *). Applicative f => f ()
pass
      | Bool
otherwise = \case
          NTOr TypeAnn
_ Annotation FieldTag
fnL Annotation FieldTag
fnR Notes p
l Notes q
r -> do
            let epNameL :: Maybe EpName
epNameL = Annotation FieldTag -> Maybe EpName
epNameFromParamAnn Annotation FieldTag
fnL
                epNameR :: Maybe EpName
epNameR = Annotation FieldTag -> Maybe EpName
epNameFromParamAnn Annotation FieldTag
fnR

            ([ArmCoord] -> [ArmCoord])
-> Either [ArmCoord] () -> Either [ArmCoord] ()
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ArmCoord
AcLeft  ArmCoord -> [ArmCoord] -> [ArmCoord]
forall a. a -> [a] -> [a]
:) (Either [ArmCoord] () -> Either [ArmCoord] ())
-> Either [ArmCoord] () -> Either [ArmCoord] ()
forall a b. (a -> b) -> a -> b
$ Maybe EpName -> Notes p -> Either [ArmCoord] ()
forall (t :: T). Maybe EpName -> Notes t -> Either [ArmCoord] ()
checkAllEpsNamed Maybe EpName
epNameL Notes p
l
            ([ArmCoord] -> [ArmCoord])
-> Either [ArmCoord] () -> Either [ArmCoord] ()
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ArmCoord
AcRight ArmCoord -> [ArmCoord] -> [ArmCoord]
forall a. a -> [a] -> [a]
:) (Either [ArmCoord] () -> Either [ArmCoord] ())
-> Either [ArmCoord] () -> Either [ArmCoord] ()
forall a b. (a -> b) -> a -> b
$ Maybe EpName -> Notes q -> Either [ArmCoord] ()
forall (t :: T). Maybe EpName -> Notes t -> Either [ArmCoord] ()
checkAllEpsNamed Maybe EpName
epNameR Notes q
r

          Notes t
_ -> [ArmCoord] -> Either [ArmCoord] ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError []

-- | Construct 'ParamNotes' performing all necessary checks.
mkParamNotes :: Notes t -> RootAnn -> Either ParamEpError (ParamNotes t)
mkParamNotes :: Notes t
-> Annotation FieldTag -> Either ParamEpError (ParamNotes t)
mkParamNotes Notes t
nt Annotation FieldTag
fa = Notes t -> Annotation FieldTag -> Either ParamEpError ()
forall (t :: T).
Notes t -> Annotation FieldTag -> Either ParamEpError ()
verifyParamNotes Notes t
nt Annotation FieldTag
fa Either ParamEpError ()
-> ParamNotes t -> Either ParamEpError (ParamNotes t)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Notes t -> Annotation FieldTag -> ParamNotes t
forall (t :: T). Notes t -> Annotation FieldTag -> ParamNotes t
UnsafeParamNotes Notes t
nt Annotation FieldTag
fa

----------------------------------------------------------------------------
-- Entrypoint logic
----------------------------------------------------------------------------

-- | Describes how to construct full contract parameter from given entrypoint
-- argument.
--
-- This could be just wrapper over @Value arg -> Value param@, but we cannot
-- use @Value@ type in this module easily.
data EpLiftSequence (arg :: T) (param :: T) where
  EplArgHere :: EpLiftSequence arg arg
  EplWrapLeft
    :: (SingI subparam, SingI r)
    => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr subparam r)
  EplWrapRight
    :: (SingI l, SingI subparam)
    => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr l subparam)

deriving stock instance Eq (EpLiftSequence arg param)
deriving stock instance Show (EpLiftSequence arg param)

$(deriveGADTNFData ''EpLiftSequence)

instance Buildable (EpLiftSequence arg param) where
  build :: EpLiftSequence arg param -> Builder
build = \case
    EpLiftSequence arg param
EplArgHere -> Builder
"×"
    EplWrapLeft EpLiftSequence arg subparam
es -> Builder
"Left (" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> EpLiftSequence arg subparam -> Builder
forall p. Buildable p => p -> Builder
build EpLiftSequence arg subparam
es Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"
    EplWrapRight EpLiftSequence arg subparam
es -> Builder
"Right (" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> EpLiftSequence arg subparam -> Builder
forall p. Buildable p => p -> Builder
build EpLiftSequence arg subparam
es Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"

-- | Reference for calling a specific entrypoint of type @arg@.
data EntrypointCallT (param :: T) (arg :: T) =
  ParameterScope arg => EntrypointCall
  { EntrypointCallT param arg -> EpName
epcName :: EpName
    -- ^ Name of entrypoint.
  , EntrypointCallT param arg -> Proxy param
epcParamProxy :: Proxy param
    -- ^ Proxy of parameter, to make parameter type more easily fetchable.
  , EntrypointCallT param arg -> EpLiftSequence arg param
epcLiftSequence :: EpLiftSequence arg param
    -- ^ How to call this entrypoint in the corresponding contract.
  }

deriving stock instance Eq (EntrypointCallT param arg)
deriving stock instance Show (EntrypointCallT param arg)
instance NFData (EntrypointCallT param arg) where
  rnf :: EntrypointCallT param arg -> ()
rnf (EntrypointCall EpName
name Proxy param
Proxy EpLiftSequence arg param
s) = (EpName, EpLiftSequence arg param) -> ()
forall a. NFData a => a -> ()
rnf (EpName
name, EpLiftSequence arg param
s)

instance Buildable (EntrypointCallT param arg) where
  build :: EntrypointCallT param arg -> Builder
build EntrypointCall{Proxy param
EpName
EpLiftSequence arg param
epcLiftSequence :: EpLiftSequence arg param
epcParamProxy :: Proxy param
epcName :: EpName
epcLiftSequence :: forall (param :: T) (arg :: T).
EntrypointCallT param arg -> EpLiftSequence arg param
epcParamProxy :: forall (param :: T) (arg :: T).
EntrypointCallT param arg -> Proxy param
epcName :: forall (param :: T) (arg :: T). EntrypointCallT param arg -> EpName
..} =
    Builder
"Call " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| EpName
epcName EpName -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
": " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| EpLiftSequence arg param
epcLiftSequence EpLiftSequence arg param -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""

-- | Construct 'EntrypointCallT' which calls no entrypoint and assumes that
-- there is no explicit "default" one.
--
-- Validity of such operation is not ensured.
unsafeEpcCallRoot :: ParameterScope param => EntrypointCallT param param
unsafeEpcCallRoot :: EntrypointCallT param param
unsafeEpcCallRoot = EntrypointCall :: forall (param :: T) (arg :: T).
ParameterScope arg =>
EpName
-> Proxy param
-> EpLiftSequence arg param
-> EntrypointCallT param arg
EntrypointCall
  { epcName :: EpName
epcName = EpName
DefEpName
  , epcParamProxy :: Proxy param
epcParamProxy = Proxy param
forall k (t :: k). Proxy t
Proxy
  , epcLiftSequence :: EpLiftSequence param param
epcLiftSequence = EpLiftSequence param param
forall (arg :: T). EpLiftSequence arg arg
EplArgHere
  }

-- | Call parameter which has no entrypoints, always safe.
epcPrimitive
  :: forall p.
     (ParameterScope p, ForbidOr p)
  => EntrypointCallT p p
epcPrimitive :: EntrypointCallT p p
epcPrimitive = EntrypointCallT p p
forall (param :: T).
ParameterScope param =>
EntrypointCallT param param
unsafeEpcCallRoot
  where
  _requireNoOr :: Dict (ForbidOr p)
_requireNoOr = ForbidOr p => Dict (ForbidOr p)
forall (a :: Constraint). a => Dict a
Dict @(ForbidOr p)

type family ForbidOr (t :: T) :: Constraint where
  ForbidOr ('TOr l r) =
    TypeError
    ('Text "Cannot apply to sum type parameter " ':<>: 'ShowType ('TOr l r))
  ForbidOr _ = ()

-- | 'EntrypointCallT' with hidden parameter type.
--
-- This requires argument to satisfy 'ParameterScope' constraint.
-- Strictly speaking, entrypoint argument may one day start having different
-- set of constraints comparing to ones applied to parameter, but this seems
-- unlikely.
data SomeEntrypointCallT (arg :: T) =
  forall param. (ParameterScope param) =>
  SomeEpc (EntrypointCallT param arg)

instance Eq (SomeEntrypointCallT arg) where
  SomeEpc EntrypointCallT param arg
epc1 == :: SomeEntrypointCallT arg -> SomeEntrypointCallT arg -> Bool
== SomeEpc EntrypointCallT param arg
epc2 = Maybe () -> Bool
forall a. Maybe a -> Bool
isJust @() (Maybe () -> Bool) -> Maybe () -> Bool
forall a b. (a -> b) -> a -> b
$ do
    param :~: param
Refl <- Proxy param -> Proxy param -> Maybe (param :~: param)
forall (a :: T) (b :: T).
(SingI a, SingI b) =>
Proxy a -> Proxy b -> Maybe (a :~: b)
eqP (EntrypointCallT param arg -> Proxy param
forall (param :: T) (arg :: T).
EntrypointCallT param arg -> Proxy param
epcParamProxy EntrypointCallT param arg
epc1) (EntrypointCallT param arg -> Proxy param
forall (param :: T) (arg :: T).
EntrypointCallT param arg -> Proxy param
epcParamProxy EntrypointCallT param arg
epc2)
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (EntrypointCallT param arg
epc1 EntrypointCallT param arg -> EntrypointCallT param arg -> Bool
forall a. Eq a => a -> a -> Bool
== EntrypointCallT param arg
EntrypointCallT param arg
epc2)

deriving stock instance Show (SomeEntrypointCallT arg)
instance NFData (SomeEntrypointCallT arg) where
  rnf :: SomeEntrypointCallT arg -> ()
rnf (SomeEpc EntrypointCallT param arg
epc) = EntrypointCallT param arg -> ()
forall a. NFData a => a -> ()
rnf EntrypointCallT param arg
epc

instance Buildable (SomeEntrypointCallT arg) where
  build :: SomeEntrypointCallT arg -> Builder
build (SomeEpc EntrypointCallT param arg
epc) = EntrypointCallT param arg -> Builder
forall p. Buildable p => p -> Builder
build EntrypointCallT param arg
epc

-- | Construct 'SomeEntrypointCallT' which calls no entrypoint and assumes that
-- there is no explicit "default" one.
--
-- Validity of such operation is not ensured.
unsafeSepcCallRoot :: ParameterScope param => SomeEntrypointCallT param
unsafeSepcCallRoot :: SomeEntrypointCallT param
unsafeSepcCallRoot = EntrypointCallT param param -> SomeEntrypointCallT param
forall (arg :: T) (param :: T).
ParameterScope param =>
EntrypointCallT param arg -> SomeEntrypointCallT arg
SomeEpc EntrypointCallT param param
forall (param :: T).
ParameterScope param =>
EntrypointCallT param param
unsafeEpcCallRoot

-- | Call parameter which has no entrypoints, always safe.
sepcPrimitive
  :: forall t.
     (ParameterScope t, ForbidOr t)
  => SomeEntrypointCallT t
sepcPrimitive :: SomeEntrypointCallT t
sepcPrimitive = EntrypointCallT t t -> SomeEntrypointCallT t
forall (arg :: T) (param :: T).
ParameterScope param =>
EntrypointCallT param arg -> SomeEntrypointCallT arg
SomeEpc EntrypointCallT t t
forall (p :: T).
(ParameterScope p, ForbidOr p) =>
EntrypointCallT p p
epcPrimitive

sepcName :: SomeEntrypointCallT arg -> EpName
sepcName :: SomeEntrypointCallT arg -> EpName
sepcName (SomeEpc EntrypointCallT param arg
epc) = EntrypointCallT param arg -> EpName
forall (param :: T) (arg :: T). EntrypointCallT param arg -> EpName
epcName EntrypointCallT param arg
epc

-- | Build 'EpLiftSequence'.
--
-- Here we accept entrypoint name and type information for the parameter
-- of target contract.
--
-- Returns 'Nothing' if entrypoint is not found.
-- Does not treat default entrypoints specially.
withEpLiftSequence
  :: forall param r.
     (ParameterScope param)
  => EpName
  -> Notes param
  -> (forall arg. (ParameterScope arg) => (Notes arg, EpLiftSequence arg param) -> r)
  -> Maybe r
withEpLiftSequence :: EpName
-> Notes param
-> (forall (arg :: T).
    ParameterScope arg =>
    (Notes arg, EpLiftSequence arg param) -> r)
-> Maybe r
withEpLiftSequence epName :: EpName
epName@(EpName -> Annotation FieldTag
epNameToParamAnn -> Annotation FieldTag
epAnn) Notes param
param forall (arg :: T).
ParameterScope arg =>
(Notes arg, EpLiftSequence arg param) -> r
cont =
  case (SingI param => Sing param
forall k (a :: k). SingI a => Sing a
sing @param, Notes param
param) of
    (STOr Sing n
lSing Sing n
rSing, NTOr TypeAnn
_ Annotation FieldTag
lFieldAnn Annotation FieldTag
rFieldAnn Notes p
lNotes Notes q
rNotes) ->
      Sing n -> (SingI n => Maybe r) -> Maybe r
forall k (n :: k) r. Sing n -> (SingI n => r) -> r
withSingI Sing n
lSing ((SingI n => Maybe r) -> Maybe r)
-> (SingI n => Maybe r) -> Maybe r
forall a b. (a -> b) -> a -> b
$
      Sing n -> (SingI n => Maybe r) -> Maybe r
forall k (n :: k) r. Sing n -> (SingI n => r) -> r
withSingI Sing n
rSing ((SingI n => Maybe r) -> Maybe r)
-> (SingI n => Maybe r) -> Maybe r
forall a b. (a -> b) -> a -> b
$
      case (Sing n -> OpPresence n
forall (ty :: T). Sing ty -> OpPresence ty
checkOpPresence Sing n
lSing, Sing n -> NestedBigMapsPresence n
forall (ty :: T). Sing ty -> NestedBigMapsPresence ty
checkNestedBigMapsPresence Sing n
lSing) of
        (OpPresence n
OpAbsent, NestedBigMapsPresence n
NestedBigMapsAbsent) -> [Maybe r] -> Maybe r
forall t (f :: * -> *) a.
(Container t, Alternative f, Element t ~ f a) =>
t -> f a
asum
          [ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Annotation FieldTag
lFieldAnn Annotation FieldTag -> Annotation FieldTag -> Bool
forall a. Eq a => a -> a -> Bool
== Annotation FieldTag
epAnn) Maybe () -> r -> Maybe r
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Notes p, EpLiftSequence p param) -> r
forall (arg :: T).
ParameterScope arg =>
(Notes arg, EpLiftSequence arg param) -> r
cont (Notes p
lNotes, EpLiftSequence p p -> EpLiftSequence p ('TOr p n)
forall (subparam :: T) (r :: T) (arg :: T).
(SingI subparam, SingI r) =>
EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr subparam r)
EplWrapLeft EpLiftSequence p p
forall (arg :: T). EpLiftSequence arg arg
EplArgHere)
          , Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Annotation FieldTag
rFieldAnn Annotation FieldTag -> Annotation FieldTag -> Bool
forall a. Eq a => a -> a -> Bool
== Annotation FieldTag
epAnn) Maybe () -> r -> Maybe r
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Notes q, EpLiftSequence q param) -> r
forall (arg :: T).
ParameterScope arg =>
(Notes arg, EpLiftSequence arg param) -> r
cont (Notes q
rNotes, EpLiftSequence q q -> EpLiftSequence q ('TOr n q)
forall (l :: T) (subparam :: T) (arg :: T).
(SingI l, SingI subparam) =>
EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr l subparam)
EplWrapRight EpLiftSequence q q
forall (arg :: T). EpLiftSequence arg arg
EplArgHere)
          , EpName
-> Notes p
-> (forall (arg :: T).
    ParameterScope arg =>
    (Notes arg, EpLiftSequence arg p) -> r)
-> Maybe r
forall (param :: T) r.
ParameterScope param =>
EpName
-> Notes param
-> (forall (arg :: T).
    ParameterScope arg =>
    (Notes arg, EpLiftSequence arg param) -> r)
-> Maybe r
withEpLiftSequence EpName
epName Notes p
lNotes ((Notes arg, EpLiftSequence arg param) -> r
forall (arg :: T).
ParameterScope arg =>
(Notes arg, EpLiftSequence arg param) -> r
cont ((Notes arg, EpLiftSequence arg param) -> r)
-> ((Notes arg, EpLiftSequence arg p)
    -> (Notes arg, EpLiftSequence arg param))
-> (Notes arg, EpLiftSequence arg p)
-> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EpLiftSequence arg p -> EpLiftSequence arg ('TOr p n))
-> (Notes arg, EpLiftSequence arg p)
-> (Notes arg, EpLiftSequence arg ('TOr p n))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap @((,) _) EpLiftSequence arg p -> EpLiftSequence arg ('TOr p n)
forall (subparam :: T) (r :: T) (arg :: T).
(SingI subparam, SingI r) =>
EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr subparam r)
EplWrapLeft)
          , EpName
-> Notes q
-> (forall (arg :: T).
    ParameterScope arg =>
    (Notes arg, EpLiftSequence arg q) -> r)
-> Maybe r
forall (param :: T) r.
ParameterScope param =>
EpName
-> Notes param
-> (forall (arg :: T).
    ParameterScope arg =>
    (Notes arg, EpLiftSequence arg param) -> r)
-> Maybe r
withEpLiftSequence EpName
epName Notes q
rNotes ((Notes arg, EpLiftSequence arg param) -> r
forall (arg :: T).
ParameterScope arg =>
(Notes arg, EpLiftSequence arg param) -> r
cont ((Notes arg, EpLiftSequence arg param) -> r)
-> ((Notes arg, EpLiftSequence arg q)
    -> (Notes arg, EpLiftSequence arg param))
-> (Notes arg, EpLiftSequence arg q)
-> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EpLiftSequence arg q -> EpLiftSequence arg ('TOr n q))
-> (Notes arg, EpLiftSequence arg q)
-> (Notes arg, EpLiftSequence arg ('TOr n q))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap @((,) _) EpLiftSequence arg q -> EpLiftSequence arg ('TOr n q)
forall (l :: T) (subparam :: T) (arg :: T).
(SingI l, SingI subparam) =>
EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr l subparam)
EplWrapRight)
          ]
    (SingT param, Notes param)
_ -> Maybe r
forall a. Maybe a
Nothing

-- Helper datatype for 'mkEntrypointCall'.
data MkEntrypointCallRes param where
  MkEntrypointCallRes
    :: ParameterScope arg
    => Notes arg
    -> EntrypointCallT param arg
    -> MkEntrypointCallRes param

-- | Build 'EntrypointCallT'.
--
-- Here we accept entrypoint name and type information for the parameter
-- of target contract.
--
-- Returns 'Nothing' if entrypoint is not found.
mkEntrypointCall
  :: (ParameterScope param)
  => EpName
  -> ParamNotes param
  -> Maybe (MkEntrypointCallRes param)
mkEntrypointCall :: EpName -> ParamNotes param -> Maybe (MkEntrypointCallRes param)
mkEntrypointCall EpName
epName (ParamNotes Notes param
paramNotes Annotation FieldTag
root) =
  [Maybe (MkEntrypointCallRes param)]
-> Maybe (MkEntrypointCallRes param)
forall t (f :: * -> *) a.
(Container t, Alternative f, Element t ~ f a) =>
t -> f a
asum
  [ do
      EpName
epName' <- Annotation FieldTag -> Maybe EpName
epNameFromParamAnn Annotation FieldTag
root
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (EpName
epName EpName -> EpName -> Bool
forall a. Eq a => a -> a -> Bool
== EpName
epName')
      return $ Notes param
-> EntrypointCallT param param -> MkEntrypointCallRes param
forall (arg :: T) (param :: T).
ParameterScope arg =>
Notes arg -> EntrypointCallT param arg -> MkEntrypointCallRes param
MkEntrypointCallRes
        Notes param
paramNotes
        EntrypointCall :: forall (param :: T) (arg :: T).
ParameterScope arg =>
EpName
-> Proxy param
-> EpLiftSequence arg param
-> EntrypointCallT param arg
EntrypointCall
          { epcName :: EpName
epcName = EpName
epName
          , epcParamProxy :: Proxy param
epcParamProxy = Proxy param
forall k (t :: k). Proxy t
Proxy
          , epcLiftSequence :: EpLiftSequence param param
epcLiftSequence = EpLiftSequence param param
forall (arg :: T). EpLiftSequence arg arg
EplArgHere
          }
  , EpName
-> Notes param
-> (forall (arg :: T).
    ParameterScope arg =>
    (Notes arg, EpLiftSequence arg param) -> MkEntrypointCallRes param)
-> Maybe (MkEntrypointCallRes param)
forall (param :: T) r.
ParameterScope param =>
EpName
-> Notes param
-> (forall (arg :: T).
    ParameterScope arg =>
    (Notes arg, EpLiftSequence arg param) -> r)
-> Maybe r
withEpLiftSequence EpName
epName Notes param
paramNotes ((forall (arg :: T).
  ParameterScope arg =>
  (Notes arg, EpLiftSequence arg param) -> MkEntrypointCallRes param)
 -> Maybe (MkEntrypointCallRes param))
-> (forall (arg :: T).
    ParameterScope arg =>
    (Notes arg, EpLiftSequence arg param) -> MkEntrypointCallRes param)
-> Maybe (MkEntrypointCallRes param)
forall a b. (a -> b) -> a -> b
$ \(Notes arg
argInfo, EpLiftSequence arg param
liftSeq) ->
      Notes arg -> EntrypointCallT param arg -> MkEntrypointCallRes param
forall (arg :: T) (param :: T).
ParameterScope arg =>
Notes arg -> EntrypointCallT param arg -> MkEntrypointCallRes param
MkEntrypointCallRes Notes arg
argInfo (EntrypointCallT param arg -> MkEntrypointCallRes param)
-> EntrypointCallT param arg -> MkEntrypointCallRes param
forall a b. (a -> b) -> a -> b
$ EntrypointCall :: forall (param :: T) (arg :: T).
ParameterScope arg =>
EpName
-> Proxy param
-> EpLiftSequence arg param
-> EntrypointCallT param arg
EntrypointCall
        { epcName :: EpName
epcName = EpName
epName
        , epcParamProxy :: Proxy param
epcParamProxy = Proxy param
forall k (t :: k). Proxy t
Proxy
        , epcLiftSequence :: EpLiftSequence arg param
epcLiftSequence = EpLiftSequence arg param
liftSeq
        }
  , Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (EpName -> Bool
isDefEpName EpName
epName) Maybe ()
-> MkEntrypointCallRes param -> Maybe (MkEntrypointCallRes param)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>
      Notes param
-> EntrypointCallT param param -> MkEntrypointCallRes param
forall (arg :: T) (param :: T).
ParameterScope arg =>
Notes arg -> EntrypointCallT param arg -> MkEntrypointCallRes param
MkEntrypointCallRes Notes param
paramNotes EntrypointCall :: forall (param :: T) (arg :: T).
ParameterScope arg =>
EpName
-> Proxy param
-> EpLiftSequence arg param
-> EntrypointCallT param arg
EntrypointCall
        { epcName :: EpName
epcName = EpName
epName
        , epcParamProxy :: Proxy param
epcParamProxy = Proxy param
forall k (t :: k). Proxy t
Proxy
        , epcLiftSequence :: EpLiftSequence param param
epcLiftSequence = EpLiftSequence param param
forall (arg :: T). EpLiftSequence arg arg
EplArgHere
        }
  ]

-- | "Parameter" type of implicit account.
tyImplicitAccountParam :: ParamNotes 'TUnit
tyImplicitAccountParam :: ParamNotes 'TUnit
tyImplicitAccountParam = Notes 'TUnit -> Annotation FieldTag -> ParamNotes 'TUnit
forall (t :: T). Notes t -> Annotation FieldTag -> ParamNotes t
UnsafeParamNotes Notes 'TUnit
forall (t :: T). SingI t => Notes t
starNotes Annotation FieldTag
forall k (a :: k). Annotation a
noAnn