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

module Michelson.Untyped.Entrypoints
  ( EpName (..)
  , pattern DefEpName
  , isDefEpName
  , epNameFromParamAnn
  , epNameToParamAnn
  , epNameFromRefAnn
  , epNameFromSelfAnn
  , epNameToRefAnn
  , EpNameFromRefAnnError (..)
  , buildEpName
  , unsafeBuildEpName
  , mkEntrypointsMap
  ) where

import Data.Aeson.TH (deriveJSON)
import qualified Data.Map as Map
import Fmt (Buildable(..), pretty, (+|), (|+))

import Michelson.Untyped.Annotation
import Michelson.Untyped.Type
import Util.Aeson
import Util.CLI

-- | Entrypoint name.
--
-- There are two properties we care about:
--
-- 1. Special treatment of the @default@ entrypoint name.
-- @default@ is prohibited in the @CONTRACT@ instruction and in
-- values of @address@ and @contract@ types.
-- However, it is not prohibited in the @SELF@ instruction.
-- Hence, the value inside @EpName@ __can__ be @"default"@, so that
-- we can distinguish @SELF@ and @SELF %default@. It is important
-- to distinguish them because their binary representation that is
-- inserted into blockchain is different. For example, typechecking
-- @SELF %default@ consumes more gas than @SELF@.
-- In this module, we provide several smart constructors with different
-- handling of @default@, please use the appropriate one for your use case.
-- 2. The set of permitted characters. Intuitively, an entrypoint name should
-- be valid only if it is a valid annotation (because entrypoints are defined
-- using field annotations). However, it is not enforced in Tezos.
-- It is not clear whether this behavior is intended. There is an upstream
-- [issue](https://gitlab.com/tezos/tezos/-/issues/851) which received @bug@
-- label, so probably it is considered a bug. Currently we treat it as a bug
-- and deviate from upstream implementation by probiting entrypoint names that
-- are not valid annotations. If Tezos developers fix it soon, we will be happy.
-- If they don't, we should (maybe temporarily) remove this limitation from our
-- code. There is an
-- [issue](https://gitlab.com/morley-framework/morley/-/issues/275) in our
-- repo as well.
newtype EpName = EpNameUnsafe { EpName -> Text
unEpName :: Text }
  deriving stock (Int -> EpName -> ShowS
[EpName] -> ShowS
EpName -> String
(Int -> EpName -> ShowS)
-> (EpName -> String) -> ([EpName] -> ShowS) -> Show EpName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EpName] -> ShowS
$cshowList :: [EpName] -> ShowS
show :: EpName -> String
$cshow :: EpName -> String
showsPrec :: Int -> EpName -> ShowS
$cshowsPrec :: Int -> EpName -> ShowS
Show, EpName -> EpName -> Bool
(EpName -> EpName -> Bool)
-> (EpName -> EpName -> Bool) -> Eq EpName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EpName -> EpName -> Bool
$c/= :: EpName -> EpName -> Bool
== :: EpName -> EpName -> Bool
$c== :: EpName -> EpName -> Bool
Eq, Eq EpName
Eq EpName =>
(EpName -> EpName -> Ordering)
-> (EpName -> EpName -> Bool)
-> (EpName -> EpName -> Bool)
-> (EpName -> EpName -> Bool)
-> (EpName -> EpName -> Bool)
-> (EpName -> EpName -> EpName)
-> (EpName -> EpName -> EpName)
-> Ord EpName
EpName -> EpName -> Bool
EpName -> EpName -> Ordering
EpName -> EpName -> EpName
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 :: EpName -> EpName -> EpName
$cmin :: EpName -> EpName -> EpName
max :: EpName -> EpName -> EpName
$cmax :: EpName -> EpName -> EpName
>= :: EpName -> EpName -> Bool
$c>= :: EpName -> EpName -> Bool
> :: EpName -> EpName -> Bool
$c> :: EpName -> EpName -> Bool
<= :: EpName -> EpName -> Bool
$c<= :: EpName -> EpName -> Bool
< :: EpName -> EpName -> Bool
$c< :: EpName -> EpName -> Bool
compare :: EpName -> EpName -> Ordering
$ccompare :: EpName -> EpName -> Ordering
$cp1Ord :: Eq EpName
Ord, (forall x. EpName -> Rep EpName x)
-> (forall x. Rep EpName x -> EpName) -> Generic EpName
forall x. Rep EpName x -> EpName
forall x. EpName -> Rep EpName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EpName x -> EpName
$cfrom :: forall x. EpName -> Rep EpName x
Generic)

instance NFData EpName

deriveJSON morleyAesonOptions ''EpName

-- | This is a bidirectional pattern that can be used for two purposes:
--
-- 1. Construct an 'EpName' referring to the default entrypoint.
-- 2. Use it in pattern-matching or in equality comparison to check whether
-- 'EpName' refers to the default entrypoint. This is trickier because there
-- are two possible 'EpName' values referring to the default entrypoints.
-- 'DefEpName' will match only the most common one (no entrypoint).
-- However, there is a special case: @SELF@ instruction can have explicit
-- @%default@ reference. For this reason, it is recommended to use
-- 'isDefEpName' instead. Pattern-matching on 'DefEpName' is still permitted
-- for backwards compatibility and for the cases when you are sure that
-- 'EpName' does not come from the @SELF@ instruction.
pattern DefEpName :: EpName
pattern $bDefEpName :: EpName
$mDefEpName :: forall r. EpName -> (Void# -> r) -> (Void# -> r) -> r
DefEpName = EpNameUnsafe ""

-- | Check whether given 'EpName' refers to the default entrypoint.
-- Unlike 'DefEpName' pattern, this function correctly handles all cases,
-- including the @SELF@ instruction.
isDefEpName :: EpName -> Bool
isDefEpName :: EpName -> Bool
isDefEpName epName :: EpName
epName = EpName
epName EpName -> EpName -> Bool
forall a. Eq a => a -> a -> Bool
== EpName
DefEpName Bool -> Bool -> Bool
|| EpName
epName EpName -> EpName -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> EpName
EpNameUnsafe "default"

instance Buildable EpName where
  build :: EpName -> Builder
build = \case
    DefEpName -> "<default>"
    EpNameUnsafe name :: Text
name -> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
name

-- | Make up 'EpName' from annotation in parameter type declaration.
--
-- Returns 'Nothing' if no entrypoint is assigned here.
epNameFromParamAnn :: FieldAnn -> Maybe EpName
epNameFromParamAnn :: FieldAnn -> Maybe EpName
epNameFromParamAnn an :: FieldAnn
an@(Annotation a :: Text
a)
  | FieldAnn
an FieldAnn -> FieldAnn -> Bool
forall a. Eq a => a -> a -> Bool
== FieldAnn
forall k (a :: k). Annotation a
noAnn = Maybe EpName
forall a. Maybe a
Nothing
  | Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "default" = EpName -> Maybe EpName
forall a. a -> Maybe a
Just (Text -> EpName
EpNameUnsafe "")
  | Bool
otherwise = EpName -> Maybe EpName
forall a. a -> Maybe a
Just (EpName -> Maybe EpName) -> EpName -> Maybe EpName
forall a b. (a -> b) -> a -> b
$ Text -> EpName
EpNameUnsafe Text
a

-- | Turn entrypoint name into annotation for contract parameter declaration.
epNameToParamAnn :: EpName -> FieldAnn
epNameToParamAnn :: EpName -> FieldAnn
epNameToParamAnn (EpNameUnsafe name :: Text
name)
  | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "" = Text -> FieldAnn
forall k (a :: k). HasCallStack => Text -> Annotation a
ann "default"
  | Bool
otherwise = Text -> FieldAnn
forall k (a :: k). HasCallStack => Text -> Annotation a
ann Text
name

data EpNameFromRefAnnError
  = InEpNameBadAnnotation FieldAnn
  deriving stock (Int -> EpNameFromRefAnnError -> ShowS
[EpNameFromRefAnnError] -> ShowS
EpNameFromRefAnnError -> String
(Int -> EpNameFromRefAnnError -> ShowS)
-> (EpNameFromRefAnnError -> String)
-> ([EpNameFromRefAnnError] -> ShowS)
-> Show EpNameFromRefAnnError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EpNameFromRefAnnError] -> ShowS
$cshowList :: [EpNameFromRefAnnError] -> ShowS
show :: EpNameFromRefAnnError -> String
$cshow :: EpNameFromRefAnnError -> String
showsPrec :: Int -> EpNameFromRefAnnError -> ShowS
$cshowsPrec :: Int -> EpNameFromRefAnnError -> ShowS
Show, EpNameFromRefAnnError -> EpNameFromRefAnnError -> Bool
(EpNameFromRefAnnError -> EpNameFromRefAnnError -> Bool)
-> (EpNameFromRefAnnError -> EpNameFromRefAnnError -> Bool)
-> Eq EpNameFromRefAnnError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EpNameFromRefAnnError -> EpNameFromRefAnnError -> Bool
$c/= :: EpNameFromRefAnnError -> EpNameFromRefAnnError -> Bool
== :: EpNameFromRefAnnError -> EpNameFromRefAnnError -> Bool
$c== :: EpNameFromRefAnnError -> EpNameFromRefAnnError -> Bool
Eq, (forall x. EpNameFromRefAnnError -> Rep EpNameFromRefAnnError x)
-> (forall x. Rep EpNameFromRefAnnError x -> EpNameFromRefAnnError)
-> Generic EpNameFromRefAnnError
forall x. Rep EpNameFromRefAnnError x -> EpNameFromRefAnnError
forall x. EpNameFromRefAnnError -> Rep EpNameFromRefAnnError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EpNameFromRefAnnError x -> EpNameFromRefAnnError
$cfrom :: forall x. EpNameFromRefAnnError -> Rep EpNameFromRefAnnError x
Generic)

instance NFData EpNameFromRefAnnError

instance Buildable EpNameFromRefAnnError where
  build :: EpNameFromRefAnnError -> Builder
build = \case
    InEpNameBadAnnotation (Annotation an :: Text
an) ->
      "Invalid entrypoint reference `" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text
an Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ "`"

-- | Make up 'EpName' from annotation which is reference to an entrypoint.
-- Note that it's more common for Michelson to prohibit explicit @default@
-- entrypoint reference.
--
-- Specifically, @%default@ annotation is probitited in values of @address@
-- and @contract@ types. It's also prohibited in the @CONTRACT@ instruction.
-- However, there is an exception: @SELF %default@ is a perfectly valid
-- instruction. Hence, when you construct an 'EpName' from an annotation
-- that's part of @SELF@, you should use 'epNameFromSelfAnn' instead.
epNameFromRefAnn :: FieldAnn -> Either EpNameFromRefAnnError EpName
epNameFromRefAnn :: FieldAnn -> Either EpNameFromRefAnnError EpName
epNameFromRefAnn an :: FieldAnn
an@(Annotation a :: Text
a)
  | Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "default" = EpNameFromRefAnnError -> Either EpNameFromRefAnnError EpName
forall a b. a -> Either a b
Left (EpNameFromRefAnnError -> Either EpNameFromRefAnnError EpName)
-> EpNameFromRefAnnError -> Either EpNameFromRefAnnError EpName
forall a b. (a -> b) -> a -> b
$ FieldAnn -> EpNameFromRefAnnError
InEpNameBadAnnotation FieldAnn
an
  | Bool
otherwise = EpName -> Either EpNameFromRefAnnError EpName
forall a b. b -> Either a b
Right (EpName -> Either EpNameFromRefAnnError EpName)
-> EpName -> Either EpNameFromRefAnnError EpName
forall a b. (a -> b) -> a -> b
$ Text -> EpName
EpNameUnsafe Text
a

-- | Make up an 'EpName' from an annotation which is part of the
-- @SELF@ instruction.
epNameFromSelfAnn :: FieldAnn -> EpName
epNameFromSelfAnn :: FieldAnn -> EpName
epNameFromSelfAnn (Annotation a :: Text
a) = Text -> EpName
EpNameUnsafe Text
a

-- | Turn entrypoint name into annotation used as reference to entrypoint.
epNameToRefAnn :: EpName -> FieldAnn
epNameToRefAnn :: EpName -> FieldAnn
epNameToRefAnn (EpNameUnsafe name :: Text
name) = Text -> FieldAnn
forall k (a :: k). HasCallStack => Text -> Annotation a
ann Text
name

-- | Make a valid entrypoint name from an arbitrary text. This
-- function prohibits explicit @default@ entrypoint name which is
-- permitted by Michelson inside the @SELF@ instruction. This
-- limitation shouldn't be restrictive because @SELF@ is equivalent to
-- @SELF %default@.
buildEpName :: Text -> Either String EpName
buildEpName :: Text -> Either String EpName
buildEpName txt :: Text
txt = do
  FieldAnn
annotation <-
    Text -> Either Text FieldAnn
forall k (a :: k). Text -> Either Text (Annotation a)
mkAnnotation Text
txt
    Either Text FieldAnn
-> (Either Text FieldAnn -> Either String FieldAnn)
-> Either String FieldAnn
forall a b. a -> (a -> b) -> b
& (Text -> String) -> Either Text FieldAnn -> Either String FieldAnn
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> ShowS
forall a. Monoid a => a -> a -> a
mappend "Failed to parse entrypoint: " ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty)
  FieldAnn -> Either EpNameFromRefAnnError EpName
