{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module PlutusCore.Value
  ( Value -- Do not expose data constructor
  , K -- Do not expose data constructor
  , k
  , unK
  , maxKeyLen
  , Quantity -- Do not expose data constructor
  , quantity
  , unQuantity
  , zeroQuantity
  , addQuantity
  , negativeAmounts
  , NestedMap
  , unpack
  , pack
  , empty
  , fromList
  , toList
  , toFlatList
  , totalSize
  , maxInnerSize
  , insertCoin
  , deleteCoin
  , scaleValue
  , lookupCoin
  , valueContains
  , unionValue
  , valueData
  , unValueData
  ) where

import Codec.CBOR.Decoding qualified as CBOR
import Codec.Serialise qualified as CBOR
import Control.DeepSeq (NFData)
import Control.Monad.Extra (replicateM, unless, when, whenJust, (>=>))
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Base64 qualified as Base64
import Data.Foldable (find)
import Data.Hashable (Hashable (..))
import Data.IntMap.Strict (IntMap)
import Data.IntMap.Strict qualified as IntMap
import Data.Map.Merge.Strict qualified as M
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text.Encoding qualified as Text
import GHC.Generics
import GHC.Stack
  ( HasCallStack
  , callStack
  , getCallStack
  )

import PlutusCore.Builtin.Result
import PlutusCore.Data (Data (..))
import PlutusCore.Flat qualified as Flat
import PlutusCore.Flat.Decoder qualified as Flat
import PlutusPrelude (Pretty (..))

-- Max length (in bytes) for currency symbols and token names in `Value`,
-- both of which cannot exceed 32 bytes. Currency symbols are in fact either
-- empty or 28 bytes, but for simplicity we allow anything between 0 and 32 bytes.
maxKeyLen :: Int
maxKeyLen :: Int
maxKeyLen = Int
32
{-# INLINE maxKeyLen #-}

----------------------------------------------------------------------------------------------------
-- Newtype-wrapper for keys used in the nested maps ------------------------------------------------

-- | A `ByteString` with maximum length of `maxKeyLen` bytes.
newtype K = UnsafeK {K -> ByteString
unK :: ByteString}
  deriving newtype (K -> K -> Bool
(K -> K -> Bool) -> (K -> K -> Bool) -> Eq K
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: K -> K -> Bool
== :: K -> K -> Bool
$c/= :: K -> K -> Bool
/= :: K -> K -> Bool
Eq, Eq K
Eq K =>
(K -> K -> Ordering)
-> (K -> K -> Bool)
-> (K -> K -> Bool)
-> (K -> K -> Bool)
-> (K -> K -> Bool)
-> (K -> K -> K)
-> (K -> K -> K)
-> Ord K
K -> K -> Bool
K -> K -> Ordering
K -> K -> K
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: K -> K -> Ordering
compare :: K -> K -> Ordering
$c< :: K -> K -> Bool
< :: K -> K -> Bool
$c<= :: K -> K -> Bool
<= :: K -> K -> Bool
$c> :: K -> K -> Bool
> :: K -> K -> Bool
$c>= :: K -> K -> Bool
>= :: K -> K -> Bool
$cmax :: K -> K -> K
max :: K -> K -> K
$cmin :: K -> K -> K
min :: K -> K -> K
Ord, Int -> K -> ShowS
[K] -> ShowS
K -> String
(Int -> K -> ShowS) -> (K -> String) -> ([K] -> ShowS) -> Show K
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> K -> ShowS
showsPrec :: Int -> K -> ShowS
$cshow :: K -> String
show :: K -> String
$cshowList :: [K] -> ShowS
showList :: [K] -> ShowS
Show, Eq K
Eq K => (Int -> K -> Int) -> (K -> Int) -> Hashable K
Int -> K -> Int
K -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> K -> Int
hashWithSalt :: Int -> K -> Int
$chash :: K -> Int
hash :: K -> Int
Hashable, K -> ()
(K -> ()) -> NFData K
forall a. (a -> ()) -> NFData a
$crnf :: K -> ()
rnf :: K -> ()
NFData)
  deriving stock ((forall x. K -> Rep K x) -> (forall x. Rep K x -> K) -> Generic K
forall x. Rep K x -> K
forall x. K -> Rep K x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. K -> Rep K x
from :: forall x. K -> Rep K x
$cto :: forall x. Rep K x -> K
to :: forall x. Rep K x -> K
Generic)

k :: ByteString -> Maybe K
k :: ByteString -> Maybe K
k ByteString
b = if ByteString -> Int
B.length ByteString
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxKeyLen then K -> Maybe K
forall a. a -> Maybe a
Just (ByteString -> K
UnsafeK ByteString
b) else Maybe K
forall a. Maybe a
Nothing
{-# INLINEABLE k #-}

instance Flat.Flat K where
  encode :: K -> Encoding
encode (UnsafeK ByteString
b) = ByteString -> Encoding
forall a. Flat a => a -> Encoding
Flat.encode ByteString
b
  {-# INLINE encode #-}
  decode :: Get K
decode = do
    ByteString
b <- Get ByteString
forall a. Flat a => Get a
Flat.decode
    Get K -> (K -> Get K) -> Maybe K -> Get K
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Get K
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get K) -> String -> Get K
forall a b. (a -> b) -> a -> b
$ String
"Invalid Value key: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Word8] -> String
forall a. Show a => a -> String
show (ByteString -> [Word8]
B.unpack ByteString
b)) K -> Get K
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe K
k ByteString
b)
  {-# INLINEABLE decode #-}

instance CBOR.Serialise K where
  encode :: K -> Encoding
encode (UnsafeK ByteString
b) = ByteString -> Encoding
forall a. Serialise a => a -> Encoding
CBOR.encode ByteString
b
  {-# INLINE encode #-}
  decode :: forall s. Decoder s K
decode = do
    ByteString
b <- Decoder s ByteString
forall s. Decoder s ByteString
forall a s. Serialise a => Decoder s a
CBOR.decode
    Decoder s K -> (K -> Decoder s K) -> Maybe K -> Decoder s K
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Decoder s K
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s K) -> String -> Decoder s K
forall a b. (a -> b) -> a -> b
$ String
"Invalid Value key: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Word8] -> String
forall a. Show a => a -> String
show (ByteString -> [Word8]
B.unpack ByteString
b)) K -> Decoder s K
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe K
k ByteString
b)
  {-# INLINEABLE decode #-}

----------------------------------------------------------------------------------------------------
-- Quantity: Signed 128-bit Integer ----------------------------------------------------------------

-- | A signed 128-bit integer quantity.
newtype Quantity = UnsafeQuantity {Quantity -> Integer
unQuantity :: Integer}
  deriving newtype (Quantity -> Quantity -> Bool
(Quantity -> Quantity -> Bool)
-> (Quantity -> Quantity -> Bool) -> Eq Quantity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Quantity -> Quantity -> Bool
== :: Quantity -> Quantity -> Bool
$c/= :: Quantity -> Quantity -> Bool
/= :: Quantity -> Quantity -> Bool
Eq, Eq Quantity
Eq Quantity =>
(Quantity -> Quantity -> Ordering)
-> (Quantity -> Quantity -> Bool)
-> (Quantity -> Quantity -> Bool)
-> (Quantity -> Quantity -> Bool)
-> (Quantity -> Quantity -> Bool)
-> (Quantity -> Quantity -> Quantity)
-> (Quantity -> Quantity -> Quantity)
-> Ord Quantity
Quantity -> Quantity -> Bool
Quantity -> Quantity -> Ordering
Quantity -> Quantity -> Quantity
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Quantity -> Quantity -> Ordering
compare :: Quantity -> Quantity -> Ordering
$c< :: Quantity -> Quantity -> Bool
< :: Quantity -> Quantity -> Bool
$c<= :: Quantity -> Quantity -> Bool
<= :: Quantity -> Quantity -> Bool
$c> :: Quantity -> Quantity -> Bool
> :: Quantity -> Quantity -> Bool
$c>= :: Quantity -> Quantity -> Bool
>= :: Quantity -> Quantity -> Bool
$cmax :: Quantity -> Quantity -> Quantity
max :: Quantity -> Quantity -> Quantity
$cmin :: Quantity -> Quantity -> Quantity
min :: Quantity -> Quantity -> Quantity
Ord, Int -> Quantity -> ShowS
[Quantity] -> ShowS
Quantity -> String
(Int -> Quantity -> ShowS)
-> (Quantity -> String) -> ([Quantity] -> ShowS) -> Show Quantity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Quantity -> ShowS
showsPrec :: Int -> Quantity -> ShowS
$cshow :: Quantity -> String
show :: Quantity -> String
$cshowList :: [Quantity] -> ShowS
showList :: [Quantity] -> ShowS
Show, Quantity -> ()
(Quantity -> ()) -> NFData Quantity
forall a. (a -> ()) -> NFData a
$crnf :: Quantity -> ()
rnf :: Quantity -> ()
NFData, Eq Quantity
Eq Quantity =>
(Int -> Quantity -> Int) -> (Quantity -> Int) -> Hashable Quantity
Int -> Quantity -> Int
Quantity -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Quantity -> Int
hashWithSalt :: Int -> Quantity -> Int
$chash :: Quantity -> Int
hash :: Quantity -> Int
Hashable)
  deriving stock ((forall x. Quantity -> Rep Quantity x)
-> (forall x. Rep Quantity x -> Quantity) -> Generic Quantity
forall x. Rep Quantity x -> Quantity
forall x. Quantity -> Rep Quantity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Quantity -> Rep Quantity x
from :: forall x. Quantity -> Rep Quantity x
$cto :: forall x. Rep Quantity x -> Quantity
to :: forall x. Rep Quantity x -> Quantity
Generic)

instance CBOR.Serialise Quantity where
  encode :: Quantity -> Encoding
encode (UnsafeQuantity Integer
i) = Integer -> Encoding
forall a. Serialise a => a -> Encoding
CBOR.encode Integer
i
  {-# INLINE encode #-}
  decode :: forall s. Decoder s Quantity
decode = do
    Integer
i <- Decoder s Integer
forall s. Decoder s Integer
forall a s. Serialise a => Decoder s a
CBOR.decode
    case Integer -> Maybe Quantity
quantity Integer
i of
      Just Quantity
q -> Quantity -> Decoder s Quantity
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Quantity
q
      Maybe Quantity
Nothing -> String -> Decoder s Quantity
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s Quantity) -> String -> Decoder s Quantity
forall a b. (a -> b) -> a -> b
$ String
"Quantity out of signed 128-bit integer bounds: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
i
  {-# INLINEABLE decode #-}

instance Flat.Flat Quantity where
  encode :: Quantity -> Encoding
encode (UnsafeQuantity Integer
i) = Integer -> Encoding
forall a. Flat a => a -> Encoding
Flat.encode Integer
i
  {-# INLINE encode #-}
  decode :: Get Quantity
decode = do
    Integer
i <- Get Integer
forall a. Flat a => Get a
Flat.decode
    case Integer -> Maybe Quantity
quantity Integer
i of
      Just Quantity
q -> Quantity -> Get Quantity
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Quantity
q
      Maybe Quantity
Nothing -> String -> Get Quantity
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Quantity) -> String -> Get Quantity
forall a b. (a -> b) -> a -> b
$ String
"Quantity out of signed 128-bit integer bounds: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
i
  {-# INLINEABLE decode #-}

instance Pretty Quantity where
  pretty :: forall ann. Quantity -> Doc ann
pretty (UnsafeQuantity Integer
i) = Integer -> Doc ann
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i

instance Bounded Quantity where
  minBound :: Quantity
minBound = Integer -> Quantity
UnsafeQuantity (-(Integer
2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
127 :: Integer)))
  {-# INLINE minBound #-}
  maxBound :: Quantity
maxBound = Integer -> Quantity
UnsafeQuantity (Integer
2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
127 :: Integer) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
  {-# INLINE maxBound #-}

-- | Smart constructor for Quantity that validates bounds.
quantity :: Integer -> Maybe Quantity
quantity :: Integer -> Maybe Quantity
quantity Integer
i
  | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Quantity -> Integer
unQuantity Quantity
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Quantity -> Integer
unQuantity Quantity
forall a. Bounded a => a
maxBound = Quantity -> Maybe Quantity
forall a. a -> Maybe a
Just (Integer -> Quantity
UnsafeQuantity Integer
i)
  | Bool
otherwise = Maybe Quantity
forall a. Maybe a
Nothing
{-# INLINEABLE quantity #-}

-- | The zero quantity.
zeroQuantity :: Quantity
zeroQuantity :: Quantity
zeroQuantity = Integer -> Quantity
UnsafeQuantity Integer
0
{-# INLINE zeroQuantity #-}

-- | Safely add two quantities, checking for overflow.
addQuantity :: Quantity -> Quantity -> Maybe Quantity
addQuantity :: Quantity -> Quantity -> Maybe Quantity
addQuantity (UnsafeQuantity Integer
x) (UnsafeQuantity Integer
y) = Integer -> Maybe Quantity
quantity (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
y)
{-# INLINEABLE addQuantity #-}

-- | Safely scale a quantity with given integer, checking for overflow.
scaleQuantity :: Integer -> Quantity -> Maybe Quantity
scaleQuantity :: Integer -> Quantity -> Maybe Quantity
scaleQuantity Integer
x (UnsafeQuantity Integer
y) = Integer -> Maybe Quantity
quantity (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
y)
{-# INLINEABLE scaleQuantity #-}

----------------------------------------------------------------------------------------------------
-- Builtin Value definition ------------------------------------------------------------------------

type NestedMap = Map K (Map K Quantity)

-- | The underlying type of the UPLC built-in type @Value@.
data Value
  = Value
      !NestedMap
      {-^ Map from (currency symbol, token name) to quantity.

      Invariants: no empty inner map, and no zero quantity. -}
      !(IntMap Int)
      {-^ Map from size to the number of inner maps that have that size.
      This allows efficient retrieval of the size of the largest inner map,
      which is useful for costing of operations like `lookupCoin`.

      Invariant: all values are positive. -}
      {-# UNPACK #-} !Int
      {-^ Total size, i.e., sum total of inner map sizes. This avoids recomputing
      the total size during the costing of operations like `unionValue`. -}
      {-# UNPACK #-} !Int
      -- ^ The number of negative amounts it contains.
  deriving stock (Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: Value -> Value -> Bool
Eq, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Value -> ShowS
showsPrec :: Int -> Value -> ShowS
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> ShowS
showList :: [Value] -> ShowS
Show, (forall x. Value -> Rep Value x)
-> (forall x. Rep Value x -> Value) -> Generic Value
forall x. Rep Value x -> Value
forall x. Value -> Rep Value x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Value -> Rep Value x
from :: forall x. Value -> Rep Value x
$cto :: forall x. Rep Value x -> Value
to :: forall x. Rep Value x -> Value
Generic)
  deriving anyclass (Value -> ()
(Value -> ()) -> NFData Value
forall a. (a -> ()) -> NFData a
$crnf :: Value -> ()
rnf :: Value -> ()
NFData)

instance Hashable Value where
  hash :: Value -> Int
hash = NestedMap -> Int
forall a. Hashable a => a -> Int
hash (NestedMap -> Int) -> (Value -> NestedMap) -> Value -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> NestedMap
unpack
  {-# INLINE hash #-}
  hashWithSalt :: Int -> Value -> Int
hashWithSalt Int
salt = Int -> NestedMap -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (NestedMap -> Int) -> (Value -> NestedMap) -> Value -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> NestedMap
unpack
  {-# INLINE hashWithSalt #-}

instance CBOR.Serialise Value where
  encode :: Value -> Encoding
encode (Value NestedMap
v IntMap Int
_ Int
_ Int
_) = NestedMap -> Encoding
forall a. Serialise a => a -> Encoding
CBOR.encode NestedMap
v
  {-# INLINE encode #-}
  decode :: forall s. Decoder s Value
decode = do
    Int
outerLen <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeMapLen
    [(K, [(K, Quantity)])]
outer <- Int
-> Decoder s (K, [(K, Quantity)])
-> Decoder s [(K, [(K, Quantity)])]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
outerLen (Decoder s (K, [(K, Quantity)])
 -> Decoder s [(K, [(K, Quantity)])])
-> Decoder s (K, [(K, Quantity)])
-> Decoder s [(K, [(K, Quantity)])]
forall a b. (a -> b) -> a -> b
$ do
      K
currency <- Decoder s K
forall s. Decoder s K
forall a s. Serialise a => Decoder s a
CBOR.decode
      Int
innerLen <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeMapLen
      [(K, Quantity)]
inner <- Int -> Decoder s (K, Quantity) -> Decoder s [(K, Quantity)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
innerLen ((,) (K -> Quantity -> (K, Quantity))
-> Decoder s K -> Decoder s (Quantity -> (K, Quantity))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s K
forall s. Decoder s K
forall a s. Serialise a => Decoder s a
CBOR.decode Decoder s (Quantity -> (K, Quantity))
-> Decoder s Quantity -> Decoder s (K, Quantity)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s Quantity
forall s. Decoder s Quantity
forall a s. Serialise a => Decoder s a
CBOR.decode)
      (K, [(K, Quantity)]) -> Decoder s (K, [(K, Quantity)])
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (K
currency, [(K, Quantity)]
inner)
    String
-> ((K, [(K, Quantity)]) -> Decoder s (K, [(K, Quantity)]))
-> ((K, Quantity) -> Decoder s (K, Quantity))
-> [(K, [(K, Quantity)])]
-> Decoder s Value
forall (m :: * -> *) a b.
MonadFail m =>
String
-> (a -> m (K, [b])) -> (b -> m (K, Quantity)) -> [a] -> m Value
buildValueWith String
"Value CBOR decoder" (K, [(K, Quantity)]) -> Decoder s (K, [(K, Quantity)])
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (K, Quantity) -> Decoder s (K, Quantity)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(K, [(K, Quantity)])]
outer
  {-# INLINE decode #-}

instance Flat.Flat Value where
  encode :: Value -> Encoding
encode (Value NestedMap
v IntMap Int
_ Int
_ Int
_) = NestedMap -> Encoding
forall a. Flat a => a -> Encoding
Flat.encode NestedMap
v
  {-# INLINE encode #-}
  decode :: Get Value
decode = do
    [(K, [(K, Quantity)])]
outer <- Get (K, [(K, Quantity)]) -> Get [(K, [(K, Quantity)])]
forall a. Get a -> Get [a]
Flat.decodeListWith (Get (K, [(K, Quantity)]) -> Get [(K, [(K, Quantity)])])
-> Get (K, [(K, Quantity)]) -> Get [(K, [(K, Quantity)])]
forall a b. (a -> b) -> a -> b
$ do
      K
currency <- Get K
forall a. Flat a => Get a
Flat.decode
      [(K, Quantity)]
inner <- Get (K, Quantity) -> Get [(K, Quantity)]
forall a. Get a -> Get [a]
Flat.decodeListWith ((,) (K -> Quantity -> (K, Quantity))
-> Get K -> Get (Quantity -> (K, Quantity))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get K
forall a. Flat a => Get a
Flat.decode Get (Quantity -> (K, Quantity))
-> Get Quantity -> Get (K, Quantity)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Quantity
forall a. Flat a => Get a
Flat.decode)
      (K, [(K, Quantity)]) -> Get (K, [(K, Quantity)])
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (K
currency, [(K, Quantity)]
inner)
    String
-> ((K, [(K, Quantity)]) -> Get (K, [(K, Quantity)]))
-> ((K, Quantity) -> Get (K, Quantity))
-> [(K, [(K, Quantity)])]
-> Get Value
forall (m :: * -> *) a b.
MonadFail m =>
String
-> (a -> m (K, [b])) -> (b -> m (K, Quantity)) -> [a] -> m Value
buildValueWith String
"Value Flat decoder" (K, [(K, Quantity)]) -> Get (K, [(K, Quantity)])
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (K, Quantity) -> Get (K, Quantity)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(K, [(K, Quantity)])]
outer
  {-# INLINE decode #-}
  size :: Value -> Int -> Int
size (Value NestedMap
v IntMap Int
_ Int
_ Int
_) = NestedMap -> Int -> Int
forall a. Flat a => a -> Int -> Int
Flat.size NestedMap
v
  {-# INLINE size #-}

{-| Unpack a `Value` into a map from (currency symbol, token name) to quantity.

The map is guaranteed to not contain empty inner map or zero quantity. -}
unpack :: Value -> NestedMap
unpack :: Value -> NestedMap
unpack (Value NestedMap
v IntMap Int
_ Int
_ Int
_) = NestedMap
v
{-# INLINE unpack #-}

{-| Pack a map from (currency symbol, token name) to quantity into a `Value`.

The map will be filtered so that it does not contain empty inner map or zero quantity. -}
pack :: NestedMap -> Value
pack :: NestedMap -> Value
pack = NestedMap -> Value
pack' (NestedMap -> Value)
-> (NestedMap -> NestedMap) -> NestedMap -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NestedMap -> NestedMap
normalize
{-# INLINE pack #-}

-- | Like `pack` but does not normalize.
pack' :: NestedMap -> Value
pack' :: NestedMap -> Value
pack' NestedMap
v = NestedMap -> IntMap Int -> Int -> Int -> Value
Value NestedMap
v IntMap Int
sizes Int
total Int
neg
  where
    (IntMap Int
sizes, Int
total, Int
neg) = ((IntMap Int, Int, Int)
 -> Map K Quantity -> (IntMap Int, Int, Int))
-> (IntMap Int, Int, Int) -> NestedMap -> (IntMap Int, Int, Int)
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' (IntMap Int, Int, Int) -> Map K Quantity -> (IntMap Int, Int, Int)
forall {a} {k}.
Num a =>
(IntMap a, Int, Int) -> Map k Quantity -> (IntMap a, Int, Int)
alg (IntMap Int
forall a. Monoid a => a
mempty, Int
0, Int
0) NestedMap
v
    alg :: (IntMap a, Int, Int) -> Map k Quantity -> (IntMap a, Int, Int)
alg (IntMap a
ss, Int
t, Int
n) Map k Quantity
inner =
      ( (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IntMap.alter (Maybe a -> (a -> Maybe a) -> Maybe a -> Maybe a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Maybe a
forall a. a -> Maybe a
Just a
1) (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (a -> a) -> a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> a
forall a. Num a => a -> a -> a
+ a
1))) (Map k Quantity -> Int
forall k a. Map k a -> Int
Map.size Map k Quantity
inner) IntMap a
ss
      , Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Map k Quantity -> Int
forall k a. Map k a -> Int
Map.size Map k Quantity
inner
      , Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Map k Quantity -> Int
forall k a. Map k a -> Int
Map.size ((Quantity -> Bool) -> Map k Quantity -> Map k Quantity
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
< Quantity
zeroQuantity) Map k Quantity
inner)
      )
{-# INLINEABLE pack' #-}

{-| Total size, i.e., the number of distinct `(currency symbol, token name)` pairs
contained in the `Value`. -}
totalSize :: Value -> Int
totalSize :: Value -> Int
totalSize (Value NestedMap
_ IntMap Int
_ Int
total Int
_) = Int
total
{-# INLINE totalSize #-}

-- | Size of the largest inner map.
maxInnerSize :: Value -> Int
maxInnerSize :: Value -> Int
maxInnerSize (Value NestedMap
_ IntMap Int
sizes Int
_ Int
_) = Int -> ((Int, Int) -> Int) -> Maybe (Int, Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int, Int) -> Int
forall a b. (a, b) -> a
fst (IntMap Int -> Maybe (Int, Int)
forall a. IntMap a -> Maybe (Int, a)
IntMap.lookupMax IntMap Int
sizes)
{-# INLINE maxInnerSize #-}

negativeAmounts :: Value -> Int
negativeAmounts :: Value -> Int
negativeAmounts (Value NestedMap
_ IntMap Int
_ Int
_ Int
neg) = Int
neg
{-# INLINE negativeAmounts #-}

empty :: Value
empty :: Value
empty = NestedMap -> IntMap Int -> Int -> Int -> Value
Value NestedMap
forall a. Monoid a => a
mempty IntMap Int
forall a. Monoid a => a
mempty Int
0 Int
0
{-# INLINE empty #-}

toList :: Value -> [(K, [(K, Quantity)])]
toList :: Value -> [(K, [(K, Quantity)])]
toList = Map K [(K, Quantity)] -> [(K, [(K, Quantity)])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map K [(K, Quantity)] -> [(K, [(K, Quantity)])])
-> (Value -> Map K [(K, Quantity)])
-> Value
-> [(K, [(K, Quantity)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map K Quantity -> [(K, Quantity)])
-> NestedMap -> Map K [(K, Quantity)]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Map K Quantity -> [(K, Quantity)]
forall k a. Map k a -> [(k, a)]
Map.toList (NestedMap -> Map K [(K, Quantity)])
-> (Value -> NestedMap) -> Value -> Map K [(K, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> NestedMap
unpack
{-# INLINEABLE toList #-}

toFlatList :: Value -> [(K, K, Quantity)]
toFlatList :: Value -> [(K, K, Quantity)]
toFlatList (Value -> [(K, [(K, Quantity)])]
toList -> [(K, [(K, Quantity)])]
xs) = [(K
c, K
t, Quantity
a) | (K
c, [(K, Quantity)]
ys) <- [(K, [(K, Quantity)])]
xs, (K
t, Quantity
a) <- [(K, Quantity)]
ys]
{-# INLINEABLE toFlatList #-}

fromList :: [(K, [(K, Quantity)])] -> BuiltinResult Value
fromList :: [(K, [(K, Quantity)])] -> BuiltinResult Value
fromList [(K, [(K, Quantity)])]
xs = do
  -- Use unchecked addition during construction
  let outerMap :: NestedMap
outerMap =
        (Map K Quantity -> Map K Quantity -> Map K Quantity)
-> [(K, Map K Quantity)] -> NestedMap
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
          ((Quantity -> Quantity -> Quantity)
-> Map K Quantity -> Map K Quantity -> Map K Quantity
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Quantity -> Quantity -> Quantity
unsafeAddQuantity) -- combine inner maps with unchecked addition
          (([(K, Quantity)] -> Map K Quantity)
-> (K, [(K, Quantity)]) -> (K, Map K Quantity)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Quantity -> Quantity -> Quantity)
-> [(K, Quantity)] -> Map K Quantity
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Quantity -> Quantity -> Quantity
unsafeAddQuantity) ((K, [(K, Quantity)]) -> (K, Map K Quantity))
-> [(K, [(K, Quantity)])] -> [(K, Map K Quantity)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(K, [(K, Quantity)])]
xs)
  -- Validate all quantities are within bounds
  NestedMap -> Value
pack (NestedMap -> Value)
-> BuiltinResult NestedMap -> BuiltinResult Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => NestedMap -> BuiltinResult NestedMap
NestedMap -> BuiltinResult NestedMap
validateQuantities NestedMap
outerMap
{-# INLINEABLE fromList #-}

-- | Unsafe addition of quantities without bounds checking.
unsafeAddQuantity :: Quantity -> Quantity -> Quantity
unsafeAddQuantity :: Quantity -> Quantity -> Quantity
unsafeAddQuantity (UnsafeQuantity Integer
x) (UnsafeQuantity Integer
y) = Integer -> Quantity
UnsafeQuantity (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
y)
{-# INLINE unsafeAddQuantity #-}

-- | Validate all quantities in a nested map are within bounds.
validateQuantities :: HasCallStack => NestedMap -> BuiltinResult NestedMap
validateQuantities :: HasCallStack => NestedMap -> BuiltinResult NestedMap
validateQuantities NestedMap
nestedMap =
  case (Quantity -> Bool) -> [Quantity] -> Maybe Quantity
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Quantity -> Bool
isOutOfBounds [Quantity]
allQuantities of
    Just (UnsafeQuantity Integer
i) -> String -> BuiltinResult NestedMap
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> BuiltinResult NestedMap)
-> String -> BuiltinResult NestedMap
forall a b. (a -> b) -> a -> b
$ String
context String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": quantity out of bounds: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
i
    Maybe Quantity
Nothing -> NestedMap -> BuiltinResult NestedMap
forall a. a -> BuiltinResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NestedMap
nestedMap
  where
    allQuantities :: [Quantity]
allQuantities = (Map K Quantity -> [Quantity]) -> [Map K Quantity] -> [Quantity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Map K Quantity -> [Quantity]
forall k a. Map k a -> [a]
Map.elems ([Map K Quantity] -> [Quantity]) -> [Map K Quantity] -> [Quantity]
forall a b. (a -> b) -> a -> b
$ NestedMap -> [Map K Quantity]
forall k a. Map k a -> [a]
Map.elems NestedMap
nestedMap
    isOutOfBounds :: Quantity -> Bool
isOutOfBounds (UnsafeQuantity Integer
i) =
      Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Quantity -> Integer
unQuantity Quantity
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
|| Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Quantity -> Integer
unQuantity Quantity
forall a. Bounded a => a
maxBound
    context :: String
context = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack of
      (String
fnName, SrcLoc
_) : [(String, SrcLoc)]
_ -> String
fnName
      [] -> String
"<unknown>"
{-# INLINEABLE validateQuantities #-}

normalize :: NestedMap -> NestedMap
normalize :: NestedMap -> NestedMap
normalize = (Map K Quantity -> Bool) -> NestedMap -> NestedMap
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool)
-> (Map K Quantity -> Bool) -> Map K Quantity -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map K Quantity -> Bool
forall k a. Map k a -> Bool
Map.null) (NestedMap -> NestedMap)
-> (NestedMap -> NestedMap) -> NestedMap -> NestedMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map K Quantity -> Map K Quantity) -> NestedMap -> NestedMap
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Quantity -> Bool) -> Map K Quantity -> Map K Quantity
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
/= Quantity
zeroQuantity))
{-# INLINEABLE normalize #-}

instance Pretty Value where
  pretty :: forall ann. Value -> Doc ann
pretty = [(Text, [(Text, Quantity)])] -> Doc ann
forall ann. [(Text, [(Text, Quantity)])] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([(Text, [(Text, Quantity)])] -> Doc ann)
-> (Value -> [(Text, [(Text, Quantity)])]) -> Value -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((K, [(K, Quantity)]) -> (Text, [(Text, Quantity)]))
-> [(K, [(K, Quantity)])] -> [(Text, [(Text, Quantity)])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((K -> Text)
-> ([(K, Quantity)] -> [(Text, Quantity)])
-> (K, [(K, Quantity)])
-> (Text, [(Text, Quantity)])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap K -> Text
toText (((K, Quantity) -> (Text, Quantity))
-> [(K, Quantity)] -> [(Text, Quantity)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((K -> Text) -> (K, Quantity) -> (Text, Quantity)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first K -> Text
toText))) ([(K, [(K, Quantity)])] -> [(Text, [(Text, Quantity)])])
-> (Value -> [(K, [(K, Quantity)])])
-> Value
-> [(Text, [(Text, Quantity)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(K, [(K, Quantity)])]
toList
    where
      toText :: K -> Text
toText = ByteString -> Text
Text.decodeLatin1 (ByteString -> Text) -> (K -> ByteString) -> K -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode (ByteString -> ByteString) -> (K -> ByteString) -> K -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K -> ByteString
unK

{-| \(O(\log \max(m, k))\), where \(m\) is the size of the outer map, and \(k\) is
the size of the largest inner map. -}
insertCoin :: ByteString -> ByteString -> Integer -> Value -> BuiltinResult Value
insertCoin :: ByteString -> ByteString -> Integer -> Value -> BuiltinResult Value
insertCoin ByteString
unsafeCurrency ByteString
unsafeToken Integer
unsafeAmount v :: Value
v@(Value NestedMap
outer IntMap Int
sizes Int
total Int
neg)
  | Integer
unsafeAmount Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = Value -> BuiltinResult Value
forall a. a -> BuiltinResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> BuiltinResult Value) -> Value -> BuiltinResult Value
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Value -> Value
deleteCoin ByteString
unsafeCurrency ByteString
unsafeToken Value
v
  | Bool
otherwise = case (ByteString -> Maybe K
k ByteString
unsafeCurrency, ByteString -> Maybe K
k ByteString
unsafeToken, Integer -> Maybe Quantity
quantity Integer
unsafeAmount) of
      (Maybe K
Nothing, Maybe K
_, Maybe Quantity
_) -> String -> BuiltinResult Value
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> BuiltinResult Value) -> String -> BuiltinResult Value
forall a b. (a -> b) -> a -> b
$ String
"insertCoin: invalid currency: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Word8] -> String
forall a. Show a => a -> String
show (ByteString -> [Word8]
B.unpack ByteString
unsafeCurrency)
      (Maybe K
_, Maybe K
Nothing, Maybe Quantity
_) -> String -> BuiltinResult Value
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> BuiltinResult Value) -> String -> BuiltinResult Value
forall a b. (a -> b) -> a -> b
$ String
"insertCoin: invalid token: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Word8] -> String
forall a. Show a => a -> String
show (ByteString -> [Word8]
B.unpack ByteString
unsafeToken)
      (Maybe K
_, Maybe K
_, Maybe Quantity
Nothing) -> String -> BuiltinResult Value
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> BuiltinResult Value) -> String -> BuiltinResult Value
forall a b. (a -> b) -> a -> b
$ String
"insertCoin: quantity out of bounds: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
unsafeAmount
      (Just K
currency, Just K
token, Just Quantity
qty) ->
        let f
              :: Maybe (Map K Quantity)
              -> ( -- Left (old size of inner map) if the total size grows by 1,
                   -- otherwise, Right (old quantity)
                   Either Int Quantity
                 , Maybe (Map K Quantity)
                 )
            f :: Maybe (Map K Quantity)
-> (Either Int Quantity, Maybe (Map K Quantity))
f = \case
              Maybe (Map K Quantity)
Nothing -> (Int -> Either Int Quantity
forall a b. a -> Either a b
Left Int
0, Map K Quantity -> Maybe (Map K Quantity)
forall a. a -> Maybe a
Just (K -> Quantity -> Map K Quantity
forall k a. k -> a -> Map k a
Map.singleton K
token Quantity
qty))
              Just Map K Quantity
inner ->
                let (Maybe Quantity
mOldQuantity, Map K Quantity
inner') =
                      (K -> Quantity -> Quantity -> Quantity)
-> K
-> Quantity
-> Map K Quantity
-> (Maybe Quantity, Map K Quantity)
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Map.insertLookupWithKey (\K
_ Quantity
_ Quantity
_ -> Quantity
qty) K
token Quantity
qty Map K Quantity
inner
                 in (Either Int Quantity
-> (Quantity -> Either Int Quantity)
-> Maybe Quantity
-> Either Int Quantity
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Either Int Quantity
forall a b. a -> Either a b
Left (Map K Quantity -> Int
forall k a. Map k a -> Int
Map.size Map K Quantity
inner)) Quantity -> Either Int Quantity
forall a b. b -> Either a b
Right Maybe Quantity
mOldQuantity, Map K Quantity -> Maybe (Map K Quantity)
forall a. a -> Maybe a
Just Map K Quantity
inner')
            (Either Int Quantity
res, NestedMap
outer') = (Maybe (Map K Quantity)
 -> (Either Int Quantity, Maybe (Map K Quantity)))
-> K -> NestedMap -> (Either Int Quantity, NestedMap)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF Maybe (Map K Quantity)
-> (Either Int Quantity, Maybe (Map K Quantity))
f K
currency NestedMap
outer
            (IntMap Int
sizes', Int
total', Int
neg') = case Either Int Quantity
res of
              Left Int
oldSize ->
                ( Int -> Int -> IntMap Int -> IntMap Int
updateSizes Int
oldSize (Int
oldSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) IntMap Int
sizes
                , Int
total Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                , if Quantity
qty Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
< Quantity
zeroQuantity then Int
neg Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
neg
                )
              Right Quantity
oldQuantity ->
                ( IntMap Int
sizes
                , Int
total
                , if Quantity
oldQuantity Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
< Quantity
zeroQuantity Bool -> Bool -> Bool
&& Quantity
qty Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
> Quantity
zeroQuantity
                    then Int
neg Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                    else
                      if Quantity
oldQuantity Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
> Quantity
zeroQuantity Bool -> Bool -> Bool
&& Quantity
qty Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
< Quantity
zeroQuantity
                        then Int
neg Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                        else Int
neg
                )
         in Value -> BuiltinResult Value
forall a. a -> BuiltinResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> BuiltinResult Value) -> Value -> BuiltinResult Value
forall a b. (a -> b) -> a -> b
$ NestedMap -> IntMap Int -> Int -> Int -> Value
Value NestedMap
outer' IntMap Int
sizes' Int
total' Int
neg'
{-# INLINEABLE insertCoin #-}

-- | \(O(\log \max(m, k))\)
deleteCoin :: ByteString -> ByteString -> Value -> Value
deleteCoin :: ByteString -> ByteString -> Value -> Value
deleteCoin (ByteString -> K
UnsafeK -> K
currency) (ByteString -> K
UnsafeK -> K
token) (Value NestedMap
outer IntMap Int
sizes Int
total Int
neg) =
  NestedMap -> IntMap Int -> Int -> Int -> Value
Value NestedMap
outer' IntMap Int
sizes' Int
total' Int
neg'
  where
    (Maybe (Int, Quantity)
mold, NestedMap
outer') = (Maybe (Map K Quantity)
 -> (Maybe (Int, Quantity), Maybe (Map K Quantity)))
-> K -> NestedMap -> (Maybe (Int, Quantity), NestedMap)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF Maybe (Map K Quantity)
-> (Maybe (Int, Quantity), Maybe (Map K Quantity))
f K
currency NestedMap
outer
    (IntMap Int
sizes', Int
total', Int
neg') = case Maybe (Int, Quantity)
mold of
      Just (Int
oldSize, Quantity
oldQuantity) ->
        ( Int -> Int -> IntMap Int -> IntMap Int
updateSizes Int
oldSize (Int
oldSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) IntMap Int
sizes
        , Int
total Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        , if Quantity
oldQuantity Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
< Quantity
zeroQuantity then Int
neg Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 else Int
neg
        )
      Maybe (Int, Quantity)
Nothing -> (IntMap Int
sizes, Int
total, Int
neg)
    f
      :: Maybe (Map K Quantity)
      -> ( -- Just (old size of inner map, old quantity) if the total size shrinks by 1,
           -- otherwise Nothing
           Maybe (Int, Quantity)
         , Maybe (Map K Quantity)
         )
    f :: Maybe (Map K Quantity)
-> (Maybe (Int, Quantity), Maybe (Map K Quantity))
f = \case
      Maybe (Map K Quantity)
Nothing -> (Maybe (Int, Quantity)
forall a. Maybe a
Nothing, Maybe (Map K Quantity)
forall a. Maybe a
Nothing)
      Just Map K Quantity
inner ->
        let (Maybe Quantity
qty, Map K Quantity
inner') = (K -> Quantity -> Maybe Quantity)
-> K -> Map K Quantity -> (Maybe Quantity, Map K Quantity)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\K
_ Quantity
_ -> Maybe Quantity
forall a. Maybe a
Nothing) K
token Map K Quantity
inner
         in ((Map K Quantity -> Int
forall k a. Map k a -> Int
Map.size Map K Quantity
inner,) (Quantity -> (Int, Quantity))
-> Maybe Quantity -> Maybe (Int, Quantity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Quantity
qty, if Map K Quantity -> Bool
forall k a. Map k a -> Bool
Map.null Map K Quantity
inner' then Maybe (Map K Quantity)
forall a. Maybe a
Nothing else Map K Quantity -> Maybe (Map K Quantity)
forall a. a -> Maybe a
Just Map K Quantity
inner')

-- | \(O(\log \max(m, k))\)
lookupCoin :: ByteString -> ByteString -> Value -> Integer
lookupCoin :: ByteString -> ByteString -> Value -> Integer
lookupCoin (ByteString -> K
UnsafeK -> K
currency) (ByteString -> K
UnsafeK -> K
token) (Value -> NestedMap
unpack -> NestedMap
outer) =
  case K -> NestedMap -> Maybe (Map K Quantity)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup K
currency NestedMap
outer of
    Maybe (Map K Quantity)
Nothing -> Integer
0
    Just Map K Quantity
inner -> Quantity -> Integer
unQuantity (Quantity -> Integer) -> Quantity -> Integer
forall a b. (a -> b) -> a -> b
$ Quantity -> K -> Map K Quantity -> Quantity
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Quantity
zeroQuantity K
token Map K Quantity
inner

{-| \(O(n_{2}\log \max(m_{1}, k_{1}))\), where \(n_{2}\) is the total size of the second
`Value`, \(m_{1}\) is the size of the outer map in the first `Value` and \(k_{1}\) is
the size of the largest inner map in the first `Value`.

@a@ contains @b@ if for each @(currency, token, quantity)@ in @b@,
@lookup currency token a >= quantity@.

Both values must not contain negative amounts. -}
valueContains :: Value -> Value -> BuiltinResult Bool
valueContains :: Value -> Value -> BuiltinResult Bool
valueContains Value
v1 Value
v2
  | Value -> Int
negativeAmounts Value
v1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = String -> BuiltinResult Bool
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"valueContains: first value contains negative amounts"
  | Value -> Int
negativeAmounts Value
v2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = String -> BuiltinResult Bool
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"valueContains: second value contains negative amounts"
  | Value -> Int
totalSize Value
v1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Value -> Int
totalSize Value
v2 = Bool -> BuiltinResult Bool
forall a. a -> BuiltinResult a
BuiltinSuccess Bool
False
  -- \^ v2 is too big to be contained in v1: `isSubmapOfBy` has a similar check,
  -- but that only applies to the top-level structure of the map, so v1 can
  -- have a larger outer map than v2 but a smaller number of total entries, and
  -- without this check the outer call of `isSubmapOfBy` would carry on and
  -- compare the inner maps even though v2 can't fit inside v1.
  | Bool
otherwise = Bool -> BuiltinResult Bool
forall a. a -> BuiltinResult a
BuiltinSuccess (Bool -> BuiltinResult Bool) -> Bool -> BuiltinResult Bool
forall a b. (a -> b) -> a -> b
$ (Map K Quantity -> Map K Quantity -> Bool)
-> NestedMap -> NestedMap -> Bool
forall k a b.
Ord k =>
(a -> b -> Bool) -> Map k a -> Map k b -> Bool
Map.isSubmapOfBy ((Quantity -> Quantity -> Bool)
-> Map K Quantity -> Map K Quantity -> Bool
forall k a b.
Ord k =>
(a -> b -> Bool) -> Map k a -> Map k b -> Bool
Map.isSubmapOfBy Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
(<=)) (Value -> NestedMap
unpack Value
v2) (Value -> NestedMap
unpack Value
v1)
{-# INLINEABLE valueContains #-}

{-| \(O(n_{1}) + O(n_{2})\), where \(n_{1}\) and \(n_{2}\) are the total sizes
(i.e., sum of inner map sizes) of the two maps.

Shortcircuits if either value is empty.

Since 'unionValue' is commutative, we switch the arguments whenever the second
value is larger in total size than the first one. We have found through experimentation
that this results in better performance in practice. -}
unionValue :: Value -> Value -> BuiltinResult Value
unionValue :: Value -> Value -> BuiltinResult Value
unionValue Value
vA Value
vB
  | Value -> Int
totalSize Value
vA Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Value -> BuiltinResult Value
forall a. a -> BuiltinResult a
BuiltinSuccess Value
vB
  | Value -> Int
totalSize Value
vB Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Value -> BuiltinResult Value
forall a. a -> BuiltinResult a
BuiltinSuccess Value
vA
  | Bool
otherwise =
      NestedMap -> Value
pack'
        (NestedMap -> Value)
-> BuiltinResult NestedMap -> BuiltinResult Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WhenMissing BuiltinResult K (Map K Quantity) (Map K Quantity)
-> WhenMissing BuiltinResult K (Map K Quantity) (Map K Quantity)
-> WhenMatched
     BuiltinResult K (Map K Quantity) (Map K Quantity) (Map K Quantity)
-> NestedMap
-> NestedMap
-> BuiltinResult NestedMap
forall (f :: * -> *) k a c b.
(Applicative f, Ord k) =>
WhenMissing f k a c
-> WhenMissing f k b c
-> WhenMatched f k a b c
-> Map k a
-> Map k b
-> f (Map k c)
M.mergeA
          WhenMissing BuiltinResult K (Map K Quantity) (Map K Quantity)
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
M.preserveMissing
          WhenMissing BuiltinResult K (Map K Quantity) (Map K Quantity)
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
M.preserveMissing
          ( (K
 -> Map K Quantity
 -> Map K Quantity
 -> BuiltinResult (Maybe (Map K Quantity)))
-> WhenMatched
     BuiltinResult K (Map K Quantity) (Map K Quantity) (Map K Quantity)
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> f (Maybe z)) -> WhenMatched f k x y z
M.zipWithMaybeAMatched \K
_ Map K Quantity
innerA Map K Quantity
innerB ->
              (Map K Quantity -> Maybe (Map K Quantity))
-> BuiltinResult (Map K Quantity)
-> BuiltinResult (Maybe (Map K Quantity))
forall a b. (a -> b) -> BuiltinResult a -> BuiltinResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Map K Quantity
inner -> if Map K Quantity -> Bool
forall k a. Map k a -> Bool
Map.null Map K Quantity
inner then Maybe (Map K Quantity)
forall a. Maybe a
Nothing else Map K Quantity -> Maybe (Map K Quantity)
forall a. a -> Maybe a
Just Map K Quantity
inner) (BuiltinResult (Map K Quantity)
 -> BuiltinResult (Maybe (Map K Quantity)))
-> BuiltinResult (Map K Quantity)
-> BuiltinResult (Maybe (Map K Quantity))
forall a b. (a -> b) -> a -> b
$
                WhenMissing BuiltinResult K Quantity Quantity
-> WhenMissing BuiltinResult K Quantity Quantity
-> WhenMatched BuiltinResult K Quantity Quantity Quantity
-> Map K Quantity
-> Map K Quantity
-> BuiltinResult (Map K Quantity)
forall (f :: * -> *) k a c b.
(Applicative f, Ord k) =>
WhenMissing f k a c
-> WhenMissing f k b c
-> WhenMatched f k a b c
-> Map k a
-> Map k b
-> f (Map k c)
M.mergeA
                  WhenMissing BuiltinResult K Quantity Quantity
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
M.preserveMissing
                  WhenMissing BuiltinResult K Quantity Quantity
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
M.preserveMissing
                  ( (K -> Quantity -> Quantity -> BuiltinResult (Maybe Quantity))
-> WhenMatched BuiltinResult K Quantity Quantity Quantity
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> f (Maybe z)) -> WhenMatched f k x y z
M.zipWithMaybeAMatched \K
_ Quantity
x Quantity
y ->
                      case Quantity -> Quantity -> Maybe Quantity
addQuantity Quantity
x Quantity
y of
                        Just Quantity
z -> Maybe Quantity -> BuiltinResult (Maybe Quantity)
forall a. a -> BuiltinResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure if Quantity
z Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
zeroQuantity then Maybe Quantity
forall a. Maybe a
Nothing else Quantity -> Maybe Quantity
forall a. a -> Maybe a
Just Quantity
z
                        Maybe Quantity
Nothing ->
                          String -> BuiltinResult (Maybe Quantity)
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unionValue: quantity is out of the signed 128-bit integer bounds"
                  )
                  Map K Quantity
innerA
                  Map K Quantity
innerB
          )
          NestedMap
v1
          NestedMap
v2
  where
    (NestedMap
v1, NestedMap
v2) =
      if Value -> Int
totalSize Value
vB Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Value -> Int
totalSize Value
vA
        then (Value -> NestedMap
unpack Value
vB, Value -> NestedMap
unpack Value
vA)
        else (Value -> NestedMap
unpack Value
vA, Value -> NestedMap
unpack Value
vB)
{-# INLINEABLE unionValue #-}

valueDataMaxSize :: Int
valueDataMaxSize :: Int
valueDataMaxSize = Int
40000

{-| \(O(n)\). Encodes `Value` as `Data`, in the same way as non-builtin @Value@.
This is the denotation of @ValueData@ in Plutus V1, V2 and V3. -}
valueData :: Value -> BuiltinResult Data
valueData :: Value -> BuiltinResult Data
valueData Value
v =
  if Value -> Int
totalSize Value
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
valueDataMaxSize
    then Data -> BuiltinResult Data
forall a. a -> BuiltinResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Data -> BuiltinResult Data) -> Data -> BuiltinResult Data
forall a b. (a -> b) -> a -> b
$ [(Data, Data)] -> Data
Map ([(Data, Data)] -> Data)
-> (Value -> [(Data, Data)]) -> Value -> Data
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((K, Map K Quantity) -> (Data, Data))
-> [(K, Map K Quantity)] -> [(Data, Data)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((K -> Data)
-> (Map K Quantity -> Data) -> (K, Map K Quantity) -> (Data, Data)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ByteString -> Data
B (ByteString -> Data) -> (K -> ByteString) -> K -> Data
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K -> ByteString
unK) Map K Quantity -> Data
tokensData) ([(K, Map K Quantity)] -> [(Data, Data)])
-> (Value -> [(K, Map K Quantity)]) -> Value -> [(Data, Data)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NestedMap -> [(K, Map K Quantity)]
forall k a. Map k a -> [(k, a)]
Map.toList (NestedMap -> [(K, Map K Quantity)])
-> (Value -> NestedMap) -> Value -> [(K, Map K Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> NestedMap
unpack (Value -> Data) -> Value -> Data
forall a b. (a -> b) -> a -> b
$ Value
v
    else String -> BuiltinResult Data
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> BuiltinResult Data) -> String -> BuiltinResult Data
forall a b. (a -> b) -> a -> b
$ String
"valueData: maximum input size (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
valueDataMaxSize String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") exceeded"
  where
    tokensData :: Map K Quantity -> Data
    tokensData :: Map K Quantity -> Data
tokensData = [(Data, Data)] -> Data
Map ([(Data, Data)] -> Data)
-> (Map K Quantity -> [(Data, Data)]) -> Map K Quantity -> Data
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((K, Quantity) -> (Data, Data))
-> [(K, Quantity)] -> [(Data, Data)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((K -> Data) -> (Quantity -> Data) -> (K, Quantity) -> (Data, Data)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ByteString -> Data
B (ByteString -> Data) -> (K -> ByteString) -> K -> Data
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K -> ByteString
unK) (Integer -> Data
I (Integer -> Data) -> (Quantity -> Integer) -> Quantity -> Data
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Quantity -> Integer
unQuantity)) ([(K, Quantity)] -> [(Data, Data)])
-> (Map K Quantity -> [(K, Quantity)])
-> Map K Quantity
-> [(Data, Data)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map K Quantity -> [(K, Quantity)]
forall k a. Map k a -> [(k, a)]
Map.toList
{-# INLINEABLE valueData #-}

{-| \(O(n)\). Decodes `Data` into `Value`.
This is the denotation of @UnValueData@ in Plutus V1, V2 and V3. -}
unValueData :: Data -> BuiltinResult Value
unValueData :: Data -> BuiltinResult Value
unValueData =
  Data -> BuiltinResult [(Data, Data)]
unMap
    (Data -> BuiltinResult [(Data, Data)])
-> ([(Data, Data)] -> BuiltinResult Value)
-> Data
-> BuiltinResult Value
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String
-> ((Data, Data) -> BuiltinResult (K, [(Data, Data)]))
-> ((Data, Data) -> BuiltinResult (K, Quantity))
-> [(Data, Data)]
-> BuiltinResult Value
forall (m :: * -> *) a b.
MonadFail m =>
String
-> (a -> m (K, [b])) -> (b -> m (K, Quantity)) -> [a] -> m Value
buildValueWith
      String
"unValueData"
      ( \(Data
cData, Data
tsData) ->
          (,)
            (K -> [(Data, Data)] -> (K, [(Data, Data)]))
-> BuiltinResult K
-> BuiltinResult ([(Data, Data)] -> (K, [(Data, Data)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Data -> BuiltinResult K
unB Data
cData
            BuiltinResult ([(Data, Data)] -> (K, [(Data, Data)]))
-> BuiltinResult [(Data, Data)]
-> BuiltinResult (K, [(Data, Data)])
forall a b.
BuiltinResult (a -> b) -> BuiltinResult a -> BuiltinResult b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Data -> BuiltinResult [(Data, Data)]
unMap Data
tsData
      )
      (\(Data
tData, Data
qData) -> (,) (K -> Quantity -> (K, Quantity))
-> BuiltinResult K -> BuiltinResult (Quantity -> (K, Quantity))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Data -> BuiltinResult K
unB Data
tData BuiltinResult (Quantity -> (K, Quantity))
-> BuiltinResult Quantity -> BuiltinResult (K, Quantity)
forall a b.
BuiltinResult (a -> b) -> BuiltinResult a -> BuiltinResult b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Data -> BuiltinResult Quantity
unQ Data
qData)
  where
    unB :: Data -> BuiltinResult K
    unB :: Data -> BuiltinResult K
unB = \case
      B ByteString
b -> BuiltinResult K
-> (K -> BuiltinResult K) -> Maybe K -> BuiltinResult K
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> BuiltinResult K
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> BuiltinResult K) -> String -> BuiltinResult K
forall a b. (a -> b) -> a -> b
$ String
"unValueData: invalid key: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Word8] -> String
forall a. Show a => a -> String
show (ByteString -> [Word8]
B.unpack ByteString
b)) K -> BuiltinResult K
forall a. a -> BuiltinResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe K
k ByteString
b)
      Data
_ -> String -> BuiltinResult K
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unValueData: non-B constructor"
    {-# INLINEABLE unB #-}

    unQ :: Data -> BuiltinResult Quantity
    unQ :: Data -> BuiltinResult Quantity
unQ = \case
      I Integer
i
        | Just Quantity
q <- Integer -> Maybe Quantity
quantity Integer
i -> Quantity -> BuiltinResult Quantity
forall a. a -> BuiltinResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Quantity
q
        | Bool
otherwise -> String -> BuiltinResult Quantity
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unValueData: invalid quantity"
      Data
_ -> String -> BuiltinResult Quantity
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unValueData: non-I constructor"
    {-# INLINEABLE unQ #-}

    unMap :: Data -> BuiltinResult [(Data, Data)]
    unMap :: Data -> BuiltinResult [(Data, Data)]
unMap = \case
      Map [(Data, Data)]
xs -> [(Data, Data)] -> BuiltinResult [(Data, Data)]
forall a. a -> BuiltinResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Data, Data)]
xs
      Data
_ -> String -> BuiltinResult [(Data, Data)]
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unValueData: non-Map constructor"
{-# INLINEABLE unValueData #-}

-- | Decrement bucket @old@, and increment bucket @new@.
updateSizes :: Int -> Int -> IntMap Int -> IntMap Int
updateSizes :: Int -> Int -> IntMap Int -> IntMap Int
updateSizes Int
old Int
new = IntMap Int -> IntMap Int
dec (IntMap Int -> IntMap Int)
-> (IntMap Int -> IntMap Int) -> IntMap Int -> IntMap Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap Int -> IntMap Int
inc
  where
    inc :: IntMap Int -> IntMap Int
inc =
      if Int
new Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then IntMap Int -> IntMap Int
forall a. a -> a
id
        else (Maybe Int -> Maybe Int) -> Int -> IntMap Int -> IntMap Int
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IntMap.alter (Maybe Int -> (Int -> Maybe Int) -> Maybe Int -> Maybe Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Int -> Int) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))) Int
new
    dec :: IntMap Int -> IntMap Int
dec =
      if Int
old Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then IntMap Int -> IntMap Int
forall a. a -> a
id
        else (Int -> Maybe Int) -> Int -> IntMap Int -> IntMap Int
forall a. (a -> Maybe a) -> Int -> IntMap a -> IntMap a
IntMap.update (\Int
n -> if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then Maybe Int
forall a. Maybe a
Nothing else Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Int
old
{-# INLINEABLE updateSizes #-}

-- | \(O(n)\). Scale each token by the given constant factor.
scaleValue :: Integer -> Value -> BuiltinResult Value
scaleValue :: Integer -> Value -> BuiltinResult Value
scaleValue Integer
c (Value NestedMap
outer IntMap Int
sizes Int
size Int
neg)
  -- When scaling by positive factor, no need to change sizes and number of negative amounts.
  | Integer
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 = do
      NestedMap
outer' <- NestedMap -> BuiltinResult NestedMap
go NestedMap
outer
      Value -> BuiltinResult Value
forall a. a -> BuiltinResult a
BuiltinSuccess (Value -> BuiltinResult Value) -> Value -> BuiltinResult Value
forall a b. (a -> b) -> a -> b
$ NestedMap -> IntMap Int -> Int -> Int -> Value
Value NestedMap
outer' IntMap Int
sizes Int
size Int
neg
  -- When scaling by negative factor, only need to "flip" negative amounts.
  | Integer
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = do
      NestedMap
outer' <- NestedMap -> BuiltinResult NestedMap
go NestedMap
outer
      Value -> BuiltinResult Value
forall a. a -> BuiltinResult a
BuiltinSuccess (Value -> BuiltinResult Value) -> Value -> BuiltinResult Value
forall a b. (a -> b) -> a -> b
$ NestedMap -> IntMap Int -> Int -> Int -> Value
Value NestedMap
outer' IntMap Int
sizes Int
size (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
neg)
  -- Scaling by 0 is always empty value
  | Bool
otherwise = Value -> BuiltinResult Value
forall a. a -> BuiltinResult a
BuiltinSuccess Value
empty
  where
    go :: NestedMap -> BuiltinResult NestedMap
    go :: NestedMap -> BuiltinResult NestedMap
go = (Map K Quantity -> BuiltinResult (Map K Quantity))
-> NestedMap -> BuiltinResult NestedMap
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map K a -> f (Map K b)
traverse ((Quantity -> BuiltinResult Quantity)
-> Map K Quantity -> BuiltinResult (Map K Quantity)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map K a -> f (Map K b)
traverse Quantity -> BuiltinResult Quantity
goScale)
    goScale :: Quantity -> BuiltinResult Quantity
    goScale :: Quantity -> BuiltinResult Quantity
goScale Quantity
x =
      case Integer -> Quantity -> Maybe Quantity
scaleQuantity Integer
c Quantity
x of
        Maybe Quantity
Nothing ->
          String -> BuiltinResult Quantity
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> BuiltinResult Quantity)
-> String -> BuiltinResult Quantity
forall a b. (a -> b) -> a -> b
$
            String
"scaleValue: quantity out of bounds: "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
c
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" * "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show (Quantity -> Integer
unQuantity Quantity
x)
        Just Quantity
q -> Quantity -> BuiltinResult Quantity
forall a. a -> BuiltinResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Quantity
q

{-| Build a `Value` from a list of entries. It fails unless the following
conditions are met:

  * currency symbols are strictly ascending
  * token names are strictly ascending
  * every quantity is within bounds
  * no zero quantity -}
buildValueWith
  :: forall m a b
   . MonadFail m
  => String
  -> (a -> m (K, [b]))
  -- ^ Convert an outer entry into (currency, inner entries)
  -> (b -> m (K, Quantity))
  -- ^ Convert an inner entry into (token, quantity)
  -> [a]
  -> m Value
buildValueWith :: forall (m :: * -> *) a b.
MonadFail m =>
String
-> (a -> m (K, [b])) -> (b -> m (K, Quantity)) -> [a] -> m Value
buildValueWith String
ctx a -> m (K, [b])
fouter b -> m (K, Quantity)
finner [a]
cs = do
  ([(K, Map K Quantity)]
outerDescList, IntMap Int
sizes, Int
total, Int
neg) <- Maybe K
-> [(K, Map K Quantity)]
-> IntMap Int
-> Int
-> Int
-> [a]
-> m ([(K, Map K Quantity)], IntMap Int, Int, Int)
goOuter Maybe K
forall a. Maybe a
Nothing [(K, Map K Quantity)]
forall a. Monoid a => a
mempty IntMap Int
forall a. Monoid a => a
mempty Int
0 Int
0 [a]
cs
  Value -> m Value
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ NestedMap -> IntMap Int -> Int -> Int -> Value
Value ([(K, Map K Quantity)] -> NestedMap
forall k a. [(k, a)] -> Map k a
Map.fromDistinctDescList [(K, Map K Quantity)]
outerDescList) IntMap Int
sizes Int
total Int
neg
  where
    goOuter
      :: Maybe K
      -> [(K, Map K Quantity)]
      -> IntMap Int
      -> Int
      -> Int
      -> [a]
      -> m ([(K, Map K Quantity)], IntMap Int, Int, Int)
    goOuter :: Maybe K
-> [(K, Map K Quantity)]
-> IntMap Int
-> Int
-> Int
-> [a]
-> m ([(K, Map K Quantity)], IntMap Int, Int, Int)
goOuter !Maybe K
prev ![(K, Map K Quantity)]
acc !IntMap Int
sizes !Int
total !Int
neg = \case
      [] -> ([(K, Map K Quantity)], IntMap Int, Int, Int)
-> m ([(K, Map K Quantity)], IntMap Int, Int, Int)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(K, Map K Quantity)]
acc, IntMap Int
sizes, Int
total, Int
neg)
      a
x : [a]
xs -> do
        (!K
c, ![b]
innerEntries) <- a -> m (K, [b])
fouter a
x
        Maybe K -> (K -> m ()) -> m ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust
          Maybe K
prev
          ( \K
p ->
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
                (K
p K -> K -> Bool
forall a. Ord a => a -> a -> Bool
< K
c)
                (String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
ctx String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": currency symbols not strictly ascending")
          )
        ([(K, Quantity)]
innerDescList, Int
innerNeg) <- Maybe K
-> [(K, Quantity)] -> Int -> [b] -> m ([(K, Quantity)], Int)
goInner Maybe K
forall a. Maybe a
Nothing [(K, Quantity)]
forall a. Monoid a => a
mempty Int
0 [b]
innerEntries
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(K, Quantity)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(K, Quantity)]
innerDescList) (m () -> m ()) -> (String -> m ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
ctx String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": empty inner map"
        let !inner :: Map K Quantity
inner = [(K, Quantity)] -> Map K Quantity
forall k a. [(k, a)] -> Map k a
Map.fromDistinctDescList [(K, Quantity)]
innerDescList
            !innerSize :: Int
innerSize = Map K Quantity -> Int
forall k a. Map k a -> Int
Map.size Map K Quantity
inner
            !sizes' :: IntMap Int
sizes' = (Maybe Int -> Maybe Int) -> Int -> IntMap Int -> IntMap Int
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IntMap.alter (Maybe Int -> (Int -> Maybe Int) -> Maybe Int -> Maybe Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Int -> Int) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))) Int
innerSize IntMap Int
sizes
        Maybe K
-> [(K, Map K Quantity)]
-> IntMap Int
-> Int
-> Int
-> [a]
-> m ([(K, Map K Quantity)], IntMap Int, Int, Int)
goOuter (K -> Maybe K
forall a. a -> Maybe a
Just K
c) ((K
c, Map K Quantity
inner) (K, Map K Quantity)
-> [(K, Map K Quantity)] -> [(K, Map K Quantity)]
forall a. a -> [a] -> [a]
: [(K, Map K Quantity)]
acc) IntMap Int
sizes' (Int
total Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
innerSize) (Int
neg Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
innerNeg) [a]
xs

    goInner :: Maybe K -> [(K, Quantity)] -> Int -> [b] -> m ([(K, Quantity)], Int)
    goInner :: Maybe K
-> [(K, Quantity)] -> Int -> [b] -> m ([(K, Quantity)], Int)
goInner !Maybe K
prev ![(K, Quantity)]
acc !Int
neg = \case
      [] -> ([(K, Quantity)], Int) -> m ([(K, Quantity)], Int)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(K, Quantity)]
acc, Int
neg)
      b
x : [b]
xs -> do
        (!K
t, !Quantity
q) <- b -> m (K, Quantity)
finner b
x
        Maybe K -> (K -> m ()) -> m ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust
          Maybe K
prev
          ( \K
p ->
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
                (K
p K -> K -> Bool
forall a. Ord a => a -> a -> Bool
< K
t)
                (String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
ctx String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": token names not strictly ascending")
          )
        -- minBound and maxBound are checked in `quantity`. We just need to
        -- guard against zero here.
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Quantity
q Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
zeroQuantity) (m () -> m ()) -> (String -> m ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
ctx String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": zero quantity"
        let neg' :: Int
neg' = if Quantity
q Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
< Quantity
zeroQuantity then Int
neg Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
neg
        Maybe K
-> [(K, Quantity)] -> Int -> [b] -> m ([(K, Quantity)], Int)
goInner (K -> Maybe K
forall a. a -> Maybe a
Just K
t) ((K
t, Quantity
q) (K, Quantity) -> [(K, Quantity)] -> [(K, Quantity)]
forall a. a -> [a] -> [a]
: [(K, Quantity)]
acc) Int
neg' [b]
xs
{-# INLINEABLE buildValueWith #-}