{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Test.QuickCheck.ContractModel.Internal.Symbolics where

import Cardano.Api hiding (txIns)
import Control.Lens

import Test.QuickCheck.StateModel
import Test.QuickCheck.ContractModel.Internal.Common (Era)

import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Maybe
import Data.Foldable
import Data.Function
import Barbies
import Barbies.Constraints
import Text.PrettyPrint.HughesPJClass hiding ((<>))

------------------------------------------------------------------------
-- The Barbie
------------------------------------------------------------------------

data SymIndexF f = SymIndex { SymIndexF f -> f AssetId
_tokens :: f AssetId
                            , SymIndexF f -> f (TxOut CtxUTxO Era)
_utxos  :: f (TxOut CtxUTxO Era)
                            , SymIndexF f -> f TxIn
_txIns  :: f TxIn
                            } deriving stock (forall x. SymIndexF f -> Rep (SymIndexF f) x)
-> (forall x. Rep (SymIndexF f) x -> SymIndexF f)
-> Generic (SymIndexF f)
forall x. Rep (SymIndexF f) x -> SymIndexF f
forall x. SymIndexF f -> Rep (SymIndexF f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) x. Rep (SymIndexF f) x -> SymIndexF f
forall (f :: * -> *) x. SymIndexF f -> Rep (SymIndexF f) x
$cto :: forall (f :: * -> *) x. Rep (SymIndexF f) x -> SymIndexF f
$cfrom :: forall (f :: * -> *) x. SymIndexF f -> Rep (SymIndexF f) x
Generic
                              deriving anyclass (FunctorB SymIndexF
FunctorB SymIndexF
-> (forall (c :: * -> Constraint) (f :: * -> *).
    AllB c SymIndexF =>
    SymIndexF f -> SymIndexF (Product (Dict c) f))
-> ConstraintsB SymIndexF
forall k (b :: (k -> *) -> *).
FunctorB b
-> (forall (c :: k -> Constraint) (f :: k -> *).
    AllB c b =>
    b f -> b (Product (Dict c) f))
-> ConstraintsB b
forall (c :: * -> Constraint) (f :: * -> *).
AllB c SymIndexF =>
SymIndexF f -> SymIndexF (Product (Dict c) f)
baddDicts :: SymIndexF f -> SymIndexF (Product (Dict c) f)
$cbaddDicts :: forall (c :: * -> Constraint) (f :: * -> *).
AllB c SymIndexF =>
SymIndexF f -> SymIndexF (Product (Dict c) f)
$cp1ConstraintsB :: FunctorB SymIndexF
ConstraintsB, (forall (f :: * -> *) (g :: * -> *).
 (forall a. f a -> g a) -> SymIndexF f -> SymIndexF g)
-> FunctorB SymIndexF
forall k (b :: (k -> *) -> *).
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> b f -> b g)
-> FunctorB b
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> SymIndexF f -> SymIndexF g
bmap :: (forall a. f a -> g a) -> SymIndexF f -> SymIndexF g
$cbmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> SymIndexF f -> SymIndexF g
FunctorB, FunctorB SymIndexF
FunctorB SymIndexF
-> (forall (f :: * -> *). (forall a. f a) -> SymIndexF f)
-> (forall (f :: * -> *) (g :: * -> *).
    SymIndexF f -> SymIndexF g -> SymIndexF (Product f g))
-> ApplicativeB SymIndexF
forall k (b :: (k -> *) -> *).
FunctorB b
-> (forall (f :: k -> *). (forall (a :: k). f a) -> b f)
-> (forall (f :: k -> *) (g :: k -> *).
    b f -> b g -> b (Product f g))
-> ApplicativeB b
forall (f :: * -> *). (forall a. f a) -> SymIndexF f
forall (f :: * -> *) (g :: * -> *).
SymIndexF f -> SymIndexF g -> SymIndexF (Product f g)
bprod :: SymIndexF f -> SymIndexF g -> SymIndexF (Product f g)
$cbprod :: forall (f :: * -> *) (g :: * -> *).
SymIndexF f -> SymIndexF g -> SymIndexF (Product f g)
bpure :: (forall a. f a) -> SymIndexF f
$cbpure :: forall (f :: * -> *). (forall a. f a) -> SymIndexF f
$cp1ApplicativeB :: FunctorB SymIndexF
ApplicativeB, FunctorB SymIndexF
FunctorB SymIndexF
-> (forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
    Applicative e =>
    (forall a. f a -> e (g a)) -> SymIndexF f -> e (SymIndexF g))
-> TraversableB SymIndexF
forall k (b :: (k -> *) -> *).
FunctorB b
-> (forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
    Applicative e =>
    (forall (a :: k). f a -> e (g a)) -> b f -> e (b g))
-> TraversableB b
forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> SymIndexF f -> e (SymIndexF g)
btraverse :: (forall a. f a -> e (g a)) -> SymIndexF f -> e (SymIndexF g)
$cbtraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> SymIndexF f -> e (SymIndexF g)
$cp1TraversableB :: FunctorB SymIndexF
TraversableB)
makeLenses ''SymIndexF

deriving instance AllBF Show f SymIndexF => Show (SymIndexF f)
deriving instance AllBF Eq f SymIndexF => Eq (SymIndexF f)

class HasSymbolicRep t where
  symIndexL :: Lens' (SymIndexF f) (f t)
  symPrefix :: String

instance HasSymbolicRep AssetId where
  symIndexL :: (f AssetId -> f (f AssetId)) -> SymIndexF f -> f (SymIndexF f)
