{-# OPTIONS_GHC -Wno-orphans #-}

module Hydra.Cardano.Api.ValidityInterval where

import Hydra.Cardano.Api.Prelude

import Cardano.Ledger.Allegra.Scripts qualified as Ledger
import Cardano.Ledger.BaseTypes (StrictMaybe (..), maybeToStrictMaybe)
import Test.Gen.Cardano.Api.Typed (genTxValidityLowerBound, genTxValidityUpperBound)
import Test.QuickCheck.Hedgehog (hedgehog)

toLedgerValidityInterval ::
  (TxValidityLowerBound era, TxValidityUpperBound era) ->
  Ledger.ValidityInterval
toLedgerValidityInterval :: forall era.
(TxValidityLowerBound era, TxValidityUpperBound era)
-> ValidityInterval
toLedgerValidityInterval (TxValidityLowerBound era
lowerBound, TxValidityUpperBound era
upperBound) =
  Ledger.ValidityInterval
    { invalidBefore :: StrictMaybe SlotNo
Ledger.invalidBefore =
        case TxValidityLowerBound era
lowerBound of
          TxValidityLowerBound era
TxValidityNoLowerBound -> StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing
          TxValidityLowerBound AllegraEraOnwards era
_ SlotNo
s -> SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust SlotNo
s
    , invalidHereafter :: StrictMaybe SlotNo
Ledger.invalidHereafter =
        case TxValidityUpperBound era
upperBound of
          TxValidityUpperBound ShelleyBasedEra era
_ Maybe SlotNo
s -> Maybe SlotNo -> StrictMaybe SlotNo
forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe Maybe SlotNo
s
    }
fromLedgerValidityInterval ::
  Ledger.ValidityInterval ->
  (TxValidityLowerBound Era, TxValidityUpperBound Era)
fromLedgerValidityInterval :: ValidityInterval
-> (TxValidityLowerBound Era, TxValidityUpperBound Era)
fromLedgerValidityInterval ValidityInterval
validityInterval =
  let Ledger.ValidityInterval{invalidBefore :: ValidityInterval -> StrictMaybe SlotNo
Ledger.invalidBefore = StrictMaybe SlotNo
invalidBefore, invalidHereafter :: ValidityInterval -> StrictMaybe SlotNo
Ledger.invalidHereafter = StrictMaybe SlotNo
invalidHereAfter} = ValidityInterval
validityInterval
      lowerBound :: TxValidityLowerBound Era
lowerBound = case StrictMaybe SlotNo
invalidBefore of
        StrictMaybe SlotNo
SNothing -> TxValidityLowerBound Era
forall era. TxValidityLowerBound era
TxValidityNoLowerBound
        SJust SlotNo
s -> AllegraEraOnwards Era -> SlotNo -> TxValidityLowerBound Era
forall era.
AllegraEraOnwards era -> SlotNo -> TxValidityLowerBound era
TxValidityLowerBound AllegraEraOnwards Era
forall era. IsAllegraBasedEra era => AllegraEraOnwards era
allegraBasedEra SlotNo
s
      upperBound :: TxValidityUpperBound Era
upperBound = case StrictMaybe SlotNo
invalidHereAfter of
        StrictMaybe SlotNo
SNothing -> ShelleyBasedEra Era -> Maybe SlotNo -> TxValidityUpperBound Era
forall era.
ShelleyBasedEra era -> Maybe SlotNo -> TxValidityUpperBound era
TxValidityUpperBound ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra Maybe SlotNo
forall a. Maybe a
Nothing
        SJust SlotNo
s -> ShelleyBasedEra Era -> Maybe SlotNo -> TxValidityUpperBound Era
forall era.
ShelleyBasedEra era -> Maybe SlotNo -> TxValidityUpperBound era
TxValidityUpperBound ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
Just SlotNo
s)
   in (TxValidityLowerBound Era
lowerBound, TxValidityUpperBound Era
upperBound)

instance Arbitrary (TxValidityLowerBound Era) where
  arbitrary :: Gen (TxValidityLowerBound Era)
arbitrary = Gen (TxValidityLowerBound Era) -> Gen (TxValidityLowerBound Era)
forall a. Gen a -> Gen a
hedgehog (Gen (TxValidityLowerBound Era) -> Gen (TxValidityLowerBound Era))
-> Gen (TxValidityLowerBound Era) -> Gen (TxValidityLowerBound Era)
forall a b. (a -> b) -> a -> b
$ CardanoEra Era -> Gen (TxValidityLowerBound Era)
forall era. CardanoEra era -> Gen (TxValidityLowerBound era)
genTxValidityLowerBound CardanoEra Era
forall era. IsCardanoEra era => CardanoEra era
cardanoEra

instance Arbitrary (TxValidityUpperBound Era) where
  arbitrary :: Gen (TxValidityUpperBound Era)
arbitrary = Gen (TxValidityUpperBound Era) -> Gen (TxValidityUpperBound Era)
forall a. Gen a -> Gen a
hedgehog (Gen (TxValidityUpperBound Era) -> Gen (TxValidityUpperBound Era))
-> Gen (TxValidityUpperBound Era) -> Gen (TxValidityUpperBound Era)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra Era -> Gen (TxValidityUpperBound Era)
forall era. ShelleyBasedEra era -> Gen (TxValidityUpperBound era)
genTxValidityUpperBound ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra