{-# LANGUAGE NumericUnderscores #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Ledger.Value.CardanoAPI (
    C.Value
  , C.Lovelace(..)
  , C.AssetId(..)
  , C.PolicyId
  , C.AssetName
  , C.selectAsset
  , C.valueToList
  , C.valueFromList
  , C.selectLovelace
  , C.filterValue
  , C.negateValue
  , lovelaceToValue
  , lovelaceValueOf
  , adaValueOf
  , isZero
  , isAdaOnlyValue
  , noAdaValue
  , adaOnlyValue
  , adaToCardanoValue
  , singleton
  , assetIdValue
  , scale
  , split
  , policyId
  , toCardanoValue
  , fromCardanoValue
  , toCardanoAssetId
  , fromCardanoAssetId
  , combine
  , valueGeq
  , valueLeq
  ) where

import Cardano.Api qualified as C
import Data.Bifunctor (bimap)
import Data.List (partition)
import Data.Maybe (isJust)
import Data.Monoid (All (All, getAll))
import Data.Ratio (denominator, numerator)
import Ledger.Scripts (Language (..), MintingPolicy (MintingPolicy), Versioned (..))
import Ledger.Tx.CardanoAPI.Internal (adaToCardanoValue, fromCardanoAssetId, fromCardanoValue, toCardanoAssetId,
                                      toCardanoValue)
import Plutus.Script.Utils.V1.Scripts qualified as PV1
import Plutus.Script.Utils.V2.Scripts qualified as PV2
import PlutusTx.Lattice (JoinSemiLattice (..))

lovelaceToValue :: C.Lovelace -> C.Value
lovelaceToValue :: Lovelace -> Value
lovelaceToValue Lovelace
0 = Value
forall a. Monoid a => a
mempty
lovelaceToValue Lovelace
l = Lovelace -> Value
C.lovelaceToValue Lovelace
l

lovelaceValueOf :: Integer -> C.Value
lovelaceValueOf :: Integer -> Value
lovelaceValueOf = Lovelace -> Value
C.lovelaceToValue (Lovelace -> Value) -> (Integer -> Lovelace) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lovelace
C.Lovelace

adaValueOf :: Rational -> C.Value
adaValueOf :: Rational -> Value
adaValueOf Rational
r = if Rational -> Integer
forall a. Ratio a -> a
denominator Rational
l Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 then Integer -> Value
lovelaceValueOf (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
l) else [Char] -> Value
forall a. HasCallStack => [Char] -> a
error [Char]
"Ledger.Value.CardanoAPI: value is not a whole number of lovelace"
  where l :: Rational
l = Rational
r Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
1_000_000

isZero :: C.Value -> Bool
isZero :: Value -> Bool
isZero = ((AssetId, Quantity) -> Bool) -> [(AssetId, Quantity)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(AssetId
_, Quantity
q) -> Quantity
q Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
0) ([(AssetId, Quantity)] -> Bool)
-> (Value -> [(AssetId, Quantity)]) -> Value -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
C.valueToList

isAdaOnlyValue :: C.Value -> Bool
isAdaOnlyValue :: Value -> Bool
isAdaOnlyValue = Maybe Lovelace -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Lovelace -> Bool)
-> (Value -> Maybe Lovelace) -> Value -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Lovelace
C.valueToLovelace

noAdaValue :: C.Value -> C.Value
noAdaValue :: Value -> Value
noAdaValue = (AssetId -> Bool) -> Value -> Value
C.filterValue (AssetId -> AssetId -> Bool
forall a. Eq a => a -> a -> Bool
/= AssetId
C.AdaAssetId)

adaOnlyValue :: C.Value -> C.Value
adaOnlyValue :: Value -> Value
adaOnlyValue = (AssetId -> Bool) -> Value -> Value
C.filterValue (AssetId -> AssetId -> Bool
forall a. Eq a => a -> a -> Bool
== AssetId
C.AdaAssetId)

singleton :: C.PolicyId -> C.AssetName -> Integer -> C.Value
singleton :: PolicyId -> AssetName -> Integer -> Value
singleton PolicyId
pid AssetName
an = AssetId -> Integer -> Value
assetIdValue (PolicyId -> AssetName -> AssetId
C.AssetId PolicyId
pid AssetName
an)

