{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Constrained.Classes where

import Cardano.Ledger.Alonzo.Scripts (AsIx, AsIxItem, PlutusPurpose)
import Cardano.Ledger.Alonzo.TxOut (AlonzoTxOut (..))
import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..))
import Cardano.Ledger.Babbage.TxOut (BabbageTxOut (..))
import Cardano.Ledger.BaseTypes (EpochNo (..), ProtVer (..), SlotNo (..))
import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..))
import Cardano.Ledger.Conway.Governance hiding (GovState)
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..))
import Cardano.Ledger.Plutus (ExUnits (..))
import Cardano.Ledger.PoolDistr (IndividualPoolStake (..))
import Cardano.Ledger.Shelley.Governance (FuturePParams (..), ShelleyGovState (..))
import qualified Cardano.Ledger.Shelley.Governance as Gov
import Cardano.Ledger.Shelley.PParams (pvCanFollow)
import qualified Cardano.Ledger.Shelley.PParams as PP (ProposedPPUpdates (..))
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.TxIn (TxIn)
import Cardano.Ledger.UTxO (ScriptsNeeded, UTxO (..))
import Cardano.Ledger.Val (Val (coin, modifyCoin, (<+>)))
import Data.Default (Default (def))
import qualified Data.List as List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Typeable
import Data.Word (Word64)
import GHC.Real (denominator, numerator, (%))
import Lens.Micro
import Numeric.Natural (Natural)
import Test.Cardano.Ledger.Alonzo.Arbitrary ()
import Test.Cardano.Ledger.Babbage.Arbitrary ()
import Test.Cardano.Ledger.Constrained.Combinators (errorMess)
import Test.Cardano.Ledger.Constrained.Monad (
  LiftT (..),
  Typed (..),
  failT,
 )
import Test.Cardano.Ledger.Constrained.Pairing (pair, unpair)
import Test.Cardano.Ledger.Constrained.Scripts (genCoreScript)
import Test.Cardano.Ledger.Constrained.Size (
  Size (..),
  genFromIntRange,
  genFromNonNegIntRange,
  genFromSize,
  negateSize,
  sepsP,
 )
import Test.Cardano.Ledger.Conway.Arbitrary ()
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Generic.Functions (protocolVersion)
import Test.Cardano.Ledger.Generic.GenState (plutusPurposeTags)
import Test.Cardano.Ledger.Generic.PrettyCore (
  PDoc,
  PrettyA (..),
  pcPParams,
  pcScript,
  pcScriptsNeeded,
  pcTx,
  pcTxBody,
  pcTxCert,
  pcTxOut,
  pcVal,
  pcWitnesses,
  ppPlutusPurposeAsIx,
  ppPlutusPurposeAsIxItem,
  ppProposedPPUpdates,
  ppString,
 )
import Test.Cardano.Ledger.Generic.Proof (
  GoodCrypto,
  Proof (..),
  Reflect (..),
  unReflect,
 )
import Test.Cardano.Ledger.Shelley.Constants (defaultConstants)
import Test.Cardano.Ledger.Shelley.Generator.Update (genShelleyPParamsUpdate)
import Test.QuickCheck (
  Arbitrary (..),
  Gen,
  choose,
  chooseInt,
  elements,
  frequency,
  oneof,
  shuffle,
  suchThat,
  vectorOf,
 )

-- =====================================================================
-- Helper functions

gauss :: Floating a => a -> a -> a -> a
gauss :: forall a. Floating a => a -> a -> a -> a
gauss a
mean a
stdev a
x = (a
1 forall a. Fractional a => a -> a -> a
/ (a
stdev forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
sqrt (a
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi))) forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
exp (forall a. Num a => a -> a
negate ((a
1 forall a. Fractional a => a -> a -> a
/ a
2) forall a. Num a => a -> a -> a
* ((a
x forall a. Num a => a -> a -> a
- a
mean) forall a. Fractional a => a -> a -> a
/ a
stdev) forall a. Floating a => a -> a -> a
** a
2))

-- | The Adds class
--
-- Some methods of 'Adds' like 'minus', 'genAdds', 'partition' and 'fromI' are partial.
-- That is they might not be defined on all inputs. The `[string]` is a representation
-- of a stack trace, that describes what the sytem was doing, so if the function is partial
-- it can raise an appropriate error. The function
-- Test.Cardano.Ledger.Constrained.Combinators(errorMess) is used to raise an error
-- and properly report the stack trace.
class (Eq x, Show x, Typeable x) => Adds x where
  -- | Additive identity
  zero :: x

  -- | Just the unit of increment.
  one :: x

  -- | Add two of these
  add :: x -> x -> x

  -- | Subtract one from another
  minus :: [String] -> x -> x -> x

  -- | Increase by unit of increment
  increaseBy1 :: Int -> Int
  increaseBy1 Int
n = forall x. Adds x => x -> x -> x
add Int
n forall x. Adds x => x
one

  -- | Decrease by unit of increment
  decreaseBy1 :: Int -> Int
  decreaseBy1 Int
n = forall x. Adds x => [String] -> x -> x -> x
minus [String
"decreaseBy1"] Int
n forall x. Adds x => x
one

  -- | Generate a list of values
  -- @ partition 7 trace 4 235 @ generate a list of length 4 that
  -- adds up t0 235, where the smallest number is >= 7
  partition :: x -> [String] -> Int -> x -> Gen [x]

  -- | Generate a single value
  -- @ genAdds trace spec @ generates an 'x' in the range specified by 'spec'
  genAdds :: [String] -> AddsSpec x -> Gen x

  -- | Analogous to fromIntegral, translate an Int to an appropriate 'x'
  fromI :: [String] -> Int -> x

  -- | translate an 'x' Int to an appropriate Int
  toI :: x -> Int

  -- | Used in testing to get appropriate 'smallest' values to test
  -- 'partition smallest trace count total'. The generator should choose from
  -- several values appropriate for the type 'x'. choose [0,1,2] would be
  -- appropriate for Natural, since there are no negative Natural numbers.
  genSmall :: Gen Int

  runOrdCondition :: OrdCond -> x -> x -> Bool

  supportsNegative :: x -> Bool

  smallerOf :: x -> x -> x

sumAdds :: (Foldable t, Adds c) => t c -> c
sumAdds :: forall (t :: * -> *) c. (Foldable t, Adds c) => t c -> c
sumAdds = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' forall x. Adds x => x -> x -> x
add forall x. Adds x => x
zero

lensAdds :: (Foldable t, Adds b) => Lens' a b -> t a -> b
lensAdds :: forall (t :: * -> *) b a.
(Foldable t, Adds b) =>
Lens' a b -> t a -> b
lensAdds Lens' a b
l = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' b -> a -> b
accum forall x. Adds x => x
zero
  where
    accum :: b -> a -> b
accum b
ans a
x = forall x. Adds x => x -> x -> x
add b
ans (a
x forall s a. s -> Getting a s a -> a
^. Lens' a b
l)

genFromAddsSpec :: [String] -> AddsSpec c -> Gen Int
genFromAddsSpec :: forall c. [String] -> AddsSpec c -> Gen Int
genFromAddsSpec [String]
_ AddsSpec c
AddsSpecAny = Size -> Gen Int
genFromIntRange Size
SzAny
genFromAddsSpec [String]
_ (AddsSpecSize String
_ Size
size) = Size -> Gen Int
genFromIntRange Size
size
genFromAddsSpec [String]
msgs (AddsSpecNever [String]
_) = forall a. HasCallStack => String -> [String] -> a
errorMess String
"genFromAddsSpec applied to AddsSpecNever" [String]
msgs

genFromNonNegAddsSpec :: [String] -> AddsSpec c -> Gen Int
genFromNonNegAddsSpec :: forall c. [String] -> AddsSpec c -> Gen Int
genFromNonNegAddsSpec [String]
_ AddsSpec c
AddsSpecAny = Size -> Gen Int
genFromNonNegIntRange Size
SzAny
genFromNonNegAddsSpec [String]
_ (AddsSpecSize String
_ Size
size) = Size -> Gen Int
genFromNonNegIntRange Size
size
genFromNonNegAddsSpec [String]
msgs (AddsSpecNever [String]
_) = forall a. HasCallStack => String -> [String] -> a
errorMess String
"genFromAddsSpec applied to AddsSpecNever" [String]
msgs

-- ================
-- Adds instances

instance Adds ExUnits where
  zero :: ExUnits
zero = Natural -> Natural -> ExUnits
ExUnits Natural
0 Natural
0
  one :: ExUnits
one = Natural -> Natural -> ExUnits
ExUnits Natural
1 Natural
1
  add :: ExUnits -> ExUnits -> ExUnits
add (ExUnits Natural
a Natural
b) (ExUnits Natural
c Natural
d) = Natural -> Natural -> ExUnits
ExUnits (Natural
a forall a. Num a => a -> a -> a
+ Natural
c) (Natural
b forall a. Num a => a -> a -> a
+ Natural
d)
  minus :: [String] -> ExUnits -> ExUnits -> ExUnits
minus [String]
msgs (ExUnits Natural
a Natural
b) (ExUnits Natural
c Natural
d) =
    Natural -> Natural -> ExUnits
ExUnits
      (forall x. Adds x => [String] -> x -> x -> x
minus (String
"Ex memory" forall a. a -> [a] -> [a]
: [String]
msgs) Natural
a Natural
c)
      (forall x. Adds x => [String] -> x -> x -> x
minus (String
"Ex steps" forall a. a -> [a] -> [a]
: [String]
msgs) Natural
b Natural
d)
  increaseBy1 :: Int -> Int
increaseBy1 Int
n = let (Int
i, Int
j) = Int -> (Int, Int)
unpair Int
n in Int -> Int -> Int
pair (forall x. Adds x => Int -> Int
increaseBy1 @Natural Int
i) (forall x. Adds x => Int -> Int
increaseBy1 @Natural Int
j)
  decreaseBy1 :: Int -> Int
decreaseBy1 Int
n = let (Int
i, Int
j) = Int -> (Int, Int)
unpair Int
n in Int -> Int -> Int
pair (forall x. Adds x => Int -> Int
decreaseBy1 @Natural Int
i) (forall x. Adds x => Int -> Int
decreaseBy1 @Natural Int
j)
  partition :: ExUnits -> [String] -> Int -> ExUnits -> Gen [ExUnits]
partition (ExUnits Natural
smallestmemory Natural
smalleststeps) [String]
msgs Int
count (ExUnits Natural
memory Natural
steps) = do
    [Natural]
memG <- forall x. Adds x => x -> [String] -> Int -> x -> Gen [x]
partition Natural
smallestmemory (String
"Ex memory" forall a. a -> [a] -> [a]
: [String]
msgs) Int
count Natural
memory
    [Natural]
stepsG <- forall x. Adds x => x -> [String] -> Int -> x -> Gen [x]
partition Natural
smalleststeps (String
"Ex steps" forall a. a -> [a] -> [a]
: [String]
msgs) Int
count Natural
steps
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Natural -> Natural -> ExUnits
ExUnits [Natural]
memG [Natural]
stepsG)
  genAdds :: [String] -> AddsSpec ExUnits -> Gen ExUnits
genAdds [String]
msgs = \case
    AddsSpec ExUnits
AddsSpecAny -> forall a. HasCallStack => String -> [String] -> a
errorMess String
"AddsSpecAny" [String]
ms
    AddsSpecNever [String]
msgs' -> forall a. HasCallStack => String -> [String] -> a
errorMess String
"AddsSpecNever" forall a b. (a -> b) -> a -> b
$ [String]
ms forall a. Semigroup a => a -> a -> a
<> [String]
msgs'
    AddsSpecSize String
msg Size
sz -> case Size
sz of
      SzLeast Int
n ->
        let (Int
i, Int
j) = Int -> (Int, Int)
unpair Int
n
         in do
              Natural
ig <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Size -> Gen Int
genFromSize (Int -> Size
SzLeast Int
i)
              Natural
jg <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Size -> Gen Int
genFromSize (Int -> Size
SzLeast Int
j)
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> ExUnits
ExUnits Natural
ig Natural
jg
      SzMost Int
n ->
        let (Int
i, Int
j) = Int -> (Int, Int)
unpair Int
n
         in do
              Natural
ig <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Size -> Gen Int
genFromSize (Int -> Size
SzMost Int
i)
              Natural
jg <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Size -> Gen Int
genFromSize (Int -> Size
SzMost Int
j)
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> ExUnits
ExUnits Natural
ig Natural
jg
      SzExact Int
n ->
        let (Int
i, Int
j) = Int -> (Int, Int)
unpair Int
n
         in do
              Natural
ig <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Size -> Gen Int
genFromSize (Int -> Size
SzExact Int
i)
              Natural
jg <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Size -> Gen Int
genFromSize (Int -> Size
SzExact Int
j)
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> ExUnits
ExUnits Natural
ig Natural
jg
      SzNever [String]
m -> forall a. HasCallStack => String -> [String] -> a
errorMess String
"AddsSpecSize SzNever" forall a b. (a -> b) -> a -> b
$ [String]
ms forall a. Semigroup a => a -> a -> a
<> [String
msg] forall a. Semigroup a => a -> a -> a
<> [String]
m
      Size
_ -> forall a. HasCallStack => String -> [String] -> a
errorMess String
"AddsSpecSize SzAny or SzRng" forall a b. (a -> b) -> a -> b
$ [String]
ms forall a. Semigroup a => a -> a -> a
<> [String
msg]
    where
      ms :: [String]
ms = [String]
msgs forall a. [a] -> [a] -> [a]
++ [String
"genAdds ExUnits"]
  fromI :: [String] -> Int -> ExUnits
fromI [String]
msgs Int
n = Natural -> Natural -> ExUnits
ExUnits Natural
mem Natural
step
    where
      (Int
memInt, Int
stepInt) = Int -> (Int, Int)
unpair Int
n
      mem :: Natural
mem = forall x. Adds x => [String] -> Int -> x
fromI (String
"Ex memory" forall a. a -> [a] -> [a]
: [String]
msgs) Int
memInt
      step :: Natural
step = forall x. Adds x => [String] -> Int -> x
fromI (String
"Ex steps" forall a. a -> [a] -> [a]
: [String]
msgs) Int
stepInt
  toI :: ExUnits -> Int
toI (ExUnits Natural
mem Natural
step) = Int -> Int -> Int
pair (forall x. Adds x => x -> Int
toI Natural
mem) (forall x. Adds x => x -> Int
toI Natural
step)
  supportsNegative :: ExUnits -> Bool
supportsNegative ExUnits
_ = Bool
False
  genSmall :: Gen Int
genSmall = forall a. HasCallStack => [Gen a] -> Gen a
oneof [forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall x. Adds x => x -> Int
toI (Natural -> Natural -> ExUnits
ExUnits Natural
1 Natural
1), forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall x. Adds x => x -> Int
toI (Natural -> Natural -> ExUnits
ExUnits Natural
2 Natural
2), forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall x. Adds x => x -> Int
toI (Natural -> Natural -> ExUnits
ExUnits Natural
3 Natural
1)]

  -- Some ExUnits are incomparable: i.e. x=(ExUnits 5 7) and y=(ExUnits 8 3)
  -- neither x<y  or y<x is true.
  runOrdCondition :: OrdCond -> ExUnits -> ExUnits -> Bool
