{-# OPTIONS_GHC -Wno-orphans #-}

-- | This module exposes the withdrawing constructs used in a
-- 'Cooked.Skeleton.TxSkel' and their associated utilities. To issue withdrawals
-- in a skeleton, the usual way is to invoke @txSkelWithdrawals =
-- txSkelWithdrawalsFromList [pubKeyWithdrawal pk amount, scriptWithdrawal
-- script redeemer amount, ...]@
module Cooked.Skeleton.Withdrawal
  ( -- * Data types
    Withdrawal (..),
    TxSkelWithdrawals (unTxSkelWithdrawals),

    -- * Optics
    withdrawalUserL,
    withdrawalMAmountL,
    withdrawalAmountAT,
    txSkelWithdrawalsListI,

    -- * Smart constructors
    pubKeyWithdrawal,
    scriptWithdrawal,
    txSkelWithdrawalsFromList,

    -- * Utilities
    fillAmount,
  )
where

import Cooked.Skeleton.Redeemer
import Cooked.Skeleton.User
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe
import Data.Typeable (Typeable)
import Optics.Core
import Optics.TH
import Plutus.Script.Utils.Address qualified as Script
import Plutus.Script.Utils.Value qualified as Script
import PlutusLedgerApi.V3 qualified as Api

-- | Withdrawals associate either a script or a private key with a redeemer and
-- a certain amount of ada. They are uniquely identified by the hash of either.
newtype TxSkelWithdrawals = TxSkelWithdrawals {TxSkelWithdrawals -> Map Credential Withdrawal
unTxSkelWithdrawals :: Map Api.Credential Withdrawal}
  deriving (Int -> TxSkelWithdrawals -> ShowS
[TxSkelWithdrawals] -> ShowS
TxSkelWithdrawals -> String
(Int -> TxSkelWithdrawals -> ShowS)
-> (TxSkelWithdrawals -> String)
-> ([TxSkelWithdrawals] -> ShowS)
-> Show TxSkelWithdrawals
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TxSkelWithdrawals -> ShowS
showsPrec :: Int -> TxSkelWithdrawals -> ShowS
$cshow :: TxSkelWithdrawals -> String
show :: TxSkelWithdrawals -> String
$cshowList :: [TxSkelWithdrawals] -> ShowS
showList :: [TxSkelWithdrawals] -> ShowS
Show, TxSkelWithdrawals -> TxSkelWithdrawals -> Bool
(TxSkelWithdrawals -> TxSkelWithdrawals -> Bool)
-> (TxSkelWithdrawals -> TxSkelWithdrawals -> Bool)
-> Eq TxSkelWithdrawals
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TxSkelWithdrawals -> TxSkelWithdrawals -> Bool
== :: TxSkelWithdrawals -> TxSkelWithdrawals -> Bool
$c/= :: TxSkelWithdrawals -> TxSkelWithdrawals -> Bool
/= :: TxSkelWithdrawals -> TxSkelWithdrawals -> Bool
Eq)

-- | A single 'Withdrawal', owned by a pubkey or redeemed script
data Withdrawal where
  Withdrawal ::
    { -- | The user making a withdrawals of their rewards
      Withdrawal -> User 'IsEither 'Redemption
withdrawalUser :: User IsEither Redemption,
      -- | The amount of lovelace to withdraw. If set to 'Nothing', cooked will
      -- attempt to fill this out with the current rewards for the user, which
      -- is the only acceptable amount ledger-wise. Manually setting this value
      -- is only left as a possibility for testing purposes.
      Withdrawal -> Maybe Lovelace
withdrawalAmount :: Maybe Api.Lovelace
    } ->
    Withdrawal
  deriving (Int -> Withdrawal -> ShowS
[Withdrawal] -> ShowS
Withdrawal -> String
(Int -> Withdrawal -> ShowS)
-> (Withdrawal -> String)
-> ([Withdrawal] -> ShowS)
-> Show Withdrawal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Withdrawal -> ShowS
showsPrec :: Int -> Withdrawal -> ShowS
$cshow :: Withdrawal -> String
show :: Withdrawal -> String
$cshowList :: [Withdrawal] -> ShowS
showList :: [Withdrawal] -> ShowS
Show, Withdrawal -> Withdrawal -> Bool
(Withdrawal -> Withdrawal -> Bool)
-> (Withdrawal -> Withdrawal -> Bool) -> Eq Withdrawal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Withdrawal -> Withdrawal -> Bool
== :: Withdrawal -> Withdrawal -> Bool
$c/= :: Withdrawal -> Withdrawal -> Bool
/= :: Withdrawal -> Withdrawal -> Bool
Eq)

-- | Focuses on the optional amount in a 'Withdrawal'
makeLensesFor [("withdrawalAmount", "withdrawalMAmountL")] ''Withdrawal

-- | Focuses on the user owning a 'Withdrawal'
makeLensesFor [("withdrawalUser", "withdrawalUserL")] ''Withdrawal

-- | Focuses on the amount in a 'Withdrawal'
withdrawalAmountAT :: AffineTraversal' Withdrawal Api.Lovelace
withdrawalAmountAT :: AffineTraversal' Withdrawal Lovelace
withdrawalAmountAT = Lens' Withdrawal (Maybe Lovelace)
withdrawalMAmountL Lens' Withdrawal (Maybe Lovelace)
-> Optic
     A_Prism NoIx (Maybe Lovelace) (Maybe Lovelace) Lovelace Lovelace
-> AffineTraversal' Withdrawal Lovelace
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Prism NoIx (Maybe Lovelace) (Maybe Lovelace) Lovelace Lovelace
forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Transforms a @[Withdrawal]@ to a 'TxSkelWithdrawals and vice
-- versa. Accumulates amount of withdrawals with similar owners, and keep the
-- latest found redeemer in the case of scripts, discarding the previous ones.
txSkelWithdrawalsListI :: Iso' TxSkelWithdrawals [Withdrawal]
txSkelWithdrawalsListI :: Iso' TxSkelWithdrawals [Withdrawal]
txSkelWithdrawalsListI =
  (TxSkelWithdrawals -> [Withdrawal])
-> ([Withdrawal] -> TxSkelWithdrawals)
-> Iso' TxSkelWithdrawals [Withdrawal]
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
    (Map Credential Withdrawal -> [Withdrawal]
forall k a. Map k a -> [a]
Map.elems (Map Credential Withdrawal -> [Withdrawal])
-> (TxSkelWithdrawals -> Map Credential Withdrawal)
-> TxSkelWithdrawals
-> [Withdrawal]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkelWithdrawals -> Map Credential Withdrawal
unTxSkelWithdrawals)
    ( (TxSkelWithdrawals -> Withdrawal -> TxSkelWithdrawals)
-> TxSkelWithdrawals -> [Withdrawal] -> TxSkelWithdrawals
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
        ( \(TxSkelWithdrawals Map Credential Withdrawal
withdrawals) withdrawal :: Withdrawal
withdrawal@(Withdrawal (Optic' A_Getter NoIx (User 'IsEither 'Redemption) Credential
-> User 'IsEither 'Redemption -> Credential
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Getter NoIx (User 'IsEither 'Redemption) Credential
forall (kind :: UserKind) (mode :: UserMode).
Getter (User kind mode) Credential
userCredentialG -> Credential
cred) Maybe Lovelace
amount) ->
            Map Credential Withdrawal -> TxSkelWithdrawals
TxSkelWithdrawals (Map Credential Withdrawal -> TxSkelWithdrawals)
-> Map Credential Withdrawal -> TxSkelWithdrawals
forall a b. (a -> b) -> a -> b
$
              Optic
  A_Lens
  NoIx
  (Map Credential Withdrawal)
  (Map Credential Withdrawal)
  (Maybe Withdrawal)
  (Maybe Withdrawal)
-> (Maybe Withdrawal -> Maybe Withdrawal)
-> Map Credential Withdrawal
-> Map Credential Withdrawal
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over
                (Index (Map Credential Withdrawal)
-> Lens'
     (Map Credential Withdrawal)
     (Maybe (IxValue (Map Credential Withdrawal)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Credential Withdrawal)
Credential
cred)
                (Maybe Withdrawal
-> (Withdrawal -> Maybe Withdrawal)
-> Maybe Withdrawal
-> Maybe Withdrawal
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Withdrawal -> Maybe Withdrawal
forall a. a -> Maybe a
Just Withdrawal
withdrawal) (Withdrawal -> Maybe Withdrawal
forall a. a -> Maybe a
Just (Withdrawal -> Maybe Withdrawal)
-> (Withdrawal -> Withdrawal) -> Withdrawal -> Maybe Withdrawal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Withdrawal (Maybe Lovelace)
-> (Maybe Lovelace -> Maybe Lovelace) -> Withdrawal -> Withdrawal
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Lens' Withdrawal (Maybe Lovelace)
withdrawalMAmountL (Maybe Lovelace
-> (Lovelace -> Maybe Lovelace) -> Maybe Lovelace -> Maybe Lovelace
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe Lovelace
amount (Lovelace -> Maybe Lovelace
forall a. a -> Maybe a
Just (Lovelace -> Maybe Lovelace)
-> (Lovelace -> Lovelace) -> Lovelace -> Maybe Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lovelace -> Lovelace -> Lovelace
forall a. Num a => a -> a -> a
+ Lovelace -> Maybe Lovelace -> Lovelace
forall a. a -> Maybe a -> a
fromMaybe Lovelace
0 Maybe Lovelace
amount)))))
                Map Credential Withdrawal
withdrawals
        )
        TxSkelWithdrawals
forall a. Monoid a => a
mempty
    )