symIndexL = (f AssetId -> f (f AssetId)) -> SymIndexF f -> f (SymIndexF f)
forall (f :: * -> *). Lens' (SymIndexF f) (f AssetId)
tokens
  symPrefix :: String
symPrefix = String
"tok"

instance HasSymbolicRep (TxOut CtxUTxO Era) where
  symIndexL :: (f (TxOut CtxUTxO Era) -> f (f (TxOut CtxUTxO Era)))
-> SymIndexF f -> f (SymIndexF f)
symIndexL = (f (TxOut CtxUTxO Era) -> f (f (TxOut CtxUTxO Era)))
-> SymIndexF f -> f (SymIndexF f)
forall (f :: * -> *). Lens' (SymIndexF f) (f (TxOut CtxUTxO Era))
utxos
  symPrefix :: String
symPrefix = String
"txOut"

instance HasSymbolicRep TxIn where
  symIndexL :: (f TxIn -> f (f TxIn)) -> SymIndexF f -> f (SymIndexF f)
symIndexL = (f TxIn -> f (f TxIn)) -> SymIndexF f -> f (SymIndexF f)
forall (f :: * -> *). Lens' (SymIndexF f) (f TxIn)
txIns
  symPrefix :: String
symPrefix = String
"txIn"

-- Semigroup and Monoids --------------------------------------------------

bmapConst :: FunctorB b => (forall a. f a -> c) -> b f -> Container b c
bmapConst :: (forall a. f a -> c) -> b f -> Container b c
bmapConst forall a. f a -> c
f b f
b = b (Const c) -> Container b c
forall (b :: (* -> *) -> *) a. b (Const a) -> Container b a
Container (b (Const c) -> Container b c) -> b (Const c) -> Container b c
forall a b. (a -> b) -> a -> b
$ (forall a. f a -> Const c a) -> b f -> b (Const c)
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
bmap (c -> Const c a
forall k a (b :: k). a -> Const a b
Const (c -> Const c a) -> (f a -> c) -> f a -> Const c a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> c
forall a. f a -> c
f) b f
b

mappendSymIndexF :: forall f. (AllBF Semigroup f SymIndexF, Show (SymIndexF f))
                 => (forall a. f a -> Set String)
                 -> SymIndexF f
                 -> SymIndexF f
                 -> SymIndexF f
mappendSymIndexF :: (forall a. f a -> Set String)
-> SymIndexF f -> SymIndexF f -> SymIndexF f
mappendSymIndexF forall a. f a -> Set String
toSet SymIndexF f
s SymIndexF f
s'
  | Container SymIndexF Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (Set String -> Set String -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint (Set String -> Set String -> Bool)
-> Container SymIndexF (Set String)
-> Container SymIndexF (Set String -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. f a -> Set String)
-> SymIndexF f -> Container SymIndexF (Set String)
forall (b :: (* -> *) -> *) (f :: * -> *) c.
FunctorB b =>
(forall a. f a -> c) -> b f -> Container b c
bmapConst forall a. f a -> Set String
toSet SymIndexF f
s
                      Container SymIndexF (Set String -> Bool)
-> Container SymIndexF (Set String) -> Container SymIndexF Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. f a -> Set String)
-> SymIndexF f -> Container SymIndexF (Set String)
forall (b :: (* -> *) -> *) (f :: * -> *) c.
FunctorB b =>
(forall a. f a -> c) -> b f -> Container b c
bmapConst forall a. f a -> Set String
toSet SymIndexF f
s') = (forall a. ClassF Semigroup f a => f a -> f a -> f a)
-> SymIndexF f -> SymIndexF f -> SymIndexF f
forall k (c :: k -> Constraint) (b :: (k -> *) -> *) (f :: k -> *)
       (g :: k -> *) (h :: k -> *).
(AllB c b, ConstraintsB b, ApplicativeB b) =>
(forall (a :: k). c a => f a -> g a -> h a) -> b f -> b g -> b h
bzipWithC @(ClassF Semigroup f) forall a. Semigroup a => a -> a -> a
forall a. ClassF Semigroup f a => f a -> f a -> f a
(<>) SymIndexF f
s SymIndexF f
s'
  | Bool
otherwise = String -> SymIndexF f
forall a. HasCallStack => String -> a
error (String -> SymIndexF f) -> String -> SymIndexF f
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ String
"Non-unique SymIndexF", SymIndexF f -> String
forall a. Show a => a -> String
show SymIndexF f
s, SymIndexF f -> String
forall a. Show a => a -> String
show SymIndexF f
s' ]

instance Semigroup SymIndex where
  <> :: SymIndex -> SymIndex -> SymIndex
(<>) = (forall a. Map String a -> Set String)
-> SymIndex -> SymIndex -> SymIndex
forall (f :: * -> *).
(AllBF Semigroup f SymIndexF, Show (SymIndexF f)) =>
(forall a. f a -> Set String)
-> SymIndexF f -> SymIndexF f -> SymIndexF f
mappendSymIndexF forall a. Map String a -> Set String
forall k a. Map k a -> Set k
Map.keysSet

instance Semigroup SymCreationIndex where
  <> :: SymCreationIndex -> SymCreationIndex -> SymCreationIndex
(<>) = (forall a. Const (Set String) a -> Set String)
-> SymCreationIndex -> SymCreationIndex -> SymCreationIndex
forall (f :: * -> *).
(AllBF Semigroup f SymIndexF, Show (SymIndexF f)) =>
(forall a. f a -> Set String)
-> SymIndexF f -> SymIndexF f -> SymIndexF f
mappendSymIndexF forall a. Const (Set String) a -> Set String
forall a k (b :: k). Const a b -> a
getConst

