module Morley.Tezos.Address.Alias
( AddressOrAlias(..)
, addressOrAliasKindSanity
, Alias(..)
, SomeAlias
, pattern SomeAlias
, ImplicitAlias
, ContractAlias
, ImplicitAddressOrAlias
, ContractAddressOrAlias
, unAlias
, mkAlias
, aliasKindSanity
, SomeAddressOrAlias(..)
, aliasPrefix
, contractPrefix
, implicitPrefix
)
where
import Data.Aeson (FromJSON(..), ToJSON(..))
import Data.Constraint (Dict(..), (\\))
import Data.Constraint.Extras (has)
import Data.Constraint.Extras.TH (deriveArgDict)
import Data.GADT.Compare.TH (deriveGCompare, deriveGEq)
import Data.Singletons (SingI(..), demote)
import Data.Text qualified as T
import Fmt (Buildable(..), Doc, pretty)
import Options.Applicative qualified as Opt
import Data.Char qualified as Char
import Morley.Tezos.Address
import Morley.Tezos.Address.Kinds
import Morley.Util.CLI (HasCLReader(..))
import Morley.Util.Constrained
import Morley.Util.Interpolate (itu)
import Morley.Util.Sing
import Morley.Util.TH
data Alias (kind :: AddressKind) where
ImplicitAlias :: Text -> Alias 'AddressKindImplicit
ContractAlias :: Text -> Alias 'AddressKindContract
type ImplicitAlias = Alias 'AddressKindImplicit
type ContractAlias = Alias 'AddressKindContract
deriving stock instance Show (Alias kind)
deriving stock instance Eq (Alias kind)
deriving stock instance Ord (Alias kind)
deriveGADTNFData ''Alias
deriveGEq ''Alias
deriveGCompare ''Alias
deriveArgDict ''Alias
unAlias :: Alias kind -> Text
unAlias :: forall (kind :: AddressKind). Alias kind -> Text
unAlias = \case
ImplicitAlias Text
x -> Text
x
ContractAlias Text
x -> Text
x
mkAlias :: forall kind. (SingI kind, L1AddressKind kind) => Text -> Alias kind
mkAlias :: forall (kind :: AddressKind).
(SingI kind, L1AddressKind kind) =>
Text -> Alias kind
mkAlias = forall (kind :: AddressKind) a. L1AddressKind kind => a -> a
usingImplicitOrContractKind @kind ((Text -> Alias kind) -> Text -> Alias kind)
-> (Text -> Alias kind) -> Text -> Alias kind
forall a b. (a -> b) -> a -> b
$ case forall {k} (a :: k). SingI a => Sing a
forall (a :: AddressKind). SingI a => Sing a
sing @kind of
Sing kind
SingAddressKind kind
SAddressKindImplicit -> Text -> Alias kind
Text -> Alias 'AddressKindImplicit
ImplicitAlias
Sing kind
SingAddressKind kind
SAddressKindContract -> Text -> Alias kind
Text -> Alias 'AddressKindContract
ContractAlias
instance Buildable (Alias kind) where
build :: Alias kind -> Doc
build = Text -> Doc
forall a. Buildable a => a -> Doc
build (Text -> Doc) -> (Alias kind -> Text) -> Alias kind -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alias kind -> Text
forall (kind :: AddressKind). Alias kind -> Text
unAlias
instance ToJSON (Alias kind) where
toJSON :: Alias kind -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (Alias kind -> Text) -> Alias kind -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alias kind -> Text
forall (kind :: AddressKind). Alias kind -> Text
unAlias
instance (SingI kind, L1AddressKind kind) => FromJSON (Alias kind) where
parseJSON :: Value -> Parser (Alias kind)
parseJSON = (Text -> Alias kind) -> Parser Text -> Parser (Alias kind)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Alias kind
forall (kind :: AddressKind).
(SingI kind, L1AddressKind kind) =>
Text -> Alias kind
mkAlias (Parser Text -> Parser (Alias kind))
-> (Value -> Parser Text) -> Value -> Parser (Alias kind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON
type SomeAlias = Constrained NullConstraint Alias
pattern SomeAlias :: Alias a -> SomeAlias
pattern $mSomeAlias :: forall {r}.
SomeAlias
-> (forall {a :: AddressKind}. Alias a -> r) -> ((# #) -> r) -> r
$bSomeAlias :: forall (a :: AddressKind). Alias a -> SomeAlias
SomeAlias x = Constrained x
{-# COMPLETE SomeAlias #-}
aliasKindSanity :: Alias kind -> Dict (L1AddressKind kind, SingI kind)
aliasKindSanity :: forall (kind :: AddressKind).
Alias kind -> Dict (L1AddressKind kind, SingI kind)
aliasKindSanity Alias kind
x = forall {k} (c :: k -> Constraint) (f :: k -> *) (a :: k) r.
Has c f =>
f a -> (c a => r) -> r
forall (c :: AddressKind -> Constraint) (f :: AddressKind -> *)
(a :: AddressKind) r.
Has c f =>
f a -> (c a => r) -> r
has @AliasKindSanityHelper Alias kind
x Dict (L1AddressKind kind, SingI kind)
AliasKindSanityHelper kind => Dict (L1AddressKind kind, SingI kind)
forall (a :: Constraint). a => Dict a
Dict
class (L1AddressKind kind, SingI kind) => AliasKindSanityHelper kind
instance (L1AddressKind kind, SingI kind) => AliasKindSanityHelper kind
data AddressOrAlias kind where
AddressResolved :: L1AddressKind kind => KindedAddress kind -> AddressOrAlias kind
AddressAlias :: Alias kind -> AddressOrAlias kind
deriving stock instance Show (AddressOrAlias kind)
deriving stock instance Eq (AddressOrAlias kind)
deriving stock instance Ord (AddressOrAlias kind)
instance (SingI kind, L1AddressKind kind) => HasCLReader (AddressOrAlias kind) where
getReader :: ReadM (AddressOrAlias kind)
getReader =
forall a. HasCLReader a => ReadM a
getReader @SomeAddressOrAlias ReadM SomeAddressOrAlias
-> (SomeAddressOrAlias -> ReadM (AddressOrAlias kind))
-> ReadM (AddressOrAlias kind)
forall a b. ReadM a -> (a -> ReadM b) -> ReadM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
SAOAKindSpecified AddressOrAlias kind
aoa ->
case forall {k} (a :: k) (b :: k) (t :: k -> *).
(SingI a, SingI b, SDecide k) =>
t a -> Maybe (t b)
forall (a :: AddressKind) (b :: AddressKind)
(t :: AddressKind -> *).
(SingI a, SingI b, SDecide AddressKind) =>
t a -> Maybe (t b)
castSing @_ @kind AddressOrAlias kind
aoa ((L1AddressKind kind, SingI kind) => Maybe (AddressOrAlias kind))
-> Dict (L1AddressKind kind, SingI kind)
-> Maybe (AddressOrAlias kind)
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ AddressOrAlias kind -> Dict (L1AddressKind kind, SingI kind)
forall (kind :: AddressKind).
AddressOrAlias kind -> Dict (L1AddressKind kind, SingI kind)
addressOrAliasKindSanity AddressOrAlias kind
aoa of
Just AddressOrAlias kind
aoa' -> AddressOrAlias kind -> ReadM (AddressOrAlias kind)
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AddressOrAlias kind
aoa'
Maybe (AddressOrAlias kind)
Nothing -> String -> ReadM (AddressOrAlias kind)
forall a. String -> ReadM a
Opt.readerError
let expectedKind :: Demote AddressKind
expectedKind = forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: AddressKind).
(SingKind AddressKind, SingI a) =>
Demote AddressKind
demote @kind in
[itu|Unexpected address kind: expected #{expectedKind} address or alias, but got: '#{aoa}'|]
SAOAKindUnspecified Text
aliasText ->
AddressOrAlias kind -> ReadM (AddressOrAlias kind)
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AddressOrAlias kind -> ReadM (AddressOrAlias kind))
-> AddressOrAlias kind -> ReadM (AddressOrAlias kind)
forall a b. (a -> b) -> a -> b
$ Alias kind -> AddressOrAlias kind
forall (kind :: AddressKind). Alias kind -> AddressOrAlias kind
AddressAlias (Alias kind -> AddressOrAlias kind)
-> Alias kind -> AddressOrAlias kind
forall a b. (a -> b) -> a -> b
$ Text -> Alias kind
forall (kind :: AddressKind).
(SingI kind, L1AddressKind kind) =>
Text -> Alias kind
mkAlias Text
aliasText
getMetavar :: String
getMetavar = ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
Char.toUpper ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ AddressKind -> String
forall a b. (Buildable a, FromDoc b) => a -> b
pretty (AddressKind -> String) -> AddressKind -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: AddressKind).
(SingKind AddressKind, SingI a) =>
Demote AddressKind
demote @kind) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" ADDRESS OR ALIAS"
instance Buildable (AddressOrAlias kind) where
build :: AddressOrAlias kind -> Doc
build = \case
AddressResolved KindedAddress kind
addr -> KindedAddress kind -> Doc
forall a. Buildable a => a -> Doc
build KindedAddress kind
addr
AddressAlias Alias kind
alias -> forall (addressKind :: AddressKind).
(L1AddressKind addressKind, SingI addressKind) =>
Doc
aliasPrefix @kind Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
":" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Alias kind -> Doc
forall a. Buildable a => a -> Doc
build Alias kind
alias ((L1AddressKind kind, SingI kind) => Doc)
-> Dict (L1AddressKind kind, SingI kind) -> Doc
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ Alias kind -> Dict (L1AddressKind kind, SingI kind)
forall (kind :: AddressKind).
Alias kind -> Dict (L1AddressKind kind, SingI kind)
aliasKindSanity Alias kind
alias
type ImplicitAddressOrAlias = AddressOrAlias 'AddressKindImplicit
type ContractAddressOrAlias = AddressOrAlias 'AddressKindContract
addressOrAliasKindSanity :: forall kind. AddressOrAlias kind -> Dict (L1AddressKind kind, SingI kind)
addressOrAliasKindSanity :: forall (kind :: AddressKind).
AddressOrAlias kind -> Dict (L1AddressKind kind, SingI kind)
addressOrAliasKindSanity = \case
AddressResolved KindedAddress kind
addr -> Dict (L1AddressKind kind, SingI kind)
SingI kind => Dict (L1AddressKind kind, SingI kind)
forall (a :: Constraint). a => Dict a
Dict (SingI kind => Dict (L1AddressKind kind, SingI kind))
-> Dict (SingI kind) -> Dict (L1AddressKind kind, SingI kind)
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ KindedAddress kind -> Dict (SingI kind)
forall (kind :: AddressKind).
KindedAddress kind -> Dict (SingI kind)
addressKindSanity KindedAddress kind
addr
AddressAlias Alias kind
alias -> Alias kind -> Dict (L1AddressKind kind, SingI kind)
forall (kind :: AddressKind).
Alias kind -> Dict (L1AddressKind kind, SingI kind)
aliasKindSanity Alias kind
alias
data SomeAddressOrAlias where
SAOAKindSpecified :: AddressOrAlias kind -> SomeAddressOrAlias
SAOAKindUnspecified :: Text -> SomeAddressOrAlias
deriving stock instance Show SomeAddressOrAlias
instance Buildable SomeAddressOrAlias where
build :: SomeAddressOrAlias -> Doc
build = \case
SAOAKindUnspecified Text
alias -> Text -> Doc
forall a. Buildable a => a -> Doc
build Text
alias
SAOAKindSpecified AddressOrAlias kind
aoa -> AddressOrAlias kind -> Doc
forall a. Buildable a => a -> Doc
build AddressOrAlias kind
aoa
instance HasCLReader SomeAddressOrAlias where
getMetavar :: String
getMetavar = String
"CONTRACT OR IMPLICIT ADDRESS OR ALIAS"
getReader :: ReadM SomeAddressOrAlias
getReader =
ReadM Text
forall s. IsString s => ReadM s
Opt.str ReadM Text
-> (Text -> ReadM SomeAddressOrAlias) -> ReadM SomeAddressOrAlias
forall a b. ReadM a -> (a -> ReadM b) -> ReadM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
str ->
case Text -> Either ParseAddressError Address
parseAddress Text
str of
Right (Constrained KindedAddress a
addr) ->
case KindedAddress a
addr of
ImplicitAddress{} -> SomeAddressOrAlias -> ReadM SomeAddressOrAlias
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeAddressOrAlias -> ReadM SomeAddressOrAlias)
-> SomeAddressOrAlias -> ReadM SomeAddressOrAlias
forall a b. (a -> b) -> a -> b
$ AddressOrAlias a -> SomeAddressOrAlias
forall (kind :: AddressKind).
AddressOrAlias kind -> SomeAddressOrAlias
SAOAKindSpecified (AddressOrAlias a -> SomeAddressOrAlias)
-> AddressOrAlias a -> SomeAddressOrAlias
forall a b. (a -> b) -> a -> b
$ KindedAddress a -> AddressOrAlias a
forall (kind :: AddressKind).
L1AddressKind kind =>
KindedAddress kind -> AddressOrAlias kind
AddressResolved KindedAddress a
addr
ContractAddress{} -> SomeAddressOrAlias -> ReadM SomeAddressOrAlias
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeAddressOrAlias -> ReadM SomeAddressOrAlias)
-> SomeAddressOrAlias -> ReadM SomeAddressOrAlias
forall a b. (a -> b) -> a -> b
$ AddressOrAlias a -> SomeAddressOrAlias
forall (kind :: AddressKind).
AddressOrAlias kind -> SomeAddressOrAlias
SAOAKindSpecified (AddressOrAlias a -> SomeAddressOrAlias)
-> AddressOrAlias a -> SomeAddressOrAlias
forall a b. (a -> b) -> a -> b
$ KindedAddress a -> AddressOrAlias a
forall (kind :: AddressKind).
L1AddressKind kind =>
KindedAddress kind -> AddressOrAlias kind
AddressResolved KindedAddress a
addr
SmartRollupAddress{} -> String -> ReadM SomeAddressOrAlias
forall a. String -> ReadM a
Opt.readerError (String -> ReadM SomeAddressOrAlias)
-> String -> ReadM SomeAddressOrAlias
forall a b. (a -> b) -> a -> b
$ String
"Unexpected smart rollup address: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> KindedAddress a -> String
forall a b. (Buildable a, FromDoc b) => a -> b
pretty KindedAddress a
addr
Left ParseAddressError
_ ->
SomeAddressOrAlias -> ReadM SomeAddressOrAlias
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeAddressOrAlias -> ReadM SomeAddressOrAlias)
-> SomeAddressOrAlias -> ReadM SomeAddressOrAlias
forall a b. (a -> b) -> a -> b
$
forall (kind :: AddressKind).
(L1AddressKind kind, SingI kind) =>
Text -> Maybe SomeAddressOrAlias
parseAliasWithPrefix @'AddressKindImplicit Text
str Maybe SomeAddressOrAlias
-> Maybe SomeAddressOrAlias -> Maybe SomeAddressOrAlias
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (kind :: AddressKind).
(L1AddressKind kind, SingI kind) =>
Text -> Maybe SomeAddressOrAlias
parseAliasWithPrefix @'AddressKindContract Text
str
Maybe SomeAddressOrAlias
-> (Maybe SomeAddressOrAlias -> SomeAddressOrAlias)
-> SomeAddressOrAlias
forall a b. a -> (a -> b) -> b
& SomeAddressOrAlias
-> Maybe SomeAddressOrAlias -> SomeAddressOrAlias
forall a. a -> Maybe a -> a
fromMaybe (Text -> SomeAddressOrAlias
SAOAKindUnspecified Text
str)
where
parseAliasWithPrefix
:: forall kind. (L1AddressKind kind, SingI kind)
=> Text
-> Maybe SomeAddressOrAlias
parseAliasWithPrefix :: forall (kind :: AddressKind).
(L1AddressKind kind, SingI kind) =>
Text -> Maybe SomeAddressOrAlias
parseAliasWithPrefix Text
str =
Text -> Text -> Maybe Text
T.stripPrefix (Doc -> Text
forall a b. (Buildable a, FromDoc b) => a -> b
pretty (Doc -> Text) -> Doc -> Text
forall a b. (a -> b) -> a -> b
$ forall (addressKind :: AddressKind).
(L1AddressKind addressKind, SingI addressKind) =>
Doc
aliasPrefix @kind Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
":") Text
str Maybe Text
-> (Text -> SomeAddressOrAlias) -> Maybe SomeAddressOrAlias
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Text
alias ->
AddressOrAlias kind -> SomeAddressOrAlias
forall (kind :: AddressKind).
AddressOrAlias kind -> SomeAddressOrAlias
SAOAKindSpecified (AddressOrAlias kind -> SomeAddressOrAlias)
-> AddressOrAlias kind -> SomeAddressOrAlias
forall a b. (a -> b) -> a -> b
$ Alias kind -> AddressOrAlias kind
forall (kind :: AddressKind). Alias kind -> AddressOrAlias kind
AddressAlias (Alias kind -> AddressOrAlias kind)
-> Alias kind -> AddressOrAlias kind
forall a b. (a -> b) -> a -> b
$ forall (kind :: AddressKind).
(SingI kind, L1AddressKind kind) =>
Text -> Alias kind
mkAlias @kind Text
alias
aliasPrefix :: forall addressKind. (L1AddressKind addressKind, SingI addressKind) => Doc
aliasPrefix :: forall (addressKind :: AddressKind).
(L1AddressKind addressKind, SingI addressKind) =>
Doc
aliasPrefix =
forall (kind :: AddressKind) a. L1AddressKind kind => a -> a
usingImplicitOrContractKind @addressKind (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
AddressKind -> Doc
forall a. Buildable a => a -> Doc
build (AddressKind -> Doc) -> AddressKind -> Doc
forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: AddressKind).
(SingKind AddressKind, SingI a) =>
Demote AddressKind
demote @addressKind
contractPrefix, implicitPrefix :: Doc
contractPrefix :: Doc
contractPrefix = forall (addressKind :: AddressKind).
(L1AddressKind addressKind, SingI addressKind) =>
Doc
aliasPrefix @'AddressKindContract
implicitPrefix :: Doc
implicitPrefix = forall (addressKind :: AddressKind).
(L1AddressKind addressKind, SingI addressKind) =>
Doc
aliasPrefix @'AddressKindImplicit