-- | Creates a 'Withdrawal' from a private key hash
pubKeyWithdrawal :: (Script.ToPubKeyHash pkh, Typeable pkh) => pkh -> Withdrawal
pubKeyWithdrawal :: forall pkh. (ToPubKeyHash pkh, Typeable pkh) => pkh -> Withdrawal
pubKeyWithdrawal = (User 'IsEither 'Redemption -> Maybe Lovelace -> Withdrawal
`Withdrawal` Maybe Lovelace
forall a. Maybe a
Nothing) (User 'IsEither 'Redemption -> Withdrawal)
-> (pkh -> User 'IsEither 'Redemption) -> pkh -> Withdrawal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. pkh -> User 'IsEither 'Redemption
forall pkh (a :: UserKind) (b :: UserMode).
(a ∈ '[ 'IsPubKey, 'IsEither], ToPubKeyHash pkh, Typeable pkh) =>
pkh -> User a b
UserPubKey

-- | Creates a 'Withdrawal' from a redeemed script and lovelace amount
scriptWithdrawal :: (ToVScript script, Typeable script, RedeemerConstrs red) => script -> red -> Withdrawal
scriptWithdrawal :: forall script red.
(ToVScript script, Typeable script, RedeemerConstrs red) =>
script -> red -> Withdrawal
scriptWithdrawal script
script red
red = User 'IsEither 'Redemption -> Maybe Lovelace -> Withdrawal
Withdrawal (script -> TxSkelRedeemer -> User 'IsEither 'Redemption
forall script (a :: UserKind).
(a ∈ '[ 'IsScript, 'IsEither], ToVScript script,
 Typeable script) =>
script -> TxSkelRedeemer -> User a 'Redemption
UserRedeemedScript script
script (red -> TxSkelRedeemer
forall redeemer.
RedeemerConstrs redeemer =>
redeemer -> TxSkelRedeemer
someTxSkelRedeemer red
red)) Maybe Lovelace
forall a. Maybe a
Nothing

-- | Builds a 'TxSkelWithdrawals' from a list of 'Withdrawal'. This is
-- equivalent to calling @review txSkelWithdrawalsListI@
txSkelWithdrawalsFromList :: [Withdrawal] -> TxSkelWithdrawals
txSkelWithdrawalsFromList :: [Withdrawal] -> TxSkelWithdrawals
txSkelWithdrawalsFromList = Iso' TxSkelWithdrawals [Withdrawal]
-> [Withdrawal] -> TxSkelWithdrawals
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Iso' TxSkelWithdrawals [Withdrawal]
txSkelWithdrawalsListI

-- | Fills a given amount of lovelace to withdraw, if not already set
fillAmount :: Api.Lovelace -> Withdrawal -> Withdrawal
fillAmount :: Lovelace -> Withdrawal -> Withdrawal
fillAmount Lovelace
newAmount = Lens' Withdrawal (Maybe Lovelace)
-> (Maybe Lovelace -> Maybe Lovelace) -> Withdrawal -> Withdrawal
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Lens' Withdrawal (Maybe Lovelace)
withdrawalMAmountL (Maybe Lovelace
-> (Lovelace -> Maybe Lovelace) -> Maybe Lovelace -> Maybe Lovelace
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Lovelace -> Maybe Lovelace
forall a. a -> Maybe a
Just Lovelace
newAmount) Lovelace -> Maybe Lovelace
forall a. a -> Maybe a
Just)

