-- 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
  , epcCallRootUnsafe
  , SomeEntrypointCallT (..)
  , sepcCallRootUnsafe
  , sepcPrimitive
  , sepcName
  , ForbidOr
  , MkEntrypointCallRes (..)
  , mkEntrypointCall

  , tyImplicitAccountParam
  , flattenEntrypoints

    -- * 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 qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import Fmt (Buildable(..), hexF, pretty, (+|), (|+))
import Test.QuickCheck (Arbitrary(..))

import Michelson.Text
import Michelson.Typed.Annotation
import Michelson.Typed.Extract
import Michelson.Typed.Scope
import Michelson.Typed.Sing
import Michelson.Typed.T
import qualified Michelson.Untyped as U
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 addr :: Address
addr ep :: 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
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 ea :: 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
mkMTextUnsafe 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 = \case
    ParseEpAddressBadAddress err :: ParseAddressError
err -> ParseAddressError -> Builder
forall p. Buildable p => p -> Builder
build ParseAddressError
err
    ParseEpAddressRawBadAddress err :: ParseAddressRawError
err -> ParseAddressRawError -> Builder
forall p. Buildable p => p -> Builder
build ParseAddressRawError
err
    ParseEpAddressBadEntryopint addr :: ByteString
addr exception :: UnicodeException
exception ->
      "Invalid entrypoint given for raw adddress " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
forall a. FormatAsHex a => a -> Builder
hexF ByteString
addr Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
      " and failed with " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build (UnicodeException -> Text
forall b a. (Show a, IsString b) => a -> b
show @Text UnicodeException
exception)
    ParseEpAddressBadRefAnn txt :: Text
txt -> Text -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ "Invalid reference annotation: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt
    ParseEpAddressRefAnnError err :: EpNameFromRefAnnError
err -> EpNameFromRefAnnError -> Builder
forall p. Buildable p => p -> Builder
build EpNameFromRefAnnError
err
    ParseEpAddressInvalidLength len :: Int
len ->
      "Given raw entrypoint address has invalid length: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall p. Buildable p => p -> Builder
build 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 txt :: Text
txt =
  let (addrTxt :: Text
addrTxt, mannotTxt :: Text
mannotTxt) = Text -> Text -> (Text, Text)
T.breakOn "%" Text
txt
  in case Text
mannotTxt of
    "" -> 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
    annotTxt' :: 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
annotTxt' of
        Nothing -> Text -> Either Text (Annotation FieldTag)
forall a. HasCallStack => Text -> a
error "impossible"
        Just a :: 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

instance Arbitrary FieldAnn => Arbitrary EpAddress where
  arbitrary :: Gen EpAddress
arbitrary = Address -> EpName -> EpAddress
EpAddress (Address -> EpName -> EpAddress)
-> Gen Address -> Gen (EpName -> EpAddress)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Address
forall a. Arbitrary a => Gen a
arbitrary Gen (EpName -> EpAddress) -> Gen EpName -> Gen EpAddress
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen EpName
forall a. Arbitrary a => Gen a
arbitrary