epNameFromRefAnn FieldAnn
annotation
    Either EpNameFromRefAnnError EpName
-> (Either EpNameFromRefAnnError EpName -> Either String EpName)
-> Either String EpName
forall a b. a -> (a -> b) -> b
& (EpNameFromRefAnnError -> String)
-> Either EpNameFromRefAnnError EpName -> Either String EpName
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first EpNameFromRefAnnError -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty

-- | Partial version of 'buildEpName'.
unsafeBuildEpName :: HasCallStack => Text -> EpName
unsafeBuildEpName :: Text -> EpName
unsafeBuildEpName = (String -> EpName)
-> (EpName -> EpName) -> Either String EpName -> EpName
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> EpName
forall a. HasCallStack => Text -> a
error (Text -> EpName) -> (String -> Text) -> String -> EpName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty) EpName -> EpName
forall a. a -> a
id (Either String EpName -> EpName)
-> (Text -> Either String EpName) -> Text -> EpName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String EpName
buildEpName

instance HasCLReader EpName where
  getReader :: ReadM EpName
getReader = (String -> Either String EpName) -> ReadM EpName
forall a. (String -> Either String a) -> ReadM a
eitherReader (Text -> Either String EpName
buildEpName (Text -> Either String EpName)
-> (String -> Text) -> String -> Either String EpName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText)
  getMetavar :: String
getMetavar = "ENTRYPOINT"

-- | Given an untyped parameter type, extract a map that maps entrypoint names
-- to the their parameter types. If there are duplicate entrypoints in the
-- given Type then the duplicate entrypoints at a deeper nesting level will get
-- overwritten with the ones that are on top.
mkEntrypointsMap :: ParameterType -> Map EpName Type
mkEntrypointsMap :: ParameterType -> Map EpName Type
mkEntrypointsMap (ParameterType ty :: Type
ty rootAnn :: FieldAnn
rootAnn) = FieldAnn -> Type -> Map EpName Type
mkEntrypointsMapRec FieldAnn
rootAnn Type
ty

-- | Version of 'mkEntrypointMaps' for plain untyped type.
mkEntrypointsMapRec :: FieldAnn -> Type -> Map EpName Type
mkEntrypointsMapRec :: FieldAnn -> Type -> Map EpName Type
mkEntrypointsMapRec curRootAnn :: FieldAnn
curRootAnn ty :: Type
ty =
  FieldAnn -> Map EpName Type
accountRoot FieldAnn
curRootAnn Map EpName Type -> Map EpName Type -> Map EpName Type
forall a. Semigroup a => a -> a -> a
<> Type -> Map EpName Type
accountTree Type
ty
  where
    accountRoot :: FieldAnn -> Map EpName Type
