-- | A mock implementation of a ledger using very simple UTxO transactions.
--
-- These transactions have a very simplified representation of unspent
-- transaction outputs being just integers, but already have inputs and outputs.
-- Transactions are validated against the current state of the ledger, so that
-- one transaction could at some point be invalid, then becomes valid because
-- some inputs it consumes are now available.
--
-- NOTE: There is no notion of time in this ledger, so transactions validation
-- will never depend on the L1 slot.
module Hydra.Ledger.Simple where

import Hydra.Prelude

import Codec.Serialise (serialise)
import Data.Aeson (
  object,
  withObject,
  (.:),
  (.=),
 )
import Data.Set qualified as Set
import Hydra.Chain.ChainState (ChainSlot, ChainStateType, IsChainState (..))
import Hydra.Ledger (Ledger (..), ValidationError (ValidationError))
import Hydra.Tx (IsTx (..))

-- * Simple transactions

type SimpleId = Integer

-- | Simple transaction.
-- A transaction is a 'SimpleId', a list of inputs and a list of outputs,
-- and it has no time validity.
data SimpleTx = SimpleTx
  { SimpleTx -> SimpleId
txSimpleId :: SimpleId
  , SimpleTx -> UTxOType SimpleTx
txInputs :: UTxOType SimpleTx
  , SimpleTx -> UTxOType SimpleTx
txOutputs :: UTxOType SimpleTx
  }
  deriving stock (SimpleTx -> SimpleTx -> Bool
(SimpleTx -> SimpleTx -> Bool)
-> (SimpleTx -> SimpleTx -> Bool) -> Eq SimpleTx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SimpleTx -> SimpleTx -> Bool
== :: SimpleTx -> SimpleTx -> Bool
$c/= :: SimpleTx -> SimpleTx -> Bool
/= :: SimpleTx -> SimpleTx -> Bool
Eq, Eq SimpleTx
Eq SimpleTx =>
(SimpleTx -> SimpleTx -> Ordering)
-> (SimpleTx -> SimpleTx -> Bool)
-> (SimpleTx -> SimpleTx -> Bool)
-> (SimpleTx -> SimpleTx -> Bool)
-> (SimpleTx -> SimpleTx -> Bool)
-> (SimpleTx -> SimpleTx -> SimpleTx)
-> (SimpleTx -> SimpleTx -> SimpleTx)
-> Ord SimpleTx
SimpleTx -> SimpleTx -> Bool
SimpleTx -> SimpleTx -> Ordering
SimpleTx -> SimpleTx -> SimpleTx
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 :: SimpleTx -> SimpleTx -> Ordering
compare :: SimpleTx -> SimpleTx -> Ordering
$c< :: SimpleTx -> SimpleTx -> Bool
< :: SimpleTx -> SimpleTx -> Bool
$c<= :: SimpleTx -> SimpleTx -> Bool
<= :: SimpleTx -> SimpleTx -> Bool
$c> :: SimpleTx -> SimpleTx -> Bool
> :: SimpleTx -> SimpleTx -> Bool
$c>= :: SimpleTx -> SimpleTx -> Bool
>= :: SimpleTx -> SimpleTx -> Bool
$cmax :: SimpleTx -> SimpleTx -> SimpleTx
max :: SimpleTx -> SimpleTx -> SimpleTx
$cmin :: SimpleTx -> SimpleTx -> SimpleTx
min :: SimpleTx -> SimpleTx -> SimpleTx
Ord, (forall x. SimpleTx -> Rep SimpleTx x)
-> (forall x. Rep SimpleTx x -> SimpleTx) -> Generic SimpleTx
forall x. Rep SimpleTx x -> SimpleTx
forall x. SimpleTx -> Rep SimpleTx x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SimpleTx -> Rep SimpleTx x
from :: forall x. SimpleTx -> Rep SimpleTx x
$cto :: forall x. Rep SimpleTx x -> SimpleTx
to :: forall x. Rep SimpleTx x -> SimpleTx
Generic, Int -> SimpleTx -> ShowS
[SimpleTx] -> ShowS
SimpleTx -> String
(Int -> SimpleTx -> ShowS)
-> (SimpleTx -> String) -> ([SimpleTx] -> ShowS) -> Show SimpleTx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SimpleTx -> ShowS
showsPrec :: Int -> SimpleTx -> ShowS
$cshow :: SimpleTx -> String
show :: SimpleTx -> String
$cshowList :: [SimpleTx] -> ShowS
showList :: [SimpleTx] -> ShowS
Show)

