-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

module Morley.Tezos.Address.Alias
  ( AddressOrAlias(..)
  , Alias(..)
  , SomeAlias(..)
  , SomeAddressOrAlias(..)
  , ImplicitAlias
  , ContractAlias
  , ImplicitAddressOrAlias
  , ContractAddressOrAlias
  , unAlias
  , mkAlias
  , aliasKindSanity
  )
  where

import Data.Aeson (FromJSON(..), ToJSON(..))
import Data.Constraint (Dict(..), (\\))
import Data.Singletons (SingI(..), demote)
import Data.Type.Equality ((:~:)(..))
import Fmt (Buildable(..), nameF, pretty, (+|), (|+))
import Options.Applicative qualified as Opt

import Morley.Tezos.Address
import Morley.Tezos.Address.Kinds
import Morley.Util.CLI (HasCLReader(..))
import Morley.Util.Sing

-- | @tezos-client@ can associate addresses with textual aliases.
-- This type denotes such an alias.
data Alias (kind :: AddressKind) where
  ImplicitAlias :: Text -> Alias 'AddressKindImplicit
  ContractAlias :: Text -> Alias 'AddressKindContract

-- | A type only allowing v'ImplicitAlias' values.
type ImplicitAlias = Alias 'AddressKindImplicit

-- | A type only allowing v'ContractAlias' values.
type ContractAlias = Alias 'AddressKindContract

deriving stock instance Show (Alias kind)
deriving stock instance Eq (Alias kind)
deriving stock instance Ord (Alias kind)

-- | Get raw alias text from 'Alias'
unAlias :: Alias kind -> Text
unAlias :: forall (kind :: AddressKind). Alias kind -> Text
unAlias = \case
  ImplicitAlias Text
x -> Text
x
  ContractAlias Text
x -> Text
x

-- | Construct an 'Alias' from alias 'Text'.
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 -> Builder
build = Text -> Builder
forall p. Buildable p => p -> Builder
build (Text -> Builder) -> (Alias kind -> Text) -> Alias kind -> Builder
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 (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

-- | Existential wrapper over 'Alias'.
data SomeAlias = forall kind. SomeAlias (Alias kind)

deriving stock instance Show SomeAlias

instance Buildable SomeAlias where
  build :: SomeAlias -> Builder
build (SomeAlias Alias kind
x) = Alias kind -> Builder
forall p. Buildable p => p -> Builder
build Alias kind
x

-- | Given an 'Alias', prove it's @kind@ is well-defined (i.e. it has a 'SingI'
-- instance and satisfies 'L1AddressKind' constraint)
aliasKindSanity :: Alias kind -> Dict (L1AddressKind kind, SingI kind)
aliasKindSanity :: forall (kind :: AddressKind).
Alias kind -> Dict (L1AddressKind kind, SingI kind)
aliasKindSanity = \case
  ImplicitAlias{} -> Dict (L1AddressKind kind, SingI kind)
forall (a :: Constraint). a => Dict a
Dict
  ContractAlias{} -> Dict (L1AddressKind kind, SingI kind)
forall (a :: Constraint). a => Dict a
Dict

