{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | A 'Spec' is a first order data structure that denotes a random generator
--   For example
--   (MapSpec era dom rng) denotes Gen(Map dom rng)
--   (RngSpec era t)       denotes Gen[t]  where the [t] has some Summing properties
--   (RelSep era t)        denotes Gen(Set t) where the set meets some relational properties
--   (Size)                denotes Gen Int, the size of some Map, Set, List etc.
--   (PairSpec era d r)    denotes (([d],[r]) -> ([d],[r])) a transformer
module Test.Cardano.Ledger.Constrained.Spec where

import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..))
import Cardano.Ledger.Core (Era (..))
import qualified Data.List as List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word (Word64)
import qualified Debug.Trace as Debug
import Lens.Micro hiding (set)
import Test.Cardano.Ledger.Constrained.Ast (Pred (..), Sum (..), Term (..), runPred)
import Test.Cardano.Ledger.Constrained.Classes (
  Adds (..),
  AddsSpec (..),
  OrdCond (..),
  genFromAddsSpec,
  genFromNonNegAddsSpec,
  lensAdds,
  sumAdds,
  varOnLeft,
  varOnRight,
 )
import Test.Cardano.Ledger.Constrained.Combinators (
  addUntilSize,
  errorMess,
  fixSet,
  mapFromSubset,
  setSized,
  subMapFromMapWithSize,
  subsetFromSet,
  suchThatErr,
  superSetFromSet,
  superSetFromSetWithSize,
 )
import Test.Cardano.Ledger.Constrained.Env (Access (No), V (..), emptyEnv, storeVar)
import Test.Cardano.Ledger.Constrained.Monad
import Test.Cardano.Ledger.Constrained.Size (
  Size (..),
  atLeastDelta,
  atMostAny,
  genFromIntRange,
  genFromNonNegIntRange,
  genFromSize,
  runSize,
  seps,
  sepsP,
 )
import Test.Cardano.Ledger.Constrained.TypeRep (
  Rep (..),
  format,
  genRep,
  synopsis,
 )
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Generic.Proof (BabbageEra)
import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators ()
import Test.Tasty
import Test.Tasty.QuickCheck hiding (total)

data SomeLens era t where
  SomeLens :: Adds c => (Lens' t c) -> SomeLens era t

-- ===========================================================
{- TODO, possible extensions and improvements, so we don't forget
1) Redo Size with: data Size = SzNever [String] | SzRange Int (Maybe Int) Move to own file
2) Add newtype Never = Never [String], then instead of (XXXNever xs) we use (XX (Never xs))
3) class Specify
4) A better story about fields in constraints. Maybe add FieldSpec type.
-}

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

-- ============================================================
-- Operators for Size (Defined in TypeRep.hs)

maxSize :: Size -> Int
maxSize :: Size -> Int
maxSize Size
SzAny = Int
atMostAny
maxSize (SzLeast Int
i) = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
atLeastDelta
maxSize (SzMost Int
n) = Int
n
maxSize (SzRng Int
_ Int
j) = Int
j
maxSize (SzNever [String]
xs) = String -> [String] -> Int
forall a. HasCallStack => String -> [String] -> a
errorMess String
"SzNever in maxSize" [String]
xs

minSize :: Size -> Int
minSize :: Size -> Int
minSize Size
SzAny = Int
0
minSize (SzLeast Int
n) = Int
n
minSize (SzMost Int
_) = Int
0
minSize (SzRng Int
i Int
_) = Int
i
minSize (SzNever [String]
xs) = String -> [String] -> Int
forall a. HasCallStack => String -> [String] -> a
errorMess String
"SzNever in minSize" [String]
xs

-- | Generate a Size with all positive numbers, This is used where
--   we want Size to denote things that must be >= 0. Coin, Word64, Natural
genSize :: Gen Size
genSize :: Gen Size
genSize =
  [(Int, Gen Size)] -> Gen Size
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, Int -> Size
SzLeast (Int -> Size) -> Gen Int -> Gen Size
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall t. TestAdd t => Gen t
pos)
    , (Int
1, Int -> Size
SzMost (Int -> Size) -> Gen Int -> Gen Size
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
chooseInt (Int
0, Int
atMostAny))
    , (Int
1, (\Int
x -> Int -> Int -> Size
SzRng Int
x Int
x) (Int -> Size) -> Gen Int -> Gen Size
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall t. TestAdd t => Gen t
pos)
    , (Int
1, do Int
lo <- (Int, Int) -> Gen Int
chooseInt (Int
0, Int
atMostAny); Int
hi <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6); Size -> Gen Size
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Size
SzRng Int
lo Int
hi))
    ]

-- | Generate a Size denoting an Int range, across both positive
--   and negative numbers. DeltaCoin, Int, Rational. This is used
--   when we use Size to denote OrdCond on types with negative values
genSizeRange :: Gen Size
genSizeRange :: Gen Size
genSizeRange =
  [(Int, Gen Size)] -> Gen Size
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, Int -> Size
SzLeast (Int -> Size) -> Gen Int -> Gen Size
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
someInt)
    , (Int
1, Int -> Size
SzMost (Int -> Size) -> Gen Int -> Gen Size
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
someInt)
    , (Int
1, (\Int
x -> Int -> Int -> Size
SzRng Int
x Int
x) (Int -> Size) -> Gen Int -> Gen Size
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
someInt)
    , (Int
1, do Int
lo <- Gen Int
someInt; Int
hi <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
atMostAny); Size -> Gen Size
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Size
SzRng Int
lo Int
hi))
    ]
  where
    someInt :: Gen Int
someInt = (Int, Int) -> Gen Int
chooseInt (-Int
atMostAny, Int
atMostAny)

genBigSize :: Int -> Gen Size
genBigSize :: Int -> Gen Size
genBigSize Int
n =
  [(Int, Gen Size)] -> Gen Size
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, Int -> Size
SzLeast (Int -> Size) -> Gen Int -> Gen Size
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
30))
    , -- , (1, SzMost <$> choose (n+60,n+90)) -- Without context, it is impossible to tell how big is OK
      (Int
1, (\Int
x -> Int -> Int -> Size
SzRng Int
x Int
x) (Int -> Size) -> Gen Int -> Gen Size
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
30))
    , (Int
1, do Int
lo <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
30); Int
hi <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
30); Size -> Gen Size
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Size
SzRng Int
lo Int
hi))
    ]

testSoundSize :: Gen Bool
testSoundSize :: Gen Bool
testSoundSize = do
  Size
spec <- Gen Size
genSize
  Int
ans <- Size -> Gen Int
genFromSize Size
spec
  Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Gen Bool) -> Bool -> Gen Bool
forall a b. (a -> b) -> a -> b
$ Int -> Size -> Bool
runSize Int
ans Size
spec

testNonNegSize :: Gen Bool
testNonNegSize :: Gen Bool
testNonNegSize = do
  Size
spec <- Gen Size
genSize
  Int
ans <- Size -> Gen Int
genFromSize Size
spec
  Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Gen Bool) -> Bool -> Gen Bool
forall a b. (a -> b) -> a -> b
$ Int
ans Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0

testMergeSize :: Gen Bool
testMergeSize :: Gen Bool
testMergeSize = do
  Size
spec1 <- Gen Size
genSize
  Size
spec2 <- Gen Size
genSize
  case Size
spec1 Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> Size
spec2 of
    SzNever [String]
_xs -> Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Size
SzAny -> Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Size
spec -> do
      Int
ans <- Size -> Gen Int
genFromSize Size
spec
      Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Gen Bool) -> Bool -> Gen Bool
forall a b. (a -> b) -> a -> b
$ Int -> Size -> Bool
runSize Int
ans Size
spec Bool -> Bool -> Bool
&& Int -> Size -> Bool
runSize Int
ans Size
spec1 Bool -> Bool -> Bool
&& Int -> Size -> Bool
runSize Int
ans Size
spec2

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

genSizeByRep :: forall t era. Adds t => Rep era t -> Gen Size
genSizeByRep :: forall t era. Adds t => Rep era t -> Gen Size
genSizeByRep Rep era t
IntR = Gen Size
genSizeRange
genSizeByRep Rep era t
DeltaCoinR = Gen Size
genSizeRange
genSizeByRep Rep era t
RationalR = Gen Size
genSizeRange
genSizeByRep Rep era t
Word64R = Gen Size
genSize
genSizeByRep Rep era t
CoinR = Gen Size
genSize
genSizeByRep Rep era t
NaturalR = Gen Size
genSize
genSizeByRep Rep era t
r = String -> Gen Size
forall a. HasCallStack => String -> a
error (String
"genSizeByRep " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era t -> String
forall a. Show a => a -> String
show Rep era t
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not have an Adds instance." String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String -> String
forall a b. a -> b -> b
seq (forall x. Adds x => x
zero @t) String
"")

genFromSizeByRep :: forall t era. Adds t => Rep era t -> Size -> Gen Int
genFromSizeByRep :: forall t era. Adds t => Rep era t -> Size -> Gen Int
genFromSizeByRep Rep era t
IntR = Size -> Gen Int
genFromIntRange
genFromSizeByRep Rep era t
DeltaCoinR = Size -> Gen Int
genFromIntRange
genFromSizeByRep Rep era t
RationalR = Size -> Gen Int
genFromIntRange
genFromSizeByRep Rep era t
Word64R = Size -> Gen Int
genFromNonNegIntRange
genFromSizeByRep Rep era t
CoinR = Size -> Gen Int
genFromNonNegIntRange
genFromSizeByRep Rep era t
NaturalR = Size -> Gen Int
genFromNonNegIntRange
genFromSizeByRep Rep era t
r = String -> Size -> Gen Int
forall a. HasCallStack => String -> a
error (String
"genFromSizeByRep " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era t -> String
forall a. Show a => a -> String
show Rep era t
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", does not have an Adds instance." String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String -> String
forall a b. a -> b -> b
seq (forall x. Adds x => x
zero @t) String
"")

data SomeAdd era where Some :: Adds t => Rep era t -> SomeAdd era

instance Show (SomeAdd era) where
  show :: SomeAdd era -> String
show (Some Rep era t
x) = Rep era t -> String
forall a. Show a => a -> String
show Rep era t
x

genAddsRep :: Gen (SomeAdd era)
genAddsRep :: forall era. Gen (SomeAdd era)
genAddsRep = [SomeAdd era] -> Gen (SomeAdd era)
forall a. HasCallStack => [a] -> Gen a
elements [Rep era Int -> SomeAdd era
forall c era. Adds c => Rep era c -> SomeAdd era
Some Rep era Int
forall era. Rep era Int
IntR, Rep era DeltaCoin -> SomeAdd era
forall c era. Adds c => Rep era c -> SomeAdd era
Some Rep era DeltaCoin
forall era. Rep era DeltaCoin
DeltaCoinR, Rep era (Ratio Integer) -> SomeAdd era
forall c era. Adds c => Rep era c -> SomeAdd era
Some Rep era (Ratio Integer)
forall era. Rep era (Ratio Integer)
RationalR, Rep era Word64 -> SomeAdd era
forall c era. Adds c => Rep era c -> SomeAdd era
Some Rep era Word64
forall era. Rep era Word64
Word64R, Rep era Coin -> SomeAdd era
forall c era. Adds c => Rep era c -> SomeAdd era
Some Rep era Coin
forall era. Rep era Coin
CoinR, Rep era Natural -> SomeAdd era
forall c era. Adds c => Rep era c -> SomeAdd era
Some Rep era Natural
forall era. Rep era Natural
NaturalR]

testMergeSize2 :: Gen Property
testMergeSize2 :: Gen Property
testMergeSize2 = do
  Some Rep Any t
rep <- Gen (SomeAdd Any)
forall era. Gen (SomeAdd era)
genAddsRep
  Size
spec1 <- Rep Any t -> Gen Size
forall t era. Adds t => Rep era t -> Gen Size
genSizeByRep Rep Any t
rep
  Size
spec2 <- Rep Any t -> Gen Size
forall t era. Adds t => Rep era t -> Gen Size
genSizeByRep Rep Any t
rep
  case Size
spec1 Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> Size
spec2 of
    SzNever [String]
_xs -> Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    Size
SzAny -> Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    Size
spec -> do
      Int
ans <- Rep Any t -> Size -> Gen Int
forall t era. Adds t => Rep era t -> Size -> Gen Int
genFromSizeByRep Rep Any t
rep Size
spec
      Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$
        String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
          ( String
"at type="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep Any t -> String
forall a. Show a => a -> String
show Rep Any t
rep
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", spec1="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
spec1
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", spec2="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
spec2
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", spec1<>spec2="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
spec
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", ans="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ans
          )
          (Int -> Size -> Bool
runSize Int
ans Size
spec Bool -> Bool -> Bool
&& Int -> Size -> Bool
runSize Int
ans Size
spec1 Bool -> Bool -> Bool
&& Int -> Size -> Bool
runSize Int
ans Size
spec2)

-- =====================================================
-- RelSpec

data RelSpec era dom where
  RelAny ::
    -- | There is no restriction on the set. Denotes the universe.
    RelSpec era dom
  RelNever ::
    -- | Something is inconsistent
    [String] ->
    RelSpec era dom
  -- | Denotes things like: (x == y) equality, (x ⊆ y) subset, ( x ∩ y = ∅) disjointness, (x ⊇ y) superset.
  --   Invariants of r@(RepOper must (Just may) cant)
  -- 1) must is a subset of may
  -- 2) must and may are disjoint from cant
  -- 3) (sizeFromRel r) is realizable E.g.  (SzRng 10 3) is NOT realizable
  RelOper ::
    Ord d =>
    Rep era d ->
    -- | Must set
    Set d ->
    -- | May set, Nothing denotes the universe
    Maybe (Set d) ->
    -- | Can't set
    Set d ->
    RelSpec era d
  -- RelLens :: Ord b => Lens' dom b -> Rep era dom -> Rep era b -> Set b -> RelSpec era dom
  -- Try this
  RelLens :: Ord b => Lens' dom b -> Rep era dom -> Rep era b -> (RelSpec era b) -> RelSpec era dom

relSubset, relSuperset, relDisjoint, relEqual :: Ord t => Rep era t -> Set t -> RelSpec era t
relSubset :: forall t era. Ord t => Rep era t -> Set t -> RelSpec era t
relSubset Rep era t
r Set t
set = Rep era t -> Set t -> Maybe (Set t) -> Set t -> RelSpec era t
forall d era.
Ord d =>
Rep era d -> Set d -> Maybe (Set d) -> Set d -> RelSpec era d
RelOper Rep era t
r Set t
forall a. Set a
Set.empty (Set t -> Maybe (Set t)
forall a. a -> Maybe a
Just Set t
set) Set t
forall a. Set a
Set.empty
relSuperset :: forall t era. Ord t => Rep era t -> Set t -> RelSpec era t
relSuperset Rep era t
r Set t
set = Rep era t -> Set t -> Maybe (Set t) -> Set t -> RelSpec era t
forall d era.
Ord d =>
Rep era d -> Set d -> Maybe (Set d) -> Set d -> RelSpec era d
RelOper Rep era t
r Set t
set Maybe (Set t)
forall a. Maybe a
Nothing Set t
forall a. Set a
Set.empty
relDisjoint :: forall t era. Ord t => Rep era t -> Set t -> RelSpec era t
relDisjoint Rep era t
r Set t
set = Rep era t -> Set t -> Maybe (Set t) -> Set t -> RelSpec era t
forall d era.
Ord d =>
Rep era d -> Set d -> Maybe (Set d) -> Set d -> RelSpec era d
RelOper Rep era t
r Set t
forall a. Set a
Set.empty Maybe (Set t)
forall a. Maybe a
Nothing Set t
set
relEqual :: forall t era. Ord t => Rep era t -> Set t -> RelSpec era t
relEqual Rep era t
r Set t
set = Rep era t -> Set t -> Maybe (Set t) -> Set t -> RelSpec era t
forall d era.
Ord d =>
Rep era d -> Set d -> Maybe (Set d) -> Set d -> RelSpec era d
RelOper Rep era t
r Set t
set (Set t -> Maybe (Set t)
forall a. a -> Maybe a
Just Set t
set) Set t
forall a. Set a
Set.empty

instance Monoid (RelSpec era dom) where
  mempty :: RelSpec era dom
mempty = RelSpec era dom
forall era dom. RelSpec era dom
RelAny

instance Semigroup (RelSpec era dom) where
  <> :: RelSpec era dom -> RelSpec era dom -> RelSpec era dom
(<>) = RelSpec era dom -> RelSpec era dom -> RelSpec era dom
forall era dom.
RelSpec era dom -> RelSpec era dom -> RelSpec era dom
mergeRelSpec

instance Show (RelSpec era dom) where
  show :: RelSpec era dom -> String
show = RelSpec era dom -> String
forall era dom. RelSpec era dom -> String
showRelSpec

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

showRelSpec :: RelSpec era dom -> String
showRelSpec :: forall era dom. RelSpec era dom -> String
showRelSpec RelSpec era dom
RelAny = String
"RelAny"
showRelSpec (RelOper Rep era dom
r Set dom
x (Just Set dom
s) Set dom
y) | Set dom -> Bool
forall a. Set a -> Bool
Set.null Set dom
y Bool -> Bool -> Bool
&& Set dom
x Set dom -> Set dom -> Bool
forall a. Eq a => a -> a -> Bool
== Set dom
s = [String] -> String
sepsP [String
"RelEqual", Rep era (Set dom) -> Set dom -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era dom -> Rep era (Set dom)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era dom
r) Set dom
x]
showRelSpec (RelOper Rep era dom
r Set dom
x (Just Set dom
s) Set dom
y) | Set dom -> Bool
forall a. Set a -> Bool
Set.null Set dom
x Bool -> Bool -> Bool
&& Set dom -> Bool
forall a. Set a -> Bool
Set.null Set dom
y = [String] -> String
sepsP [String
"RelSubset", Rep era (Set dom) -> Set dom -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era dom -> Rep era (Set dom)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era dom
r) Set dom
s]
showRelSpec (RelOper Rep era dom
r Set dom
x Maybe (Set dom)
Nothing Set dom
y) | Set dom -> Bool
forall a. Set a -> Bool
Set.null Set dom
y = [String] -> String
sepsP [String
"RelSuperset", Rep era (Set dom) -> Set dom -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era dom -> Rep era (Set dom)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era dom
r) Set dom
x]
showRelSpec (RelOper Rep era dom
r Set dom
x Maybe (Set dom)
Nothing Set dom
y) | Set dom -> Bool
forall a. Set a -> Bool
Set.null Set dom
x = [String] -> String
sepsP [String
"RelDisjoint", Rep era (Set dom) -> Set dom -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era dom -> Rep era (Set dom)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era dom
r) Set dom
y]
showRelSpec (RelOper Rep era dom
r Set dom
x Maybe (Set dom)
Nothing Set dom
y) = [String] -> String
sepsP [String
"RelOper", Rep era (Set dom) -> Set dom -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era dom -> Rep era (Set dom)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era dom
r) Set dom
x, String
"Univ", Rep era (Set dom) -> Set dom -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era dom -> Rep era (Set dom)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era dom
r) Set dom
y]
showRelSpec (RelOper Rep era dom
r Set dom
x (Just Set dom
y) Set dom
z) = [String] -> String
sepsP [String
"RelOper", Rep era (Set dom) -> Set dom -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era dom -> Rep era (Set dom)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era dom
r) Set dom
x, Rep era (Set dom) -> Set dom -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era dom -> Rep era (Set dom)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era dom
r) Set dom
y, Rep era (Set dom) -> Set dom -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era dom -> Rep era (Set dom)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era dom
r) Set dom
z]
showRelSpec (RelLens Lens' dom b
_ Rep era dom
repd Rep era b
repb RelSpec era b
relsp) = [String] -> String
sepsP [String
"RelLens", String
"(Lens' " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era dom -> String
forall a. Show a => a -> String
show Rep era dom
repd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era b -> String
forall a. Show a => a -> String
show Rep era b
repb String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")", RelSpec era b -> String
forall a. Show a => a -> String
show RelSpec era b
relsp]
showRelSpec (RelNever [String]
_) = String
"RelNever"

mergeRelSpec :: RelSpec era d -> RelSpec era d -> RelSpec era d
mergeRelSpec :: forall era dom.
RelSpec era dom -> RelSpec era dom -> RelSpec era dom
mergeRelSpec (RelNever [String]
xs) (RelNever [String]
ys) = [String] -> RelSpec era d
forall era dom. [String] -> RelSpec era dom
RelNever ([String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ys)
mergeRelSpec d :: RelSpec era d
d@(RelNever [String]
_) RelSpec era d
_ = RelSpec era d
d
mergeRelSpec RelSpec era d
_ d :: RelSpec era d
d@(RelNever [String]
_) = RelSpec era d
d
mergeRelSpec RelSpec era d
RelAny RelSpec era d
x = RelSpec era d
x
mergeRelSpec RelSpec era d
x RelSpec era d
RelAny = RelSpec era d
x
mergeRelSpec RelSpec era d
x y :: RelSpec era d
y@RelLens {} = RelSpec era d -> RelSpec era d -> RelSpec era d
forall era dom.
RelSpec era dom -> RelSpec era dom -> RelSpec era dom
mergeRelSpec RelSpec era d
y RelSpec era d
x
mergeRelSpec a :: RelSpec era d
a@RelLens {} RelSpec era d
b =
  [String] -> RelSpec era d
forall era dom. [String] -> RelSpec era dom
RelNever
    [ String
"merging a=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era d -> String
forall a. Show a => a -> String
show RelSpec era d
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n        b=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era d -> String
forall a. Show a => a -> String
show RelSpec era d
b
    , String
"RelLens is inconsistent with everything, and can't be merged."
    ]
mergeRelSpec a :: RelSpec era d
a@(RelOper Rep era d
r Set d
must1 Maybe (Set d)
may1 Set d
cant1) b :: RelSpec era d
b@(RelOper Rep era d
_ Set d
must2 Maybe (Set d)
may2 Set d
cant2) =
  Typed (RelSpec era d) -> RelSpec era d
forall x. LiftT x => Typed x -> x
dropT (Typed (RelSpec era d) -> RelSpec era d)
-> Typed (RelSpec era d) -> RelSpec era d
forall a b. (a -> b) -> a -> b
$
    String -> Typed (RelSpec era d) -> Typed (RelSpec era d)
forall a. String -> Typed a -> Typed a
explain (String
"merging a=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era d -> String
forall a. Show a => a -> String
show RelSpec era d
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n        b=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era d -> String
forall a. Show a => a -> String
show RelSpec era d
b) (Typed (RelSpec era d) -> Typed (RelSpec era d))
-> Typed (RelSpec era d) -> Typed (RelSpec era d)
forall a b. (a -> b) -> a -> b
$
      [(Bool, [String])]
-> Typed (RelSpec era d) -> Typed (RelSpec era d)
forall a. [(Bool, [String])] -> Typed a -> Typed a
requireAll
        [
          ( Set d -> Set d -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set d
must1 Set d
cant2
          ,
            [ String
"The 'must' set of a("
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era d -> Set d -> String
forall t era. Ord t => Rep era t -> Set t -> String
synSet Rep era d
r Set d
must1
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") is not disjoint from the 'cant' set of b("
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era d -> Set d -> String
forall t era. Ord t => Rep era t -> Set t -> String
synSet Rep era d
r Set d
cant2
            ]
          )
        ,
          ( Set d -> Set d -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set d
must2 Set d
cant1
          ,
            [ String
"The 'must' set of b("
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era d -> Set d -> String
forall t era. Ord t => Rep era t -> Set t -> String
synSet Rep era d
r Set d
must2
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") is not disjoint from the 'cant' set of a("
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era d -> Set d -> String
forall t era. Ord t => Rep era t -> Set t -> String
synSet Rep era d
r Set d
cant1
            ]
          )
        ]
        (Rep era d
-> Set d -> Maybe (Set d) -> Set d -> Typed (RelSpec era d)
forall d era.
Ord d =>
Rep era d
-> Set d -> Maybe (Set d) -> Set d -> Typed (RelSpec era d)
relOper Rep era d
r Set d
must Maybe (Set d)
may Set d
cant)
  where
    must :: Set d
must = Set d -> Set d -> Set d
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set d
must1 Set d
must2
    cant :: Set d
cant = Set d -> Set d -> Set d
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set d
cant1 Set d
cant2
    may :: Maybe (Set d)
may = (Set d -> Set d -> Set d
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set d
cant) (Set d -> Set d) -> Maybe (Set d) -> Maybe (Set d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Set d) -> Maybe (Set d) -> Maybe (Set d)
forall a. Ord a => Maybe (Set a) -> Maybe (Set a) -> Maybe (Set a)
interSectM Maybe (Set d)
may1 Maybe (Set d)
may2

-- ==================
-- Helper functions for defining mergeRelSpec and
-- for testing and maintaining RelSpec invariants

-- | The interpretation of (Just set) is set, and of Nothing is the universe (all possible sets)
interSectM :: Ord a => Maybe (Set a) -> Maybe (Set a) -> Maybe (Set a)
interSectM :: forall a. Ord a => Maybe (Set a) -> Maybe (Set a) -> Maybe (Set a)
interSectM Maybe (Set a)
Nothing Maybe (Set a)
Nothing = Maybe (Set a)
forall a. Maybe a
Nothing
interSectM Maybe (Set a)
Nothing Maybe (Set a)
x = Maybe (Set a)
x
interSectM Maybe (Set a)
x Maybe (Set a)
Nothing = Maybe (Set a)
x
interSectM (Just Set a
x) (Just Set a
y) = Set a -> Maybe (Set a)
forall a. a -> Maybe a
Just (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set a
x Set a
y)

-- | Test if 's1' is a subset of 's2'
--   Recall, if s2==Nothing, then it denotes the universe
--   and every set is a subset of the universe.
univSubset :: Ord a => Set a -> Maybe (Set a) -> Bool
univSubset :: forall a. Ord a => Set a -> Maybe (Set a) -> Bool
univSubset Set a
_ Maybe (Set a)
Nothing = Bool
True
univSubset Set a
s1 (Just Set a
s2) = Set a -> Set a -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set a
s1 Set a
s2

okSize :: RelSpec era d -> Bool
okSize :: forall era d. RelSpec era d -> Bool
okSize (RelOper Rep era d
_ Set d
must (Just Set d
may) Set d
cant) =
  Set d -> Int
forall a. Set a -> Int
Set.size Set d
must Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Set d -> Int
forall a. Set a -> Int
Set.size (Set d -> Set d -> Set d
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set d
may Set d
cant)
okSize RelSpec era d
_ = Bool
True

-- | Compute the Size that bounds the Size of a set generated from a RelSpec
sizeForRel :: RelSpec era dom -> Size
sizeForRel :: forall era dom. RelSpec era dom -> Size
sizeForRel RelSpec era dom
RelAny = Size
SzAny
sizeForRel (RelNever [String]
_) = Size
SzAny
sizeForRel (RelOper Rep era dom
_ Set dom
must Maybe (Set dom)
Nothing Set dom
_) = Int -> Size
SzLeast (Set dom -> Int
forall a. Set a -> Int
Set.size Set dom
must)
sizeForRel (RelOper Rep era dom
_ Set dom
must (Just Set dom
may) Set dom
_) | Set dom -> Bool
forall a. Set a -> Bool
Set.null Set dom
must = Int -> Size
SzMost (Set dom -> Int
forall a. Set a -> Int
Set.size Set dom
may)
sizeForRel (RelOper Rep era dom
_ Set dom
must (Just Set dom
may) Set dom
cant) = Int -> Int -> Size
SzRng (Set dom -> Int
forall a. Set a -> Int
Set.size Set dom
must) (Set dom -> Int
forall a. Set a -> Int
Set.size (Set dom -> Set dom -> Set dom
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set dom
may Set dom
cant))
sizeForRel (RelLens Lens' dom b
_ Rep era dom
_ Rep era b
_ RelSpec era b
spec) = RelSpec era b -> Size
forall era dom. RelSpec era dom -> Size
sizeForRel RelSpec era b
spec

maybeSynopsis :: Rep e t -> Maybe t -> String
maybeSynopsis :: forall e t. Rep e t -> Maybe t -> String
maybeSynopsis Rep e t
r (Just t
x) = Rep e t -> t -> String
forall e t. Rep e t -> t -> String
format Rep e t
r t
x
maybeSynopsis Rep e t
_ Maybe t
_ = String
""

synSet :: Ord t => Rep era t -> Set t -> String
synSet :: forall t era. Ord t => Rep era t -> Set t -> String
synSet Rep era t
r Set t
s = Rep era (Set t) -> Set t -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era t -> Rep era (Set t)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era t
r) Set t
s

-- | Check that RelSpec invariants on the constructor RelOper hold on: spec@(RelOper must may cant)
--   1)  must ⊆ may, checked by 'univSubset must may'
--   2)  (must ∩ cant = ∅), checked by 'Set.disjoint must cant'
--   3)  Set.size must <= Set.size (Set.difference may cant), checked by 'okSize spec'
relOper :: Ord d => Rep era d -> Set d -> Maybe (Set d) -> Set d -> Typed (RelSpec era d)
relOper :: forall d era.
Ord d =>
Rep era d
-> Set d -> Maybe (Set d) -> Set d -> Typed (RelSpec era d)
relOper Rep era d
r Set d
must Maybe (Set d)
may Set d
cant =
  let potential :: RelSpec era d
potential = Rep era d -> Set d -> Maybe (Set d) -> Set d -> RelSpec era d
forall d era.
Ord d =>
Rep era d -> Set d -> Maybe (Set d) -> Set d -> RelSpec era d
RelOper Rep era d
r Set d
must Maybe (Set d)
may Set d
cant
   in String -> Typed (RelSpec era d) -> Typed (RelSpec era d)
forall a. String -> Typed a -> Typed a
explain
        (String
"Checking RelSpec self consistency\n   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era d -> String
forall a. Show a => a -> String
show (Rep era d -> Set d -> Maybe (Set d) -> Set d -> RelSpec era d
forall d era.
Ord d =>
Rep era d -> Set d -> Maybe (Set d) -> Set d -> RelSpec era d
RelOper Rep era d
r Set d
must Maybe (Set d)
may Set d
cant))
        ( [(Bool, [String])]
-> Typed (RelSpec era d) -> Typed (RelSpec era d)
forall a. [(Bool, [String])] -> Typed a -> Typed a
requireAll
            [
              ( Set d -> Maybe (Set d) -> Bool
forall a. Ord a => Set a -> Maybe (Set a) -> Bool
univSubset Set d
must Maybe (Set d)
may
              ,
                [ String
"'must' "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Set d) -> Set d -> String
forall e t. Rep e t -> t -> String
format (Rep era d -> Rep era (Set d)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era d
r) Set d
must
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Is not a subset of: 'may' "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Set d) -> Maybe (Set d) -> String
forall e t. Rep e t -> Maybe t -> String
maybeSynopsis (Rep era d -> Rep era (Set d)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era d
r) Maybe (Set d)
may
                ]
              )
            ,
              ( Set d -> Set d -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set d
must Set d
cant
              ,
                [ String
"'must' "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Set d) -> Set d -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era d -> Rep era (Set d)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era d
r) Set d
must
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Is not disjoint from: 'cant' "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Set d) -> Set d -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era d -> Rep era (Set d)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era d
r) Set d
cant
                ]
              )
            ,
              ( Bool -> (Set d -> Bool) -> Maybe (Set d) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\Set d
may' -> Set d -> Set d -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set d
may' Set d
cant) Maybe (Set d)
may
              ,
                [ String
"'may' "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Set d -> String) -> Maybe (Set d) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"Nothing" (Rep era (Set d) -> Set d -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era (Set d) -> Set d -> String)
-> Rep era (Set d) -> Set d -> String
forall a b. (a -> b) -> a -> b
$ Rep era d -> Rep era (Set d)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era d
r) Maybe (Set d)
may
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Is not disjoint from: 'cant' "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Set d) -> Set d -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era d -> Rep era (Set d)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era d
r) Set d
cant
                ]
              )
            ,
              ( RelSpec era d -> Bool
forall era d. RelSpec era d -> Bool
okSize RelSpec era d
potential
              , case RelSpec era d
potential of
                  rel :: RelSpec era d
rel@(RelOper Rep era d
_ Set d
_ (Just Set d
mayJ) Set d
_) ->
                    [ RelSpec era d -> String
forall a. Show a => a -> String
show RelSpec era d
potential String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has unrealizable size " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (RelSpec era d -> Size
forall era dom. RelSpec era dom -> Size
sizeForRel RelSpec era d
rel)
                    , String
"size must("
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Set d -> Int
forall a. Set a -> Int
Set.size Set d
must)
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") > size(mayJ - cant)("
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Set d -> Int
forall a. Set a -> Int
Set.size (Set d -> Set d -> Set d
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set d
mayJ Set d
cant))
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
                    ]
                  RelSpec era d
_ -> []
              )
            ]
            (RelSpec era d -> Typed (RelSpec era d)
forall a. a -> Typed a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RelSpec era d
potential)
        )

-- ==============================================
-- The standard operations on RelSpec
-- runRelSpec, genFromRelSpec, genRelSpec

-- | test that a set 's' meets the RelSpec
runRelSpec :: Ord t => Set t -> RelSpec era t -> Bool
runRelSpec :: forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec Set t
_ RelSpec era t
RelAny = Bool
True
runRelSpec Set t
_ (RelNever [String]
xs) = String -> [String] -> Bool
forall a. HasCallStack => String -> [String] -> a
errorMess String
"RelNever in call to runRelSpec" [String]
xs
runRelSpec Set t
s (RelOper Rep era t
_ Set t
must Maybe (Set t)
Nothing Set t
cant) = Set t -> Set t -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set t
must Set t
s Bool -> Bool -> Bool
&& Set t -> Set t -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set t
s Set t
cant
runRelSpec Set t
s (RelOper Rep era t
_ Set t
must (Just Set t
may) Set t
cant) = Set t -> Set t -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set t
must Set t
s Bool -> Bool -> Bool
&& Set t -> Set t -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set t
s Set t
may Bool -> Bool -> Bool
&& Set t -> Set t -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set t
s Set t
cant
runRelSpec Set t
s (RelLens Lens' t b
lensdb Rep era t
_ Rep era b
_ RelSpec era b
spec) = Set b -> RelSpec era b -> Bool
forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec ((t -> b) -> Set t -> Set b
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\t
x -> t
x t -> Getting b t b -> b
forall s a. s -> Getting a s a -> a
^. Getting b t b
Lens' t b
lensdb) Set t
s) RelSpec era b
spec

-- | return a generator that always generates things that meet the RelSpec
genFromRelSpec ::
  forall era t. (Era era, Ord t) => [String] -> Gen t -> Int -> RelSpec era t -> Gen (Set t)
genFromRelSpec :: forall era t.
(Era era, Ord t) =>
[String] -> Gen t -> Int -> RelSpec era t -> Gen (Set t)
genFromRelSpec [String]
msgs Gen t
g Int
n RelSpec era t
spec =
  let msg :: String
msg = String
"genFromRelSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era t -> String
forall a. Show a => a -> String
show RelSpec era t
spec
   in case RelSpec era t
spec of
        RelNever [String]
xs -> String -> [String] -> Gen (Set t)
forall a. HasCallStack => String -> [String] -> a
errorMess String
"RelNever in genFromSpecT" ([String]
msgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
xs)
        RelSpec era t