instance Semigroup SymCollectionIndex where
  <> :: SymCollectionIndex -> SymCollectionIndex -> SymCollectionIndex
(<>) = (forall a. SymSet a -> SymSet a -> SymSet a)
-> SymCollectionIndex -> SymCollectionIndex -> SymCollectionIndex
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *)
       (h :: k -> *).
ApplicativeB b =>
(forall (a :: k). f a -> g a -> h a) -> b f -> b g -> b h
bzipWith forall a. Semigroup a => a -> a -> a
forall a. SymSet a -> SymSet a -> SymSet a
(<>)

instance (AllBF Monoid f SymIndexF, Semigroup (SymIndexF f)) => Monoid (SymIndexF f) where
  mempty :: SymIndexF f
mempty = SymIndexF f
forall k (f :: k -> *) (b :: (k -> *) -> *).
(AllBF Monoid f b, ConstraintsB b, ApplicativeB b) =>
b f
bmempty

------------------------------------------------------------------------
-- Applications
------------------------------------------------------------------------

-- | For an assumed variable, what's the mapping of String indices to
-- underlying actual values. This is what is returned by a contract model
-- action when it runs.
type SymIndex = SymIndexF (Map String)

symIndex :: HasSymbolicRep t => String -> t -> SymIndex
symIndex :: String -> t -> SymIndex
symIndex String
s t
t = SymIndex
forall a. Monoid a => a
mempty SymIndex -> (SymIndex -> SymIndex) -> SymIndex
forall a b. a -> (a -> b) -> b
& (Map String t -> Identity (Map String t))
-> SymIndex -> Identity SymIndex
forall t (f :: * -> *).
HasSymbolicRep t =>
Lens' (SymIndexF f) (f t)
symIndexL ((Map String t -> Identity (Map String t))
 -> SymIndex -> Identity SymIndex)
-> ((Maybe t -> Identity (Maybe t))
    -> Map String t -> Identity (Map String t))
-> (Maybe t -> Identity (Maybe t))
-> SymIndex
-> Identity SymIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map String t)
-> Lens' (Map String t) (Maybe (IxValue (Map String t)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at String
Index (Map String t)
s ((Maybe t -> Identity (Maybe t)) -> SymIndex -> Identity SymIndex)
-> Maybe t -> SymIndex -> SymIndex
forall s t a b. ASetter s t a b -> b -> s -> t
.~ t -> Maybe t
forall a. a -> Maybe a
Just t
t

-- | For a given action, what are the String indices used to construct
-- symbolic variables when this action ran. NOTE: this purposefully does
-- not include the variable because we might want to fake the variable
-- with `Var 0` in some cases. See comment somewhere for why this is
-- safe...
type SymCreationIndex = SymIndexF (Const (Set String))

toCreationIndex :: SymIndex -> SymCreationIndex
toCreationIndex :: SymIndex -> SymCreationIndex
toCreationIndex = (forall a. Map String a -> Const (Set String) a)
-> SymIndex -> SymCreationIndex
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
bmap (Set String -> Const (Set String) a
forall k a (b :: k). a -> Const a b
Const (Set String -> Const (Set String) a)
-> (Map String a -> Set String)
-> Map String a
-> Const (Set String) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String a -> Set String
forall k a. Map k a -> Set k
Map.keysSet)

createIndex :: forall t. HasSymbolicRep t
            => String -> SymCreationIndex
createIndex :: String -> SymCreationIndex
createIndex String
s = SymCreationIndex
forall a. Monoid a => a
mempty SymCreationIndex
-> (SymCreationIndex -> SymCreationIndex) -> SymCreationIndex
forall a b. a -> (a -> b) -> b
& forall (f :: * -> *). HasSymbolicRep t => Lens' (SymIndexF f) (f t)
forall t (f :: * -> *).
HasSymbolicRep t =>
Lens' (SymIndexF f) (f t)
symIndexL @t ((Const (Set String) t -> Identity (Const (Set String) t))
 -> SymCreationIndex -> Identity SymCreationIndex)
-> Const (Set String) t -> SymCreationIndex -> SymCreationIndex
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set String -> Const (Set String) t
forall k a (b :: k). a -> Const a b
Const (String -> Set String
forall a. a -> Set a
Set.singleton String
s)

showCreateIndex :: SymCreationIndex -> String
showCreateIndex :: SymCreationIndex -> String
showCreateIndex = [String] -> String
forall a. Show a => a -> String
show ([String] -> String)
-> (SymCreationIndex -> [String]) -> SymCreationIndex -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String -> [String])
-> (SymCreationIndex -> Set String) -> SymCreationIndex -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Container SymIndexF (Set String) -> Set String
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Container SymIndexF (Set String) -> Set String)
-> (SymCreationIndex -> Container SymIndexF (Set String))
-> SymCreationIndex
-> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymCreationIndex -> Container SymIndexF (Set String)
forall (b :: (* -> *) -> *) a. b (Const a) -> Container b a
Container (SymCreationIndex -> Container SymIndexF (Set String))
-> (SymCreationIndex -> SymCreationIndex)
-> SymCreationIndex
-> Container SymIndexF (Set String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a.
 HasSymbolicRep a =>
 Const (Set String) a -> Const (Set String) a)
