-- | 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 -> Integer
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 -> Integer -> 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 ->
    Integer -> Set SimpleTxOut -> Set SimpleTxOut -> SimpleTx
Integer -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx
      (Integer -> Set SimpleTxOut -> Set SimpleTxOut -> SimpleTx)
-> Parser Integer
-> Parser (Set SimpleTxOut -> Set SimpleTxOut -> SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
obj Object -> Key -> Parser Integer
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 Integer
txid UTxOType SimpleTx
inputs UTxOType SimpleTx
outputs) =
    Integer -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Integer
txid Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Set SimpleTxOut -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Set SimpleTxOut
UTxOType SimpleTx
inputs Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Set SimpleTxOut -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Set SimpleTxOut
UTxOType SimpleTx
outputs

instance FromCBOR SimpleTx where
  fromCBOR :: forall s. Decoder s SimpleTx
fromCBOR =
    Integer -> Set SimpleTxOut -> Set SimpleTxOut -> SimpleTx
Integer -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx
      (Integer -> Set SimpleTxOut -> Set SimpleTxOut -> SimpleTx)
-> Decoder s Integer
-> Decoder s (Set SimpleTxOut -> Set SimpleTxOut -> SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder s (Set SimpleTxOut -> Set SimpleTxOut -> SimpleTx)
-> Decoder s (Set SimpleTxOut)
-> Decoder s (Set SimpleTxOut -> SimpleTx)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Set SimpleTxOut)
forall s. Decoder s (Set SimpleTxOut)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder s (Set SimpleTxOut -> SimpleTx)
-> Decoder s (Set SimpleTxOut) -> Decoder s SimpleTx
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Set SimpleTxOut)
forall s. Decoder s (Set SimpleTxOut)
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance Arbitrary SimpleTx where
  arbitrary :: Gen SimpleTx
arbitrary = Gen SimpleTx
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

-- | A single output of a 'SimpleTx' having an integer identity and sole value.
newtype SimpleTxOut = SimpleTxOut {SimpleTxOut -> Integer
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, Integer -> SimpleTxOut
SimpleTxOut -> SimpleTxOut
SimpleTxOut -> SimpleTxOut -> SimpleTxOut
(SimpleTxOut -> SimpleTxOut -> SimpleTxOut)
-> (SimpleTxOut -> SimpleTxOut -> SimpleTxOut)
-> (SimpleTxOut -> SimpleTxOut -> SimpleTxOut)
-> (SimpleTxOut -> SimpleTxOut)
-> (SimpleTxOut -> SimpleTxOut)
-> (SimpleTxOut -> SimpleTxOut)
-> (Integer -> SimpleTxOut)
-> Num SimpleTxOut
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> 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 :: Integer -> SimpleTxOut
fromInteger :: Integer -> 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, Gen SimpleTxOut
Gen SimpleTxOut
-> (SimpleTxOut -> [SimpleTxOut]) -> Arbitrary SimpleTxOut
SimpleTxOut -> [SimpleTxOut]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen SimpleTxOut
arbitrary :: Gen SimpleTxOut
$cshrink :: SimpleTxOut -> [SimpleTxOut]
shrink :: SimpleTxOut -> [SimpleTxOut]
Arbitrary)

instance ToCBOR SimpleTxOut where
  toCBOR :: SimpleTxOut -> Encoding
toCBOR (SimpleTxOut Integer
inId) = Integer -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Integer
inId

instance FromCBOR SimpleTxOut where
  fromCBOR :: forall s. Decoder s SimpleTxOut
fromCBOR = Integer -> SimpleTxOut
SimpleTxOut (Integer -> SimpleTxOut)
-> Decoder s Integer -> Decoder s SimpleTxOut
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR

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 Integer
tid UTxOType SimpleTx
_ UTxOType SimpleTx
_) = Integer
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 (Integer -> ByteString
forall a. Serialise a => a -> ByteString
serialise (Integer -> ByteString)
-> (SimpleTxOut -> Integer) -> SimpleTxOut -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleTxOut -> Integer
unSimpleTxOut)
  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

  txSpendingUTxO :: UTxOType SimpleTx -> SimpleTx
txSpendingUTxO UTxOType SimpleTx
utxo =
    SimpleTx
      { $sel:txSimpleId:SimpleTx :: Integer
txSimpleId = Integer
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
      }

-- * 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 (Gen SimpleChainState
Gen SimpleChainState
-> (SimpleChainState -> [SimpleChainState])
-> Arbitrary SimpleChainState
SimpleChainState -> [SimpleChainState]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen SimpleChainState
arbitrary :: Gen SimpleChainState
$cshrink :: SimpleChainState -> [SimpleChainState]
shrink :: SimpleChainState -> [SimpleChainState]
Arbitrary)

instance IsChainState SimpleTx where
  type ChainStateType SimpleTx = SimpleChainState

  chainStateSlot :: ChainStateType SimpleTx -> ChainSlot
chainStateSlot SimpleChainState{ChainSlot
$sel:slot:SimpleChainState :: SimpleChainState -> ChainSlot
slot :: ChainSlot
slot} = ChainSlot
slot

-- * A simple ledger

simpleLedger :: Ledger SimpleTx
simpleLedger :: Ledger SimpleTx
simpleLedger =
  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}
 where
  -- NOTE: _slot is unused as SimpleTx transactions don't have a notion of time.
  applyTransactions :: 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 Integer
_ 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")

-- * Builders

utxoRef :: Integer -> UTxOType SimpleTx
utxoRef :: Integer -> UTxOType SimpleTx
utxoRef = SimpleTxOut -> Set SimpleTxOut
forall a. a -> Set a
Set.singleton (SimpleTxOut -> Set SimpleTxOut)
-> (Integer -> SimpleTxOut) -> Integer -> Set SimpleTxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> SimpleTxOut
SimpleTxOut

utxoRefs :: [Integer] -> UTxOType SimpleTx
utxoRefs :: [Integer] -> UTxOType SimpleTx
utxoRefs = [SimpleTxOut] -> Set SimpleTxOut
forall a. Ord a => [a] -> Set a
Set.fromList ([SimpleTxOut] -> Set SimpleTxOut)
-> ([Integer] -> [SimpleTxOut]) -> [Integer] -> Set SimpleTxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> SimpleTxOut) -> [Integer] -> [SimpleTxOut]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> SimpleTxOut
SimpleTxOut

aValidTx :: Integer -> SimpleTx
aValidTx :: Integer -> SimpleTx
aValidTx Integer
n = Integer -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx Integer
n Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty (Integer -> UTxOType SimpleTx
utxoRef Integer
n)

-- * Generators

listOfCommittedUTxOs :: Integer -> Gen [UTxOType SimpleTx]
listOfCommittedUTxOs :: Integer -> Gen [UTxOType SimpleTx]
listOfCommittedUTxOs Integer
numCommits =
  [UTxOType SimpleTx] -> Gen [UTxOType SimpleTx]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([UTxOType SimpleTx] -> Gen [UTxOType SimpleTx])
-> [UTxOType SimpleTx] -> Gen [UTxOType SimpleTx]
forall a b. (a -> b) -> a -> b
$ SimpleTxOut -> Set SimpleTxOut
forall a. a -> Set a
Set.singleton (SimpleTxOut -> Set SimpleTxOut)
-> (Integer -> SimpleTxOut) -> Integer -> Set SimpleTxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> SimpleTxOut
SimpleTxOut (Integer -> Set SimpleTxOut) -> [Integer] -> [Set SimpleTxOut]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Integer
1 .. Integer
numCommits]