RelAny -> [String] -> Int -> Gen t -> Gen (Set t)
forall a. Ord a => [String] -> Int -> Gen a -> Gen (Set a)
setSized (String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Int
n Gen t
g
        RelOper Rep era t
_ Set t
must (Just Set t
may) Set t
cant | Set t
must Set t -> Set t -> Bool
forall a. Eq a => a -> a -> Bool
== Set t
may Bool -> Bool -> Bool
&& Set t -> Bool
forall a. Set a -> Bool
Set.null Set t
cant -> Set t -> Gen (Set t)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set t
must -- The is the (relEqual r s) case
        RelOper Rep era t
_ Set t
must Maybe (Set t)
Nothing Set t
dis ->
          -- add things (not in cant) to 'must' until you get to size 'n'
          [String] -> Int -> Int -> Gen t -> Set t -> Gen (Set t)
forall a.
Ord a =>
[String] -> Int -> Int -> Gen a -> Set a -> Gen (Set a)
fixSet (String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Int
1000 Int
n ([String] -> Gen t -> (t -> Bool) -> Gen t
forall a. [String] -> Gen a -> (a -> Bool) -> Gen a
suchThatErr (String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Gen t
g (t -> Set t -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set t
dis)) Set t
must
        RelOper Rep era t
_ Set t
must (Just Set t
may) Set t
dis ->
          let choices :: Set t
choices = Set t -> Set t -> Set t
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set t
may Set t
dis
              m :: Int
m = Set t -> Int
forall a. Set a -> Int
Set.size Set t
choices
           in -- add things (from choices) to 'must' until you get to size 'n'
              case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
m Int
n of
                Ordering
EQ -> Set t -> Gen (Set t)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set t
choices
                Ordering
LT ->
                  String -> [String] -> Gen (Set t)
forall a. HasCallStack => String -> [String] -> a
errorMess
                    ( String
"Size inconsistency. We need "
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". The most we can get from (may-cant) is "
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
m
                    )
                    (String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs)
                Ordering
GT -> [String] -> Set t -> Set t -> Int -> Gen (Set t)
forall a. Ord a => [String] -> Set a -> Set a -> Int -> Gen (Set a)
addUntilSize (String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Set t
must Set t
choices Int
n
        RelLens Lens' t b
lensDB Rep era t
repD Rep era b
repB RelSpec era b
specB -> do
          -- This case supercedes the "projOnDom" function.
          Set b
setB <- [String] -> Gen b -> Int -> RelSpec era b -> Gen (Set b)
forall era t.
(Era era, Ord t) =>
[String] -> Gen t -> Int -> RelSpec era t -> Gen (Set t)
genFromRelSpec [String]
msgs (Rep era b -> Gen b
forall era b. Rep era b -> Gen b
genRep Rep era b
repB) Int
n RelSpec era b
specB
          -- Generate (Set B), we will use these, to fixup a (Set D)
          -- where we overwrite the B field of D
          let accum :: Gen (Set t) -> b -> Gen (Set t)
accum Gen (Set t)
ansG b
b =
                do
                  Set t
ans <- Gen (Set t)
ansG
                  t
d <- Rep era t -> Gen t
forall era b. Rep era b -> Gen b
genRep Rep era t
repD -- Generate the D
                  Set t -> Gen (Set t)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set t -> Gen (Set t)) -> Set t -> Gen (Set t)
forall a b. (a -> b) -> a -> b
$ t -> Set t -> Set t
forall a. Ord a => a -> Set a -> Set a
Set.insert (t
d t -> (t -> t) -> t
forall a b. a -> (a -> b) -> b
& (b -> Identity b) -> t -> Identity t
Lens' t b
lensDB ((b -> Identity b) -> t -> Identity t) -> b -> t -> t
forall s t a b. ASetter s t a b -> b -> s -> t
.~ b
b) Set t
ans
          -- Overwrite the B field of D, and insert the changed value D{B=b}
          (Gen (Set t) -> b -> Gen (Set t))
-> Gen (Set t) -> Set b -> Gen (Set t)
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' Gen (Set t) -> b -> Gen (Set t)
accum (Set t -> Gen (Set t)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set t
forall a. Set a
Set.empty) Set b
setB

-- | Generate a random RelSpec
--   We deliberately do NOT generate RelLens, as it is inconsistent with everything.
genRelSpec :: Ord dom => [String] -> Gen dom -> Rep era dom -> Int -> Gen (RelSpec era dom)
genRelSpec :: forall dom era.
Ord dom =>
[String] -> Gen dom -> Rep era dom -> Int -> Gen (RelSpec era dom)
genRelSpec [String]
_ Gen dom
_ Rep era dom
r Int
0 = RelSpec era dom -> Gen (RelSpec era dom)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelSpec era dom -> Gen (RelSpec era dom))
-> RelSpec era dom -> Gen (RelSpec era dom)
forall a b. (a -> b) -> a -> b
$ Rep era dom -> Set dom -> RelSpec era dom
forall t era. Ord t => Rep era t -> Set t -> RelSpec era t
relEqual Rep era dom
r Set dom
forall a. Set a
Set.empty
genRelSpec [String]
msg Gen dom
genD Rep era dom
r Int
n = do
  Int
smaller <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
2 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
  Int
larger <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7)
  let msgs :: [String]
msgs =
        ([String] -> String
sepsP [String
"genRelSpec ", Int -> String
forall a. Show a => a -> String
show Int
n, Rep era dom -> String
forall a. Show a => a -> String
show Rep era dom
r, String
" smaller=", Int -> String
forall a. Show a => a -> String
show Int
smaller, String
", larger=", Int -> String
forall a. Show a => a -> String
show Int
larger]) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msg
  [(Int, Gen (RelSpec era dom))] -> Gen (RelSpec era dom)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [
      ( Int
1
      , do
          Set dom
must <- [String] -> Int -> Gen dom -> Gen (Set dom)
forall a. Ord a => [String] -> Int -> Gen a -> Gen (Set a)
setSized (String
"must of RelOper Nothing" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Int
smaller Gen dom
genD
          Set dom
dis <-
            Gen dom -> Gen (Set dom)
forall t. Ord t => Gen t -> Gen (Set t)
someSet
              ([String] -> Gen dom -> (dom -> Bool) -> Gen dom
forall a. [String] -> Gen a -> (a -> Bool) -> Gen a
suchThatErr ((String
"dis of RelOper Nothing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era dom -> Set dom -> String
forall t era. Ord t => Rep era t -> Set t -> String
synSet Rep era dom
r Set dom
must) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Gen dom
genD (dom -> Set dom -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set dom
must))
          Typed (RelSpec era dom) -> Gen (RelSpec era dom)
forall (m :: * -> *) t. (HasCallStack, Monad m) => Typed t -> m t
monadTyped (Rep era dom
-> Set dom -> Maybe (Set dom) -> Set dom -> Typed (RelSpec era dom)
forall d era.
Ord d =>
Rep era d
-> Set d -> Maybe (Set d) -> Set d -> Typed (RelSpec era d)
relOper Rep era dom
r Set dom
must Maybe (Set dom)
forall a. Maybe a
Nothing Set dom
dis)
      )
    ,
      ( Int
2
      , do
          Set dom
must <- [String] -> Int -> Gen dom -> Gen (Set dom)
forall a. Ord a => [String] -> Int -> Gen a -> Gen (Set a)
setSized (String
"must of RelOper Just" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Int
smaller Gen dom
genD
          Set dom
may <- [String] -> Int -> Gen dom -> Set dom -> Gen (Set dom)
forall a. Ord a => [String] -> Int -> Gen a -> Set a -> Gen (Set a)
superSetFromSetWithSize (String
"may of RelOper Just" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Int
larger Gen dom
genD Set dom
must
          Set dom
dis <-
            [String] -> Int -> Gen dom -> Gen (Set dom)
forall a. Ord a => [String] -> Int -> Gen a -> Gen (Set a)
setSized
              (String
"dis of RelOper Some" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs)
              Int
3
              ( [String] -> Gen dom -> (dom -> Bool) -> Gen dom
forall a. [String] -> Gen a -> (a -> Bool) -> Gen a
suchThatErr
                  ((String
"dis of RelOper Some must=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era dom -> Set dom -> String
forall t era. Ord t => Rep era t -> Set t -> String
synSet Rep era dom
r Set dom
must String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" may=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era dom -> Set dom -> String
forall t era. Ord t => Rep era t -> Set t -> String
synSet Rep era dom
r Set dom
may) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs)
                  Gen dom
genD
                  (dom -> Set dom -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set dom
may)
              )
          Typed (RelSpec era dom) -> Gen (RelSpec era dom)
forall (m :: * -> *) t. (HasCallStack, Monad m) => Typed t -> m t
monadTyped (Rep era dom
-> Set dom -> Maybe (Set dom) -> Set dom -> Typed (RelSpec era dom)
forall d era.
Ord d =>
Rep era d
-> Set d -> Maybe (Set d) -> Set d -> Typed (RelSpec era d)
relOper Rep era dom
r Set dom
must (Set dom -> Maybe (Set dom)
forall a. a -> Maybe a
Just Set dom
may) Set dom
dis)
      )
    , (Int
1, RelSpec era dom -> Gen (RelSpec era dom)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RelSpec era dom
forall era dom. RelSpec era dom
RelAny)
    ]

-- | Generate another set which is disjoint from the input 'set'
--   Note that the empty set is always a solution.
--   These sets tend to be rather small (size <= atLeastDelta)
genDisjoint :: Ord a => Set a -> Gen a -> Gen (Set a)
genDisjoint :: forall a. Ord a => Set a -> Gen a -> Gen (Set a)
genDisjoint Set a
set Gen a
gen = Int -> Set a -> Gen (Set a)
help Int
atLeastDelta Set a
forall a. Set a
Set.empty
  where
    help :: Int -> Set a -> Gen (Set a)
help Int
n !Set a
answer | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Set a -> Gen (Set a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set a
answer
    help Int
n !Set a
answer = do
      a
x <- Gen a
gen
      Int -> Set a -> Gen (Set a)
help (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (if a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member a
x Set a
set then Set a
answer else a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
answer)

-- | Generate another RelSpec, guaranteed to be consistent with the input
--   Where (consistent a b) means:  (a <> b) =/= (RelNever _)
--   See the property test 'genConsistent'
genConsistentRelSpec :: [String] -> Gen dom -> RelSpec era dom -> Gen (RelSpec era dom)
genConsistentRelSpec :: forall dom era.
[String] -> Gen dom -> RelSpec era dom -> Gen (RelSpec era dom)
genConsistentRelSpec [String]
msg Gen dom
g RelSpec era dom
x = case RelSpec era dom
x of
  r :: RelSpec era dom
r@(RelLens {}) -> String -> Gen (RelSpec era dom)
forall a. HasCallStack => String -> a
error (String
"Can't generate a consistent spec for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era dom -> String
forall a. Show a => a -> String
show RelSpec era dom
r)
  RelOper Rep era dom
r Set dom
must Maybe (Set dom)
Nothing Set dom
cant ->
    [(Int, Gen (RelSpec era dom))] -> Gen (RelSpec era dom)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, RelSpec era dom -> Gen (RelSpec era dom)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RelSpec era dom
forall era dom. RelSpec era dom
RelAny)
      ,
        ( Int
1
        , do
            Set dom
cant2 <- Set dom -> Gen dom -> Gen (Set dom)
forall a. Ord a => Set a -> Gen a -> Gen (Set a)
genDisjoint Set dom
must Gen dom
g
            Set dom
must2 <- Set dom -> Gen dom -> Gen (Set dom)
forall a. Ord a => Set a -> Gen a -> Gen (Set a)
genDisjoint (Set dom
cant Set dom -> Set dom -> Set dom
forall a. Semigroup a => a -> a -> a
<> Set dom
cant2) Gen dom
g
            RelSpec era dom -> Gen (RelSpec era dom)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelSpec era dom -> Gen (RelSpec era dom))
-> RelSpec era dom -> Gen (RelSpec era dom)
forall a b. (a -> b) -> a -> b
$ Rep era dom
-> Set dom -> Maybe (Set dom) -> Set dom -> RelSpec era dom
forall d era.
Ord d =>
Rep era d -> Set d -> Maybe (Set d) -> Set d -> RelSpec era d
RelOper Rep era dom
r Set dom
must2 Maybe (Set dom)
forall a. Maybe a
Nothing Set dom
cant2
        )
      ,
        ( Int
1
        , do
            Set dom
may2 <- (Set dom -> Set dom -> Set dom
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set dom
cant) (Set dom -> Set dom) -> Gen (Set dom) -> Gen (Set dom)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen dom -> Set dom -> Gen (Set dom)
forall a. Ord a => Gen a -> Set a -> Gen (Set a)
superSetFromSet Gen dom
g Set dom
must
            Set dom
must2 <- [String] -> Set dom -> Gen (Set dom)
forall a. Ord a => [String] -> Set a -> Gen (Set a)
subsetFromSet ((RelSpec era dom -> String
forall a. Show a => a -> String
show RelSpec era dom
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" gen may") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Set dom
must
            Set dom
cant2 <- Set dom -> Gen dom -> Gen (Set dom)
forall a. Ord a => Set a -> Gen a -> Gen (Set a)
genDisjoint Set dom
may2 Gen dom
g
            RelSpec era dom -> Gen (RelSpec era dom)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelSpec era dom -> Gen (RelSpec era dom))
-> RelSpec era dom -> Gen (RelSpec era dom)
forall a b. (a -> b) -> a -> b
$ Rep era dom
-> Set dom -> Maybe (Set dom) -> Set dom -> RelSpec era dom
forall d era.
Ord d =>
Rep era d -> Set d -> Maybe (Set d) -> Set d -> RelSpec era d
RelOper Rep era dom
r Set dom
must2 (Set dom -> Maybe (Set dom)
forall a. a -> Maybe a
Just Set dom
may2) Set dom
cant2
        )
      ]
  RelOper Rep era dom
r Set dom
must (Just Set dom
may) Set dom
cant ->
    [(Int, Gen (RelSpec era dom))] -> Gen (RelSpec era dom)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, RelSpec era dom -> Gen (RelSpec era dom)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RelSpec era dom
forall era dom. RelSpec era dom
RelAny)
      ,
        ( Int
1
        , do
            Set dom
cant2 <- Set dom -> Gen dom -> Gen (Set dom)
forall a. Ord a => Set a -> Gen a -> Gen (Set a)
genDisjoint Set dom
may Gen dom
g
            Set dom
must2 <- [String] -> Set dom -> Gen (Set dom)
forall a. Ord a => [String] -> Set a -> Gen (Set a)
subsetFromSet ((RelSpec era dom -> String
forall a. Show a => a -> String
show RelSpec era dom
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" gen must") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Set dom
may
            RelSpec era dom -> Gen (RelSpec era dom)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelSpec era dom -> Gen (RelSpec era dom))
-> RelSpec era dom -> Gen (RelSpec era dom)
forall a b. (a -> b) -> a -> b
$ Rep era dom
-> Set dom -> Maybe (Set dom) -> Set dom -> RelSpec era dom
forall d era.
Ord d =>
Rep era d -> Set d -> Maybe (Set d) -> Set d -> RelSpec era d
RelOper Rep era dom
r Set dom
must2 Maybe (Set dom)
forall a. Maybe a
Nothing Set dom
cant2
        )
      ,
        ( Int
1
        , do
            Set dom
may2 <- (Set dom -> Set dom -> Set dom
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set dom
cant) (Set dom -> Set dom) -> Gen (Set dom) -> Gen (Set dom)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen dom -> Set dom -> Gen (Set dom)
forall a. Ord a => Gen a -> Set a -> Gen (Set a)
superSetFromSet Gen dom
g Set dom
must
            Set dom
must2 <- [String] -> Set dom -> Gen (Set dom)
forall a. Ord a => [String] -> Set a -> Gen (Set a)
subsetFromSet ((RelSpec era dom -> String
forall a. Show a => a -> String
show RelSpec era dom
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" gen must") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Set dom
must
            Set dom
cant2 <- Set dom -> Gen dom -> Gen (Set dom)
forall a. Ord a => Set a -> Gen a -> Gen (Set a)
genDisjoint (Set dom
may Set dom -> Set dom -> Set dom
forall a. Semigroup a => a -> a -> a
<> Set dom
may2) Gen dom
g
            RelSpec era dom -> Gen (RelSpec era dom)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelSpec era dom -> Gen (RelSpec era dom))
-> RelSpec era dom -> Gen (RelSpec era dom)
forall a b. (a -> b) -> a -> b
$ Rep era dom
-> Set dom -> Maybe (Set dom) -> Set dom -> RelSpec era dom
forall d era.
Ord d =>
Rep era d -> Set d -> Maybe (Set d) -> Set d -> RelSpec era d
RelOper Rep era dom
r Set dom
must2 (Set dom -> Maybe (Set dom)
forall a. a -> Maybe a
Just (Set dom
may Set dom -> Set dom -> Set dom
forall a. Semigroup a => a -> a -> a
<> Set dom
may2)) Set dom
cant2
        )
      ]
  RelSpec era dom
RelAny -> RelSpec era dom -> Gen (RelSpec era dom)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RelSpec era dom
forall era dom. RelSpec era dom
RelAny
  RelNever [String]
_ -> String -> Gen (RelSpec era dom)
forall a. HasCallStack => String -> a
error String
"RelNever in genConsistentRelSpec"
  where
    msgs :: [String]
msgs = (String
"genConsistentRelSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era dom -> String
forall a. Show a => a -> String
show RelSpec era dom
x) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msg

-- ==================
-- Actual property tests for Relpec

testConsistentRel :: Gen Property
testConsistentRel :: Gen Property
testConsistentRel = do
  Int
n <- (Int, Int) -> Gen Int
chooseInt (Int
3, Int
10)
  RelSpec Any Int
s1 <- [String] -> Gen Int -> Rep Any Int -> Int -> Gen (RelSpec Any Int)
forall dom era.
Ord dom =>
[String] -> Gen dom -> Rep era dom -> Int -> Gen (RelSpec era dom)
genRelSpec [String
"testConsistentRel " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n] ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
10000)) Rep Any Int
forall era. Rep era Int
IntR Int
n
  RelSpec Any Int
s2 <- [String] -> Gen Int -> RelSpec Any Int -> Gen (RelSpec Any Int)
forall dom era.
[String] -> Gen dom -> RelSpec era dom -> Gen (RelSpec era dom)
genConsistentRelSpec [String
"testConsistentRel " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec Any Int -> String
forall a. Show a => a -> String
show RelSpec Any Int
s1] ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
1000)) RelSpec Any Int
s1
  case RelSpec Any Int
s1 RelSpec Any Int -> RelSpec Any Int -> RelSpec Any Int
forall a. Semigroup a => a -> a -> a
<> RelSpec Any Int
s2 of
    RelNever [String]
ms -> Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([String] -> String
unlines ([String
"genConsistent fails", RelSpec Any Int -> String
forall a. Show a => a -> String
show RelSpec Any Int
s1, RelSpec Any Int -> String
forall a. Show a => a -> String
show RelSpec Any Int
s2] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ms)) Bool
False
    RelSpec Any Int
_ -> Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True

testSoundRelSpec :: Gen Property
testSoundRelSpec :: Gen Property
testSoundRelSpec = do
  Int
n <- (Int, Int) -> Gen Int
chooseInt (Int
3, Int
10)
  RelSpec BabbageEra Word64
s1 <- [String]
-> Gen Word64
-> Rep BabbageEra Word64
-> Int
-> Gen (RelSpec BabbageEra Word64)
forall dom era.
Ord dom =>
[String] -> Gen dom -> Rep era dom -> Int -> Gen (RelSpec era dom)
genRelSpec [String
"from testSoundRelSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n] ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
10000)) Rep BabbageEra Word64
forall era. Rep era Word64
Word64R Int
n
  Set Word64
ans <- forall era t.
(Era era, Ord t) =>
[String] -> Gen t -> Int -> RelSpec era t -> Gen (Set t)
genFromRelSpec @BabbageEra [String
"from testSoundRelSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n] ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
100000)) Int
n RelSpec BabbageEra Word64
s1
  Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"spec=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RelSpec BabbageEra Word64
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nans=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Set Word64 -> String
forall a. Show a => a -> String
show Set Word64
ans) (Set Word64 -> RelSpec BabbageEra Word64 -> Bool
forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec Set Word64
ans RelSpec BabbageEra Word64
s1)

testMergeRelSpec :: Gen Property
testMergeRelSpec :: Gen Property
testMergeRelSpec = do
  let msg :: [String]
msg = [String
"testMergeRelSpec"]
  Int
n <- (Int, Int) -> Gen Int
chooseInt (Int
0, Int
10)
  RelSpec BabbageEra Word64
s1 <- [String]
-> Gen Word64
-> Rep BabbageEra Word64
-> Int
-> Gen (RelSpec BabbageEra Word64)
forall dom era.
Ord dom =>
[String] -> Gen dom -> Rep era dom -> Int -> Gen (RelSpec era dom)
genRelSpec ((String
"genRelSpec") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msg) ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
10000)) Rep BabbageEra Word64
forall era. Rep era Word64
Word64R Int
n
  RelSpec BabbageEra Word64
s2 <- [String]
-> Gen Word64
-> RelSpec BabbageEra Word64
-> Gen (RelSpec BabbageEra Word64)
forall dom era.
[String] -> Gen dom -> RelSpec era dom -> Gen (RelSpec era dom)
genConsistentRelSpec ((String
"genConsistentRepSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RelSpec BabbageEra Word64
s1) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msg) ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
1000)) RelSpec BabbageEra Word64
s1
  case RelSpec BabbageEra Word64
s1 RelSpec BabbageEra Word64
-> RelSpec BabbageEra Word64 -> RelSpec BabbageEra Word64
forall a. Semigroup a => a -> a -> a
<> RelSpec BabbageEra Word64
s2 of
    RelNever [String]
_ -> Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True) -- This test is an implication (consistent (s1 <> s2) => ...)
    RelSpec BabbageEra Word64
s4 -> do
      let size :: Size
size = RelSpec BabbageEra Word64 -> Size
forall era dom. RelSpec era dom -> Size
sizeForRel RelSpec BabbageEra Word64
s4
      Int
m <- Size -> Gen Int
genFromSize Size
size
      Set Word64
ans <-
        forall era t.
(Era era, Ord t) =>
[String] -> Gen t -> Int -> RelSpec era t -> Gen (Set t)
genFromRelSpec @BabbageEra
          [String
"testMergeRelSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RelSpec BabbageEra Word64
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RelSpec BabbageEra Word64
s2]
          ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
1000))
          Int
m
          RelSpec BabbageEra Word64
s4
      Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$
        String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
          ( String
"s1="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RelSpec BabbageEra Word64
s1
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\ns2="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RelSpec BabbageEra Word64
s2
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\ns1<>s2="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RelSpec BabbageEra Word64
s4
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nans="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Set Word64 -> String
forall a. Show a => a -> String
show Set Word64
ans
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nrun s1="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (Set Word64 -> RelSpec BabbageEra Word64 -> Bool
forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec Set Word64
ans RelSpec BabbageEra Word64
s1)
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nrun s2="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (Set Word64 -> RelSpec BabbageEra Word64 -> Bool
forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec Set Word64
ans RelSpec BabbageEra Word64
s2)
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nrun s4="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (Set Word64 -> RelSpec BabbageEra Word64 -> Bool
forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec Set Word64
ans RelSpec BabbageEra Word64
s4)
          )
          (Set Word64 -> RelSpec BabbageEra Word64 -> Bool
forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec Set Word64
ans RelSpec BabbageEra Word64
s4 Bool -> Bool -> Bool
&& Set Word64 -> RelSpec BabbageEra Word64 -> Bool
forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec Set Word64
ans RelSpec BabbageEra Word64
s2 Bool -> Bool -> Bool
&& Set Word64 -> RelSpec BabbageEra Word64 -> Bool
forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec Set Word64
ans RelSpec BabbageEra Word64
s1)

consistent :: (LiftT a, Semigroup a) => a -> a -> Maybe a
consistent :: forall a. (LiftT a, Semigroup a) => a -> a -> Maybe a
consistent a
x a
y = case Typed a -> Either [String] a
forall x. Typed x -> Either [String] x
runTyped (a -> Typed a
forall x. LiftT x => x -> Typed x
liftT (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y)) of
  Left [String]
_ -> Maybe a
forall a. Maybe a
Nothing
  Right a
spec -> a -> Maybe a
forall a. a -> Maybe a
Just a
spec

manyMergeRelSpec :: Gen (Int, Int, [String])
manyMergeRelSpec :: Gen (Int, Int, [String])
manyMergeRelSpec = do
  Int
n <- (Int, Int) -> Gen Int
chooseInt (Int
3, Int
10)
  [RelSpec BabbageEra Int]
xs <- Int -> Gen (RelSpec BabbageEra Int) -> Gen [RelSpec BabbageEra Int]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
60 ([String]
-> Gen Int
-> Rep BabbageEra Int
-> Int
-> Gen (RelSpec BabbageEra Int)
forall dom era.
Ord dom =>
[String] -> Gen dom -> Rep era dom -> Int -> Gen (RelSpec era dom)
genRelSpec [String
"manyMergeRelSpec xs"] ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
100)) Rep BabbageEra Int
forall era. Rep era Int
IntR Int
n)
  [RelSpec BabbageEra Int]
ys <- Int -> Gen (RelSpec BabbageEra Int) -> Gen [RelSpec BabbageEra Int]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
60 ([String]
-> Gen Int
-> Rep BabbageEra Int
-> Int
-> Gen (RelSpec BabbageEra Int)
forall dom era.
Ord dom =>
[String] -> Gen dom -> Rep era dom -> Int -> Gen (RelSpec era dom)
genRelSpec [String
"manyMergeRelSpec ys"] ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
100)) Rep BabbageEra Int
forall era. Rep era Int
IntR Int
n)
  let ok :: RelSpec era dom -> Bool
ok RelSpec era dom
RelAny = Bool
False
      ok RelSpec era dom
_ = Bool
True
      check :: (RelSpec BabbageEra Int, RelSpec BabbageEra Int,
 RelSpec BabbageEra Int)
-> Gen
     (RelSpec BabbageEra Int, Bool, RelSpec BabbageEra Int, Bool,
      Set Int, Bool, RelSpec BabbageEra Int)
check (RelSpec BabbageEra Int
x, RelSpec BabbageEra Int
y, RelSpec BabbageEra Int
m) = do
        let size :: Size
size = RelSpec BabbageEra Int -> Size
forall era dom. RelSpec era dom -> Size
sizeForRel RelSpec BabbageEra Int
m
        Int
i <- Size -> Gen Int
genFromSize Size
size
        let wordsX :: [String]
wordsX =
              [ String
"s1<>s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (RelSpec BabbageEra Int -> Size
forall era dom. RelSpec era dom -> Size
sizeForRel RelSpec BabbageEra Int
m)
              , String
"s1<>s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec BabbageEra Int -> String
forall a. Show a => a -> String
show RelSpec BabbageEra Int
m
              , String
"s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (RelSpec BabbageEra Int -> Size
forall era dom. RelSpec era dom -> Size
sizeForRel RelSpec BabbageEra Int
x)
              , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec BabbageEra Int -> String
forall a. Show a => a -> String
show RelSpec BabbageEra Int
x
              , String
"s1 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (RelSpec BabbageEra Int -> Size
forall era dom. RelSpec era dom -> Size
sizeForRel RelSpec BabbageEra Int
y)
              , String
"s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec BabbageEra Int -> String
forall a. Show a => a -> String
show RelSpec BabbageEra Int
y
              , String
"GenFromRelSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" n=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
              ]
        Set Int
z <- forall era t.
(Era era, Ord t) =>
[String] -> Gen t -> Int -> RelSpec era t -> Gen (Set t)
genFromRelSpec @BabbageEra [String]
wordsX ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
100)) Int
i RelSpec BabbageEra Int
m
        (RelSpec BabbageEra Int, Bool, RelSpec BabbageEra Int, Bool,
 Set Int, Bool, RelSpec BabbageEra Int)
-> Gen
     (RelSpec BabbageEra Int, Bool, RelSpec BabbageEra Int, Bool,
      Set Int, Bool, RelSpec BabbageEra Int)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelSpec BabbageEra Int
x, Set Int -> RelSpec BabbageEra Int -> Bool
forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec Set Int
z RelSpec BabbageEra Int
x, RelSpec BabbageEra Int
y, Set Int -> RelSpec BabbageEra Int -> Bool
forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec Set Int
z RelSpec BabbageEra Int
y, Set Int
z, Set Int -> RelSpec BabbageEra Int -> Bool
forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec Set Int
z RelSpec BabbageEra Int
m, RelSpec BabbageEra Int
m)
      showAns :: (RelSpec era dom, a, RelSpec era dom, a, a, a, RelSpec era dom)
-> String
showAns (RelSpec era dom
s1, a
run1, RelSpec era dom
s2, a
run2, a
v, a
run3, RelSpec era dom
s3) =
        [String] -> String
unlines
          [ String
"\ns1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era dom -> String
forall a. Show a => a -> String
show RelSpec era dom
s1
          , String
"s1 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (RelSpec era dom -> Size
forall era dom. RelSpec era dom -> Size
sizeForRel RelSpec era dom
s1)
          , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era dom -> String
forall a. Show a => a -> String
show RelSpec era dom
s2
          , String
"s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (RelSpec era dom -> Size
forall era dom. RelSpec era dom -> Size
sizeForRel RelSpec era dom
s2)
          , String
"s1 <> s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era dom -> String
forall a. Show a => a -> String
show RelSpec era dom
s3
          , String
"s1<>s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (RelSpec era dom -> Size
forall era dom. RelSpec era dom -> Size
sizeForRel RelSpec era dom
s3)
          , String
"v = genFromRelSpec (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v
          , String
"runRelSpec v s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run1
          , String
"runRelSpec v s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run2
          , String
"runRelSpec v (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run3
          ]
      pr :: (RelSpec era dom, Bool, RelSpec era dom, Bool, a, Bool,
 RelSpec era dom)
-> Maybe String
pr x :: (RelSpec era dom, Bool, RelSpec era dom, Bool, a, Bool,
 RelSpec era dom)
x@(RelSpec era dom
_, Bool
a, RelSpec era dom
_, Bool
b, a
_, Bool
c, RelSpec era dom
_) = if Bool -> Bool
not (Bool
a Bool -> Bool -> Bool
&& Bool
b Bool -> Bool -> Bool
&& Bool
c) then String -> Maybe String
forall a. a -> Maybe a
Just ((RelSpec era dom, Bool, RelSpec era dom, Bool, a, Bool,
 RelSpec era dom)
-> String
forall {a} {a} {a} {a} {era} {dom} {era} {dom} {era} {dom}.
(Show a, Show a, Show a, Show a) =>
(RelSpec era dom, a, RelSpec era dom, a, a, a, RelSpec era dom)
-> String
showAns (RelSpec era dom, Bool, RelSpec era dom, Bool, a, Bool,
 RelSpec era dom)
x) else Maybe String
forall a. Maybe a
Nothing
  let trips :: [(RelSpec BabbageEra Int, RelSpec BabbageEra Int,
  RelSpec BabbageEra Int)]
trips = [(RelSpec BabbageEra Int
x, RelSpec BabbageEra Int
y, RelSpec BabbageEra Int
m) | RelSpec BabbageEra Int
x <- [RelSpec BabbageEra Int]
xs, RelSpec BabbageEra Int
y <- [RelSpec BabbageEra Int]
ys, RelSpec BabbageEra Int -> Bool
forall era d. RelSpec era d -> Bool
ok RelSpec BabbageEra Int
x Bool -> Bool -> Bool
&& RelSpec BabbageEra Int -> Bool
forall era d. RelSpec era d -> Bool
ok RelSpec BabbageEra Int
y, Just RelSpec BabbageEra Int
m <- [RelSpec BabbageEra Int
-> RelSpec BabbageEra Int -> Maybe (RelSpec BabbageEra Int)
forall a. (LiftT a, Semigroup a) => a -> a -> Maybe a
consistent RelSpec BabbageEra Int
x RelSpec BabbageEra Int
y]]
  [(RelSpec BabbageEra Int, Bool, RelSpec BabbageEra Int, Bool,
  Set Int, Bool, RelSpec BabbageEra Int)]
ts <- ((RelSpec BabbageEra Int, RelSpec BabbageEra Int,
  RelSpec BabbageEra Int)
 -> Gen
      (RelSpec BabbageEra Int, Bool, RelSpec BabbageEra Int, Bool,
       Set Int, Bool, RelSpec BabbageEra Int))
-> [(RelSpec BabbageEra Int, RelSpec BabbageEra Int,
     RelSpec BabbageEra Int)]
-> Gen
     [(RelSpec BabbageEra Int, Bool, RelSpec BabbageEra Int, Bool,
       Set Int, Bool, RelSpec BabbageEra Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (RelSpec BabbageEra Int, RelSpec BabbageEra Int,
 RelSpec BabbageEra Int)
-> Gen
     (RelSpec BabbageEra Int, Bool, RelSpec BabbageEra Int, Bool,
      Set Int, Bool, RelSpec BabbageEra Int)
check [(RelSpec BabbageEra Int, RelSpec BabbageEra Int,
  RelSpec BabbageEra Int)]
trips
  (Int, Int, [String]) -> Gen (Int, Int, [String])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, Int, [String]) -> Gen (Int, Int, [String]))
-> (Int, Int, [String]) -> Gen (Int, Int, [String])
forall a b. (a -> b) -> a -> b
$ (Int
n, [(RelSpec BabbageEra Int, RelSpec BabbageEra Int,
  RelSpec BabbageEra Int)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(RelSpec BabbageEra Int, RelSpec BabbageEra Int,
  RelSpec BabbageEra Int)]
trips, ((RelSpec BabbageEra Int, Bool, RelSpec BabbageEra Int, Bool,
  Set Int, Bool, RelSpec BabbageEra Int)
 -> Maybe String)
-> [(RelSpec BabbageEra Int, Bool, RelSpec BabbageEra Int, Bool,
     Set Int, Bool, RelSpec BabbageEra Int)]
-> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (RelSpec BabbageEra Int, Bool, RelSpec BabbageEra Int, Bool,
 Set Int, Bool, RelSpec BabbageEra Int)
-> Maybe String
forall {a} {era} {dom} {era} {dom} {era} {dom}.
Show a =>
(RelSpec era dom, Bool, RelSpec era dom, Bool, a, Bool,
 RelSpec era dom)
-> Maybe String
pr [(RelSpec BabbageEra Int, Bool, RelSpec BabbageEra Int, Bool,
  Set Int, Bool, RelSpec BabbageEra Int)]
ts)

reportManyMergeRelSpec :: IO ()
reportManyMergeRelSpec :: IO ()
reportManyMergeRelSpec = do
  (Int
n, Int
passed, [String]
bad) <- Gen (Int, Int, [String]) -> IO (Int, Int, [String])
forall a. Gen a -> IO a
generate Gen (Int, Int, [String])
manyMergeRelSpec
  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
bad
    then String -> IO ()
