{-# OPTIONS_GHC -Wno-orphans #-}

module Cooked.Skeleton.Mint
  ( TxSkelMints,
    addToTxSkelMints,
    txSkelMintsToList,
    txSkelMintsFromList,
    txSkelMintsFromList',
    txSkelMintsValue,
  )
where

import Cooked.Skeleton.Redeemer as X
import Data.List.NonEmpty qualified as NEList
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Map.NonEmpty (NEMap)
import Data.Map.NonEmpty qualified as NEMap
import Optics.Core
import Plutus.Script.Utils.Scripts qualified as Script
import Plutus.Script.Utils.Value qualified as Script hiding (adaSymbol, adaToken)
import PlutusLedgerApi.V3 qualified as Api
import Test.QuickCheck (NonZero (..))

-- | A description of what a transaction mints. For every policy, there can only
-- be one 'TxSkelRedeemer', and if there is, there must be some token names, each
-- with a non-zero amount of tokens.
--
-- You'll probably not construct this by hand, but use 'txSkelMintsFromList'.
type TxSkelMints =
  Map
    (Script.Versioned Script.MintingPolicy)
    (TxSkelRedeemer, NEMap Api.TokenName (NonZero Integer))

-- | Combining 'TxSkelMints' in a sensible way. In particular, this means that
--
-- > Map.fromList [(pol, (red, NEMap.fromList [(tName, 1)]))]
--
-- and
--
-- > Map.fromList [(pol, (red', NEMap.fromList [(tName, -1)]))]
--
-- will combine to become the empty 'TxSkelMints' (and similar examples, where
-- the values add up to zero, see the comment at the definition of
-- 'addToTxSkelMints').
--
-- In every case, if you add mints with a different redeemer for the same
-- policy, the redeemer used in the right argument takes precedence.
instance {-# OVERLAPPING #-} Semigroup TxSkelMints where
  TxSkelMints
a <> :: TxSkelMints -> TxSkelMints -> TxSkelMints
<> TxSkelMints
b = (TxSkelMints
 -> (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
 -> TxSkelMints)
-> TxSkelMints
-> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
-> TxSkelMints
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (((Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
 -> TxSkelMints -> TxSkelMints)
-> TxSkelMints
-> (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
-> TxSkelMints
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
-> TxSkelMints -> TxSkelMints
addToTxSkelMints) TxSkelMints
a (TxSkelMints
-> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
txSkelMintsToList TxSkelMints
b)

instance {-# OVERLAPPING #-} Monoid TxSkelMints where
  mempty :: TxSkelMints
mempty = TxSkelMints
forall k a. Map k a
Map.empty

-- | Add a new entry to a 'TxSkelMints'. There are a few wrinkles:
--
-- (1) If for a given policy, redeemer, and token name, there are @n@ tokens in
-- the argument 'TxSkelMints', and you add @-n@ tokens, the corresponding entry
-- in the "inner map" of the policy will disappear (obviously, because all of
-- its values have to be non-zero). If that also means that the inner map
-- becomes empty, the policy will disappear from the 'TxSkelMints' altogether.
--
-- (2) If a policy is already present on the argument 'TxSkelMints' with a
-- redeemer @a@, and you add a mint with a different redeemer @b@, the old
-- redeemer is thrown away. The values associated with the token names of that
-- policy are added as described above, though. This means that any pre-existing
-- values will be minted with a new redeemer.
--
-- If, for some reason, you really want to generate a 'TxSkelMints' that has
-- both a negative and a positive entry of the same asset class and redeemer,
-- you'll have to do so manually. Note, however, that even if you do so, NO
-- VALIDATOR OR MINTING POLICY WILL EVER GET TO SEE A TRANSACTION WITH SUCH
-- CONFLICTING INFORMATION. This is not a design decision/limitation of
-- cooked-validators: The Cardano API 'TxBodyContent' type, that we're
-- translating everything into eventually, stores minting information as a
-- minted value together with a map from policy IDs to witnesses (which
-- represent the used redeemers). That means that we can only store _one_
-- redeemer per minting policy, and no conflicting mints of the same asset
-- class, since they'll just cancel.
addToTxSkelMints ::
  (Script.Versioned Script.MintingPolicy, TxSkelRedeemer, Api.TokenName, Integer) ->
  TxSkelMints ->
  TxSkelMints
addToTxSkelMints :: (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
-> TxSkelMints -> TxSkelMints
addToTxSkelMints (Versioned MintingPolicy
pol, TxSkelRedeemer
red, TokenName
tName, Integer
amount) TxSkelMints
mints
  | Integer
0 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
amount = TxSkelMints
mints
  | Bool
otherwise = case TxSkelMints
mints TxSkelMints
-> Versioned MintingPolicy
-> Maybe (TxSkelRedeemer, NEMap TokenName (NonZero Integer))
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Versioned MintingPolicy
pol of
      Maybe (TxSkelRedeemer, NEMap TokenName (NonZero Integer))
Nothing ->
        -- The policy isn't yet in the given 'TxSkelMints', so we can just add a
        -- new entry:
        Versioned MintingPolicy
-> (TxSkelRedeemer, NEMap TokenName (NonZero Integer))
-> TxSkelMints
-> TxSkelMints
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Versioned MintingPolicy
pol (TxSkelRedeemer
red, TokenName -> NonZero Integer -> NEMap TokenName (NonZero Integer)
forall k a. k -> a -> NEMap k a
NEMap.singleton TokenName
tName (Integer -> NonZero Integer
forall a. a -> NonZero a
NonZero Integer
amount)) TxSkelMints
mints
      Just (TxSkelRedeemer
_oldRed, NEMap TokenName (NonZero Integer)
innerMap) ->
        -- Ignore the old redeemer: If it's the same as the new one, nothing
        -- will change, if not, the new redeemer will be kept.
        case NEMap TokenName (NonZero Integer)
innerMap NEMap TokenName (NonZero Integer)
-> TokenName -> Maybe (NonZero Integer)
forall k a. Ord k => NEMap k a -> k -> Maybe a
NEMap.!? TokenName
tName of
          Maybe (NonZero Integer)
Nothing ->
            -- The given token name has not yet occurred for the given
            -- policy. This means that we can just add the new tokens to the
            -- inner map:
            Versioned MintingPolicy
-> (TxSkelRedeemer, NEMap TokenName (NonZero Integer))
-> TxSkelMints
-> TxSkelMints
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Versioned MintingPolicy
pol (TxSkelRedeemer
red, TokenName
-> NonZero Integer
-> NEMap TokenName (NonZero Integer)
-> NEMap TokenName (NonZero Integer)
forall k a. Ord k => k -> a -> NEMap k a -> NEMap k a
NEMap.insert TokenName
tName (Integer -> NonZero Integer
forall a. a -> NonZero a
NonZero Integer
amount) NEMap TokenName (NonZero Integer)
innerMap) TxSkelMints
mints
          Just (NonZero Integer
oldAmount) ->
            let newAmount :: Integer
newAmount = Integer
oldAmount Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
amount
             in if Integer
newAmount Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
                  then -- If the sum of the old amount of tokens and the
                  -- additional tokens is non-zero, we can just update the
                  -- amount in the inner map:
                    Versioned MintingPolicy
-> (TxSkelRedeemer, NEMap TokenName (NonZero Integer))
-> TxSkelMints
-> TxSkelMints
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Versioned MintingPolicy
pol (TxSkelRedeemer
red, TokenName
-> NonZero Integer
-> NEMap TokenName (NonZero Integer)
-> NEMap TokenName (NonZero Integer)
forall k a. Ord k => k -> a -> NEMap k a -> NEMap k a
NEMap.insert TokenName
tName (Integer -> NonZero Integer
forall a. a -> NonZero a
NonZero Integer
newAmount) NEMap TokenName (NonZero Integer)
innerMap) TxSkelMints
mints
                  else -- If the sum is zero, we'll have to delete the token
                  -- name from the inner map. If that yields a completely empty
                  -- inner map, we'll have to remove the entry altogether:
                  case Map TokenName (NonZero Integer)
-> Maybe (NEMap TokenName (NonZero Integer))
forall k a. Map k a -> Maybe (NEMap k a)
NEMap.nonEmptyMap (Map TokenName (NonZero Integer)
 -> Maybe (NEMap TokenName (NonZero Integer)))
-> Map TokenName (NonZero Integer)
-> Maybe (NEMap TokenName (NonZero Integer))
forall a b. (a -> b) -> a -> b
$ TokenName
-> NEMap TokenName (NonZero Integer)
-> Map TokenName (NonZero Integer)
forall k a. Ord k => k -> NEMap k a -> Map k a
NEMap.delete TokenName
tName NEMap TokenName (NonZero Integer)
innerMap of
                    Maybe (NEMap TokenName (NonZero Integer))
Nothing -> Versioned MintingPolicy -> TxSkelMints -> TxSkelMints
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Versioned MintingPolicy
pol TxSkelMints
mints
                    Just NEMap TokenName (NonZero Integer)
newInnerMap -> Versioned MintingPolicy
-> (TxSkelRedeemer, NEMap TokenName (NonZero Integer))
-> TxSkelMints
-> TxSkelMints
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Versioned MintingPolicy
pol (TxSkelRedeemer
red, NEMap TokenName (NonZero Integer)
newInnerMap) TxSkelMints
mints

-- | Convert from 'TxSkelMints' to a list of tuples describing eveything that's
-- being minted.
txSkelMintsToList :: TxSkelMints -> [(Script.Versioned Script.MintingPolicy, TxSkelRedeemer, Api.TokenName, Integer)]
txSkelMintsToList :: TxSkelMints
-> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
txSkelMintsToList =
  ((Versioned MintingPolicy,
  (TxSkelRedeemer, NEMap TokenName (NonZero Integer)))
 -> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)])
-> [(Versioned MintingPolicy,
     (TxSkelRedeemer, NEMap TokenName (NonZero Integer)))]
-> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
    ( \(Versioned MintingPolicy
p, (TxSkelRedeemer
r, NEMap TokenName (NonZero Integer)
m)) ->
        (\(TokenName
t, NonZero Integer
n) -> (Versioned MintingPolicy
p, TxSkelRedeemer
r, TokenName
t, Integer
n))
          ((TokenName, NonZero Integer)
 -> (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer))
-> [(TokenName, NonZero Integer)]
-> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (TokenName, NonZero Integer)
-> [(TokenName, NonZero Integer)]
forall a. NonEmpty a -> [a]
NEList.toList (NEMap TokenName (NonZero Integer)
-> NonEmpty (TokenName, NonZero Integer)
forall k a. NEMap k a -> NonEmpty (k, a)
NEMap.toList NEMap TokenName (NonZero Integer)
m)
    )
    ([(Versioned MintingPolicy,
   (TxSkelRedeemer, NEMap TokenName (NonZero Integer)))]
 -> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)])
-> (TxSkelMints
    -> [(Versioned MintingPolicy,
         (TxSkelRedeemer, NEMap TokenName (NonZero Integer)))])
-> TxSkelMints
-> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkelMints
-> [(Versioned MintingPolicy,
     (TxSkelRedeemer, NEMap TokenName (NonZero Integer)))]
forall k a. Map k a -> [(k, a)]
Map.toList

-- | Smart constructor for 'TxSkelMints'. This function relies on
-- 'addToTxSkelMints'. So, some non-empty lists (where all amounts for a given
-- asset class an redeemer add up to zero) might be translated into the empty
-- 'TxSkelMints'.
txSkelMintsFromList :: [(Script.Versioned Script.MintingPolicy, TxSkelRedeemer, Api.TokenName, Integer)] -> TxSkelMints
txSkelMintsFromList :: [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
-> TxSkelMints
txSkelMintsFromList = ((Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
 -> TxSkelMints -> TxSkelMints)
-> TxSkelMints
-> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
-> TxSkelMints
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
-> TxSkelMints -> TxSkelMints
addToTxSkelMints TxSkelMints
forall a. Monoid a => a
mempty

-- | Another smart constructor for 'TxSkelMints', where the redeemer and minting
-- policies are not duplicated.
txSkelMintsFromList' :: [(Script.Versioned Script.MintingPolicy, TxSkelRedeemer, [(Api.TokenName, Integer)])] -> TxSkelMints
txSkelMintsFromList' :: [(Versioned MintingPolicy, TxSkelRedeemer, [(TokenName, Integer)])]
-> TxSkelMints
txSkelMintsFromList' = [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
-> TxSkelMints
txSkelMintsFromList ([(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
 -> TxSkelMints)
-> ([(Versioned MintingPolicy, TxSkelRedeemer,
      [(TokenName, Integer)])]
    -> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)])
-> [(Versioned MintingPolicy, TxSkelRedeemer,
     [(TokenName, Integer)])]
-> TxSkelMints
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Versioned MintingPolicy, TxSkelRedeemer, [(TokenName, Integer)])
 -> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)])
-> [(Versioned MintingPolicy, TxSkelRedeemer,
     [(TokenName, Integer)])]
-> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Versioned MintingPolicy
mp, TxSkelRedeemer
r, [(TokenName, Integer)]
m) -> (\(TokenName
tn, Integer
i) -> (Versioned MintingPolicy
mp, TxSkelRedeemer
r, TokenName
tn, Integer
i)) ((TokenName, Integer)
 -> (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer))
-> [(TokenName, Integer)]
-> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TokenName, Integer)]
m)

