module Cardano.YTxP (
  YTxPParams,
  validatorLinker,
  stakeValidatorLinker,
  mintingPolicyLinker,
) where

import Data.Aeson (FromJSON, ToJSON)
import Data.Coerce (coerce)
import Data.Map (fromList)
import Data.Text (Text, pack)

import Cardano.YTxP.SDK.SdkParameters (
  AuthorisedScriptsSTCS (AuthorisedScriptsSTCS),
  SdkParameters (
    authorisedScriptsSTCS,
    mintingPoliciesNonceList,
    stakingValidatorsNonceList
  ),
 )

import PlutusLedgerApi.V2 (CurrencySymbol)
import Ply qualified

import Plutarch (Config (NoTracing), Script (Script), compile)
import Plutarch.Lift (PLifted, PUnsafeLiftDecl)
import PlutusPrelude (unsafeFromRight)
import Ply.Core.Unsafe (unsafeTypedScript, unsafeUnTypedScript')
import ScriptExport.ScriptInfo (
  Linker,
  ScriptExport (ScriptExport),
  ScriptRole (ThreeArgumentScript, TwoArgumentScript),
  fetchTS,
  getParam,
  toRoledScript,
 )
import UntypedPlutusCore (applyProgram)

--------------------------------------------------------------------------------

data YTxPParams = YTxPParams
  { YTxPParams -> SdkParameters
params :: SdkParameters
  , YTxPParams -> Text
commitHash :: Text
  }
  deriving stock (Int -> YTxPParams -> ShowS
[YTxPParams] -> ShowS
YTxPParams -> String
(Int -> YTxPParams -> ShowS)
-> (YTxPParams -> String)
-> ([YTxPParams] -> ShowS)
-> Show YTxPParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> YTxPParams -> ShowS
showsPrec :: Int -> YTxPParams -> ShowS
$cshow :: YTxPParams -> String
show :: YTxPParams -> String
$cshowList :: [YTxPParams] -> ShowS
showList :: [YTxPParams] -> ShowS
Show, (forall x. YTxPParams -> Rep YTxPParams x)
-> (forall x. Rep YTxPParams x -> YTxPParams) -> Generic YTxPParams
forall x. Rep YTxPParams x -> YTxPParams
forall x. YTxPParams -> Rep YTxPParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. YTxPParams -> Rep YTxPParams x
from :: forall x. YTxPParams -> Rep YTxPParams x
$cto :: forall x. Rep YTxPParams x -> YTxPParams
to :: forall x. Rep YTxPParams x -> YTxPParams
Generic, YTxPParams -> YTxPParams -> Bool
(YTxPParams -> YTxPParams -> Bool)
-> (YTxPParams -> YTxPParams -> Bool) -> Eq YTxPParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: YTxPParams -> YTxPParams -> Bool
== :: YTxPParams -> YTxPParams -> Bool
$c/= :: YTxPParams -> YTxPParams -> Bool
/= :: YTxPParams -> YTxPParams -> Bool
Eq)
  deriving anyclass ([YTxPParams] -> Value
[YTxPParams] -> Encoding
YTxPParams -> Bool
YTxPParams -> Value
YTxPParams -> Encoding
(YTxPParams -> Value)
-> (YTxPParams -> Encoding)
-> ([YTxPParams] -> Value)
-> ([YTxPParams] -> Encoding)
-> (YTxPParams -> Bool)
-> ToJSON YTxPParams
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: YTxPParams -> Value
toJSON :: YTxPParams -> Value
$ctoEncoding :: YTxPParams -> Encoding
toEncoding :: YTxPParams -> Encoding
$ctoJSONList :: [YTxPParams] -> Value
toJSONList :: [YTxPParams] -> Value
$ctoEncodingList :: [YTxPParams] -> Encoding
toEncodingList :: [YTxPParams] -> Encoding
$comitField :: YTxPParams -> Bool
omitField :: YTxPParams -> Bool
ToJSON, Maybe YTxPParams
Value -> Parser [YTxPParams]
Value -> Parser YTxPParams
(Value -> Parser YTxPParams)
-> (Value -> Parser [YTxPParams])
-> Maybe YTxPParams
-> FromJSON YTxPParams
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser YTxPParams
parseJSON :: Value -> Parser YTxPParams
$cparseJSONList :: Value -> Parser [YTxPParams]
parseJSONList :: Value -> Parser [YTxPParams]
$comittedField :: Maybe YTxPParams
omittedField :: Maybe YTxPParams
FromJSON)

{- | Apply a Plutarch (Haskell lifted) term to a script
| We use it instead of Ply.# due to issues with encoding encountered.
-}
ap :: (PUnsafeLiftDecl x) => Ply.TypedScript r (PLifted x ': xs) -> PLifted x -> Ply.TypedScript r xs
ap :: forall (x :: PType) (r :: ScriptRole) (xs :: [Type]).
PUnsafeLiftDecl x =>
TypedScript r ((':) @Type (PLifted x) xs)
-> PLifted x -> TypedScript r xs
ap TypedScript r ((':) @Type (PLifted x) xs)
ts PLifted x
x = ScriptVersion -> UPLCProgram -> TypedScript r xs
forall (r :: ScriptRole) (a :: [Type]).
ScriptVersion -> UPLCProgram -> TypedScript r a
unsafeTypedScript ScriptVersion
ver (UPLCProgram -> TypedScript r xs)
-> UPLCProgram -> TypedScript r xs
forall a b. (a -> b) -> a -> b
$ Either ApplyProgramError UPLCProgram -> UPLCProgram
forall e a. Show e => Either e a -> a
unsafeFromRight (Either ApplyProgramError UPLCProgram -> UPLCProgram)
-> Either ApplyProgramError UPLCProgram -> UPLCProgram
forall a b. (a -> b) -> a -> b
$ UPLCProgram
prog UPLCProgram -> UPLCProgram -> Either ApplyProgramError UPLCProgram
forall (m :: Type -> Type) a name (uni :: Type -> Type) fun.
(MonadError ApplyProgramError m, Semigroup a) =>
Program name uni fun a
-> Program name uni fun a -> m (Program name uni fun a)
`applyProgram` UPLCProgram
xc
  where
    (ScriptVersion
ver, UPLCProgram
prog) = TypedScript r ((':) @Type (PLifted x) xs)
-> (ScriptVersion, UPLCProgram)
forall (r :: ScriptRole) (a :: [Type]).
TypedScript r a -> (ScriptVersion, UPLCProgram)
unsafeUnTypedScript' TypedScript r ((':) @Type (PLifted x) xs)
ts
    Script UPLCProgram
xc = Either Text Script -> Script
forall e a. Show e => Either e a -> a
unsafeFromRight (Either Text Script -> Script) -> Either Text Script -> Script
forall a b. (a -> b) -> a -> b
$ Config -> ClosedTerm x -> Either Text Script
forall (a :: PType). Config -> ClosedTerm a -> Either Text Script
compile Config
NoTracing (ClosedTerm x -> Either Text Script)
-> ClosedTerm x -> Either Text Script
forall a b. (a -> b) -> a -> b
$ PLifted x -> Term s x
forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant PLifted x
x

validatorLinker :: Linker SdkParameters (ScriptExport SdkParameters)
validatorLinker :: Linker SdkParameters (ScriptExport SdkParameters)
validatorLinker = do
  SdkParameters
info <- Linker SdkParameters SdkParameters
forall lparam. Linker lparam lparam
getParam

  TypedScript
  'ThreeArgumentScript ((':) @Type CurrencySymbol ('[] @Type))
yieldingValidator <-
    forall (rl :: ScriptRole) (params :: [Type]) lparam.
TypedReader rl params =>
Text -> Linker lparam (TypedScript rl params)
fetchTS
      @'ThreeArgumentScript
      @'[CurrencySymbol]
      Text
"ytxp:yieldingValidator"

  let
    authorisedScriptsSymbol :: CurrencySymbol
authorisedScriptsSymbol =
      forall a b. Coercible @Type a b => a -> b
forall a b. Coercible @Type a b => a -> b
coerce @_ @CurrencySymbol (SdkParameters -> AuthorisedScriptsSTCS
authorisedScriptsSTCS SdkParameters
info)

    yieldingValidator' :: TypedScript 'ThreeArgumentScript ('[] @Type)
yieldingValidator' =
      TypedScript
  'ThreeArgumentScript ((':) @Type CurrencySymbol ('[] @Type))
TypedScript
  'ThreeArgumentScript
  ((':) @Type (PLifted PCurrencySymbol) ('[] @Type))
yieldingValidator TypedScript
  'ThreeArgumentScript
  ((':) @Type (PLifted PCurrencySymbol) ('[] @Type))
-> PLifted PCurrencySymbol
-> TypedScript 'ThreeArgumentScript ('[] @Type)
forall (x :: PType) (r :: ScriptRole) (xs :: [Type]).
PUnsafeLiftDecl x =>
TypedScript r ((':) @Type (PLifted x) xs)
-> PLifted x -> TypedScript r xs
`ap` CurrencySymbol
PLifted PCurrencySymbol
authorisedScriptsSymbol

  ScriptExport SdkParameters
-> Linker SdkParameters (ScriptExport SdkParameters)
forall a. a -> Linker SdkParameters a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ScriptExport SdkParameters
 -> Linker SdkParameters (ScriptExport SdkParameters))
-> ScriptExport SdkParameters
-> Linker SdkParameters (ScriptExport SdkParameters)
forall a b. (a -> b) -> a -> b
$
    Map Text RoledScript -> SdkParameters -> ScriptExport SdkParameters
forall a. Map Text RoledScript -> a -> ScriptExport a
ScriptExport
      ( [(Text, RoledScript)] -> Map Text RoledScript
forall k a. Ord k => [(k, a)] -> Map k a
fromList
          [(Text
"ytxp:yieldingValidator", TypedScript 'ThreeArgumentScript ('[] @Type) -> RoledScript
forall (rl :: ScriptRole) (param :: [Type]).
ToRoledScript rl =>
TypedScript rl param -> RoledScript
toRoledScript TypedScript 'ThreeArgumentScript ('[] @Type)
yieldingValidator')]
      )
      SdkParameters
info

mintingPolicyLinker :: Linker SdkParameters (ScriptExport SdkParameters)
mintingPolicyLinker :: Linker SdkParameters (ScriptExport SdkParameters)
mintingPolicyLinker = do
  SdkParameters
info <- Linker SdkParameters SdkParameters
forall lparam. Linker lparam lparam
getParam

  TypedScript
  'TwoArgumentScript
  ((':) @Type CurrencySymbol ((':) @Type Integer ('[] @Type)))
yieldingMP <-
    forall (rl :: ScriptRole) (params :: [Type]) lparam.
TypedReader rl params =>
Text -> Linker lparam (TypedScript rl params)
fetchTS
      @'TwoArgumentScript
      @'[CurrencySymbol, Integer]
      Text
"ytxp:yieldingMintingPolicy"

  let
    authorisedScriptsSymbol :: CurrencySymbol
authorisedScriptsSymbol =
      forall a b. Coercible @Type a b => a -> b
forall a b. Coercible @Type a b => a -> b
coerce @_ @CurrencySymbol (SdkParameters -> AuthorisedScriptsSTCS
authorisedScriptsSTCS SdkParameters
info)

    yieldingMPs :: [(Text, RoledScript)]
yieldingMPs =
      (Natural -> (Text, RoledScript))
-> [Natural] -> [(Text, RoledScript)]
forall a b. (a -> b) -> [a] -> [b]
map
        ( \Natural
nonce ->
            ( String -> Text
pack (String
"ytxp:yieldingMintingPolicy:" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall a. Show a => a -> String
show Natural
nonce)
            , TypedScript 'TwoArgumentScript ('[] @Type) -> RoledScript
forall (rl :: ScriptRole) (param :: [Type]).
ToRoledScript rl =>
TypedScript rl param -> RoledScript
toRoledScript (TypedScript 'TwoArgumentScript ('[] @Type) -> RoledScript)
-> TypedScript 'TwoArgumentScript ('[] @Type) -> RoledScript
forall a b. (a -> b) -> a -> b
$
                TypedScript
  'TwoArgumentScript
  ((':) @Type CurrencySymbol ((':) @Type Integer ('[] @Type)))
TypedScript
  'TwoArgumentScript
  ((':)
     @Type (PLifted PCurrencySymbol) ((':) @Type Integer ('[] @Type)))
yieldingMP TypedScript
  'TwoArgumentScript
  ((':)
     @Type (PLifted PCurrencySymbol) ((':) @Type Integer ('[] @Type)))
-> PLifted PCurrencySymbol
-> TypedScript 'TwoArgumentScript ((':) @Type Integer ('[] @Type))
forall (x :: PType) (r :: ScriptRole) (xs :: [Type]).
PUnsafeLiftDecl x =>
TypedScript r ((':) @Type (PLifted x) xs)
-> PLifted x -> TypedScript r xs
`ap` CurrencySymbol
PLifted PCurrencySymbol
authorisedScriptsSymbol TypedScript
  'TwoArgumentScript ((':) @Type (PLifted PInteger) ('[] @Type))
-> PLifted PInteger -> TypedScript 'TwoArgumentScript ('[] @Type)
forall (x :: PType) (r :: ScriptRole) (xs :: [Type]).
PUnsafeLiftDecl x =>
TypedScript r ((':) @Type (PLifted x) xs)
-> PLifted x -> TypedScript r xs
`ap` Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
nonce
            )
        )
        (SdkParameters -> [Natural]
mintingPoliciesNonceList SdkParameters
info)

  ScriptExport SdkParameters
-> Linker SdkParameters (ScriptExport SdkParameters)
forall a. a -> Linker SdkParameters a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ScriptExport SdkParameters
 -> Linker SdkParameters (ScriptExport SdkParameters))
-> ScriptExport SdkParameters
-> Linker SdkParameters (ScriptExport SdkParameters)
forall a b. (a -> b) -> a -> b
$
    Map Text RoledScript -> SdkParameters -> ScriptExport SdkParameters
forall a. Map Text RoledScript -> a -> ScriptExport a
ScriptExport
      ([(Text, RoledScript)] -> Map Text RoledScript
forall k a. Ord k => [(k, a)] -> Map k a
fromList [(Text, RoledScript)]
yieldingMPs)
      SdkParameters
info

stakeValidatorLinker :: Linker SdkParameters (ScriptExport SdkParameters)
stakeValidatorLinker :: Linker SdkParameters (ScriptExport SdkParameters)
stakeValidatorLinker = do
  SdkParameters
info <- Linker SdkParameters SdkParameters
forall lparam. Linker lparam lparam
getParam

  TypedScript
  'TwoArgumentScript
  ((':) @Type CurrencySymbol ((':) @Type Integer ('[] @Type)))
yieldingSV <-
    forall (rl :: ScriptRole) (params :: [Type]) lparam.
TypedReader rl params =>
Text -> Linker lparam (TypedScript rl params)
fetchTS
      @'TwoArgumentScript
      @'[CurrencySymbol, Integer]
      Text
"ytxp:yieldingStakeValidator"

  let
    authorisedScriptsSymbol :: CurrencySymbol
authorisedScriptsSymbol =
      forall a b. Coercible @Type a b => a -> b
forall a b. Coercible @Type a b => a -> b
coerce @_ @CurrencySymbol (SdkParameters -> AuthorisedScriptsSTCS
authorisedScriptsSTCS SdkParameters
info)

    yieldingSVs :: [(Text, RoledScript)]
yieldingSVs =
      (Natural -> (Text, RoledScript))
-> [Natural] -> [(Text, RoledScript)]
forall a b. (a -> b) -> [a] -> [b]
map
        ( \Natural
nonce ->
            ( String -> Text
pack (String
"ytxp:yieldingStakeValidator:" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall a. Show a => a -> String
show Natural
nonce)
            , TypedScript 'TwoArgumentScript ('[] @Type) -> RoledScript
forall (rl :: ScriptRole) (param :: [Type]).
ToRoledScript rl =>
TypedScript rl param -> RoledScript
toRoledScript (TypedScript 'TwoArgumentScript ('[] @Type) -> RoledScript)
-> TypedScript 'TwoArgumentScript ('[] @Type) -> RoledScript
forall a b. (a -> b) -> a -> b
$
                TypedScript
  'TwoArgumentScript
  ((':) @Type CurrencySymbol ((':) @Type Integer ('[] @Type)))
TypedScript
  'TwoArgumentScript
  ((':)
     @Type (PLifted PCurrencySymbol) ((':) @Type Integer ('[] @Type)))
yieldingSV TypedScript
  'TwoArgumentScript
  ((':)
     @Type (PLifted PCurrencySymbol) ((':) @Type Integer ('[] @Type)))
-> PLifted PCurrencySymbol
-> TypedScript 'TwoArgumentScript ((':) @Type Integer ('[] @Type))
forall (x :: PType) (r :: ScriptRole) (xs :: [Type]).
PUnsafeLiftDecl x =>
TypedScript r ((':) @Type (PLifted x) xs)
-> PLifted x -> TypedScript r xs
`ap` CurrencySymbol
PLifted PCurrencySymbol
authorisedScriptsSymbol TypedScript
  'TwoArgumentScript ((':) @Type (PLifted PInteger) ('[] @Type))
-> PLifted PInteger -> TypedScript 'TwoArgumentScript ('[] @Type)
forall (x :: PType) (r :: ScriptRole) (xs :: [Type]).
PUnsafeLiftDecl x =>
TypedScript r ((':) @Type (PLifted x) xs)
-> PLifted x -> TypedScript r xs
`ap` Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
nonce
            )
        )
        (SdkParameters -> [Natural]
stakingValidatorsNonceList SdkParameters
info)

  ScriptExport SdkParameters
-> Linker SdkParameters (ScriptExport SdkParameters)
forall a. a -> Linker SdkParameters a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ScriptExport SdkParameters
 -> Linker SdkParameters (ScriptExport SdkParameters))
-> ScriptExport SdkParameters
-> Linker SdkParameters (ScriptExport SdkParameters)
forall a b. (a -> b) -> a -> b
$
    Map Text RoledScript -> SdkParameters -> ScriptExport SdkParameters
forall a. Map Text RoledScript -> a -> ScriptExport a
ScriptExport
      ([(Text, RoledScript)] -> Map Text RoledScript
forall k a. Ord k => [(k, a)] -> Map k a
fromList [(Text, RoledScript)]
yieldingSVs)
      SdkParameters
info