{- |
Module      : Singular.Registry.Blueprint.Params
Description : UPLC parameter application for blueprint compiled code
License     : Apache-2.0

Applies the registry's parameters to the flat-encoded UPLC programs a
blueprint carries: raw 'Data' values, integers, bytes, output
references, the state validator's @previousPolicies@ allowlist, and
the request validator's @(statePolicyId, cageToken)@ pair in source
order.

This is the parameter-application owner extracted from
@Singular.Registry.Blueprint@; the public module re-exports it and is
its only intended consumer surface.
-}
module Singular.Registry.Blueprint.Params
    ( applyDataParam
    , applyIntParam
    , applyBytesParam
    , applyOutputRef
    , applyPreviousPolicies
    , applyRequestParams
    ) where

import Data.ByteString qualified as BS
import Data.ByteString.Short qualified as SBS
import PlutusCore qualified as PLC
import PlutusCore.Data (Data (..))
import PlutusLedgerApi.V3
    ( serialiseUPLC
    , uncheckedDeserialiseUPLC
    )
import PlutusTx.Builtins.Internal
    ( BuiltinByteString (..)
    , BuiltinData (..)
    )
import PlutusTx.IsData.Class (ToData (..))
import Singular.Registry.Types
    ( OnChainTokenId (..)
    , OnChainTxOutRef
    )
import UntypedPlutusCore
    ( Program (..)
    , applyProgram
    )
import UntypedPlutusCore qualified as UPLC
import UntypedPlutusCore.DeBruijn ()

{- | Apply a 'Data' parameter to a UPLC script.
The blueprint's @compiledCode@ is a flat-encoded
UPLC program that expects one parameter. This
function applies the supplied 'Data' value to that
parameter slot, producing the final script bytes.
-}
applyDataParam
    :: Data
    -- ^ Encoded parameter value
    -> SBS.ShortByteString
    -- ^ Flat-encoded UPLC program
    -> SBS.ShortByteString
applyDataParam :: Data -> ShortByteString -> ShortByteString
applyDataParam Data
d ShortByteString
sbs =
    let
        prog :: Program DeBruijn DefaultUni DefaultFun ()
prog = ShortByteString -> Program DeBruijn DefaultUni DefaultFun ()
uncheckedDeserialiseUPLC ShortByteString
sbs
        argProg :: Program name DefaultUni fun ()
argProg =
            ()
-> Version
-> Term name DefaultUni fun ()
-> Program name DefaultUni fun ()
forall name (uni :: * -> *) fun ann.
ann -> Version -> Term name uni fun ann -> Program name uni fun ann
Program
                ()
                (Program DeBruijn DefaultUni DefaultFun () -> Version
forall {name} {uni :: * -> *} {fun} {ann}.
Program name uni fun ann -> Version
progVer Program DeBruijn DefaultUni DefaultFun ()
prog)
                ( () -> Some (ValueOf DefaultUni) -> Term name DefaultUni fun ()
forall name (uni :: * -> *) fun ann.
ann -> Some (ValueOf uni) -> Term name uni fun ann
UPLC.Constant
                    ()
                    ( ValueOf DefaultUni Data -> Some (ValueOf DefaultUni)
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
PLC.Some
                        ( DefaultUni (Esc Data) -> Data -> ValueOf DefaultUni Data
forall (uni :: * -> *) a. uni (Esc a) -> a -> ValueOf uni a
PLC.ValueOf
                            DefaultUni (Esc Data)
PLC.DefaultUniData
                            Data
d
                        )
                    )
                )
        applied :: Program DeBruijn DefaultUni DefaultFun ()
applied = case Program DeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
-> Either
     ApplyProgramError (Program DeBruijn DefaultUni DefaultFun ())
forall (m :: * -> *) a name (uni :: * -> *) fun.
(MonadError ApplyProgramError m, Semigroup a) =>
Program name uni fun a
-> Program name uni fun a -> m (Program name uni fun a)
applyProgram Program DeBruijn DefaultUni DefaultFun ()
prog Program DeBruijn DefaultUni DefaultFun ()
forall {name} {fun}. Program name DefaultUni fun ()
argProg of
            Right Program DeBruijn DefaultUni DefaultFun ()
p -> Program DeBruijn DefaultUni DefaultFun ()
p
            Left ApplyProgramError
e ->
                [Char] -> Program DeBruijn DefaultUni DefaultFun ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> Program DeBruijn DefaultUni DefaultFun ())
-> [Char] -> Program DeBruijn DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$
                    [Char]
"applyDataParam: "
                        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ApplyProgramError -> [Char]