-- | 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 raw :: ByteString
raw = do
  let (bytes :: ByteString
bytes, eps :: 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
+ 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 $ $WEpAddress :: Address -> EpName -> EpAddress
EpAddress {..}

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) = ParamNotesUnsafe
  { ParamNotes t -> Notes t
pnNotes   :: Notes t
  , ParamNotes t -> RootAnn
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 -> RootAnn -> r) -> (Void# -> r) -> r
ParamNotes t f <- ParamNotesUnsafe t f
{-# COMPLETE ParamNotes #-}

-- | Parameter without annotations.
starParamNotes :: SingI t => ParamNotes t
starParamNotes :: ParamNotes t
starParamNotes = Notes t -> RootAnn -> ParamNotes t
forall (t :: T). Notes t -> RootAnn -> ParamNotes t
ParamNotesUnsafe Notes t
forall (t :: T). SingI t => Notes t
starNotes RootAnn
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 = \case
    AcLeft -> "left"
    AcRight -> "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 = \case
    ParamEpDuplicatedNames names :: NonEmpty EpName
names -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
      [ "Duplicated entrypoint names: "
      , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([Builder] -> [Builder]) -> [Builder] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse ", " ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (EpName -> Builder) -> [EpName] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Builder -> Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a -> a
surround "'" "'" (Builder -> Builder) -> (EpName -> Builder) -> EpName -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpName -> Builder
forall p. Buildable p => p -> Builder
build) (NonEmpty EpName -> [Element (NonEmpty EpName)]
forall t. Container t => t -> [Element t]
toList NonEmpty EpName
names)
      ]
    ParamEpUncallableArm arm :: [ArmCoord]
arm -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
      [ "Due to presence of 'default' entrypoint, one of contract \"arms\" \
        \cannot be called: \""
      , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([Builder] -> [Builder]) -> [Builder] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse " - " ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (ArmCoord -> Builder) -> [ArmCoord] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ArmCoord -> Builder
forall p. Buildable p => p -> Builder
build [ArmCoord]
arm
      , "\""
      , if [ArmCoord] -> Int
forall t. Container t => t -> Int
length [ArmCoord]
arm Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 then " (in top-to-bottom order)" else ""
      ]
    where
    surround :: a -> a -> a -> a
surround pre :: a
pre post :: a
post builder :: a
builder = a
pre a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
builder a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
post

-- | Check whether given notes are valid parameter notes.
verifyParamNotes :: Notes t -> RootAnn -> Either ParamEpError ()
verifyParamNotes :: Notes t -> RootAnn -> Either ParamEpError ()
verifyParamNotes notes :: Notes t
notes ra :: RootAnn
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 -> Maybe EpName)
-> Annotation FieldTag -> Maybe EpName
forall a b. (a -> b) -> a -> b
$ RootAnn -> Annotation FieldTag
forall k1 k2 (tag1 :: k1) (tag2 :: k2).
Annotation tag1 -> Annotation tag2
convAnn RootAnn
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
$ \dups :: 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 (RootAnn
ra RootAnn -> RootAnn -> Bool
forall a. Eq a => a -> a -> Bool
== RootAnn
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 _ fn1 :: Annotation FieldTag
fn1 fn2 :: Annotation FieldTag
fn2 l :: Notes p
l r :: 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
        ]
      _ -> 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 _ fnL :: Annotation FieldTag
fnL fnR :: Annotation FieldTag
fnR l :: Notes p
l r :: 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]

      _ -> 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 epNameRoot :: Maybe EpName
epNameRoot
      | Maybe EpName -> Bool
forall a. Maybe a -> Bool
isJust Maybe EpName
epNameRoot = \_ -> Either [ArmCoord] ()
forall (f :: * -> *). Applicative f => f ()
pass
      | Bool
otherwise = \case
          NTOr _ fnL :: Annotation FieldTag