instance ToJSON SimpleTx where
  toJSON :: SimpleTx -> Value
toJSON SimpleTx
tx =
    [Pair] -> Value
object
      [ Key
"id" Key -> SimpleId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId SimpleTx
tx
      , Key
"inputs" Key -> Set SimpleTxOut -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SimpleTx -> UTxOType SimpleTx
txInputs SimpleTx
tx
      , Key
"outputs" Key -> Set SimpleTxOut -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SimpleTx -> UTxOType SimpleTx
txOutputs SimpleTx
tx
      ]

instance FromJSON SimpleTx where
  parseJSON :: Value -> Parser SimpleTx
parseJSON = String -> (Object -> Parser SimpleTx) -> Value -> Parser SimpleTx
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"SimpleTx" ((Object -> Parser SimpleTx) -> Value -> Parser SimpleTx)
-> (Object -> Parser SimpleTx) -> Value -> Parser SimpleTx
forall a b. (a -> b) -> a -> b
$ \Object
obj ->
    SimpleId -> Set SimpleTxOut -> Set SimpleTxOut -> SimpleTx
SimpleId -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx
      (SimpleId -> Set SimpleTxOut -> Set SimpleTxOut -> SimpleTx)
-> Parser SimpleId
-> Parser (Set SimpleTxOut -> Set SimpleTxOut -> SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
obj Object -> Key -> Parser SimpleId
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id")
      Parser (Set SimpleTxOut -> Set SimpleTxOut -> SimpleTx)
-> Parser (Set SimpleTxOut) -> Parser (Set SimpleTxOut -> SimpleTx)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
obj Object -> Key -> Parser (Set SimpleTxOut)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"inputs")
      Parser (Set SimpleTxOut -> SimpleTx)
-> Parser (Set SimpleTxOut) -> Parser SimpleTx
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
obj Object -> Key -> Parser (Set SimpleTxOut)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"outputs")

instance ToCBOR SimpleTx where
  toCBOR :: SimpleTx -> Encoding
toCBOR = SimpleTx -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance FromCBOR SimpleTx where
  fromCBOR :: forall s. Decoder s SimpleTx
fromCBOR = Decoder s SimpleTx
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