-> SymCreationIndex -> SymCreationIndex
forall k (c :: k -> Constraint) (b :: (k -> *) -> *) (f :: k -> *)
       (g :: k -> *).
(AllB c b, ConstraintsB b) =>
(forall (a :: k). c a => f a -> g a) -> b f -> b g
bmapC @HasSymbolicRep forall a.
HasSymbolicRep a =>
Const (Set String) a -> Const (Set String) a
addPrefix
  where
    addPrefix :: forall t. HasSymbolicRep t => Const (Set String) t -> Const (Set String) t
    addPrefix :: Const (Set String) t -> Const (Set String) t
addPrefix (Const Set String
set) = Set String -> Const (Set String) t
forall k a (b :: k). a -> Const a b
Const (Set String -> Const (Set String) t)
-> Set String -> Const (Set String) t
forall a b. (a -> b) -> a -> b
$ ShowS -> Set String -> Set String
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic ((HasSymbolicRep t => String
forall t. HasSymbolicRep t => String
symPrefix @t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".") String -> ShowS
forall a. [a] -> [a] -> [a]
++) Set String
set

-- | What symbolic variables have been created in a given run of the
-- `Spec` monad?
type SymCollectionIndex = SymIndexF SymSet

newtype SymSet t = SymSet { SymSet t -> Set (Symbolic t)
unSymSet :: Set (Symbolic t) }
  deriving stock (forall x. SymSet t -> Rep (SymSet t) x)
-> (forall x. Rep (SymSet t) x -> SymSet t) -> Generic (SymSet t)
forall x. Rep (SymSet t) x -> SymSet t
forall x. SymSet t -> Rep (SymSet t) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (t :: k) x. Rep (SymSet t) x -> SymSet t
forall k (t :: k) x. SymSet t -> Rep (SymSet t) x
$cto :: forall k (t :: k) x. Rep (SymSet t) x -> SymSet t
$cfrom :: forall k (t :: k) x. SymSet t -> Rep (SymSet t) x
Generic
  deriving newtype (b -> SymSet t -> SymSet t
NonEmpty (SymSet t) -> SymSet t
SymSet t -> SymSet t -> SymSet t
(SymSet t -> SymSet t -> SymSet t)
-> (NonEmpty (SymSet t) -> SymSet t)
-> (forall b. Integral b => b -> SymSet t -> SymSet t)
-> Semigroup (SymSet t)
forall b. Integral b => b -> SymSet t -> SymSet t
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall k (t :: k). NonEmpty (SymSet t) -> SymSet t
forall k (t :: k). SymSet t -> SymSet t -> SymSet t
forall k (t :: k) b. Integral b => b -> SymSet t -> SymSet t
stimes :: b -> SymSet t -> SymSet t
$cstimes :: forall k (t :: k) b. Integral b => b -> SymSet t -> SymSet t
sconcat :: NonEmpty (SymSet t) -> SymSet t
$csconcat :: forall k (t :: k). NonEmpty (SymSet t) -> SymSet t
<> :: SymSet t -> SymSet t -> SymSet t
$c<> :: forall k (t :: k). SymSet t -> SymSet t -> SymSet t
Semigroup, Semigroup (SymSet t)
SymSet t
Semigroup (SymSet t)
-> SymSet t
-> (SymSet t -> SymSet t -> SymSet t)
-> ([SymSet t] -> SymSet t)
-> Monoid (SymSet t)
[SymSet t] -> SymSet t
SymSet t -> SymSet t -> SymSet t
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall k (t :: k). Semigroup (SymSet t)
forall k (t :: k). SymSet t
forall k (t :: k). [SymSet t] -> SymSet t
forall k (t :: k). SymSet t -> SymSet t -> SymSet t
mconcat :: [SymSet t] -> SymSet t
$cmconcat :: forall k (t :: k). [SymSet t] -> SymSet t
mappend :: SymSet t -> SymSet t -> SymSet t
$cmappend :: forall k (t :: k). SymSet t -> SymSet t -> SymSet t
mempty :: SymSet t
$cmempty :: forall k (t :: k). SymSet t
$cp1Monoid :: forall k (t :: k). Semigroup (SymSet t)
Monoid)

deriving instance Show (Symbolic t) => Show (SymSet t)

symCollect :: HasSymbolicRep t
           => Symbolic t -> SymCollectionIndex
symCollect :: Symbolic t -> SymCollectionIndex
symCollect Symbolic t
s = SymCollectionIndex
forall a. Monoid a => a
mempty SymCollectionIndex
-> (SymCollectionIndex -> SymCollectionIndex) -> SymCollectionIndex
forall a b. a -> (a -> b) -> b
& (SymSet t -> Identity (SymSet t))
-> SymCollectionIndex -> Identity SymCollectionIndex
forall t (f :: * -> *).
HasSymbolicRep t =>
Lens' (SymIndexF f) (f t)
symIndexL ((SymSet t -> Identity (SymSet t))
 -> SymCollectionIndex -> Identity SymCollectionIndex)
-> SymSet t -> SymCollectionIndex -> SymCollectionIndex
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Set (Symbolic t) -> SymSet t
forall k (t :: k). Set (Symbolic t) -> SymSet t
SymSet (Set (Symbolic t) -> SymSet t) -> Set (Symbolic t) -> SymSet t
forall a b. (a -> b) -> a -> b
$ Symbolic t -> Set (Symbolic t)
forall a. a -> Set a
Set.singleton Symbolic t
s)