fnL fnR :: Annotation FieldTag
fnR l :: Notes p
l r :: 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

          _ -> [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 -> RootAnn -> Either ParamEpError (ParamNotes t)
mkParamNotes nt :: Notes t
nt fa :: RootAnn
fa = Notes t -> RootAnn -> Either ParamEpError ()
forall (t :: T). Notes t -> RootAnn -> Either ParamEpError ()
verifyParamNotes Notes t
nt RootAnn
fa Either ParamEpError ()
-> ParamNotes t -> Either ParamEpError (ParamNotes t)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Notes t -> RootAnn -> ParamNotes t
forall (t :: T). Notes t -> RootAnn -> ParamNotes t
ParamNotesUnsafe Notes t
nt RootAnn
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
    :: (KnownT subparam, KnownT r)
    => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr subparam r)
  EplWrapRight
    :: (KnownT l, KnownT 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
    EplArgHere -> "×"
    EplWrapLeft es :: EpLiftSequence arg subparam
es -> "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
<> ")"
    EplWrapRight es :: EpLiftSequence arg subparam
es -> "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
<> ")"

-- | 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 name :: EpName
name Proxy s :: 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{..} =
    "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
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
|+ ""

-- | Construct 'EntrypointCallT' which calls no entrypoint and assumes that
-- there is no explicit "default" one.
--
-- Validity of such operation is not ensured.
epcCallRootUnsafe :: ParameterScope param => EntrypointCallT param param
epcCallRootUnsafe :: EntrypointCallT param param
epcCallRootUnsafe = $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 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
epcCallRootUnsafe
  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 epc1 :: EntrypointCallT param arg
epc1 == :: SomeEntrypointCallT arg -> SomeEntrypointCallT arg -> Bool
== SomeEpc epc2 :: 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 k (a :: k) (b :: k).
(Typeable a, Typeable 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 epc :: 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 epc :: 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.
sepcCallRootUnsafe :: ParameterScope param => SomeEntrypointCallT param
sepcCallRootUnsafe :: SomeEntrypointCallT param
sepcCallRootUnsafe = 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
epcCallRootUnsafe

-- | 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 epc :: 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) param :: Notes param
param cont :: 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 lSing :: Sing a
lSing _, NTOr _ lFieldAnn :: Annotation FieldTag
lFieldAnn rFieldAnn :: Annotation FieldTag
rFieldAnn lNotes :: Notes p
lNotes rNotes :: Notes q
rNotes) ->
      case (Sing a -> OpPresence a
forall (ty :: T). Sing ty -> OpPresence ty
checkOpPresence Sing a
lSing, Sing a -> NestedBigMapsPresence a
forall (ty :: T). Sing ty -> NestedBigMapsPresence ty
checkNestedBigMapsPresence Sing a
lSing) of
        (OpAbsent, 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 b)
forall (subparam :: T) (r :: T) (arg :: T).
(KnownT subparam, KnownT 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 a q)
forall (l :: T) (subparam :: T) (arg :: T).
(KnownT l, KnownT 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 b))
-> (Notes arg, EpLiftSequence arg p)
-> (Notes arg, EpLiftSequence arg ('TOr p b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap @((,) _) EpLiftSequence arg p -> EpLiftSequence arg ('TOr p b)
forall (subparam :: T) (r :: T) (arg :: T).
(KnownT subparam, KnownT 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 a q))
-> (Notes arg, EpLiftSequence arg q)
-> (Notes arg, EpLiftSequence arg ('TOr a q))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap @((,) _) EpLiftSequence arg q -> EpLiftSequence arg ('TOr a q)
forall (l :: T) (subparam :: T) (arg :: T).
(KnownT l, KnownT subparam) =>
EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr l subparam)
EplWrapRight)
          ]
    _ -> 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
epName (ParamNotes paramNotes :: Notes param
paramNotes root :: RootAnn
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 -> Maybe EpName)
-> Annotation FieldTag -> Maybe EpName
forall a b. (a -> b) -> a -> b
$ RootAnn -> Annotation FieldTag
forall k1 k2 (tag1 :: k1) (tag2 :: k2).
Annotation tag1 -> Annotation tag2
convAnn RootAnn
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
        $WEntrypointCall :: 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
$ \(argInfo :: Notes arg
argInfo, liftSeq :: 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
$ $WEntrypointCall :: 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 $WEntrypointCall :: 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 -> RootAnn -> ParamNotes 'TUnit
forall (t :: T). Notes t -> RootAnn -> ParamNotes t
ParamNotesUnsafe Notes 'TUnit
forall (t :: T). SingI t => Notes t
starNotes RootAnn
forall k (a :: k). Annotation a
noAnn

-- Misc
----------------------------------------------------------------------------

-- | Flatten a provided list of notes to a map of its entrypoints and its
-- corresponding utype. Please refer to 'mkEntrypointsMap' in regards to how
-- duplicate entrypoints are handled.
flattenEntrypoints :: SingI t => ParamNotes t -> Map EpName U.Type
flattenEntrypoints :: ParamNotes t -> Map EpName Type
flattenEntrypoints (ParamNotes t -> Notes t
forall (t :: T). ParamNotes t -> Notes t
pnNotes -> Notes t
notes) = Type -> Map EpName Type
mkEntrypointsMap (Notes t -> Type
forall (x :: T). SingI x => Notes x -> Type
mkUType Notes t
notes)