putStrLn (String
"passed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
passed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests. Spec size " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
    else do (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
bad; String -> IO ()
forall a. HasCallStack => String -> a
error String
"TestFails"

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

-- | Indicates which constraints (if any) the range of a Map must adhere to
--   There are 3 cases RngSum, RngProj, and RngRel. They are all mutually inconsistent.
--   So while any Map may constrain its range, it can only choose ONE of the cases.
data RngSpec era rng where
  -- | The set must have Adds instance and add up to 'rng'
  RngSum ::
    Adds rng =>
    rng -> -- the smallest element in the partition (usually 0 or 1)
    Size -> -- the sum of all the elements must fall in the range denoted by the Size
    RngSpec era rng
  RngProj ::
    Adds c =>
    c -> -- the smallest element in the partition (usually 0 or 1)
    Rep era x ->
    Lens' x c ->
    Size -> -- the sum of all the elements must fall in the range denoted by the Size
    RngSpec era x
  -- | The range has exactly these elements
  RngElem :: Eq r => Rep era r -> [r] -> RngSpec era r
  -- | The range must hold on the relation specified
  RngRel :: Ord x => RelSpec era x -> RngSpec era x
  -- | There are no constraints on the range (random generator will do)
  RngAny :: RngSpec era rng
  -- | Something was inconsistent
  RngNever :: [String] -> RngSpec era rng

instance Show (RngSpec era t) where
  show :: RngSpec era t -> String
show = RngSpec era t -> String
forall era t. RngSpec era t -> String
showRngSpec

instance Era era => Monoid (RngSpec era rng) where
  mempty :: RngSpec era rng
mempty = RngSpec era rng
forall era rng. RngSpec era rng
RngAny

instance Era era => Semigroup (RngSpec era rng) where
  <> :: RngSpec era rng -> RngSpec era rng -> RngSpec era rng
(<>) = RngSpec era rng -> RngSpec era rng -> RngSpec era rng
forall r era. RngSpec era r -> RngSpec era r -> RngSpec era r
mergeRngSpec

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

showRngSpec :: RngSpec era t -> String
showRngSpec :: forall era t. RngSpec era t -> String
showRngSpec (RngSum t
small Size
sz) = [String] -> String
sepsP [String
"RngSum", t -> String
forall a. Show a => a -> String
show t
small, Size -> String
forall a. Show a => a -> String
show Size
sz]
showRngSpec (RngProj c
small Rep era t
xrep Lens' t c
_l Size
sz) = [String] -> String
sepsP [String
"RngProj", c -> String
forall a. Show a => a -> String
show c
small, Rep era t -> String
forall a. Show a => a -> String
show Rep era t
xrep, Size -> String
forall a. Show a => a -> String
show Size
sz]
showRngSpec (RngElem Rep era t
r [t]
cs) = [String] -> String
sepsP [String
"RngElem", Rep era t -> String
forall a. Show a => a -> String
show Rep era t
r, Rep era [t] -> [t] -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era t -> Rep era [t]
forall era a. Rep era a -> Rep era [a]
ListR Rep era t
r) [t]
cs]
showRngSpec (RngRel RelSpec era t
x) = [String] -> String
sepsP [String
"RngRel", RelSpec era t -> String
forall a. Show a => a -> String
show RelSpec era t
x]
showRngSpec RngSpec era t
RngAny = String
"RngAny"
showRngSpec (RngNever [String]
_) = String
"RngNever"

mergeRngSpec :: forall r era. RngSpec era r -> RngSpec era r -> RngSpec era r
mergeRngSpec :: forall r era. RngSpec era r -> RngSpec era r -> RngSpec era r
mergeRngSpec RngSpec era r
RngAny RngSpec era r
x = RngSpec era r
x
mergeRngSpec RngSpec era r
x RngSpec era r
RngAny = RngSpec era r
x
mergeRngSpec (RngRel RelSpec era r
RelAny) RngSpec era r
x = RngSpec era r
x
mergeRngSpec RngSpec era r
x (RngRel RelSpec era r
RelAny) = RngSpec era r
x
mergeRngSpec RngSpec era r
_ (RngNever [String]
xs) = [String] -> RngSpec era r
forall era rng. [String] -> RngSpec era rng
RngNever [String]
xs
mergeRngSpec (RngNever [String]
xs) RngSpec era r
_ = [String] -> RngSpec era r
forall era rng. [String] -> RngSpec era rng
RngNever [String]
xs
mergeRngSpec a :: RngSpec era r
a@(RngElem Rep era r
_ [r]
xs) RngSpec era r
b
  | [r] -> RngSpec era r -> Bool
forall r era. [r] -> RngSpec era r -> Bool
runRngSpec [r]
xs RngSpec era r
b = RngSpec era r
a
  | Bool
otherwise = [String] -> RngSpec era r
forall era rng. [String] -> RngSpec era rng
RngNever [String
"The RngSpec's are inconsistent.\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era r -> String
forall a. Show a => a -> String
show RngSpec era r
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era r -> String
forall a. Show a => a -> String
show RngSpec era r
b]
mergeRngSpec RngSpec era r
a b :: RngSpec era r
b@(RngElem Rep era r
_ [r]
xs)
  | [r] -> RngSpec era r -> Bool
forall r era. [r] -> RngSpec era r -> Bool
runRngSpec [r]
xs RngSpec era r
a = RngSpec era r
b
  | Bool
otherwise = [String] -> RngSpec era r
forall era rng. [String] -> RngSpec era rng
RngNever [String
"The RngSpec's are inconsistent.\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era r -> String
forall a. Show a => a -> String
show RngSpec era r
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era r -> String
forall a. Show a => a -> String
show RngSpec era r
b]
mergeRngSpec a :: RngSpec era r
a@(RngSum r
small1 Size
sz1) b :: RngSpec era r
b@(RngSum r
small2 Size
sz2) =
  case Size
sz1 Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> Size
sz2 of
    SzNever [String]
xs -> [String] -> RngSpec era r
forall era rng. [String] -> RngSpec era rng
RngNever ([String
"The RngSpec's are inconsistent.\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era r -> String
forall a. Show a => a -> String
show RngSpec era r
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era r -> String
forall a. Show a => a -> String
show RngSpec era r
b] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
xs)
    Size
sz3 -> r -> Size -> RngSpec era r
forall rng era. Adds rng => rng -> Size -> RngSpec era rng
RngSum (r -> r -> r
forall x. Adds x => x -> x -> x
smallerOf r
small1 r
small2) Size
sz3
mergeRngSpec a :: RngSpec era r
a@(RngRel RelSpec era r
r1) b :: RngSpec era r
b@(RngRel RelSpec era r
r2) =
  case RelSpec era r
r1 RelSpec era r -> RelSpec era r -> RelSpec era r
forall a. Semigroup a => a -> a -> a
<> RelSpec era r
r2 of
    RelNever [String]
xs -> [String] -> RngSpec era r
forall era rng. [String] -> RngSpec era rng
RngNever ([String
"The RngSpec's are inconsistent.\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era r -> String
forall a. Show a => a -> String
show RngSpec era r
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era r -> String
forall a. Show a => a -> String
show RngSpec era r
b] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
xs)
    RelSpec era r
r3 -> RelSpec era r -> RngSpec era r
forall x era. Ord x => RelSpec era x -> RngSpec era x
RngRel RelSpec era r
r3
mergeRngSpec RngSpec era r
a RngSpec era r
b = [String] -> RngSpec era r
forall era rng. [String] -> RngSpec era rng
RngNever [String
"The RngSpec's are inconsistent.\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era r -> String
forall a. Show a => a -> String
show RngSpec era r
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era r -> String
forall a. Show a => a -> String
show RngSpec era r
b]

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

-- | Compute the Size that is appropriate for a RngSpec
sizeForRng :: forall dom era. RngSpec era dom -> Size
sizeForRng :: forall dom era. RngSpec era dom -> Size
sizeForRng (RngRel RelSpec era dom
x) = RelSpec era dom -> Size
forall era dom. RelSpec era dom -> Size
sizeForRel RelSpec era dom
x
sizeForRng (RngSum dom
small Size
sz) =
  if dom -> Int
forall x. Adds x => x -> Int
toI dom
small Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Size -> Int
minSize Size
sz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& (Size -> Int
minSize Size
sz Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` dom -> Int
forall x. Adds x => x -> Int
toI dom
small) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    then Int -> Int -> Size
SzRng Int
1 (Size -> Int
minSize Size
sz Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` dom -> Int
forall x. Adds x => x -> Int
toI dom
small)
    else Int -> Size
SzLeast Int
1
sizeForRng (RngProj c
small Rep era dom
_ Lens' dom c
_l Size
sz) =
  if c -> Int
forall x. Adds x => x -> Int
toI c
small Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Size -> Int
minSize Size
sz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& (Size -> Int
minSize Size
sz Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` c -> Int
forall x. Adds x => x -> Int
toI c
small) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    then Int -> Int -> Size
SzRng Int
1 (Size -> Int
minSize Size
sz Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` c -> Int
forall x. Adds x => x -> Int
toI c
small)
    else Int -> Size
SzLeast Int
1
sizeForRng (RngElem Rep era dom
_ [dom]
xs) = Int -> Size
SzExact ([dom] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [dom]
xs)
sizeForRng RngSpec era dom
RngAny = Size
SzAny
sizeForRng (RngNever [String]
_) = Size
SzAny

-- ------------------------------------------
-- generators for test functions.

-- | Generate an arbitrary size [r] for a particular size 'n'
--   The generated list is consistent with the RngSpec given as input.
genFromRngSpec :: forall era r. Era era => [String] -> Gen r -> Int -> RngSpec era r -> Gen [r]
genFromRngSpec :: forall era r.
Era era =>
[String] -> Gen r -> Int -> RngSpec era r -> Gen [r]
genFromRngSpec [String]
msgs Gen r
genr Int
n RngSpec era r
x = case RngSpec era r
x of
  (RngNever [String]
xs) -> String -> [String] -> Gen [r]
forall a. HasCallStack => String -> [String] -> a
errorMess String
"RngNever in genFromRngSpec" ([String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs))
  RngSpec era r
RngAny -> Int -> Gen r -> Gen [r]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen r
genr
  (RngSum r
small Size
sz) -> do
    Int
tot <- Size -> Gen Int
genFromIntRange Size
sz
    r -> [String] -> Int -> r -> Gen [r]
forall x. Adds x => x -> [String] -> Int -> x -> Gen [x]
partition r
small (String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Int
n ([String] -> Int -> r
forall x. Adds x => [String] -> Int -> x
fromI (String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Int
tot)
  (RngProj c
small Rep era r
xrep Lens' r c
l Size
sz) -> do
    Int
tot <- Size -> Gen Int
genFromIntRange Size
sz
    [c]
rs <- c -> [String] -> Int -> c -> Gen [c]
forall x. Adds x => x -> [String] -> Int -> x -> Gen [x]
partition c
small ((String
"partition " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tot) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Int
n ([String] -> Int -> c
forall x. Adds x => [String] -> Int -> x
fromI (String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Int
tot)
    (c -> Gen r) -> [c] -> Gen [r]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\c
r -> do r
ans <- Rep era r -> Gen r
forall era b. Rep era b -> Gen b
genRep Rep era r
xrep; r -> Gen r
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r
ans r -> (r -> r) -> r
forall a b. a -> (a -> b) -> b
& (c -> Identity c) -> r -> Identity r
Lens' r c
l ((c -> Identity c) -> r -> Identity r) -> c -> r -> r
forall s t a b. ASetter s t a b -> b -> s -> t
.~ c
r)) [c]
rs
  (RngRel RelSpec era r
relspec) -> Set r -> [r]
forall a. Set a -> [a]
Set.toList (Set r -> [r]) -> Gen (Set r) -> Gen [r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Gen r -> Int -> RelSpec era r -> Gen (Set r)
forall era t.
(Era era, Ord t) =>
[String] -> Gen t -> Int -> RelSpec era t -> Gen (Set t)
genFromRelSpec (String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Gen r
genr Int
n RelSpec era r
relspec
  (RngElem Rep era r
_ [r]
xs) -> [r] -> Gen [r]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [r]
xs
  where
    msg :: String
msg = String
"genFromRngSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era r -> String
forall a. Show a => a -> String
show RngSpec era r
x

-- | Generate a random RngSpec, appropriate for a given size. In order to accomodate any OrdCond
--   (EQL, LTH, LTE, GTE, GTH) in RngSum and RngProj, we make the total a bit larger than 'n'
genRngSpec ::
  forall w era.
  (Ord w, Adds w) =>
  Gen w ->
  Rep era w ->
  -- Rep era c ->
  SomeLens era w ->
  Int ->
  Gen (RngSpec era w)
genRngSpec :: forall w era.
(Ord w, Adds w) =>
Gen w -> Rep era w -> SomeLens era w -> Int -> Gen (RngSpec era w)
genRngSpec Gen w
_ Rep era w
repw SomeLens era w
_ Int
0 = RngSpec era w -> Gen (RngSpec era w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RngSpec era w -> Gen (RngSpec era w))
-> RngSpec era w -> Gen (RngSpec era w)
forall a b. (a -> b) -> a -> b
$ RelSpec era w -> RngSpec era w
forall x era. Ord x => RelSpec era x -> RngSpec era x
RngRel (Rep era w -> Set w -> RelSpec era w
forall t era. Ord t => Rep era t -> Set t -> RelSpec era t
relEqual Rep era w
repw Set w
forall a. Set a
Set.empty)
genRngSpec Gen w
g Rep era w
repw (SomeLens (Lens' w c
l :: Lens' w c)) Int
n = do
  [(Int, Gen (RngSpec era w))] -> Gen (RngSpec era w)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [
      ( Int
3
      , do
          Int
smallest <- forall x. Adds x => Gen Int
genSmall @w -- Chooses smallest appropriate for type 'w'
          Size
sz <- Int -> Gen Size
genBigSize (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
smallest Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n))
          RngSpec era w -> Gen (RngSpec era w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (w -> Size -> RngSpec era w
forall rng era. Adds rng => rng -> Size -> RngSpec era rng
RngSum ([String] -> Int -> w
forall x. Adds x => [String] -> Int -> x
fromI [String
"genRngSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n] Int
smallest) Size
sz)
      )
    ,
      ( Int
2
      , do
          Int
smallest <- forall x. Adds x => Gen Int
genSmall @c
          Size
sz <- Int -> Gen Size
genBigSize (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
smallest Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n))
          RngSpec era w -> Gen (RngSpec era w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c -> Rep era w -> Lens' w c -> Size -> RngSpec era w
forall c era x.
Adds c =>
c -> Rep era x -> Lens' x c -> Size -> RngSpec era x
RngProj ([String] -> Int -> c
forall x. Adds x => [String] -> Int -> x
fromI [String
"genRngSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n] Int
smallest) Rep era w
repw (c -> f c) -> w -> f w
Lens' w c
l Size
sz)
      )
    , (Int
4, RelSpec era w -> RngSpec era w
forall x era. Ord x => RelSpec era x -> RngSpec era x
RngRel (RelSpec era w -> RngSpec era w)
-> Gen (RelSpec era w) -> Gen (RngSpec era w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall dom era.
Ord dom =>
[String] -> Gen dom -> Rep era dom -> Int -> Gen (RelSpec era dom)
genRelSpec @w [String
"genRngSpec "] Gen w
g Rep era w
repw Int
n)
    , (Int
1, RngSpec era w -> Gen (RngSpec era w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RngSpec era w
forall era rng. RngSpec era rng
RngAny)
    , (Int
2, Rep era w -> [w] -> RngSpec era w
forall r era. Eq r => Rep era r -> [r] -> RngSpec era r
RngElem Rep era w
repw ([w] -> RngSpec era w) -> Gen [w] -> Gen (RngSpec era w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen w -> Gen [w]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen w
g)
    ]

runRngSpec :: [r] -> RngSpec era r -> Bool
runRngSpec :: forall r era. [r] -> RngSpec era r -> Bool
runRngSpec [r]
_ (RngNever [String]
_) = Bool
False
runRngSpec [r]
_ RngSpec era r
RngAny = Bool
True
runRngSpec [r]
ll (RngElem Rep era r
_ [r]
xs) = [r]
ll [r] -> [r] -> Bool
forall a. Eq a => a -> a -> Bool
== [r]
xs
runRngSpec [r]
ll (RngSum r
_ Size
sz) = Int -> Size -> Bool
runSize (r -> Int
forall x. Adds x => x -> Int
toI ([r] -> r
forall (t :: * -> *) c. (Foldable t, Adds c) => t c -> c
sumAdds [r]
ll)) Size
sz
runRngSpec [r]
ll (RngProj c
_ Rep era r
_ Lens' r c
l Size
sz) = Int -> Size -> Bool
runSize (c -> Int
forall x. Adds x => x -> Int
toI (Lens' r c -> [r] -> c
forall (t :: * -> *) b a.
(Foldable t, Adds b) =>
Lens' a b -> t a -> b
lensAdds (c -> f c) -> r -> f r
Lens' r c
l [r]
ll)) Size
sz
runRngSpec [r]
ll (RngRel RelSpec era r
rspec) = Set r -> RelSpec era r -> Bool
forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec ([r] -> Set r
forall a. Ord a => [a] -> Set a
Set.fromList [r]
ll) RelSpec era r
rspec

-- ------------------------------------------
-- generators for RngSpec

genConsistentRngSpec ::
  forall era w c.
  (Ord w, Adds w) =>
  Int ->
  Gen w ->
  Rep era w ->
  Rep era c ->
  SomeLens era w ->
  Gen (RngSpec era w, RngSpec era w)
genConsistentRngSpec :: forall era w c.
(Ord w, Adds w) =>
Int
-> Gen w
-> Rep era w
-> Rep era c
-> SomeLens era w
-> Gen (RngSpec era w, RngSpec era w)
genConsistentRngSpec Int
n Gen w
g Rep era w
repw Rep era c
repc sl :: SomeLens era w
sl@(SomeLens Lens' w c
l) = do
  RngSpec era w
x1 <- Gen w -> Rep era w -> SomeLens era w -> Int -> Gen (RngSpec era w)
forall w era.
(Ord w, Adds w) =>
Gen w -> Rep era w -> SomeLens era w -> Int -> Gen (RngSpec era w)
genRngSpec Gen w
g Rep era w
repw SomeLens era w
sl Int
n
  RngSpec era w
x2 <- case RngSpec era w
x1 of
    RngSpec era w
RngAny -> Gen w -> Rep era w -> SomeLens era w -> Int -> Gen (RngSpec era w)
forall w era.
(Ord w, Adds w) =>
Gen w -> Rep era w -> SomeLens era w -> Int -> Gen (RngSpec era w)
genRngSpec Gen w
g Rep era w
repw SomeLens era w
sl Int
n
    RngRel RelSpec era w
RelAny -> Gen w -> Rep era w -> SomeLens era w -> Int -> Gen (RngSpec era w)
forall w era.
(Ord w, Adds w) =>
Gen w -> Rep era w -> SomeLens era w -> Int -> Gen (RngSpec era w)
genRngSpec Gen w
g Rep era w
repw SomeLens era w
sl Int
n
    RngRel RelSpec era w
x -> RelSpec era w -> RngSpec era w
forall x era. Ord x => RelSpec era x -> RngSpec era x
RngRel (RelSpec era w -> RngSpec era w)
-> Gen (RelSpec era w) -> Gen (RngSpec era w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Gen w -> RelSpec era w -> Gen (RelSpec era w)
forall dom era.
[String] -> Gen dom -> RelSpec era dom -> Gen (RelSpec era dom)
genConsistentRelSpec [String]
msgs Gen w
g RelSpec era w
x
    RngSum w
sm Size
sz -> do
      Size
sz2 <- Gen Size -> (Size -> Bool) -> Gen Size
forall a. Gen a -> (a -> Bool) -> Gen a
suchThat Gen Size
genSize (Maybe Size -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Maybe Size -> Bool) -> (Size -> Maybe Size) -> Size -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> Size -> Maybe Size
forall a. (LiftT a, Semigroup a) => a -> a -> Maybe a
consistent Size
sz)
      RngSpec era w -> Gen (RngSpec era w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RngSpec era w -> Gen (RngSpec era w))
-> RngSpec era w -> Gen (RngSpec era w)
forall a b. (a -> b) -> a -> b
$ w -> Size -> RngSpec era w
forall rng era. Adds rng => rng -> Size -> RngSpec era rng
RngSum (w -> w -> w
forall x. Adds x => x -> x -> x
add w
sm ([String] -> Int -> w
forall x. Adds x => [String] -> Int -> x
fromI [String]
msgs Int
2)) Size
sz2 -- Make the smaller bigger
    RngProj c
_sm Rep era w
_rep Lens' w c
_l Size
_sz -> RngSpec era w -> Gen (RngSpec era w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RngSpec era w
forall era rng. RngSpec era rng
RngAny
    RngElem Rep era w
_ [w]
xs ->
      [(Int, Gen (RngSpec era w))] -> Gen (RngSpec era w)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
1, RngSpec era w -> Gen (RngSpec era w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RngSpec era w -> Gen (RngSpec era w))
-> RngSpec era w -> Gen (RngSpec era w)
forall a b. (a -> b) -> a -> b
$ w -> Size -> RngSpec era w
forall rng era. Adds rng => rng -> Size -> RngSpec era rng
RngSum ([String] -> Int -> w
forall x. Adds x => [String] -> Int -> x
fromI [String]
msgs Int
1) (Int -> Size
SzExact (w -> Int
forall x. Adds x => x -> Int
toI ([w] -> w
forall (t :: * -> *) c. (Foldable t, Adds c) => t c -> c
sumAdds [w]
xs))))
        , (Int
1, RngSpec era w -> Gen (RngSpec era w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RngSpec era w -> Gen (RngSpec era w))
-> RngSpec era w -> Gen (RngSpec era w)
forall a b. (a -> b) -> a -> b
$ c -> Rep era w -> Lens' w c -> Size -> RngSpec era w
forall c era x.
Adds c =>
c -> Rep era x -> Lens' x c -> Size -> RngSpec era x
RngProj ([String] -> Int -> c
forall x. Adds x => [String] -> Int -> x
fromI [String]
msgs Int
1) Rep era w
repw (c -> f c) -> w -> f w
Lens' w c
l (Int -> Size
SzExact (c -> Int
forall x. Adds x => x -> Int
toI (Lens' w c -> [w] -> c
forall (t :: * -> *) b a.
(Foldable t, Adds b) =>
Lens' a b -> t a -> b
lensAdds (c -> f c) -> w -> f w
Lens' w c
l [w]
xs))))
        ]
    RngNever [String]
xs -> String -> [String] -> Gen (RngSpec era w)
forall a. HasCallStack => String -> [String] -> a
errorMess String
"RngNever in genConsistentRngSpec" [String]
xs
  (RngSpec era w, RngSpec era w)
-> Gen (RngSpec era w, RngSpec era w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RngSpec era w
x1, RngSpec era w
x2)
  where
    msgs :: [String]
msgs = [[String] -> String
seps [String
"genConsistentRngSpec", Rep era w -> String
forall a. Show a => a -> String
show Rep era w
repw, Rep era c -> String
forall a. Show a => a -> String
show Rep era c
repc]]

word64CoinL :: Lens' Word64 Coin
word64CoinL :: Lens' Word64 Coin
word64CoinL = (Word64 -> Coin) -> (Word64 -> Coin -> Word64) -> Lens' Word64 Coin
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (Integer -> Coin
Coin (Integer -> Coin) -> (Word64 -> Integer) -> Word64 -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (\Word64
_w (Coin Integer
n) -> Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n)

-- Tests

testConsistentRng :: Gen Property
testConsistentRng :: Gen Property
testConsistentRng = do
  Int
n <- (Int, Int) -> Gen Int
chooseInt (Int
3, Int
10)
  (RngSpec BabbageEra Word64
s1, RngSpec BabbageEra Word64
s2) <-
    forall era w c.
(Ord w, Adds w) =>
Int
-> Gen w
-> Rep era w
-> Rep era c
-> SomeLens era w
-> Gen (RngSpec era w, RngSpec era w)
genConsistentRngSpec @BabbageEra Int
n ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
1000)) Rep BabbageEra Word64
forall era. Rep era Word64
Word64R Rep BabbageEra Coin
forall era. Rep era Coin
CoinR (Lens' Word64 Coin -> SomeLens BabbageEra Word64
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (Coin -> f Coin) -> Word64 -> f Word64
Lens' Word64 Coin
word64CoinL)
  case RngSpec BabbageEra Word64
s1 RngSpec BabbageEra Word64
-> RngSpec BabbageEra Word64 -> RngSpec BabbageEra Word64
forall a. Semigroup a => a -> a -> a
<> RngSpec BabbageEra Word64
s2 of
    RngNever [String]
ms -> Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([String] -> String
unlines ([String
"genConsistentRng fails", RngSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Word64
s1, RngSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Word64
s2] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ms)) Bool
False
    RngSpec BabbageEra Word64
_ -> Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"" Bool
True

testSoundRngSpec :: Gen Property
testSoundRngSpec :: Gen Property
testSoundRngSpec = do
  Int
n <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
2, Int
8)
  RngSpec BabbageEra Word64
spec <- Gen Word64
-> Rep BabbageEra Word64
-> SomeLens BabbageEra Word64
-> Int
-> Gen (RngSpec BabbageEra Word64)
forall w era.
(Ord w, Adds w) =>
Gen w -> Rep era w -> SomeLens era w -> Int -> Gen (RngSpec era w)
genRngSpec ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
1000)) Rep BabbageEra Word64
forall era. Rep era Word64
Word64R (Lens' Word64 Coin -> SomeLens BabbageEra Word64
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (Coin -> f Coin) -> Word64 -> f Word64
Lens' Word64 Coin
word64CoinL) Int
n
  let msgs :: [String]
msgs = [String
"testSoundRngSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Word64
spec]
  [Word64]
list <- forall era r.
Era era =>
[String] -> Gen r -> Int -> RngSpec era r -> Gen [r]
genFromRngSpec @BabbageEra [String]
msgs ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
1000)) Int
n RngSpec BabbageEra Word64
spec
  Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$
    String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
      (String
"spec=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Word64
spec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nlist=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Word64] -> String
forall a. Show a => a -> String
show [Word64]
list)
      ([Word64] -> RngSpec BabbageEra Word64 -> Bool
forall r era. [r] -> RngSpec era r -> Bool
runRngSpec [Word64]
list RngSpec BabbageEra Word64
spec)

testMergeRngSpec :: Gen Property
testMergeRngSpec :: Gen Property
testMergeRngSpec = do
  (RngSpec BabbageEra Word64
s1, RngSpec BabbageEra Word64
s2) <- Int
-> Gen Word64
-> Rep BabbageEra Word64
-> Rep BabbageEra Coin
-> SomeLens BabbageEra Word64
-> Gen (RngSpec BabbageEra Word64, RngSpec BabbageEra Word64)
forall era w c.
(Ord w, Adds w) =>
Int
-> Gen w
-> Rep era w
-> Rep era c
-> SomeLens era w
-> Gen (RngSpec era w, RngSpec era w)
genConsistentRngSpec Int
3 ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
1000)) Rep BabbageEra Word64
forall era. Rep era Word64
Word64R Rep BabbageEra Coin
forall era. Rep era Coin
CoinR (Lens' Word64 Coin -> SomeLens BabbageEra Word64
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (Coin -> f Coin) -> Word64 -> f Word64
Lens' Word64 Coin
word64CoinL)
  case RngSpec BabbageEra Word64
s1 RngSpec BabbageEra Word64
-> RngSpec BabbageEra Word64 -> RngSpec BabbageEra Word64
forall a. Semigroup a => a -> a -> a
<> RngSpec BabbageEra Word64
s2 of
    RngNever [String]
_ ->
      String -> Gen Property -> Gen Property
forall a. String -> a -> a
Debug.trace (String
"inconsistent RngSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Word64
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Word64
s2) (Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"" Bool
True))
    RngSpec BabbageEra Word64
s3 -> do
      let size :: Size
size = RngSpec BabbageEra Word64 -> Size
forall dom era. RngSpec era dom -> Size
sizeForRng RngSpec BabbageEra Word64
s3
      Int
n <- Size -> Gen Int
genFromSize Size
size
      let wordsX :: [String]
wordsX =
            [ String
"s1=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Word64
s1
            , String
"s2=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Word64
s2
            , String
"s3=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Word64
s3
            , String
"size=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
size
            , String
"n=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
            , String
"testMergeRngSpec"
            ]
      [Word64]
list <- forall era r.
Era era =>
[String] -> Gen r -> Int -> RngSpec era r -> Gen [r]
genFromRngSpec @BabbageEra [String]
wordsX ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
1000)) Int
n RngSpec BabbageEra Word64
s3
      Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$
        String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
          ( String
"s1="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Word64
s1
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  s2="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Word64
s2
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  s3="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Word64
s3
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  size="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
size
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  n="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  list="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep Any [Word64] -> [Word64] -> String
forall e t. Rep e t -> t -> String
synopsis (Rep Any Word64 -> Rep Any [Word64]
forall era a. Rep era a -> Rep era [a]
ListR Rep Any Word64
forall era. Rep era Word64
Word64R) [Word64]
list
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  run1="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show ([Word64] -> RngSpec BabbageEra Word64 -> Bool
forall r era. [r] -> RngSpec era r -> Bool
runRngSpec [Word64]
list RngSpec BabbageEra Word64
s1)
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n run2="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show ([Word64] -> RngSpec BabbageEra Word64 -> Bool
forall r era. [r] -> RngSpec era r -> Bool
runRngSpec [Word64]
list RngSpec BabbageEra Word64
s2)
          )
          ([Word64] -> RngSpec BabbageEra Word64 -> Bool
forall r era. [r] -> RngSpec era r -> Bool
runRngSpec [Word64]
list RngSpec BabbageEra Word64
s1 Bool -> Bool -> Bool
&& [Word64] -> RngSpec BabbageEra Word64 -> Bool
forall r era. [r] -> RngSpec era r -> Bool
runRngSpec [Word64]
list RngSpec BabbageEra Word64
s2)

intDeltaCoinL :: Lens' Int DeltaCoin
intDeltaCoinL :: Lens' Int DeltaCoin
intDeltaCoinL = (Int -> DeltaCoin)
-> (Int -> DeltaCoin -> Int) -> Lens' Int DeltaCoin
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (Integer -> DeltaCoin
DeltaCoin (Integer -> DeltaCoin) -> (Int -> Integer) -> Int -> DeltaCoin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (\Int
_i (DeltaCoin Integer
d) -> Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
d)

manyMergeRngSpec :: Gen (Int, Int, [String])
manyMergeRngSpec :: Gen (Int, Int, [String])
manyMergeRngSpec = do
  Int
n <- (Int, Int) -> Gen Int
chooseInt (Int
3, Int
10)
  [RngSpec BabbageEra Int]
xs <- Int -> Gen (RngSpec BabbageEra Int) -> Gen [RngSpec BabbageEra Int]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
50 (Gen Int
-> Rep BabbageEra Int
-> SomeLens BabbageEra Int
-> Int
-> Gen (RngSpec BabbageEra Int)
forall w era.
(Ord w, Adds w) =>
Gen w -> Rep era w -> SomeLens era w -> Int -> Gen (RngSpec era w)
genRngSpec ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
100)) Rep BabbageEra Int
forall era. Rep era Int
IntR (Lens' Int DeltaCoin -> SomeLens BabbageEra Int
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (DeltaCoin -> f DeltaCoin) -> Int -> f Int
Lens' Int DeltaCoin
intDeltaCoinL) Int
n)
  [RngSpec BabbageEra Int]
ys <- Int -> Gen (RngSpec BabbageEra Int) -> Gen [RngSpec BabbageEra Int]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
50 (Gen Int
-> Rep BabbageEra Int
-> SomeLens BabbageEra Int
-> Int
-> Gen (RngSpec BabbageEra Int)
forall w era.
(Ord w, Adds w) =>
Gen w -> Rep era w -> SomeLens era w -> Int -> Gen (RngSpec era w)
genRngSpec ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
100)) Rep BabbageEra Int
forall era. Rep era Int
IntR (Lens' Int DeltaCoin -> SomeLens BabbageEra Int
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (DeltaCoin -> f DeltaCoin) -> Int -> f Int
Lens' Int DeltaCoin
intDeltaCoinL) Int
n)
  let check :: (RngSpec BabbageEra Int, RngSpec BabbageEra Int,
 RngSpec BabbageEra Int)
-> Gen
     (RngSpec BabbageEra Int, Bool, RngSpec BabbageEra Int, Bool, [Int],
      Bool, RngSpec BabbageEra Int)
check (RngSpec BabbageEra Int
x, RngSpec BabbageEra Int
y, RngSpec BabbageEra Int
m) = do
        let size :: Size
size = RngSpec BabbageEra Int -> Size
forall dom era. RngSpec era dom -> Size
sizeForRng RngSpec BabbageEra Int
m
        Int
i <- Size -> Gen Int
genFromSize Size
size
        let wordsX :: [String]
wordsX =
              [ String
"s1<>s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (RngSpec BabbageEra Int -> Size
forall dom era. RngSpec era dom -> Size
sizeForRng RngSpec BabbageEra Int
m)
              , String
"s1<>s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec BabbageEra Int -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Int
m
              , String
"s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (RngSpec BabbageEra Int -> Size
forall dom era. RngSpec era dom -> Size
sizeForRng RngSpec BabbageEra Int
x)
              , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec BabbageEra Int -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Int
x
              , String
"s1 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (RngSpec BabbageEra Int -> Size
forall dom era. RngSpec era dom -> Size
sizeForRng RngSpec BabbageEra Int
y)
              , String
"s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec BabbageEra Int -> String
forall a. Show a => a -> String
show RngSpec BabbageEra Int
y
              , String
"GenFromRngSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" n=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
              ]
        [Int]
z <- forall era r.
Era era =>
[String] -> Gen r -> Int -> RngSpec era r -> Gen [r]
genFromRngSpec @BabbageEra [String]
wordsX ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
100)) Int
i RngSpec BabbageEra Int
m
        (RngSpec BabbageEra Int, Bool, RngSpec BabbageEra Int, Bool, [Int],
 Bool, RngSpec BabbageEra Int)
-> Gen
     (RngSpec BabbageEra Int, Bool, RngSpec BabbageEra Int, Bool, [Int],
      Bool, RngSpec BabbageEra Int)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RngSpec BabbageEra Int
x, [Int] -> RngSpec BabbageEra Int -> Bool
forall r era. [r] -> RngSpec era r -> Bool
runRngSpec [Int]
z RngSpec BabbageEra Int
x, RngSpec BabbageEra Int
y, [Int] -> RngSpec BabbageEra Int -> Bool
forall r era. [r] -> RngSpec era r -> Bool
runRngSpec [Int]
z RngSpec BabbageEra Int
y, [Int]
z, [Int] -> RngSpec BabbageEra Int -> Bool
forall r era. [r] -> RngSpec era r -> Bool
runRngSpec [Int]
z RngSpec BabbageEra Int
m, RngSpec BabbageEra Int
m)
      showAns :: (RngSpec era dom, a, RngSpec era dom, a, a, a, RngSpec era dom)
-> String
showAns (RngSpec era dom
s1, a
run1, RngSpec era dom
s2, a
run2, a
v, a
run3, RngSpec era dom
s3) =
        [String] -> String
unlines
          [ String
"\ns1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era dom -> String
forall a. Show a => a -> String
show RngSpec era dom
s1
          , String
"s1 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (RngSpec era dom -> Size
forall dom era. RngSpec era dom -> Size
sizeForRng RngSpec era dom
s1)
          , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era dom -> String
forall a. Show a => a -> String
show RngSpec era dom
s2
          , String
"s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (RngSpec era dom -> Size
forall dom era. RngSpec era dom -> Size
sizeForRng RngSpec era dom
s2)
          , String
"s1 <> s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era dom -> String
forall a. Show a => a -> String
show RngSpec era dom
s3
          , String
"s1<>s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (RngSpec era dom -> Size
forall dom era. RngSpec era dom -> Size
sizeForRng RngSpec era dom
s3)
          , String
"v = genFromRngSpec (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v
          , String
"runRngSpec v s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run1
          , String
"runRngSpec v s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run2
          , String
"runRngSpec v (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run3
          ]
      pr :: (RngSpec era dom, Bool, RngSpec era dom, Bool, a, Bool,
 RngSpec era dom)
-> Maybe String
pr x :: (RngSpec era dom, Bool, RngSpec era dom, Bool, a, Bool,
 RngSpec era dom)
x@(RngSpec era dom
_, Bool
a, RngSpec era dom
_, Bool
b, a
_, Bool
c, RngSpec era dom
_) = if Bool -> Bool
not (Bool
a Bool -> Bool -> Bool
&& Bool
b Bool -> Bool -> Bool
&& Bool
c) then String -> Maybe String
forall a. a -> Maybe a
Just ((RngSpec era dom, Bool, RngSpec era dom, Bool, a, Bool,
 RngSpec era dom)
-> String
forall {a} {a} {a} {a} {era} {dom} {era} {dom} {era} {dom}.
(Show a, Show a, Show a, Show a) =>
(RngSpec era dom, a, RngSpec era dom, a, a, a, RngSpec era dom)
-> String
showAns (RngSpec era dom, Bool, RngSpec era dom, Bool, a, Bool,
 RngSpec era dom)
x) else Maybe String
forall a. Maybe a
Nothing
  let trips :: [(RngSpec BabbageEra Int, RngSpec BabbageEra Int,
  RngSpec BabbageEra Int)]
trips = [(RngSpec BabbageEra Int
x, RngSpec BabbageEra Int
y, RngSpec BabbageEra Int
m) | RngSpec BabbageEra Int
x <- [RngSpec BabbageEra Int]
xs, RngSpec BabbageEra Int
y <- [RngSpec BabbageEra Int]
ys, Just RngSpec BabbageEra Int
m <- [RngSpec BabbageEra Int
-> RngSpec BabbageEra Int -> Maybe (RngSpec BabbageEra Int)
forall a. (LiftT a, Semigroup a) => a -> a -> Maybe a
consistent RngSpec BabbageEra Int
x RngSpec BabbageEra Int
y]]
  [(RngSpec BabbageEra Int, Bool, RngSpec BabbageEra Int, Bool,
  [Int], Bool, RngSpec BabbageEra Int)]
ts <- ((RngSpec BabbageEra Int, RngSpec BabbageEra Int,
  RngSpec BabbageEra Int)
 -> Gen
      (RngSpec BabbageEra Int, Bool, RngSpec BabbageEra Int, Bool, [Int],
       Bool, RngSpec BabbageEra Int))
-> [(RngSpec BabbageEra Int, RngSpec BabbageEra Int,
     RngSpec BabbageEra Int)]
-> Gen
     [(RngSpec BabbageEra Int, Bool, RngSpec BabbageEra Int, Bool,
       [Int], Bool, RngSpec BabbageEra Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (RngSpec BabbageEra Int, RngSpec BabbageEra Int,
 RngSpec BabbageEra Int)
-> Gen
     (RngSpec BabbageEra Int, Bool, RngSpec BabbageEra Int, Bool, [Int],
      Bool, RngSpec BabbageEra Int)
check [(RngSpec BabbageEra Int, RngSpec BabbageEra Int,
  RngSpec BabbageEra Int)]
trips
  (Int, Int, [String]) -> Gen (Int, Int, [String])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, Int, [String]) -> Gen (Int, Int, [String]))
-> (Int, Int, [String]) -> Gen (Int, Int, [String])
forall a b. (a -> b) -> a -> b
$ (Int
n, [(RngSpec BabbageEra Int, RngSpec BabbageEra Int,
  RngSpec BabbageEra Int)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(RngSpec BabbageEra Int, RngSpec BabbageEra Int,
  RngSpec BabbageEra Int)]
trips, ((RngSpec BabbageEra Int, Bool, RngSpec BabbageEra Int, Bool,
  [Int], Bool, RngSpec BabbageEra Int)
 -> Maybe String)
-> [(RngSpec BabbageEra Int, Bool, RngSpec BabbageEra Int, Bool,
     [Int], Bool, RngSpec BabbageEra Int)]
-> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (RngSpec BabbageEra Int, Bool, RngSpec BabbageEra Int, Bool, [Int],
 Bool, RngSpec BabbageEra Int)
-> Maybe String
forall {a} {era} {dom} {era} {dom} {era} {dom}.
Show a =>
(RngSpec era dom, Bool, RngSpec era dom, Bool, a, Bool,
 RngSpec era dom)
-> Maybe String
pr [(RngSpec BabbageEra Int, Bool, RngSpec BabbageEra Int, Bool,
  [Int], Bool, RngSpec BabbageEra Int)]
ts)

reportManyMergeRngSpec :: IO ()
reportManyMergeRngSpec :: IO ()
reportManyMergeRngSpec = do
  (Int
n, Int
passed, [String]
bad) <- Gen (Int, Int, [String]) -> IO (Int, Int, [String])
forall a. Gen a -> IO a
generate Gen (Int, Int, [String])
manyMergeRngSpec
  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
bad
    then String -> IO ()
putStrLn (String
"passed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
passed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests. Spec size " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
    else do (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
bad; String -> IO ()
forall a. HasCallStack => String -> a
error String
"TestFails"

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

-- | Indicates which constraints (if any) a Map must adhere to
data MapSpec era dom rng where
  -- | The map may be constrained 3 ways. 1) Its size(Size) 2) its domain(RelSpec) 3) its range(RngSpec)
  MapSpec ::
    Size ->
    RelSpec era dom ->
    PairSpec era dom rng ->
    RngSpec era rng ->
    MapSpec era dom rng
  -- | Something is inconsistent
  MapNever :: [String] -> MapSpec era dom rng

instance Ord d => Show (MapSpec w d r) where
  show :: MapSpec w d r -> String
show = MapSpec w d r -> String
forall era dom rng. MapSpec era dom rng -> String
showMapSpec

instance (Ord dom, Era era) => Semigroup (MapSpec era dom rng) where
  <> :: MapSpec era dom rng -> MapSpec era dom rng -> MapSpec era dom rng
(<>) = MapSpec era dom rng -> MapSpec era dom rng -> MapSpec era dom rng
forall dom era rng.
Ord dom =>
MapSpec era dom rng -> MapSpec era dom rng -> MapSpec era dom rng
mergeMapSpec

instance (Ord dom, Era era) => Monoid (MapSpec era dom rng) where
  mempty :: MapSpec era dom rng
mempty = Size
-> RelSpec era dom
-> PairSpec era dom rng
-> RngSpec era rng
-> MapSpec era dom rng
forall era dom rng.
Size
-> RelSpec era dom
-> PairSpec era dom rng
-> RngSpec era rng
-> MapSpec era dom rng
MapSpec Size
SzAny RelSpec era dom
forall era dom. RelSpec era dom
RelAny PairSpec era dom rng
forall era a b. PairSpec era a b
PairAny RngSpec era rng
forall era rng. RngSpec era rng
RngAny

instance LiftT (MapSpec era a b) where
  liftT :: MapSpec era a b -> Typed (MapSpec era a b)
liftT (MapNever [String]
xs) = [String] -> Typed (MapSpec era a b)
forall a. [String] -> Typed a
failT [String]
xs
  liftT MapSpec era a b
x = MapSpec era a b -> Typed (MapSpec era a b)
forall a. a -> Typed a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MapSpec era a b
x
  dropT :: Typed (MapSpec era a b) -> MapSpec era a b
dropT (Typed (Left [String]
s)) = [String] -> MapSpec era a b
forall era dom rng. [String] -> MapSpec era dom rng
MapNever [String]
s
  dropT (Typed (Right MapSpec era a b
x)) = MapSpec era a b
x

showMapSpec :: MapSpec era dom rng -> String
showMapSpec :: forall era dom rng. MapSpec era dom rng -> String
showMapSpec (MapSpec Size
w RelSpec era dom
d PairSpec era dom rng
p RngSpec era rng
r) =
  String
"("
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines
      [ String
"MapSpec"
      , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
w
      , String
"   "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"   "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era dom -> String
forall era dom. RelSpec era dom -> String
showRelSpec RelSpec era dom
d
      , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec era dom rng -> String
forall era dom rng. PairSpec era dom rng -> String
showPairSpec PairSpec era dom rng
p
      , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era rng -> String
forall era t. RngSpec era t -> String
showRngSpec RngSpec era rng
r
      ]
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showMapSpec (MapNever [String]
_) = String
"MapNever"