runOrdCondition OrdCond
EQL (ExUnits Natural
a Natural
b) (ExUnits Natural
c Natural
d) = Natural
a forall a. Eq a => a -> a -> Bool
== Natural
c Bool -> Bool -> Bool
&& Natural
b forall a. Eq a => a -> a -> Bool
== Natural
d
  runOrdCondition OrdCond
LTH (ExUnits Natural
a Natural
b) (ExUnits Natural
c Natural
d) = Natural
a forall a. Ord a => a -> a -> Bool
< Natural
c Bool -> Bool -> Bool
&& Natural
b forall a. Ord a => a -> a -> Bool
< Natural
d
  runOrdCondition OrdCond
LTE (ExUnits Natural
a Natural
b) (ExUnits Natural
m Natural
n) = forall x. Adds x => OrdCond -> x -> x -> Bool
runOrdCondition OrdCond
LTE Natural
a Natural
m Bool -> Bool -> Bool
&& forall x. Adds x => OrdCond -> x -> x -> Bool
runOrdCondition OrdCond
LTE Natural
b Natural
n
  runOrdCondition OrdCond
GTH (ExUnits Natural
a Natural
b) (ExUnits Natural
c Natural
d) = Natural
a forall a. Ord a => a -> a -> Bool
> Natural
c Bool -> Bool -> Bool
&& Natural
b forall a. Ord a => a -> a -> Bool
> Natural
d
  runOrdCondition OrdCond
GTE (ExUnits Natural
a Natural
b) (ExUnits Natural
m Natural
n) = forall x. Adds x => OrdCond -> x -> x -> Bool
runOrdCondition OrdCond
GTE Natural
a Natural
m Bool -> Bool -> Bool
&& forall x. Adds x => OrdCond -> x -> x -> Bool
runOrdCondition OrdCond
GTE Natural
b Natural
n
  smallerOf :: ExUnits -> ExUnits -> ExUnits
smallerOf ExUnits
x ExUnits
y
    | forall x. Adds x => OrdCond -> x -> x -> Bool
runOrdCondition OrdCond
LTE ExUnits
x ExUnits
y = ExUnits
x
    | forall x. Adds x => OrdCond -> x -> x -> Bool
runOrdCondition OrdCond
GTE ExUnits
x ExUnits
y = ExUnits
y
    | Bool
otherwise = forall a. HasCallStack => String -> [String] -> a
errorMess String
"ExUnits are incomparable, can't choose the 'smallerOf'" [forall a. Show a => a -> String
show ExUnits
x, forall a. Show a => a -> String
show ExUnits
y]

-- ================
instance Adds Word64 where
  zero :: Word64
zero = Word64
0
  one :: Word64
one = Word64
1
  add :: Word64 -> Word64 -> Word64
add = forall a. Num a => a -> a -> a
(+)
  minus :: [String] -> Word64 -> Word64 -> Word64
minus [String]
msg Word64
x Word64
y =
    if Word64
x forall a. Ord a => a -> a -> Bool
< Word64
y
      then forall a. HasCallStack => String -> [String] -> a
errorMess (String
"(minus @Word64 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word64
x forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word64
y forall a. [a] -> [a] -> [a]
++ String
") is not possible") [String]
msg
      else Word64
x forall a. Num a => a -> a -> a
- Word64
y
  partition :: Word64 -> [String] -> Int -> Word64 -> Gen [Word64]
partition = Word64 -> [String] -> Int -> Word64 -> Gen [Word64]
partitionWord64
  genAdds :: [String] -> AddsSpec Word64 -> Gen Word64
genAdds [String]
msgs AddsSpec Word64
spec = forall x. Adds x => [String] -> Int -> x
fromI [String]
ms forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. [String] -> AddsSpec c -> Gen Int
genFromNonNegAddsSpec [String]
ms AddsSpec Word64
spec
    where
      ms :: [String]
ms = [String]
msgs forall a. [a] -> [a] -> [a]
++ [String
"genAdds Word64"]
  fromI :: [String] -> Int -> Word64
fromI [String]
_ Int
m | Int
m forall a. Ord a => a -> a -> Bool
>= Int
0 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m
  fromI [String]
msgs Int
m = forall a. HasCallStack => String -> [String] -> a
errorMess (String
"can't convert " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
m forall a. [a] -> [a] -> [a]
++ String
" into a Word64.") [String]
msgs
  toI :: Word64 -> Int
toI = forall a b. (Integral a, Num b) => a -> b
fromIntegral
  genSmall :: Gen Int
genSmall = forall a. HasCallStack => [a] -> Gen a
elements [Int
0, Int
1, Int
2]
  runOrdCondition :: OrdCond -> Word64 -> Word64 -> Bool
runOrdCondition = forall c. Ord c => OrdCond -> c -> c -> Bool
runOrdCond
  supportsNegative :: Word64 -> Bool
supportsNegative Word64
_ = Bool
False
  smallerOf :: Word64 -> Word64 -> Word64
smallerOf = forall a. Ord a => a -> a -> a
min

instance Adds Int where
  zero :: Int
zero = Int
0
  one :: Int
one = Int
1
  add :: Int -> Int -> Int
add = forall a. Num a => a -> a -> a
(+)
  minus :: [String] -> Int -> Int -> Int
minus [String]
_ = (-)
  partition :: Int -> [String] -> Int -> Int -> Gen [Int]
partition = Int -> [String] -> Int -> Int -> Gen [Int]
partitionInt
  genAdds :: [String] -> AddsSpec Int -> Gen Int
genAdds [String]
msgs AddsSpec Int
spec = forall x. Adds x => [String] -> Int -> x
fromI [String]
ms forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. [String] -> AddsSpec c -> Gen Int
genFromAddsSpec [String]
ms AddsSpec Int
spec
    where
      ms :: [String]
ms = [String]
msgs forall a. [a] -> [a] -> [a]
++ [String
"genAdds Int"]
  fromI :: [String] -> Int -> Int
fromI [String]
_ Int
n = Int
n
  toI :: Int -> Int
toI Int
n = Int
n
  genSmall :: Gen Int
genSmall = forall a. HasCallStack => [a] -> Gen a
elements [-Int
2, -Int
1, Int
0, Int
1, Int
2]
  runOrdCondition :: OrdCond -> Int -> Int -> Bool
runOrdCondition = forall c. Ord c => OrdCond -> c -> c -> Bool
runOrdCond
  supportsNegative :: Int -> Bool
supportsNegative Int
_ = Bool
True
  smallerOf :: Int -> Int -> Int
smallerOf = forall a. Ord a => a -> a -> a
min

instance Adds Natural where
  zero :: Natural
zero = Natural
0
  one :: Natural
one = Natural
1
  add :: Natural -> Natural -> Natural
add = forall a. Num a => a -> a -> a
(+)
  minus :: [String] -> Natural -> Natural -> Natural
minus [String]
msg Natural
x Natural
y =
    if Natural
x forall a. Ord a => a -> a -> Bool
< Natural
y
      then forall a. HasCallStack => String -> [String] -> a
errorMess (String
"(minus @Natural " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Natural
x forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Natural
y forall a. [a] -> [a] -> [a]
++ String
") is not possible") [String]
msg
      else Natural
x forall a. Num a => a -> a -> a
- Natural
y
  partition :: Natural -> [String] -> Int -> Natural -> Gen [Natural]
partition = Natural -> [String] -> Int -> Natural -> Gen [Natural]
partitionNatural
  genAdds :: [String] -> AddsSpec Natural -> Gen Natural
genAdds [String]
msgs AddsSpec Natural
spec = forall x. Adds x => [String] -> Int -> x
fromI [String]
ms forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. [String] -> AddsSpec c -> Gen Int
genFromNonNegAddsSpec [String]
ms AddsSpec Natural
spec
    where
      ms :: [String]
ms = [String]
msgs forall a. [a] -> [a] -> [a]
++ [String
"genAdds Natural"]
  fromI :: [String] -> Int -> Natural
fromI [String]
_ Int
n | Int
n forall a. Ord a => a -> a -> Bool
>= Int
0 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
  fromI [String]
msgs Int
m = forall a. HasCallStack => String -> [String] -> a
errorMess (String
"can't convert " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
m forall a. [a] -> [a] -> [a]
++ String
" into a Natural.") [String]
msgs
  toI :: Natural -> Int
toI = forall a b. (Integral a, Num b) => a -> b
fromIntegral
  genSmall :: Gen Int
genSmall = forall a. HasCallStack => [a] -> Gen a
elements [Int
0, Int
1, Int
2]
  runOrdCondition :: OrdCond -> Natural -> Natural -> Bool
runOrdCondition = forall c. Ord c => OrdCond -> c -> c -> Bool
runOrdCond
  supportsNegative :: Natural -> Bool
supportsNegative Natural
_ = Bool
False
  smallerOf :: Natural -> Natural -> Natural
smallerOf = forall a. Ord a => a -> a -> a
min

instance Adds Rational where
  zero :: Rational
zero = Rational
0
  one :: Rational
one = Rational
1
  add :: Rational -> Rational -> Rational
add = forall a. Num a => a -> a -> a
(+)
  minus :: [String] -> Rational -> Rational -> Rational
minus [String]
_ = (-)
  partition :: Rational -> [String] -> Int -> Rational -> Gen [Rational]
partition = Rational -> [String] -> Int -> Rational -> Gen [Rational]
partitionRational
  genAdds :: [String] -> AddsSpec Rational -> Gen Rational
genAdds [String]
msgs AddsSpec Rational
spec = forall x. Adds x => [String] -> Int -> x
fromI [String]
ms forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. [String] -> AddsSpec c -> Gen Int
genFromAddsSpec [String]
ms AddsSpec Rational
spec
    where
      ms :: [String]
ms = [String]
msgs forall a. [a] -> [a] -> [a]
++ [String
"genAdds Rational"]
  fromI :: [String] -> Int -> Rational
fromI [String]
_ Int
n = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n forall a. Integral a => a -> a -> a
`div` Integer
1000) forall a. Integral a => a -> a -> Ratio a
% Integer
1
  toI :: Rational -> Int
toI Rational
r = forall a b. (RealFrac a, Integral b) => a -> b
round (Rational
r forall a. Num a => a -> a -> a
* Rational
1000)
  genSmall :: Gen Int
genSmall = forall a. HasCallStack => [a] -> Gen a
elements [Int
0, Int
1]
  runOrdCondition :: OrdCond -> Rational -> Rational -> Bool
runOrdCondition = forall c. Ord c => OrdCond -> c -> c -> Bool
runOrdCond
  supportsNegative :: Rational -> Bool
supportsNegative Rational
_ = Bool
True
  smallerOf :: Rational -> Rational -> Rational
smallerOf = forall a. Ord a => a -> a -> a
min

instance Adds Coin where
  zero :: Coin
zero = Integer -> Coin
Coin Integer
0
  one :: Coin
one = Integer -> Coin
Coin Integer
1
  add :: Coin -> Coin -> Coin
add = forall t. Val t => t -> t -> t
(<+>)
  minus :: [String] -> Coin -> Coin -> Coin
minus [String]
msg (Coin Integer
n) (Coin Integer
m) =
    if Integer
n forall a. Ord a => a -> a -> Bool
< Integer
m
      then forall a. HasCallStack => String -> [String] -> a
errorMess (String
"(minus @Coin " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
n forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
m forall a. [a] -> [a] -> [a]
++ String
") is not possible") [String]
msg
      else Integer -> Coin
Coin (Integer
n forall a. Num a => a -> a -> a
- Integer
m)
  partition :: Coin -> [String] -> Int -> Coin -> Gen [Coin]
partition = Coin -> [String] -> Int -> Coin -> Gen [Coin]
partitionCoin
  genAdds :: [String] -> AddsSpec Coin -> Gen Coin
genAdds [String]
msgs AddsSpec Coin
spec = forall x. Adds x => [String] -> Int -> x
fromI [String]
ms forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. [String] -> AddsSpec c -> Gen Int
genFromNonNegAddsSpec [String]
ms AddsSpec Coin
spec
    where
      ms :: [String]
ms = [String]
msgs forall a. [a] -> [a] -> [a]
++ [String
"genAdds Coin"]
  fromI :: [String] -> Int -> Coin
fromI [String]
_ Int
n | Int
n forall a. Ord a => a -> a -> Bool
>= Int
0 = Integer -> Coin
Coin (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  fromI [String]
msgs Int
m = forall a. HasCallStack => String -> [String] -> a
errorMess (String
"can't convert " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
m forall a. [a] -> [a] -> [a]
++ String
" into a Coin.") [String]
msgs
  toI :: Coin -> Int
toI (Coin Integer
n) = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n
  genSmall :: Gen Int
genSmall = forall a. HasCallStack => [a] -> Gen a
elements [Int
0, Int
1, Int
2]
  runOrdCondition :: OrdCond -> Coin -> Coin -> Bool
runOrdCondition = forall c. Ord c => OrdCond -> c -> c -> Bool
runOrdCond
  supportsNegative :: Coin -> Bool
supportsNegative Coin
_ = Bool
False
  smallerOf :: Coin -> Coin -> Coin
smallerOf = forall a. Ord a => a -> a -> a
min

instance Adds DeltaCoin where
  zero :: DeltaCoin
zero = Integer -> DeltaCoin
DeltaCoin Integer
0
  one :: DeltaCoin
one = Integer -> DeltaCoin
DeltaCoin Integer
1
  add :: DeltaCoin -> DeltaCoin -> DeltaCoin
add = forall t. Val t => t -> t -> t
(<+>)
  minus :: [String] -> DeltaCoin -> DeltaCoin -> DeltaCoin
minus [String]
_ (DeltaCoin Integer
n) (DeltaCoin Integer
m) = Integer -> DeltaCoin
DeltaCoin (Integer
n forall a. Num a => a -> a -> a
- Integer
m)
  partition :: DeltaCoin -> [String] -> Int -> DeltaCoin -> Gen [DeltaCoin]
partition = DeltaCoin -> [String] -> Int -> DeltaCoin -> Gen [DeltaCoin]
partitionDeltaCoin
  genAdds :: [String] -> AddsSpec DeltaCoin -> Gen DeltaCoin
genAdds [String]
msgs AddsSpec DeltaCoin
spec = forall x. Adds x => [String] -> Int -> x
fromI [String]
ms forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. [String] -> AddsSpec c -> Gen Int
genFromAddsSpec [String]
ms AddsSpec DeltaCoin
spec
    where
      ms :: [String]
ms = [String]
msgs forall a. [a] -> [a] -> [a]
++ [String
"genAdds DeltaCoin"]
  fromI :: [String] -> Int -> DeltaCoin
fromI [String]
_ Int
n = Integer -> DeltaCoin
DeltaCoin (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  toI :: DeltaCoin -> Int
toI (DeltaCoin Integer
n) = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n
  genSmall :: Gen Int
genSmall = forall a. HasCallStack => [a] -> Gen a
elements [-Int
2, Int
0, Int
1, Int
2]
  runOrdCondition :: OrdCond -> DeltaCoin -> DeltaCoin -> Bool
runOrdCondition = forall c. Ord c => OrdCond -> c -> c -> Bool
runOrdCond
  supportsNegative :: DeltaCoin -> Bool
supportsNegative DeltaCoin
_ = Bool
True
  smallerOf :: DeltaCoin -> DeltaCoin -> DeltaCoin
smallerOf = forall a. Ord a => a -> a -> a
min

-- ===========================================================================
-- The Sums class, for summing a projected c (where Adds c) from some richer type

class (Show x, Adds x) => Sums t x | t -> x where
  getSum :: t -> x
  genT :: [String] -> x -> Gen t

instance GoodCrypto c => Sums (IndividualPoolStake c) Rational where
  getSum :: IndividualPoolStake c -> Rational
getSum (IndividualPoolStake Rational
r CompactForm Coin
_ VRFVerKeyHash 'StakePoolVRF c
_) = Rational
r
  genT :: [String] -> Rational -> Gen (IndividualPoolStake c)
genT [String]
_ Rational
r =
    -- We use mempty for the individualTotalPoolStake here
    -- but that field is intended to hold the total stake
    -- assigned to the pool. We do not have enough information
    -- here to be able to assign it its correct value.
    forall c.
Rational
-> CompactForm Coin
-> VRFVerKeyHash 'StakePoolVRF c
-> IndividualPoolStake c
IndividualPoolStake Rational
r forall a. Monoid a => a
mempty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary

instance Reflect era => Sums (TxOutF era) Coin where
  getSum :: TxOutF era -> Coin
getSum (TxOutF Proof era
_ TxOut era
txout) = forall t. Val t => t -> Coin
coin (TxOut era
txout forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) (Value era)
valueTxOutL)
  genT :: [String] -> Coin -> Gen (TxOutF era)
genT [String]
_ Coin
cn = forall era. Reflect era => Proof era -> Coin -> Gen (TxOutF era)
genTxOutX forall era. Reflect era => Proof era
reify Coin
cn

genTxOutX :: Reflect era => Proof era -> Coin -> Gen (TxOutF era)
genTxOutX :: forall era. Reflect era => Proof era -> Coin -> Gen (TxOutF era)
genTxOutX Proof era
p Coin
coins = do
  TxOut era
txout <- case Proof era
p of
    Proof era
Shelley -> forall a. Arbitrary a => Gen a
arbitrary
    Proof era
Allegra -> forall a. Arbitrary a => Gen a
arbitrary
    Proof era
Mary -> forall a. Arbitrary a => Gen a
arbitrary
    Proof era
Alonzo -> forall a. Arbitrary a => Gen a
arbitrary
    Proof era
Babbage -> forall a. Arbitrary a => Gen a
arbitrary
    Proof era
Conway -> forall a. Arbitrary a => Gen a
arbitrary
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> TxOut era -> TxOutF era
TxOutF Proof era
p (TxOut era
txout forall a b. a -> (a -> b) -> b
& forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
coins)

instance Reflect era => Sums (ValueF era) Coin where
  getSum :: ValueF era -> Coin
getSum (ValueF Proof era
_ Value era
v) = forall t. Val t => t -> Coin
coin Value era
v
  genT :: [String] -> Coin -> Gen (ValueF era)
genT [String]
_ Coin
cn = forall era. Reflect era => Proof era -> Coin -> Gen (ValueF era)
genValueX forall era. Reflect era => Proof era
reify Coin
cn

genValueX :: Reflect era => Proof era -> Coin -> Gen (ValueF era)
genValueX :: forall era. Reflect era => Proof era -> Coin -> Gen (ValueF era)
genValueX Proof era
proof Coin
cn = do
  ValueF Proof era
p Value era
v <- forall era. Proof era -> Gen (ValueF era)
genValue Proof era
proof
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era. Proof era -> Value era -> ValueF era
ValueF Proof era
p (forall t. Val t => (Coin -> Coin) -> t -> t
modifyCoin (forall a b. a -> b -> a
const Coin
cn) Value era
v))

