{-# 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.QuickCheck (oneof)

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. HasCallStack => [Gen a] -> Gen a
oneof
      [ TxValidityLowerBound Era -> Gen (TxValidityLowerBound Era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxValidityLowerBound Era
forall era. TxValidityLowerBound era
TxValidityNoLowerBound
      , AllegraEraOnwards Era -> SlotNo -> TxValidityLowerBound Era
forall era.
AllegraEraOnwards era -> SlotNo -> TxValidityLowerBound era
TxValidityLowerBound AllegraEraOnwards Era
forall era. IsAllegraBasedEra era => AllegraEraOnwards era
allegraBasedEra (SlotNo -> TxValidityLowerBound Era)
-> (Word64 -> SlotNo) -> Word64 -> TxValidityLowerBound Era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> SlotNo
SlotNo (Word64 -> TxValidityLowerBound Era)
-> Gen Word64 -> Gen (TxValidityLowerBound Era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
forall a. Arbitrary a => Gen a
arbitrary
      ]

instance Arbitrary (TxValidityUpperBound Era) where
  arbitrary :: Gen (TxValidityUpperBound Era)
arbitrary = ShelleyBasedEra Era -> Maybe SlotNo -> TxValidityUpperBound Era
forall era.
ShelleyBasedEra era -> Maybe SlotNo -> TxValidityUpperBound era
TxValidityUpperBound (forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra @Era) (Maybe SlotNo -> TxValidityUpperBound Era)
-> (Maybe Word64 -> Maybe SlotNo)
-> Maybe Word64
-> TxValidityUpperBound Era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> SlotNo) -> Maybe Word64 -> Maybe SlotNo
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> SlotNo
SlotNo (Maybe Word64 -> TxValidityUpperBound Era)
-> Gen (Maybe Word64) -> Gen (TxValidityUpperBound Era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Maybe Word64)
forall a. Arbitrary a => Gen a
arbitrary