-- 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 Michelson.Printer.Util (RenderDoc (..), renderAnyBuildable, buildRenderDoc)
import Text.PrettyPrint.Leijen.Text ((<+>), enclose)
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 = UnsafeEpName { 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 = UnsafeEpName ""

-- | 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 -> Bool
forall a. Eq a => a -> a -> Bool
== EpName
DefEpName Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| EpName
epName EpName -> EpName -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> EpName
UnsafeEpName Text
"default"

instance Buildable EpName where
  build :: EpName -> Builder
build = \case
    EpName
DefEpName -> Builder
"<default>"
    UnsafeEpName 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 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
== Text
"default" = EpName -> Maybe EpName
forall a. a -> Maybe a
Just (Text -> EpName
UnsafeEpName Text
"")
  | 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
UnsafeEpName Text
a

-- | Turn entrypoint name into annotation for contract parameter declaration.
epNameToParamAnn :: EpName -> FieldAnn
epNameToParamAnn :: EpName -> FieldAnn
epNameToParamAnn (UnsafeEpName Text
name)
  | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" = [annQ|default|]
  | Bool
otherwise = Text -> FieldAnn
forall k (a :: k). HasCallStack => Text -> Annotation a
unsafeMkAnnotation 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 = EpNameFromRefAnnError -> Builder
forall a. RenderDoc a => a -> Builder
buildRenderDoc

instance RenderDoc EpNameFromRefAnnError where
  renderDoc :: RenderContext -> EpNameFromRefAnnError -> Doc
renderDoc RenderContext
_ = \case
    InEpNameBadAnnotation (Annotation Text
an) ->
      Doc
"Invalid entrypoint reference" Doc -> Doc -> Doc
<+> (Doc -> Doc -> Doc -> Doc
enclose Doc
"`" Doc
"`" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
forall a. Buildable a => a -> Doc
renderAnyBuildable Text
an)

-- | 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 Text
a)
  | Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"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
UnsafeEpName Text
a

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

-- | Turn entrypoint name into annotation used as reference to entrypoint.
epNameToRefAnn :: EpName -> FieldAnn
epNameToRefAnn :: EpName -> FieldAnn
epNameToRefAnn (UnsafeEpName Text
name) = Text -> FieldAnn
forall k (a :: k). HasCallStack => Text -> Annotation a
unsafeMkAnnotation 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 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 String
"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 = String
"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 Ty
mkEntrypointsMap :: ParameterType -> Map EpName Ty
mkEntrypointsMap (ParameterType Ty
ty FieldAnn
rootAnn) = FieldAnn -> Ty -> Map EpName Ty
mkEntrypointsMapRec FieldAnn
rootAnn Ty
ty

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

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