-- | Representation of an address that @tezos-client@ uses. It can be
-- an address itself or a textual alias.
data AddressOrAlias kind
  = AddressResolved (KindedAddress kind)
  -- ^ Address itself, can be used as is.
  | AddressAlias (Alias kind)
  -- ^ Address alias, should be resolved by @tezos-client@.
  deriving stock (Int -> AddressOrAlias kind -> ShowS
[AddressOrAlias kind] -> ShowS
AddressOrAlias kind -> String
(Int -> AddressOrAlias kind -> ShowS)
-> (AddressOrAlias kind -> String)
-> ([AddressOrAlias kind] -> ShowS)
-> Show (AddressOrAlias kind)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (kind :: AddressKind). Int -> AddressOrAlias kind -> ShowS
forall (kind :: AddressKind). [AddressOrAlias kind] -> ShowS
forall (kind :: AddressKind). AddressOrAlias kind -> String
showList :: [AddressOrAlias kind] -> ShowS
$cshowList :: forall (kind :: AddressKind). [AddressOrAlias kind] -> ShowS
show :: AddressOrAlias kind -> String
$cshow :: forall (kind :: AddressKind). AddressOrAlias kind -> String
showsPrec :: Int -> AddressOrAlias kind -> ShowS
$cshowsPrec :: forall (kind :: AddressKind). Int -> AddressOrAlias kind -> ShowS
Show, AddressOrAlias kind -> AddressOrAlias kind -> Bool
(AddressOrAlias kind -> AddressOrAlias kind -> Bool)
-> (AddressOrAlias kind -> AddressOrAlias kind -> Bool)
-> Eq (AddressOrAlias kind)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (kind :: AddressKind).
AddressOrAlias kind -> AddressOrAlias kind -> Bool
/= :: AddressOrAlias kind -> AddressOrAlias kind -> Bool
$c/= :: forall (kind :: AddressKind).
AddressOrAlias kind -> AddressOrAlias kind -> Bool
== :: AddressOrAlias kind -> AddressOrAlias kind -> Bool
$c== :: forall (kind :: AddressKind).
AddressOrAlias kind -> AddressOrAlias kind -> Bool
Eq, Eq (AddressOrAlias kind)
Eq (AddressOrAlias kind)
-> (AddressOrAlias kind -> AddressOrAlias kind -> Ordering)
-> (AddressOrAlias kind -> AddressOrAlias kind -> Bool)
-> (AddressOrAlias kind -> AddressOrAlias kind -> Bool)
-> (AddressOrAlias kind -> AddressOrAlias kind -> Bool)
-> (AddressOrAlias kind -> AddressOrAlias kind -> Bool)
-> (AddressOrAlias kind
    -> AddressOrAlias kind -> AddressOrAlias kind)
-> (AddressOrAlias kind
    -> AddressOrAlias kind -> AddressOrAlias kind)
-> Ord (AddressOrAlias kind)
AddressOrAlias kind -> AddressOrAlias kind -> Bool
AddressOrAlias kind -> AddressOrAlias kind -> Ordering
AddressOrAlias kind -> AddressOrAlias kind -> AddressOrAlias kind
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
forall (kind :: AddressKind). Eq (AddressOrAlias kind)
forall (kind :: AddressKind).
AddressOrAlias kind -> AddressOrAlias kind -> Bool
forall (kind :: AddressKind).
AddressOrAlias kind -> AddressOrAlias kind -> Ordering
forall (kind :: AddressKind).
AddressOrAlias kind -> AddressOrAlias kind -> AddressOrAlias kind
min :: AddressOrAlias kind -> AddressOrAlias kind -> AddressOrAlias kind
$cmin :: forall (kind :: AddressKind).
AddressOrAlias kind -> AddressOrAlias kind -> AddressOrAlias kind
max :: AddressOrAlias kind -> AddressOrAlias kind -> AddressOrAlias kind
$cmax :: forall (kind :: AddressKind).
AddressOrAlias kind -> AddressOrAlias kind -> AddressOrAlias kind
>= :: AddressOrAlias kind -> AddressOrAlias kind -> Bool
$c>= :: forall (kind :: AddressKind).
AddressOrAlias kind -> AddressOrAlias kind -> Bool
> :: AddressOrAlias kind -> AddressOrAlias kind -> Bool
$c> :: forall (kind :: AddressKind).
AddressOrAlias kind -> AddressOrAlias kind -> Bool
<= :: AddressOrAlias kind -> AddressOrAlias kind -> Bool
$c<= :: forall (kind :: AddressKind).
AddressOrAlias kind -> AddressOrAlias kind -> Bool
< :: AddressOrAlias kind -> AddressOrAlias kind -> Bool
$c< :: forall (kind :: AddressKind).
AddressOrAlias kind -> AddressOrAlias kind -> Bool
compare :: AddressOrAlias kind -> AddressOrAlias kind -> Ordering
$ccompare :: forall (kind :: AddressKind).
AddressOrAlias kind -> AddressOrAlias kind -> Ordering
Ord)

