{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilyDependencies #-}

module Hydra.Ledger where

import Hydra.Prelude

import Hydra.Chain.ChainState (ChainSlot (..))
import Hydra.Tx.IsTx (IsTx (..))
import Test.QuickCheck.Instances.Natural ()
import Test.QuickCheck.Instances.Text ()

-- | Get outputs of a transaction.
outputsOfTx :: IsTx tx => tx -> [TxOutType tx]
outputsOfTx :: forall tx. IsTx tx => tx -> [TxOutType tx]
outputsOfTx = UTxOType tx -> [TxOutType tx]
forall tx. IsTx tx => UTxOType tx -> [TxOutType tx]
outputsOfUTxO (UTxOType tx -> [TxOutType tx])
-> (tx -> UTxOType tx) -> tx -> [TxOutType tx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. tx -> UTxOType tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx

-- | Get the next chain slot. Use this instead of giving 'Enum' or 'Num'
-- instances to 'ChainSlot'.
nextChainSlot :: ChainSlot -> ChainSlot
nextChainSlot :: ChainSlot -> ChainSlot
nextChainSlot (ChainSlot Natural
n) = Natural -> ChainSlot
ChainSlot (Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1)

-- | An abstract interface for a 'Ledger'. Allows to define mock / simpler
-- implementation for testing as well as limiting feature-envy from the business
-- logic by forcing a closed interface.
newtype Ledger tx = Ledger
  { forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions ::
      ChainSlot ->
      UTxOType tx ->
      [tx] ->
      Either (tx, ValidationError) (UTxOType tx)
  -- ^ Apply a set of transaction to a given UTxO set. Returns the new UTxO or
  -- validation failures returned from the ledger.
  -- TODO: 'ValidationError' should also include the UTxO, which is not
  -- necessarily the same as the given UTxO after some transactions
  }

-- | Collect applicable transactions and resulting UTxO. In contrast to
-- 'applyTransactions', this functions continues on validation errors.
collectTransactions :: Ledger tx -> ChainSlot -> UTxOType tx -> [tx] -> ([tx], UTxOType tx)
collectTransactions :: forall tx.
Ledger tx
-> ChainSlot -> UTxOType tx -> [tx] -> ([tx], UTxOType tx)
collectTransactions Ledger{ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
$sel:applyTransactions:Ledger :: forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions :: ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions} ChainSlot
slot UTxOType tx
utxo =
  (tx -> ([tx], UTxOType tx) -> ([tx], UTxOType tx))
-> ([tx], UTxOType tx) -> [tx] -> ([tx], UTxOType tx)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr tx -> ([tx], UTxOType tx) -> ([tx], UTxOType tx)
go ([], UTxOType tx
utxo)
 where
  go :: tx -> ([tx], UTxOType tx) -> ([tx], UTxOType tx)
go tx
tx ([tx]
applicableTxs, UTxOType tx
u) =
    case ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions ChainSlot
slot UTxOType tx
u [tx
tx] of
      Left (tx, ValidationError)
_ -> ([tx]
applicableTxs, UTxOType tx
u)
      Right UTxOType tx
u' -> ([tx]
applicableTxs [tx] -> [tx] -> [tx]
forall a. Semigroup a => a -> a -> a
<> [tx
tx], UTxOType tx
u')

-- | Either valid or an error which we get from the ledger-specs tx validation.
data ValidationResult
  = Valid
  | Invalid ValidationError
  deriving stock (ValidationResult -> ValidationResult -> Bool
(ValidationResult -> ValidationResult -> Bool)
-> (ValidationResult -> ValidationResult -> Bool)
-> Eq ValidationResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidationResult -> ValidationResult -> Bool
== :: ValidationResult -> ValidationResult -> Bool
$c/= :: ValidationResult -> ValidationResult -> Bool
/= :: ValidationResult -> ValidationResult -> Bool
Eq, Int -> ValidationResult -> ShowS
[ValidationResult] -> ShowS
ValidationResult -> String
(Int -> ValidationResult -> ShowS)
-> (ValidationResult -> String)
-> ([ValidationResult] -> ShowS)
-> Show ValidationResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidationResult -> ShowS
showsPrec :: Int -> ValidationResult -> ShowS
$cshow :: ValidationResult -> String
show :: ValidationResult -> String
$cshowList :: [ValidationResult] -> ShowS
showList :: [ValidationResult] -> ShowS
Show, (forall x. ValidationResult -> Rep ValidationResult x)
-> (forall x. Rep ValidationResult x -> ValidationResult)
-> Generic ValidationResult
forall x. Rep ValidationResult x -> ValidationResult
forall x. ValidationResult -> Rep ValidationResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ValidationResult -> Rep ValidationResult x
from :: forall x. ValidationResult -> Rep ValidationResult x
$cto :: forall x. Rep ValidationResult x -> ValidationResult
to :: forall x. Rep ValidationResult x -> ValidationResult
Generic)

newtype ValidationError = ValidationError {ValidationError -> Text
reason :: Text}
  deriving stock (ValidationError -> ValidationError -> Bool
(ValidationError -> ValidationError -> Bool)
-> (ValidationError -> ValidationError -> Bool)
-> Eq ValidationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidationError -> ValidationError -> Bool
== :: ValidationError -> ValidationError -> Bool
$c/= :: ValidationError -> ValidationError -> Bool
/= :: ValidationError -> ValidationError -> Bool
Eq, Int -> ValidationError -> ShowS
[ValidationError] -> ShowS
ValidationError -> String
(Int -> ValidationError -> ShowS)
-> (ValidationError -> String)
-> ([ValidationError] -> ShowS)
-> Show ValidationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidationError -> ShowS
showsPrec :: Int -> ValidationError -> ShowS
$cshow :: ValidationError -> String
show :: ValidationError -> String
$cshowList :: [ValidationError] -> ShowS
showList :: [ValidationError] -> ShowS
Show, (forall x. ValidationError -> Rep ValidationError x)
-> (forall x. Rep ValidationError x -> ValidationError)
-> Generic ValidationError
forall x. Rep ValidationError x -> ValidationError
forall x. ValidationError -> Rep ValidationError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ValidationError -> Rep ValidationError x
from :: forall x. ValidationError -> Rep ValidationError x
$cto :: forall x. Rep ValidationError x -> ValidationError
to :: forall x. Rep ValidationError x -> ValidationError
Generic)
  deriving anyclass ([ValidationError] -> Value
[ValidationError] -> Encoding
ValidationError -> Bool
ValidationError -> Value
ValidationError -> Encoding
(ValidationError -> Value)
-> (ValidationError -> Encoding)
-> ([ValidationError] -> Value)
-> ([ValidationError] -> Encoding)
-> (ValidationError -> Bool)
-> ToJSON ValidationError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ValidationError -> Value
toJSON :: ValidationError -> Value
$ctoEncoding :: ValidationError -> Encoding
toEncoding :: ValidationError -> Encoding
$ctoJSONList :: [ValidationError] -> Value
toJSONList :: [ValidationError] -> Value
$ctoEncodingList :: [ValidationError] -> Encoding
toEncodingList :: [ValidationError] -> Encoding
$comitField :: ValidationError -> Bool
omitField :: ValidationError -> Bool
ToJSON, Maybe ValidationError
Value -> Parser [ValidationError]
Value -> Parser ValidationError
(Value -> Parser ValidationError)
-> (Value -> Parser [ValidationError])
-> Maybe ValidationError
-> FromJSON ValidationError
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ValidationError
parseJSON :: Value -> Parser ValidationError
$cparseJSONList :: Value -> Parser [ValidationError]
parseJSONList :: Value -> Parser [ValidationError]
$comittedField :: Maybe ValidationError
omittedField :: Maybe ValidationError
FromJSON)

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