instance Crypto c => Sums [Reward c] Coin where
  getSum :: [Reward c] -> Coin
getSum [Reward c]
ss = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' forall {c}. Coin -> Reward c -> Coin
accum (Integer -> Coin
Coin Integer
0) [Reward c]
ss
    where
      accum :: Coin -> Reward c -> Coin
accum Coin
ans (Reward RewardType
_ KeyHash 'StakePool c
_ Coin
c) = forall x. Adds x => x -> x -> x
add Coin
ans Coin
c
  genT :: [String] -> Coin -> Gen [Reward c]
genT [String]
_ (Coin Integer
1) = (forall a. a -> [a] -> [a]
: []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall c. Coin -> Reward c -> Reward c
updateRew (Integer -> Coin
Coin Integer
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary)
  genT [String]
msgs (Coin Integer
n) | Integer
n forall a. Ord a => a -> a -> Bool
> Integer
1 = do
    Int
size <- (Int, Int) -> Gen Int
chooseInt (Int
1, forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n)
    [Coin]
cs <- forall x. Adds x => x -> [String] -> Int -> x -> Gen [x]
partition (Integer -> Coin
Coin Integer
1) [String]
msgs Int
size (Integer -> Coin
Coin Integer
n)
    [Reward c]
list <- forall a. Int -> Gen a -> Gen [a]
vectorOf Int
size (forall a. Arbitrary a => Gen a
arbitrary :: Gen (Reward c))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall c. Coin -> Reward c -> Reward c
updateRew @c) [Coin]
cs [Reward c]
list
  genT [String]
msgs Coin
c = forall a. HasCallStack => String -> [String] -> a
errorMess (String
"Coin in genT must be positive: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Coin
c) [String]
msgs

updateRew :: forall c. Coin -> Reward c -> Reward c
updateRew :: forall c. Coin -> Reward c -> Reward c
updateRew Coin
c (Reward RewardType
a KeyHash 'StakePool c
b Coin
_) = forall c. RewardType -> KeyHash 'StakePool c -> Coin -> Reward c
Reward RewardType
a KeyHash 'StakePool c
b Coin
c

-- ===========================================================
-- Sizeable Class

class Show t => Sizeable t where
  -- | extract the 'size' of 't'
  getSize :: t -> Int

instance Sizeable Natural where
  getSize :: Natural -> Int
getSize Natural
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n

instance Sizeable Int where
  getSize :: Int -> Int
getSize Int
n = Int
n

instance Sizeable Word64 where
  getSize :: Word64 -> Int
getSize Word64
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n

instance Sizeable EpochNo where
  getSize :: EpochNo -> Int
getSize (EpochNo Word64
n) = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n

instance Sizeable SlotNo where
  getSize :: SlotNo -> Int
getSize (SlotNo Word64
n) = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n

instance (Show dom, Show rng) => Sizeable (Map dom rng) where
  getSize :: Map dom rng -> Int
getSize Map dom rng
m = forall k a. Map k a -> Int
Map.size Map dom rng
m

instance Show t => Sizeable (Set t) where
  getSize :: Set t -> Int
getSize Set t
m = forall a. Set a -> Int
Set.size Set t
m

instance Show t => Sizeable [t] where
  getSize :: [t] -> Int
getSize [t]
m = forall (t :: * -> *) a. Foldable t => t a -> Int
length [t]
m

instance Sizeable Coin where
  getSize :: Coin -> Int
getSize (Coin Integer
n) = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n

instance Sizeable (MultiAsset c) where
  getSize :: MultiAsset c -> Int
getSize (MultiAsset Map (PolicyID c) (Map AssetName Integer)
m) = forall k a. Map k a -> Int
Map.size Map (PolicyID c) (Map AssetName Integer)
m

instance EraPParams era => Sizeable (Proposals era) where
  getSize :: Proposals era -> Int
getSize = forall era. Proposals era -> Int
proposalsSize

-- ===========================================================
-- The Count class 0,1,2,3,4 ...

class Count t where
  -- | 'canFollow x y', is 'x' an appropriate successor to 'y'
  canFollow :: t -> t -> Bool

  -- | Generate the predecessor, given the successor
  genPred :: t -> Gen t

  -- | Generate the successor, given the predecessor
  genSucc :: t -> Gen t

instance Count Int where
  canFollow :: Int -> Int -> Bool
canFollow Int
x Int
y = Int
x forall a. Num a => a -> a -> a
+ Int
1 forall a. Eq a => a -> a -> Bool
== Int
y
  genPred :: Int -> Gen Int
genPred Int
n | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. HasCallStack => String -> a
error (String
"genPredFromSucc @Int is undefined on " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n)
  genPred Int
n = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n forall a. Num a => a -> a -> a
- Int
1)
  genSucc :: Int -> Gen Int
genSucc Int
n = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n forall a. Num a => a -> a -> a
+ Int
1)

instance Count ProtVer where
  canFollow :: ProtVer -> ProtVer -> Bool
canFollow ProtVer
succX ProtVer
predX = ProtVer -> ProtVer -> Bool
pvCanFollow ProtVer
predX ProtVer
succX
  genPred :: ProtVer -> Gen ProtVer
genPred succX :: ProtVer
succX@(ProtVer Version
n Natural
0)
    | Version
n forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
minBound = forall a. HasCallStack => String -> a
error (String
"genPredFromSucc @ProtVer is undefined on " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ProtVer
succX)
  genPred (ProtVer Version
n Natural
0) = Version -> Natural -> ProtVer
ProtVer (forall a. Enum a => a -> a
pred Version
n) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCallStack => [a] -> Gen a
elements [Natural
0, Natural
1, Natural
2, Natural
3]
  genPred (ProtVer Version
n Natural
m) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Version -> Natural -> ProtVer
ProtVer Version
n (Natural
m forall a. Num a => a -> a -> a
- Natural
1))
  genSucc :: ProtVer -> Gen ProtVer
genSucc (ProtVer Version
n Natural
m) = forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure (Version -> Natural -> ProtVer
ProtVer (forall a. Enum a => a -> a
succ Version
n) Natural
0)), (Int
2, forall (f :: * -> *) a. Applicative f => a -> f a
pure (Version -> Natural -> ProtVer
ProtVer Version
n (Natural
m forall a. Num a => a -> a -> a
+ Natural
1)))]

instance Count EpochNo where
  canFollow :: EpochNo -> EpochNo -> Bool
canFollow EpochNo
predX EpochNo
succX = EpochNo
predX forall a. Num a => a -> a -> a
+ EpochNo
1 forall a. Eq a => a -> a -> Bool
== EpochNo
succX
  genPred :: EpochNo -> Gen EpochNo
genPred EpochNo
n | EpochNo
n forall a. Eq a => a -> a -> Bool
== EpochNo
0 = forall a. HasCallStack => String -> a
error (String
"genPredFromSucc @EpochNo is undefined on " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show EpochNo
n)
  genPred EpochNo
n = forall (f :: * -> *) a. Applicative f => a -> f a
pure (EpochNo
n forall a. Num a => a -> a -> a
- EpochNo
1)
  genSucc :: EpochNo -> Gen EpochNo
genSucc EpochNo
n = forall (f :: * -> *) a. Applicative f => a -> f a
pure (EpochNo
n forall a. Num a => a -> a -> a
+ EpochNo
1)

instance Count SlotNo where
  canFollow :: SlotNo -> SlotNo -> Bool
canFollow SlotNo
predX SlotNo
succX = SlotNo
predX forall a. Num a => a -> a -> a
+ SlotNo
1 forall a. Eq a => a -> a -> Bool
== SlotNo
succX
  genPred :: SlotNo -> Gen SlotNo
genPred SlotNo
n | SlotNo
n forall a. Eq a => a -> a -> Bool
== SlotNo
0 = forall a. HasCallStack => String -> a
error (String
"genPredFromSucc @SlotNo is undefined on " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SlotNo
n)
  genPred SlotNo
n = forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
n forall a. Num a => a -> a -> a
- SlotNo
1)
  genSucc :: SlotNo -> Gen SlotNo
genSucc SlotNo
n = forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
n forall a. Num a => a -> a -> a
+ SlotNo
1)

-- ============================================================================
-- Special accomodation for Type Families
-- ============================================================================

data TxAuxDataF era where
  TxAuxDataF :: Proof era -> TxAuxData era -> TxAuxDataF era

hashTxAuxDataF :: Reflect era => TxAuxDataF era -> AuxiliaryDataHash (EraCrypto era)
hashTxAuxDataF :: forall era.
Reflect era =>
TxAuxDataF era -> AuxiliaryDataHash (EraCrypto era)
hashTxAuxDataF (TxAuxDataF Proof era
_ TxAuxData era
x) = forall era.
EraTxAuxData era =>
TxAuxData era -> AuxiliaryDataHash (EraCrypto era)
hashTxAuxData TxAuxData era
x

unTxAuxData :: TxAuxDataF era -> TxAuxData era
unTxAuxData :: forall era. TxAuxDataF era -> TxAuxData era
unTxAuxData (TxAuxDataF Proof era
_ TxAuxData era
x) = TxAuxData era
x

instance Show (TxAuxDataF era) where
  show :: TxAuxDataF era -> String
show (TxAuxDataF Proof era
p TxAuxData era
x) = forall a. Show a => a -> String
show ((forall era a. (Reflect era => Proof era -> a) -> Proof era -> a
unReflect forall era. Proof era -> TxAuxData era -> PDoc
pcAuxData Proof era
p TxAuxData era
x) :: PDoc)

instance Eq (TxAuxDataF era) where
  (TxAuxDataF Proof era
Shelley TxAuxData era
x) == :: TxAuxDataF era -> TxAuxDataF era -> Bool
== (TxAuxDataF Proof era
Shelley TxAuxData era
y) = TxAuxData era
x forall a. Eq a => a -> a -> Bool
== TxAuxData era
y
  (TxAuxDataF Proof era
Allegra TxAuxData era
x) == (TxAuxDataF Proof era
Allegra TxAuxData era
y) = TxAuxData era
x forall a. Eq a => a -> a -> Bool
== TxAuxData era
y
  (TxAuxDataF Proof era
Mary TxAuxData era
x) == (TxAuxDataF Proof era
Mary TxAuxData era
y) = TxAuxData era
x forall a. Eq a => a -> a -> Bool
== TxAuxData era
y
  (TxAuxDataF Proof era
Alonzo TxAuxData era
x) == (TxAuxDataF Proof era
Alonzo TxAuxData era
y) = TxAuxData era
x forall a. Eq a => a -> a -> Bool
== TxAuxData era
y
  (TxAuxDataF Proof era
Babbage TxAuxData era
x) == (TxAuxDataF Proof era
Babbage TxAuxData era
y) = TxAuxData era
x forall a. Eq a => a -> a -> Bool
== TxAuxData era
y
  (TxAuxDataF Proof era
Conway TxAuxData era
x) == (TxAuxDataF Proof era
Conway TxAuxData era
y) = TxAuxData era
x forall a. Eq a => a -> a -> Bool
== TxAuxData era
y

pcAuxData :: Proof era -> TxAuxData era -> PDoc
pcAuxData :: forall era. Proof era -> TxAuxData era -> PDoc
pcAuxData Proof era
p TxAuxData era
_x = forall a. String -> Doc a
ppString (String
"TxAuxData " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Proof era
p) -- TODO make this more accurate

genTxAuxDataF :: Proof era -> Gen (TxAuxDataF era)
genTxAuxDataF :: forall era. Proof era -> Gen (TxAuxDataF era)
genTxAuxDataF p :: Proof era
p@Proof era
Shelley = forall era. Proof era -> TxAuxData era -> TxAuxDataF era
TxAuxDataF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> (a -> Bool) -> Gen a
suchThat forall a. Arbitrary a => Gen a
arbitrary (forall era. EraTxAuxData era => ProtVer -> TxAuxData era -> Bool
validateTxAuxData (forall era. Proof era -> ProtVer
protocolVersion Proof era
p))
genTxAuxDataF p :: Proof era
p@Proof era
Allegra = forall era. Proof era -> TxAuxData era -> TxAuxDataF era
TxAuxDataF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> (a -> Bool) -> Gen a
suchThat forall a. Arbitrary a => Gen a
arbitrary (forall era. EraTxAuxData era => ProtVer -> TxAuxData era -> Bool
validateTxAuxData (forall era. Proof era -> ProtVer
protocolVersion Proof era
p))
genTxAuxDataF p :: Proof era
p@Proof era
Mary = forall era. Proof era -> TxAuxData era -> TxAuxDataF era
TxAuxDataF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> (a -> Bool) -> Gen a
suchThat forall a. Arbitrary a => Gen a
arbitrary (forall era. EraTxAuxData era => ProtVer -> TxAuxData era -> Bool
validateTxAuxData (forall era. Proof era -> ProtVer
protocolVersion Proof era
p))
genTxAuxDataF p :: Proof era
p@Proof era
Alonzo = forall era. Proof era -> TxAuxData era -> TxAuxDataF era
TxAuxDataF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> (a -> Bool) -> Gen a
suchThat forall a. Arbitrary a => Gen a
arbitrary (forall era. EraTxAuxData era => ProtVer -> TxAuxData era -> Bool
validateTxAuxData (forall era. Proof era -> ProtVer
protocolVersion Proof era
p))
genTxAuxDataF p :: Proof era
p@Proof era
Babbage = forall era. Proof era -> TxAuxData era -> TxAuxDataF era
TxAuxDataF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> (a -> Bool) -> Gen a
suchThat forall a. Arbitrary a => Gen a
arbitrary (forall era. EraTxAuxData era => ProtVer -> TxAuxData era -> Bool
validateTxAuxData (forall era. Proof era -> ProtVer
protocolVersion Proof era
p))
genTxAuxDataF p :: Proof era
p@Proof era
Conway = forall era. Proof era -> TxAuxData era -> TxAuxDataF era
TxAuxDataF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> (a -> Bool) -> Gen a
suchThat forall a. Arbitrary a => Gen a
arbitrary (forall era. EraTxAuxData era => ProtVer -> TxAuxData era -> Bool
validateTxAuxData (forall era. Proof era -> ProtVer
protocolVersion Proof era
p))

-- ==============

data TxF era where
  TxF :: Proof era -> Tx era -> TxF era

unTxF :: TxF era -> Tx era
unTxF :: forall era. TxF era -> Tx era
unTxF (TxF Proof era
_ Tx era
x) = Tx era
x

instance PrettyA (TxF era) where
  prettyA :: TxF era -> PDoc
prettyA (TxF Proof era
p Tx era
tx) = forall era. Proof era -> Tx era -> PDoc
pcTx Proof era
p Tx era
tx

instance PrettyA (PParamsUpdate era) => Show (TxF era) where
  show :: TxF era -> String
show (TxF Proof era
p Tx era
x) = forall a. Show a => a -> String
show ((forall era a. (Reflect era => Proof era -> a) -> Proof era -> a
unReflect forall era. Proof era -> Tx era -> PDoc
pcTx Proof era
p Tx era
x) :: PDoc)

instance Eq (TxF era) where
  (TxF Proof era
Shelley Tx era
x) == :: TxF era -> TxF era -> Bool
== (TxF Proof era
Shelley Tx era
y) = Tx era
x forall a. Eq a => a -> a -> Bool
== Tx era
y
  (TxF Proof era
Allegra Tx era
x) == (TxF Proof era
Allegra Tx era
y) = Tx era
x forall a. Eq a => a -> a -> Bool
== Tx era
y
  (TxF Proof era
Mary Tx era
x) == (TxF Proof era
Mary Tx era
y) = Tx era
x forall a. Eq a => a -> a -> Bool
== Tx era
y
  (TxF Proof era
Alonzo Tx era
x) == (TxF Proof era
Alonzo Tx era
y) = Tx era
x forall a. Eq a => a -> a -> Bool
== Tx era
y
  (TxF Proof era
Babbage Tx era
x) == (TxF Proof era
Babbage Tx era
y) = Tx era
x forall a. Eq a => a -> a -> Bool
== Tx era
y
  (TxF Proof era
Conway Tx era
x) == (TxF Proof era
Conway Tx era
y) = Tx era
x forall a. Eq a => a -> a -> Bool
== Tx era
y

-- ==============

data TxWitsF era where
  TxWitsF :: Proof era -> TxWits era -> TxWitsF era

unTxWitsF :: TxWitsF era -> TxWits era
unTxWitsF :: forall era. TxWitsF era -> TxWits era
unTxWitsF (TxWitsF Proof era
_ TxWits era
x) = TxWits era
x

instance Show (TxWitsF era) where
  show :: TxWitsF era -> String
show (TxWitsF Proof era
p TxWits era
x) = forall a. Show a => a -> String
show ((forall era a. (Reflect era => Proof era -> a) -> Proof era -> a
unReflect forall era. Reflect era => Proof era -> TxWits era -> PDoc
pcWitnesses Proof era
p TxWits era
x) :: PDoc)

instance Eq (TxWitsF era) where
  (TxWitsF Proof era
Shelley TxWits era
x) == :: TxWitsF era -> TxWitsF era -> Bool
== (TxWitsF Proof era
Shelley TxWits era
y) = TxWits era
x forall a. Eq a => a -> a -> Bool
== TxWits era
y
  (TxWitsF Proof era
Allegra TxWits era
x) == (TxWitsF Proof era
Allegra TxWits era
y) = TxWits era
x forall a. Eq a => a -> a -> Bool
== TxWits era
y
  (TxWitsF Proof era
Mary TxWits era
x) == (TxWitsF Proof era
Mary TxWits era
y) = TxWits era
x forall a. Eq a => a -> a -> Bool
== TxWits era
y
  (TxWitsF Proof era
Alonzo TxWits era
x) == (TxWitsF Proof era
Alonzo TxWits era
y) = TxWits era
x forall a. Eq a => a -> a -> Bool
== TxWits era
y
  (TxWitsF Proof era
Babbage TxWits era
x) == (TxWitsF Proof era
Babbage TxWits era
y) = TxWits era
x forall a. Eq a => a -> a -> Bool
== TxWits era
y
  (TxWitsF Proof era
Conway TxWits era
x) == (TxWitsF Proof era
Conway TxWits era
y) = TxWits era
x forall a. Eq a => a -> a -> Bool
== TxWits era
y

-- ==============================

data TxBodyF era where
  TxBodyF :: Proof era -> TxBody era -> TxBodyF era

unTxBodyF :: TxBodyF era -> TxBody era
unTxBodyF :: forall era. TxBodyF era -> TxBody era
unTxBodyF (TxBodyF Proof era
_ TxBody era
x) = TxBody era
x

instance PrettyA (PParamsUpdate era) => Show (TxBodyF era) where
  show :: TxBodyF era -> String
show (TxBodyF Proof era
p TxBody era
x) = forall a. Show a => a -> String
show ((forall era a. (Reflect era => Proof era -> a) -> Proof era -> a
unReflect forall era. Proof era -> TxBody era -> PDoc
pcTxBody Proof era
p TxBody era
x) :: PDoc)

instance PrettyA (TxBodyF era) where
  prettyA :: TxBodyF era -> PDoc
prettyA (TxBodyF Proof era
p TxBody era
x) = forall era a. (Reflect era => Proof era -> a) -> Proof era -> a
unReflect forall era. Proof era -> TxBody era -> PDoc
pcTxBody Proof era
p TxBody era
x

instance Eq (TxBodyF era) where
  (TxBodyF Proof era
Shelley TxBody era
x) == :: TxBodyF era -> TxBodyF era -> Bool
== (TxBodyF Proof era
Shelley TxBody era
y) = TxBody era
x forall a. Eq a => a -> a -> Bool
== TxBody era
y
  (TxBodyF Proof era
Allegra TxBody era
x) == (TxBodyF Proof era
Allegra TxBody era
y) = TxBody era
x forall a. Eq a => a -> a -> Bool
== TxBody era
y
  (TxBodyF Proof era
Mary TxBody era
x) == (TxBodyF Proof era
Mary TxBody era
y) = TxBody era
x forall a. Eq a => a -> a -> Bool
== TxBody era
y
  (TxBodyF Proof era
Alonzo TxBody era
x) == (TxBodyF Proof era
Alonzo TxBody era
y) = TxBody era
x forall a. Eq a => a -> a -> Bool
== TxBody era
y
  (TxBodyF Proof era
Babbage TxBody era
x) == (TxBodyF Proof era
Babbage TxBody era
y) = TxBody era
x forall a. Eq a => a -> a -> Bool
== TxBody era
y
  (TxBodyF Proof era
Conway TxBody era
x) == (TxBodyF Proof era
Conway TxBody era
y) = TxBody era
x forall a. Eq a => a -> a -> Bool
== TxBody era
y

-- ==================
data TxCertF era where
  TxCertF :: Proof era -> TxCert era -> TxCertF era

unTxCertF :: TxCertF era -> TxCert era
unTxCertF :: forall era. TxCertF era -> TxCert era
unTxCertF (TxCertF Proof era
_ TxCert era
x) = TxCert era
x

instance PrettyA (TxCertF era) where
  prettyA :: TxCertF era -> PDoc
prettyA (TxCertF Proof era
p TxCert era
x) = forall era. Proof era -> TxCert era -> PDoc
pcTxCert Proof era
p TxCert era
x

instance Show (TxCertF era) where
  show :: TxCertF era -> String
show (TxCertF Proof era
p TxCert era
x) = forall a. Show a => a -> String
show (forall era. Proof era -> TxCert era -> PDoc
pcTxCert Proof era
p TxCert era
x)

instance Eq (TxCertF era) where
  (TxCertF Proof era
Shelley TxCert era
x) == :: TxCertF era -> TxCertF era -> Bool
== (TxCertF Proof era
Shelley TxCert era
y) = TxCert era
x forall a. Eq a => a -> a -> Bool
== TxCert era
y
  (TxCertF Proof era
Allegra TxCert era
x) == (TxCertF Proof era
Allegra TxCert era
y) = TxCert era
x forall a. Eq a => a -> a -> Bool
== TxCert era
y
  (TxCertF Proof era
Mary TxCert era
x) == (TxCertF Proof era
Mary TxCert era
y) = TxCert era
x forall a. Eq a => a -> a -> Bool
== TxCert era
y
  (TxCertF Proof era
Alonzo TxCert era
x) == (TxCertF Proof era
Alonzo TxCert era
y) = TxCert era
x forall a. Eq a => a -> a -> Bool
== TxCert era
y
  (TxCertF Proof era
Babbage TxCert era
x) == (TxCertF Proof era
Babbage TxCert era
y) = TxCert era
x forall a. Eq a => a -> a -> Bool
== TxCert era
y
  (TxCertF Proof era
Conway TxCert era
x) == (TxCertF Proof era
Conway TxCert era
y) = TxCert era
x forall a. Eq a => a -> a -> Bool
== TxCert era
y

-- ==================
data PlutusPurposeF era where
  PlutusPurposeF :: Proof era -> PlutusPurpose AsIxItem era -> PlutusPurposeF era

unPlutusPurposeF :: PlutusPurposeF era -> PlutusPurpose AsIxItem era
unPlutusPurposeF :: forall era. PlutusPurposeF era -> PlutusPurpose AsIxItem era
unPlutusPurposeF (PlutusPurposeF Proof era
_ PlutusPurpose AsIxItem era
pp) = PlutusPurpose AsIxItem era
pp

data PlutusPointerF era where
  PlutusPointerF :: Proof era -> PlutusPurpose AsIx era -> PlutusPointerF era

unPlutusPointerF :: PlutusPointerF era -> PlutusPurpose AsIx era
unPlutusPointerF :: forall era. PlutusPointerF era -> PlutusPurpose AsIx era
unPlutusPointerF (PlutusPointerF Proof era
_ PlutusPurpose AsIx era
pp) = PlutusPurpose AsIx era
pp

instance Show (PlutusPurposeF era) where
  show :: PlutusPurposeF era -> String
show (PlutusPurposeF Proof era
p PlutusPurpose AsIxItem era
x) = forall era a. (Reflect era => Proof era -> a) -> Proof era -> a
unReflect (\Proof era
_ -> forall a. Show a => a -> String
show (forall era. Reflect era => PlutusPurpose AsIxItem era -> PDoc
ppPlutusPurposeAsIxItem PlutusPurpose AsIxItem era
x)) Proof era
p

instance Show (PlutusPointerF era) where
  show :: PlutusPointerF era -> String
show (PlutusPointerF Proof era
p PlutusPurpose AsIx era
x) = forall era a. (Reflect era => Proof era -> a) -> Proof era -> a
unReflect (\Proof era
_ -> forall a. Show a => a -> String
show (forall era. Reflect era => PlutusPurpose AsIx era -> PDoc
ppPlutusPurposeAsIx PlutusPurpose AsIx era
x)) Proof era
p

instance Eq (PlutusPurposeF era) where
  PlutusPurposeF Proof era
Alonzo PlutusPurpose AsIxItem era
x == :: PlutusPurposeF era -> PlutusPurposeF era -> Bool
== PlutusPurposeF Proof era
Alonzo PlutusPurpose AsIxItem era
y = PlutusPurpose AsIxItem era
x forall a. Eq a => a -> a -> Bool
== PlutusPurpose AsIxItem era
y
  PlutusPurposeF Proof era
Babbage PlutusPurpose AsIxItem era
x == PlutusPurposeF Proof era
Babbage PlutusPurpose AsIxItem era
y = PlutusPurpose AsIxItem era
x forall a. Eq a => a -> a -> Bool
== PlutusPurpose AsIxItem era
y
  PlutusPurposeF Proof era
Conway PlutusPurpose AsIxItem era
x == PlutusPurposeF Proof era
Conway PlutusPurpose AsIxItem era
y = PlutusPurpose AsIxItem era
x forall a. Eq a => a -> a -> Bool
== PlutusPurpose AsIxItem era
y
  PlutusPurposeF era
_ == PlutusPurposeF era
_ = forall a. HasCallStack => String -> a
error String
"Unsupported"

instance Eq (PlutusPointerF era) where
  PlutusPointerF Proof era
Alonzo PlutusPurpose AsIx era
x == :: PlutusPointerF era -> PlutusPointerF era -> Bool
== PlutusPointerF Proof era
Alonzo PlutusPurpose AsIx era
y = PlutusPurpose AsIx era
x forall a. Eq a => a -> a -> Bool
== PlutusPurpose AsIx era
y
  PlutusPointerF Proof era
Babbage PlutusPurpose AsIx era
x == PlutusPointerF Proof era
Babbage PlutusPurpose AsIx era
y = PlutusPurpose AsIx era
x forall a. Eq a => a -> a -> Bool
== PlutusPurpose AsIx era
y
  PlutusPointerF Proof era
Conway PlutusPurpose AsIx era
x == PlutusPointerF Proof era
Conway PlutusPurpose AsIx era
y = PlutusPurpose AsIx era
x forall a. Eq a => a -> a -> Bool
== PlutusPurpose AsIx era
y
  PlutusPointerF era
_ == PlutusPointerF era
_ = forall a. HasCallStack => String -> a
error String
"Unsupported"

instance Ord (PlutusPointerF era) where
  compare :: PlutusPointerF era -> PlutusPointerF era -> Ordering
