{-# OPTIONS_GHC -Wno-orphans #-}

-- | This modules exposes optics around 'Api.Value' and 'Api.Lovelace' that we
-- use in our 'Cooked.Skeleton.TxSkel' and are not defined anywhere else.
module Cooked.Skeleton.Value
  ( -- * Optics
    valueAssetClassesI,
    valueAssetClassAmountL,
    valueLovelaceL,
    valueAssetClassAmountP,
    valueLovelaceP,
    lovelaceIntegerI,
  )
where

import Data.List (sortOn)
import Optics.Core
import Plutus.Script.Utils.Scripts qualified as Script
import PlutusLedgerApi.V1.Value qualified as Api
import PlutusTx.AssocMap qualified as PMap

-- | Focuses on the amount of tokens of a certain 'Api.AssetClass'
-- in a given 'Api.Value'. This removes the entry if the new amount is 0.
valueAssetClassAmountL :: (Script.ToMintingPolicyHash mp) => mp -> Api.TokenName -> Lens' Api.Value Integer
valueAssetClassAmountL :: forall mp.
ToMintingPolicyHash mp =>
mp -> TokenName -> Lens' Value Integer
valueAssetClassAmountL (mp -> CurrencySymbol
forall script.
ToMintingPolicyHash script =>
script -> CurrencySymbol
Script.toCurrencySymbol -> CurrencySymbol
cs) TokenName
tk =
  (Value -> Integer)
-> (Value -> Integer -> Value) -> Lens' Value Integer
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (Value -> AssetClass -> Integer
`Api.assetClassValueOf` CurrencySymbol -> TokenName -> AssetClass
Api.assetClass CurrencySymbol
cs TokenName
tk)
    ( \v :: Value
v@(Api.Value Map CurrencySymbol (Map TokenName Integer)
val) Integer
i -> case CurrencySymbol
-> Map CurrencySymbol (Map TokenName Integer)
-> Maybe (Map TokenName Integer)
forall k v. Eq k => k -> Map k v -> Maybe v
PMap.lookup CurrencySymbol
cs Map CurrencySymbol (Map TokenName Integer)
val of
        -- No previous cs entry and nothing to add.
        Maybe (Map TokenName Integer)
Nothing | Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -> Value
v
        -- No previous cs entry, and something to add.
        Maybe (Map TokenName Integer)
Nothing -> Map CurrencySymbol (Map TokenName Integer) -> Value
Api.Value (Map CurrencySymbol (Map TokenName Integer) -> Value)
-> Map CurrencySymbol (Map TokenName Integer) -> Value
forall a b. (a -> b) -> a -> b
$ CurrencySymbol
-> Map TokenName Integer
-> Map CurrencySymbol (Map TokenName Integer)
-> Map CurrencySymbol (Map TokenName Integer)
forall k v. Eq k => k -> v -> Map k v -> Map k v
PMap.insert CurrencySymbol
cs (TokenName -> Integer -> Map TokenName Integer
forall k v. k -> v -> Map k v
PMap.singleton TokenName
tk Integer
i) Map CurrencySymbol (Map TokenName Integer)
val
        -- A previous cs and tk entry, which needs to be removed and the whole
        -- cs entry as well because it only contains this tk.
        Just (Map TokenName Integer -> [(TokenName, Integer)]
forall k v. Map k v -> [(k, v)]
PMap.toList -> [(TokenName
tk', Integer
_)]) | Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0, TokenName
tk TokenName -> TokenName -> Bool
forall a. Eq a => a -> a -> Bool
== TokenName
tk' -> Map CurrencySymbol (Map TokenName Integer) -> Value
Api.Value (Map CurrencySymbol (Map TokenName Integer) -> Value)
-> Map CurrencySymbol (Map TokenName Integer) -> Value
forall a b. (a -> b) -> a -> b
$ CurrencySymbol
-> Map CurrencySymbol (Map TokenName Integer)
-> Map CurrencySymbol (Map TokenName Integer)
forall k v. Eq k => k -> Map k v -> Map k v
PMap.delete CurrencySymbol
cs Map CurrencySymbol (Map TokenName Integer)
val
        -- A previous cs and tk entry, which needs to be removed, but the whole
        -- cs entry has other tokens and thus is kept.
        Just Map TokenName Integer
tokenMap | Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -> Map CurrencySymbol (Map TokenName Integer) -> Value
Api.Value (Map CurrencySymbol (Map TokenName Integer) -> Value)
-> Map CurrencySymbol (Map TokenName Integer) -> Value
forall a b. (a -> b) -> a -> b
$ CurrencySymbol
-> Map TokenName Integer
-> Map CurrencySymbol (Map TokenName Integer)
-> Map CurrencySymbol (Map TokenName Integer)
forall k v. Eq k => k -> v -> Map k v -> Map k v
PMap.insert CurrencySymbol
cs (TokenName -> Map TokenName Integer -> Map TokenName Integer
forall k v. Eq k => k -> Map k v -> Map k v
PMap.delete TokenName
tk Map TokenName Integer
tokenMap) Map CurrencySymbol (Map TokenName Integer)
val
        -- A previous cs entry, in which we insert the new tk (regardless of
        -- whether the tk was already present).
        Just Map TokenName Integer
tokenMap -> Map CurrencySymbol (Map TokenName Integer) -> Value
Api.Value (Map CurrencySymbol (Map TokenName Integer) -> Value)
-> Map CurrencySymbol (Map TokenName Integer) -> Value
forall a b. (a -> b) -> a -> b
$ CurrencySymbol
-> Map TokenName Integer
-> Map CurrencySymbol (Map TokenName Integer)
-> Map CurrencySymbol (Map TokenName Integer)
forall k v. Eq k => k -> v -> Map k v -> Map k v
PMap.insert CurrencySymbol
cs (TokenName
-> Integer -> Map TokenName Integer -> Map TokenName Integer
forall k v. Eq k => k -> v -> Map k v -> Map k v
PMap.insert TokenName
tk Integer
i Map TokenName Integer
tokenMap) Map CurrencySymbol (Map TokenName Integer)
val
    )

-- | An isomorphism between a value and its flattened representation. The
-- flattened representation is always sorted by asset class (as produced by
-- 'Api.flattenValue'), and building a value back from a list canonicalises it
-- the same way, so that the internal map ordering of the resulting value does
-- not depend on the order of the input list.
valueAssetClassesI :: Iso' Api.Value [(Api.CurrencySymbol, Api.TokenName, Integer)]
valueAssetClassesI :: Iso' Value [(CurrencySymbol, TokenName, Integer)]
valueAssetClassesI =
  (Value -> [(CurrencySymbol, TokenName, Integer)])
-> ([(CurrencySymbol, TokenName, Integer)] -> Value)
-> Iso' Value [(CurrencySymbol, TokenName, Integer)]
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
    Value -> [(CurrencySymbol, TokenName, Integer)]
Api.flattenValue
    ((Value -> (CurrencySymbol, TokenName, Integer) -> Value)
-> Value -> [(CurrencySymbol, TokenName, Integer)] -> Value
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Value
val (CurrencySymbol
cur, TokenName
tk, Integer
i) -> Lens' Value Integer -> Integer -> Value -> Value
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (CurrencySymbol -> TokenName -> Lens' Value Integer
forall mp.
ToMintingPolicyHash mp =>
mp -> TokenName -> Lens' Value Integer
valueAssetClassAmountL CurrencySymbol
cur TokenName
tk) Integer
i Value
val) Value
forall a. Monoid a => a
mempty ([(CurrencySymbol, TokenName, Integer)] -> Value)
-> ([(CurrencySymbol, TokenName, Integer)]
    -> [(CurrencySymbol, TokenName, Integer)])
-> [(CurrencySymbol, TokenName, Integer)]
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CurrencySymbol, TokenName, Integer)
 -> (CurrencySymbol, TokenName))