makeSymCollection :: SymCreationIndex -> Var SymIndex -> SymCollectionIndex
makeSymCollection :: SymCreationIndex -> Var SymIndex -> SymCollectionIndex
makeSymCollection SymCreationIndex
ci Var SymIndex
v = (forall a. Const (Set String) a -> SymSet a)
-> SymCreationIndex -> SymCollectionIndex
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
bmap (Set (Symbolic a) -> SymSet a
forall k (t :: k). Set (Symbolic t) -> SymSet t
SymSet (Set (Symbolic a) -> SymSet a)
-> (Const (Set String) a -> Set (Symbolic a))
-> Const (Set String) a
-> SymSet a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Symbolic a) -> Set String -> Set (Symbolic a)
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic (Var SymIndex -> String -> Symbolic a
forall k (t :: k). Var SymIndex -> String -> Symbolic t
Symbolic Var SymIndex
v) (Set String -> Set (Symbolic a))
-> (Const (Set String) a -> Set String)
-> Const (Set String) a
-> Set (Symbolic a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const (Set String) a -> Set String
forall a k (b :: k). Const a b -> a
getConst) SymCreationIndex
ci

symCollectionSubset :: SymCollectionIndex -> SymCollectionIndex -> Bool
symCollectionSubset :: SymCollectionIndex -> SymCollectionIndex -> Bool
symCollectionSubset SymCollectionIndex
s0 SymCollectionIndex
s1 = Container SymIndexF Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (Container SymIndexF Bool -> Bool)
-> (SymIndexF (Const Bool) -> Container SymIndexF Bool)
-> SymIndexF (Const Bool)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymIndexF (Const Bool) -> Container SymIndexF Bool
forall (b :: (* -> *) -> *) a. b (Const a) -> Container b a
Container (SymIndexF (Const Bool) -> Bool) -> SymIndexF (Const Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ (forall a. SymSet a -> SymSet a -> Const Bool a)
-> SymCollectionIndex
-> SymCollectionIndex
-> SymIndexF (Const Bool)
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *)
       (h :: k -> *).
