{-# 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,
  negativeAmounts,
  NestedMap,
  unpack,
  pack,
  empty,
  fromList,
  toList,
  toFlatList,
  totalSize,
  maxInnerSize,
  insertCoin,
  deleteCoin,
  lookupCoin,
  valueContains,
  unionValue,
  valueData,
  unValueData,
) where

import Codec.Serialise qualified as CBOR
import Control.DeepSeq (NFData)
import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Base64 qualified as Base64
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.Monoid (All (..))
import Data.Text.Encoding qualified as Text
import GHC.Generics

import PlutusCore.Builtin.Result
import PlutusCore.Data (Data (..))
import PlutusCore.Flat 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 #-}

-- | 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 #-}

type NestedMap = Map K (Map K Integer)

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

      Invariants: no empty inner map, and no zero amount.
      -}
      !(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 = NestedMap -> Value
pack (NestedMap -> Value) -> Decoder s NestedMap -> Decoder s Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s NestedMap
forall s. Decoder s NestedMap
forall a s. Serialise a => Decoder s a
CBOR.decode
  {-# 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 = NestedMap -> Value
pack (NestedMap -> Value) -> Get NestedMap -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get NestedMap
forall a. Flat a => Get a
Flat.decode
  {-# INLINE decode #-}

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

The map is guaranteed to not contain empty inner map or zero amount.
-}
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 amount into a `Value`.

The map will be filtered so that it does not contain empty inner map or zero amount.
-}
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
size Int
neg
 where
  (IntMap Int
sizes, Int
size, Int
neg) = ((IntMap Int, Int, Int) -> Map K Integer -> (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 Integer -> (IntMap Int, Int, Int)
forall {a} {a} {k}.
(Ord a, Num a, Num a) =>
(IntMap a, Int, Int) -> Map k a -> (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 a -> (IntMap a, Int, Int)
alg (IntMap a
ss, Int
s, Int
n) Map k a
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 a -> Int
forall k a. Map k a -> Int
Map.size Map k a
inner) IntMap a
ss
    , Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Map k a -> Int
forall k a. Map k a -> Int
Map.size Map k a
inner
    , Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Map k a -> Int
forall k a. Map k a -> Int
Map.size ((a -> Bool) -> Map k a -> Map k a
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0) Map k a
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
size Int
_) = Int
size
{-# 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, Integer)])]
toList :: Value -> [(K, [(K, Integer)])]
toList = Map K [(K, Integer)] -> [(K, [(K, Integer)])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map K [(K, Integer)] -> [(K, [(K, Integer)])])
-> (Value -> Map K [(K, Integer)])
-> Value
-> [(K, [(K, Integer)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map K Integer -> [(K, Integer)])
-> NestedMap -> Map K [(K, Integer)]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Map K Integer -> [(K, Integer)]
forall k a. Map k a -> [(k, a)]
Map.toList (NestedMap -> Map K [(K, Integer)])
-> (Value -> NestedMap) -> Value -> Map K [(K, Integer)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> NestedMap
unpack
{-# INLINEABLE toList #-}

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

fromList :: [(K, [(K, Integer)])] -> Value
fromList :: [(K, [(K, Integer)])] -> Value
fromList =
  NestedMap -> Value
pack
    (NestedMap -> Value)
-> ([(K, [(K, Integer)])] -> NestedMap)
-> [(K, [(K, Integer)])]
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map K Integer -> Map K Integer -> Map K Integer)
-> [(K, Map K Integer)] -> NestedMap
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith ((Integer -> Integer -> Integer)
-> Map K Integer -> Map K Integer -> Map K Integer
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
    ([(K, Map K Integer)] -> NestedMap)
-> ([(K, [(K, Integer)])] -> [(K, Map K Integer)])
-> [(K, [(K, Integer)])]
-> NestedMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((K, [(K, Integer)]) -> (K, Map K Integer))
-> [(K, [(K, Integer)])] -> [(K, Map K Integer)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([(K, Integer)] -> Map K Integer)
-> (K, [(K, Integer)]) -> (K, Map K Integer)
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 ((Integer -> Integer -> Integer) -> [(K, Integer)] -> Map K Integer
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+)))
{-# INLINEABLE fromList #-}

normalize :: NestedMap -> NestedMap
normalize :: NestedMap -> NestedMap
normalize = (Map K Integer -> Bool) -> NestedMap -> NestedMap
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool) -> (Map K Integer -> Bool) -> Map K Integer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map K Integer -> 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 Integer -> Map K Integer) -> NestedMap -> NestedMap
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Integer -> Bool) -> Map K Integer -> Map K Integer
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0))
{-# INLINEABLE normalize #-}

instance Pretty Value where
  pretty :: forall ann. Value -> Doc ann
pretty = [(Text, [(Text, Integer)])] -> Doc ann
forall ann. [(Text, [(Text, Integer)])] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([(Text, [(Text, Integer)])] -> Doc ann)
-> (Value -> [(Text, [(Text, Integer)])]) -> Value -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((K, [(K, Integer)]) -> (Text, [(Text, Integer)]))
-> [(K, [(K, Integer)])] -> [(Text, [(Text, Integer)])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((K -> Text)
-> ([(K, Integer)] -> [(Text, Integer)])
-> (K, [(K, Integer)])
-> (Text, [(Text, Integer)])
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, Integer) -> (Text, Integer))
-> [(K, Integer)] -> [(Text, Integer)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((K -> Text) -> (K, Integer) -> (Text, Integer)
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, Integer)])] -> [(Text, [(Text, Integer)])])
-> (Value -> [(K, [(K, Integer)])])
-> Value
-> [(Text, [(Text, Integer)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(K, [(K, Integer)])]
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
currency ByteString
token Integer
amt v :: Value
v@(Value NestedMap
outer IntMap Int
sizes Int
size Int
neg)
  | Integer
amt 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
currency ByteString
token Value
v
  | Bool
otherwise = case (ByteString -> Maybe K
k ByteString
currency, ByteString -> Maybe K
k ByteString
token) of
      (Maybe K
Nothing, Maybe K
_) -> 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
currency)
      (Maybe K
_, Maybe K
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: 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
token)
      (Just K
ck, Just K
tk) ->
        let f
              :: Maybe (Map K Integer)
              -> ( -- Left (old size of inner map) if the total size grows by 1,
                   -- otherwise, Right (old amount)
                   Either Int Integer
                 , Maybe (Map K Integer)
                 )
            f :: Maybe (Map K Integer)
-> (Either Int Integer, Maybe (Map K Integer))
f = \case
              Maybe (Map K Integer)
Nothing -> (Int -> Either Int Integer
forall a b. a -> Either a b
Left Int
0, Map K Integer -> Maybe (Map K Integer)
forall a. a -> Maybe a
Just (K -> Integer -> Map K Integer
forall k a. k -> a -> Map k a
Map.singleton K
tk Integer
amt))
              Just Map K Integer
inner ->
                let (Maybe Integer
moldAmt, Map K Integer
inner') =
                      (K -> Integer -> Integer -> Integer)
-> K -> Integer -> Map K Integer -> (Maybe Integer, Map K Integer)
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Map.insertLookupWithKey (\K
_ Integer
_ Integer
_ -> Integer
amt) K
tk Integer
amt Map K Integer
inner
                 in (Either Int Integer
-> (Integer -> Either Int Integer)
-> Maybe Integer
-> Either Int Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Either Int Integer
forall a b. a -> Either a b
Left (Map K Integer -> Int
forall k a. Map k a -> Int
Map.size Map K Integer
inner)) Integer -> Either Int Integer
forall a b. b -> Either a b
Right Maybe Integer
moldAmt, Map K Integer -> Maybe (Map K Integer)
forall a. a -> Maybe a
Just Map K Integer
inner')
            (Either Int Integer
res, NestedMap
outer') = (Maybe (Map K Integer)
 -> (Either Int Integer, Maybe (Map K Integer)))
-> K -> NestedMap -> (Either Int Integer, 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 Integer)
-> (Either Int Integer, Maybe (Map K Integer))
f K
ck NestedMap
outer
            (IntMap Int
sizes', Int
size', Int
neg') = case Either Int Integer
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
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                , if Integer
amt Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Int
neg Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
neg
                )
              Right Integer
oldAmt ->
                ( IntMap Int
sizes
                , Int
size
                , if Integer
oldAmt Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
&& Integer
amt Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0
                    then Int
neg Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                    else
                      if Integer
oldAmt Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
&& Integer
amt Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
                        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
size' 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
size Int
neg) =
  NestedMap -> IntMap Int -> Int -> Int -> Value
Value NestedMap
outer' IntMap Int
sizes' Int
size' Int
neg'
 where
  (Maybe (Int, Integer)
mold, NestedMap
outer') = (Maybe (Map K Integer)
 -> (Maybe (Int, Integer), Maybe (Map K Integer)))
-> K -> NestedMap -> (Maybe (Int, Integer), 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 Integer)
-> (Maybe (Int, Integer), Maybe (Map K Integer))
f K
currency NestedMap
outer
  (IntMap Int
sizes', Int
size', Int
neg') = case Maybe (Int, Integer)
mold of
    Just (Int
oldSize, Integer
oldAmt) ->
      ( 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
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      , if Integer
oldAmt Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Int
neg Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 else Int
neg
      )
    Maybe (Int, Integer)
Nothing -> (IntMap Int
sizes, Int
size, Int
neg)
  f
    :: Maybe (Map K Integer)
    -> ( -- Just (old size of inner map, old amount) if the total size shrinks by 1,
         -- otherwise Nothing
         Maybe (Int, Integer)
       , Maybe (Map K Integer)
       )
  f :: Maybe (Map K Integer)
-> (Maybe (Int, Integer), Maybe (Map K Integer))
f = \case
    Maybe (Map K Integer)
Nothing -> (Maybe (Int, Integer)
forall a. Maybe a
Nothing, Maybe (Map K Integer)
forall a. Maybe a
Nothing)
    Just Map K Integer
inner ->
      let (Maybe Integer
amt, Map K Integer
inner') = (K -> Integer -> Maybe Integer)
-> K -> Map K Integer -> (Maybe Integer, Map K Integer)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\K
_ Integer
_ -> Maybe Integer
forall a. Maybe a
Nothing) K
token Map K Integer
inner
       in ((Map K Integer -> Int
forall k a. Map k a -> Int
Map.size Map K Integer
inner,) (Integer -> (Int, Integer))
-> Maybe Integer -> Maybe (Int, Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
amt, if Map K Integer -> Bool
forall k a. Map k a -> Bool
Map.null Map K Integer
inner' then Maybe (Map K Integer)
forall a. Maybe a
Nothing else Map K Integer -> Maybe (Map K Integer)
forall a. a -> Maybe a
Just Map K Integer
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 Integer)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup K
currency NestedMap
outer of
    Maybe (Map K Integer)
Nothing    -> Integer
0
    Just Map K Integer
inner -> Integer -> K -> Map K Integer -> Integer
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Integer
0 K
token Map K Integer
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, amount)@ in @b@, if @amount > 0@, then
@lookup currency token a >= amount@, and if @amount < 0@, then
@lookup currency token a == amount@.
-}
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"
  | Bool
otherwise = Bool -> BuiltinResult Bool
forall a. a -> BuiltinResult a
BuiltinSuccess (Bool -> BuiltinResult Bool)
-> (All -> Bool) -> All -> BuiltinResult Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. All -> Bool
getAll (All -> BuiltinResult Bool) -> All -> BuiltinResult Bool
forall a b. (a -> b) -> a -> b
$ (K -> Map K Integer -> All -> All) -> All -> NestedMap -> All
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey' K -> Map K Integer -> All -> All
go All
forall a. Monoid a => a
mempty (Value -> NestedMap
unpack Value
v2)
 where
  go :: K -> Map K Integer -> All -> All
go K
c Map K Integer
inner = All -> All -> All
forall a. Semigroup a => a -> a -> a
(<>) ((K -> Integer -> All -> All) -> All -> Map K Integer -> All
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey' K -> Integer -> All -> All
goInner All
forall a. Monoid a => a
mempty Map K Integer
inner)
   where
    goInner :: K -> Integer -> All -> All
goInner K
t Integer
a2 = All -> All -> All
forall a. Semigroup a => a -> a -> a
(<>) (Bool -> All
All (Bool -> All) -> Bool -> All
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Value -> Integer
lookupCoin (K -> ByteString
unK K
c) (K -> ByteString
unK K
t) Value
v1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
a2)
{-# 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.
-}
unionValue :: Value -> Value -> Value
unionValue :: Value -> Value -> Value
unionValue (Value -> NestedMap
unpack -> NestedMap
vA) (Value -> NestedMap
unpack -> NestedMap
vB) =
  NestedMap -> Value
pack' (NestedMap -> Value) -> NestedMap -> Value
forall a b. (a -> b) -> a -> b
$
    SimpleWhenMissing K (Map K Integer) (Map K Integer)
-> SimpleWhenMissing K (Map K Integer) (Map K Integer)
-> SimpleWhenMatched
     K (Map K Integer) (Map K Integer) (Map K Integer)
-> NestedMap
-> NestedMap
-> NestedMap
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
M.merge
      SimpleWhenMissing K (Map K Integer) (Map K Integer)
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
M.preserveMissing
      SimpleWhenMissing K (Map K Integer) (Map K Integer)
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
M.preserveMissing
      ( (K -> Map K Integer -> Map K Integer -> Maybe (Map K Integer))
-> SimpleWhenMatched
     K (Map K Integer) (Map K Integer) (Map K Integer)
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> Maybe z) -> WhenMatched f k x y z
M.zipWithMaybeMatched ((K -> Map K Integer -> Map K Integer -> Maybe (Map K Integer))
 -> SimpleWhenMatched
      K (Map K Integer) (Map K Integer) (Map K Integer))
-> (K -> Map K Integer -> Map K Integer -> Maybe (Map K Integer))
-> SimpleWhenMatched
     K (Map K Integer) (Map K Integer) (Map K Integer)
forall a b. (a -> b) -> a -> b
$ \K
_ Map K Integer
innerA Map K Integer
innerB ->
          let inner :: Map K Integer
inner =
                SimpleWhenMissing K Integer Integer
-> SimpleWhenMissing K Integer Integer
-> SimpleWhenMatched K Integer Integer Integer
-> Map K Integer
-> Map K Integer
-> Map K Integer
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
M.merge
                  SimpleWhenMissing K Integer Integer
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
M.preserveMissing
                  SimpleWhenMissing K Integer Integer
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
M.preserveMissing
                  ( (K -> Integer -> Integer -> Maybe Integer)
-> SimpleWhenMatched K Integer Integer Integer
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> Maybe z) -> WhenMatched f k x y z
M.zipWithMaybeMatched ((K -> Integer -> Integer -> Maybe Integer)
 -> SimpleWhenMatched K Integer Integer Integer)
-> (K -> Integer -> Integer -> Maybe Integer)
-> SimpleWhenMatched K Integer Integer Integer
forall a b. (a -> b) -> a -> b
$ \K
_ Integer
x Integer
y ->
                      let z :: Integer
z = Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
y in if Integer
z Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then Maybe Integer
forall a. Maybe a
Nothing else Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
z
                  )
                  Map K Integer
innerA
                  Map K Integer
innerB
           in if Map K Integer -> Bool
forall k a. Map k a -> Bool
Map.null Map K Integer
inner
                then Maybe (Map K Integer)
forall a. Maybe a
Nothing
                else
                  Map K Integer -> Maybe (Map K Integer)
forall a. a -> Maybe a
Just Map K Integer
inner
      )
      NestedMap