accountRoot rootAnn :: FieldAnn
rootAnn = [(EpName, Type)] -> Map EpName Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(EpName, Type)] -> Map EpName Type)
-> [(EpName, Type)] -> Map EpName Type
forall a b. (a -> b) -> a -> b
$ do
      Just rootEp :: EpName
rootEp <- Maybe EpName -> [Maybe EpName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe EpName -> [Maybe EpName]) -> Maybe EpName -> [Maybe EpName]
forall a b. (a -> b) -> a -> b
$ FieldAnn -> Maybe EpName
epNameFromParamAnn FieldAnn
rootAnn
      (EpName, Type) -> [(EpName, Type)]
forall (m :: * -> *) a. Monad m => a -> m a
return (EpName
rootEp, Type
ty)

    accountTree :: Type -> Map EpName Type
accountTree (Type t :: T
t _) = case T
t of
      -- We are only interested in `Or` branches to extract entrypoint
      -- annotations.
      TOr f1 :: FieldAnn
f1 f2 :: FieldAnn
f2 t1 :: Type
t1 t2 :: Type
t2 -> FieldAnn -> Type -> Map EpName Type
mkEntrypointsMapRec FieldAnn
f1 Type
t1 Map EpName Type -> Map EpName Type -> Map EpName Type
forall a. Semigroup a => a -> a -> a
<> FieldAnn -> Type -> Map EpName Type
mkEntrypointsMapRec FieldAnn
f2 Type
t2
      _ -> Map EpName Type
forall a. Monoid a => a
mempty