-> [(CurrencySymbol, TokenName, Integer)]
-> [(CurrencySymbol, TokenName, Integer)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(CurrencySymbol
cur, TokenName
tk, Integer
_) -> (CurrencySymbol
cur, TokenName
tk)))

-- | An isomorphism between an 'Api.Lovelace' and an 'Integer'
lovelaceIntegerI :: Iso' Api.Lovelace Integer
lovelaceIntegerI :: Iso' Lovelace Integer
lovelaceIntegerI = (Lovelace -> Integer)
-> (Integer -> Lovelace) -> Iso' Lovelace Integer
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Lovelace -> Integer
Api.getLovelace Integer -> Lovelace
Api.Lovelace

-- | Focuses on the 'Api.Lovelace' of an 'Api.Value'
valueLovelaceL :: Lens' Api.Value Api.Lovelace
valueLovelaceL :: Lens' Value Lovelace
valueLovelaceL = CurrencySymbol -> TokenName -> Lens' Value Integer
forall mp.
ToMintingPolicyHash mp =>
mp -> TokenName -> Lens' Value Integer
valueAssetClassAmountL CurrencySymbol
Api.adaSymbol TokenName
Api.adaToken Lens' Value Integer
-> Optic An_Iso NoIx Integer Integer Lovelace Lovelace
-> Lens' Value 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
% Iso' Lovelace Integer
-> Optic
     (ReversedOptic An_Iso) NoIx Integer Integer Lovelace Lovelace