-- | A single output of a 'SimpleTx' having an integer identity and sole value.
newtype SimpleTxOut = SimpleTxOut {SimpleTxOut -> SimpleId
unSimpleTxOut :: Integer}
  deriving stock ((forall x. SimpleTxOut -> Rep SimpleTxOut x)
-> (forall x. Rep SimpleTxOut x -> SimpleTxOut)
-> Generic SimpleTxOut
forall x. Rep SimpleTxOut x -> SimpleTxOut
forall x. SimpleTxOut -> Rep SimpleTxOut x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SimpleTxOut -> Rep SimpleTxOut x
from :: forall x. SimpleTxOut -> Rep SimpleTxOut x
$cto :: forall x. Rep SimpleTxOut x -> SimpleTxOut
to :: forall x. Rep SimpleTxOut x -> SimpleTxOut
Generic)
  deriving newtype (SimpleTxOut -> SimpleTxOut -> Bool
(SimpleTxOut -> SimpleTxOut -> Bool)
-> (SimpleTxOut -> SimpleTxOut -> Bool) -> Eq SimpleTxOut
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SimpleTxOut -> SimpleTxOut -> Bool
== :: SimpleTxOut -> SimpleTxOut -> Bool
$c/= :: SimpleTxOut -> SimpleTxOut -> Bool
/= :: SimpleTxOut -> SimpleTxOut -> Bool
Eq, Eq SimpleTxOut
Eq SimpleTxOut =>
(SimpleTxOut -> SimpleTxOut -> Ordering)
-> (SimpleTxOut -> SimpleTxOut -> Bool)
-> (SimpleTxOut -> SimpleTxOut -> Bool)
-> (SimpleTxOut -> SimpleTxOut -> Bool)
-> (SimpleTxOut -> SimpleTxOut -> Bool)
-> (SimpleTxOut -> SimpleTxOut -> SimpleTxOut)
-> (SimpleTxOut -> SimpleTxOut -> SimpleTxOut)
-> Ord SimpleTxOut
SimpleTxOut -> SimpleTxOut -> Bool
SimpleTxOut -> SimpleTxOut -> Ordering
SimpleTxOut -> SimpleTxOut -> SimpleTxOut
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 :: SimpleTxOut -> SimpleTxOut -> Ordering
compare :: SimpleTxOut -> SimpleTxOut -> Ordering
$c< :: SimpleTxOut -> SimpleTxOut -> Bool
< :: SimpleTxOut -> SimpleTxOut -> Bool
$c<= :: SimpleTxOut -> SimpleTxOut -> Bool
<= :: SimpleTxOut -> SimpleTxOut -> Bool
$c> :: SimpleTxOut -> SimpleTxOut -> Bool
> :: SimpleTxOut -> SimpleTxOut -> Bool
$c>= :: SimpleTxOut -> SimpleTxOut -> Bool
>= :: SimpleTxOut -> SimpleTxOut -> Bool
$cmax :: SimpleTxOut -> SimpleTxOut -> SimpleTxOut
max :: SimpleTxOut -> SimpleTxOut -> SimpleTxOut
$cmin :: SimpleTxOut -> SimpleTxOut -> SimpleTxOut
min :: SimpleTxOut -> SimpleTxOut -> SimpleTxOut
Ord, Int -> SimpleTxOut -> ShowS
[SimpleTxOut] -> ShowS
SimpleTxOut -> String
(Int -> SimpleTxOut -> ShowS)
-> (SimpleTxOut -> String)
-> ([SimpleTxOut] -> ShowS)
-> Show SimpleTxOut
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SimpleTxOut -> ShowS
showsPrec :: Int -> SimpleTxOut -> ShowS
$cshow :: SimpleTxOut -> String
show :: SimpleTxOut -> String
$cshowList :: [SimpleTxOut] -> ShowS
showList :: [SimpleTxOut] -> ShowS
Show, SimpleId -> SimpleTxOut
SimpleTxOut -> SimpleTxOut
SimpleTxOut -> SimpleTxOut -> SimpleTxOut
(SimpleTxOut -> SimpleTxOut -> SimpleTxOut)
-> (SimpleTxOut -> SimpleTxOut -> SimpleTxOut)
-> (SimpleTxOut -> SimpleTxOut -> SimpleTxOut)
-> (SimpleTxOut -> SimpleTxOut)
-> (SimpleTxOut -> SimpleTxOut)
-> (SimpleTxOut -> SimpleTxOut)
-> (SimpleId -> SimpleTxOut)
-> Num SimpleTxOut
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (SimpleId -> a)
-> Num a
$c+ :: SimpleTxOut -> SimpleTxOut -> SimpleTxOut
+ :: SimpleTxOut -> SimpleTxOut -> SimpleTxOut
$c- :: SimpleTxOut -> SimpleTxOut -> SimpleTxOut
- :: SimpleTxOut -> SimpleTxOut -> SimpleTxOut
$c* :: SimpleTxOut -> SimpleTxOut -> SimpleTxOut
* :: SimpleTxOut -> SimpleTxOut -> SimpleTxOut
$cnegate :: SimpleTxOut -> SimpleTxOut
negate :: SimpleTxOut -> SimpleTxOut
$cabs :: SimpleTxOut -> SimpleTxOut
abs :: SimpleTxOut -> SimpleTxOut
$csignum :: SimpleTxOut -> SimpleTxOut
signum :: SimpleTxOut -> SimpleTxOut
$cfromInteger :: SimpleId -> SimpleTxOut
fromInteger :: SimpleId -> SimpleTxOut
Num, [SimpleTxOut] -> Value
[SimpleTxOut] -> Encoding
SimpleTxOut -> Bool
SimpleTxOut -> Value
SimpleTxOut -> Encoding
(SimpleTxOut -> Value)
-> (SimpleTxOut -> Encoding)
-> ([SimpleTxOut] -> Value)
-> ([SimpleTxOut] -> Encoding)
-> (SimpleTxOut -> Bool)
-> ToJSON SimpleTxOut
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: SimpleTxOut -> Value
toJSON :: SimpleTxOut -> Value
$ctoEncoding :: SimpleTxOut -> Encoding
toEncoding :: SimpleTxOut -> Encoding
$ctoJSONList :: [SimpleTxOut] -> Value
toJSONList :: [SimpleTxOut] -> Value
$ctoEncodingList :: [SimpleTxOut] -> Encoding
toEncodingList :: [SimpleTxOut] -> Encoding
$comitField :: SimpleTxOut -> Bool
omitField :: SimpleTxOut -> Bool
ToJSON, Maybe SimpleTxOut
Value -> Parser [SimpleTxOut]
Value -> Parser SimpleTxOut
(Value -> Parser SimpleTxOut)
-> (Value -> Parser [SimpleTxOut])
-> Maybe SimpleTxOut
-> FromJSON SimpleTxOut
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser SimpleTxOut
parseJSON :: Value -> Parser SimpleTxOut
$cparseJSONList :: Value -> Parser [SimpleTxOut]
parseJSONList :: Value -> Parser [SimpleTxOut]
$comittedField :: Maybe SimpleTxOut
omittedField :: Maybe SimpleTxOut
FromJSON)

