module Morley.Michelson.Untyped.Entrypoints
( EpName (..)
, pattern DefEpName
, isDefEpName
, epNameFromParamAnn
, epNameToParamAnn
, epNameFromRefAnn
, epNameFromSelfAnn
, epNameToRefAnn
, EpNameFromRefAnnError (..)
, buildEpName
, mkEntrypointsMap
) where
import Data.Aeson.TH (deriveJSON)
import Data.Map qualified as Map
import Fmt (Buildable(..), pretty)
import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderAnyBuildable)
import Morley.Michelson.Untyped.Annotation
import Morley.Michelson.Untyped.Type
import Morley.Util.Aeson
import Morley.Util.CLI
import Text.PrettyPrint.Leijen.Text (enclose, (<+>))
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
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
pattern DefEpName :: EpName
pattern $bDefEpName :: EpName
$mDefEpName :: forall {r}. EpName -> (Void# -> r) -> (Void# -> r) -> r
DefEpName = UnsafeEpName ""
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
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
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 = Either Text FieldAnn -> FieldAnn
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text FieldAnn -> FieldAnn)
-> (Text -> Either Text FieldAnn) -> Text -> FieldAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text FieldAnn
forall {k} (a :: k). Text -> Either Text (Annotation a)
mkAnnotation (Text -> FieldAnn) -> Text -> FieldAnn
forall a b. (a -> b) -> a -> b
$ 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)
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
epNameFromSelfAnn :: FieldAnn -> EpName
epNameFromSelfAnn :: FieldAnn -> EpName
epNameFromSelfAnn (Annotation Text
a) = Text -> EpName
UnsafeEpName Text
a
epNameToRefAnn :: EpName -> FieldAnn
epNameToRefAnn :: EpName -> FieldAnn
epNameToRefAnn (UnsafeEpName Text
name) = Either Text FieldAnn -> FieldAnn
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text FieldAnn -> FieldAnn)
-> (Text -> Either Text FieldAnn) -> Text -> FieldAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text FieldAnn
forall {k} (a :: k). Text -> Either Text (Annotation a)
mkAnnotation (Text -> FieldAnn) -> Text -> FieldAnn
forall a b. (a -> b) -> a -> b
$ Text
name
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
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"
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
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
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