ApplicativeB b =>
(forall (a :: k). f a -> g a -> h a) -> b f -> b g -> b h
bzipWith ((Bool -> Const Bool a
forall k a (b :: k). a -> Const a b
Const (Bool -> Const Bool a)
-> (Set (Symbolic a) -> Bool) -> Set (Symbolic a) -> Const Bool a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Set (Symbolic a) -> Bool) -> Set (Symbolic a) -> Const Bool a)
-> (Set (Symbolic a) -> Set (Symbolic a) -> Bool)
-> Set (Symbolic a)
-> Set (Symbolic a)
-> Const Bool a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Symbolic a) -> Set (Symbolic a) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf (Set (Symbolic a) -> Set (Symbolic a) -> Const Bool a)
-> (SymSet a -> Set (Symbolic a))
-> SymSet a
-> SymSet a
-> Const Bool a
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` SymSet a -> Set (Symbolic a)
forall k (t :: k). SymSet t -> Set (Symbolic t)
unSymSet) SymCollectionIndex
s0 SymCollectionIndex
s1

------------------------------------------------------------------------
-- Symbolic representations
------------------------------------------------------------------------

data Symbolic t = Symbolic { Symbolic t -> Var SymIndex
symVar :: Var SymIndex
                           , Symbolic t -> String
symVarIdx :: String
                           } deriving stock (Symbolic t -> Symbolic t -> Bool
(Symbolic t -> Symbolic t -> Bool)
-> (Symbolic t -> Symbolic t -> Bool) -> Eq (Symbolic t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (t :: k). Symbolic t -> Symbolic t -> Bool
/= :: Symbolic t -> Symbolic t -> Bool
$c/= :: forall k (t :: k). Symbolic t -> Symbolic t -> Bool
== :: Symbolic t -> Symbolic t -> Bool
$c== :: forall k (t :: k). Symbolic t -> Symbolic t -> Bool
Eq, Eq (Symbolic t)
Eq (Symbolic t)
-> (Symbolic t -> Symbolic t -> Ordering)
-> (Symbolic t -> Symbolic t -> Bool)
-> (Symbolic t -> Symbolic t -> Bool)
-> (Symbolic t -> Symbolic t -> Bool)
-> (Symbolic t -> Symbolic t -> Bool)
-> (Symbolic t -> Symbolic t -> Symbolic t)
-> (Symbolic t -> Symbolic t -> Symbolic t)
-> Ord (Symbolic t)
Symbolic t -> Symbolic t -> Bool
Symbolic t -> Symbolic t -> Ordering
Symbolic t -> Symbolic t -> Symbolic t
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
forall k (t :: k). Eq (Symbolic t)
forall k (t :: k). Symbolic t -> Symbolic t -> Bool
forall k (t :: k). Symbolic t -> Symbolic t -> Ordering
forall k (t :: k). Symbolic t -> Symbolic t -> Symbolic t
min :: Symbolic t -> Symbolic t -> Symbolic t
$cmin :: forall k (t :: k). Symbolic t -> Symbolic t -> Symbolic t
max :: Symbolic t -> Symbolic t -> Symbolic t
$cmax :: forall k (t :: k). Symbolic t -> Symbolic t -> Symbolic t
>= :: Symbolic t -> Symbolic t -> Bool
$c>= :: forall k (t :: k). Symbolic t -> Symbolic t -> Bool
> :: Symbolic t -> Symbolic t -> Bool
$c> :: forall k (t :: k). Symbolic t -> Symbolic t -> Bool
<= :: Symbolic t -> Symbolic t -> Bool
$c<= :: forall k (t :: k). Symbolic t -> Symbolic t -> Bool
< :: Symbolic t -> Symbolic t -> Bool
$c< :: forall k (t :: k). Symbolic t -> Symbolic t -> Bool
compare :: Symbolic t -> Symbolic t -> Ordering
$ccompare :: forall k (t :: k). Symbolic t -> Symbolic t -> Ordering
$cp1Ord :: forall k (t :: k). Eq (Symbolic t)
Ord)

type SymbolicSemantics = forall t. HasSymbolicRep t => Symbolic t -> t

instance HasSymbolicRep t => Show (Symbolic t) where
  show :: Symbolic t -> String
show (Symbolic Var SymIndex
v String
n) = HasSymbolicRep t => String
forall t. HasSymbolicRep t => String
symPrefix @t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Var SymIndex -> String
forall a. Show a => a -> String
show Var SymIndex
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n

getSymbolics :: forall t. HasSymbolicRep t
             => SymCreationIndex -> Var SymIndex -> Set (Symbolic t)
getSymbolics :: SymCreationIndex -> Var SymIndex -> Set (Symbolic t)
getSymbolics SymCreationIndex
idx Var SymIndex
v = SymCreationIndex -> Var SymIndex -> SymCollectionIndex
makeSymCollection SymCreationIndex
idx Var SymIndex
v SymCollectionIndex
-> Getting (Set (Symbolic t)) SymCollectionIndex (Set (Symbolic t))
-> Set (Symbolic t)
forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *). HasSymbolicRep t => Lens' (SymIndexF f) (f t)
forall t (f :: * -> *).
HasSymbolicRep t =>
Lens' (SymIndexF f) (f t)
symIndexL @t ((SymSet t -> Const (Set (Symbolic t)) (SymSet t))
 -> SymCollectionIndex
 -> Const (Set (Symbolic t)) SymCollectionIndex)
-> ((Set (Symbolic t)
     -> Const (Set (Symbolic t)) (Set (Symbolic t)))
    -> SymSet t -> Const (Set (Symbolic t)) (SymSet t))
-> Getting (Set (Symbolic t)) SymCollectionIndex (Set (Symbolic t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymSet t -> Set (Symbolic t))
-> (Set (Symbolic t)
    -> Const (Set (Symbolic t)) (Set (Symbolic t)))
-> SymSet t
-> Const (Set (Symbolic t)) (SymSet t)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to SymSet t -> Set (Symbolic t)
forall k (t :: k). SymSet t -> Set (Symbolic t)
unSymSet

instance HasVariables (Symbolic t) where
  getAllVariables :: Symbolic t -> Set (Any Var)
getAllVariables = Var SymIndex -> Set (Any Var)
forall a. HasVariables a => a -> Set (Any Var)
getAllVariables (Var SymIndex -> Set (Any Var))
-> (Symbolic t -> Var SymIndex) -> Symbolic t -> Set (Any Var)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbolic t -> Var SymIndex
forall k (t :: k). Symbolic t -> Var SymIndex
symVar

lookupSymbolic :: HasSymbolicRep t => SymIndex -> Symbolic t -> Maybe t
lookupSymbolic :: SymIndex -> Symbolic t -> Maybe t
lookupSymbolic SymIndex
idx Symbolic t
s = SymIndex
idx SymIndex -> Getting (Maybe t) SymIndex (Maybe t) -> Maybe t
forall s a. s -> Getting a s a -> a
^. (Map String t -> Const (Maybe t) (Map String t))
-> SymIndex -> Const (Maybe t) SymIndex
forall t (f :: * -> *).
HasSymbolicRep t =>
Lens' (SymIndexF f) (f t)
symIndexL ((Map String t -> Const (Maybe t) (Map String t))
 -> SymIndex -> Const (Maybe t) SymIndex)
-> ((Maybe t -> Const (Maybe t) (Maybe t))
    -> Map String t -> Const (Maybe t) (Map String t))
-> Getting (Maybe t) SymIndex (Maybe t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map String t)
-> Lens' (Map String t) (Maybe (IxValue (Map String t)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (Symbolic t -> String
forall k (t :: k). Symbolic t -> String
symVarIdx Symbolic t
s)

-- | A symbolic token is a token that is only available at runtime
type SymToken = Symbolic AssetId

-- | A SymTxOut is a `TxOut CtxUTxO Era` that is only available at runtime
type SymTxOut = Symbolic (TxOut CtxUTxO Era)

-- | A SymTxIn is a `TxIn` that is only available at runtime
type SymTxIn = Symbolic TxIn

-- Symbolic values --------------------------------------------------------

-- | A symbolic value is a combination of a real value and a value associating symbolic
-- tokens with an amount
data SymValue = SymValue { SymValue -> Map SymToken Quantity
symValMap     :: Map SymToken Quantity
                         , SymValue -> Value
actualValPart :: Value
                         }
  deriving stock (Int -> SymValue -> ShowS
[SymValue] -> ShowS
SymValue -> String
(Int -> SymValue -> ShowS)
-> (SymValue -> String) -> ([SymValue] -> ShowS) -> Show SymValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SymValue] -> ShowS
$cshowList :: [SymValue] -> ShowS
show :: SymValue -> String
$cshow :: SymValue -> String
showsPrec :: Int -> SymValue -> ShowS
$cshowsPrec :: Int -> SymValue -> ShowS
Show, (forall x. SymValue -> Rep SymValue x)
-> (forall x. Rep SymValue x -> SymValue) -> Generic SymValue
forall x. Rep SymValue x -> SymValue
forall x. SymValue -> Rep SymValue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SymValue x -> SymValue
$cfrom :: forall x. SymValue -> Rep SymValue x
Generic)


instance Semigroup SymValue where
  (SymValue Map SymToken Quantity
m Value
v) <> :: SymValue -> SymValue -> SymValue
<> (SymValue Map SymToken Quantity
m' Value
v') = Map SymToken Quantity -> Value -> SymValue
SymValue ((Quantity -> Quantity -> Quantity)
-> Map SymToken Quantity
-> Map SymToken Quantity
-> Map SymToken Quantity
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Quantity -> Quantity -> Quantity
forall a. Num a => a -> a -> a
(+) Map SymToken Quantity
m Map SymToken Quantity
m') (Value
v Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
v')

instance Monoid SymValue where
  mempty :: SymValue
mempty = Map SymToken Quantity -> Value -> SymValue
SymValue Map SymToken Quantity
forall a. Monoid a => a
mempty Value
forall a. Monoid a => a
mempty

instance Eq SymValue where
  (SymValue Map SymToken Quantity
m Value
v) == :: SymValue -> SymValue -> Bool
== (SymValue Map SymToken Quantity
m' Value
v') = (Quantity -> Bool)
-> Map SymToken Quantity -> Map SymToken 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
0) Map SymToken Quantity
m Map SymToken Quantity -> Map SymToken Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== (Quantity -> Bool)
-> Map SymToken Quantity -> Map SymToken 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
0) Map SymToken Quantity
m'
                                     Bool -> Bool -> Bool
&& Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
v'

pPrintValue :: Value -> Doc
pPrintValue :: Value -> Doc
pPrintValue Value
val = Doc -> Doc
braces (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma
  [ String -> Doc
text (Quantity -> String
forall a. Show a => a -> String
show Quantity
v) Doc -> Doc -> Doc
<+> AssetId -> Doc
pPrintAssetId AssetId
asset | (AssetId
asset, Quantity
v) <- Value -> [(AssetId, Quantity)]
valueToList Value
val ]

pPrintAssetId :: AssetId -> Doc
pPrintAssetId :: AssetId -> Doc
pPrintAssetId AssetId
AdaAssetId            = String -> Doc
text String
"Lovelace"
pPrintAssetId (AssetId PolicyId
policy AssetName
name) = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
8 (ShowS
forall a. [a] -> [a]
tail ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ PolicyId -> String
forall a. Show a => a -> String
show PolicyId
policy) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"') (AssetName -> String
forall a. Show a => a -> String
show AssetName
name)

instance Pretty SymValue where
  pPrint :: SymValue -> Doc
pPrint (SymValue Map SymToken Quantity
sym Value
val) = Doc -> Doc
braces (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$
    [ String -> Doc
text (Quantity -> String
forall a. Show a => a -> String
show Quantity
v) Doc -> Doc -> Doc
<+> String -> Doc
text (SymToken -> String
forall a. Show a => a -> String
show SymToken
tok)     | (SymToken
tok, Quantity
v)   <- Map SymToken Quantity -> [(SymToken, Quantity)]
forall k a. Map k a -> [(k, a)]
Map.toList Map SymToken Quantity
sym  ] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++
    [ String -> Doc
text (Quantity -> String
forall a. Show a => a -> String
show Quantity
v) Doc -> Doc -> Doc
<+> AssetId -> Doc
pPrintAssetId AssetId
asset | (AssetId
asset, Quantity
v) <- Value -> [(AssetId, Quantity)]
valueToList Value
val ]

-- | Check if a symbolic value is zero
symIsZero :: SymValue -> Bool
symIsZero :: SymValue -> Bool
symIsZero (SymValue Map SymToken Quantity
m Value
v) =
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ (Quantity -> Bool) -> Map SymToken Quantity -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
==Quantity
0) Map SymToken Quantity
m
      , ((AssetId, Quantity) -> Bool) -> [(AssetId, Quantity)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
==Quantity
0) (Quantity -> Bool)
-> ((AssetId, Quantity) -> Quantity) -> (AssetId, Quantity) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AssetId, Quantity) -> Quantity
forall a b. (a, b) -> b
snd) (Value -> [(AssetId, Quantity)]
valueToList Value
v)
      ]

-- | Check if one symbolic value is less than or equal to another
symLeq :: SymValue -> SymValue -> Bool
symLeq :: SymValue -> SymValue -> Bool
symLeq (SymValue Map SymToken Quantity
m Value
v) (SymValue Map SymToken Quantity
m' Value
v') =
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ ((AssetId, Quantity) -> Bool) -> [(AssetId, Quantity)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
<= Quantity
0) (Quantity -> Bool)
-> ((AssetId, Quantity) -> Quantity) -> (AssetId, Quantity) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AssetId, Quantity) -> Quantity
forall a b. (a, b) -> b
snd) (Value -> [(AssetId, Quantity)]
valueToList (Value -> [(AssetId, Quantity)]) -> Value -> [(AssetId, Quantity)]
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
negateValue Value
v')
      , (Quantity -> Bool) -> Map SymToken Quantity -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
<=Quantity
0) ((Quantity -> Quantity -> Quantity)
-> Map SymToken Quantity
-> Map SymToken Quantity
-> Map SymToken Quantity
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Quantity -> Quantity -> Quantity
forall a. Num a => a -> a -> a
(+) Map SymToken Quantity
m (Quantity -> Quantity
forall a. Num a => a -> a
negate (Quantity -> Quantity)
-> Map SymToken Quantity -> Map SymToken Quantity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map SymToken Quantity
m'))
      ]

-- | Using a semantics function for symbolic tokens, convert a SymValue to a Value
toValue :: (SymToken -> AssetId) -> SymValue -> Value
toValue :: (SymToken -> AssetId) -> SymValue -> Value
toValue SymToken -> AssetId
symTokenMap (SymValue Map SymToken Quantity
m Value
v) = Value
v Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> [(AssetId, Quantity)] -> Value
valueFromList [ (SymToken -> AssetId
symTokenMap SymToken
t, Quantity
v) | (SymToken
t, Quantity
v) <- Map SymToken Quantity -> [(SymToken, Quantity)]
forall k a. Map k a -> [(k, a)]
Map.toList Map SymToken Quantity
m ]

-- | Invert a sym token mapping to turn a Value into a SymValue,
-- useful for error reporting
toSymVal :: (AssetId -> Maybe SymToken) -> Value -> SymValue
toSymVal :: (AssetId -> Maybe SymToken) -> Value -> SymValue
toSymVal AssetId -> Maybe SymToken
invSymTokenMap Value
v =
  let aidMap :: [(AssetId, Quantity)]
aidMap = [ (AssetId
ai, Quantity
i) | (AssetId
ai, Quantity
i) <- Value -> [(AssetId, Quantity)]
valueToList Value
v ]
  -- TODO: prettier to do with a fold
  in Map SymToken Quantity -> Value -> SymValue
SymValue ([(SymToken, Quantity)] -> Map SymToken Quantity
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (SymToken
tn, Quantity
i) | (AssetId
ai, Quantity
i) <- [(AssetId, Quantity)]
aidMap, SymToken
tn <- Maybe SymToken -> [SymToken]
forall a. Maybe a -> [a]
maybeToList (Maybe SymToken -> [SymToken]) -> Maybe SymToken -> [SymToken]
forall a b. (a -> b) -> a -> b
$ AssetId -> Maybe SymToken
invSymTokenMap AssetId
ai ])
              ([(AssetId, Quantity)] -> Value
valueFromList [ (AssetId
ai, Quantity
i) | (AssetId
ai, Quantity
i) <- [(AssetId, Quantity)]
aidMap, AssetId -> Maybe SymToken
invSymTokenMap AssetId
ai Maybe SymToken -> Maybe SymToken -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe SymToken
forall a. Maybe a
Nothing ])

-- Negate a symbolic value
inv :: SymValue -> SymValue
inv :: SymValue -> SymValue
inv (SymValue Map SymToken Quantity
m Value
v) = Map SymToken Quantity -> Value -> SymValue
SymValue (Quantity -> Quantity
forall a. Num a => a -> a
negate (Quantity -> Quantity)
-> Map SymToken Quantity -> Map SymToken Quantity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map SymToken Quantity
m) (Value -> Value
negateValue Value
v)

class SymValueLike v where
  toSymValue :: v -> SymValue

class TokenLike t where
  -- | Get the value of a specific token in a `SymValue`
  symAssetIdValueOf :: SymValue -> t -> Quantity
  -- | Convert a token and an amount to a `SymValue`
  symAssetIdValue :: t -> Quantity -> SymValue

instance SymValueLike Value where
  toSymValue :: Value -> SymValue
toSymValue = Map SymToken Quantity -> Value -> SymValue
SymValue Map SymToken Quantity
forall a. Monoid a => a
mempty

instance SymValueLike SymValue where
  toSymValue :: SymValue -> SymValue
toSymValue = SymValue -> SymValue
forall a. a -> a
id

instance TokenLike SymToken where
  symAssetIdValueOf :: SymValue -> SymToken -> Quantity
symAssetIdValueOf (SymValue Map SymToken Quantity
svm Value
_) SymToken
t = Maybe Quantity -> Quantity
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Maybe Quantity -> Quantity) -> Maybe Quantity -> Quantity
forall a b. (a -> b) -> a -> b
$ SymToken -> Map SymToken Quantity -> Maybe Quantity
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SymToken
t Map SymToken Quantity
svm

  symAssetIdValue :: SymToken -> Quantity -> SymValue
symAssetIdValue SymToken
_ Quantity
0 = Map SymToken Quantity -> Value -> SymValue
SymValue Map SymToken Quantity
forall a. Monoid a => a
mempty Value
forall a. Monoid a => a
mempty
  symAssetIdValue SymToken
t Quantity
i = Map SymToken Quantity -> Value -> SymValue
SymValue (SymToken -> Quantity -> Map SymToken Quantity
forall k a. k -> a -> Map k a
Map.singleton SymToken
t Quantity
i) Value
forall a. Monoid a => a
mempty

instance TokenLike AssetId where
  symAssetIdValueOf :: SymValue -> AssetId -> Quantity
symAssetIdValueOf = Value -> AssetId -> Quantity
selectAsset (Value -> AssetId -> Quantity)
-> (SymValue -> Value) -> SymValue -> AssetId -> Quantity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymValue -> Value
actualValPart
  symAssetIdValue :: AssetId -> Quantity -> SymValue
symAssetIdValue AssetId
t Quantity
i = Value -> SymValue
forall v. SymValueLike v => v -> SymValue
toSymValue (Value -> SymValue) -> Value -> SymValue
forall a b. (a -> b) -> a -> b
$ [(AssetId, Quantity)] -> Value
valueFromList [(AssetId
t, Quantity
i)]