instance ToCBOR SimpleTxOut where
  toCBOR :: SimpleTxOut -> Encoding
toCBOR = SimpleTxOut -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance FromCBOR SimpleTxOut where
  fromCBOR :: forall s. Decoder s SimpleTxOut
fromCBOR = Decoder s SimpleTxOut
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

instance IsTx SimpleTx where
  type TxIdType SimpleTx = SimpleId
  type TxOutType SimpleTx = SimpleTxOut
  type UTxOType SimpleTx = Set SimpleTxOut
  type ValueType SimpleTx = Int

  txId :: SimpleTx -> TxIdType SimpleTx
txId (SimpleTx SimpleId
tid UTxOType SimpleTx
_ UTxOType SimpleTx
_) = SimpleId
TxIdType SimpleTx
tid
  balance :: UTxOType SimpleTx -> ValueType SimpleTx
balance = Set SimpleTxOut -> Int
UTxOType SimpleTx -> ValueType SimpleTx
forall a. Set a -> Int
Set.size
  hashUTxO :: UTxOType SimpleTx -> ByteString
hashUTxO = ByteString -> ByteString
forall l s. LazyStrict l s => l -> s
toStrict (ByteString -> ByteString)
-> (Set SimpleTxOut -> ByteString) -> Set SimpleTxOut -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SimpleTxOut -> ByteString) -> Set SimpleTxOut -> ByteString
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (SimpleId -> ByteString
forall a. Serialise a => a -> ByteString
serialise (SimpleId -> ByteString)
-> (SimpleTxOut -> SimpleId) -> SimpleTxOut -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleTxOut -> SimpleId
unSimpleTxOut)
  txIdBytes :: TxIdType SimpleTx -> ByteString
txIdBytes = ByteString -> ByteString
forall l s. LazyStrict l s => l -> s
toStrict (ByteString -> ByteString)
-> (SimpleId -> ByteString) -> SimpleId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleId -> ByteString
forall a. Serialise a => a -> ByteString
serialise
  utxoFromTx :: SimpleTx -> UTxOType SimpleTx
utxoFromTx = SimpleTx -> UTxOType SimpleTx
txOutputs
  outputsOfUTxO :: UTxOType SimpleTx -> [TxOutType SimpleTx]
outputsOfUTxO = Set SimpleTxOut -> [SimpleTxOut]
UTxOType SimpleTx -> [TxOutType SimpleTx]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  withoutUTxO :: UTxOType SimpleTx -> UTxOType SimpleTx -> UTxOType SimpleTx
withoutUTxO = Set SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
UTxOType SimpleTx -> UTxOType SimpleTx -> UTxOType SimpleTx
forall a. Ord a => Set a -> Set a -> Set a
Set.difference

  applyTxTo :: SimpleTx -> UTxOType SimpleTx -> UTxOType SimpleTx