forall a. Show a => a -> [Char]
show ApplyProgramError
e
    in
        Program DeBruijn DefaultUni DefaultFun () -> ShortByteString
serialiseUPLC Program DeBruijn DefaultUni DefaultFun ()
applied
  where
    progVer :: Program name uni fun ann -> Version
progVer (Program ann
_ Version
v Term name uni fun ann
_) = Version
v

{- | Apply an integer parameter to a UPLC script.

`witness(kind, registry)` (#157 mint-matches-edge-deltas) takes its kind as a plain integer, and
the deployment applies it three times. Wrapping the `Data` encoding here
keeps the 'PlutusCore.Data' vocabulary inside this module, where the rest
of the blueprint's encoding already lives.
-}
applyIntParam
    :: Integer
    -- ^ Encoded integer parameter
    -> SBS.ShortByteString
    -- ^ Flat-encoded UPLC program
    -> SBS.ShortByteString
applyIntParam :: Integer -> ShortByteString -> ShortByteString
applyIntParam = Data -> ShortByteString -> ShortByteString
applyDataParam (Data -> ShortByteString -> ShortByteString)
-> (Integer -> Data)
-> Integer
-> ShortByteString
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Data
I

-- | Apply a raw bytes parameter to a UPLC script.
applyBytesParam
    :: BS.ByteString
    -- ^ Encoded bytes parameter
    -> SBS.ShortByteString
    -- ^ Flat-encoded UPLC program
    -> SBS.ShortByteString
applyBytesParam :: ByteString -> ShortByteString -> ShortByteString
applyBytesParam ByteString
bs =
    Data -> ShortByteString -> ShortByteString
applyDataParam (ByteString -> Data
B ByteString
bs)

{- | Apply an 'OnChainTxOutRef' parameter to a UPLC
script. Wraps 'applyDataParam' with the canonical
@Constr 0 [bytes, integer]@ encoding produced by the
'ToData OnChainTxOutRef' instance — matching what the
on-chain validator's parameter slot expects when the
Aiken validator is parameterized by an
@OutputReference@.
-}
applyOutputRef
    :: OnChainTxOutRef
    -- ^ Output reference to apply as the seed parameter
    -> SBS.ShortByteString
    -- ^ Flat-encoded UPLC program
    -> SBS.ShortByteString
applyOutputRef :: OnChainTxOutRef -> ShortByteString -> ShortByteString
applyOutputRef OnChainTxOutRef
ref ShortByteString
sbs =
    let BuiltinData Data
d = OnChainTxOutRef -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData OnChainTxOutRef
ref
    in  Data -> ShortByteString -> ShortByteString
applyDataParam Data
d ShortByteString
sbs

{- | Apply the state validator's @previousPolicies@
allowlist parameter. The on-chain parameter type is
@List\<PolicyId\>@, encoded as
@List [B pid0, B pid1, …]@ (an empty @List []@ for a
genesis cage, which makes migration into it
impossible).
-}
applyPreviousPolicies
    :: [BS.ByteString]
    -- ^ Predecessor policy-id bytes (28 bytes each); @[]@ for genesis
    -> SBS.ShortByteString
    -- ^ Flat-encoded raw state UPLC program
    -> SBS.ShortByteString
applyPreviousPolicies :: [ByteString] -> ShortByteString -> ShortByteString
applyPreviousPolicies [ByteString]
pids =
    Data -> ShortByteString -> ShortByteString
applyDataParam ([Data] -> Data
List ((ByteString -> Data) -> [ByteString] -> [Data]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Data
B [ByteString]
pids))

{- | Apply request-validator parameters in source
order: @statePolicyId@ first, then @cageTokenName@.
-}
applyRequestParams
    :: BS.ByteString
    -- ^ State policy id bytes
    -> OnChainTokenId
    -- ^ Cage token asset name
    -> SBS.ShortByteString
    -- ^ Flat-encoded request UPLC program
    -> SBS.ShortByteString
applyRequestParams :: ByteString -> OnChainTokenId -> ShortByteString -> ShortByteString
applyRequestParams ByteString
statePolicyId (OnChainTokenId (BuiltinByteString ByteString
token)) ShortByteString
sbs =
    ByteString -> ShortByteString -> ShortByteString
applyBytesParam ByteString
token (ShortByteString -> ShortByteString)
-> ShortByteString -> ShortByteString
forall a b. (a -> b) -> a -> b
$
        ByteString -> ShortByteString -> ShortByteString
applyBytesParam ByteString
statePolicyId ShortByteString
sbs