mergeMapSpec :: Ord dom => MapSpec era dom rng -> MapSpec era dom rng -> MapSpec era dom rng
mergeMapSpec :: forall dom era rng.
Ord dom =>
MapSpec era dom rng -> MapSpec era dom rng -> MapSpec era dom rng
mergeMapSpec MapSpec era dom rng
spec1 MapSpec era dom rng
spec2 = case (MapSpec era dom rng
spec1, MapSpec era dom rng
spec2) of
  (MapNever [String]
s, MapNever [String]
t) -> [String] -> MapSpec era dom rng
forall era dom rng. [String] -> MapSpec era dom rng
MapNever ([String]
s [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
t)
  (MapNever [String]
_, MapSpec era dom rng
y) -> MapSpec era dom rng
y
  (MapSpec era dom rng
x, MapNever [String]
_) -> MapSpec era dom rng
x
  (MapSpec Size
SzAny RelSpec era dom
RelAny PairSpec era dom rng
PairAny RngSpec era rng
RngAny, MapSpec era dom rng
x) -> MapSpec era dom rng
x
  (MapSpec era dom rng
x, MapSpec Size
SzAny RelSpec era dom
RelAny PairSpec era dom rng
PairAny RngSpec era rng
RngAny) -> MapSpec era dom rng
x
  (MapSpec Size
s1 RelSpec era dom
d1 PairSpec era dom rng
p1 RngSpec era rng
r1, MapSpec Size
s2 RelSpec era dom
d2 PairSpec era dom rng
p2 RngSpec era rng
r2) -> case RngSpec era rng -> RngSpec era rng -> RngSpec era rng
forall r era. RngSpec era r -> RngSpec era r -> RngSpec era r
mergeRngSpec RngSpec era rng
r1 RngSpec era rng
r2 of
    RngNever [String]
msgs -> [String] -> MapSpec era dom rng
forall era dom rng. [String] -> MapSpec era dom rng
MapNever ([String
"The MapSpec's are inconsistent.", String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era dom rng -> String
forall a. Show a => a -> String
show MapSpec era dom rng
spec1, String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era dom rng -> String
forall a. Show a => a -> String
show MapSpec era dom rng
spec2] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
msgs)
    RngSpec era rng
r -> case RelSpec era dom -> RelSpec era dom -> RelSpec era dom
forall era dom.
RelSpec era dom -> RelSpec era dom -> RelSpec era dom
mergeRelSpec RelSpec era dom
d1 RelSpec era dom
d2 of
      RelNever [String]
msgs -> [String] -> MapSpec era dom rng
forall era dom rng. [String] -> MapSpec era dom rng
MapNever ([String
"The MapSpec's are inconsistent.", String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era dom rng -> String
forall a. Show a => a -> String
show MapSpec era dom rng
spec1, String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era dom rng -> String
forall a. Show a => a -> String
show MapSpec era dom rng
spec2] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
msgs)
      RelSpec era dom
d -> case PairSpec era dom rng
-> PairSpec era dom rng -> PairSpec era dom rng
forall era a b.
PairSpec era a b -> PairSpec era a b -> PairSpec era a b
mergePairSpec PairSpec era dom rng
p1 PairSpec era dom rng
p2 of
        PairNever [String]
msgs -> [String] -> MapSpec era dom rng
forall era dom rng. [String] -> MapSpec era dom rng
MapNever ([String
"The MapSpec's are inconsistent.", String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era dom rng -> String
forall a. Show a => a -> String
show MapSpec era dom rng
spec1, String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era dom rng -> String
forall a. Show a => a -> String
show MapSpec era dom rng
spec2] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
msgs)
        PairSpec era dom rng
p ->
          Typed (MapSpec era dom rng) -> MapSpec era dom rng
forall x. LiftT x => Typed x -> x
dropT
            (String
-> Typed (MapSpec era dom rng) -> Typed (MapSpec era dom rng)
forall a. String -> Typed a -> Typed a
explain (String
"While merging\n   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era dom rng -> String
forall a. Show a => a -> String
show MapSpec era dom rng
spec1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era dom rng -> String
forall a. Show a => a -> String
show MapSpec era dom rng
spec2) (Size
-> RelSpec era dom
-> PairSpec era dom rng
-> RngSpec era rng
-> Typed (MapSpec era dom rng)
forall d era r.
Ord d =>
Size
-> RelSpec era d
-> PairSpec era d r
-> RngSpec era r
-> Typed (MapSpec era d r)
mapSpec (Size
s1 Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> Size
s2) RelSpec era dom
d PairSpec era dom rng
p RngSpec era rng
r))

-- | Use 'mapSpec' instead of 'MapSpec' to check size and PairSpec consistency at creation time.
--   Runs in the type monad, so errors are caught and reported as Solver-time errors.
--   This should avoid many Gen-time errors, as many of those are cause by size
--   inconsistencies. We can also use this in mergeMapSpec, to catch size
--   inconsistencies there as well as (\ a b c -> dropT (mapSpec a b c)) has the same
--   type as MapSpec, but pushes the reports of inconsistencies into MapNever.
mapSpec ::
  Ord d => Size -> RelSpec era d -> PairSpec era d r -> RngSpec era r -> Typed (MapSpec era d r)
mapSpec :: forall d era r.
Ord d =>
Size
-> RelSpec era d
-> PairSpec era d r
-> RngSpec era r
-> Typed (MapSpec era d r)
mapSpec Size
sz1 RelSpec era d
rel PairSpec era d r
pair RngSpec era r
rng =
  let sz2 :: Size
sz2 = RelSpec era d -> Size
forall era dom. RelSpec era dom -> Size
sizeForRel RelSpec era d
rel
      sz3 :: Size
sz3 = RngSpec era r -> Size
forall dom era. RngSpec era dom -> Size
sizeForRng RngSpec era r
rng
      sz4 :: Size
sz4 = PairSpec era d r -> Size
forall era dom rng. PairSpec era dom rng -> Size
sizeForPairSpec PairSpec era d r
pair
   in case Size
sz1 Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> Size
sz2 Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> Size
sz3 Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> Size
sz4 of
        SzNever [String]
xs ->
          [String] -> Typed (MapSpec era d r)
forall a. [String] -> Typed a
failT
            ( [ String
"Creating " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era d r -> String
forall a. Show a => a -> String
show (Size
-> RelSpec era d
-> PairSpec era d r
-> RngSpec era r
-> MapSpec era d r
forall era dom rng.
Size
-> RelSpec era dom
-> PairSpec era dom rng
-> RngSpec era rng
-> MapSpec era dom rng
MapSpec Size
sz1 RelSpec era d
rel PairSpec era d r
pair RngSpec era r
rng) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" fails."
              , String
"It has size inconsistencies."
              , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era d -> String
forall a. Show a => a -> String
show RelSpec era d
rel String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has size " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
sz2
              , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec era d r -> String
forall a. Show a => a -> String
show PairSpec era d r
pair String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has size " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
sz4
              , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era r -> String
forall a. Show a => a -> String
show RngSpec era r
rng String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has size " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
sz3
              ]
                [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
xs
            )
        Size
size ->
          case (RelSpec era d
rel, PairSpec era d r
pair, RngSpec era r
rng) of
            (RelSpec era d
_, PairSpec era d r
PairAny, RngSpec era r
_) -> MapSpec era d r -> Typed (MapSpec era d r)
forall a. a -> Typed a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size
-> RelSpec era d
-> PairSpec era d r
-> RngSpec era r
-> MapSpec era d r
forall era dom rng.
Size
-> RelSpec era dom
-> PairSpec era dom rng
-> RngSpec era rng
-> MapSpec era dom rng
MapSpec Size
size RelSpec era d
rel PairSpec era d r
pair RngSpec era r
rng)
            ((RelOper Rep era d
_ Set d
mustd Maybe (Set d)
_ Set d
_), PairSpec Rep era d
d Rep era r
r PairSide
VarOnRight Map d r
m, (RngRel (RelOper Rep era r
_ Set r
mustr Maybe (Set r)
_ Set r
_))) ->
              String -> Typed (MapSpec era d r) -> Typed (MapSpec era d r)
forall a. String -> Typed a -> Typed a
explain
                (String
"Creating " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era d r -> String
forall a. Show a => a -> String
show (Size
-> RelSpec era d
-> PairSpec era d r
-> RngSpec era r
-> MapSpec era d r
forall era dom rng.
Size
-> RelSpec era dom
-> PairSpec era dom rng
-> RngSpec era rng
-> MapSpec era dom rng
MapSpec Size
sz1 RelSpec era d
rel PairSpec era d r
pair RngSpec era r
rng) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" fails.")
                ( [(Bool, [String])]
-> Typed (MapSpec era d r) -> Typed (MapSpec era d r)
forall a. [(Bool, [String])] -> Typed a -> Typed a
requireAll
                    [
                      ( (Map d r -> Set d
forall k a. Map k a -> Set k
Map.keysSet Map d r
m Set d -> Set d -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set d
mustd)
                      ,
                        [ String
"sizes " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Size, Size, Size, Size) -> String
forall a. Show a => a -> String
show (Size
sz1, Size
sz2, Size
sz3, Size
sz4)
                        , String
"It has PairSpec inconsistencies. The domain of"
                        , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Map d r) -> Map d r -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era d -> Rep era r -> Rep era (Map d r)
forall a era b.
Ord a =>
Rep era a -> Rep era b -> Rep era (Map a b)
MapR Rep era d
d Rep era r
r) Map d r
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a subset of the of the mustSet"
                        , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Set d) -> Set d -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era d -> Rep era (Set d)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era d
d) Set d
mustd
                        , String
"   TEST " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (Map d r -> Set d
forall k a. Map k a -> Set k
Map.keysSet Map d r
m Set d -> Set d -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set d
mustd)
                        ]
                      )
                    ,
                      ( ([r] -> Set r
forall a. Ord a => [a] -> Set a
Set.fromList (Map d r -> [r]
forall k a. Map k a -> [a]
Map.elems Map d r
m) Set r -> Set r -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set r
mustr)
                      ,
                        [ String
"It has PairSpec inconsistencies. The range of"
                        , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Map d r) -> Map d r -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era d -> Rep era r -> Rep era (Map d r)
forall a era b.
Ord a =>
Rep era a -> Rep era b -> Rep era (Map a b)
MapR Rep era d
d Rep era r
r) Map d r
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a subset of the of the mustSet"
                        , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Set r) -> Set r -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era r -> Rep era (Set r)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era r
r) Set r
mustr
                        , String
"   TEST " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (Map d r -> Set d
forall k a. Map k a -> Set k
Map.keysSet Map d r
m Set d -> Set d -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set d
mustd)
                        ]
                      )
                    ]
                    (MapSpec era d r -> Typed (MapSpec era d r)
forall a. a -> Typed a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size
-> RelSpec era d
-> PairSpec era d r
-> RngSpec era r
-> MapSpec era d r
forall era dom rng.
Size
-> RelSpec era dom
-> PairSpec era dom rng
-> RngSpec era rng
-> MapSpec era dom rng
MapSpec Size
size RelSpec era d
rel PairSpec era d r
pair RngSpec era r
rng))
                )
            ((RelOper Rep era d
_ Set d
mustd Maybe (Set d)
_ Set d
_), PairSpec Rep era d
d Rep era r
r PairSide
VarOnLeft Map d r
m, (RngRel (RelOper Rep era r
_ Set r
mustr Maybe (Set r)
_ Set r
_))) ->
              String -> Typed (MapSpec era d r) -> Typed (MapSpec era d r)
forall a. String -> Typed a -> Typed a
explain
                (String
"Creating " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era d r -> String
forall a. Show a => a -> String
show (Size
-> RelSpec era d
-> PairSpec era d r
-> RngSpec era r
-> MapSpec era d r
forall era dom rng.
Size
-> RelSpec era dom
-> PairSpec era dom rng
-> RngSpec era rng
-> MapSpec era dom rng
MapSpec Size
sz1 RelSpec era d
rel PairSpec era d r
pair RngSpec era r
rng) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" fails.")
                ( [(Bool, [String])]
-> Typed (MapSpec era d r) -> Typed (MapSpec era d r)
forall a. [(Bool, [String])] -> Typed a -> Typed a
requireAll
                    [
                      ( (Set d
mustd Set d -> Set d -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Map d r -> Set d
forall k a. Map k a -> Set k
Map.keysSet Map d r
m)
                      ,
                        [ String
"sizes " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Size, Size, Size, Size) -> String
forall a. Show a => a -> String
show (Size
sz1, Size
sz2, Size
sz3, Size
sz4)
                        , String
"It has PairSpec inconsistencies. The domain of"
                        , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Map d r) -> Map d r -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era d -> Rep era r -> Rep era (Map d r)
forall a era b.
Ord a =>
Rep era a -> Rep era b -> Rep era (Map a b)
MapR Rep era d
d Rep era r
r) Map d r
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a subset of the of the mustSet"
                        , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Set d) -> Set d -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era d -> Rep era (Set d)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era d
d) Set d
mustd
                        , String