-- | Retrieves the total value withdrawn is this 'TxSkelWithdrawals'
instance Script.ToValue TxSkelWithdrawals where
  toValue :: TxSkelWithdrawals -> Value
toValue = (Value -> Withdrawal -> Value)
-> Value -> Map Credential Withdrawal -> Value
forall b a. (b -> a -> b) -> b -> Map Credential a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Value
val -> (Value
val Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<>) (Value -> Value) -> (Withdrawal -> Value) -> Withdrawal -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> (Lovelace -> Value) -> Maybe Lovelace -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
forall a. Monoid a => a
mempty Lovelace -> Value
forall a. ToValue a => a -> Value
Script.toValue (Maybe Lovelace -> Value)
-> (Withdrawal -> Maybe Lovelace) -> Withdrawal -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Withdrawal (Maybe Lovelace) -> Withdrawal -> Maybe Lovelace
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' Withdrawal (Maybe Lovelace)
withdrawalMAmountL) Value
forall a. Monoid a => a
mempty (Map Credential Withdrawal -> Value)
-> (TxSkelWithdrawals -> Map Credential Withdrawal)
-> TxSkelWithdrawals
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkelWithdrawals -> Map Credential Withdrawal
unTxSkelWithdrawals

instance Semigroup TxSkelWithdrawals where
  TxSkelWithdrawals