assetIdValue :: C.AssetId -> Integer -> C.Value
assetIdValue :: AssetId -> Integer -> Value
assetIdValue AssetId
aid Integer
n = [(AssetId, Quantity)] -> Value
C.valueFromList [(AssetId
aid, Integer -> Quantity
C.Quantity Integer
n)]

scale :: Integer -> C.Value -> C.Value
scale :: Integer -> Value -> Value
scale Integer
i = [(AssetId, Quantity)] -> Value
C.valueFromList ([(AssetId, Quantity)] -> Value)
-> (Value -> [(AssetId, Quantity)]) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AssetId, Quantity) -> (AssetId, Quantity))
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Quantity -> Quantity)
-> (AssetId, Quantity) -> (AssetId, Quantity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Quantity -> Quantity -> Quantity
forall a. Num a => a -> a -> a
* Integer -> Quantity
C.Quantity Integer
i)) ([(AssetId, Quantity)] -> [(AssetId, Quantity)])
-> (Value -> [(AssetId, Quantity)])
-> Value
-> [(AssetId, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
C.valueToList

split :: C.Value -> (C.Value, C.Value)
split :: Value -> (Value, Value)
split = ([(AssetId, Quantity)] -> Value)
-> ([(AssetId, Quantity)] -> Value)
-> ([(AssetId, Quantity)], [(AssetId, Quantity)])
-> (Value, Value)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Value -> Value
C.negateValue (Value -> Value)
-> ([(AssetId, Quantity)] -> Value)
-> [(AssetId, Quantity)]
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AssetId, Quantity)] -> Value
C.valueFromList) [(AssetId, Quantity)] -> Value
C.valueFromList (([(AssetId, Quantity)], [(AssetId, Quantity)]) -> (Value, Value))
-> (Value -> ([(AssetId, Quantity)], [(AssetId, Quantity)]))
-> Value
-> (Value, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AssetId, Quantity) -> Bool)
-> [(AssetId, Quantity)]
-> ([(AssetId, Quantity)], [(AssetId, Quantity)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
< Quantity
0) (Quantity -> Bool)
-> ((AssetId, Quantity) -> Quantity) -> (AssetId, Quantity) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AssetId, Quantity) -> Quantity
forall a b. (a, b) -> b
snd) ([(AssetId, Quantity)]
 -> ([(AssetId, Quantity)], [(AssetId, Quantity)]))
-> (Value -> [(AssetId, Quantity)])
-> Value
-> ([(AssetId, Quantity)], [(AssetId, Quantity)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
C.valueToList

policyId :: Versioned MintingPolicy -> C.PolicyId
policyId :: Versioned MintingPolicy -> PolicyId
policyId (Versioned (MintingPolicy Script
mp) Language
PlutusV1) = Script PlutusScriptV1 -> PolicyId
forall lang. Script lang -> PolicyId
C.scriptPolicyId (Script -> Script PlutusScriptV1
PV1.toCardanoApiScript Script
mp)
policyId (Versioned (MintingPolicy Script
mp) Language
PlutusV2) = Script PlutusScriptV2 -> PolicyId
forall lang. Script lang -> PolicyId
C.scriptPolicyId (Script -> Script PlutusScriptV2
PV2.toCardanoApiScript Script
mp)

combine :: Monoid m => (C.AssetId -> C.Quantity -> C.Quantity -> m) -> C.Value -> C.Value -> m
combine :: (AssetId -> Quantity -> Quantity -> m) -> Value -> Value -> m
combine AssetId -> Quantity -> Quantity -> m
f Value
v1 Value
v2 = [(AssetId, Quantity)] -> [(AssetId, Quantity)] -> m
merge (Value -> [(AssetId, Quantity)]
C.valueToList Value
v1) (Value -> [(AssetId, Quantity)]
C.valueToList Value
v2)
    where
        -- Merge assuming the lists are ascending (thanks to Map.toList)
        merge :: [(AssetId, Quantity)] -> [(AssetId, Quantity)] -> m
merge [] [] = m
forall a. Monoid a => a
mempty
        merge [] ((AssetId
ar, Quantity
qr):[(AssetId, Quantity)]
rs) = AssetId -> Quantity -> Quantity -> m
f AssetId
ar Quantity
0 Quantity
qr m -> m -> m
forall a. Semigroup a => a -> a -> a
<> [(AssetId, Quantity)] -> [(AssetId, Quantity)] -> m
merge [] [(AssetId, Quantity)]
rs
        merge ((AssetId
al, Quantity
ql):[(AssetId, Quantity)]
ls) [] = AssetId -> Quantity -> Quantity -> m
f AssetId
al Quantity
ql Quantity
0 m -> m -> m
forall a. Semigroup a => a -> a -> a
<> [(AssetId, Quantity)] -> [(AssetId, Quantity)] -> m
merge [(AssetId, Quantity)]
ls []
        merge ls' :: [(AssetId, Quantity)]
ls'@((AssetId
al, Quantity
ql):[(AssetId, Quantity)]
ls) rs' :: [(AssetId, Quantity)]
rs'@((AssetId
ar, Quantity
qr):[(AssetId, Quantity)]
rs) = case AssetId -> AssetId -> Ordering
forall a. Ord a => a -> a -> Ordering
compare AssetId
al AssetId
ar of
            Ordering