compare (PlutusPointerF Proof era
Alonzo PlutusPurpose AsIx era
x) (PlutusPointerF Proof era
Alonzo PlutusPurpose AsIx era
y) = forall a. Ord a => a -> a -> Ordering
compare PlutusPurpose AsIx era
x PlutusPurpose AsIx era
y
  compare (PlutusPointerF Proof era
Babbage PlutusPurpose AsIx era
x) (PlutusPointerF Proof era
Babbage PlutusPurpose AsIx era
y) = forall a. Ord a => a -> a -> Ordering
compare PlutusPurpose AsIx era
x PlutusPurpose AsIx era
y
  compare (PlutusPointerF Proof era
Conway PlutusPurpose AsIx era
x) (PlutusPointerF Proof era
Conway PlutusPurpose AsIx era
y) = forall a. Ord a => a -> a -> Ordering
compare PlutusPurpose AsIx era
x PlutusPurpose AsIx era
y
  compare PlutusPointerF era
_ PlutusPointerF era
_ = forall a. HasCallStack => String -> a
error String
"Unsupported"

-- =========
data TxOutF era where
  TxOutF :: Proof era -> TxOut era -> TxOutF era

unTxOut :: TxOutF era -> TxOut era
unTxOut :: forall era. TxOutF era -> TxOut era
unTxOut (TxOutF Proof era
_ TxOut era
x) = TxOut era
x

instance PrettyA (TxOutF era) where
  prettyA :: TxOutF era -> PDoc
prettyA (TxOutF Proof era
p TxOut era
x) = forall era a. (Reflect era => Proof era -> a) -> Proof era -> a
unReflect forall era. Reflect era => Proof era -> TxOut era -> PDoc
pcTxOut Proof era
p TxOut era
x

instance Eq (TxOutF era) where
  TxOutF era
x1 == :: TxOutF era -> TxOutF era -> Bool
== TxOutF era
x2 = forall a. Ord a => a -> a -> Ordering
compare TxOutF era
x1 TxOutF era
x2 forall a. Eq a => a -> a -> Bool
== Ordering
EQ

instance Ord (TxOutF era) where
  compare :: TxOutF era -> TxOutF era -> Ordering
compare (TxOutF Proof era
Shelley (ShelleyTxOut Addr (EraCrypto (ShelleyEra StandardCrypto))
a1 Value (ShelleyEra StandardCrypto)
v1)) (TxOutF Proof era
Shelley (ShelleyTxOut Addr (EraCrypto (ShelleyEra StandardCrypto))
a2 Value (ShelleyEra StandardCrypto)
v2)) =
    forall a. Ord a => a -> a -> Ordering
compare Addr (EraCrypto (ShelleyEra StandardCrypto))
a1 Addr (EraCrypto (ShelleyEra StandardCrypto))
a2 forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare Value (ShelleyEra StandardCrypto)
v1 Value (ShelleyEra StandardCrypto)
v2
  compare (TxOutF Proof era
Allegra (ShelleyTxOut Addr (EraCrypto (AllegraEra StandardCrypto))
a1 Value (AllegraEra StandardCrypto)
v1)) (TxOutF Proof era
Allegra (ShelleyTxOut Addr (EraCrypto (AllegraEra StandardCrypto))
a2 Value (AllegraEra StandardCrypto)
v2)) =
    forall a. Ord a => a -> a -> Ordering
compare (Addr (EraCrypto (AllegraEra StandardCrypto))
a1, Value (AllegraEra StandardCrypto)
v1) (Addr (EraCrypto (AllegraEra StandardCrypto))
a2, Value (AllegraEra StandardCrypto)
v2)
  compare (TxOutF Proof era
Mary (ShelleyTxOut Addr (EraCrypto (MaryEra StandardCrypto))
a1 Value (MaryEra StandardCrypto)
v1)) (TxOutF Proof era
Mary (ShelleyTxOut Addr (EraCrypto (MaryEra StandardCrypto))
a2 Value (MaryEra StandardCrypto)
v2)) =
    forall a. Ord a => a -> a -> Ordering
compare (Addr (EraCrypto (MaryEra StandardCrypto))
a1, Value (MaryEra StandardCrypto)
v1) (Addr (EraCrypto (MaryEra StandardCrypto))
a2, Value (MaryEra StandardCrypto)
v2)
  compare (TxOutF Proof era
Alonzo (AlonzoTxOut Addr (EraCrypto (AlonzoEra StandardCrypto))
a1 Value (AlonzoEra StandardCrypto)
v1 StrictMaybe (DataHash (EraCrypto (AlonzoEra StandardCrypto)))
d1)) (TxOutF Proof era
Alonzo (AlonzoTxOut Addr (EraCrypto (AlonzoEra StandardCrypto))
a2 Value (AlonzoEra StandardCrypto)
v2 StrictMaybe (DataHash (EraCrypto (AlonzoEra StandardCrypto)))
d2)) =
    forall a. Ord a => a -> a -> Ordering
compare (Addr (EraCrypto (AlonzoEra StandardCrypto))
a1, Value (AlonzoEra StandardCrypto)
v1, StrictMaybe (DataHash (EraCrypto (AlonzoEra StandardCrypto)))
d1) (Addr (EraCrypto (AlonzoEra StandardCrypto))
a2, Value (AlonzoEra StandardCrypto)
v2, StrictMaybe (DataHash (EraCrypto (AlonzoEra StandardCrypto)))
d2)
  compare (TxOutF Proof era
Babbage (BabbageTxOut Addr (EraCrypto (BabbageEra StandardCrypto))
a1 Value (BabbageEra StandardCrypto)
v1 Datum (BabbageEra StandardCrypto)
d1 StrictMaybe (Script (BabbageEra StandardCrypto))
x1)) (TxOutF Proof era
Babbage (BabbageTxOut Addr (EraCrypto (BabbageEra StandardCrypto))
a2 Value (BabbageEra StandardCrypto)
v2 Datum (BabbageEra StandardCrypto)
d2 StrictMaybe (Script (BabbageEra StandardCrypto))
x2)) =
    forall a. Ord a => a -> a -> Ordering
compare (Addr (EraCrypto (BabbageEra StandardCrypto))
a1, Value (BabbageEra StandardCrypto)
v1, Datum (BabbageEra StandardCrypto)
d1, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript StrictMaybe (Script (BabbageEra StandardCrypto))
x1) (Addr (EraCrypto (BabbageEra StandardCrypto))
a2, Value (BabbageEra StandardCrypto)
v2, Datum (BabbageEra StandardCrypto)
d2, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript StrictMaybe (Script (BabbageEra StandardCrypto))
x2)
  compare (TxOutF Proof era
Conway (BabbageTxOut Addr (EraCrypto (ConwayEra StandardCrypto))
a1 Value (ConwayEra StandardCrypto)
v1 Datum (ConwayEra StandardCrypto)
d1 StrictMaybe (Script (ConwayEra StandardCrypto))
x1)) (TxOutF Proof era
Conway (BabbageTxOut Addr (EraCrypto (ConwayEra StandardCrypto))
a2 Value (ConwayEra StandardCrypto)
v2 Datum (ConwayEra StandardCrypto)
d2 StrictMaybe (Script (ConwayEra StandardCrypto))
x2)) =
    forall a. Ord a => a -> a -> Ordering
compare (Addr (EraCrypto (ConwayEra StandardCrypto))
a1, Value (ConwayEra StandardCrypto)
v1, Datum (ConwayEra StandardCrypto)
d1, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript StrictMaybe (Script (ConwayEra StandardCrypto))
x1) (Addr (EraCrypto (ConwayEra StandardCrypto))
a2, Value (ConwayEra StandardCrypto)
v2, Datum (ConwayEra StandardCrypto)
d2, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript StrictMaybe (Script (ConwayEra StandardCrypto))
x2)

-- ======
data ValueF era where
  ValueF :: Proof era -> Value era -> ValueF era

instance PrettyA (ValueF era) where
  prettyA :: ValueF era -> PDoc
prettyA (ValueF Proof era
p Value era
v) = forall era. Proof era -> Value era -> PDoc
pcVal Proof era
p Value era
v

unValue :: ValueF era -> Value era
unValue :: forall era. ValueF era -> Value era
unValue (ValueF Proof era
_ Value era
v) = Value era
v

instance Crypto c => Ord (MaryValue c) where
  compare :: MaryValue c -> MaryValue c -> Ordering
compare (MaryValue Coin
c1 MultiAsset c
m1) (MaryValue Coin
c2 MultiAsset c
m2) = forall a. Ord a => a -> a -> Ordering
compare (Coin
c1, MultiAsset c
m1) (Coin
c2, MultiAsset c
m2)

instance Crypto c => Ord (MultiAsset c) where
  compare :: MultiAsset c -> MultiAsset c -> Ordering
compare (MultiAsset Map (PolicyID c) (Map AssetName Integer)
m1) (MultiAsset Map (PolicyID c) (Map AssetName Integer)
m2) = forall a. Ord a => a -> a -> Ordering
compare Map (PolicyID c) (Map AssetName Integer)
m1 Map (PolicyID c) (Map AssetName Integer)
m2

instance Eq (ValueF era) where
  ValueF era
x == :: ValueF era -> ValueF era -> Bool
== ValueF era
y = forall a. Ord a => a -> a -> Ordering
compare ValueF era
x ValueF era
y forall a. Eq a => a -> a -> Bool
== Ordering
EQ

instance Ord (ValueF era) where
  (ValueF Proof era
Shelley Value era
x) compare :: ValueF era -> ValueF era -> Ordering
`compare` (ValueF Proof era
Shelley Value era
y) = forall a. Ord a => a -> a -> Ordering
compare Value era
x Value era
y
  (ValueF Proof era
Allegra Value era
x) `compare` (ValueF Proof era
Allegra Value era
y) = forall a. Ord a => a -> a -> Ordering
compare Value era
x Value era
y
  (ValueF Proof era
Mary (MaryValue Coin
c1 MultiAsset StandardCrypto
m1)) `compare` (ValueF Proof era
Mary (MaryValue Coin
c2 MultiAsset StandardCrypto
m2)) = forall a. Ord a => a -> a -> Ordering
compare Coin
c1 Coin
c2 forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare MultiAsset StandardCrypto
m1 MultiAsset StandardCrypto
m2
  (ValueF Proof era
Alonzo (MaryValue Coin
c1 MultiAsset StandardCrypto
m1)) `compare` (ValueF Proof era
Alonzo (MaryValue Coin
c2 MultiAsset StandardCrypto
m2)) = forall a. Ord a => a -> a -> Ordering
compare Coin
c1 Coin
c2 forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare MultiAsset StandardCrypto
m1 MultiAsset StandardCrypto
m2
  (ValueF Proof era
Babbage (MaryValue Coin
c1 MultiAsset StandardCrypto
m1)) `compare` (ValueF Proof era
Babbage (MaryValue Coin
c2 MultiAsset StandardCrypto
m2)) = forall a. Ord a => a -> a -> Ordering
compare Coin
c1 Coin
c2 forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare MultiAsset StandardCrypto
m1 MultiAsset StandardCrypto
m2
  (ValueF Proof era
Conway (MaryValue Coin
c1 MultiAsset StandardCrypto
m1)) `compare` (ValueF Proof era
Conway (MaryValue Coin
c2 MultiAsset StandardCrypto
m2)) = forall a. Ord a => a -> a -> Ordering
compare Coin
c1 Coin
c2 forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare MultiAsset StandardCrypto
m1 MultiAsset StandardCrypto
m2

-- ======
data PParamsF era where
  PParamsF :: Proof era -> PParams era -> PParamsF era

unPParams :: PParamsF era -> PParams era
unPParams :: forall era. PParamsF era -> PParams era
unPParams (PParamsF Proof era
_ PParams era
p) = PParams era
p

instance PrettyA (PParamsF era) where
  prettyA :: PParamsF era -> PDoc
prettyA (PParamsF Proof era
p PParams era
x) = forall era a. (Reflect era => Proof era -> a) -> Proof era -> a
unReflect forall era. Proof era -> PParams era -> PDoc
pcPParams Proof era
p PParams era
x

instance Eq (PParamsF era) where
  PParamsF Proof era
p1 PParams era
x == :: PParamsF era -> PParamsF era -> Bool
== PParamsF Proof era
_ PParams era
y =
    case Proof era
p1 of
      Proof era
Shelley -> PParams era
x forall a. Eq a => a -> a -> Bool
== PParams era
y
      Proof era
Allegra -> PParams era
x forall a. Eq a => a -> a -> Bool
== PParams era
y
      Proof era
Mary -> PParams era
x forall a. Eq a => a -> a -> Bool
== PParams era
y
      Proof era
Alonzo -> PParams era
x forall a. Eq a => a -> a -> Bool
== PParams era
y
      Proof era
Babbage -> PParams era
x forall a. Eq a => a -> a -> Bool
== PParams era
y
      Proof era
Conway -> PParams era
x forall a. Eq a => a -> a -> Bool
== PParams era
y

pparamsWrapperL :: Lens' (PParamsF era) (PParams era)
pparamsWrapperL :: forall era. Lens' (PParamsF era) (PParams era)
pparamsWrapperL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. PParamsF era -> PParams era
unPParams (\(PParamsF Proof era
p PParams era
_) PParams era
pp -> forall era. Proof era -> PParams era -> PParamsF era
PParamsF Proof era
p PParams era
pp)

-- =======

data PParamsUpdateF era where
  PParamsUpdateF :: Proof era -> PParamsUpdate era -> PParamsUpdateF era

unPParamsUpdate :: PParamsUpdateF era -> PParamsUpdate era
unPParamsUpdate :: forall era. PParamsUpdateF era -> PParamsUpdate era
unPParamsUpdate (PParamsUpdateF Proof era
_ PParamsUpdate era
p) = PParamsUpdate era
p

pparamsUpdateWrapperL :: Lens' (PParamsUpdateF era) (PParamsUpdate era)
pparamsUpdateWrapperL :: forall era. Lens' (PParamsUpdateF era) (PParamsUpdate era)
pparamsUpdateWrapperL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. PParamsUpdateF era -> PParamsUpdate era
unPParamsUpdate (\(PParamsUpdateF Proof era
p PParamsUpdate era
_) PParamsUpdate era
pp -> forall era. Proof era -> PParamsUpdate era -> PParamsUpdateF era
PParamsUpdateF Proof era
p PParamsUpdate era
pp)

-- =====================

data ProposedPPUpdatesF era where
  ProposedPPUpdatesF :: Proof era -> PP.ProposedPPUpdates era -> ProposedPPUpdatesF era

unProposedPPUpdates :: ProposedPPUpdatesF era -> PP.ProposedPPUpdates era
unProposedPPUpdates :: forall era. ProposedPPUpdatesF era -> ProposedPPUpdates era
unProposedPPUpdates (ProposedPPUpdatesF Proof era
_ ProposedPPUpdates era
x) = ProposedPPUpdates era
x

instance PrettyA (PParamsUpdate e) => PrettyA (ProposedPPUpdatesF e) where
  prettyA :: ProposedPPUpdatesF e -> PDoc
prettyA (ProposedPPUpdatesF Proof e
_p ProposedPPUpdates e
x) = forall era.
PrettyA (PParamsUpdate era) =>
ProposedPPUpdates era -> PDoc
ppProposedPPUpdates ProposedPPUpdates e
x

proposedCoreL ::
  Lens' (PP.ProposedPPUpdates era) (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era))
proposedCoreL :: forall era.
Lens'
  (ProposedPPUpdates era)
  (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era))
proposedCoreL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(PP.ProposedPPUpdates Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
m) -> Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
m) (\(PP.ProposedPPUpdates Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
_) Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
m -> forall era.
Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
PP.ProposedPPUpdates Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
m)

proposedWrapperL :: Lens' (ProposedPPUpdatesF era) (PP.ProposedPPUpdates era)
proposedWrapperL :: forall era. Lens' (ProposedPPUpdatesF era) (ProposedPPUpdates era)
proposedWrapperL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ProposedPPUpdatesF era -> ProposedPPUpdates era
unProposedPPUpdates (\(ProposedPPUpdatesF Proof era
p ProposedPPUpdates era
_) ProposedPPUpdates era
pp -> forall era.
Proof era -> ProposedPPUpdates era -> ProposedPPUpdatesF era
ProposedPPUpdatesF Proof era
p ProposedPPUpdates era
pp)

coreMapL ::
  Proof era ->
  Lens'
    (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era))
    (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdateF era))
coreMapL :: forall era.
Proof era
-> Lens'
     (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era))
     (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdateF era))
coreMapL Proof era
p = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era. Proof era -> PParamsUpdate era -> PParamsUpdateF era
PParamsUpdateF Proof era
p)) (\Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
_ Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdateF era)
b -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era. PParamsUpdateF era -> PParamsUpdate era
unPParamsUpdate Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdateF era)
b)

proposedMapL ::
  Lens' (ProposedPPUpdatesF era) (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdateF era))
proposedMapL :: forall era.
Lens'
  (ProposedPPUpdatesF era)
  (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdateF era))
proposedMapL =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (\(ProposedPPUpdatesF Proof era
p ProposedPPUpdates era
x) -> ProposedPPUpdates era
x forall s a. s -> Getting a s a -> a
^. (forall era.
Lens'
  (ProposedPPUpdates era)
  (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era))
proposedCoreL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Proof era
-> Lens'
     (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era))
     (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdateF era))
coreMapL Proof era
p))
    (\(ProposedPPUpdatesF Proof era
p ProposedPPUpdates era
x) Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdateF era)
y -> forall era.
Proof era -> ProposedPPUpdates era -> ProposedPPUpdatesF era
ProposedPPUpdatesF Proof era
p (ProposedPPUpdates era
x forall a b. a -> (a -> b) -> b
& (forall era.
Lens'
  (ProposedPPUpdates era)
  (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era))
proposedCoreL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Proof era
-> Lens'
     (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era))
     (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdateF era))
coreMapL Proof era
p) forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdateF era)
y))

-- ====================

data GovState era = GovState (Proof era) (Gov.GovState era)

unGovState :: GovState era -> Gov.GovState era
unGovState :: forall era. GovState era -> GovState era
unGovState (GovState Proof era
_ GovState era
x) = GovState era
x

govProposedL :: Lens' (GovState era) (ShelleyGovState era)
govProposedL :: forall era. Lens' (GovState era) (ShelleyGovState era)
govProposedL =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (\(GovState Proof era
p GovState era
x) -> forall era. Proof era -> GovState era -> ShelleyGovState era
getPPUP Proof era
p GovState era
x)
    (\(GovState Proof era
p GovState era
_) ShelleyGovState era
y -> forall era. Proof era -> GovState era -> GovState era
GovState Proof era
p (forall era. Proof era -> ShelleyGovState era -> GovState era
putPPUP Proof era
p ShelleyGovState era
y))

getPPUP :: forall era. Proof era -> Gov.GovState era -> ShelleyGovState era
getPPUP :: forall era. Proof era -> GovState era -> ShelleyGovState era
getPPUP Proof era
Shelley GovState era
x = GovState era
x
getPPUP Proof era
Allegra GovState era
x = GovState era
x
getPPUP Proof era
Mary GovState era
x = GovState era
x
getPPUP Proof era
Alonzo GovState era
x = GovState era
x
getPPUP Proof era
Babbage GovState era
x = GovState era
x
getPPUP Proof era
Conway GovState era
_ = forall a. Default a => a
def @(ShelleyGovState era)

putPPUP :: forall era. Proof era -> ShelleyGovState era -> Gov.GovState era
putPPUP :: forall era. Proof era -> ShelleyGovState era -> GovState era
putPPUP Proof era
Shelley ShelleyGovState era
x = ShelleyGovState era
x
putPPUP Proof era
Allegra ShelleyGovState era
x = ShelleyGovState era
x
putPPUP Proof era
Mary ShelleyGovState era
x = ShelleyGovState era
x
putPPUP Proof era
Alonzo ShelleyGovState era
x = ShelleyGovState era
x
putPPUP Proof era
Babbage ShelleyGovState era
x = ShelleyGovState era
x
putPPUP Proof era
Conway ShelleyGovState era
_ = forall era. EraGov era => GovState era
Gov.emptyGovState @era

-- ================
liftUTxO :: Map (TxIn (EraCrypto era)) (TxOutF era) -> UTxO era
liftUTxO :: forall era. Map (TxIn (EraCrypto era)) (TxOutF era) -> UTxO era
liftUTxO Map (TxIn (EraCrypto era)) (TxOutF era)
m = forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall era. TxOutF era -> TxOut era
unTxOut Map (TxIn (EraCrypto era)) (TxOutF era)
m)

instance Show (TxOutF era) where
  show :: TxOutF era -> String
show (TxOutF Proof era
p TxOut era
t) = forall a. Show a => a -> String
show (forall era a. (Reflect era => Proof era -> a) -> Proof era -> a
unReflect forall era. Reflect era => Proof era -> TxOut era -> PDoc
pcTxOut Proof era
p TxOut era
t :: PDoc)

instance Show (ValueF era) where
  show :: ValueF era -> String
show (ValueF Proof era
p Value era
t) = forall a. Show a => a -> String
show (forall era. Proof era -> Value era -> PDoc
pcVal Proof era
p Value era
t)

instance Show (PParamsF era) where
  show :: PParamsF era -> String
show (PParamsF Proof era
_ PParams era
_) = String
"PParamsF ..."

instance Show (PParamsUpdateF era) where
  show :: PParamsUpdateF era -> String
show (PParamsUpdateF Proof era
_ PParamsUpdate era
_) = String
"PParamsUpdateF ..."

instance Show (ProposedPPUpdatesF era) where
  show :: ProposedPPUpdatesF era -> String
show (ProposedPPUpdatesF Proof era
_ ProposedPPUpdates era
_) = String
"ProposedPPUdatesF ..."

genValue :: Proof era -> Gen (ValueF era)
genValue :: forall era. Proof era -> Gen (ValueF era)
genValue Proof era
p = case Proof era
p of
  Proof era
Shelley -> forall era. Proof era -> Value era -> ValueF era
ValueF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Allegra -> forall era. Proof era -> Value era -> ValueF era
ValueF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Mary -> forall era. Proof era -> Value era -> ValueF era
ValueF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Alonzo -> forall era. Proof era -> Value era -> ValueF era
ValueF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Babbage -> forall era. Proof era -> Value era -> ValueF era
ValueF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Conway -> forall era. Proof era -> Value era -> ValueF era
ValueF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary

genTxOut :: Proof era -> Gen (TxOutF era)
genTxOut :: forall era. Proof era -> Gen (TxOutF era)
genTxOut Proof era
p = do
  Integer
n <- forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
2, forall a. Random a => (a, a) -> Gen a
choose (Integer
1, Integer
100)), (Int
1, forall a. Random a => (a, a) -> Gen a
choose (Integer
101, Integer
1000))]
  forall era a. (Reflect era => Proof era -> a) -> Proof era -> a
unReflect forall era. Reflect era => Proof era -> Coin -> Gen (TxOutF era)
genTxOutX Proof era
p (Integer -> Coin
Coin Integer
n)

genPParams :: Proof era -> Gen (PParamsF era)
genPParams :: forall era. Proof era -> Gen (PParamsF era)
genPParams Proof era
p = case Proof era
p of
  Proof era
Shelley -> forall era. Proof era -> PParams era -> PParamsF era
PParamsF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Allegra -> forall era. Proof era -> PParams era -> PParamsF era
PParamsF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Mary -> forall era. Proof era -> PParams era -> PParamsF era
PParamsF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Alonzo -> forall era. Proof era -> PParams era -> PParamsF era
PParamsF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Babbage -> forall era. Proof era -> PParams era -> PParamsF era
PParamsF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Conway -> forall era. Proof era -> PParams era -> PParamsF era
PParamsF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary

genFuturePParams :: Proof era -> Gen (FuturePParams era)
genFuturePParams :: forall era. Proof era -> Gen (FuturePParams era)
genFuturePParams Proof era
p =
  forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
2, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall era. FuturePParams era
NoPParamsUpdate)
    , (Int
2, forall era. PParams era -> FuturePParams era
DefinitePParamsUpdate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. PParamsF era -> PParams era
unPParams forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. Proof era -> Gen (PParamsF era)
genPParams Proof era
p)
    , (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era. Maybe (PParams era) -> FuturePParams era
PotentialPParamsUpdate forall a. Maybe a
Nothing))
    , (Int
1, forall era. Maybe (PParams era) -> FuturePParams era
PotentialPParamsUpdate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. PParamsF era -> PParams era
unPParams forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. Proof era -> Gen (PParamsF era)
genPParams Proof era
p)
    ]

genPParamsUpdate :: Proof era -> Gen (PParamsUpdateF era)
genPParamsUpdate :: forall era. Proof era -> Gen (PParamsUpdateF era)
genPParamsUpdate Proof era
p = case Proof era
p of
  Proof era
Shelley -> forall era. Proof era -> PParamsUpdate era -> PParamsUpdateF era
PParamsUpdateF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8,
 EraPParams era) =>
Constants -> PParams era -> Gen (PParamsUpdate era)
genShelleyPParamsUpdate Constants
defaultConstants forall a. Default a => a
def
  Proof era
Allegra -> forall era. Proof era -> PParamsUpdate era -> PParamsUpdateF era
PParamsUpdateF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8,
 EraPParams era) =>
Constants -> PParams era -> Gen (PParamsUpdate era)
genShelleyPParamsUpdate Constants
defaultConstants forall a. Default a => a
def
  Proof era
Mary -> forall era. Proof era -> PParamsUpdate era -> PParamsUpdateF era
PParamsUpdateF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8,
 EraPParams era) =>
Constants -> PParams era -> Gen (PParamsUpdate era)
genShelleyPParamsUpdate Constants
defaultConstants forall a. Default a => a
def
  Proof era
Alonzo -> forall era. Proof era -> PParamsUpdate era -> PParamsUpdateF era
PParamsUpdateF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Babbage -> forall era. Proof era -> PParamsUpdate era -> PParamsUpdateF era
PParamsUpdateF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Conway -> forall era. Proof era -> PParamsUpdate era -> PParamsUpdateF era
PParamsUpdateF Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary

genProposedPPUpdates :: Proof era -> Gen (ProposedPPUpdatesF era)
genProposedPPUpdates :: forall era. Proof era -> Gen (ProposedPPUpdatesF era)
genProposedPPUpdates Proof era
p = case Proof era
p of
  Proof era
Shelley -> forall era.
Proof era -> ProposedPPUpdates era -> ProposedPPUpdatesF era
ProposedPPUpdatesF Proof era
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
PP.ProposedPPUpdates forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Allegra -> forall era.
Proof era -> ProposedPPUpdates era -> ProposedPPUpdatesF era
ProposedPPUpdatesF Proof era
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
PP.ProposedPPUpdates forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Mary -> forall era.
Proof era -> ProposedPPUpdates era -> ProposedPPUpdatesF era
ProposedPPUpdatesF Proof era
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
PP.ProposedPPUpdates forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Alonzo -> forall era.
Proof era -> ProposedPPUpdates era -> ProposedPPUpdatesF era
ProposedPPUpdatesF Proof era
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
PP.ProposedPPUpdates forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Babbage -> forall era.
Proof era -> ProposedPPUpdates era -> ProposedPPUpdatesF era
ProposedPPUpdatesF Proof era
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
PP.ProposedPPUpdates forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Conway -> forall era.
Proof era -> ProposedPPUpdates era -> ProposedPPUpdatesF era
ProposedPPUpdatesF Proof era
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
PP.ProposedPPUpdates forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary

genGovState :: Proof era -> Gen (GovState era)
genGovState :: forall era. Proof era -> Gen (GovState era)
genGovState Proof era
p = case Proof era
p of
  Proof era
Shelley -> forall era. Proof era -> GovState era -> GovState era
GovState Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Allegra -> forall era. Proof era -> GovState era -> GovState era
GovState Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Mary -> forall era. Proof era -> GovState era -> GovState era
GovState Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Alonzo -> forall era. Proof era -> GovState era -> GovState era
GovState Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Babbage -> forall era. Proof era -> GovState era -> GovState era
GovState Proof era
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Conway -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> GovState era -> GovState era
GovState Proof era
p forall era. EraGov era => GovState era
Gov.emptyGovState

genUTxO :: Proof era -> Gen (UTxO era)
genUTxO :: forall era. Proof era -> Gen (UTxO era)
genUTxO Proof era
p = case Proof era
p of
  Proof era
Shelley -> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Allegra -> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Mary -> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Alonzo -> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Babbage -> forall a. Arbitrary a => Gen a
arbitrary
  Proof era
Conway -> forall a. Arbitrary a => Gen a
arbitrary

-- ========================

data ScriptsNeededF era where
  ScriptsNeededF :: Proof era -> ScriptsNeeded era -> ScriptsNeededF era

unScriptsNeededF :: ScriptsNeededF era -> ScriptsNeeded era
unScriptsNeededF :: forall era. ScriptsNeededF era -> ScriptsNeeded era
unScriptsNeededF (ScriptsNeededF Proof era
_ ScriptsNeeded era
v) = ScriptsNeeded era
v

instance Show (ScriptsNeededF era) where
  show :: ScriptsNeededF era -> String
show (ScriptsNeededF Proof era
p ScriptsNeeded era
t) = forall era a. (Reflect era => Proof era -> a) -> Proof era -> a
unReflect (\Proof era
_ -> forall a. Show a => a -> String
show (forall era. Reflect era => Proof era -> ScriptsNeeded era -> PDoc
pcScriptsNeeded Proof era
p ScriptsNeeded era
t)) Proof era
p

-- ========================

data ScriptF era where
  ScriptF :: Proof era -> Script era -> ScriptF era

unScriptF :: ScriptF era -> Script era
unScriptF :: forall era. ScriptF era -> Script era
unScriptF (ScriptF Proof era
_ Script era
v) = Script era
v

instance PrettyA (ScriptF era) where
  prettyA :: ScriptF era -> PDoc
prettyA (ScriptF Proof era
p Script era
x) = forall era a. (Reflect era => Proof era -> a) -> Proof era -> a
unReflect forall era. Reflect era => Proof era -> Script era -> PDoc
pcScript Proof era
p Script era
x

instance Show (ScriptF era) where
  show :: ScriptF era -> String
show (ScriptF Proof era
p Script era
t) = forall a. Show a => a -> String
show ((forall era a. (Reflect era => Proof era -> a) -> Proof era -> a
unReflect forall era. Reflect era => Proof era -> Script era -> PDoc
pcScript Proof era
p Script era
t) :: PDoc)