vA
      NestedMap
vB
{-# INLINEABLE unionValue #-}

{-| \(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 -> Data
valueData :: Value -> Data
valueData = [(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 Integer) -> (Data, Data))
-> [(K, Map K Integer)] -> [(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 Integer -> Data) -> (K, Map K Integer) -> (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 Integer -> Data
tokensData) ([(K, Map K Integer)] -> [(Data, Data)])
-> (Value -> [(K, Map K Integer)]) -> Value -> [(Data, Data)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NestedMap -> [(K, Map K Integer)]
forall k a. Map k a -> [(k, a)]
Map.toList (NestedMap -> [(K, Map K Integer)])
-> (Value -> NestedMap) -> Value -> [(K, Map K Integer)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> NestedMap
unpack
 where
  tokensData :: Map K Integer -> Data
  tokensData :: Map K Integer -> Data
tokensData = [(Data, Data)] -> Data
Map ([(Data, Data)] -> Data)
-> (Map K Integer -> [(Data, Data)]) -> Map K Integer -> Data
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((K, Integer) -> (Data, Data)) -> [(K, Integer)] -> [(Data, Data)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((K -> Data) -> (Integer -> Data) -> (K, Integer) -> (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) ([(K, Integer)] -> [(Data, Data)])
-> (Map K Integer -> [(K, Integer)])
-> Map K Integer
-> [(Data, Data)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map K Integer -> [(K, Integer)]
forall k a. Map k a -> [(k, a)]
Map.toList
{-# INLINEABLE valueData #-}

{-| \(O(n \log n)\). Decodes `Data` into `Value`, in the same way as non-builtin @Value@.
This is the denotation of @UnValueData@ in Plutus V1, V2 and V3.
-}
unValueData :: Data -> BuiltinResult Value
unValueData :: Data -> BuiltinResult Value
unValueData =
  (NestedMap -> Value)
-> BuiltinResult NestedMap -> BuiltinResult Value
forall a b. (a -> b) -> BuiltinResult a -> BuiltinResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NestedMap -> Value
pack (BuiltinResult NestedMap -> BuiltinResult Value)
-> (Data -> BuiltinResult NestedMap) -> Data -> BuiltinResult Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Map [(Data, Data)]
cs -> ([(K, Map K Integer)] -> NestedMap)
-> BuiltinResult [(K, Map K Integer)] -> BuiltinResult NestedMap
forall a b. (a -> b) -> BuiltinResult a -> BuiltinResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Map K Integer -> Map K Integer -> Map K Integer)
-> [(K, Map K Integer)] -> NestedMap
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith ((Integer -> Integer -> Integer)
-> Map K Integer -> Map K Integer -> Map K Integer
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))) (((Data, Data) -> BuiltinResult (K, Map K Integer))
-> [(Data, Data)] -> BuiltinResult [(K, Map K Integer)]
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) -> [a] -> f [b]
traverse ((Data -> BuiltinResult K)
-> (Data -> BuiltinResult (Map K Integer))
-> (Data, Data)
-> BuiltinResult (K, Map K Integer)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse Data -> BuiltinResult K
unB Data -> BuiltinResult (Map K Integer)
unTokens) [(Data, Data)]
cs)
    Data
_ -> String -> BuiltinResult NestedMap
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unValueData: non-Map constructor"
 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"

  unI :: Data -> BuiltinResult Integer
  unI :: Data -> BuiltinResult Integer
unI = \case
    I Integer
i -> Integer -> BuiltinResult Integer
forall a. a -> BuiltinResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
i
    Data
_ -> String -> BuiltinResult Integer
forall a. String -> BuiltinResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unValueData: non-I constructor"

  unTokens :: Data -> BuiltinResult (Map K Integer)
  unTokens :: Data -> BuiltinResult (Map K Integer)
unTokens = \case
    Map [(Data, Data)]
ts -> ([(K, Integer)] -> Map K Integer)
-> BuiltinResult [(K, Integer)] -> BuiltinResult (Map K Integer)
forall a b. (a -> b) -> BuiltinResult a -> BuiltinResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Integer -> Integer -> Integer) -> [(K, Integer)] -> Map K Integer
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+)) (((Data, Data) -> BuiltinResult (K, Integer))
-> [(Data, Data)] -> BuiltinResult [(K, Integer)]
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) -> [a] -> f [b]
traverse ((Data -> BuiltinResult K)
-> (Data -> BuiltinResult Integer)
-> (Data, Data)
-> BuiltinResult (K, Integer)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse Data -> BuiltinResult K
unB Data -> BuiltinResult Integer
unI) [(Data, Data)]
ts)
    Data
_ -> String -> BuiltinResult (Map K Integer)
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 #-}