forall (is :: IxList) s t a b.
AcceptsEmptyIndices "re" is =>
Optic An_Iso is s t a b -> Optic (ReversedOptic An_Iso) is b a t s
forall k (is :: IxList) s t a b.
(ReversibleOptic k, AcceptsEmptyIndices "re" is) =>
Optic k is s t a b -> Optic (ReversedOptic k) is b a t s
re Iso' Lovelace Integer
lovelaceIntegerI

-- | Builds or retrieves the amount of tokens of a certain 'Api.AssetClass' in an
-- 'Api.Value', treating a zero amount as absent
valueAssetClassAmountP :: (Script.ToMintingPolicyHash mp) => mp -> Api.TokenName -> Prism' Api.Value Integer
valueAssetClassAmountP :: forall mp.
ToMintingPolicyHash mp =>
mp -> TokenName -> Prism' Value Integer
valueAssetClassAmountP (mp -> CurrencySymbol
forall script.
ToMintingPolicyHash script =>
script -> CurrencySymbol
Script.toCurrencySymbol -> CurrencySymbol
cs) TokenName
tk
  | AssetClass
ac <- CurrencySymbol -> TokenName -> AssetClass
Api.assetClass CurrencySymbol
cs TokenName
tk =
      (Integer -> Value)
-> (Value -> Either Value Integer) -> Prism' Value Integer
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
        ( \case
            Integer
i | Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -> Value
forall a. Monoid a => a
mempty
            Integer
i -> AssetClass -> Integer -> Value
Api.assetClassValue AssetClass
ac Integer
i
        )
        ( \Value
val -> case Value
val Value -> AssetClass -> Integer
`Api.assetClassValueOf` AssetClass
ac of
            Integer
i | Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -> Value -> Either Value Integer
forall a b. a -> Either a b
Left Value
val
            Integer
i -> Integer -> Either Value Integer
forall a b. b -> Either a b
Right Integer
i
        )

-- | Builds or retrieves the 'Api.Lovelace' of an 'Api.Value'
valueLovelaceP :: Prism' Api.Value Api.Lovelace
valueLovelaceP :: Prism' Value Lovelace
valueLovelaceP = CurrencySymbol -> TokenName -> Prism' Value Integer
forall mp.
ToMintingPolicyHash mp =>
mp -> TokenName -> Prism' Value Integer
valueAssetClassAmountP CurrencySymbol
Api.adaSymbol TokenName
Api.adaToken Prism' Value Integer
-> Optic An_Iso NoIx Integer Integer Lovelace Lovelace
-> Prism' Value 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
% Iso' Lovelace Integer
-> Optic
     (ReversedOptic An_Iso) NoIx Integer Integer Lovelace Lovelace
forall (is :: IxList) s t a b.
AcceptsEmptyIndices "re" is =>
Optic An_Iso is s t a b -> Optic (ReversedOptic An_Iso) is b a t s
forall k (is :: IxList) s t a b.
(ReversibleOptic k, AcceptsEmptyIndices "re" is) =>
Optic k is s t a b -> Optic (ReversedOptic k) is b a t s
re Iso' Lovelace Integer
lovelaceIntegerI

instance Ord Api.Value where
  compare :: Value -> Value -> Ordering
compare Value
v1 Value
v2 = [(CurrencySymbol, Map TokenName Integer)]
-> [(CurrencySymbol, Map TokenName Integer)] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Map CurrencySymbol (Map TokenName Integer)
-> [(CurrencySymbol, Map TokenName Integer)]
forall k v. Map k v -> [(k, v)]
PMap.toList (Map CurrencySymbol (Map TokenName Integer)
 -> [(CurrencySymbol, Map TokenName Integer)])
-> Map CurrencySymbol (Map TokenName Integer)
-> [(CurrencySymbol, Map TokenName Integer)]
forall a b. (a -> b) -> a -> b
$ Value -> Map CurrencySymbol (Map TokenName Integer)
Api.getValue Value
v1) (Map CurrencySymbol (Map TokenName Integer)
-> [(CurrencySymbol, Map TokenName Integer)]
forall k v. Map k v -> [(k, v)]
PMap.toList (Map CurrencySymbol (Map TokenName Integer)
 -> [(CurrencySymbol, Map TokenName Integer)])
-> Map CurrencySymbol (Map TokenName Integer)
-> [(CurrencySymbol, Map TokenName Integer)]
forall a b. (a -> b) -> a -> b
$ Value -> Map CurrencySymbol (Map TokenName Integer)
Api.getValue Value
v2)