instance Eq (ScriptF era) where
  (ScriptF Proof era
Shelley Script era
x) == :: ScriptF era -> ScriptF era -> Bool
== (ScriptF Proof era
Shelley Script era
y) = Script era
x forall a. Eq a => a -> a -> Bool
== Script era
y
  (ScriptF Proof era
Allegra Script era
x) == (ScriptF Proof era
Allegra Script era
y) = Script era
x forall a. Eq a => a -> a -> Bool
== Script era
y
  (ScriptF Proof era
Mary Script era
x) == (ScriptF Proof era
Mary Script era
y) = Script era
x forall a. Eq a => a -> a -> Bool
== Script era
y
  (ScriptF Proof era
Alonzo Script era
x) == (ScriptF Proof era
Alonzo Script era
y) = Script era
x forall a. Eq a => a -> a -> Bool
== Script era
y
  (ScriptF Proof era
Babbage Script era
x) == (ScriptF Proof era
Babbage Script era
y) = Script era
x forall a. Eq a => a -> a -> Bool
== Script era
y
  (ScriptF Proof era
Conway Script era
x) == (ScriptF Proof era
Conway Script era
y) = Script era
x forall a. Eq a => a -> a -> Bool
== Script era
y

genScriptF :: Era era => Proof era -> Gen (ScriptF era)
genScriptF :: forall era. Era era => Proof era -> Gen (ScriptF era)
genScriptF Proof era
proof = do
  PlutusPurposeTag
tag <- forall a. HasCallStack => [a] -> Gen a
elements forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> [PlutusPurposeTag]
plutusPurposeTags Proof era
proof
  ValidityInterval
vi <- forall a. Arbitrary a => Gen a
arbitrary
  Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
m <- forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> Gen a -> Gen [a]
vectorOf Int
5 forall a. Arbitrary a => Gen a
arbitrary
  Script era
corescript <- forall era.
Proof era
-> PlutusPurposeTag
-> KeyMap era
-> ValidityInterval
-> Gen (Script era)
genCoreScript Proof era
proof PlutusPurposeTag
tag Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
m ValidityInterval
vi
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era. Proof era -> Script era -> ScriptF era
ScriptF Proof era
proof Script era
corescript)

-- ==========================================================================
-- A Single Partition function on Integer, we use to do all partitions by
-- using wrapper functions.
-- ==========================================================================

zeroCount :: Show a => [Char] -> a -> [Char]
zeroCount :: forall a. Show a => String -> a -> String
zeroCount String
fname a
total =
  String
fname
    forall a. [a] -> [a] -> [a]
++ String
" called with count=(0) and total=("
    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
total
    forall a. [a] -> [a] -> [a]
++ String
") \n"
    forall a. [a] -> [a] -> [a]
++ String
"Probably due to (SumsTo comparison "
    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
total
    forall a. [a] -> [a] -> [a]
++ String
" [SumMap x]) where 'x' is the emptyset.\n"
    forall a. [a] -> [a] -> [a]
++ String
"Try adding (Sized (Range 1 m) (Dom x)) constraint to force 'x' to have at least 1 element"

legalCallPartition :: [String] -> String -> Integer -> Int -> Integer -> Maybe [String]
legalCallPartition :: [String] -> String -> Integer -> Int -> Integer -> Maybe [String]
legalCallPartition [String]
msgs String
typname Integer
smallest Int
size Integer
total
  | Int
size forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Integer
smallest forall a. Ord a => a -> a -> Bool
> Integer
0 =
      forall a. a -> Maybe a
Just
        ( [ String
"partition at type " forall a. [a] -> [a] -> [a]
++ String
typname
          , String
"smallest="
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
smallest
              forall a. [a] -> [a] -> [a]
++ String
", size="
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
size
              forall a. [a] -> [a] -> [a]
++ String
", total="
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
total
          ]
            forall a. [a] -> [a] -> [a]
++ [String]
msgs
        )
  | forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size forall a. Ord a => a -> a -> Bool
> Integer
total Bool -> Bool -> Bool
&& Integer
smallest forall a. Ord a => a -> a -> Bool
> Integer
0 =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
        ( String
"Can't partition "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
total
            forall a. [a] -> [a] -> [a]
++ String
" into "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
size
            forall a. [a] -> [a] -> [a]
++ String
" positive pieces at type "
            forall a. [a] -> [a] -> [a]
++ String
typname
            forall a. [a] -> [a] -> [a]
++ String
" (smallest = "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
smallest
            forall a. [a] -> [a] -> [a]
++ String
")"
        )
          forall a. a -> [a] -> [a]
: [String]
msgs
  | Int
size forall a. Ord a => a -> a -> Bool
<= Int
0 =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
        ( String
"Can only make a partition of a positive number of pieces: "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
size
            forall a. [a] -> [a] -> [a]
++ String
", total: "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
total
            forall a. [a] -> [a] -> [a]
++ String
", smallest: "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
smallest
        )
          forall a. a -> [a] -> [a]
: [String]
msgs
  | Integer
smallest forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
&& Integer
smallest forall a. Num a => a -> a -> a
* (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size) forall a. Ord a => a -> a -> Bool
> Integer
total =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
        ( String
"Can't partition "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
total
            forall a. [a] -> [a] -> [a]
++ String
" into "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
size
            forall a. [a] -> [a] -> [a]
++ String
" pieces, each (>= "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
smallest
            forall a. [a] -> [a] -> [a]
++ String
")"
        )
          forall a. a -> [a] -> [a]
: [String]
msgs
  | Integer
total forall a. Ord a => a -> a -> Bool
< Integer
1 Bool -> Bool -> Bool
&& Integer
smallest forall a. Ord a => a -> a -> Bool
> Integer
0 =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
        ( String
"Total ("
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
total
            forall a. [a] -> [a] -> [a]
++ String
") must be positive when smallest("
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
smallest
            forall a. [a] -> [a] -> [a]
++ String
") is positive."
        )
          forall a. a -> [a] -> [a]
: [String]
msgs
  | Bool
True = forall a. Maybe a
Nothing

-- | Generate a list of length 'size' that sums to 'total', where the minimum element is (>= 'smallest')
integerPartition :: [String] -> String -> Integer -> Int -> Integer -> Gen [Integer]
integerPartition :: [String] -> String -> Integer -> Int -> Integer -> Gen [Integer]
integerPartition [String]
msgs String
typname Integer
smallest Int
size Integer
total
  | Integer
total forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
&& Integer
smallest forall a. Ord a => a -> a -> Bool
<= Integer
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Int -> a -> [a]
replicate Int
size Integer
0)
  | Bool
True = case [String] -> String -> Integer -> Int -> Integer -> Maybe [String]
legalCallPartition [String]
msgs String
typname Integer
smallest Int
size Integer
total of
      Just (String
x : [String]
xs) -> forall a. HasCallStack => String -> [String] -> a
errorMess String
x [String]
xs
      Just [] -> forall a. HasCallStack => String -> [String] -> a
errorMess String
"legalCallPartition returns []" []
      Maybe [String]
Nothing ->
        let mean :: Integer
mean = Integer
total forall a. Integral a => a -> a -> a
`div` forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
size forall a. Num a => a -> a -> a
+ Int
1)
            go :: Integer -> Integer -> Gen [Integer]
go Integer
1 Integer
total1
              | Integer
total1 forall a. Ord a => a -> a -> Bool
< Integer
1 Bool -> Bool -> Bool
&& Integer
smallest forall a. Ord a => a -> a -> Bool
> Integer
0 =
                  forall a. HasCallStack => String -> [String] -> a
errorMess (String
"Ran out of choices(2), total went negative: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
total1) [String]
msgs
              | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure [Integer
total1]
            go Integer
2 Integer
total1 = do
              Integer
z <- forall a. Random a => (a, a) -> Gen a
choose (Integer
smallest, Integer
total1 forall a. Num a => a -> a -> a
- Integer
1)
              forall (f :: * -> *) a. Applicative f => a -> f a
pure [Integer
z, Integer
total1 forall a. Num a => a -> a -> a
- Integer
z]
            go Integer
size1 Integer
total1 = do
              let hi :: Integer
hi =
                    forall a. Ord a => a -> a -> a
min
                      (forall a. Ord a => a -> a -> a
max Integer
1 Integer
mean)
                      (Integer
total1 forall a. Num a => a -> a -> a
- (Integer
size1 forall a. Num a => a -> a -> a
- Integer
1))
              Integer
x <- forall a. Random a => (a, a) -> Gen a
choose (Integer
smallest, Integer
hi)
              [Integer]
xs <- Integer -> Integer -> Gen [Integer]
go (Integer
size1 forall a. Num a => a -> a -> a
- Integer
1) (Integer
total1 forall a. Num a => a -> a -> a
- Integer
x)
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer
x forall a. a -> [a] -> [a]
: [Integer]
xs)
         in do
              [Integer]
ws <- Integer -> Integer -> Gen [Integer]
go (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size) Integer
total
              forall a. [a] -> Gen [a]
shuffle [Integer]
ws

partitionRational :: Rational -> [String] -> Int -> Rational -> Gen [Rational]
partitionRational :: Rational -> [String] -> Int -> Rational -> Gen [Rational]
partitionRational Rational
smallest [String]
msgs Int
size Rational
total = do
  let scale :: Integer
scale = forall a. Integral a => a -> a -> a
lcm (forall a. Ratio a -> a
denominator Rational
smallest) (forall a. Ratio a -> a
denominator Rational
total)
      iSmallest :: Integer
iSmallest = forall a. Ratio a -> a
numerator (Rational
smallest forall a. Num a => a -> a -> a
* (Integer
scale forall a. Integral a => a -> a -> Ratio a
% Integer
1))
      iTotal :: Integer
iTotal = forall a. Ratio a -> a
numerator (Rational
total forall a. Num a => a -> a -> a
* (Integer
scale forall a. Integral a => a -> a -> Ratio a
% Integer
1))
  [Integer]
is <- [String] -> String -> Integer -> Int -> Integer -> Gen [Integer]
integerPartition [String]
msgs (String
"Rational*" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
scale) Integer
iSmallest Int
size Integer
iTotal
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (a -> b) -> [a] -> [b]
map (\Integer
i -> Integer
i forall a. Integral a => a -> a -> Ratio a
% Integer
scale) [Integer]
is)

partitionCoin :: Coin -> [String] -> Int -> Coin -> Gen [Coin]
partitionCoin :: Coin -> [String] -> Int -> Coin -> Gen [Coin]
partitionCoin (Coin Integer
small) [String]
msgs Int
n (Coin Integer
total) =
  forall a b. (a -> b) -> [a] -> [b]
map Integer -> Coin
Coin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> String -> Integer -> Int -> Integer -> Gen [Integer]
integerPartition [String]
msgs String
"Coin" Integer
small Int
n Integer
total

partitionDeltaCoin :: DeltaCoin -> [String] -> Int -> DeltaCoin -> Gen [DeltaCoin]
partitionDeltaCoin :: DeltaCoin -> [String] -> Int -> DeltaCoin -> Gen [DeltaCoin]
partitionDeltaCoin (DeltaCoin Integer
small) [String]
msgs Int
n (DeltaCoin Integer
total) =
  forall a b. (a -> b) -> [a] -> [b]
map Integer -> DeltaCoin
DeltaCoin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> String -> Integer -> Int -> Integer -> Gen [Integer]
integerPartition [String]
msgs String
"DeltaCoin" Integer
small Int
n Integer
total

partitionInt :: Int -> [String] -> Int -> Int -> Gen [Int]
partitionInt :: Int -> [String] -> Int -> Int -> Gen [Int]
partitionInt Int
small [String]
msgs Int
n Int
total =
  forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> String -> Integer -> Int -> Integer -> Gen [Integer]
integerPartition [String]
msgs String
"Int" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
small) Int
n (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
total)

partitionWord64 :: Word64 -> [String] -> Int -> Word64 -> Gen [Word64]
partitionWord64 :: Word64 -> [String] -> Int -> Word64 -> Gen [Word64]
partitionWord64 Word64
small [String]
msgs Int
n Word64
total =
  forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> String -> Integer -> Int -> Integer -> Gen [Integer]
integerPartition [String]
msgs String
"Word64" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
small) Int
n (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
total)

partitionNatural :: Natural -> [String] -> Int -> Natural -> Gen [Natural]
partitionNatural :: Natural -> [String] -> Int -> Natural -> Gen [Natural]
partitionNatural Natural
small [String]
msgs Int
n Natural
total =
  forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> String -> Integer -> Int -> Integer -> Gen [Integer]
integerPartition [String]
msgs String
"Natural" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
small) Int
n (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
total)

-- =======================================================

-- | Translate (s,cond,n), into a Size which
--   specifies the Int range on which the OrdCond is True.
--   The triple (s, EQL, 2) denotes s = 2
--              (s, LTH, 7) denotes s < 7
--              (s, GTH, 5) denotes s > 5 ...
ordCondToSize :: forall a. Adds a => (String, OrdCond, a) -> Size
ordCondToSize :: forall a. Adds a => (String, OrdCond, a) -> Size
ordCondToSize (String
_label, OrdCond
cond, a
n) = case OrdCond
cond of
  OrdCond
EQL -> Int -> Size
SzExact forall a b. (a -> b) -> a -> b
$ forall x. Adds x => x -> Int
toI a
n
  OrdCond
LTH -> Int -> Size
SzMost forall a b. (a -> b) -> a -> b
$ forall x. Adds x => Int -> Int
decreaseBy1 @a forall a b. (a -> b) -> a -> b
$ forall x. Adds x => x -> Int
toI a
n
  OrdCond
LTE -> Int -> Size
SzMost forall a b. (a -> b) -> a -> b
$ forall x. Adds x => x -> Int
toI a
n
  OrdCond
GTH -> Int -> Size
SzLeast forall a b. (a -> b) -> a -> b
$ forall x. Adds x => Int -> Int
increaseBy1 @a forall a b. (a -> b) -> a -> b
$ forall x. Adds x => x -> Int
toI a
n
  OrdCond
GTE -> Int -> Size
SzLeast forall a b. (a -> b) -> a -> b
$ forall x. Adds x => x -> Int
toI a
n

-- Translate some thing like [SumsTo _ x <= 4 + 6 + 9] where the variable 'x' is on the left
varOnLeft :: Adds a => String -> OrdCond -> a -> AddsSpec c
varOnLeft :: forall a c. Adds a => String -> OrdCond -> a -> AddsSpec c
varOnLeft String
x OrdCond
cond a
n = forall c. String -> Size -> AddsSpec c
AddsSpecSize String
x (forall a. Adds a => String -> OrdCond -> a -> Size
varOnLeftSize String
x OrdCond
cond a
n)

varOnLeftSize :: Adds a => String -> OrdCond -> a -> Size
varOnLeftSize :: forall a. Adds a => String -> OrdCond -> a -> Size
varOnLeftSize String
x OrdCond
cond a
n = forall a. Adds a => (String, OrdCond, a) -> Size
ordCondToSize (String
x, OrdCond
cond, a
n)

-- Translate some thing like [SumsTo c 8 < 2 + x + 3] where the variable 'x' is on the right
varOnRight :: Adds a => [String] -> a -> OrdCond -> a -> String -> AddsSpec c
varOnRight :: forall a c.
Adds a =>
[String] -> a -> OrdCond -> a -> String -> AddsSpec c
varOnRight [String]
_ a
lhs OrdCond
LTH a
rhs String
s
  | forall x. Adds x => x -> Int
toI a
rhs forall a. Ord a => a -> a -> Bool
> forall x. Adds x => x -> Int
toI a
lhs -- When this holds the only constraint on the var 's' is that its is (>= 0)
    =
      forall c. String -> Size -> AddsSpec c