applyTxTo (SimpleTx SimpleId
_ UTxOType SimpleTx
ins UTxOType SimpleTx
outs) UTxOType SimpleTx
utxo = (Set SimpleTxOut
UTxOType SimpleTx
utxo Set SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set SimpleTxOut
UTxOType SimpleTx
ins) Set SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
forall a. Semigroup a => a -> a -> a
<> Set SimpleTxOut
UTxOType SimpleTx
outs

  txSpendingUTxO :: UTxOType SimpleTx -> SimpleTx
txSpendingUTxO UTxOType SimpleTx
utxo =
    SimpleTx
      { $sel:txSimpleId:SimpleTx :: SimpleId
txSimpleId = SimpleId
0
      , $sel:txInputs:SimpleTx :: UTxOType SimpleTx
txInputs = UTxOType SimpleTx
utxo
      , $sel:txOutputs:SimpleTx :: UTxOType SimpleTx
txOutputs = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
      }

  filterUTxOByOutputs :: UTxOType SimpleTx -> Set (TxOutType SimpleTx) -> UTxOType SimpleTx
filterUTxOByOutputs = Set SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
UTxOType SimpleTx -> Set (TxOutType SimpleTx) -> UTxOType SimpleTx
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection

  removeOneOutputFromUTxO :: TxOutType SimpleTx -> UTxOType SimpleTx -> UTxOType SimpleTx
removeOneOutputFromUTxO = TxOutType SimpleTx -> UTxOType SimpleTx -> UTxOType SimpleTx
SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
forall a. Ord a => a -> Set a -> Set a
Set.delete

  utxoToElement :: TxOutType SimpleTx -> ByteString
utxoToElement = ByteString -> ByteString
forall l s. LazyStrict l s => l -> s
toStrict (ByteString -> ByteString)
-> (SimpleTxOut -> ByteString) -> SimpleTxOut -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleId -> ByteString
forall a. Serialise a => a -> ByteString
serialise (SimpleId -> ByteString)
-> (SimpleTxOut -> SimpleId) -> SimpleTxOut -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleTxOut -> SimpleId
unSimpleTxOut

-- * Simple chain state