EQ -> AssetId -> Quantity -> Quantity -> m
f AssetId
al Quantity
ql Quantity
qr m -> m -> m
forall a. Semigroup a => a -> a -> a
<> [(AssetId, Quantity)] -> [(AssetId, Quantity)] -> m
merge [(AssetId, Quantity)]
ls [(AssetId, Quantity)]
rs
            Ordering
LT -> AssetId -> Quantity -> Quantity -> m
f AssetId
al Quantity
ql Quantity
0 m -> m -> m
forall a. Semigroup a => a -> a -> a
<> [(AssetId, Quantity)] -> [(AssetId, Quantity)] -> m
merge [(AssetId, Quantity)]
ls [(AssetId, Quantity)]
rs'
            Ordering
GT -> AssetId -> Quantity -> Quantity -> m
f AssetId
ar Quantity
0 Quantity
qr m -> m -> m
forall a. Semigroup a => a -> a -> a
<> [(AssetId, Quantity)] -> [(AssetId, Quantity)] -> m
merge [(AssetId, Quantity)]
ls' [(AssetId, Quantity)]
rs

valueGeq :: C.Value -> C.Value -> Bool
valueGeq :: Value -> Value -> Bool
valueGeq Value
lv Value
rv = All -> Bool
getAll (All -> Bool) -> All -> Bool
forall a b. (a -> b) -> a -> b
$ (AssetId -> Quantity -> Quantity -> All) -> Value -> Value -> All
forall m.
Monoid m =>
(AssetId -> Quantity -> Quantity -> m) -> Value -> Value -> m
combine (\AssetId
_ Quantity
l Quantity
r -> Bool -> All
All (Quantity
l Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
>= Quantity
r)) Value
lv Value
rv

valueLeq :: C.Value -> C.Value -> Bool
valueLeq :: Value -> Value -> Bool
valueLeq Value
lv Value
rv = All -> Bool
getAll (All -> Bool) -> All -> Bool
forall a b. (a -> b) -> a -> b
$ (AssetId -> Quantity -> Quantity -> All) -> Value -> Value -> All
forall m.
Monoid m =>
(AssetId -> Quantity -> Quantity -> m) -> Value -> Value -> m
combine (\AssetId
_ Quantity
l Quantity
r -> Bool -> All
All (Quantity
l Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
<= Quantity
r)) Value
lv Value
rv

instance JoinSemiLattice C.Value where
  \/ :: Value -> Value -> Value
(\/) = (AssetId -> Quantity -> Quantity -> Value)
-> Value -> Value -> Value
forall m.
Monoid m =>
(AssetId -> Quantity -> Quantity -> m) -> Value -> Value -> m
combine (\AssetId
a Quantity
ql Quantity
qr -> [(AssetId, Quantity)] -> Value
C.valueFromList [(AssetId
a, Quantity
ql Quantity -> Quantity -> Quantity
forall a. Ord a => a -> a -> a
`max` Quantity
qr)])