AddsSpecSize String
s (Int -> Size
SzLeast Int
0)
varOnRight [String]
msgs a
lhs OrdCond
cond a
rhs String
s =
  forall c. String -> Size -> AddsSpec c
AddsSpecSize
    String
s
    ( forall a. Adds a => [String] -> a -> OrdCond -> a -> String -> Size
varOnRightSize
        ( ( String
"varOnRight @"
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Typeable a => a -> TypeRep
typeOf a
lhs)
              forall a. [a] -> [a] -> [a]
++ String
" "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
lhs
              forall a. [a] -> [a] -> [a]
++ String
" "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show OrdCond
cond
              forall a. [a] -> [a] -> [a]
++ String
" "
              forall a. [a] -> [a] -> [a]
++ String
s
              forall a. [a] -> [a] -> [a]
++ String
" + "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
rhs
          )
            forall a. a -> [a] -> [a]
: [String]
msgs
        )
        a
lhs
        OrdCond
cond
        a
rhs
        String
s
    )

varOnRightSize :: Adds a => [String] -> a -> OrdCond -> a -> String -> Size
varOnRightSize :: forall a. Adds a => [String] -> a -> OrdCond -> a -> String -> Size
varOnRightSize [String]
msgs a
n OrdCond
cond a
m String
s =
  if Bool -> Bool
not (forall x. Adds x => x -> Bool
supportsNegative a
n) Bool -> Bool -> Bool
&& forall x. Adds x => x -> Int
toI a
n forall a. Ord a => a -> a -> Bool
<= forall x. Adds x => x -> Int
toI a
m
    then -- if the lhs 'n' is less than the rhs 'm', then the var 's' must be 0 or greater
      Int -> Size
SzLeast Int
0
    else
      forall a. Adds a => (String, OrdCond, a) -> Size
ordCondToSize
        ( String
s
        , OrdCond -> OrdCond
reverseOrdCond OrdCond
cond
        , forall x. Adds x => [String] -> x -> x -> x
minus
            ((String
"varOnRightSize " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show OrdCond
cond forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
m forall a. [a] -> [a] -> [a]
++ String
" + " forall a. [a] -> [a] -> [a]
++ String
s) forall a. a -> [a] -> [a]
: [String]
msgs)
            a
n
            a
m
        )

-- Translate some thing like [SumsTo (Negate x) <= 4 + 6 + 9] where the variable 'x'
-- is on the left, and we want to produce its negation.
varOnLeftNeg :: Adds a => String -> OrdCond -> a -> AddsSpec c
varOnLeftNeg :: forall a c. Adds a => String -> OrdCond -> a -> AddsSpec c
varOnLeftNeg String
s OrdCond
cond a
n = forall c. String -> Size -> AddsSpec c
AddsSpecSize String
s (Size -> Size
negateSize (forall a. Adds a => (String, OrdCond, a) -> Size
ordCondToSize (String
s, OrdCond
cond, a
n)))

-- Translate some thing like [SumsTo 8 < 2 + (Negate x) + 3] where the
-- variable 'x' is on the right, and we want to produce its negation.
varOnRightNeg :: Adds a => a -> OrdCond -> a -> String -> AddsSpec c
varOnRightNeg :: forall a c. Adds a => a -> OrdCond -> a -> String -> AddsSpec c
varOnRightNeg a
n OrdCond
cond a
m String
s =
  forall c. String -> Size -> AddsSpec c
AddsSpecSize
    String
s
    (Size -> Size
negateSize (forall a. Adds a => (String, OrdCond, a) -> Size
ordCondToSize (String
s, OrdCond -> OrdCond
reverseOrdCond OrdCond
cond, forall x. Adds x => [String] -> x -> x -> x
minus [String
"varOnRightNeg", String
s, forall a. Show a => a -> String
show a
m] a
n a
m)))

-- | This function `reverseOrdCond` has been defined to handle the Pred SumsTo when the
--   variable is on the right-hand-side (rhs) of the OrdCond operator. In order to do that
--   we must multiply both sides of the inequality by (-1). For example consider
--   [SumsTo (DeltaCoin 1) ▵₳ -2 > ∑ ▵₳ -1 + x]
--                 Note variable x on the rhs ^
--    To solve we subtract 'x' from both sides, and add '▵₳ -2' from bothsides
--    getting      (-x) > ∑  (▵₳ -1) + (▵₳ -2)
--    reduced to   (-x) > ∑  (▵₳ -3)
--    to solve we must multiply both sides by (-1)
--                 x ?? ∑  (▵₳ 3)
-- What operator do we replace ?? by to make the original (▵₳ -2 > ∑ ▵₳ -1 + x) True?
-- The change in the operator is called "reversing" the operator. See
-- https://www.mathsisfun.com/algebra/inequality-solving.html for one explantion.
reverseOrdCond :: OrdCond -> OrdCond
reverseOrdCond :: OrdCond -> OrdCond
reverseOrdCond OrdCond
EQL = OrdCond
EQL
reverseOrdCond OrdCond
LTH = OrdCond
GTH
reverseOrdCond OrdCond
LTE = OrdCond
GTE
reverseOrdCond OrdCond
GTH = OrdCond
LTH
reverseOrdCond OrdCond
GTE = OrdCond
LTE

-- =========================================================================
-- OrdCond
-- x <= y
--   ^     paramerterize over the condition
--
-- EQL = (==), LTH = (<), LTE = (<=), GTH = (>), GTE = (>=)
-- =========================================================================

-- | First order representation of the Ord comparisons
data OrdCond = EQL | LTH | LTE | GTH | GTE
  deriving (OrdCond -> OrdCond -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OrdCond -> OrdCond -> Bool
$c/= :: OrdCond -> OrdCond -> Bool
== :: OrdCond -> OrdCond -> Bool
$c== :: OrdCond -> OrdCond -> Bool
Eq)

instance Show OrdCond where
  show :: OrdCond -> String
show OrdCond
EQL = String
" = ∑ "
  show OrdCond
LTH = String
" < ∑ "
  show OrdCond
LTE = String
" <= ∑ "
  show OrdCond
GTH = String
" > ∑ "
  show OrdCond
GTE = String
" >= ∑ "

runOrdCond :: Ord c => OrdCond -> c -> c -> Bool
runOrdCond :: forall c. Ord c => OrdCond -> c -> c -> Bool
runOrdCond OrdCond
EQL c
x c
y = c
x forall a. Eq a => a -> a -> Bool
== c
y
runOrdCond OrdCond
LTH c
x c
y = c
x forall a. Ord a => a -> a -> Bool
< c
y
runOrdCond OrdCond
LTE c
x c
y = c
x forall a. Ord a => a -> a -> Bool
<= c
y
runOrdCond OrdCond
GTH c
x c
y = c
x forall a. Ord a => a -> a -> Bool
> c
y
runOrdCond OrdCond
GTE c
x c
y = c
x forall a. Ord a => a -> a -> Bool
>= c
y

-- =========================================================================

-- | A specification of summation. like: lhs = ∑ rhs
--   The idea is that the 'rhs' can contain multiple terms: rhs = ∑ r1 + r2 + r3
--   Other example conditions:  (lhs < ∑ rhs), and (lhs >= ∑ rhs)
--   The invariant is that only a single variable appears in the summation.
--   It can appear on either side. If it appears in the 'rhs' then there
--   may be other, constant terms, in the rhs:  7 = ∑ 3 + v + 9
--   We always do the sums and solving at type Int, and cast back and forth to
--   accommodate other types with (Adds c) instances, using the methods 'fromI" and 'toI'
--   This allows the instance to deal with special conditions.
--   There are two (non-failure) possibilities 1) Var on the left, 2) Var on the right
--   We supply functions
--      varOnLeft  :: String -> OrdCond -> Integer -> AddsSpec c
--                SumsTo _ x <= 4 + 6 + 9 ===> (varOnLeft x LTE 19) == (AddsSpecSize x (AtMost 19))
--      varOnRight :: Integer -> OrdCond -> Integer -> String -> AddsSpec c
--                SumsTo _ 8 < 2 + x + 3 ===> (varOnRight 8 LTH 5 x) == (AddsSpecSize x (AtLeast 4))
--   But internally we store the information as a String and a Size (I.e. a range of Int)
data AddsSpec c where
  AddsSpecSize ::
    -- | name
    String ->
    -- | total (range like (4 .. 12))
    Size ->
    AddsSpec c
  AddsSpecAny :: AddsSpec c
  AddsSpecNever :: [String] -> AddsSpec c

instance LiftT (AddsSpec c) where
  liftT :: AddsSpec c -> Typed (AddsSpec c)
liftT (AddsSpecNever [String]
xs) = forall a. [String] -> Typed a
failT [String]
xs
  liftT AddsSpec c
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure AddsSpec c
x
  dropT :: Typed (AddsSpec c) -> AddsSpec c
dropT (Typed (Left [String]
s)) = forall c. [String] -> AddsSpec c
AddsSpecNever [String]
s
  dropT (Typed (Right AddsSpec c
x)) = AddsSpec c
x

instance Show (AddsSpec c) where show :: AddsSpec c -> String
show = forall c. AddsSpec c -> String
showAddsSpec

instance Semigroup (AddsSpec c) where <> :: AddsSpec c -> AddsSpec c -> AddsSpec c
(<>) = forall c. AddsSpec c -> AddsSpec c -> AddsSpec c
mergeAddsSpec
instance Monoid (AddsSpec c) where mempty :: AddsSpec c
mempty = forall c. AddsSpec c
AddsSpecAny

showAddsSpec :: AddsSpec c -> String
showAddsSpec :: forall c. AddsSpec c -> String
showAddsSpec AddsSpec c
AddsSpecAny = String
"AddsSpecAny"
showAddsSpec (AddsSpecSize String
s Size
size) = [String] -> String
sepsP [String
"AddsSpecSize", String
s, forall a. Show a => a -> String
show Size
size]
showAddsSpec (AddsSpecNever [String]
_) = String
"AddsSpecNever"

mergeAddsSpec :: AddsSpec c -> AddsSpec c -> AddsSpec c
mergeAddsSpec :: forall c. AddsSpec c -> AddsSpec c -> AddsSpec c
mergeAddsSpec (AddsSpecNever [String]
xs) (AddsSpecNever [String]
ys) = forall c. [String] -> AddsSpec c
AddsSpecNever ([String]
xs forall a. [a] -> [a] -> [a]
++ [String]
ys)
mergeAddsSpec x :: AddsSpec c
x@(AddsSpecNever [String]
_) AddsSpec c
_ = AddsSpec c
x
mergeAddsSpec AddsSpec c
_ x :: AddsSpec c
x@(AddsSpecNever [String]
_) = AddsSpec c
x
mergeAddsSpec AddsSpec c
AddsSpecAny AddsSpec c
x = AddsSpec c
x
mergeAddsSpec AddsSpec c
x AddsSpec c
AddsSpecAny = AddsSpec c
x
mergeAddsSpec a :: AddsSpec c
a@(AddsSpecSize String
nam1 Size
size1) b :: AddsSpec c
b@(AddsSpecSize String
nam2 Size
size2) =
  if String
nam1 forall a. Eq a => a -> a -> Bool
/= String
nam2
    then
      forall c. [String] -> AddsSpec c
AddsSpecNever
        [ String
"vars " forall a. [a] -> [a] -> [a]
++ String
nam1 forall a. [a] -> [a] -> [a]
++ String
" and " forall a. [a] -> [a] -> [a]
++ String
nam2 forall a. [a] -> [a] -> [a]
++ String
" are not the same."
        , forall a. Show a => a -> String
show AddsSpec c
a forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show AddsSpec c
b forall a. [a] -> [a] -> [a]
++ String
" are inconsistent."
        ]
    else case Size
size1 forall a. Semigroup a => a -> a -> a
<> Size
size2 of
      (SzNever [String]
xs) -> forall c. [String] -> AddsSpec c
AddsSpecNever ([String]
xs forall a. [a] -> [a] -> [a]
++ [forall a. Show a => a -> String
show AddsSpec c
a forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show AddsSpec c
a forall a. [a] -> [a] -> [a]
++ String
" are inconsistent."])
      Size
size3 -> forall c. String -> Size -> AddsSpec c
AddsSpecSize String
nam1 Size
size3

-- =======================================
-- Helper function to create AddsSpecSize

-- Translate some thing like [SumsTo _ x <= 4 + 6 + 9] where the variable 'x' is on the left
vLeft :: String -> OrdCond -> Int -> (AddsSpec c)
vLeft :: forall c. String -> OrdCond -> Int -> AddsSpec c
vLeft String
x OrdCond
cond Int
n = forall c. String -> Size -> AddsSpec c
AddsSpecSize String
x (String -> OrdCond -> Int -> Size
vLeftSize String
x OrdCond
cond Int
n)

vLeftSize :: String -> OrdCond -> Int -> Size
vLeftSize :: String -> OrdCond -> Int -> Size
vLeftSize String
x OrdCond
cond Int
n = forall a. Adds a => (String, OrdCond, a) -> Size
ordCondToSize (String
x, OrdCond
cond, Int
n)

-- Translate some thing like [SumsTo c 8 < 2 + x + 3] where the variable 'x' is on the right
vRight :: Int -> OrdCond -> Int -> String -> AddsSpec c
vRight :: forall c. Int -> OrdCond -> Int -> String -> AddsSpec c
vRight Int
n OrdCond
cond Int
m String
s = forall c. String -> Size -> AddsSpec c
AddsSpecSize String
s (Int -> OrdCond -> Int -> String -> Size
vRightSize Int
n OrdCond
cond Int
m String
s)

-- vRightSize :: Adds c => c -> OrdCond -> Int ->String - Size
vRightSize :: Int -> OrdCond -> Int -> String -> Size
vRightSize :: Int -> OrdCond -> Int -> String -> Size
vRightSize Int
n OrdCond
cond Int
m String
s = forall a. Adds a => (String, OrdCond, a) -> Size
ordCondToSize (String
s, OrdCond -> OrdCond
reverseOrdCond OrdCond
cond, Int
n forall a. Num a => a -> a -> a
- Int
m)

-- Translate some thing like [SumsTo (Negate x) <= 4 + 6 + 9] where the variable 'x'
-- is on the left, and we want to produce its negation.
vLeftNeg :: String -> OrdCond -> Int -> (AddsSpec c)
vLeftNeg :: forall c. String -> OrdCond -> Int -> AddsSpec c
vLeftNeg String
s OrdCond
cond Int
n = forall c. String -> Size -> AddsSpec c
AddsSpecSize String
s (Size -> Size
negateSize (forall a. Adds a => (String, OrdCond, a) -> Size
ordCondToSize (String
s, OrdCond
cond, Int
n)))

-- Translate some thing like [SumsTo 8 < 2 + (Negate x) + 3] where the
-- variable 'x' is on the right, and we want to produce its negation.
vRightNeg :: Int -> OrdCond -> Int -> String -> AddsSpec c
vRightNeg :: forall c. Int -> OrdCond -> Int -> String -> AddsSpec c
vRightNeg Int
n OrdCond
cond Int
m String
s = forall c. String -> Size -> AddsSpec c
AddsSpecSize String
s (Size -> Size
negateSize (forall a. Adds a => (String, OrdCond, a) -> Size
ordCondToSize (String
s, OrdCond -> OrdCond
reverseOrdCond OrdCond
cond, Int
n forall a. Num a => a -> a -> a
- Int
m)))