instance (SingI kind, L1AddressKind kind) => HasCLReader (AddressOrAlias kind) where
  getReader :: ReadM (AddressOrAlias kind)
getReader =
    ReadM Text
forall s. IsString s => ReadM s
Opt.str ReadM Text
-> (Text -> ReadM (AddressOrAlias kind))
-> ReadM (AddressOrAlias kind)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
addrOrAlias ->
      case Text -> Either ParseAddressError Address
parseAddress Text
addrOrAlias of
        Right (MkAddress (KindedAddress kind
addr :: KindedAddress kind')) ->
          case forall {k} (a :: k) (b :: k).
(SingI a, SingI b, TestEquality Sing) =>
Maybe (a :~: b)
forall (a :: AddressKind) (b :: AddressKind).
(SingI a, SingI b, TestEquality Sing) =>
Maybe (a :~: b)
eqI @kind @kind' (SingI kind => Maybe (kind :~: kind))
-> Dict (SingI kind) -> Maybe (kind :~: 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 of
            Just kind :~: kind
Refl -> AddressOrAlias kind -> ReadM (AddressOrAlias kind)
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
$ KindedAddress kind -> AddressOrAlias kind
forall (kind :: AddressKind).
KindedAddress kind -> AddressOrAlias kind
AddressResolved KindedAddress kind
addr
            Maybe (kind :~: kind)
Nothing -> String -> ReadM (AddressOrAlias kind)
forall a. String -> ReadM a
Opt.readerError (String -> ReadM (AddressOrAlias kind))
-> String -> ReadM (AddressOrAlias kind)
forall a b. (a -> b) -> a -> b
$ Builder -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Builder -> String) -> Builder -> String
forall a b. (a -> b) -> a -> b
$ Builder -> Builder -> Builder
nameF Builder
"Unexpected address kind" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
              Builder
"expected " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: AddressKind).
(SingKind AddressKind, SingI a) =>
Demote AddressKind
demote @kind AddressKind -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" address, but got " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| KindedAddress kind
addr KindedAddress kind -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
        Left ParseAddressError
_ -> AddressOrAlias kind -> ReadM (AddressOrAlias kind)
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 (Text -> Alias kind
forall (kind :: AddressKind).
(SingI kind, L1AddressKind kind) =>
Text -> Alias kind
mkAlias Text
addrOrAlias)
  getMetavar :: String
getMetavar = String
"ADDRESS OR ALIAS"

instance Buildable (AddressOrAlias kind) where
  build :: AddressOrAlias kind -> Builder
build = \case
    AddressResolved KindedAddress kind
addr -> KindedAddress kind -> Builder
forall p. Buildable p => p -> Builder
build KindedAddress kind
addr
    AddressAlias Alias kind
alias -> Alias kind -> Builder
forall p. Buildable p => p -> Builder
build Alias kind
alias

-- | Convenience type synonym.
type ImplicitAddressOrAlias = AddressOrAlias 'AddressKindImplicit

-- | Convenience type synonym.
type ContractAddressOrAlias = AddressOrAlias 'AddressKindContract

-- | Existential over 'AddressOrAlias'.
data SomeAddressOrAlias = forall kind. SomeAddressOrAlias (AddressOrAlias kind)

instance Buildable SomeAddressOrAlias where
  build :: SomeAddressOrAlias -> Builder
build (SomeAddressOrAlias AddressOrAlias kind
x) = AddressOrAlias kind -> Builder
forall p. Buildable p => p -> Builder
build AddressOrAlias kind
x

deriving stock instance Show SomeAddressOrAlias