newtype SimpleChainState = SimpleChainState {SimpleChainState -> ChainSlot
slot :: ChainSlot}
  deriving stock (SimpleChainState -> SimpleChainState -> Bool
(SimpleChainState -> SimpleChainState -> Bool)
-> (SimpleChainState -> SimpleChainState -> Bool)
-> Eq SimpleChainState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SimpleChainState -> SimpleChainState -> Bool
== :: SimpleChainState -> SimpleChainState -> Bool
$c/= :: SimpleChainState -> SimpleChainState -> Bool
/= :: SimpleChainState -> SimpleChainState -> Bool
Eq, Int -> SimpleChainState -> ShowS
[SimpleChainState] -> ShowS
SimpleChainState -> String
(Int -> SimpleChainState -> ShowS)
-> (SimpleChainState -> String)
-> ([SimpleChainState] -> ShowS)
-> Show SimpleChainState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SimpleChainState -> ShowS
showsPrec :: Int -> SimpleChainState -> ShowS
$cshow :: SimpleChainState -> String
show :: SimpleChainState -> String
$cshowList :: [SimpleChainState] -> ShowS
showList :: [SimpleChainState] -> ShowS
Show, (forall x. SimpleChainState -> Rep SimpleChainState x)
-> (forall x. Rep SimpleChainState x -> SimpleChainState)
-> Generic SimpleChainState
forall x. Rep SimpleChainState x -> SimpleChainState
forall x. SimpleChainState -> Rep SimpleChainState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SimpleChainState -> Rep SimpleChainState x
from :: forall x. SimpleChainState -> Rep SimpleChainState x
$cto :: forall x. Rep SimpleChainState x -> SimpleChainState
to :: forall x. Rep SimpleChainState x -> SimpleChainState
Generic)
  deriving anyclass ([SimpleChainState] -> Value
[SimpleChainState] -> Encoding
SimpleChainState -> Bool
SimpleChainState -> Value
SimpleChainState -> Encoding
(SimpleChainState -> Value)
-> (SimpleChainState -> Encoding)
-> ([SimpleChainState] -> Value)
-> ([SimpleChainState] -> Encoding)
-> (SimpleChainState -> Bool)
-> ToJSON SimpleChainState
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: SimpleChainState -> Value
toJSON :: SimpleChainState -> Value
$ctoEncoding :: SimpleChainState -> Encoding
toEncoding :: SimpleChainState -> Encoding
$ctoJSONList :: [SimpleChainState] -> Value
toJSONList :: [SimpleChainState] -> Value
$ctoEncodingList :: [SimpleChainState] -> Encoding
toEncodingList :: [SimpleChainState] -> Encoding
$comitField :: SimpleChainState -> Bool
omitField :: SimpleChainState -> Bool
ToJSON, Maybe SimpleChainState
Value -> Parser [SimpleChainState]
Value -> Parser SimpleChainState
(Value -> Parser SimpleChainState)
-> (Value -> Parser [SimpleChainState])
-> Maybe SimpleChainState
-> FromJSON SimpleChainState
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser SimpleChainState
parseJSON :: Value -> Parser SimpleChainState
$cparseJSONList :: Value -> Parser [SimpleChainState]
parseJSONList :: Value -> Parser [SimpleChainState]
$comittedField :: Maybe SimpleChainState
omittedField :: Maybe SimpleChainState
FromJSON)
  deriving newtype (SimpleId -> SimpleChainState
SimpleChainState -> SimpleChainState
SimpleChainState -> SimpleChainState -> SimpleChainState
(SimpleChainState -> SimpleChainState -> SimpleChainState)
-> (SimpleChainState -> SimpleChainState -> SimpleChainState)
-> (SimpleChainState -> SimpleChainState -> SimpleChainState)
-> (SimpleChainState -> SimpleChainState)
-> (SimpleChainState -> SimpleChainState)
-> (SimpleChainState -> SimpleChainState)
-> (SimpleId -> SimpleChainState)
-> Num SimpleChainState
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (SimpleId -> a)
-> Num a
$c+ :: SimpleChainState -> SimpleChainState -> SimpleChainState
+ :: SimpleChainState -> SimpleChainState -> SimpleChainState
$c- :: SimpleChainState -> SimpleChainState -> SimpleChainState
- :: SimpleChainState -> SimpleChainState -> SimpleChainState
$c* :: SimpleChainState -> SimpleChainState -> SimpleChainState
* :: SimpleChainState -> SimpleChainState -> SimpleChainState
$cnegate :: SimpleChainState -> SimpleChainState
negate :: SimpleChainState -> SimpleChainState
$cabs :: SimpleChainState -> SimpleChainState
abs :: SimpleChainState -> SimpleChainState
$csignum :: SimpleChainState -> SimpleChainState
signum :: SimpleChainState -> SimpleChainState
$cfromInteger :: SimpleId -> SimpleChainState
fromInteger :: SimpleId -> SimpleChainState
Num)

instance ToCBOR SimpleChainState where
  toCBOR :: SimpleChainState -> Encoding
toCBOR = SimpleChainState -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance FromCBOR SimpleChainState where
  fromCBOR :: forall s. Decoder s SimpleChainState
fromCBOR = Decoder s SimpleChainState
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

instance IsChainState SimpleTx where
  type ChainPointType SimpleTx = ChainSlot
  type ChainStateType SimpleTx = SimpleChainState
  chainStatePoint :: ChainStateType SimpleTx -> ChainPointType SimpleTx
chainStatePoint = ChainStateType SimpleTx -> ChainPointType SimpleTx
SimpleChainState -> ChainSlot
slot
  chainPointSlot :: ChainPointType SimpleTx -> ChainSlot
chainPointSlot = ChainSlot -> ChainSlot
ChainPointType SimpleTx -> ChainSlot
forall a. a -> a
id

-- * A simple ledger