txSkelW <> :: TxSkelWithdrawals -> TxSkelWithdrawals -> TxSkelWithdrawals
<> TxSkelWithdrawals
txSkelW' =
    Iso' TxSkelWithdrawals [Withdrawal]
-> [Withdrawal] -> TxSkelWithdrawals
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Iso' TxSkelWithdrawals [Withdrawal]
txSkelWithdrawalsListI ([Withdrawal] -> TxSkelWithdrawals)
-> [Withdrawal] -> TxSkelWithdrawals
forall a b. (a -> b) -> a -> b
$
      Iso' TxSkelWithdrawals [Withdrawal]
-> TxSkelWithdrawals -> [Withdrawal]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Iso' TxSkelWithdrawals [Withdrawal]
txSkelWithdrawalsListI TxSkelWithdrawals
txSkelW
        [Withdrawal] -> [Withdrawal] -> [Withdrawal]
forall a. Semigroup a => a -> a -> a
<> Iso' TxSkelWithdrawals [Withdrawal]
-> TxSkelWithdrawals -> [Withdrawal]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Iso' TxSkelWithdrawals [Withdrawal]
txSkelWithdrawalsListI TxSkelWithdrawals
txSkelW'

instance Monoid TxSkelWithdrawals where
  mempty :: TxSkelWithdrawals
mempty = Map Credential Withdrawal -> TxSkelWithdrawals
TxSkelWithdrawals Map Credential Withdrawal
forall a. Monoid a => a
mempty