"   TEST " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (Map d r -> Set d
forall k a. Map k a -> Set k
Map.keysSet Map d r
m Set d -> Set d -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set d
mustd)
                        ]
                      )
                    ,
                      ( (Set r
mustr Set r -> Set r -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` [r] -> Set r
forall a. Ord a => [a] -> Set a
Set.fromList (Map d r -> [r]
forall k a. Map k a -> [a]
Map.elems Map d r
m))
                      ,
                        [ String
"It has PairSpec inconsistencies. The range of"
                        , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Map d r) -> Map d r -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era d -> Rep era r -> Rep era (Map d r)
forall a era b.
Ord a =>
Rep era a -> Rep era b -> Rep era (Map a b)
MapR Rep era d
d Rep era r
r) Map d r
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a subset of the of the mustSet"
                        , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Set r) -> Set r -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era r -> Rep era (Set r)
forall a era. Ord a => Rep era a -> Rep era (Set a)
SetR Rep era r
r) Set r
mustr
                        , String
"   TEST " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (Map d r -> Set d
forall k a. Map k a -> Set k
Map.keysSet Map d r
m Set d -> Set d -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set d
mustd)
                        ]
                      )
                    ]
                    (MapSpec era d r -> Typed (MapSpec era d r)
forall a. a -> Typed a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size
-> RelSpec era d
-> PairSpec era d r
-> RngSpec era r
-> MapSpec era d r
forall era dom rng.
Size
-> RelSpec era dom
-> PairSpec era dom rng
-> RngSpec era rng
-> MapSpec era dom rng
MapSpec Size
size RelSpec era d
rel PairSpec era d r
pair RngSpec era r
rng))
                )
            (RelSpec era d
_, PairSpec Rep era d
_d Rep era r
_r PairSide
_side Map d r
_m, RngSpec era r
_) ->
              [String] -> Typed (MapSpec era d r)
forall a. [String] -> Typed a
failT
                [ String
"Creating " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era d r -> String
forall a. Show a => a -> String
show (Size
-> RelSpec era d
-> PairSpec era d r
-> RngSpec era r
-> MapSpec era d r
forall era dom rng.
Size
-> RelSpec era dom
-> PairSpec era dom rng
-> RngSpec era rng
-> MapSpec era dom rng
MapSpec Size
sz1 RelSpec era d
rel PairSpec era d r
pair RngSpec era r
rng) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" fails."
                , String
"This spec has a non-PairAny PairSpec"
                , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec era d r -> String
forall a. Show a => a -> String
show PairSpec era d r
pair
                , String
"so to be consistent it must have both a RelOper RelSpec, and a RngRel RelSpec."
                , String
"But it does not:"
                , String
"   RelSpec = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era d -> String
forall a. Show a => a -> String
show RelSpec era d
rel
                , String
"   RngSpec = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RngSpec era r -> String
forall a. Show a => a -> String
show RngSpec era r
rng
                ]
            (RelSpec era d
_, PairSpec era d r
p, RngSpec era r
_) | PairSpec era d r -> Bool
forall era d r. PairSpec era d r -> Bool
anyPairSpec PairSpec era d r
p -> MapSpec era d r -> Typed (MapSpec era d r)
forall a. a -> Typed a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size
-> RelSpec era d
-> PairSpec era d r
-> RngSpec era r
-> MapSpec era d r
forall era dom rng.
Size
-> RelSpec era dom
-> PairSpec era dom rng
-> RngSpec era rng
-> MapSpec era dom rng
MapSpec Size
size RelSpec era d
rel PairSpec era d r
pair RngSpec era r
rng)
            (RelSpec era d
_, PairNever [String]
msgs, RngSpec era r
_) ->
              [String] -> Typed (MapSpec era d r)
forall a. [String] -> Typed a
failT
                ((String
"Creating " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era d r -> String
forall a. Show a => a -> String
show (Size
-> RelSpec era d
-> PairSpec era d r
-> RngSpec era r
-> MapSpec era d r
forall era dom rng.
Size
-> RelSpec era dom
-> PairSpec era dom rng
-> RngSpec era rng
-> MapSpec era dom rng
MapSpec Size
sz1 RelSpec era d
rel PairSpec era d r
pair RngSpec era r
rng) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" fails.") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs)

-- ------------------------------------------
-- MapSpec test functions

-- | test a Map against a MapSpec
runMapSpec :: (Ord d, Eq r) => Map d r -> MapSpec era d r -> Bool
runMapSpec :: forall d r era. (Ord d, Eq r) => Map d r -> MapSpec era d r -> Bool
runMapSpec Map d r
_ (MapNever [String]
xs) = String -> [String] -> Bool
forall a. HasCallStack => String -> [String] -> a
errorMess String
"MapNever in runMapSpec" [String]
xs
runMapSpec Map d r
_ (MapSpec Size
SzAny RelSpec era d
RelAny PairSpec era d r
PairAny RngSpec era r
RngAny) = Bool
True
runMapSpec Map d r
m (MapSpec Size
sz RelSpec era d
dom PairSpec era d r
pair RngSpec era r
rng) =
  Int -> Size -> Bool
runSize (Map d r -> Int
forall k a. Map k a -> Int
Map.size Map d r
m) Size
sz
    Bool -> Bool -> Bool
&& Set d -> RelSpec era d -> Bool
forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec (Map d r -> Set d
forall k a. Map k a -> Set k
Map.keysSet Map d r
m) RelSpec era d
dom
    Bool -> Bool -> Bool
&& Map d r -> PairSpec era d r -> Bool
forall dom rng era.
(Ord dom, Eq rng) =>
Map dom rng -> PairSpec era dom rng -> Bool
runPairSpec Map d r
m PairSpec era d r
pair
    Bool -> Bool -> Bool
&& [r] -> RngSpec era r -> Bool
forall r era. [r] -> RngSpec era r -> Bool
runRngSpec (Map d r -> [r]
forall k a. Map k a -> [a]
Map.elems Map d r
m) RngSpec era r
rng

-- | compute a Size that bounds a MapSpec
sizeForMapSpec :: MapSpec era d r -> Size
sizeForMapSpec :: forall era d r. MapSpec era d r -> Size
sizeForMapSpec (MapSpec Size
sz RelSpec era d
_ PairSpec era d r
_ RngSpec era r
_) = Size
sz
sizeForMapSpec (MapNever [String]
_) = Size
SzAny

-- ----------------------------------------
-- MapSpec generators

-- | Generate a random MapSpec
genMapSpec ::
  forall era dom w.
  (Ord dom, Era era, Ord w, Adds w) =>
  Gen dom ->
  Rep era dom ->
  Rep era w ->
  -- Rep era c ->
  -- (forall c. Adds c => Lens' w c) ->
  SomeLens era w ->
  Int ->
  Gen (MapSpec era dom w)
genMapSpec :: forall era dom w.
(Ord dom, Era era, Ord w, Adds w) =>
Gen dom
-> Rep era dom
-> Rep era w
-> SomeLens era w
-> Int
-> Gen (MapSpec era dom w)
genMapSpec Gen dom
genD Rep era dom
repd Rep era w
repw SomeLens era w
l Int
n = [(Int, Gen (MapSpec era dom w))] -> Gen (MapSpec era dom w)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
1, MapSpec era dom w -> Gen (MapSpec era dom w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MapSpec era dom w
forall a. Monoid a => a
mempty), (Int
6, Gen (MapSpec era dom w)
genmapspec)]
  where
    genmapspec :: Gen (MapSpec era dom w)
genmapspec = do
      RelSpec era dom
relspec <- [String] -> Gen dom -> Rep era dom -> Int -> Gen (RelSpec era dom)
forall dom era.
Ord dom =>
[String] -> Gen dom -> Rep era dom -> Int -> Gen (RelSpec era dom)
genRelSpec [String
"genMapSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era dom -> String
forall a. Show a => a -> String
show Rep era dom
repd] Gen dom
genD Rep era dom
repd Int
n
      RngSpec era w
rngspec <- Gen w -> Rep era w -> SomeLens era w -> Int -> Gen (RngSpec era w)
forall w era.
(Ord w, Adds w) =>
Gen w -> Rep era w -> SomeLens era w -> Int -> Gen (RngSpec era w)
genRngSpec (forall era b. Rep era b -> Gen b
genRep @era Rep era w
repw) Rep era w
repw SomeLens era w
l Int
n
      MapSpec era dom w -> Gen (MapSpec era dom w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size
-> RelSpec era dom
-> PairSpec era dom w
-> RngSpec era w
-> MapSpec era dom w
forall era dom rng.
Size
-> RelSpec era dom
-> PairSpec era dom rng
-> RngSpec era rng
-> MapSpec era dom rng
MapSpec (Int -> Size
SzExact Int
n) RelSpec era dom
relspec PairSpec era dom w
forall era a b. PairSpec era a b
PairAny RngSpec era w
rngspec)

-- | Generate a (Map d t) from a (MapSpec era d r)
-- genFromMapSpec ::
--   forall era w dom.
--   (Era era, Ord dom) =>
--   (V era (Map dom w)) ->
--   [String] ->
--   Gen dom ->
--   Gen w ->
--   MapSpec era dom w ->
--   Gen (Map dom w)
-- genFromMapSpec nm _ _ _ (MapNever xs) = errorMess ("genFromMapSpec " ++ (show nm) ++ " (MapNever _) fails") xs
-- genFromMapSpec nm msgs genD genR ms@(MapSpec size rel pair rng) = do
--   n <- genFromSize size
--   dom <-
--     genFromRelSpec
--       (("GenFromMapSpec " ++ (show nm) ++ "\n   " ++ show ms) : msgs)
--       genD
--       n
--       rel
--   rangelist <-
--     genFromRngSpec
--       (("genFromMapSpec " ++ (show nm) ++ "\n   " ++ show ms) : msgs)
--       genR
--       n
--       rng
--   pure (Map.fromList (zip (Set.toList dom) rangelist))
genFromMapSpec ::
  forall era w dom.
  (Era era, Ord dom) =>
  String ->
  [String] ->
  Gen dom ->
  Gen w ->
  MapSpec era dom w ->
  Gen (Map dom w)
genFromMapSpec :: forall era w dom.
(Era era, Ord dom) =>
String
-> [String]
-> Gen dom
-> Gen w
-> MapSpec era dom w
-> Gen (Map dom w)
genFromMapSpec String
nm [String]
msgs Gen dom
_ Gen w
_ (MapSpec Size
_size RelSpec era dom
_ (PairNever [String]
xs) RngSpec era w
_) =
  String -> [String] -> Gen (Map dom w)
forall a. HasCallStack => String -> [String] -> a
errorMess (String
"genFromMapSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (PairNever _) fails") ([String]
msgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
xs)
genFromMapSpec String
nm [String]
_ Gen dom
_ Gen w
_ (MapNever [String]
xs) =
  String -> [String] -> Gen (Map dom w)
forall a. HasCallStack => String -> [String] -> a
errorMess (String
"genFromMapSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (MapNever _) fails") [String]
xs
genFromMapSpec String
nm [String]
msgs Gen dom
genD Gen w
genR ms :: MapSpec era dom w
ms@(MapSpec Size
size RelSpec era dom
rel PairSpec era dom w
PairAny RngSpec era w
rng) = do
  Int
n <- Size -> Gen Int
genFromSize Size
size
  Set dom
dom <-
    [String] -> Gen dom -> Int -> RelSpec era dom -> Gen (Set dom)
forall era t.
(Era era, Ord t) =>
[String] -> Gen t -> Int -> RelSpec era t -> Gen (Set t)
genFromRelSpec
      ((String
"GenFromMapSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era dom w -> String
forall a. Show a => a -> String
show MapSpec era dom w
ms) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs)
      Gen dom
genD
      Int
n
      RelSpec era dom
rel
  [w]
rangelist <-
    [String] -> Gen w -> Int -> RngSpec era w -> Gen [w]
forall era r.
Era era =>
[String] -> Gen r -> Int -> RngSpec era r -> Gen [r]
genFromRngSpec
      ((String
"genFromMapSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era dom w -> String
forall a. Show a => a -> String
show MapSpec era dom w
ms) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs)
      Gen w
genR
      Int
n
      RngSpec era w
rng
  Map dom w -> Gen (Map dom w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(dom, w)] -> Map dom w
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([dom] -> [w] -> [(dom, w)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set dom -> [dom]
forall a. Set a -> [a]
Set.toList Set dom
dom) [w]
rangelist))
genFromMapSpec String
nm [String]
msgs Gen dom
genD Gen w
genR ms :: MapSpec era dom w
ms@(MapSpec Size
size RelSpec era dom
rel (PairSpec Rep era dom
dr Rep era w
rr PairSide
varside Map dom w
m) RngSpec era w
rng) = do
  Int
n <- Size -> Gen Int
genFromSize Size
size
  Set dom
dom <-
    [String] -> Gen dom -> Int -> RelSpec era dom -> Gen (Set dom)
forall era t.
(Era era, Ord t) =>
[String] -> Gen t -> Int -> RelSpec era t -> Gen (Set t)
genFromRelSpec
      ((String
"GenFromMapSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era dom w -> String
forall a. Show a => a -> String
show MapSpec era dom w
ms) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs)
      Gen dom
genD
      Int
n
      RelSpec era dom
rel
  [w]
rangelist <-
    [String] -> Gen w -> Int -> RngSpec era w -> Gen [w]
forall era r.
Era era =>
[String] -> Gen r -> Int -> RngSpec era r -> Gen [r]
genFromRngSpec
      ((String
"genFromMapSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era dom w -> String
forall a. Show a => a -> String
show MapSpec era dom w
ms) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs)
      Gen w
genR
      Int
n
      RngSpec era w
rng
  let domainlist :: [dom]
domainlist = Set dom -> [dom]
forall a. Set a -> [a]
Set.toList Set dom
dom
      extraPairs :: [(dom, w)]
extraPairs = PairSide
-> Rep era dom
-> Rep era w
-> Map dom w
-> ([dom], [w])
-> [(dom, w)]
forall d r era.
(Ord d, Eq r) =>
PairSide
-> Rep era d -> Rep era r -> Map d r -> ([d], [r]) -> [(d, r)]
pairSpecTransform PairSide
varside Rep era dom
dr Rep era w
rr Map dom w
m ([dom]
domainlist, [w]
rangelist)
  case PairSide
varside of
    PairSide
VarOnRight -> Map dom w -> Gen (Map dom w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map dom w -> Map dom w -> Map dom w
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map dom w
m ([(dom, w)] -> Map dom w
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(dom, w)]
extraPairs))
    PairSide
VarOnLeft -> Int -> Map dom w -> Gen (Map dom w)
forall k a. Ord k => Int -> Map k a -> Gen (Map k a)
subMapFromMapWithSize Int
n (Map dom w -> Set dom -> Map dom w
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys Map dom w
m ([dom] -> Set dom
forall a. Ord a => [a] -> Set a
Set.fromList (((dom, w) -> dom) -> [(dom, w)] -> [dom]
forall a b. (a -> b) -> [a] -> [b]
map (dom, w) -> dom
forall a b. (a, b) -> a
fst [(dom, w)]
extraPairs)))

-- | Transform the domain and range lists by removing the (domain,range) pairs from 'm'.
--   for each pair (domain,range) remove domain from 'dlist' and range from 'rlist',
--   then zip together the two remaining lists. The pairs in this list are 'extra'
--   pairs which might me useful.
--   Strategy depends on which term to (SubMap t1 t2) are variables.
--   (SubMap xvar yexp) Break value of yexp into (x + extra), then answer: xvar = x
--   (SubMap xexp yvar) Break value of xexp into (x + extra), then answer: yvar == x + extra
pairSpecTransform ::
  (Ord d, Eq r) => PairSide -> Rep era d -> Rep era r -> Map d r -> ([d], [r]) -> [(d, r)]
pairSpecTransform :: forall d r era.
(Ord d, Eq r) =>
PairSide
-> Rep era d -> Rep era r -> Map d r -> ([d], [r]) -> [(d, r)]
pairSpecTransform PairSide
side Rep era d
drep Rep era r
rrep Map d r
m ([d]
dlist, [r]
rlist) = [d] -> [r] -> [(d, r)]
forall a b. [a] -> [b] -> [(a, b)]
zip [d]
doms [r]
rngs
  where
    accum :: ([d], [r]) -> d -> r -> ([d], [r])
accum ([d]
ds, [r]
rs) d
k r
v = (PairSide -> String -> Rep era d -> d -> [d] -> [d]
forall a era.
Eq a =>
PairSide -> String -> Rep era a -> a -> [a] -> [a]
remove PairSide
side String
"domain" Rep era d
drep d
k [d]
ds, PairSide -> String -> Rep era r -> r -> [r] -> [r]
forall a era.
Eq a =>
PairSide -> String -> Rep era a -> a -> [a] -> [a]
remove PairSide
side String
"range" Rep era r
rrep r
v [r]
rs)
    ([d]
doms, [r]
rngs) = (([d], [r]) -> d -> r -> ([d], [r]))
-> ([d], [r]) -> Map d r -> ([d], [r])
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' ([d], [r]) -> d -> r -> ([d], [r])
accum ([d]
dlist, [r]
rlist) Map d r
m

remove :: Eq a => PairSide -> String -> Rep era a -> a -> [a] -> [a]
remove :: forall a era.
Eq a =>
PairSide -> String -> Rep era a -> a -> [a] -> [a]
remove PairSide
side String
part Rep era a
rep a
x (a
y : [a]
ys) =
  if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y then [a]
ys else a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (PairSide -> String -> Rep era a -> a -> [a] -> [a]
forall a era.
Eq a =>
PairSide -> String -> Rep era a -> a -> [a] -> [a]
remove PairSide
side String
part Rep era a
rep a
x [a]
ys)
remove PairSide
VarOnLeft String
_part Rep era a
_rep a
_x [] = []
remove PairSide
VarOnRight String
part Rep era a
rep a
x [] =
  String -> [String] -> [a]
forall a. HasCallStack => String -> [String] -> a
errorMess
    ( String
"In SubMap, when the variable is on the right (i.e. (SubMap map var) ) the "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
part
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"of map should contain "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era a -> a -> String
forall e t. Rep e t -> t -> String
synopsis Rep era a
rep a
x
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" which appears in the "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
part
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of the PairSpec."
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" But it does not."
    )
    [String
"genFromMapSpec"]

genMapSpecIsSound :: Gen Property
genMapSpecIsSound :: Gen Property
genMapSpecIsSound = do
  Int
n <- (Int, Int) -> Gen Int
chooseInt (Int
1, Int
15)
  MapSpec BabbageEra Int Word64
spec <- Gen Int
-> Rep BabbageEra Int
-> Rep BabbageEra Word64
-> SomeLens BabbageEra Word64
-> Int
-> Gen (MapSpec BabbageEra Int Word64)
forall era dom w.
(Ord dom, Era era, Ord w, Adds w) =>
Gen dom
-> Rep era dom
-> Rep era w
-> SomeLens era w
-> Int
-> Gen (MapSpec era dom w)
genMapSpec ((Int, Int) -> Gen Int
chooseInt (Int
1, Int
10000)) Rep BabbageEra Int
forall era. Rep era Int
IntR Rep BabbageEra Word64
forall era. Rep era Word64
Word64R (Lens' Word64 Coin -> SomeLens BabbageEra Word64
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (Coin -> f Coin) -> Word64 -> f Word64
Lens' Word64 Coin
word64CoinL) Int
n
  Map Int Word64
mp <- forall era w dom.
(Era era, Ord dom) =>
String
-> [String]
-> Gen dom
-> Gen w
-> MapSpec era dom w
-> Gen (Map dom w)
genFromMapSpec @BabbageEra String
"mapSpecIsSound" [] ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
10000)) ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
10000)) MapSpec BabbageEra Int Word64
spec
  Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"spec = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec BabbageEra Int Word64 -> String
forall a. Show a => a -> String
show MapSpec BabbageEra Int Word64
spec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nmp = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Map Int Word64 -> String
forall a. Show a => a -> String
show Map Int Word64
mp) (Map Int Word64 -> MapSpec BabbageEra Int Word64 -> Bool
forall d r era. (Ord d, Eq r) => Map d r -> MapSpec era d r -> Bool
runMapSpec Map Int Word64
mp MapSpec BabbageEra Int Word64
spec)

manyMergeMapSpec :: Gen (Int, Int, [String])
manyMergeMapSpec :: Gen (Int, Int, [String])
manyMergeMapSpec = do
  Int
n <- (Int, Int) -> Gen Int
chooseInt (Int
1, Int
10)
  [MapSpec BabbageEra Int Word64]
xs <- Int
-> Gen (MapSpec BabbageEra Int Word64)
-> Gen [MapSpec BabbageEra Int Word64]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
50 (Gen Int
-> Rep BabbageEra Int
-> Rep BabbageEra Word64
-> SomeLens BabbageEra Word64
-> Int
-> Gen (MapSpec BabbageEra Int Word64)
forall era dom w.
(Ord dom, Era era, Ord w, Adds w) =>
Gen dom
-> Rep era dom
-> Rep era w
-> SomeLens era w
-> Int
-> Gen (MapSpec era dom w)
genMapSpec ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
100)) Rep BabbageEra Int
forall era. Rep era Int
IntR Rep BabbageEra Word64
forall era. Rep era Word64
Word64R (Lens' Word64 Coin -> SomeLens BabbageEra Word64
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (Coin -> f Coin) -> Word64 -> f Word64
Lens' Word64 Coin
word64CoinL) Int
n)
  [MapSpec BabbageEra Int Word64]
ys <- Int
-> Gen (MapSpec BabbageEra Int Word64)
-> Gen [MapSpec BabbageEra Int Word64]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
50 (Gen Int
-> Rep BabbageEra Int
-> Rep BabbageEra Word64
-> SomeLens BabbageEra Word64
-> Int
-> Gen (MapSpec BabbageEra Int Word64)
forall era dom w.
(Ord dom, Era era, Ord w, Adds w) =>
Gen dom
-> Rep era dom
-> Rep era w
-> SomeLens era w
-> Int
-> Gen (MapSpec era dom w)
genMapSpec ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
100)) Rep BabbageEra Int
forall era. Rep era Int
IntR Rep BabbageEra Word64
forall era. Rep era Word64
Word64R (Lens' Word64 Coin -> SomeLens BabbageEra Word64
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (Coin -> f Coin) -> Word64 -> f Word64
Lens' Word64 Coin
word64CoinL) Int
n)
  let check :: (MapSpec BabbageEra Int Word64, MapSpec BabbageEra Int Word64,
 MapSpec BabbageEra Int Word64)
-> Gen
     (MapSpec BabbageEra Int Word64, Bool,
      MapSpec BabbageEra Int Word64, Bool, Map Int Word64, Bool,
      MapSpec BabbageEra Int Word64)
check (MapSpec BabbageEra Int Word64
x, MapSpec BabbageEra Int Word64
y, MapSpec BabbageEra Int Word64
m) = do
        let msize :: Size
msize = MapSpec BabbageEra Int Word64 -> Size
forall era d r. MapSpec era d r -> Size
sizeForMapSpec MapSpec BabbageEra Int Word64
m
        Int
i <- Size -> Gen Int
genFromSize Size
msize
        let wordsX :: [String]
wordsX =
              [ String
"s1<>s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
msize
              , String
"s1<>s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec BabbageEra Int Word64 -> String
forall a. Show a => a -> String
show MapSpec BabbageEra Int Word64
m
              , String
"s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (MapSpec BabbageEra Int Word64 -> Size
forall era d r. MapSpec era d r -> Size
sizeForMapSpec MapSpec BabbageEra Int Word64
x)
              , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec BabbageEra Int Word64 -> String
forall a. Show a => a -> String
show MapSpec BabbageEra Int Word64
x
              , String
"s1 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (MapSpec BabbageEra Int Word64 -> Size
forall era d r. MapSpec era d r -> Size
sizeForMapSpec MapSpec BabbageEra Int Word64
y)
              , String
"s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec BabbageEra Int Word64 -> String
forall a. Show a => a -> String
show MapSpec BabbageEra Int Word64
y
              , String
"GenFromMapSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" n=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
              ]
        Map Int Word64
z <- forall era w dom.
(Era era, Ord dom) =>
String
-> [String]
-> Gen dom
-> Gen w
-> MapSpec era dom w
-> Gen (Map dom w)
genFromMapSpec @BabbageEra String
"manyMergeMap" [String]
wordsX ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
100)) ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
100)) MapSpec BabbageEra Int Word64
m
        (MapSpec BabbageEra Int Word64, Bool,
 MapSpec BabbageEra Int Word64, Bool, Map Int Word64, Bool,
 MapSpec BabbageEra Int Word64)
-> Gen
     (MapSpec BabbageEra Int Word64, Bool,
      MapSpec BabbageEra Int Word64, Bool, Map Int Word64, Bool,
      MapSpec BabbageEra Int Word64)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MapSpec BabbageEra Int Word64
x, Map Int Word64 -> MapSpec BabbageEra Int Word64 -> Bool
forall d r era. (Ord d, Eq r) => Map d r -> MapSpec era d r -> Bool
runMapSpec Map Int Word64
z MapSpec BabbageEra Int Word64
x, MapSpec BabbageEra Int Word64
y, Map Int Word64 -> MapSpec BabbageEra Int Word64 -> Bool
forall d r era. (Ord d, Eq r) => Map d r -> MapSpec era d r -> Bool
runMapSpec Map Int Word64
z MapSpec BabbageEra Int Word64
y, Map Int Word64
z, Map Int Word64 -> MapSpec BabbageEra Int Word64 -> Bool
forall d r era. (Ord d, Eq r) => Map d r -> MapSpec era d r -> Bool
runMapSpec Map Int Word64
z MapSpec BabbageEra Int Word64
m, MapSpec BabbageEra Int Word64
m)
      showAns :: (MapSpec era d r, a, MapSpec era d r, a, a, a, MapSpec era d r)
-> String
showAns (MapSpec era d r
s1, a
run1, MapSpec era d r
s2, a
run2, a
v, a
run3, MapSpec era d r
s3) =
        [String] -> String
unlines
          [ String
"\ns1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era d r -> String
forall a. Show a => a -> String
show MapSpec era d r
s1
          , String
"s1 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (MapSpec era d r -> Size
forall era d r. MapSpec era d r -> Size
sizeForMapSpec MapSpec era d r
s1)
          , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era d r -> String
forall a. Show a => a -> String
show MapSpec era d r
s2
          , String
"s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (MapSpec era d r -> Size
forall era d r. MapSpec era d r -> Size
sizeForMapSpec MapSpec era d r
s2)
          , String
"s1 <> s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapSpec era d r -> String
forall a. Show a => a -> String
show MapSpec era d r
s3
          , String
"s1<>s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (MapSpec era d r -> Size
forall era d r. MapSpec era d r -> Size
sizeForMapSpec MapSpec era d r
s3)
          , String
"v = genFromMapSpec (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v
          , String
"runMapSpec v s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run1
          , String
"runMapSpec v s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run2
          , String
"runMapSpec v (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run3
          ]
      pr :: (MapSpec era d r, Bool, MapSpec era d r, Bool, a, Bool,
 MapSpec era d r)
-> Maybe String
pr x :: (MapSpec era d r, Bool, MapSpec era d r, Bool, a, Bool,
 MapSpec era d r)
x@(MapSpec era d r
_, Bool
a, MapSpec era d r
_, Bool
b, a
_, Bool
c, MapSpec era d r
_) = if Bool -> Bool
not (Bool
a Bool -> Bool -> Bool
&& Bool
b Bool -> Bool -> Bool
&& Bool
c) then String -> Maybe String
forall a. a -> Maybe a
Just ((MapSpec era d r, Bool, MapSpec era d r, Bool, a, Bool,
 MapSpec era d r)
-> String
forall {d} {d} {d} {a} {a} {a} {a} {era} {r} {era} {r} {era} {r}.
(Ord d, Ord d, Ord d, Show a, Show a, Show a, Show a) =>
(MapSpec era d r, a, MapSpec era d r, a, a, a, MapSpec era d r)
-> String
showAns (MapSpec era d r, Bool, MapSpec era d r, Bool, a, Bool,
 MapSpec era d r)
x) else Maybe String
forall a. Maybe a
Nothing
  let trips :: [(MapSpec BabbageEra Int Word64, MapSpec BabbageEra Int Word64,
  MapSpec BabbageEra Int Word64)]
trips = [(MapSpec BabbageEra Int Word64
x, MapSpec BabbageEra Int Word64
y, MapSpec BabbageEra Int Word64
m) | MapSpec BabbageEra Int Word64
x <- [MapSpec BabbageEra Int Word64]
xs, MapSpec BabbageEra Int Word64
y <- [MapSpec BabbageEra Int Word64]
ys, Just MapSpec BabbageEra Int Word64
m <- [MapSpec BabbageEra Int Word64
-> MapSpec BabbageEra Int Word64
-> Maybe (MapSpec BabbageEra Int Word64)
forall a. (LiftT a, Semigroup a) => a -> a -> Maybe a
consistent MapSpec BabbageEra Int Word64
x MapSpec BabbageEra Int Word64
y]]
  [(MapSpec BabbageEra Int Word64, Bool,
  MapSpec BabbageEra Int Word64, Bool, Map Int Word64, Bool,
  MapSpec BabbageEra Int Word64)]
ts <- ((MapSpec BabbageEra Int Word64, MapSpec BabbageEra Int Word64,
  MapSpec BabbageEra Int Word64)
 -> Gen
      (MapSpec BabbageEra Int Word64, Bool,
       MapSpec BabbageEra Int Word64, Bool, Map Int Word64, Bool,
       MapSpec BabbageEra Int Word64))
-> [(MapSpec BabbageEra Int Word64, MapSpec BabbageEra Int Word64,
     MapSpec BabbageEra Int Word64)]
-> Gen
     [(MapSpec BabbageEra Int Word64, Bool,
       MapSpec BabbageEra Int Word64, Bool, Map Int Word64, Bool,
       MapSpec BabbageEra Int Word64)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (MapSpec BabbageEra Int Word64, MapSpec BabbageEra Int Word64,
 MapSpec BabbageEra Int Word64)
-> Gen
     (MapSpec BabbageEra Int Word64, Bool,
      MapSpec BabbageEra Int Word64, Bool, Map Int Word64, Bool,
      MapSpec BabbageEra Int Word64)
check [(MapSpec BabbageEra Int Word64, MapSpec BabbageEra Int Word64,
  MapSpec BabbageEra Int Word64)]
trips
  (Int, Int, [String]) -> Gen (Int, Int, [String])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, Int, [String]) -> Gen (Int, Int, [String]))
-> (Int, Int, [String]) -> Gen (Int, Int, [String])
forall a b. (a -> b) -> a -> b
$ (Int
n, [(MapSpec BabbageEra Int Word64, MapSpec BabbageEra Int Word64,
  MapSpec BabbageEra Int Word64)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(MapSpec BabbageEra Int Word64, MapSpec BabbageEra Int Word64,
  MapSpec BabbageEra Int Word64)]
trips, [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
Maybe.catMaybes (((MapSpec BabbageEra Int Word64, Bool,
  MapSpec BabbageEra Int Word64, Bool, Map Int Word64, Bool,
  MapSpec BabbageEra Int Word64)
 -> Maybe String)
-> [(MapSpec BabbageEra Int Word64, Bool,
     MapSpec BabbageEra Int Word64, Bool, Map Int Word64, Bool,
     MapSpec BabbageEra Int Word64)]
-> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (MapSpec BabbageEra Int Word64, Bool,
 MapSpec BabbageEra Int Word64, Bool, Map Int Word64, Bool,
 MapSpec BabbageEra Int Word64)
-> Maybe String
forall {d} {d} {d} {a} {era} {r} {era} {r} {era} {r}.
(Ord d, Ord d, Ord d, Show a) =>
(MapSpec era d r, Bool, MapSpec era d r, Bool, a, Bool,
 MapSpec era d r)
-> Maybe String
pr [(MapSpec BabbageEra Int Word64, Bool,
  MapSpec BabbageEra Int Word64, Bool, Map Int Word64, Bool,
  MapSpec BabbageEra Int Word64)]
ts))

reportManyMergeMapSpec :: IO ()
reportManyMergeMapSpec :: IO ()
reportManyMergeMapSpec = do
  (Int
n, Int
passed, [String]
bad) <- Gen (Int, Int, [String]) -> IO (Int, Int, [String])
forall a. Gen a -> IO a
generate Gen (Int, Int, [String])
manyMergeMapSpec
  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
bad
    then String -> IO ()
putStrLn (String
"passed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
passed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests. Spec size " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
    else do (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
bad; String -> IO ()
forall a. HasCallStack => String -> a
error String
"TestFails"

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

data SetSpec era a where
  SetSpec :: Ord a => Size -> RelSpec era a -> SetSpec era a
  SetNever :: [String] -> SetSpec era a

instance Show (SetSpec era a) where show :: SetSpec era a -> String
show = SetSpec era a -> String
forall era a. SetSpec era a -> String
showSetSpec

instance Ord a => Semigroup (SetSpec era a) where
  <> :: SetSpec era a -> SetSpec era a -> SetSpec era a
(<>) = SetSpec era a -> SetSpec era a -> SetSpec era a
forall a era.
Ord a =>
SetSpec era a -> SetSpec era a -> SetSpec era a
mergeSetSpec

instance Ord a => Monoid (SetSpec era a) where
  mempty :: SetSpec era a
mempty = Size -> RelSpec era a -> SetSpec era a
forall a era. Ord a => Size -> RelSpec era a -> SetSpec era a
SetSpec Size
SzAny RelSpec era a
forall era dom. RelSpec era dom
RelAny

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

showSetSpec :: SetSpec era a -> String
showSetSpec :: forall era a. SetSpec era a -> String
showSetSpec (SetSpec Size
s RelSpec era a
r) = [String] -> String
sepsP [String
"SetSpec", Size -> String
forall a. Show a => a -> String
show Size
s, RelSpec era a -> String
forall a. Show a => a -> String
show RelSpec era a
r]
showSetSpec (SetNever [String]
_) = String
"SetNever"

mergeSetSpec :: Ord a => SetSpec era a -> SetSpec era a -> SetSpec era a
mergeSetSpec :: forall a era.
Ord a =>
SetSpec era a -> SetSpec era a -> SetSpec era a
mergeSetSpec SetSpec era a
s1 SetSpec era a
s2 = case (SetSpec era a
s1, SetSpec era a
s2) of
  (SetNever [String]
xs, SetNever [String]
ys) -> [String] -> SetSpec era a
forall era a. [String] -> SetSpec era a
SetNever ([String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ys)
  (SetNever [String]
xs, SetSpec era a
_) -> [String] -> SetSpec era a
forall era a. [String] -> SetSpec era a
SetNever [String]
xs
  (SetSpec era a
_, SetNever [String]
ys) -> [String] -> SetSpec era a
forall era a. [String] -> SetSpec era a
SetNever [String]
ys
  (SetSpec Size
SzAny RelSpec era a
RelAny, SetSpec era a
x) -> SetSpec era a
x
  (SetSpec era a
x, SetSpec Size
SzAny RelSpec era a
RelAny) -> SetSpec era a
x
  (SetSpec Size
s11 RelSpec era a
r1, SetSpec Size
s22 RelSpec era a
r2) -> case RelSpec era a
r1 RelSpec era a -> RelSpec era a -> RelSpec era a
forall a. Semigroup a => a -> a -> a
<> RelSpec era a
r2 of
    RelNever [String]
xs -> [String] -> SetSpec era a
forall era a. [String] -> SetSpec era a
SetNever ([String
"The SetSpec's are inconsistent.", String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetSpec era a -> String
forall a. Show a => a -> String
show SetSpec era a
s1, String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetSpec era a -> String
forall a. Show a => a -> String
show SetSpec era a
s2] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
xs)
    RelSpec era a
r3 -> Typed (SetSpec era a) -> SetSpec era a
forall x. LiftT x => Typed x -> x
dropT (String -> Typed (SetSpec era a) -> Typed (SetSpec era a)
forall a. String -> Typed a -> Typed a
explain (String
"While merging\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetSpec era a -> String
forall a. Show a => a -> String
show SetSpec era a
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetSpec era a -> String
forall a. Show a => a -> String
show SetSpec era a
s2) (Typed (SetSpec era a) -> Typed (SetSpec era a))
-> Typed (SetSpec era a) -> Typed (SetSpec era a)
forall a b. (a -> b) -> a -> b
$ Size -> RelSpec era a -> Typed (SetSpec era a)
forall t era.
Ord t =>
Size -> RelSpec era t -> Typed (SetSpec era t)
setSpec (Size
s11 Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> Size
s22) RelSpec era a
r3)

-- | Test the size consistency while building a SetSpec
setSpec :: Ord t => Size -> RelSpec era t -> Typed (SetSpec era t)
setSpec :: forall t era.
Ord t =>
Size -> RelSpec era t -> Typed (SetSpec era t)
setSpec Size
sz1 RelSpec era t
rel = case (Size
sz1 Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> Size
sz2) of
  SzNever [String]
xs ->
    [String] -> Typed (SetSpec era t)
forall a. [String] -> Typed a
failT
      ( [ String
"Creating " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetSpec era t -> String
forall a. Show a => a -> String
show (Size -> RelSpec era t -> SetSpec era t
forall a era. Ord a => Size -> RelSpec era a -> SetSpec era a
SetSpec Size
sz1 RelSpec era t
rel) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" fails."
        , String
"It has size inconsistencies."
        , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RelSpec era t -> String
forall a. Show a => a -> String
show RelSpec era t
rel String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has size " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
sz2
        , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"the expected size is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
sz1
        ]
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
xs
      )
  Size
size -> SetSpec era t -> Typed (SetSpec era t)
forall a. a -> Typed a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size -> RelSpec era t -> SetSpec era t
forall a era. Ord a => Size -> RelSpec era a -> SetSpec era a
SetSpec Size
size RelSpec era t
rel)
  where
    sz2 :: Size
sz2 = RelSpec era t -> Size
forall era dom. RelSpec era dom -> Size
sizeForRel RelSpec era t
rel

runSetSpec :: Set a -> SetSpec era a -> Bool
runSetSpec :: forall a era. Set a -> SetSpec era a -> Bool
runSetSpec Set a
s (SetSpec Size
sz RelSpec era a
rel) = Int -> Size -> Bool
runSize (Set a -> Int
forall a. Set a -> Int
Set.size Set a
s) Size
sz Bool -> Bool -> Bool
&& Set a -> RelSpec era a -> Bool
forall t era. Ord t => Set t -> RelSpec era t -> Bool
runRelSpec Set a
s RelSpec era a
rel
runSetSpec Set a
_ (SetNever [String]
msgs) = String -> [String] -> Bool
forall a. HasCallStack => String -> [String] -> a
errorMess String
"runSetSpec applied to SetNever" [String]
msgs

sizeForSetSpec :: SetSpec era a -> Size
sizeForSetSpec :: forall era a. SetSpec era a -> Size
sizeForSetSpec (SetSpec Size
sz RelSpec era a
_) = Size
sz
sizeForSetSpec (SetNever [String]
_) = Size
SzAny

genSetSpec :: Ord s => [String] -> Gen s -> Rep era s -> Int -> Gen (SetSpec era s)
genSetSpec :: forall s era.
Ord s =>
[String] -> Gen s -> Rep era s -> Int -> Gen (SetSpec era s)
genSetSpec [String]
msgs Gen s
genS Rep era s
repS Int
size = do
  RelSpec era s
r <- [String] -> Gen s -> Rep era s -> Int -> Gen (RelSpec era s)
forall dom era.
Ord dom =>
[String] -> Gen dom -> Rep era dom -> Int -> Gen (RelSpec era dom)
genRelSpec (String
"from genSetSpec" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Gen s
genS Rep era s
repS Int
size
  SetSpec era s -> Gen (SetSpec era s)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size -> RelSpec era s -> SetSpec era s
forall a era. Ord a => Size -> RelSpec era a -> SetSpec era a
SetSpec (Int -> Size
SzExact Int
size) RelSpec era s
r)

genFromSetSpec :: forall era a. Era era => [String] -> Gen a -> SetSpec era a -> Gen (Set a)
genFromSetSpec :: forall era a.
Era era =>
[String] -> Gen a -> SetSpec era a -> Gen (Set a)
genFromSetSpec [String]
msgs Gen a
genS (SetSpec Size
sz RelSpec era a
rp) = do
  Int
n <- Size -> Gen Int
genFromSize Size
sz
  [String] -> Gen a -> Int -> RelSpec era a -> Gen (Set a)
forall era t.
(Era era, Ord t) =>
[String] -> Gen t -> Int -> RelSpec era t -> Gen (Set t)
genFromRelSpec (String
"genFromSetSpec" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Gen a
genS Int
n RelSpec era a
rp
genFromSetSpec [String]
_ Gen a
_ (SetNever [String]
msgs) = String -> [String] -> Gen (Set a)
forall a. HasCallStack => String -> [String] -> a
errorMess String
"genFromSetSpec applied to SetNever" [String]
msgs

genSetSpecIsSound :: Gen Property
genSetSpecIsSound :: Gen Property
genSetSpecIsSound = do
  Int
size <- (Int, Int) -> Gen Int
chooseInt (Int
0, Int
10)
  SetSpec BabbageEra Int
spec <- [String]
-> Gen Int
-> Rep BabbageEra Int
-> Int
-> Gen (SetSpec BabbageEra Int)
forall s era.
Ord s =>
[String] -> Gen s -> Rep era s -> Int -> Gen (SetSpec era s)
genSetSpec [String]
msgs ((Int, Int) -> Gen Int
chooseInt (Int
1, Int
1000)) Rep BabbageEra Int
forall era. Rep era Int
IntR Int
size
  Set Int
mp <- forall era a.
Era era =>
[String] -> Gen a -> SetSpec era a -> Gen (Set a)
genFromSetSpec @BabbageEra [String]
msgs ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
10000)) SetSpec BabbageEra Int
spec
  Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"spec = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetSpec BabbageEra Int -> String
forall a. Show a => a -> String
show SetSpec BabbageEra Int
spec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nmp = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Set Int -> String
forall a. Show a => a -> String
show Set Int
mp) (Set Int -> SetSpec BabbageEra Int -> Bool
forall a era. Set a -> SetSpec era a -> Bool
runSetSpec Set Int
mp SetSpec BabbageEra Int
spec)
  where
    msgs :: [String]
msgs = [String
"genSetSpecIsSound"]

manyMergeSetSpec :: Gen (Int, Int, [String])
manyMergeSetSpec :: Gen (Int, Int, [String])
manyMergeSetSpec = do
  Int
n <- (Int, Int) -> Gen Int
chooseInt (Int
1, Int
10)
  [SetSpec BabbageEra Int]
xs <- Int -> Gen (SetSpec BabbageEra Int) -> Gen [SetSpec BabbageEra Int]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
50 ([String]
-> Gen Int
-> Rep BabbageEra Int
-> Int
-> Gen (SetSpec BabbageEra Int)
forall s era.
Ord s =>
[String] -> Gen s -> Rep era s -> Int -> Gen (SetSpec era s)
genSetSpec [] ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
100)) Rep BabbageEra Int
forall era. Rep era Int
IntR Int
n)
  [SetSpec BabbageEra Int]
ys <- Int -> Gen (SetSpec BabbageEra Int) -> Gen [SetSpec BabbageEra Int]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
50 ([String]
-> Gen Int
-> Rep BabbageEra Int
-> Int
-> Gen (SetSpec BabbageEra Int)
forall s era.
Ord s =>
[String] -> Gen s -> Rep era s -> Int -> Gen (SetSpec era s)
genSetSpec [] ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
100)) Rep BabbageEra Int
forall era. Rep era Int
IntR Int
n)
  let check :: (SetSpec BabbageEra Int, SetSpec BabbageEra Int,
 SetSpec BabbageEra Int)
-> Gen
     (SetSpec BabbageEra Int, Bool, SetSpec BabbageEra Int, Bool,
      Set Int, Bool, SetSpec BabbageEra Int)
check (SetSpec BabbageEra Int
x, SetSpec BabbageEra Int
y, SetSpec BabbageEra Int
m) = do
        let msize :: Size
msize = SetSpec BabbageEra Int -> Size
forall era a. SetSpec era a -> Size
sizeForSetSpec SetSpec BabbageEra Int
m
        Int
i <- Size -> Gen Int
genFromSize Size
msize
        let wordsX :: [String]
wordsX =
              [ String
"s1<>s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
msize
              , String
"s1<>s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetSpec BabbageEra Int -> String
forall a. Show a => a -> String
show SetSpec BabbageEra Int
m
              , String
"s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (SetSpec BabbageEra Int -> Size
forall era a. SetSpec era a -> Size
sizeForSetSpec SetSpec BabbageEra Int
x)
              , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetSpec BabbageEra Int -> String
forall a. Show a => a -> String
show SetSpec BabbageEra Int
x
              , String
"s1 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (SetSpec BabbageEra Int -> Size
forall era a. SetSpec era a -> Size
sizeForSetSpec SetSpec BabbageEra Int
y)
              , String
"s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetSpec BabbageEra Int -> String
forall a. Show a => a -> String
show SetSpec BabbageEra Int
y
              , String
"GenFromSetSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" n=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
              ]
        Set Int
z <- forall era a.
Era era =>
[String] -> Gen a -> SetSpec era a -> Gen (Set a)
genFromSetSpec @BabbageEra [String]
wordsX ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
100)) SetSpec BabbageEra Int
m
        (SetSpec BabbageEra Int, Bool, SetSpec BabbageEra Int, Bool,
 Set Int, Bool, SetSpec BabbageEra Int)
-> Gen
     (SetSpec BabbageEra Int, Bool, SetSpec BabbageEra Int, Bool,
      Set Int, Bool, SetSpec BabbageEra Int)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SetSpec BabbageEra Int
x, Set Int -> SetSpec BabbageEra Int -> Bool
forall a era. Set a -> SetSpec era a -> Bool
runSetSpec Set Int
z SetSpec BabbageEra Int
x, SetSpec BabbageEra Int
y, Set Int -> SetSpec BabbageEra Int -> Bool
forall a era. Set a -> SetSpec era a -> Bool
runSetSpec Set Int
z SetSpec BabbageEra Int
y, Set Int
z, Set Int -> SetSpec BabbageEra Int -> Bool
forall a era. Set a -> SetSpec era a -> Bool
runSetSpec Set Int
z SetSpec BabbageEra Int
m, SetSpec BabbageEra Int
m)
      showAns :: (SetSpec era a, a, SetSpec era a, a, a, a, SetSpec era a) -> String
showAns (SetSpec era a
s1, a
run1, SetSpec era a
s2, a
run2, a
v, a
run3, SetSpec era a
s3) =
        [String] -> String
unlines
          [ String
"\ns1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetSpec era a -> String
forall a. Show a => a -> String
show SetSpec era a
s1
          , String
"s1 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (SetSpec era a -> Size
forall era a. SetSpec era a -> Size
sizeForSetSpec SetSpec era a
s1)
          , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetSpec era a -> String
forall a. Show a => a -> String
show SetSpec era a
s2
          , String
"s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (SetSpec era a -> Size
forall era a. SetSpec era a -> Size
sizeForSetSpec SetSpec era a
s2)
          , String
"s1 <> s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetSpec era a -> String
forall a. Show a => a -> String
show SetSpec era a
s3
          , String
"s1<>s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (SetSpec era a -> Size
forall era a. SetSpec era a -> Size
sizeForSetSpec SetSpec era a
s3)
          , String
"v = genFromSetSpec (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v
          , String
"runSetSpec v s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run1
          , String
"runSetSpec v s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run2
          , String
"runSetSpec v (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run3
          ]
      pr :: (SetSpec era a, Bool, SetSpec era a, Bool, a, Bool, SetSpec era a)
-> Maybe String
pr x :: (SetSpec era a, Bool, SetSpec era a, Bool, a, Bool, SetSpec era a)
x@(SetSpec era a
_, Bool
a, SetSpec era a
_, Bool
b, a
_, Bool
c, SetSpec era a
_) = if Bool -> Bool
not (Bool
a Bool -> Bool -> Bool
&& Bool
b Bool -> Bool -> Bool
&& Bool
c) then String -> Maybe String
forall a. a -> Maybe a
Just ((SetSpec era a, Bool, SetSpec era a, Bool, a, Bool, SetSpec era a)
-> String
forall {a} {a} {a} {a} {era} {a} {era} {a} {era} {a}.
(Show a, Show a, Show a, Show a) =>
(SetSpec era a, a, SetSpec era a, a, a, a, SetSpec era a) -> String
showAns (SetSpec era a, Bool, SetSpec era a, Bool, a, Bool, SetSpec era a)
x) else Maybe String
forall a. Maybe a
Nothing
  let trips :: [(SetSpec BabbageEra Int, SetSpec BabbageEra Int,
  SetSpec BabbageEra Int)]
trips = [(SetSpec BabbageEra Int
x, SetSpec BabbageEra Int
y, SetSpec BabbageEra Int
m) | SetSpec BabbageEra Int
x <- [SetSpec BabbageEra Int]
xs, SetSpec BabbageEra Int
y <- [SetSpec BabbageEra Int]
ys, Just SetSpec BabbageEra Int
m <- [SetSpec BabbageEra Int
-> SetSpec BabbageEra Int -> Maybe (SetSpec BabbageEra Int)
forall a. (LiftT a, Semigroup a) => a -> a -> Maybe a
consistent SetSpec BabbageEra Int
x SetSpec BabbageEra Int
y]]
  [(SetSpec BabbageEra Int, Bool, SetSpec BabbageEra Int, Bool,
  Set Int, Bool, SetSpec BabbageEra Int)]
ts <- ((SetSpec BabbageEra Int, SetSpec BabbageEra Int,
  SetSpec BabbageEra Int)
 -> Gen
      (SetSpec BabbageEra Int, Bool, SetSpec BabbageEra Int, Bool,
       Set Int, Bool, SetSpec BabbageEra Int))
-> [(SetSpec BabbageEra Int, SetSpec BabbageEra Int,
     SetSpec BabbageEra Int)]
-> Gen
     [(SetSpec BabbageEra Int, Bool, SetSpec BabbageEra Int, Bool,
       Set Int, Bool, SetSpec BabbageEra Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (SetSpec BabbageEra Int, SetSpec BabbageEra Int,
 SetSpec BabbageEra Int)
-> Gen
     (SetSpec BabbageEra Int, Bool, SetSpec BabbageEra Int, Bool,
      Set Int, Bool, SetSpec BabbageEra Int)
check [(SetSpec BabbageEra Int, SetSpec BabbageEra Int,
  SetSpec BabbageEra Int)]
trips
  (Int, Int, [String]) -> Gen (Int, Int, [String])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, Int, [String]) -> Gen (Int, Int, [String]))
-> (Int, Int, [String]) -> Gen (Int, Int, [String])
forall a b. (a -> b) -> a -> b
$ (Int
n, [(SetSpec BabbageEra Int, SetSpec BabbageEra Int,
  SetSpec BabbageEra Int)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(SetSpec BabbageEra Int, SetSpec BabbageEra Int,
  SetSpec BabbageEra Int)]
trips, [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
Maybe.catMaybes (((SetSpec BabbageEra Int, Bool, SetSpec BabbageEra Int, Bool,
  Set Int, Bool, SetSpec BabbageEra Int)
 -> Maybe String)
-> [(SetSpec BabbageEra Int, Bool, SetSpec BabbageEra Int, Bool,
     Set Int, Bool, SetSpec BabbageEra Int)]
-> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (SetSpec BabbageEra Int, Bool, SetSpec BabbageEra Int, Bool,
 Set Int, Bool, SetSpec BabbageEra Int)
-> Maybe String
forall {a} {era} {a} {era} {a} {era} {a}.
Show a =>
(SetSpec era a, Bool, SetSpec era a, Bool, a, Bool, SetSpec era a)
-> Maybe String
pr [(SetSpec BabbageEra Int, Bool, SetSpec BabbageEra Int, Bool,
  Set Int, Bool, SetSpec BabbageEra Int)]
ts))

reportManyMergeSetSpec :: IO ()
reportManyMergeSetSpec :: IO ()
reportManyMergeSetSpec = do
  (Int
n, Int
passed, [String]
bad) <- Gen (Int, Int, [String]) -> IO (Int, Int, [String])
forall a. Gen a -> IO a
generate Gen (Int, Int, [String])
manyMergeSetSpec
  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
bad
    then String -> IO ()
putStrLn (String
"passed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
passed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests. Spec size " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
    else do (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
bad; String -> IO ()
forall a. HasCallStack => String -> a
error String
"TestFails"

-- =======================================================
-- Specifications for Lists

data ElemSpec era t where
  -- | The set must add up to 'tot', which is any number in the scope of Size
  ElemSum ::
    Adds t =>
    t -> -- The smallest allowed
    Size ->
    ElemSpec era t
  -- | The range must sum upto 'c', which is any number in the scope of Size,
  --   through the projection witnessed by the (Sums t c) class
  ElemProj ::
    Adds c =>
    c -> -- The smallest allowed
    Rep era x ->
    Lens' x c ->
    Size ->
    ElemSpec era x
  -- | The range has exactly these elements
  ElemEqual :: Eq t => Rep era t -> [t] -> ElemSpec era t
  -- In the future we will want to add somethig like:
  -- ElemOrd :: Ord t => Rep era t -> t -> OrdCond -> t -> ElemSpec era tS
  ElemNever :: [String] -> ElemSpec era t
  ElemAny :: ElemSpec era t

instance Show (ElemSpec era a) where
  show :: ElemSpec era a -> String
show = ElemSpec era a -> String
forall era a. ElemSpec era a -> String
showElemSpec

instance Era era => Semigroup (ElemSpec era a) where
  <> :: ElemSpec era a -> ElemSpec era a -> ElemSpec era a
(<>) = ElemSpec era a -> ElemSpec era a -> ElemSpec era a
forall era a.
Era era =>
ElemSpec era a -> ElemSpec era a -> ElemSpec era a
mergeElemSpec

instance Era era => Monoid (ElemSpec era a) where
  mempty :: ElemSpec era a
mempty = ElemSpec era a
forall era t. ElemSpec era t
ElemAny

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

showElemSpec :: ElemSpec era a -> String
showElemSpec :: forall era a. ElemSpec era a -> String
showElemSpec (ElemSum a
small Size
sz) = [String] -> String
sepsP [String
"ElemSum", a -> String
forall a. Show a => a -> String
show a
small, Size -> String
forall a. Show a => a -> String
show Size
sz]
showElemSpec (ElemProj c
small Rep era a
r Lens' a c
_l Size
sz) = [String] -> String
sepsP [String
"ElemProj", c -> String
forall a. Show a => a -> String
show c
small, Rep era a -> String
forall a. Show a => a -> String
show Rep era a
r, Size -> String
forall a. Show a => a -> String
show Size
sz]
showElemSpec (ElemEqual Rep era a
r [a]
xs) = [String] -> String
sepsP [String
"ElemEqual", Rep era a -> String
forall a. Show a => a -> String
show Rep era a
r, Rep era [a] -> [a] -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era a -> Rep era [a]
forall era a. Rep era a -> Rep era [a]
ListR Rep era a
r) [a]
xs]
showElemSpec (ElemNever [String]
_) = String
"ElemNever"
showElemSpec ElemSpec era a
ElemAny = String
"ElemAny"

mergeElemSpec :: Era era => ElemSpec era a -> ElemSpec era a -> ElemSpec era a
mergeElemSpec :: forall era a.
Era era =>
ElemSpec era a -> ElemSpec era a -> ElemSpec era a
mergeElemSpec (ElemNever [String]
xs) (ElemNever [String]
ys) = [String] -> ElemSpec era a
forall era t. [String] -> ElemSpec era t
ElemNever ([String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ys)
mergeElemSpec (ElemNever [String]
xs) ElemSpec era a
_ = [String] -> ElemSpec era a
forall era t. [String] -> ElemSpec era t
ElemNever [String]
xs
mergeElemSpec ElemSpec era a
_ (ElemNever [String]
ys) = [String] -> ElemSpec era a
forall era t. [String] -> ElemSpec era t
ElemNever [String]
ys
mergeElemSpec ElemSpec era a
ElemAny ElemSpec era a
x = ElemSpec era a
x
mergeElemSpec ElemSpec era a
x ElemSpec era a
ElemAny = ElemSpec era a
x
mergeElemSpec a :: ElemSpec era a
a@(ElemEqual Rep era a
r [a]
xs) b :: ElemSpec era a
b@(ElemEqual Rep era a
_ [a]
ys) =
  if [a]
xs [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
ys
    then Rep era a -> [a] -> ElemSpec era a
forall t era. Eq t => Rep era t -> [t] -> ElemSpec era t
ElemEqual Rep era a
r [a]
xs
    else
      [String] -> ElemSpec era a
forall era t. [String] -> ElemSpec era t
ElemNever
        [ String
"The ElemSpec's are inconsistent."
        , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec era a -> String
forall a. Show a => a -> String
show ElemSpec era a
a
        , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec era a -> String
forall a. Show a => a -> String
show ElemSpec era a
b
        , Rep era [a] -> [a] -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era a -> Rep era [a]
forall era a. Rep era a -> Rep era [a]
ListR Rep era a
r) [a]
xs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =/= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era [a] -> [a] -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era a -> Rep era [a]
forall era a. Rep era a -> Rep era [a]
ListR Rep era a
r) [a]
ys
        ]
mergeElemSpec a :: ElemSpec era a
a@(ElemEqual Rep era a
_ [a]
xs) b :: ElemSpec era a
b@(ElemSum a
_ Size
sz) =
  let computed :: a
computed = [a] -> a
forall (t :: * -> *) c. (Foldable t, Adds c) => t c -> c
sumAdds [a]
xs
   in if Int -> Size -> Bool
runSize (a -> Int
forall x. Adds x => x -> Int
toI a
computed) Size
sz
        then ElemSpec era a
a
        else
          [String] -> ElemSpec era a
forall era t. [String] -> ElemSpec era t
ElemNever
            [ String
"The ElemSpec's are inconsistent."
            , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec era a -> String
forall a. Show a => a -> String
show ElemSpec era a
a
            , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec era a -> String
forall a. Show a => a -> String
show ElemSpec era a
b
            , String
"The computed sum("
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
computed
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") is not in the allowed range of the Size("
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
sz
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
            ]
mergeElemSpec b :: ElemSpec era a
b@(ElemSum a
_ Size
_) a :: ElemSpec era a
a@(ElemEqual Rep era a
_ [a]
_) = ElemSpec era a -> ElemSpec era a -> ElemSpec era a
forall era a.
Era era =>
ElemSpec era a -> ElemSpec era a -> ElemSpec era a
mergeElemSpec ElemSpec era a
a ElemSpec era a
b
mergeElemSpec a :: ElemSpec era a
a@(ElemSum a
sm1 Size
sz1) b :: ElemSpec era a
b@(ElemSum a
sm2 Size
sz2) =
  case Size
sz1 Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> Size
sz2 of
    SzNever [String]
xs -> [String] -> ElemSpec era a
forall era t. [String] -> ElemSpec era t
ElemNever ([String] -> String
sepsP [String
"The ElemSpec's are inconsistent.", ElemSpec era a -> String
forall a. Show a => a -> String
show ElemSpec era a
a, ElemSpec era a -> String
forall a. Show a => a -> String
show ElemSpec era a
b] String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
xs)
    Size
sz3 -> a -> Size -> ElemSpec era a
forall t era. Adds t => t -> Size -> ElemSpec era t
ElemSum (a -> a -> a
forall x. Adds x => x -> x -> x
smallerOf a
sm1 a
sm2) Size
sz3
{-
mergeElemSpec a@(ElemProj sm1 r1 _l1 sz1) b@(ElemProj sm2 r2 _l2 sz2) = -- TODO FIXME ElemProj cannot be merged
  case testEql r1 r2 of
    Just Refl ->
      case sz1 <> sz2 of
        SzNever xs -> ElemNever ((sepsP ["The ElemSpec's are inconsistent.", show a, show b]) : xs)
        sz3 -> ElemProj (smallerOf sm1 sm2) r1 sz3
    Nothing -> ElemNever ["The ElemSpec's are inconsistent.", "  " ++ show a, "  " ++ show b]
-}
mergeElemSpec ElemSpec era a
a ElemSpec era a
b = [String] -> ElemSpec era a
forall era t. [String] -> ElemSpec era t
ElemNever [String
"The ElemSpec's are inconsistent.", String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec era a -> String
forall a. Show a => a -> String
show ElemSpec era a
a, String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec era a -> String
forall a. Show a => a -> String
show ElemSpec era a
b]

sizeForElemSpec :: forall a era. ElemSpec era a -> Size
sizeForElemSpec :: forall a era. ElemSpec era a -> Size
sizeForElemSpec (ElemNever [String]
_) = Size
SzAny
sizeForElemSpec ElemSpec era a
ElemAny = Size
SzAny
sizeForElemSpec (ElemEqual Rep era a
_ [a]
x) = Int -> Size
SzExact ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
x)
sizeForElemSpec (ElemSum a
smallest Size
sz) =
  if a -> Int
forall x. Adds x => x -> Int
toI a
smallest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    then Int -> Int -> Size
SzRng Int
1 (Size -> Int
minSize Size
sz Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` a -> Int
forall x. Adds x => x -> Int
toI a
smallest)
    else Int -> Size
SzLeast Int
1
sizeForElemSpec (ElemProj c
smallest (Rep era a
_r :: (Rep era c)) Lens' a c
_l Size
sz) =
  if c -> Int
forall x. Adds x => x -> Int
toI c
smallest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    then Int -> Int -> Size
SzRng Int
1 (Size -> Int
minSize Size
sz Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` c -> Int
forall x. Adds x => x -> Int
toI c
smallest)
    else Int -> Size
SzLeast Int
1

runElemSpec :: [a] -> ElemSpec era a -> Bool
runElemSpec :: forall a era. [a] -> ElemSpec era a -> Bool
runElemSpec [a]
xs ElemSpec era a
spec = case ElemSpec era a
spec of
  ElemNever [String]
_ -> Bool
False -- ErrorMess "ElemNever in runElemSpec" []
  ElemSpec era a
ElemAny -> Bool
True
  ElemEqual Rep era a
_ [a]
ys -> [a]
xs [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
ys
  ElemSum a
_ Size
sz -> Int -> Size -> Bool
runSize (a -> Int
forall x. Adds x => x -> Int
toI ([a] -> a
forall (t :: * -> *) c. (Foldable t, Adds c) => t c -> c
sumAdds [a]
xs)) Size
sz
  ElemProj c
_ Rep era a
_ Lens' a c
l Size
sz -> Int -> Size -> Bool
runSize (c -> Int
forall x. Adds x => x -> Int
toI (Lens' a c -> [a] -> c
forall (t :: * -> *) b a.
(Foldable t, Adds b) =>
Lens' a b -> t a -> b
lensAdds (c -> f c) -> a -> f a
Lens' a c
l [a]
xs)) Size
sz

genElemSpec ::
  forall w era.
  Adds w =>
  Rep era w ->
  -- Rep era c ->
  SomeLens era w ->
  Size ->
  Gen (ElemSpec era w)
genElemSpec :: forall w era.
Adds w =>
Rep era w -> SomeLens era w -> Size -> Gen (ElemSpec era w)
genElemSpec Rep era w
repw (SomeLens (Lens' w c
l :: Lens' w c)) Size
siz = do
  let lo :: Int
lo = Size -> Int
minSize Size
siz
      hi :: Int
hi = Size -> Int
maxSize Size
siz
  if Int
lo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
    then
      [(Int, Gen (ElemSpec era w))] -> Gen (ElemSpec era w)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency -- Can't really generate Sums, when size (n) is 0.
        [
          ( Int
2
          , do
              Int
smallest <- forall x. Adds x => Gen Int
genSmall @w -- Chooses smallest appropriate for type 'w'
              Size
sz <- Int -> Gen Size
genBigSize (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
smallest Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
hi))
              ElemSpec era w -> Gen (ElemSpec era w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (w -> Size -> ElemSpec era w
forall t era. Adds t => t -> Size -> ElemSpec era t
ElemSum ([String] -> Int -> w
forall x. Adds x => [String] -> Int -> x
fromI [String
"genRngSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
siz] Int
smallest) Size
sz)
          )
        ,
          ( Int
2
          , do
              Int
smallest <- forall x. Adds x => Gen Int
genSmall @c
              Size
sz <- Int -> Gen Size
genBigSize (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
smallest Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
hi))
              ElemSpec era w -> Gen (ElemSpec era w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c -> Rep era w -> Lens' w c -> Size -> ElemSpec era w
forall c era x.
Adds c =>
c -> Rep era x -> Lens' x c -> Size -> ElemSpec era x
ElemProj ([String] -> Int -> c
forall x. Adds x => [String] -> Int -> x
fromI [String
"genRngSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
siz] Int
smallest) Rep era w
repw (c -> f c) -> w -> f w
Lens' w c
l Size
sz)
          )
        , (Int
2, Rep era w -> [w] -> ElemSpec era w
forall t era. Eq t => Rep era t -> [t] -> ElemSpec era t
ElemEqual Rep era w
repw ([w] -> ElemSpec era w) -> Gen [w] -> Gen (ElemSpec era w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do Int
n <- Size -> Gen Int
genFromSize Size
siz; Int -> Gen w -> Gen [w]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n (Rep era w -> Gen w
forall era b. Rep era b -> Gen b
genRep Rep era w
repw))
        , (Int
1, ElemSpec era w -> Gen (ElemSpec era w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ElemSpec era w
forall era t. ElemSpec era t
ElemAny)
        ]
    else
      [(Int, Gen (ElemSpec era w))] -> Gen (ElemSpec era w)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
3, Rep era w -> [w] -> ElemSpec era w
forall t era. Eq t => Rep era t -> [t] -> ElemSpec era t
ElemEqual Rep era w
repw ([w] -> ElemSpec era w) -> Gen [w] -> Gen (ElemSpec era w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do Int
n <- Size -> Gen Int
genFromSize Size
siz; Int -> Gen w -> Gen [w]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n (Rep era w -> Gen w
forall era b. Rep era b -> Gen b
genRep Rep era w
repw))
        , (Int
1, ElemSpec era w -> Gen (ElemSpec era w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ElemSpec era w
forall era t. ElemSpec era t
ElemAny)
        ]

genFromElemSpec ::
  forall era r.
  [String] ->
  Gen r ->
  Int ->
  ElemSpec era r ->
  Gen [r]
genFromElemSpec :: forall era r. [String] -> Gen r -> Int -> ElemSpec era r -> Gen [r]
genFromElemSpec [String]
msgs Gen r
genr Int
n ElemSpec era r
x = case ElemSpec era r
x of
  (ElemNever [String]
xs) -> String -> [String] -> Gen [r]
forall a. HasCallStack => String -> [String] -> a
errorMess String
"RngNever in genFromElemSpec" [String]
xs
  ElemSpec era r
ElemAny -> Int -> Gen r -> Gen [r]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen r
genr
  (ElemEqual Rep era r
_ [r]
xs) -> [r] -> Gen [r]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [r]
xs
  (ElemSum r
small Size
sz) -> do
    Int
tot <- Size -> Gen Int
genFromIntRange Size
sz
    r -> [String] -> Int -> r -> Gen [r]
forall x. Adds x => x -> [String] -> Int -> x -> Gen [x]
partition r
small [String]
msgs Int
n ([String] -> Int -> r
forall x. Adds x => [String] -> Int -> x
fromI (String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Int
tot)
  (ElemProj c
small Rep era r
xrep Lens' r c
l Size
sz) -> do
    Int
tot <- Size -> Gen Int
genFromIntRange Size
sz
    [c]
rs <- c -> [String] -> Int -> c -> Gen [c]
forall x. Adds x => x -> [String] -> Int -> x -> Gen [x]
partition c
small [String]
msgs Int
n ([String] -> Int -> c
forall x. Adds x => [String] -> Int -> x
fromI (String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Int
tot)
    (c -> Gen r) -> [c] -> Gen [r]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\c
r -> do r
ans <- Rep era r -> Gen r
forall era b. Rep era b -> Gen b
genRep Rep era r
xrep; r -> Gen r
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r
ans r -> (r -> r) -> r
forall a b. a -> (a -> b) -> b
& (c -> Identity c) -> r -> Identity r
Lens' r c
l ((c -> Identity c) -> r -> Identity r) -> c -> r -> r
forall s t a b. ASetter s t a b -> b -> s -> t
.~ c
r)) [c]
rs
  where
    msg :: String
msg = String
"genFromElemSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec era r -> String
forall a. Show a => a -> String
show ElemSpec era r
x

manyMergeElemSpec :: Gen (Size, Int, [String])
manyMergeElemSpec :: Gen (Size, Int, [String])
manyMergeElemSpec = do
  Size
size <- Gen Size
genSize
  [ElemSpec BabbageEra Word64]
xs <- Int
-> Gen (ElemSpec BabbageEra Word64)
-> Gen [ElemSpec BabbageEra Word64]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
40 (Rep BabbageEra Word64
-> SomeLens BabbageEra Word64
-> Size
-> Gen (ElemSpec BabbageEra Word64)
forall w era.
Adds w =>
Rep era w -> SomeLens era w -> Size -> Gen (ElemSpec era w)
genElemSpec Rep BabbageEra Word64
forall era. Rep era Word64
Word64R (Lens' Word64 Coin -> SomeLens BabbageEra Word64
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (Coin -> f Coin) -> Word64 -> f Word64
Lens' Word64 Coin
word64CoinL) Size
size)
  [ElemSpec BabbageEra Word64]
ys <- Int
-> Gen (ElemSpec BabbageEra Word64)
-> Gen [ElemSpec BabbageEra Word64]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
40 (Rep BabbageEra Word64
-> SomeLens BabbageEra Word64
-> Size
-> Gen (ElemSpec BabbageEra Word64)
forall w era.
Adds w =>
Rep era w -> SomeLens era w -> Size -> Gen (ElemSpec era w)
genElemSpec Rep BabbageEra Word64
forall era. Rep era Word64
Word64R (Lens' Word64 Coin -> SomeLens BabbageEra Word64
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (Coin -> f Coin) -> Word64 -> f Word64
Lens' Word64 Coin
word64CoinL) Size
size)
  let check :: (ElemSpec BabbageEra Word64, ElemSpec BabbageEra Word64,
 ElemSpec BabbageEra Word64)
-> Gen
     (ElemSpec BabbageEra Word64, Bool, ElemSpec BabbageEra Word64,
      Bool, [Word64], Bool, ElemSpec BabbageEra Word64)
check (ElemSpec BabbageEra Word64
x, ElemSpec BabbageEra Word64
y, ElemSpec BabbageEra Word64
m) = do
        let msize :: Size
msize = ElemSpec BabbageEra Word64 -> Size
forall a era. ElemSpec era a -> Size
sizeForElemSpec ElemSpec BabbageEra Word64
m
        Int
i <- Size -> Gen Int
genFromSize Size
msize
        let wordsX :: [String]
wordsX =
              [ String
"s1<>s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
msize
              , String
"s1<>s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show ElemSpec BabbageEra Word64
m
              , String
"s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (ElemSpec BabbageEra Word64 -> Size
forall a era. ElemSpec era a -> Size
sizeForElemSpec ElemSpec BabbageEra Word64
x)
              , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show ElemSpec BabbageEra Word64
x
              , String
"s1 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (ElemSpec BabbageEra Word64 -> Size
forall a era. ElemSpec era a -> Size
sizeForElemSpec ElemSpec BabbageEra Word64
y)
              , String
"s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show ElemSpec BabbageEra Word64
y
              , String
"GenFromElemSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" size=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
size
              ]
        [Word64]
z <- forall era r. [String] -> Gen r -> Int -> ElemSpec era r -> Gen [r]
genFromElemSpec @BabbageEra [String]
wordsX ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
100)) Int
i ElemSpec BabbageEra Word64
m
        (ElemSpec BabbageEra Word64, Bool, ElemSpec BabbageEra Word64,
 Bool, [Word64], Bool, ElemSpec BabbageEra Word64)
-> Gen
     (ElemSpec BabbageEra Word64, Bool, ElemSpec BabbageEra Word64,
      Bool, [Word64], Bool, ElemSpec BabbageEra Word64)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ElemSpec BabbageEra Word64
x, [Word64] -> ElemSpec BabbageEra Word64 -> Bool
forall a era. [a] -> ElemSpec era a -> Bool
runElemSpec [Word64]
z ElemSpec BabbageEra Word64
x, ElemSpec BabbageEra Word64
y, [Word64] -> ElemSpec BabbageEra Word64 -> Bool
forall a era. [a] -> ElemSpec era a -> Bool
runElemSpec [Word64]
z ElemSpec BabbageEra Word64
y, [Word64]
z, [Word64] -> ElemSpec BabbageEra Word64 -> Bool
forall a era. [a] -> ElemSpec era a -> Bool
runElemSpec [Word64]
z ElemSpec BabbageEra Word64
m, ElemSpec BabbageEra Word64
m)
      showAns :: (ElemSpec era a, a, ElemSpec era a, a, a, a, ElemSpec era a)
-> String
showAns (ElemSpec era a
s1, a
run1, ElemSpec era a
s2, a
run2, a
v, a
run3, ElemSpec era a
s3) =
        [String] -> String
unlines
          [ String
"\ns1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec era a -> String
forall a. Show a => a -> String
show ElemSpec era a
s1
          , String
"s1 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (ElemSpec era a -> Size
forall a era. ElemSpec era a -> Size
sizeForElemSpec ElemSpec era a
s1)
          , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec era a -> String
forall a. Show a => a -> String
show ElemSpec era a
s2
          , String
"s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (ElemSpec era a -> Size
forall a era. ElemSpec era a -> Size
sizeForElemSpec ElemSpec era a
s2)
          , String
"s1 <> s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec era a -> String
forall a. Show a => a -> String
show ElemSpec era a
s3
          , String
"s1<>s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (ElemSpec era a -> Size
forall a era. ElemSpec era a -> Size
sizeForElemSpec ElemSpec era a
s3)
          , String
"v = genFromElemSpec (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v
          , String
"runElemSpec v s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run1
          , String
"runElemSpec v s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run2
          , String
"runElemSpec v (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run3
          ]
      pr :: (ElemSpec era a, Bool, ElemSpec era a, Bool, a, Bool,
 ElemSpec era a)
-> Maybe String
pr x :: (ElemSpec era a, Bool, ElemSpec era a, Bool, a, Bool,
 ElemSpec era a)
x@(ElemSpec era a
_, Bool
a, ElemSpec era a
_, Bool
b, a
_, Bool
c, ElemSpec era a
_) = if Bool -> Bool
not (Bool
a Bool -> Bool -> Bool
&& Bool
b Bool -> Bool -> Bool
&& Bool
c) then String -> Maybe String
forall a. a -> Maybe a
Just ((ElemSpec era a, Bool, ElemSpec era a, Bool, a, Bool,
 ElemSpec era a)
-> String
forall {a} {a} {a} {a} {era} {a} {era} {a} {era} {a}.
(Show a, Show a, Show a, Show a) =>
(ElemSpec era a, a, ElemSpec era a, a, a, a, ElemSpec era a)
-> String
showAns (ElemSpec era a, Bool, ElemSpec era a, Bool, a, Bool,
 ElemSpec era a)
x) else Maybe String
forall a. Maybe a
Nothing
  let trips :: [(ElemSpec BabbageEra Word64, ElemSpec BabbageEra Word64,
  ElemSpec BabbageEra Word64)]
trips = [(ElemSpec BabbageEra Word64
x, ElemSpec BabbageEra Word64
y, ElemSpec BabbageEra Word64
m) | ElemSpec BabbageEra Word64
x <- [ElemSpec BabbageEra Word64]
xs, ElemSpec BabbageEra Word64
y <- [ElemSpec BabbageEra Word64]
ys, Just ElemSpec BabbageEra Word64
m <- [ElemSpec BabbageEra Word64
-> ElemSpec BabbageEra Word64 -> Maybe (ElemSpec BabbageEra Word64)
forall a. (LiftT a, Semigroup a) => a -> a -> Maybe a
consistent ElemSpec BabbageEra Word64
x ElemSpec BabbageEra Word64
y]]
  [(ElemSpec BabbageEra Word64, Bool, ElemSpec BabbageEra Word64,
  Bool, [Word64], Bool, ElemSpec BabbageEra Word64)]
ts <- ((ElemSpec BabbageEra Word64, ElemSpec BabbageEra Word64,
  ElemSpec BabbageEra Word64)
 -> Gen
      (ElemSpec BabbageEra Word64, Bool, ElemSpec BabbageEra Word64,
       Bool, [Word64], Bool, ElemSpec BabbageEra Word64))
-> [(ElemSpec BabbageEra Word64, ElemSpec BabbageEra Word64,
     ElemSpec BabbageEra Word64)]
-> Gen
     [(ElemSpec BabbageEra Word64, Bool, ElemSpec BabbageEra Word64,
       Bool, [Word64], Bool, ElemSpec BabbageEra Word64)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ElemSpec BabbageEra Word64, ElemSpec BabbageEra Word64,
 ElemSpec BabbageEra Word64)
-> Gen
     (ElemSpec BabbageEra Word64, Bool, ElemSpec BabbageEra Word64,
      Bool, [Word64], Bool, ElemSpec BabbageEra Word64)
check [(ElemSpec BabbageEra Word64, ElemSpec BabbageEra Word64,
  ElemSpec BabbageEra Word64)]
trips
  (Size, Int, [String]) -> Gen (Size, Int, [String])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Size, Int, [String]) -> Gen (Size, Int, [String]))
-> (Size, Int, [String]) -> Gen (Size, Int, [String])
forall a b. (a -> b) -> a -> b
$ (Size
size, [(ElemSpec BabbageEra Word64, ElemSpec BabbageEra Word64,
  ElemSpec BabbageEra Word64)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ElemSpec BabbageEra Word64, ElemSpec BabbageEra Word64,
  ElemSpec BabbageEra Word64)]
trips, [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
Maybe.catMaybes (((ElemSpec BabbageEra Word64, Bool, ElemSpec BabbageEra Word64,
  Bool, [Word64], Bool, ElemSpec BabbageEra Word64)
 -> Maybe String)
-> [(ElemSpec BabbageEra Word64, Bool, ElemSpec BabbageEra Word64,
     Bool, [Word64], Bool, ElemSpec BabbageEra Word64)]
-> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (ElemSpec BabbageEra Word64, Bool, ElemSpec BabbageEra Word64,
 Bool, [Word64], Bool, ElemSpec BabbageEra Word64)
-> Maybe String
forall {a} {era} {a} {era} {a} {era} {a}.
Show a =>
(ElemSpec era a, Bool, ElemSpec era a, Bool, a, Bool,
 ElemSpec era a)
-> Maybe String
pr [(ElemSpec BabbageEra Word64, Bool, ElemSpec BabbageEra Word64,
  Bool, [Word64], Bool, ElemSpec BabbageEra Word64)]
ts))

reportManyMergeElemSpec :: IO ()
reportManyMergeElemSpec :: IO ()
reportManyMergeElemSpec = do
  (Size
size, Int
passed, [String]
bad) <- Gen (Size, Int, [String]) -> IO (Size, Int, [String])
forall a. Gen a -> IO a
generate Gen (Size, Int, [String])
manyMergeElemSpec
  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
bad
    then String -> IO ()
putStrLn (String
"passed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
passed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests. Spec size " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
size)
    else do (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
bad; String -> IO ()
forall a. HasCallStack => String -> a
error String
"TestFails"

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

-- | Specs for lists have two parts, the Size, and the elements
data ListSpec era t where
  ListSpec :: Size -> ElemSpec era t -> ListSpec era t
  ListNever :: [String] -> ListSpec era t

instance Show (ListSpec era a) where
  show :: ListSpec era a -> String
show = ListSpec era a -> String
forall era a. ListSpec era a -> String
showListSpec

instance Era era => Semigroup (ListSpec era a) where
  <> :: ListSpec era a -> ListSpec era a -> ListSpec era a
(<>) = ListSpec era a -> ListSpec era a -> ListSpec era a
forall era a.
Era era =>
ListSpec era a -> ListSpec era a -> ListSpec era a
mergeListSpec

instance Era era => Monoid (ListSpec era a) where
  mempty :: ListSpec era a
mempty = Size -> ElemSpec era a -> ListSpec era a
forall era t. Size -> ElemSpec era t -> ListSpec era t
ListSpec Size
SzAny ElemSpec era a
forall era t. ElemSpec era t
ElemAny

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

showListSpec :: ListSpec era a -> String
showListSpec :: forall era a. ListSpec era a -> String
showListSpec (ListSpec Size
s ElemSpec era a
xs) = [String] -> String
sepsP [String
"ListSpec", Size -> String
forall a. Show a => a -> String
show Size
s, ElemSpec era a -> String
forall a. Show a => a -> String
show ElemSpec era a
xs]
showListSpec (ListNever [String]
_) = String
"ListNever"

mergeListSpec :: Era era => ListSpec era a -> ListSpec era a -> ListSpec era a
mergeListSpec :: forall era a.
Era era =>
ListSpec era a -> ListSpec era a -> ListSpec era a
mergeListSpec (ListNever [String]
xs) (ListNever [String]
ys) = [String] -> ListSpec era a
forall era t. [String] -> ListSpec era t
ListNever ([String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ys)
mergeListSpec (ListNever [String]
xs) (ListSpec Size
_ ElemSpec era a
_) = [String] -> ListSpec era a
forall era t. [String] -> ListSpec era t
ListNever [String]
xs
mergeListSpec (ListSpec Size
_ ElemSpec era a
_) (ListNever [String]
xs) = [String] -> ListSpec era a
forall era t. [String] -> ListSpec era t
ListNever [String]
xs
mergeListSpec a :: ListSpec era a
a@(ListSpec Size
s1 ElemSpec era a
e1) b :: ListSpec era a
b@(ListSpec Size
s2 ElemSpec era a
e2) =
  case ElemSpec era a
e1 ElemSpec era a -> ElemSpec era a -> ElemSpec era a
forall a. Semigroup a => a -> a -> a
<> ElemSpec era a
e2 of
    ElemNever [String]
xs ->
      [String] -> ListSpec era a
forall era t. [String] -> ListSpec era t
ListNever ([String
"The ListSpec's are inconsistent.", String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ListSpec era a -> String
forall a. Show a => a -> String
show ListSpec era a
a, String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ListSpec era a -> String
forall a. Show a => a -> String
show ListSpec era a
b] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
xs)
    ElemSpec era a
e3 -> Typed (ListSpec era a) -> ListSpec era a
forall x. LiftT x => Typed x -> x
dropT (String -> Typed (ListSpec era a) -> Typed (ListSpec era a)
forall a. String -> Typed a -> Typed a
explain (String
"While merging\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ListSpec era a -> String
forall a. Show a => a -> String
show ListSpec era a
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ListSpec era a -> String
forall a. Show a => a -> String
show ListSpec era a
b) (Typed (ListSpec era a) -> Typed (ListSpec era a))
-> Typed (ListSpec era a) -> Typed (ListSpec era a)
forall a b. (a -> b) -> a -> b
$ Size -> ElemSpec era a -> Typed (ListSpec era a)
forall era t. Size -> ElemSpec era t -> Typed (ListSpec era t)
listSpec (Size
s1 Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> Size
s2) ElemSpec era a
e3)

-- | Test the size consistency while building a ListSpec
listSpec :: Size -> ElemSpec era t -> Typed (ListSpec era t)
listSpec :: forall era t. Size -> ElemSpec era t -> Typed (ListSpec era t)
listSpec Size
sz1 ElemSpec era t
el = case (Size
sz1 Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> Size
sz2) of
  SzNever [String]
xs ->
    [String] -> Typed (ListSpec era t)
forall a. [String] -> Typed a
failT
      ( [ String
"Creating " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ListSpec era t -> String
forall a. Show a => a -> String
show (Size -> ElemSpec era t -> ListSpec era t
forall era t. Size -> ElemSpec era t -> ListSpec era t
ListSpec Size
sz1 ElemSpec era t
el) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" fails."
        , String
"It has size inconsistencies."
        , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec era t -> String
forall a. Show a => a -> String
show ElemSpec era t
el String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has size " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
sz2
        , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"the expected size is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
sz1
        ]
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
xs
      )
  Size
size -> ListSpec era t -> Typed (ListSpec era t)
forall a. a -> Typed a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size -> ElemSpec era t -> ListSpec era t
forall era t. Size -> ElemSpec era t -> ListSpec era t
ListSpec Size
size ElemSpec era t
el)
  where
    sz2 :: Size
sz2 = ElemSpec era t -> Size
forall a era. ElemSpec era a -> Size
sizeForElemSpec ElemSpec era t
el

sizeForListSpec :: ListSpec era t -> Size
sizeForListSpec :: forall era t. ListSpec era t -> Size
sizeForListSpec (ListSpec Size
sz ElemSpec era t
_) = Size
sz
sizeForListSpec (ListNever [String]
_) = Size
SzAny

runListSpec :: [a] -> ListSpec era a -> Bool
runListSpec :: forall a era. [a] -> ListSpec era a -> Bool
runListSpec [a]
xs ListSpec era a
spec = case ListSpec era a
spec of
  ListNever [String]
_ -> Bool
False
  ListSpec Size
sx ElemSpec era a
es -> Int -> Size -> Bool
runSize ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) Size
sx Bool -> Bool -> Bool
&& [a] -> ElemSpec era a -> Bool
forall a era. [a] -> ElemSpec era a -> Bool
runElemSpec [a]
xs ElemSpec era a
es

genListSpec ::
  forall w era.
  Adds w =>
  Rep era w ->
  -- Rep era c ->
  SomeLens era w ->
  Size ->
  Gen (ListSpec era w)
genListSpec :: forall w era.
Adds w =>
Rep era w -> SomeLens era w -> Size -> Gen (ListSpec era w)
genListSpec Rep era w
repw SomeLens era w
l Size
size = do
  ElemSpec era w
e <- Rep era w -> SomeLens era w -> Size -> Gen (ElemSpec era w)
forall w era.
Adds w =>
Rep era w -> SomeLens era w -> Size -> Gen (ElemSpec era w)
genElemSpec Rep era w
repw SomeLens era w
l Size
size
  ListSpec era w -> Gen (ListSpec era w)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size -> ElemSpec era w -> ListSpec era w
forall era t. Size -> ElemSpec era t -> ListSpec era t
ListSpec Size
size ElemSpec era w
e)

genFromListSpec ::
  forall era r.
  [String] ->
  Gen r ->
  ListSpec era r ->
  Gen [r]
genFromListSpec :: forall era r. [String] -> Gen r -> ListSpec era r -> Gen [r]
genFromListSpec [String]
_ Gen r
_ (ListNever [String]
xs) = String -> [String] -> Gen [r]
forall a. HasCallStack => String -> [String] -> a
errorMess String
"ListNever in genFromListSpec" [String]
xs
genFromListSpec [String]
msgs Gen r
genr (ListSpec Size
size ElemSpec era r
e) = do
  Int
n <- Size -> Gen Int
genFromSize Size
size
  [String] -> Gen r -> Int -> ElemSpec era r -> Gen [r]
forall era r. [String] -> Gen r -> Int -> ElemSpec era r -> Gen [r]
genFromElemSpec (String
"genFromListSpec" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Gen r
genr Int
n ElemSpec era r
e

-- List and Elem tests

testSoundElemSpec :: Gen Property
testSoundElemSpec :: Gen Property
testSoundElemSpec = do
  Size
size <- Gen Size
genSize
  ElemSpec BabbageEra Word64
spec <- Rep BabbageEra Word64
-> SomeLens BabbageEra Word64
-> Size
-> Gen (ElemSpec BabbageEra Word64)
forall w era.
Adds w =>
Rep era w -> SomeLens era w -> Size -> Gen (ElemSpec era w)
genElemSpec Rep BabbageEra Word64
forall era. Rep era Word64
Word64R (Lens' Word64 Coin -> SomeLens BabbageEra Word64
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (Coin -> f Coin) -> Word64 -> f Word64
Lens' Word64 Coin
word64CoinL) Size
size
  Int
n <- Size -> Gen Int
genFromSize Size
size
  [Word64]
list <-
    forall era r. [String] -> Gen r -> Int -> ElemSpec era r -> Gen [r]
genFromElemSpec @BabbageEra
      [String
"testSoundElemSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show ElemSpec BabbageEra Word64
spec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n]
      ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
1000))
      Int
n
      ElemSpec BabbageEra Word64
spec
  Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$
    String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
      (String
"size=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
size String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nspec=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ElemSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show ElemSpec BabbageEra Word64
spec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nlist=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep Any [Word64] -> [Word64] -> String
forall e t. Rep e t -> t -> String
synopsis (Rep Any Word64 -> Rep Any [Word64]
forall era a. Rep era a -> Rep era [a]
ListR Rep Any Word64
forall era. Rep era Word64
Word64R) [Word64]
list)
      ([Word64] -> ElemSpec BabbageEra Word64 -> Bool
forall a era. [a] -> ElemSpec era a -> Bool
runElemSpec [Word64]
list ElemSpec BabbageEra Word64
spec)

testSoundListSpec :: Gen Property
testSoundListSpec :: Gen Property
testSoundListSpec = do
  Size
size <- Gen Size
genSize
  ListSpec BabbageEra Word64
spec <- Rep BabbageEra Word64
-> SomeLens BabbageEra Word64
-> Size
-> Gen (ListSpec BabbageEra Word64)
forall w era.
Adds w =>
Rep era w -> SomeLens era w -> Size -> Gen (ListSpec era w)
genListSpec Rep BabbageEra Word64
forall era. Rep era Word64
Word64R (Lens' Word64 Coin -> SomeLens BabbageEra Word64
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (Coin -> f Coin) -> Word64 -> f Word64
Lens' Word64 Coin
word64CoinL) Size
size
  [Word64]
list <- forall era r. [String] -> Gen r -> ListSpec era r -> Gen [r]
genFromListSpec @BabbageEra [String
"testSoundListSpec"] ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
1000)) ListSpec BabbageEra Word64
spec
  Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$
    String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
      (String
"spec=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ListSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show ListSpec BabbageEra Word64
spec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nlist=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep Any [Word64] -> [Word64] -> String
forall e t. Rep e t -> t -> String
synopsis (Rep Any Word64 -> Rep Any [Word64]
forall era a. Rep era a -> Rep era [a]
ListR Rep Any Word64
forall era. Rep era Word64
Word64R) [Word64]
list)
      ([Word64] -> ListSpec BabbageEra Word64 -> Bool
forall a era. [a] -> ListSpec era a -> Bool
runListSpec [Word64]
list ListSpec BabbageEra Word64
spec)

manyMergeListSpec :: Gen (Size, Int, [String])
manyMergeListSpec :: Gen (Size, Int, [String])
manyMergeListSpec = do
  Size
size <- Gen Size
genSize
  [ListSpec BabbageEra Word64]
xs <- Int
-> Gen (ListSpec BabbageEra Word64)
-> Gen [ListSpec BabbageEra Word64]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
40 (Rep BabbageEra Word64
-> SomeLens BabbageEra Word64
-> Size
-> Gen (ListSpec BabbageEra Word64)
forall w era.
Adds w =>
Rep era w -> SomeLens era w -> Size -> Gen (ListSpec era w)
genListSpec Rep BabbageEra Word64
forall era. Rep era Word64
Word64R (Lens' Word64 Coin -> SomeLens BabbageEra Word64
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (Coin -> f Coin) -> Word64 -> f Word64
Lens' Word64 Coin
word64CoinL) Size
size)
  [ListSpec BabbageEra Word64]
ys <- Int
-> Gen (ListSpec BabbageEra Word64)
-> Gen [ListSpec BabbageEra Word64]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
40 (Rep BabbageEra Word64
-> SomeLens BabbageEra Word64
-> Size
-> Gen (ListSpec BabbageEra Word64)
forall w era.
Adds w =>
Rep era w -> SomeLens era w -> Size -> Gen (ListSpec era w)
genListSpec Rep BabbageEra Word64
forall era. Rep era Word64
Word64R (Lens' Word64 Coin -> SomeLens BabbageEra Word64
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (Coin -> f Coin) -> Word64 -> f Word64
Lens' Word64 Coin
word64CoinL) Size
size)
  let check :: (ListSpec BabbageEra Word64, ListSpec BabbageEra Word64,
 ListSpec BabbageEra Word64)
-> Gen
     (ListSpec BabbageEra Word64, Bool, ListSpec BabbageEra Word64,
      Bool, [Word64], Bool, ListSpec BabbageEra Word64)
check (ListSpec BabbageEra Word64
x, ListSpec BabbageEra Word64
y, ListSpec BabbageEra Word64
m) = do
        let msize :: Size
msize = ListSpec BabbageEra Word64 -> Size
forall era t. ListSpec era t -> Size
sizeForListSpec ListSpec BabbageEra Word64
m
        Int
i <- Size -> Gen Int
genFromSize Size
msize
        let wordsX :: [String]
wordsX =
              [ String
"s1<>s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
msize
              , String
"s1<>s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ListSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show ListSpec BabbageEra Word64
m
              , String
"s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (ListSpec BabbageEra Word64 -> Size
forall era t. ListSpec era t -> Size
sizeForListSpec ListSpec BabbageEra Word64
x)
              , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ListSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show ListSpec BabbageEra Word64
x
              , String
"s1 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (ListSpec BabbageEra Word64 -> Size
forall era t. ListSpec era t -> Size
sizeForListSpec ListSpec BabbageEra Word64
y)
              , String
"s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ListSpec BabbageEra Word64 -> String
forall a. Show a => a -> String
show ListSpec BabbageEra Word64
y
              , String
"GenFromListSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" size=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
size
              ]
        [Word64]
z <- forall era r. [String] -> Gen r -> ListSpec era r -> Gen [r]
genFromListSpec @BabbageEra [String]
wordsX ((Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
100)) ListSpec BabbageEra Word64
m
        (ListSpec BabbageEra Word64, Bool, ListSpec BabbageEra Word64,
 Bool, [Word64], Bool, ListSpec BabbageEra Word64)
-> Gen
     (ListSpec BabbageEra Word64, Bool, ListSpec BabbageEra Word64,
      Bool, [Word64], Bool, ListSpec BabbageEra Word64)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ListSpec BabbageEra Word64
x, [Word64] -> ListSpec BabbageEra Word64 -> Bool
forall a era. [a] -> ListSpec era a -> Bool
runListSpec [Word64]
z ListSpec BabbageEra Word64
x, ListSpec BabbageEra Word64
y, [Word64] -> ListSpec BabbageEra Word64 -> Bool
forall a era. [a] -> ListSpec era a -> Bool
runListSpec [Word64]
z ListSpec BabbageEra Word64
y, [Word64]
z, [Word64] -> ListSpec BabbageEra Word64 -> Bool
forall a era. [a] -> ListSpec era a -> Bool
runListSpec [Word64]
z ListSpec BabbageEra Word64
m, ListSpec BabbageEra Word64
m)
      showAns :: (ListSpec era t, a, ListSpec era t, a, a, a, ListSpec era t)
-> String
showAns (ListSpec era t
s1, a
run1, ListSpec era t
s2, a
run2, a
v, a
run3, ListSpec era t
s3) =
        [String] -> String
unlines
          [ String
"\ns1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ListSpec era t -> String
forall a. Show a => a -> String
show ListSpec era t
s1
          , String
"s1 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (ListSpec era t -> Size
forall era t. ListSpec era t -> Size
sizeForListSpec ListSpec era t
s1)
          , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ListSpec era t -> String
forall a. Show a => a -> String
show ListSpec era t
s2
          , String
"s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (ListSpec era t -> Size
forall era t. ListSpec era t -> Size
sizeForListSpec ListSpec era t
s2)
          , String
"s1 <> s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ListSpec era t -> String
forall a. Show a => a -> String
show ListSpec era t
s3
          , String
"s1<>s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (ListSpec era t -> Size
forall era t. ListSpec era t -> Size
sizeForListSpec ListSpec era t
s3)
          , String
"v = genFromListSpec (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v
          , String
"runListSpec v s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run1
          , String
"runListSpec v s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run2
          , String
"runListSpec v (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run3
          ]
      pr :: (ListSpec era t, Bool, ListSpec era t, Bool, a, Bool,
 ListSpec era t)
-> Maybe String
pr x :: (ListSpec era t, Bool, ListSpec era t, Bool, a, Bool,
 ListSpec era t)
x@(ListSpec era t
_, Bool
a, ListSpec era t
_, Bool
b, a
_, Bool
c, ListSpec era t
_) = if Bool -> Bool
not (Bool
a Bool -> Bool -> Bool
&& Bool
b Bool -> Bool -> Bool
&& Bool
c) then String -> Maybe String
forall a. a -> Maybe a
Just ((ListSpec era t, Bool, ListSpec era t, Bool, a, Bool,
 ListSpec era t)
-> String
forall {a} {a} {a} {a} {era} {t} {era} {t} {era} {t}.
(Show a, Show a, Show a, Show a) =>
(ListSpec era t, a, ListSpec era t, a, a, a, ListSpec era t)
-> String
showAns (ListSpec era t, Bool, ListSpec era t, Bool, a, Bool,
 ListSpec era t)
x) else Maybe String
forall a. Maybe a
Nothing
  let trips :: [(ListSpec BabbageEra Word64, ListSpec BabbageEra Word64,
  ListSpec BabbageEra Word64)]
trips = [(ListSpec BabbageEra Word64
x, ListSpec BabbageEra Word64
y, ListSpec BabbageEra Word64
m) | ListSpec BabbageEra Word64
x <- [ListSpec BabbageEra Word64]
xs, ListSpec BabbageEra Word64
y <- [ListSpec BabbageEra Word64]
ys, Just ListSpec BabbageEra Word64
m <- [ListSpec BabbageEra Word64
-> ListSpec BabbageEra Word64 -> Maybe (ListSpec BabbageEra Word64)
forall a. (LiftT a, Semigroup a) => a -> a -> Maybe a
consistent ListSpec BabbageEra Word64
x ListSpec BabbageEra Word64
y]]
  [(ListSpec BabbageEra Word64, Bool, ListSpec BabbageEra Word64,
  Bool, [Word64], Bool, ListSpec BabbageEra Word64)]
ts <- ((ListSpec BabbageEra Word64, ListSpec BabbageEra Word64,
  ListSpec BabbageEra Word64)
 -> Gen
      (ListSpec BabbageEra Word64, Bool, ListSpec BabbageEra Word64,
       Bool, [Word64], Bool, ListSpec BabbageEra Word64))
-> [(ListSpec BabbageEra Word64, ListSpec BabbageEra Word64,
     ListSpec BabbageEra Word64)]
-> Gen
     [(ListSpec BabbageEra Word64, Bool, ListSpec BabbageEra Word64,
       Bool, [Word64], Bool, ListSpec BabbageEra Word64)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ListSpec BabbageEra Word64, ListSpec BabbageEra Word64,
 ListSpec BabbageEra Word64)
-> Gen
     (ListSpec BabbageEra Word64, Bool, ListSpec BabbageEra Word64,
      Bool, [Word64], Bool, ListSpec BabbageEra Word64)
check [(ListSpec BabbageEra Word64, ListSpec BabbageEra Word64,
  ListSpec BabbageEra Word64)]
trips
  (Size, Int, [String]) -> Gen (Size, Int, [String])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Size, Int, [String]) -> Gen (Size, Int, [String]))
-> (Size, Int, [String]) -> Gen (Size, Int, [String])
forall a b. (a -> b) -> a -> b
$ (Size
size, [(ListSpec BabbageEra Word64, ListSpec BabbageEra Word64,
  ListSpec BabbageEra Word64)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ListSpec BabbageEra Word64, ListSpec BabbageEra Word64,
  ListSpec BabbageEra Word64)]
trips, [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
Maybe.catMaybes (((ListSpec BabbageEra Word64, Bool, ListSpec BabbageEra Word64,
  Bool, [Word64], Bool, ListSpec BabbageEra Word64)
 -> Maybe String)
-> [(ListSpec BabbageEra Word64, Bool, ListSpec BabbageEra Word64,
     Bool, [Word64], Bool, ListSpec BabbageEra Word64)]
-> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (ListSpec BabbageEra Word64, Bool, ListSpec BabbageEra Word64,
 Bool, [Word64], Bool, ListSpec BabbageEra Word64)
-> Maybe String
forall {a} {era} {t} {era} {t} {era} {t}.
Show a =>
(ListSpec era t, Bool, ListSpec era t, Bool, a, Bool,
 ListSpec era t)
-> Maybe String
pr [(ListSpec BabbageEra Word64, Bool, ListSpec BabbageEra Word64,
  Bool, [Word64], Bool, ListSpec BabbageEra Word64)]
ts))

reportManyMergeListSpec :: IO ()
reportManyMergeListSpec :: IO ()
reportManyMergeListSpec = do
  (Size
size, Int
passed, [String]
bad) <- Gen (Size, Int, [String]) -> IO (Size, Int, [String])
forall a. Gen a -> IO a
generate Gen (Size, Int, [String])
manyMergeListSpec
  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
bad
    then String -> IO ()
putStrLn (String
"passed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
passed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests. Spec size " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show Size
size)
    else do (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
bad; String -> IO ()
forall a. HasCallStack => String -> a
error String
"TestFails"

-- ================================================
-- Synthetic classes used to control the size of
-- things in the tests.

class (Arbitrary t, Adds t) => TestAdd t where
  anyAdds :: Gen t
  pos :: Gen t

instance TestAdd Word64 where
  anyAdds :: Gen Word64
anyAdds = (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
12)
  pos :: Gen Word64
pos = (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
12)

instance TestAdd Coin where
  anyAdds :: Gen Coin
anyAdds = Integer -> Coin
Coin (Integer -> Coin) -> Gen Integer -> Gen Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
0, Integer
8)
  pos :: Gen Coin
pos = Integer -> Coin
Coin (Integer -> Coin) -> Gen Integer -> Gen Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
1, Integer
8)

instance TestAdd Int where
  anyAdds :: Gen Int
anyAdds = (Int, Int) -> Gen Int
chooseInt (Int
0, Int
atMostAny)
  pos :: Gen Int
pos = (Int, Int) -> Gen Int
chooseInt (Int
1, Int
atMostAny)

-- =============================================
-- Some simple generators tied to TestAdd class

-- | Only the size of the set uses TestAdd
genSet :: Ord t => Int -> Gen t -> Gen (Set t)
genSet :: forall t. Ord t => Int -> Gen t -> Gen (Set t)
genSet Int
n Gen t
gen = do
  [t]
xs <- Int -> Gen t -> Gen [t]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
20 Gen t
gen
  Set t -> Gen (Set t)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([t] -> Set t
forall a. Ord a => [a] -> Set a
Set.fromList (Int -> [t] -> [t]
forall a. Int -> [a] -> [a]
take Int
n ([t] -> [t]
forall a. Eq a => [a] -> [a]
List.nub [t]
xs)))

testSet :: (Ord t, TestAdd t) => Gen (Set t)
testSet :: forall t. (Ord t, TestAdd t) => Gen (Set t)
testSet = do
  Int
n <- forall t. TestAdd t => Gen t
pos @Int
  [t] -> Set t
forall a. Ord a => [a] -> Set a
Set.fromList ([t] -> Set t) -> Gen [t] -> Gen (Set t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen t -> Gen [t]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen t
forall t. TestAdd t => Gen t
anyAdds

someSet :: Ord t => Gen t -> Gen (Set t)
someSet :: forall t. Ord t => Gen t -> Gen (Set t)
someSet Gen t
g = do
  Int
n <- forall t. TestAdd t => Gen t
pos @Int
  [t] -> Set t
forall a. Ord a => [a] -> Set a
Set.fromList ([t] -> Set t) -> Gen [t] -> Gen (Set t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen t -> Gen [t]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen t
g

someMap :: forall era t d. (Ord d, TestAdd t) => Rep era d -> Gen (Map d t)
someMap :: forall era t d. (Ord d, TestAdd t) => Rep era d -> Gen (Map d t)
someMap Rep era d
r = do
  Int
n <- forall t. TestAdd t => Gen t
pos @Int
  [t]
rs <- Int -> Gen t -> Gen [t]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen t
forall t. TestAdd t => Gen t
anyAdds
  [d]
ds <- Int -> Gen d -> Gen [d]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n (Rep era d -> Gen d
forall era b. Rep era b -> Gen b
genRep Rep era d
r)
  Map d t -> Gen (Map d t)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map d t -> Gen (Map d t)) -> Map d t -> Gen (Map d t)
forall a b. (a -> b) -> a -> b
$ [(d, t)] -> Map d t
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([d] -> [t] -> [(d, t)]
forall a b. [a] -> [b] -> [(a, b)]
zip [d]
ds [t]
rs)

-- ===================================
-- Some proto-tests, to be fixed soon

aMap :: Era era => Gen (MapSpec era Int Word64)
aMap :: forall era. Era era => Gen (MapSpec era Int Word64)
aMap = Gen Int
-> Rep era Int
-> Rep era Word64
-> SomeLens era Word64
-> Int
-> Gen (MapSpec era Int Word64)
forall era dom w.
(Ord dom, Era era, Ord w, Adds w) =>
Gen dom
-> Rep era dom
-> Rep era w
-> SomeLens era w
-> Int
-> Gen (MapSpec era dom w)
genMapSpec ((Int, Int) -> Gen Int
chooseInt (Int
1, Int
1000)) Rep era Int
forall era. Rep era Int
IntR Rep era Word64
forall era. Rep era Word64
Word64R (Lens' Word64 Coin -> SomeLens era Word64
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (Coin -> f Coin) -> Word64 -> f Word64
Lens' Word64 Coin
word64CoinL) Int
4

testm :: Gen (MapSpec BabbageEra Int Word64)
testm :: Gen (MapSpec BabbageEra Int Word64)
testm = do
  MapSpec BabbageEra Int Word64
a <- forall era. Era era => Gen (MapSpec era Int Word64)
aMap @BabbageEra
  MapSpec BabbageEra Int Word64
b <- Gen (MapSpec BabbageEra Int Word64)
forall era. Era era => Gen (MapSpec era Int Word64)
aMap
  Typed (MapSpec BabbageEra Int Word64)
-> Gen (MapSpec BabbageEra Int Word64)
forall (m :: * -> *) t. (HasCallStack, Monad m) => Typed t -> m t
monadTyped (MapSpec BabbageEra Int Word64
-> Typed (MapSpec BabbageEra Int Word64)
forall x. LiftT x => x -> Typed x
liftT (MapSpec BabbageEra Int Word64
a MapSpec BabbageEra Int Word64
-> MapSpec BabbageEra Int Word64 -> MapSpec BabbageEra Int Word64
forall a. Semigroup a => a -> a -> a
<> MapSpec BabbageEra Int Word64
b))

aList :: Gen (ListSpec era Word64)
aList :: forall era. Gen (ListSpec era Word64)
aList = Gen Size
genSize Gen Size
-> (Size -> Gen (ListSpec era Word64)) -> Gen (ListSpec era Word64)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Rep era Word64
-> SomeLens era Word64 -> Size -> Gen (ListSpec era Word64)
forall w era.
Adds w =>
Rep era w -> SomeLens era w -> Size -> Gen (ListSpec era w)
genListSpec Rep era Word64
forall era. Rep era Word64
Word64R (Lens' Word64 Coin -> SomeLens era Word64
forall c t era. Adds c => Lens' t c -> SomeLens era t
SomeLens (Coin -> f Coin) -> Word64 -> f Word64
Lens' Word64 Coin
word64CoinL)

testl :: Gen (ListSpec BabbageEra Word64)
testl :: Gen (ListSpec BabbageEra Word64)
testl = do
  ListSpec BabbageEra Word64
a <- forall era. Gen (ListSpec era Word64)
aList @BabbageEra
  ListSpec BabbageEra Word64
b <- Gen (ListSpec BabbageEra Word64)
forall era. Gen (ListSpec era Word64)
aList
  Typed (ListSpec BabbageEra Word64)
-> Gen (ListSpec BabbageEra Word64)
forall (m :: * -> *) t. (HasCallStack, Monad m) => Typed t -> m t
monadTyped (ListSpec BabbageEra Word64 -> Typed (ListSpec BabbageEra Word64)
forall x. LiftT x => x -> Typed x
liftT (ListSpec BabbageEra Word64
a ListSpec BabbageEra Word64
-> ListSpec BabbageEra Word64 -> ListSpec BabbageEra Word64
forall a. Semigroup a => a -> a -> a
<> ListSpec BabbageEra Word64
b))

-- =======================================================================
-- Operations on AddsSpec (defined in Classes.hs)

testV :: Era era => V era DeltaCoin
testV :: forall era. Era era => V era DeltaCoin
testV = (String
-> Rep era DeltaCoin -> Access era Any DeltaCoin -> V era DeltaCoin
forall era t s.
Era era =>
String -> Rep era t -> Access era s t -> V era t
V String
"x" Rep era DeltaCoin
forall era. Rep era DeltaCoin
DeltaCoinR Access era Any DeltaCoin
forall era s t. Access era s t
No)

genSumsTo :: Era era => Gen (Pred era)
genSumsTo :: forall era. Era era => Gen (Pred era)
genSumsTo = do
  OrdCond
c <- Gen OrdCond
genOrdCond
  let v :: Term era DeltaCoin
v = V era DeltaCoin -> Term era DeltaCoin
forall era t. V era t -> Term era t
Var V era DeltaCoin
forall era. Era era => V era DeltaCoin
testV
  Term era DeltaCoin
rhs <- (Rep era DeltaCoin -> DeltaCoin -> Term era DeltaCoin
forall era t. Rep era t -> t -> Term era t
Lit Rep era DeltaCoin
forall era. Rep era DeltaCoin
DeltaCoinR (DeltaCoin -> Term era DeltaCoin)
-> (Integer -> DeltaCoin) -> Integer -> Term era DeltaCoin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> DeltaCoin
DeltaCoin) (Integer -> Term era DeltaCoin)
-> Gen Integer -> Gen (Term era DeltaCoin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (-Integer
10, Integer
10)
  Term era DeltaCoin
lhs <- (Rep era DeltaCoin -> DeltaCoin -> Term era DeltaCoin
forall era t. Rep era t -> t -> Term era t
Lit Rep era DeltaCoin
forall era. Rep era DeltaCoin
DeltaCoinR (DeltaCoin -> Term era DeltaCoin)
-> (Integer -> DeltaCoin) -> Integer -> Term era DeltaCoin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> DeltaCoin
DeltaCoin) (Integer -> Term era DeltaCoin)
-> Gen Integer -> Gen (Term era DeltaCoin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (-Integer
10, Integer
10)
  [Pred era] -> Gen (Pred era)
forall a. HasCallStack => [a] -> Gen a
elements
    [Direct DeltaCoin
-> Term era DeltaCoin -> OrdCond -> [Sum era DeltaCoin] -> Pred era
forall era c.
(Era era, Adds c) =>
Direct c -> Term era c -> OrdCond -> [Sum era c] -> Pred era
SumsTo (DeltaCoin -> Direct DeltaCoin
forall a b. a -> Either a b
Left (Integer -> DeltaCoin
DeltaCoin Integer
1)) Term era DeltaCoin
v OrdCond
c [Term era DeltaCoin -> Sum era DeltaCoin
forall era c. Term era c -> Sum era c
One Term era DeltaCoin
rhs], Direct DeltaCoin
-> Term era DeltaCoin -> OrdCond -> [Sum era DeltaCoin] -> Pred era
forall era c.
(Era era, Adds c) =>
Direct c -> Term era c -> OrdCond -> [Sum era c] -> Pred era
SumsTo (DeltaCoin -> Direct DeltaCoin
forall a b. a -> Either a b
Left (Integer -> DeltaCoin
DeltaCoin Integer
1)) Term era DeltaCoin
lhs OrdCond
c [Term era DeltaCoin -> Sum era DeltaCoin
forall era c. Term era c -> Sum era c
One Term era DeltaCoin
rhs, Term era DeltaCoin -> Sum era DeltaCoin
forall era c. Term era c -> Sum era c
One Term era DeltaCoin
v]]

solveSumsTo :: Pred era -> AddsSpec DeltaCoin
solveSumsTo :: forall era. Pred era -> AddsSpec DeltaCoin
solveSumsTo (SumsTo Direct c
_ (Lit Rep era c
DeltaCoinR c
n) OrdCond
cond [One (Lit Rep era c
DeltaCoinR c
m), One (Var (V String
nam Rep era c
_ Access era s c
_))]) =
  forall a c.
Adds a =>
[String] -> a -> OrdCond -> a -> String -> AddsSpec c
varOnRight @DeltaCoin [String
"solveSumsTo"] c
DeltaCoin
n OrdCond
cond c
DeltaCoin
m String
nam
solveSumsTo (SumsTo Direct c
_ (Var (V String
nam Rep era c
DeltaCoinR Access era s c
_)) OrdCond
cond [One (Lit Rep era c
DeltaCoinR c
m)]) =
  String -> OrdCond -> c -> AddsSpec DeltaCoin
forall a c. Adds a => String -> OrdCond -> a -> AddsSpec c
varOnLeft String
nam OrdCond
cond c
m
solveSumsTo Pred era
x = [String] -> AddsSpec DeltaCoin
forall c. [String] -> AddsSpec c
AddsSpecNever [String
"solveSumsTo " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pred era -> String
forall a. Show a => a -> String
show Pred era
x]

condReverse :: Gen Property
condReverse :: Gen Property
condReverse = do
  Pred BabbageEra
predicate <- Gen (Pred BabbageEra)
forall era. Era era => Gen (Pred era)
genSumsTo
  let addsSpec :: AddsSpec DeltaCoin
addsSpec = Pred BabbageEra -> AddsSpec DeltaCoin
forall era. Pred era -> AddsSpec DeltaCoin
solveSumsTo Pred BabbageEra
predicate
  let msgs :: [String]
msgs = [String
"condFlip", Pred BabbageEra -> String
forall a. Show a => a -> String
show Pred BabbageEra
predicate, AddsSpec DeltaCoin -> String
forall a. Show a => a -> String
show AddsSpec DeltaCoin
addsSpec]
  Int
n <- [String] -> AddsSpec DeltaCoin -> Gen Int
forall c. [String] -> AddsSpec c -> Gen Int
genFromAddsSpec [String]
msgs AddsSpec DeltaCoin
addsSpec
  let env :: Env BabbageEra
env = V BabbageEra DeltaCoin
-> DeltaCoin -> Env BabbageEra -> Env BabbageEra
forall era t. V era t -> t -> Env era -> Env era
storeVar V BabbageEra DeltaCoin
forall era. Era era => V era DeltaCoin
testV ([String] -> Int -> DeltaCoin
forall x. Adds x => [String] -> Int -> x
fromI (Int -> String
forall a. Show a => a -> String
show Int
n String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs) Int
n) Env BabbageEra
forall era. Env era
emptyEnv
  case Typed Bool -> Either [String] Bool
forall x. Typed x -> Either [String] x
runTyped (forall era. Env era -> Pred era -> Typed Bool
runPred @BabbageEra Env BabbageEra
env Pred BabbageEra
predicate) of
    Right Bool
x -> Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([String] -> String
unlines (Int -> String
forall a. Show a => a -> String
show Int
n String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs)) Bool
x)
    Left [String]
xs -> String -> [String] -> Gen Property
forall a. HasCallStack => String -> [String] -> a
errorMess String
"runTyped in condFlip fails" ([String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
n String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs))

genAddsSpec :: forall c. Adds c => Gen (AddsSpec c)
genAddsSpec :: forall c. Adds c => Gen (AddsSpec c)
genAddsSpec = do
  String
v <- [String] -> Gen String
forall a. HasCallStack => [a] -> Gen a
elements [String
"x", String
"y"]
  OrdCond
c <- Gen OrdCond
genOrdCond
  c
rhs <- forall x. Adds x => [String] -> Int -> x
fromI @c [String
"genAddsSpec"] (Int -> c) -> Gen Int -> Gen c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose @Int (-Int
25, Int
25)
  c
lhs <- forall x. Adds x => [String] -> Int -> x
fromI @c [String
"genAddsSpec"] (Int -> c) -> Gen Int -> Gen c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose @Int (-Int
25, Int
25)
  [AddsSpec c] -> Gen (AddsSpec c)
forall a. HasCallStack => [a] -> Gen a
elements [String -> OrdCond -> c -> AddsSpec c
forall a c. Adds a => String -> OrdCond -> a -> AddsSpec c
varOnLeft String
v OrdCond
c c
rhs, [String] -> c -> OrdCond -> c -> String -> AddsSpec c
forall a c.
Adds a =>
[String] -> a -> OrdCond -> a -> String -> AddsSpec c
varOnRight [String
"genAddsSpec"] c
lhs OrdCond
c c
rhs String
v]

genNonNegAddsSpec :: forall c. Adds c => Gen (AddsSpec c)
genNonNegAddsSpec :: forall c. Adds c => Gen (AddsSpec c)
genNonNegAddsSpec = do
  String
v <- [String] -> Gen String
forall a. HasCallStack => [a] -> Gen a
elements [String
"x", String
"y"]
  OrdCond
c <- Gen OrdCond
genOrdCond
  Int
lhs <- forall a. Random a => (a, a) -> Gen a
choose @Int (Int
10, Int
30)
  Int
rhs <- forall a. Random a => (a, a) -> Gen a
choose @Int (Int
1, Int
lhs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  let lhs' :: Int
lhs' = case OrdCond
c of
        OrdCond
LTH -> Int
lhs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        OrdCond
_ -> Int
lhs
      fromX :: Int -> c
fromX Int
x = forall x. Adds x => [String] -> Int -> x
fromI @c [String
"genNonNegAddsSpec"] Int
x
  [AddsSpec c] -> Gen (AddsSpec c)
forall a. HasCallStack => [a] -> Gen a
elements [String -> OrdCond -> c -> AddsSpec c
forall a c. Adds a => String -> OrdCond -> a -> AddsSpec c
varOnLeft String
v OrdCond
c (c -> AddsSpec c) -> c -> AddsSpec c
forall a b. (a -> b) -> a -> b
$ Int -> c
fromX Int
rhs, [String] -> c -> OrdCond -> c -> String -> AddsSpec c
forall a c.
Adds a =>
[String] -> a -> OrdCond -> a -> String -> AddsSpec c
varOnRight [String
"genNonNegAddsSpec"] (Int -> c
fromX Int
lhs') OrdCond
c (Int -> c
fromX Int
rhs) String
v]

genOrdCond :: Gen OrdCond
genOrdCond :: Gen OrdCond
genOrdCond = [OrdCond] -> Gen OrdCond
forall a. HasCallStack => [a] -> Gen a
elements [OrdCond
EQL, OrdCond
LTH, OrdCond
LTE, OrdCond
GTH, OrdCond
GTE]

runAddsSpec :: forall c. Adds c => c -> AddsSpec c -> Bool
runAddsSpec :: forall c. Adds c => c -> AddsSpec c -> Bool
runAddsSpec c
c (AddsSpecSize String
_ Size
size) = Int -> Size -> Bool
runSize (c -> Int
forall x. Adds x => x -> Int
toI c
c) Size
size
runAddsSpec c
_ AddsSpec c
AddsSpecAny = Bool
True
runAddsSpec c
_ (AddsSpecNever [String]
_) = Bool
False

-- | Not sure how to interpret this? As the possible totals that make the implicit OrdCond True?
sizeForAddsSpec :: AddsSpec c -> Size
sizeForAddsSpec :: forall c. AddsSpec c -> Size
sizeForAddsSpec (AddsSpecSize String
_ Size
s) = Size
s
sizeForAddsSpec AddsSpec c
AddsSpecAny = Size
SzAny
sizeForAddsSpec (AddsSpecNever [String]
xs) = [String] -> Size
SzNever [String]
xs

tryManyAddsSpec ::
  Gen (AddsSpec Int) -> ([String] -> AddsSpec Int -> Gen Int) -> Gen (Int, [String])
tryManyAddsSpec :: Gen (AddsSpec Int)
-> ([String] -> AddsSpec Int -> Gen Int) -> Gen (Int, [String])
tryManyAddsSpec Gen (AddsSpec Int)
genSum [String] -> AddsSpec Int -> Gen Int
genFromSum = do
  [AddsSpec Int]
xs <- Int -> Gen (AddsSpec Int) -> Gen [AddsSpec Int]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
25 Gen (AddsSpec Int)
genSum
  [AddsSpec Int]
ys <- Int -> Gen (AddsSpec Int) -> Gen [AddsSpec Int]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
25 Gen (AddsSpec Int)
genSum
  let check :: (AddsSpec Int, AddsSpec Int, AddsSpec Int)
-> Gen
     (AddsSpec Int, Bool, AddsSpec Int, Bool, Int, Bool, AddsSpec Int)
check (AddsSpec Int
x, AddsSpec Int
y, AddsSpec Int
m) = do
        Int
z <- [String] -> AddsSpec Int -> Gen Int
genFromSum [String
"test tryManyAddsSpec"] AddsSpec Int
m
        (AddsSpec Int, Bool, AddsSpec Int, Bool, Int, Bool, AddsSpec Int)
-> Gen
     (AddsSpec Int, Bool, AddsSpec Int, Bool, Int, Bool, AddsSpec Int)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AddsSpec Int
x, Int -> AddsSpec Int -> Bool
forall c. Adds c => c -> AddsSpec c -> Bool
runAddsSpec Int
z AddsSpec Int
x, AddsSpec Int
y, Int -> AddsSpec Int -> Bool
forall c. Adds c => c -> AddsSpec c -> Bool
runAddsSpec Int
z AddsSpec Int
y, Int
z, Int -> AddsSpec Int -> Bool
forall c. Adds c => c -> AddsSpec c -> Bool
runAddsSpec Int
z AddsSpec Int
m, AddsSpec Int
m)
      showAns :: (AddsSpec c, Bool, AddsSpec c, Bool, Int, Bool, AddsSpec c) -> String
      showAns :: forall c.
(AddsSpec c, Bool, AddsSpec c, Bool, Int, Bool, AddsSpec c)
-> String
showAns (AddsSpec c
s1, Bool
run1, AddsSpec c
s2, Bool
run2, Int
v, Bool
run3, AddsSpec c
s3) =
        [String] -> String
unlines
          [ String
"s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AddsSpec c -> String
forall a. Show a => a -> String
show AddsSpec c
s1
          , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AddsSpec c -> String
forall a. Show a => a -> String
show AddsSpec c
s2
          , String
"s1 <> s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AddsSpec c -> String
forall a. Show a => a -> String
show AddsSpec c
s3
          , String
"v = genFromAdsSpec (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
v
          , String
"runAddsSpec s1 v = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
run1
          , String
"runAddsSpec s2 v = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
run2
          , String
"runAddsSpec (s1 <> s2) v = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
run3
          ]
      pr :: (AddsSpec c, Bool, AddsSpec c, Bool, Int, Bool, AddsSpec c)
-> Maybe String
pr x :: (AddsSpec c, Bool, AddsSpec c, Bool, Int, Bool, AddsSpec c)
x@(AddsSpec c
_, Bool
a, AddsSpec c
_, Bool
b, Int
_, Bool
c, AddsSpec c
_) = if Bool -> Bool
not (Bool
a Bool -> Bool -> Bool
&& Bool
b Bool -> Bool -> Bool
&& Bool
c) then String -> Maybe String
forall a. a -> Maybe a
Just ((AddsSpec c, Bool, AddsSpec c, Bool, Int, Bool, AddsSpec c)
-> String
forall c.
(AddsSpec c, Bool, AddsSpec c, Bool, Int, Bool, AddsSpec c)
-> String
showAns (AddsSpec c, Bool, AddsSpec c, Bool, Int, Bool, AddsSpec c)
x) else Maybe String
forall a. Maybe a
Nothing
  let trips :: [(AddsSpec Int, AddsSpec Int, AddsSpec Int)]
trips = [(AddsSpec Int
x, AddsSpec Int
y, AddsSpec Int
m) | AddsSpec Int
x <- [AddsSpec Int]
xs, AddsSpec Int
y <- [AddsSpec Int]
ys, Just AddsSpec Int
m <- [AddsSpec Int -> AddsSpec Int -> Maybe (AddsSpec Int)
forall a. (LiftT a, Semigroup a) => a -> a -> Maybe a
consistent AddsSpec Int
x AddsSpec Int
y]]
  [(AddsSpec Int, Bool, AddsSpec Int, Bool, Int, Bool, AddsSpec Int)]
ts <- ((AddsSpec Int, AddsSpec Int, AddsSpec Int)
 -> Gen
      (AddsSpec Int, Bool, AddsSpec Int, Bool, Int, Bool, AddsSpec Int))
-> [(AddsSpec Int, AddsSpec Int, AddsSpec Int)]
-> Gen
     [(AddsSpec Int, Bool, AddsSpec Int, Bool, Int, Bool, AddsSpec Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (AddsSpec Int, AddsSpec Int, AddsSpec Int)
-> Gen
     (AddsSpec Int, Bool, AddsSpec Int, Bool, Int, Bool, AddsSpec Int)
check [(AddsSpec Int, AddsSpec Int, AddsSpec Int)]
trips
  (Int, [String]) -> Gen (Int, [String])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, [String]) -> Gen (Int, [String]))
-> (Int, [String]) -> Gen (Int, [String])
forall a b. (a -> b) -> a -> b
$ ([(AddsSpec Int, AddsSpec Int, AddsSpec Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(AddsSpec Int, AddsSpec Int, AddsSpec Int)]
trips, [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
Maybe.catMaybes (((AddsSpec Int, Bool, AddsSpec Int, Bool, Int, Bool, AddsSpec Int)
 -> Maybe String)
-> [(AddsSpec Int, Bool, AddsSpec Int, Bool, Int, Bool,
     AddsSpec Int)]
-> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (AddsSpec Int, Bool, AddsSpec Int, Bool, Int, Bool, AddsSpec Int)
-> Maybe String
forall {c}.
(AddsSpec c, Bool, AddsSpec c, Bool, Int, Bool, AddsSpec c)
-> Maybe String
pr [(AddsSpec Int, Bool, AddsSpec Int, Bool, Int, Bool, AddsSpec Int)]
ts))

reportManyAddsSpec :: IO ()
reportManyAddsSpec :: IO ()
reportManyAddsSpec = do
  (Int
passed, [String]
bad) <- Gen (Int, [String]) -> IO (Int, [String])
forall a. Gen a -> IO a
generate (Gen (AddsSpec Int)
-> ([String] -> AddsSpec Int -> Gen Int) -> Gen (Int, [String])
tryManyAddsSpec Gen (AddsSpec Int)
forall c. Adds c => Gen (AddsSpec c)
genAddsSpec [String] -> AddsSpec Int -> Gen Int
forall c. [String] -> AddsSpec c -> Gen Int
genFromAddsSpec)
  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
bad
    then String -> IO ()
putStrLn (String
"passed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
passed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests.")
    else do (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
bad; String -> IO ()
forall a. HasCallStack => String -> a
error String
"TestFails"

reportManyNonNegAddsSpec :: IO ()
reportManyNonNegAddsSpec :: IO ()
reportManyNonNegAddsSpec = do
  (Int
passed, [String]
bad) <- Gen (Int, [String]) -> IO (Int, [String])
forall a. Gen a -> IO a
generate (Gen (AddsSpec Int)
-> ([String] -> AddsSpec Int -> Gen Int) -> Gen (Int, [String])
tryManyAddsSpec Gen (AddsSpec Int)
forall c. Adds c => Gen (AddsSpec c)
genNonNegAddsSpec [String] -> AddsSpec Int -> Gen Int
forall c. [String] -> AddsSpec c -> Gen Int
genFromNonNegAddsSpec)
  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
bad
    then String -> IO ()
putStrLn (String
"passed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
passed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests.")
    else do (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
bad; String -> IO ()
forall a. HasCallStack => String -> a
error String
"TestFails"

testSoundNonNegAddsSpec :: Gen Property
testSoundNonNegAddsSpec :: Gen Property
testSoundNonNegAddsSpec = do
  AddsSpec Int
spec <- forall c. Adds c => Gen (AddsSpec c)
genNonNegAddsSpec @Int
  Int
c <- [String] -> AddsSpec Int -> Gen Int
forall c. [String] -> AddsSpec c -> Gen Int
genFromNonNegAddsSpec [String
"testSoundAddsSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AddsSpec Int -> String
forall a. Show a => a -> String
show AddsSpec Int
spec] AddsSpec Int
spec
  Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$
    String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
      (String
"AddsSpec=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ AddsSpec Int -> String
forall a. Show a => a -> String
show AddsSpec Int
spec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\ngenerated value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
c)
      (Int -> AddsSpec Int -> Bool
forall c. Adds c => c -> AddsSpec c -> Bool
runAddsSpec Int
c AddsSpec Int
spec)

testSoundAddsSpec :: Gen Property
testSoundAddsSpec :: Gen Property
testSoundAddsSpec = do
  AddsSpec DeltaCoin
spec <- forall c. Adds c => Gen (AddsSpec c)
genAddsSpec @DeltaCoin
  Int
c <- [String] -> AddsSpec DeltaCoin -> Gen Int
forall c. [String] -> AddsSpec c -> Gen Int
genFromAddsSpec [String
"testSoundAddsSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AddsSpec DeltaCoin -> String
forall a. Show a => a -> String
show AddsSpec DeltaCoin
spec] AddsSpec DeltaCoin
spec
  Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$
    String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
      (String
"AddsSpec=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ AddsSpec DeltaCoin -> String
forall a. Show a => a -> String
show AddsSpec DeltaCoin
spec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\ngenerated value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
c)
      (DeltaCoin -> AddsSpec DeltaCoin -> Bool
forall c. Adds c => c -> AddsSpec c -> Bool
runAddsSpec ([String] -> Int -> DeltaCoin
forall x. Adds x => [String] -> Int -> x
fromI [String
"testSoundAddsSpec"] Int
c) AddsSpec DeltaCoin
spec)

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

allSpecTests :: TestTree
allSpecTests :: TestTree
allSpecTests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Spec tests"
    [ String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"reversing OrdCond" Gen Property
condReverse
    , String -> [TestTree] -> TestTree
testGroup
        String
"Size test"
        [ String -> Gen Bool -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test Size sound" Gen Bool
testSoundSize
        , String -> Gen Bool -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test genFromSize is non-negative" Gen Bool
testNonNegSize
        , String -> Gen Bool -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test merging Size" Gen Bool
testMergeSize
        , String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test alternate merge Size" Gen Property
testMergeSize2
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"RelSpec tests"
        [ String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"we generate consistent RelSpecs" Gen Property
testConsistentRel
        , String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test RelSpec sound" Gen Property
testSoundRelSpec
        , String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test mergeRelSpec" Gen Property
testMergeRelSpec
        , String -> IO () -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test More consistent RelSpec" IO ()
reportManyMergeRelSpec
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"RngSpec tests"
        [ String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"we generate consistent RngSpec" Gen Property
testConsistentRng
        , String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test RngSpec sound" Gen Property
testSoundRngSpec
        , String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test mergeRngSpec" Gen Property
testMergeRngSpec
        , String -> IO () -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test More consistent RngSpec" IO ()
reportManyMergeRngSpec
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"MapSpec tests"
        [ String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test MapSpec sound" Gen Property
genMapSpecIsSound
        , String -> IO () -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test More consistent MapSpec" IO ()
reportManyMergeMapSpec
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"SetSpec tests"
        [ String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test SetSpec sound" Gen Property
genSetSpecIsSound
        , String -> IO () -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test More consistent SetSpec" IO ()
reportManyMergeSetSpec
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"ListSpec tests"
        [ String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test ElemSpec sound" Gen Property
testSoundElemSpec
        , String -> IO () -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test consistent ElemSpec" IO ()
reportManyMergeElemSpec
        , String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test ListSpec sound" Gen Property
testSoundListSpec
        , String -> IO () -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test consistent ListSpec" IO ()
reportManyMergeListSpec
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"AddsSpec tests"
        [ String -> IO () -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test Sound MergeAddsSpec" IO ()
reportManyAddsSpec
        , String -> IO () -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test Sound non-negative MergeAddsSpec" IO ()
reportManyNonNegAddsSpec
        , String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test Sound non-negative AddsSpec" Gen Property
testSoundNonNegAddsSpec
        , String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test Sound any AddsSpec" Gen Property
testSoundAddsSpec
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"PairSpec test"
        [ String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test sound PairSpec" Gen Property
testSoundPairSpec
        , String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test ConsistentPair" Gen Property
testConsistentPair
        , String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test merge PairSpec" Gen Property
testMergePairSpec
        , String -> IO () -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"test More consistent PairSpec" IO ()
reportManyMergePairSpec
        ]
    ]

main :: IO ()
main :: IO ()
main = TestTree -> IO ()
defaultMain (TestTree -> IO ()) -> TestTree -> IO ()
forall a b. (a -> b) -> a -> b
$ TestTree
allSpecTests

-- :main --quickcheck-replay=740521

data PairSide = VarOnLeft | VarOnRight
  deriving (Int -> PairSide -> String -> String
[PairSide] -> String -> String
PairSide -> String
(Int -> PairSide -> String -> String)
-> (PairSide -> String)
-> ([PairSide] -> String -> String)
-> Show PairSide
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> PairSide -> String -> String
showsPrec :: Int -> PairSide -> String -> String
$cshow :: PairSide -> String
show :: PairSide -> String
$cshowList :: [PairSide] -> String -> String
showList :: [PairSide] -> String -> String
Show, PairSide -> PairSide -> Bool
(PairSide -> PairSide -> Bool)
-> (PairSide -> PairSide -> Bool) -> Eq PairSide
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PairSide -> PairSide -> Bool
== :: PairSide -> PairSide -> Bool
$c/= :: PairSide -> PairSide -> Bool
/= :: PairSide -> PairSide -> Bool
Eq)

-- | A map 'm1' meets the '(PairSpec _ _ m2)' specification if every
--   (key,value) pair in 'm2' is in 'm1'.
data PairSpec era a b where
  PairSpec :: (Ord a, Eq b) => Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
  PairNever :: [String] -> PairSpec era a b
  PairAny :: PairSpec era a b

-- TODO Add a second map to PairSpec
-- PairSpec :: (Ord a, Eq b) => Rep era a -> Rep era b -> Map a b -> Maybe(Map a b) -> PairSpec era a b
-- This way (PairSpec d r m1 (Just m2))     Implies  m1 <= x <= m2,  where (<=) is the Map.isSubmapOf relation
-- This way (PairSpec d r empty (Just m2))  Implies  x <= m2,
-- This way (PairSpec d r m1 Nothing)       Implies  m1 <= x         Note that Nothing denotes the Map that contains every pair
-- This way we can get rid of the PairSide argument, and make chains like m1 <= x <= m2,

anyPairSpec :: PairSpec era d r -> Bool
anyPairSpec :: forall era d r. PairSpec era d r -> Bool
anyPairSpec PairSpec era d r
PairAny = Bool
True
anyPairSpec (PairSpec Rep era d
_ Rep era r
_ PairSide
_ Map d r
m) = Map d r -> Bool
forall k a. Map k a -> Bool
Map.null Map d r
m
anyPairSpec PairSpec era d r
_ = Bool
False

instance Monoid (PairSpec era a b) where
  mempty :: PairSpec era a b
mempty = PairSpec era a b
forall era a b. PairSpec era a b
PairAny

instance Semigroup (PairSpec era dom rng) where
  <> :: PairSpec era dom rng
-> PairSpec era dom rng -> PairSpec era dom rng
(<>) = PairSpec era dom rng
-> PairSpec era dom rng -> PairSpec era dom rng
forall era a b.
PairSpec era a b -> PairSpec era a b -> PairSpec era a b
mergePairSpec

instance Show (PairSpec era dom rng) where
  show :: PairSpec era dom rng -> String
show = PairSpec era dom rng -> String
forall era dom rng. PairSpec era dom rng -> String
showPairSpec

instance LiftT (PairSpec era dom rng) where
  liftT :: PairSpec era dom rng -> Typed (PairSpec era dom rng)
liftT (PairNever [String]
xs) = [String] -> Typed (PairSpec era dom rng)
forall a. [String] -> Typed a
failT [String]
xs
  liftT PairSpec era dom rng
x = PairSpec era dom rng -> Typed (PairSpec era dom rng)
forall a. a -> Typed a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PairSpec era dom rng
x
  dropT :: Typed (PairSpec era dom rng) -> PairSpec era dom rng
dropT (Typed (Left [String]
s)) = [String] -> PairSpec era dom rng
forall era a b. [String] -> PairSpec era a b
PairNever [String]
s
  dropT (Typed (Right PairSpec era dom rng
x)) = PairSpec era dom rng
x

showPairSpec :: PairSpec era dom rng -> String
showPairSpec :: forall era dom rng. PairSpec era dom rng -> String
showPairSpec (PairNever [String]
_) = String
"PairNever"
showPairSpec PairSpec era dom rng
PairAny = String
"PairAny"
showPairSpec (PairSpec Rep era dom
dom Rep era rng
rng PairSide
side Map dom rng
mp) = [String] -> String
sepsP [String
"PairSpec", Rep era dom -> String
forall a. Show a => a -> String
show Rep era dom
dom, Rep era rng -> String
forall a. Show a => a -> String
show Rep era rng
rng, PairSide -> String
forall a. Show a => a -> String
show PairSide
side, Rep era (Map dom rng) -> Map dom rng -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era dom -> Rep era rng -> Rep era (Map dom rng)
forall a era b.
Ord a =>
Rep era a -> Rep era b -> Rep era (Map a b)
MapR Rep era dom
dom Rep era rng
rng) Map dom rng
mp]

mergePairSpec :: PairSpec era a b -> PairSpec era a b -> PairSpec era a b
mergePairSpec :: forall era a b.
PairSpec era a b -> PairSpec era a b -> PairSpec era a b
mergePairSpec (PairNever [String]
xs) (PairNever [String]
ys) = [String] -> PairSpec era a b
forall era a b. [String] -> PairSpec era a b
PairNever ([String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ys)
mergePairSpec d :: PairSpec era a b
d@(PairNever [String]
_) PairSpec era a b
_ = PairSpec era a b
d
mergePairSpec PairSpec era a b
_ d :: PairSpec era a b
d@(PairNever [String]
_) = PairSpec era a b
d
mergePairSpec PairSpec era a b
PairAny PairSpec era a b
x = PairSpec era a b
x
mergePairSpec PairSpec era a b
x PairSpec era a b
PairAny = PairSpec era a b
x
mergePairSpec (PairSpec Rep era a
d Rep era b
r PairSide
VarOnRight Map a b
m1) (PairSpec Rep era a
_ Rep era b
_ PairSide
VarOnRight Map a b
m2) =
  let accum :: Either [String] (Map a b) -> a -> b -> Either [String] (Map a b)
accum (Right Map a b
zs) a
key b
v =
        case a -> Map a b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
key Map a b
zs of
          Maybe b
Nothing -> Map a b -> Either [String] (Map a b)
forall a b. b -> Either a b
Right (a -> b -> Map a b -> Map a b
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
key b
v Map a b
zs)
          Just b
u ->
            if b
u b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
v
              then Map a b -> Either [String] (Map a b)
forall a b. b -> Either a b
Right (Map a b
zs)
              else
                [String] -> Either [String] (Map a b)
forall a b. a -> Either a b
Left
                  [ String
"The PairSpecs with VarOnRight"
                  , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Map a b) -> Map a b -> String
forall e t. Rep e t -> t -> String
format (Rep era a -> Rep era b -> Rep era (Map a b)
forall a era b.
Ord a =>
Rep era a -> Rep era b -> Rep era (Map a b)
MapR Rep era a
d Rep era b
r) Map a b
m1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and"
                  , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Map a b) -> Map a b -> String
forall e t. Rep e t -> t -> String
format (Rep era a -> Rep era b -> Rep era (Map a b)
forall a era b.
Ord a =>
Rep era a -> Rep era b -> Rep era (Map a b)
MapR Rep era a
d Rep era b
r) Map a b
m2
                  , String
" are inconsistent."
                  , String
"The key "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era a -> a -> String
forall e t. Rep e t -> t -> String
synopsis Rep era a
d a
key
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has multiple values: "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era b -> b -> String
forall e t. Rep e t -> t -> String
synopsis Rep era b
r b
v
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era b -> b -> String
forall e t. Rep e t -> t -> String
synopsis Rep era b
r b
u
                  ]
      accum (Left [String]
xs) a
_ b
_ = [String] -> Either [String] (Map a b)
forall a b. a -> Either a b
Left [String]
xs
   in case (Either [String] (Map a b) -> a -> b -> Either [String] (Map a b))
-> Either [String] (Map a b)
-> Map a b
-> Either [String] (Map a b)
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Either [String] (Map a b) -> a -> b -> Either [String] (Map a b)
accum (Map a b -> Either [String] (Map a b)
forall a b. b -> Either a b
Right Map a b
m1) Map a b
m2 of
        Left [String]
xs -> [String] -> PairSpec era a b
forall era a b. [String] -> PairSpec era a b
PairNever [String]
xs
        Right Map a b
m3 -> Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
forall a b era.
(Ord a, Eq b) =>
Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
PairSpec Rep era a
d Rep era b
r PairSide
VarOnRight Map a b
m3
mergePairSpec (PairSpec Rep era a
d Rep era b
r PairSide
VarOnLeft Map a b
m1) (PairSpec Rep era a
_ Rep era b
_ PairSide
VarOnLeft Map a b
m2) =
  let accum :: Either [String] (Map a b) -> a -> b -> Either [String] (Map a b)
accum (Right Map a b
zs) a
key b
v =
        -- Testing that the instersection of the domains, map to the same range.
        case a -> Map a b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
key Map a b
m1 of -- If that is True, we use this intersection as the new map
          Maybe b
Nothing -> Map a b -> Either [String] (Map a b)
forall a b. b -> Either a b
Right Map a b
zs
          Just b
u ->
            if b
u b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
v
              then Map a b -> Either [String] (Map a b)
forall a b. b -> Either a b
Right (a -> b -> Map a b -> Map a b
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
key b
u Map a b
zs)
              else
                [String] -> Either [String] (Map a b)
forall a b. a -> Either a b
Left
                  [ String
"The PairSpecs with VarOnLeft"
                  , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Map a b) -> Map a b -> String
forall e t. Rep e t -> t -> String
format (Rep era a -> Rep era b -> Rep era (Map a b)
forall a era b.
Ord a =>
Rep era a -> Rep era b -> Rep era (Map a b)
MapR Rep era a
d Rep era b
r) Map a b
m1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and"
                  , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Map a b) -> Map a b -> String
forall e t. Rep e t -> t -> String
format (Rep era a -> Rep era b -> Rep era (Map a b)
forall a era b.
Ord a =>
Rep era a -> Rep era b -> Rep era (Map a b)
MapR Rep era a
d Rep era b
r) Map a b
m2
                  , String
"are inconsistent."
                  , String
"The key "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era a -> a -> String
forall e t. Rep e t -> t -> String
synopsis Rep era a
d a
key
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has multiple values: "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era b -> b -> String
forall e t. Rep e t -> t -> String
synopsis Rep era b
r b
v
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rep era (Map a b) -> Map a b -> String
forall e t. Rep e t -> t -> String
synopsis (Rep era a -> Rep era b -> Rep era (Map a b)
forall a era b.
Ord a =>
Rep era a -> Rep era b -> Rep era (Map a b)
MapR Rep era a
d Rep era b
r) Map a b
m1
                  ]
      accum (Left [String]
xs) a
_ b
_ = [String] -> Either [String] (Map a b)
forall a b. a -> Either a b
Left [String]
xs
   in case (Either [String] (Map a b) -> a -> b -> Either [String] (Map a b))
-> Either [String] (Map a b)
-> Map a b
-> Either [String] (Map a b)
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Either [String] (Map a b) -> a -> b -> Either [String] (Map a b)
accum (Map a b -> Either [String] (Map a b)
forall a b. b -> Either a b
Right Map a b
forall k a. Map k a
Map.empty) Map a b
m2 of
        Left [String]
xs -> [String] -> PairSpec era a b
forall era a b. [String] -> PairSpec era a b
PairNever [String]
xs
        Right Map a b
m3 -> Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
forall a b era.
(Ord a, Eq b) =>
Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
PairSpec Rep era a
d Rep era b
r PairSide
VarOnLeft Map a b
m3
mergePairSpec PairSpec era a b
a PairSpec era a b
b =
  [String] -> PairSpec era a b
forall era a b. [String] -> PairSpec era a b
PairNever
    [ String
"The PairSpecs"
    , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec era a b -> String
forall a. Show a => a -> String
show PairSpec era a b
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and"
    , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec era a b -> String
forall a. Show a => a -> String
show PairSpec era a b
b
    , String
" are inconsistent."
    , String
"They have the var on different sides."
    ]

sizeForPairSpec :: PairSpec era dom rng -> Size
sizeForPairSpec :: forall era dom rng. PairSpec era dom rng -> Size
sizeForPairSpec PairSpec era dom rng
PairAny = Size
SzAny
sizeForPairSpec (PairNever [String]
msgs) = [String] -> Size
SzNever ([String]
msgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"From sizeForPairSpec."])
sizeForPairSpec (PairSpec Rep era dom
_ Rep era rng
_ PairSide
VarOnRight Map dom rng
m) = Int -> Size
SzLeast (Map dom rng -> Int
forall k a. Map k a -> Int
Map.size Map dom rng
m)
sizeForPairSpec (PairSpec Rep era dom
_ Rep era rng
_ PairSide
VarOnLeft Map dom rng
m) = Int -> Size
SzMost (Map dom rng -> Int
forall k a. Map k a -> Int
Map.size Map dom rng
m)

runPairSpec :: (Ord dom, Eq rng) => Map dom rng -> PairSpec era dom rng -> Bool
runPairSpec :: forall dom rng era.
(Ord dom, Eq rng) =>
Map dom rng -> PairSpec era dom rng -> Bool
runPairSpec Map dom rng
_ PairSpec era dom rng
PairAny = Bool
True
runPairSpec Map dom rng
_ (PairNever [String]
xs) = String -> [String] -> Bool
forall a. HasCallStack => String -> [String] -> a
errorMess String
"PairNever in call to runPairSpec" [String]
xs
runPairSpec Map dom rng
m1 (PairSpec Rep era dom
_ Rep era rng
_ PairSide
VarOnRight Map dom rng
m2) = Map dom rng -> Map dom rng -> Bool
forall k a. (Ord k, Eq a) => Map k a -> Map k a -> Bool
Map.isSubmapOf Map dom rng
m2 Map dom rng
m1
-- all pairs in m2 are in m1
-- So when we say (SubMap expr var) we store the pairs from expr in 'm2'
-- and insist that when solving 'var' it contains the pairs from 'm2' and possibly more pairs
runPairSpec Map dom rng
m1 (PairSpec Rep era dom
_ Rep era rng
_ PairSide
VarOnLeft Map dom rng
m2) = Map dom rng -> Map dom rng -> Bool
forall k a. (Ord k, Eq a) => Map k a -> Map k a -> Bool
Map.isSubmapOf Map dom rng
m1 Map dom rng
m2

genPairSpec ::
  forall era dom rng. (Ord dom, Eq rng) => Rep era dom -> Rep era rng -> Gen (PairSpec era dom rng)
genPairSpec :: forall era dom rng.
(Ord dom, Eq rng) =>
Rep era dom -> Rep era rng -> Gen (PairSpec era dom rng)
genPairSpec Rep era dom
domr Rep era rng
rngr =
  [(Int, Gen (PairSpec era dom rng))] -> Gen (PairSpec era dom rng)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, PairSpec era dom rng -> Gen (PairSpec era dom rng)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PairSpec era dom rng
forall era a b. PairSpec era a b
PairAny)
    , (Int
1, PairSpec era dom rng -> Gen (PairSpec era dom rng)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rep era dom
-> Rep era rng -> PairSide -> Map dom rng -> PairSpec era dom rng
forall a b era.
(Ord a, Eq b) =>
Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
PairSpec Rep era dom
domr Rep era rng
rngr PairSide
VarOnRight Map dom rng
forall k a. Map k a
Map.empty))
    , (Int
1, PairSpec era dom rng -> Gen (PairSpec era dom rng)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rep era dom
-> Rep era rng -> PairSide -> Map dom rng -> PairSpec era dom rng
forall a b era.
(Ord a, Eq b) =>
Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
PairSpec Rep era dom
domr Rep era rng
rngr PairSide
VarOnLeft Map dom rng
forall k a. Map k a
Map.empty))
    , (Int
4, Rep era dom
-> Rep era rng -> PairSide -> Map dom rng -> PairSpec era dom rng
forall a b era.
(Ord a, Eq b) =>
Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
PairSpec Rep era dom
domr Rep era rng
rngr PairSide
VarOnRight (Map dom rng -> PairSpec era dom rng)
-> Gen (Map dom rng) -> Gen (PairSpec era dom rng)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (dom -> rng -> Map dom rng
forall k a. k -> a -> Map k a
Map.singleton (dom -> rng -> Map dom rng) -> Gen dom -> Gen (rng -> Map dom rng)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rep era dom -> Gen dom
forall era b. Rep era b -> Gen b
genRep Rep era dom
domr Gen (rng -> Map dom rng) -> Gen rng -> Gen (Map dom rng)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rep era rng -> Gen rng
forall era b. Rep era b -> Gen b
genRep Rep era rng
rngr))
    , (Int
4, Rep era dom
-> Rep era rng -> PairSide -> Map dom rng -> PairSpec era dom rng
forall a b era.
(Ord a, Eq b) =>
Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
PairSpec Rep era dom
domr Rep era rng
rngr PairSide
VarOnLeft (Map dom rng -> PairSpec era dom rng)
-> Gen (Map dom rng) -> Gen (PairSpec era dom rng)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (dom -> rng -> Map dom rng
forall k a. k -> a -> Map k a
Map.singleton (dom -> rng -> Map dom rng) -> Gen dom -> Gen (rng -> Map dom rng)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rep era dom -> Gen dom
forall era b. Rep era b -> Gen b
genRep Rep era dom
domr Gen (rng -> Map dom rng) -> Gen rng -> Gen (Map dom rng)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rep era rng -> Gen rng
forall era b. Rep era b -> Gen b
genRep Rep era rng
rngr))
    ,
      ( Int
4
      , do
          dom
d1 <- Rep era dom -> Gen dom
forall era b. Rep era b -> Gen b
genRep Rep era dom
domr
          dom
d2 <- Rep era dom -> Gen dom
forall era b. Rep era b -> Gen b
genRep Rep era dom
domr
          rng
r1 <- Rep era rng -> Gen rng
forall era b. Rep era b -> Gen b
genRep Rep era rng
rngr
          rng
r2 <- Rep era rng -> Gen rng
forall era b. Rep era b -> Gen b
genRep Rep era rng
rngr
          [PairSpec era dom rng] -> Gen (PairSpec era dom rng)
forall a. HasCallStack => [a] -> Gen a
elements
            [ Rep era dom
-> Rep era rng -> PairSide -> Map dom rng -> PairSpec era dom rng
forall a b era.
(Ord a, Eq b) =>
Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
PairSpec Rep era dom
domr Rep era rng
rngr PairSide
VarOnRight ([(dom, rng)] -> Map dom rng
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(dom
d1, rng
r1), (dom
d2, rng
r2)])
            , Rep era dom
-> Rep era rng -> PairSide -> Map dom rng -> PairSpec era dom rng
forall a b era.
(Ord a, Eq b) =>
Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
PairSpec Rep era dom
domr Rep era rng
rngr PairSide
VarOnRight ([(dom, rng)] -> Map dom rng
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(dom
d1, rng
r1), (dom
d2, rng
r2)])
            ]
      )
    ]

fixSide :: PairSide -> PairSpec era a b -> PairSpec era a b
fixSide :: forall era a b. PairSide -> PairSpec era a b -> PairSpec era a b
fixSide PairSide
_ (PairNever [String]
xs) = [String] -> PairSpec era a b
forall era a b. [String] -> PairSpec era a b
PairNever [String]
xs
fixSide PairSide
_ PairSpec era a b
PairAny = PairSpec era a b
forall era a b. PairSpec era a b
PairAny
fixSide PairSide
side (PairSpec Rep era a
d Rep era b
r PairSide
_ Map a b
m) = Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
forall a b era.
(Ord a, Eq b) =>
Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
PairSpec Rep era a
d Rep era b
r PairSide
side Map a b
m

genConsistentPairSpec ::
  (Ord dom, Eq rng) =>
  Rep era dom ->
  Rep era rng ->
  PairSpec era dom rng ->
  Gen (PairSpec era dom rng)
genConsistentPairSpec :: forall dom rng era.
(Ord dom, Eq rng) =>
Rep era dom
-> Rep era rng
-> PairSpec era dom rng
-> Gen (PairSpec era dom rng)
genConsistentPairSpec Rep era dom
_domr Rep era rng
_rngr (PairNever [String]
xs) = String -> [String] -> Gen (PairSpec era dom rng)
forall a. HasCallStack => String -> [String] -> a
errorMess String
"PairNever in genConsistentPairSpec" [String]
xs
genConsistentPairSpec Rep era dom
domr Rep era rng
rngr PairSpec era dom rng
PairAny = Rep era dom -> Rep era rng -> Gen (PairSpec era dom rng)
forall era dom rng.
(Ord dom, Eq rng) =>
Rep era dom -> Rep era rng -> Gen (PairSpec era dom rng)
genPairSpec Rep era dom
domr Rep era rng
rngr
genConsistentPairSpec Rep era dom
domr Rep era rng
rngr (PairSpec Rep era dom
_d Rep era rng
_r PairSide
VarOnRight Map dom rng
m) | Map dom rng -> Bool
forall k a. Map k a -> Bool
Map.null Map dom rng
m = PairSide -> PairSpec era dom rng -> PairSpec era dom rng
forall era a b. PairSide -> PairSpec era a b -> PairSpec era a b
fixSide PairSide
VarOnRight (PairSpec era dom rng -> PairSpec era dom rng)
-> Gen (PairSpec era dom rng) -> Gen (PairSpec era dom rng)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rep era dom -> Rep era rng -> Gen (PairSpec era dom rng)
forall era dom rng.
(Ord dom, Eq rng) =>
Rep era dom -> Rep era rng -> Gen (PairSpec era dom rng)
genPairSpec Rep era dom
domr Rep era rng
rngr
genConsistentPairSpec Rep era dom
domr Rep era rng
rngr (PairSpec Rep era dom
_d Rep era rng
_r PairSide
VarOnLeft Map dom rng
m) | Map dom rng -> Bool
forall k a. Map k a -> Bool
Map.null Map dom rng
m = PairSide -> PairSpec era dom rng -> PairSpec era dom rng
forall era a b. PairSide -> PairSpec era a b -> PairSpec era a b
fixSide PairSide
VarOnLeft (PairSpec era dom rng -> PairSpec era dom rng)
-> Gen (PairSpec era dom rng) -> Gen (PairSpec era dom rng)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rep era dom -> Rep era rng -> Gen (PairSpec era dom rng)
forall era dom rng.
(Ord dom, Eq rng) =>
Rep era dom -> Rep era rng -> Gen (PairSpec era dom rng)
genPairSpec Rep era dom
domr Rep era rng
rngr
genConsistentPairSpec Rep era dom
_ Rep era rng
_ (PairSpec Rep era dom
d Rep era rng
r PairSide
VarOnRight Map dom rng
m) =
  [(Int, Gen (PairSpec era dom rng))] -> Gen (PairSpec era dom rng)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, PairSpec era dom rng -> Gen (PairSpec era dom rng)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PairSpec era dom rng
forall era a b. PairSpec era a b
PairAny)
    , (Int
1, do Int
n <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Map dom rng -> Int
forall k a. Map k a -> Int
Map.size Map dom rng
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1); PairSpec era dom rng -> Gen (PairSpec era dom rng)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rep era dom
-> Rep era rng -> PairSide -> Map dom rng -> PairSpec era dom rng
forall a b era.
(Ord a, Eq b) =>
Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
PairSpec Rep era dom
d Rep era rng
r PairSide
VarOnRight (Int -> Map dom rng -> Map dom rng
forall k a. Int -> Map k a -> Map k a
Map.deleteAt Int
n Map dom rng
m)))
    ,
      ( Int
1
      , do
          dom
d1 <- [String] -> Gen dom -> (dom -> Bool) -> Gen dom
forall a. [String] -> Gen a -> (a -> Bool) -> Gen a
suchThatErr [String
"genConsistentPairSpec"] (Rep era dom -> Gen dom
forall era b. Rep era b -> Gen b
genRep Rep era dom
d) (Bool -> Bool
not (Bool -> Bool) -> (dom -> Bool) -> dom -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (dom -> Map dom rng -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map dom rng
m))
          rng
r1 <- Rep era rng -> Gen rng
forall era b. Rep era b -> Gen b
genRep Rep era rng
r
          PairSpec era dom rng -> Gen (PairSpec era dom rng)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rep era dom
-> Rep era rng -> PairSide -> Map dom rng -> PairSpec era dom rng
forall a b era.
(Ord a, Eq b) =>
Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
PairSpec Rep era dom
d Rep era rng
r PairSide
VarOnRight (dom -> rng -> Map dom rng -> Map dom rng
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert dom
d1 rng
r1 Map dom rng
m))
      )
    ]
genConsistentPairSpec Rep era dom
_ Rep era rng
_ (PairSpec Rep era dom
d Rep era rng
r PairSide
VarOnLeft Map dom rng
m) =
  [(Int, Gen (PairSpec era dom rng))] -> Gen (PairSpec era dom rng)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, PairSpec era dom rng -> Gen (PairSpec era dom rng)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PairSpec era dom rng
forall era a b. PairSpec era a b
PairAny)
    , (Int
1, do Int
n <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Map dom rng -> Int
forall k a. Map k a -> Int
Map.size Map dom rng
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1); PairSpec era dom rng -> Gen (PairSpec era dom rng)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rep era dom
-> Rep era rng -> PairSide -> Map dom rng -> PairSpec era dom rng
forall a b era.
(Ord a, Eq b) =>
Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
PairSpec Rep era dom
d Rep era rng
r PairSide
VarOnLeft (Int -> Map dom rng -> Map dom rng
forall k a. Int -> Map k a -> Map k a
Map.deleteAt Int
n Map dom rng
m)))
    ,
      ( Int
1
      , do
          dom
d1 <- [String] -> Gen dom -> (dom -> Bool) -> Gen dom
forall a. [String] -> Gen a -> (a -> Bool) -> Gen a
suchThatErr [String
"genConsistentPairSpec"] (Rep era dom -> Gen dom
forall era b. Rep era b -> Gen b
genRep Rep era dom
d) (Bool -> Bool
not (Bool -> Bool) -> (dom -> Bool) -> dom -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (dom -> Map dom rng -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map dom rng
m))
          rng
r1 <- Rep era rng -> Gen rng
forall era b. Rep era b -> Gen b
genRep Rep era rng
r
          PairSpec era dom rng -> Gen (PairSpec era dom rng)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rep era dom
-> Rep era rng -> PairSide -> Map dom rng -> PairSpec era dom rng
forall a b era.
(Ord a, Eq b) =>
Rep era a -> Rep era b -> PairSide -> Map a b -> PairSpec era a b
PairSpec Rep era dom
d Rep era rng
r PairSide
VarOnLeft (dom -> rng -> Map dom rng -> Map dom rng
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert dom
d1 rng
r1 Map dom rng
m))
      )
    ]

genFromPairSpec ::
  forall era dom rng. Ord dom => [String] -> PairSpec era dom rng -> Gen (Map dom rng)
genFromPairSpec :: forall era dom rng.
Ord dom =>
[String] -> PairSpec era dom rng -> Gen (Map dom rng)
genFromPairSpec [String]
msgs (PairNever [String]
xs) = String -> [String] -> Gen (Map dom rng)
forall a. HasCallStack => String -> [String] -> a
errorMess String
"genFromPairSpec failed due to PairNever" ([String]
msgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
xs)
genFromPairSpec [String]
_msgs PairSpec era dom rng
PairAny = Map dom rng -> Gen (Map dom rng)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map dom rng -> Gen (Map dom rng))
-> Map dom rng -> Gen (Map dom rng)
forall a b. (a -> b) -> a -> b
$ Map dom rng
forall k a. Map k a
Map.empty
genFromPairSpec [String]
msgs p :: PairSpec era dom rng
p@(PairSpec Rep era dom
domr Rep era rng
rngr PairSide
VarOnRight Map dom rng
mp) = do
  Int
n <- (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Map dom rng -> Int
forall k a. Map k a -> Int
Map.size Map dom rng
mp)) (Int -> Int) -> Gen Int -> Gen Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
10)
  [String]
-> Map dom rng -> Int -> Gen dom -> Gen rng -> Gen (Map dom rng)
forall a b.
Ord a =>
[String] -> Map a b -> Int -> Gen a -> Gen b -> Gen (Map a b)
mapFromSubset ([String]
msgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"genFromPairSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec era dom rng -> String
forall a. Show a => a -> String
show PairSpec era dom rng
p]) Map dom rng
mp Int
n (Rep era dom -> Gen dom
forall era b. Rep era b -> Gen b
genRep Rep era dom
domr) (Rep era rng -> Gen rng
forall era b. Rep era b -> Gen b
genRep Rep era rng
rngr)
genFromPairSpec [String]
msgs (PairSpec Rep era dom
_domr Rep era rng
_rngr PairSide
VarOnLeft Map dom rng
mp) = do
  Set dom
domset <- [String] -> Set dom -> Gen (Set dom)
forall a. Ord a => [String] -> Set a -> Gen (Set a)
subsetFromSet ([String]
msgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"from genFromPairSpec VarOnLeft"]) (Map dom rng -> Set dom
forall k a. Map k a -> Set k
Map.keysSet Map dom rng
mp)
  Map dom rng -> Gen (Map dom rng)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map dom rng -> Set dom -> Map dom rng
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map dom rng
mp Set dom
domset)

-- ============================================
-- tests for Pair Spec

testConsistentPair :: Gen Property
testConsistentPair :: Gen Property
testConsistentPair = do
  PairSpec BabbageEra Int Int
s1 <- forall era dom rng.
(Ord dom, Eq rng) =>
Rep era dom -> Rep era rng -> Gen (PairSpec era dom rng)
genPairSpec @BabbageEra Rep BabbageEra Int
forall era. Rep era Int
IntR Rep BabbageEra Int
forall era. Rep era Int
IntR
  PairSpec BabbageEra Int Int
s2 <- Rep BabbageEra Int
-> Rep BabbageEra Int
-> PairSpec BabbageEra Int Int
-> Gen (PairSpec BabbageEra Int Int)
forall dom rng era.
(Ord dom, Eq rng) =>
Rep era dom
-> Rep era rng
-> PairSpec era dom rng
-> Gen (PairSpec era dom rng)
genConsistentPairSpec Rep BabbageEra Int
forall era. Rep era Int
IntR Rep BabbageEra Int
forall era. Rep era Int
IntR PairSpec BabbageEra Int Int
s1
  case PairSpec BabbageEra Int Int
s1 PairSpec BabbageEra Int Int
-> PairSpec BabbageEra Int Int -> PairSpec BabbageEra Int Int
forall a. Semigroup a => a -> a -> a
<> PairSpec BabbageEra Int Int
s2 of
    PairNever [String]
ms ->
      Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([String] -> String
unlines ([String
"genConsistentPair fails", PairSpec BabbageEra Int Int -> String
forall a. Show a => a -> String
show PairSpec BabbageEra Int Int
s1, PairSpec BabbageEra Int Int -> String
forall a. Show a => a -> String
show PairSpec BabbageEra Int Int
s2] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ms)) Bool
False
    PairSpec BabbageEra Int Int
_ -> Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True

testSoundPairSpec :: Gen Property
testSoundPairSpec :: Gen Property
testSoundPairSpec = do
  PairSpec BabbageEra Int Word64
s1 <- Rep BabbageEra Int
-> Rep BabbageEra Word64 -> Gen (PairSpec BabbageEra Int Word64)
forall era dom rng.
(Ord dom, Eq rng) =>
Rep era dom -> Rep era rng -> Gen (PairSpec era dom rng)
genPairSpec Rep BabbageEra Int
forall era. Rep era Int
IntR Rep BabbageEra Word64
forall era. Rep era Word64
Word64R
  Map Int Word64
ans <- forall era dom rng.
Ord dom =>
[String] -> PairSpec era dom rng -> Gen (Map dom rng)
genFromPairSpec @BabbageEra [String
"testSoundPairSpec"] PairSpec BabbageEra Int Word64
s1
  Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"spec=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec BabbageEra Int Word64 -> String
forall a. Show a => a -> String
show PairSpec BabbageEra Int Word64
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nans=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Map Int Word64 -> String
forall a. Show a => a -> String
show Map Int Word64
ans) (Map Int Word64 -> PairSpec BabbageEra Int Word64 -> Bool
forall dom rng era.
(Ord dom, Eq rng) =>
Map dom rng -> PairSpec era dom rng -> Bool
runPairSpec Map Int Word64
ans PairSpec BabbageEra Int Word64
s1)

testMergePairSpec :: Gen Property
testMergePairSpec :: Gen Property
testMergePairSpec = do
  -- let msg = ["testMergePairSpec"]
  PairSpec BabbageEra Word64 Int
s1 <- Rep BabbageEra Word64
-> Rep BabbageEra Int -> Gen (PairSpec BabbageEra Word64 Int)
forall era dom rng.
(Ord dom, Eq rng) =>
Rep era dom -> Rep era rng -> Gen (PairSpec era dom rng)
genPairSpec Rep BabbageEra Word64
forall era. Rep era Word64
Word64R Rep BabbageEra Int
forall era. Rep era Int
IntR
  PairSpec BabbageEra Word64 Int
s2 <- Rep BabbageEra Word64
-> Rep BabbageEra Int
-> PairSpec BabbageEra Word64 Int
-> Gen (PairSpec BabbageEra Word64 Int)
forall dom rng era.
(Ord dom, Eq rng) =>
Rep era dom
-> Rep era rng
-> PairSpec era dom rng
-> Gen (PairSpec era dom rng)
genConsistentPairSpec Rep BabbageEra Word64
forall era. Rep era Word64
Word64R Rep BabbageEra Int
forall era. Rep era Int
IntR PairSpec BabbageEra Word64 Int
s1
  case PairSpec BabbageEra Word64 Int
s1 PairSpec BabbageEra Word64 Int
-> PairSpec BabbageEra Word64 Int -> PairSpec BabbageEra Word64 Int
forall a. Semigroup a => a -> a -> a
<> PairSpec BabbageEra Word64 Int
s2 of
    PairNever [String]
_ -> Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True) -- This test is an implication (consistent (s1 <> s2) => ...)
    PairSpec BabbageEra Word64 Int
s4 -> do
      Map Word64 Int
ans <- forall era dom rng.
Ord dom =>
[String] -> PairSpec era dom rng -> Gen (Map dom rng)
genFromPairSpec @BabbageEra [String
"testMergePairSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec BabbageEra Word64 Int -> String
forall a. Show a => a -> String
show PairSpec BabbageEra Word64 Int
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec BabbageEra Word64 Int -> String
forall a. Show a => a -> String
show PairSpec BabbageEra Word64 Int
s2] PairSpec BabbageEra Word64 Int
s4
      Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$
        String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
          ( String
"s1="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec BabbageEra Word64 Int -> String
forall a. Show a => a -> String
show PairSpec BabbageEra Word64 Int
s1
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\ns2="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec BabbageEra Word64 Int -> String
forall a. Show a => a -> String
show PairSpec BabbageEra Word64 Int
s2
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\ns1<>s2="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec BabbageEra Word64 Int -> String
forall a. Show a => a -> String
show PairSpec BabbageEra Word64 Int
s4
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nans="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Map Word64 Int -> String
forall a. Show a => a -> String
show Map Word64 Int
ans
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nrun s1="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (Map Word64 Int -> PairSpec BabbageEra Word64 Int -> Bool
forall dom rng era.
(Ord dom, Eq rng) =>
Map dom rng -> PairSpec era dom rng -> Bool
runPairSpec Map Word64 Int
ans PairSpec BabbageEra Word64 Int
s1)
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nrun s2="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (Map Word64 Int -> PairSpec BabbageEra Word64 Int -> Bool
forall dom rng era.
(Ord dom, Eq rng) =>
Map dom rng -> PairSpec era dom rng -> Bool
runPairSpec Map Word64 Int
ans PairSpec BabbageEra Word64 Int
s2)
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nrun s4="
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (Map Word64 Int -> PairSpec BabbageEra Word64 Int -> Bool
forall dom rng era.
(Ord dom, Eq rng) =>
Map dom rng -> PairSpec era dom rng -> Bool
runPairSpec Map Word64 Int
ans PairSpec BabbageEra Word64 Int
s4)
          )
          (Map Word64 Int -> PairSpec BabbageEra Word64 Int -> Bool
forall dom rng era.
(Ord dom, Eq rng) =>
Map dom rng -> PairSpec era dom rng -> Bool
runPairSpec Map Word64 Int
ans PairSpec BabbageEra Word64 Int
s4 Bool -> Bool -> Bool
&& Map Word64 Int -> PairSpec BabbageEra Word64 Int -> Bool
forall dom rng era.
(Ord dom, Eq rng) =>
Map dom rng -> PairSpec era dom rng -> Bool
runPairSpec Map Word64 Int
ans PairSpec BabbageEra Word64 Int
s2 Bool -> Bool -> Bool
&& Map Word64 Int -> PairSpec BabbageEra Word64 Int -> Bool
forall dom rng era.
(Ord dom, Eq rng) =>
Map dom rng -> PairSpec era dom rng -> Bool
runPairSpec Map Word64 Int
ans PairSpec BabbageEra Word64 Int
s1)

manyMergePairSpec :: Gen (Int, [String])
manyMergePairSpec :: Gen (Int, [String])
manyMergePairSpec = do
  [PairSpec BabbageEra Word64 Int]
xs <- Int
-> Gen (PairSpec BabbageEra Word64 Int)
-> Gen [PairSpec BabbageEra Word64 Int]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
60 (Rep BabbageEra Word64
-> Rep BabbageEra Int -> Gen (PairSpec BabbageEra Word64 Int)
forall era dom rng.
(Ord dom, Eq rng) =>
Rep era dom -> Rep era rng -> Gen (PairSpec era dom rng)
genPairSpec Rep BabbageEra Word64
forall era. Rep era Word64
Word64R Rep BabbageEra Int
forall era. Rep era Int
IntR)
  [PairSpec BabbageEra Word64 Int]
ys <- Int
-> Gen (PairSpec BabbageEra Word64 Int)
-> Gen [PairSpec BabbageEra Word64 Int]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
60 (Rep BabbageEra Word64
-> Rep BabbageEra Int -> Gen (PairSpec BabbageEra Word64 Int)
forall era dom rng.
(Ord dom, Eq rng) =>
Rep era dom -> Rep era rng -> Gen (PairSpec era dom rng)
genPairSpec Rep BabbageEra Word64
forall era. Rep era Word64
Word64R Rep BabbageEra Int
forall era. Rep era Int
IntR)
  let ok :: PairSpec era a b -> Bool
ok PairSpec era a b
PairAny = Bool
False
      ok PairSpec era a b
_ = Bool
True
      check :: (PairSpec era dom rng, PairSpec era dom rng,
 PairSpec BabbageEra dom rng)
-> Gen
     (PairSpec era dom rng, Bool, PairSpec era dom rng, Bool,
      Map dom rng, Bool, PairSpec BabbageEra dom rng)
check (PairSpec era dom rng
x, PairSpec era dom rng
y, PairSpec BabbageEra dom rng
m) = do
        let size :: Size
size = PairSpec BabbageEra dom rng -> Size
forall era dom rng. PairSpec era dom rng -> Size
sizeForPairSpec PairSpec BabbageEra dom rng
m
        Int
i <- Size -> Gen Int
genFromSize Size
size
        let wordsX :: [String]
wordsX =
              [ String
"s1<>s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (PairSpec BabbageEra dom rng -> Size
forall era dom rng. PairSpec era dom rng -> Size
sizeForPairSpec PairSpec BabbageEra dom rng
m)
              , String
"s1<>s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec BabbageEra dom rng -> String
forall a. Show a => a -> String
show PairSpec BabbageEra dom rng
m
              , String
"s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (PairSpec era dom rng -> Size
forall era dom rng. PairSpec era dom rng -> Size
sizeForPairSpec PairSpec era dom rng
x)
              , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec era dom rng -> String
forall a. Show a => a -> String
show PairSpec era dom rng
x
              , String
"s1 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (PairSpec era dom rng -> Size
forall era dom rng. PairSpec era dom rng -> Size
sizeForPairSpec PairSpec era dom rng
y)
              , String
"s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec era dom rng -> String
forall a. Show a => a -> String
show PairSpec era dom rng
y
              , String
"GenFromPairSpec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
              ]
        Map dom rng
z <- forall era dom rng.
Ord dom =>
[String] -> PairSpec era dom rng -> Gen (Map dom rng)
genFromPairSpec @BabbageEra [String]
wordsX PairSpec BabbageEra dom rng
m
        (PairSpec era dom rng, Bool, PairSpec era dom rng, Bool,
 Map dom rng, Bool, PairSpec BabbageEra dom rng)
-> Gen
     (PairSpec era dom rng, Bool, PairSpec era dom rng, Bool,
      Map dom rng, Bool, PairSpec BabbageEra dom rng)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PairSpec era dom rng
x, Map dom rng -> PairSpec era dom rng -> Bool
forall dom rng era.
(Ord dom, Eq rng) =>
Map dom rng -> PairSpec era dom rng -> Bool
runPairSpec Map dom rng
z PairSpec era dom rng
x, PairSpec era dom rng
y, Map dom rng -> PairSpec era dom rng -> Bool
forall dom rng era.
(Ord dom, Eq rng) =>
Map dom rng -> PairSpec era dom rng -> Bool
runPairSpec Map dom rng
z PairSpec era dom rng
y, Map dom rng
z, Map dom rng -> PairSpec BabbageEra dom rng -> Bool
forall dom rng era.
(Ord dom, Eq rng) =>
Map dom rng -> PairSpec era dom rng -> Bool
runPairSpec Map dom rng
z PairSpec BabbageEra dom rng
m, PairSpec BabbageEra dom rng
m)
      showAns :: (PairSpec era dom rng, a, PairSpec era dom rng, a, a, a,
 PairSpec era dom rng)
-> String
showAns (PairSpec era dom rng
s1, a
run1, PairSpec era dom rng
s2, a
run2, a
v, a
run3, PairSpec era dom rng
s3) =
        [String] -> String
unlines
          [ String
"\ns1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec era dom rng -> String
forall a. Show a => a -> String
show PairSpec era dom rng
s1
          , String
"s1 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (PairSpec era dom rng -> Size
forall era dom rng. PairSpec era dom rng -> Size
sizeForPairSpec PairSpec era dom rng
s1)
          , String
"s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec era dom rng -> String
forall a. Show a => a -> String
show PairSpec era dom rng
s2
          , String
"s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (PairSpec era dom rng -> Size
forall era dom rng. PairSpec era dom rng -> Size
sizeForPairSpec PairSpec era dom rng
s2)
          , String
"s1 <> s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PairSpec era dom rng -> String
forall a. Show a => a -> String
show PairSpec era dom rng
s3
          , String
"s1<>s2 Size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Size -> String
forall a. Show a => a -> String
show (PairSpec era dom rng -> Size
forall era dom rng. PairSpec era dom rng -> Size
sizeForPairSpec PairSpec era dom rng
s3)
          , String
"v = genFromPairSpec (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v
          , String
"runPairSpec v s1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run1
          , String
"runPairSpec v s2 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run2
          , String
"runPairSpec v (s1 <> s2) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
run3
          ]
      pr :: (PairSpec era dom rng, Bool, PairSpec era dom rng, Bool, a, Bool,
 PairSpec era dom rng)
-> Maybe String
pr x :: (PairSpec era dom rng, Bool, PairSpec era dom rng, Bool, a, Bool,
 PairSpec era dom rng)
x@(PairSpec era dom rng
_, Bool
a, PairSpec era dom rng
_, Bool
b, a
_, Bool
c, PairSpec era dom rng
_) = if Bool -> Bool
not (Bool
a Bool -> Bool -> Bool
&& Bool
b Bool -> Bool -> Bool
&& Bool
c) then String -> Maybe String
forall a. a -> Maybe a
Just ((PairSpec era dom rng, Bool, PairSpec era dom rng, Bool, a, Bool,
 PairSpec era dom rng)
-> String
forall {a} {a} {a} {a} {era} {dom} {rng} {era} {dom} {rng} {era}
       {dom} {rng}.
(Show a, Show a, Show a, Show a) =>
(PairSpec era dom rng, a, PairSpec era dom rng, a, a, a,
 PairSpec era dom rng)
-> String
showAns (PairSpec era dom rng, Bool, PairSpec era dom rng, Bool, a, Bool,
 PairSpec era dom rng)
x) else Maybe String
forall a. Maybe a
Nothing
  let trips :: [(PairSpec BabbageEra Word64 Int, PairSpec BabbageEra Word64 Int,
  PairSpec BabbageEra Word64 Int)]
trips = [(PairSpec BabbageEra Word64 Int
x, PairSpec BabbageEra Word64 Int
y, PairSpec BabbageEra Word64 Int
m) | PairSpec BabbageEra Word64 Int
x <- [PairSpec BabbageEra Word64 Int]
xs, PairSpec BabbageEra Word64 Int
y <- [PairSpec BabbageEra Word64 Int]
ys, PairSpec BabbageEra Word64 Int -> Bool
forall era d r. PairSpec era d r -> Bool
ok PairSpec BabbageEra Word64 Int
x Bool -> Bool -> Bool
&& PairSpec BabbageEra Word64 Int -> Bool
forall era d r. PairSpec era d r -> Bool
ok PairSpec BabbageEra Word64 Int
y, Just PairSpec BabbageEra Word64 Int
m <- [PairSpec BabbageEra Word64 Int
-> PairSpec BabbageEra Word64 Int
-> Maybe (PairSpec BabbageEra Word64 Int)
forall a. (LiftT a, Semigroup a) => a -> a -> Maybe a
consistent PairSpec BabbageEra Word64 Int
x PairSpec BabbageEra Word64 Int
y]]
  [(PairSpec BabbageEra Word64 Int, Bool,
  PairSpec BabbageEra Word64 Int, Bool, Map Word64 Int, Bool,
  PairSpec BabbageEra Word64 Int)]
ts <- ((PairSpec BabbageEra Word64 Int, PairSpec BabbageEra Word64 Int,
  PairSpec BabbageEra Word64 Int)
 -> Gen
      (PairSpec BabbageEra Word64 Int, Bool,
       PairSpec BabbageEra Word64 Int, Bool, Map Word64 Int, Bool,
       PairSpec BabbageEra Word64 Int))
-> [(PairSpec BabbageEra Word64 Int,
     PairSpec BabbageEra Word64 Int, PairSpec BabbageEra Word64 Int)]
-> Gen
     [(PairSpec BabbageEra Word64 Int, Bool,
       PairSpec BabbageEra Word64 Int, Bool, Map Word64 Int, Bool,
       PairSpec BabbageEra Word64 Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (PairSpec BabbageEra Word64 Int, PairSpec BabbageEra Word64 Int,
 PairSpec BabbageEra Word64 Int)
-> Gen
     (PairSpec BabbageEra Word64 Int, Bool,
      PairSpec BabbageEra Word64 Int, Bool, Map Word64 Int, Bool,
      PairSpec BabbageEra Word64 Int)
forall {dom} {rng} {era} {era}.
(Ord dom, Eq rng) =>
(PairSpec era dom rng, PairSpec era dom rng,
 PairSpec BabbageEra dom rng)
-> Gen
     (PairSpec era dom rng, Bool, PairSpec era dom rng, Bool,
      Map dom rng, Bool, PairSpec BabbageEra dom rng)
check [(PairSpec BabbageEra Word64 Int, PairSpec BabbageEra Word64 Int,
  PairSpec BabbageEra Word64 Int)]
trips
  (Int, [String]) -> Gen (Int, [String])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, [String]) -> Gen (Int, [String]))
-> (Int, [String]) -> Gen (Int, [String])
forall a b. (a -> b) -> a -> b
$ ([(PairSpec BabbageEra Word64 Int, PairSpec BabbageEra Word64 Int,
  PairSpec BabbageEra Word64 Int)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PairSpec BabbageEra Word64 Int, PairSpec BabbageEra Word64 Int,
  PairSpec BabbageEra Word64 Int)]
trips, ((PairSpec BabbageEra Word64 Int, Bool,
  PairSpec BabbageEra Word64 Int, Bool, Map Word64 Int, Bool,
  PairSpec BabbageEra Word64 Int)
 -> Maybe String)
-> [(PairSpec BabbageEra Word64 Int, Bool,
     PairSpec BabbageEra Word64 Int, Bool, Map Word64 Int, Bool,
     PairSpec BabbageEra Word64 Int)]
-> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (PairSpec BabbageEra Word64 Int, Bool,
 PairSpec BabbageEra Word64 Int, Bool, Map Word64 Int, Bool,
 PairSpec BabbageEra Word64 Int)
-> Maybe String
forall {a} {era} {dom} {rng} {era} {dom} {rng} {era} {dom} {rng}.
Show a =>
(PairSpec era dom rng, Bool, PairSpec era dom rng, Bool, a, Bool,
 PairSpec era dom rng)
-> Maybe String
pr [(PairSpec BabbageEra Word64 Int, Bool,
  PairSpec BabbageEra Word64 Int, Bool, Map Word64 Int, Bool,
  PairSpec BabbageEra Word64 Int)]
ts)

reportManyMergePairSpec :: IO ()
reportManyMergePairSpec :: IO ()
reportManyMergePairSpec = do
  (Int
passed, [String]
bad) <- Gen (Int, [String]) -> IO (Int, [String])
forall a. Gen a -> IO a
generate Gen (Int, [String])
manyMergePairSpec
  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
bad
    then String -> IO ()
putStrLn (String
"passed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
passed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests")
    else do (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
bad; String -> IO ()
forall a. HasCallStack => String -> a
error String
"TestFails"