simpleLedger :: Ledger SimpleTx
simpleLedger :: Ledger SimpleTx
simpleLedger =
  -- NOTE: SimpleTx has no scripts or signatures, so re-application is identical
  -- to application; there is no static check to skip.
  Ledger{ChainSlot
-> Set SimpleTxOut
-> [SimpleTx]
-> Either (SimpleTx, ValidationError) (Set SimpleTxOut)
ChainSlot
-> UTxOType SimpleTx
-> [SimpleTx]
-> Either (SimpleTx, ValidationError) (UTxOType SimpleTx)
forall (t :: * -> *) p.
Foldable t =>
p
-> Set SimpleTxOut
-> t SimpleTx
-> Either (SimpleTx, ValidationError) (Set SimpleTxOut)
applyTransactions :: forall (t :: * -> *) p.
Foldable t =>
p
-> Set SimpleTxOut
-> t SimpleTx
-> Either (SimpleTx, ValidationError) (Set SimpleTxOut)
$sel:applyTransactions:Ledger :: ChainSlot
-> UTxOType SimpleTx
-> [SimpleTx]
-> Either (SimpleTx, ValidationError) (UTxOType SimpleTx)
applyTransactions, $sel:reapplyTransactions:Ledger :: ChainSlot
-> UTxOType SimpleTx
-> [SimpleTx]
-> Either (SimpleTx, ValidationError) (UTxOType SimpleTx)
reapplyTransactions = ChainSlot
-> Set SimpleTxOut
-> [SimpleTx]
-> Either (SimpleTx, ValidationError) (Set SimpleTxOut)
ChainSlot
-> UTxOType SimpleTx
-> [SimpleTx]
-> Either (SimpleTx, ValidationError) (UTxOType SimpleTx)
forall (t :: * -> *) p.
Foldable t =>
p
-> Set SimpleTxOut
-> t SimpleTx
-> Either (SimpleTx, ValidationError) (Set SimpleTxOut)
applyTransactions}
 where
  -- NOTE: _slot is unused as SimpleTx transactions don't have a notion of time.
  applyTransactions :: Foldable t => p -> Set SimpleTxOut -> t SimpleTx -> Either (SimpleTx, ValidationError) (Set SimpleTxOut)
  applyTransactions :: forall (t :: * -> *) p.
Foldable t =>
p
-> Set SimpleTxOut
-> t SimpleTx
-> Either (SimpleTx, ValidationError) (Set SimpleTxOut)
applyTransactions p
_slot =
    (Set SimpleTxOut
 -> SimpleTx
 -> Either (SimpleTx, ValidationError) (Set SimpleTxOut))
-> Set SimpleTxOut
-> t SimpleTx
-> Either (SimpleTx, ValidationError) (Set SimpleTxOut)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ((Set SimpleTxOut
  -> SimpleTx
  -> Either (SimpleTx, ValidationError) (Set SimpleTxOut))
 -> Set SimpleTxOut
 -> t SimpleTx
 -> Either (SimpleTx, ValidationError) (Set SimpleTxOut))
-> (Set SimpleTxOut
    -> SimpleTx
    -> Either (SimpleTx, ValidationError) (Set SimpleTxOut))
-> Set SimpleTxOut
-> t SimpleTx
-> Either (SimpleTx, ValidationError) (Set SimpleTxOut)
forall a b. (a -> b) -> a -> b
$ \Set SimpleTxOut
utxo tx :: SimpleTx
tx@(SimpleTx SimpleId
_ UTxOType SimpleTx
ins UTxOType SimpleTx
outs) ->
      if Set SimpleTxOut
UTxOType SimpleTx
ins Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set SimpleTxOut
utxo Bool -> Bool -> Bool
&& Set SimpleTxOut
utxo Set SimpleTxOut -> Set SimpleTxOut -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.disjoint` Set SimpleTxOut
UTxOType SimpleTx
outs
        then Set SimpleTxOut
-> Either (SimpleTx, ValidationError) (Set SimpleTxOut)
forall a b. b -> Either a b
Right (Set SimpleTxOut
 -> Either (SimpleTx, ValidationError) (Set SimpleTxOut))
-> Set SimpleTxOut
-> Either (SimpleTx, ValidationError) (Set SimpleTxOut)
forall a b. (a -> b) -> a -> b
$ (Set SimpleTxOut
utxo Set SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set SimpleTxOut
UTxOType SimpleTx
ins) Set SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set SimpleTxOut
UTxOType SimpleTx
outs
        else (SimpleTx, ValidationError)
-> Either (SimpleTx, ValidationError) (Set SimpleTxOut)
forall a b. a -> Either a b
Left (SimpleTx
tx, Text -> ValidationError
ValidationError Text
"cannot apply transaction")