-- | The value described by a 'TxSkelMints'
txSkelMintsValue :: TxSkelMints -> Api.Value
txSkelMintsValue :: TxSkelMints -> Value
txSkelMintsValue =
  Optic'
  A_Fold
  NoIx
  TxSkelMints
  (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
-> ((Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
    -> Value)
-> TxSkelMints
-> Value
forall k m (is :: IxList) s a.
(Is k A_Fold, Monoid m) =>
Optic' k is s a -> (a -> m) -> s -> m
foldMapOf
    ((TxSkelMints
 -> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)])
-> Getter
     TxSkelMints
     [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
forall s a. (s -> a) -> Getter s a
to TxSkelMints
-> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
txSkelMintsToList Getter
  TxSkelMints
  [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
-> Optic
     A_Fold
     NoIx
     [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
     [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
     (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
     (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
-> Optic'
     A_Fold
     NoIx
     TxSkelMints
     (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
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_Fold
  NoIx
  [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
  [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
  (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
  (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded)
    ( \(Versioned MintingPolicy
policy, TxSkelRedeemer
_, TokenName
tName, Integer
amount) ->
        AssetClass -> Integer -> Value
Script.assetClassValue
          ( CurrencySymbol -> TokenName -> AssetClass
Script.assetClass
              (Versioned MintingPolicy -> CurrencySymbol
Script.scriptCurrencySymbol Versioned MintingPolicy
policy)
              TokenName
tName
          )
          Integer
amount
    )