{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
-- NOTE: this is for `split` vs. `splitGen` that we haven't had
-- time to fix in `QuickCheck`.
{-# OPTIONS_GHC -Wno-deprecations #-}

module Constrained.GenT where

import Control.Monad
import Data.Foldable
import Data.List.NonEmpty (NonEmpty ((:|)), (<|))
import Data.List.NonEmpty qualified as NE
import Data.Typeable
import GHC.Stack
import System.Random
import Test.QuickCheck hiding (Args, Fun)
import Test.QuickCheck.Gen

-- ==============================================================
-- The GE Monad

-- | It distinguishes between two kinds of errors: FatalError and GenError
-- and non-fatal errors.
data GE a
  = FatalError (NonEmpty (NonEmpty String))
  | GenError (NonEmpty (NonEmpty String))
  | Result a
  deriving (Eq (GE a)
Eq (GE a) =>
(GE a -> GE a -> Ordering)
-> (GE a -> GE a -> Bool)
-> (GE a -> GE a -> Bool)
-> (GE a -> GE a -> Bool)
-> (GE a -> GE a -> Bool)
-> (GE a -> GE a -> GE a)
-> (GE a -> GE a -> GE a)
-> Ord (GE a)
GE a -> GE a -> Bool
GE a -> GE a -> Ordering
GE a -> GE a -> GE a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (GE a)
forall a. Ord a => GE a -> GE a -> Bool
forall a. Ord a => GE a -> GE a -> Ordering
forall a. Ord a => GE a -> GE a -> GE a
$ccompare :: forall a. Ord a => GE a -> GE a -> Ordering
compare :: GE a -> GE a -> Ordering
$c< :: forall a. Ord a => GE a -> GE a -> Bool
< :: GE a -> GE a -> Bool
$c<= :: forall a. Ord a => GE a -> GE a -> Bool
<= :: GE a -> GE a -> Bool
$c> :: forall a. Ord a => GE a -> GE a -> Bool
> :: GE a -> GE a -> Bool
$c>= :: forall a. Ord a => GE a -> GE a -> Bool
>= :: GE a -> GE a -> Bool
$cmax :: forall a. Ord a => GE a -> GE a -> GE a
max :: GE a -> GE a -> GE a
$cmin :: forall a. Ord a => GE a -> GE a -> GE a
min :: GE a -> GE a -> GE a
Ord, GE a -> GE a -> Bool
(GE a -> GE a -> Bool) -> (GE a -> GE a -> Bool) -> Eq (GE a)
forall a. Eq a => GE a -> GE a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => GE a -> GE a -> Bool
== :: GE a -> GE a -> Bool
$c/= :: forall a. Eq a => GE a -> GE a -> Bool
/= :: GE a -> GE a -> Bool
Eq, Int -> GE a -> ShowS
[GE a] -> ShowS
GE a -> String
(Int -> GE a -> ShowS)
-> (GE a -> String) -> ([GE a] -> ShowS) -> Show (GE a)
forall a. Show a => Int -> GE a -> ShowS
forall a. Show a => [GE a] -> ShowS
forall a. Show a => GE a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> GE a -> ShowS
showsPrec :: Int -> GE a -> ShowS
$cshow :: forall a. Show a => GE a -> String
show :: GE a -> String
$cshowList :: forall a. Show a => [GE a] -> ShowS
showList :: [GE a] -> ShowS
Show, (forall a b. (a -> b) -> GE a -> GE b)
-> (forall a b. a -> GE b -> GE a) -> Functor GE
forall a b. a -> GE b -> GE a
forall a b. (a -> b) -> GE a -> GE b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> GE a -> GE b
fmap :: forall a b. (a -> b) -> GE a -> GE b
$c<$ :: forall a b. a -> GE b -> GE a
<$ :: forall a b. a -> GE b -> GE a
Functor)

instance Applicative GE where
  pure :: forall a. a -> GE a
pure = a -> GE a
forall a. a -> GE a
Result
  <*> :: forall a b. GE (a -> b) -> GE a -> GE b
(<*>) = GE (a -> b) -> GE a -> GE b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad GE where
  FatalError NonEmpty (NonEmpty String)
es >>= :: forall a b. GE a -> (a -> GE b) -> GE b
>>= a -> GE b
_ = NonEmpty (NonEmpty String) -> GE b
forall a. NonEmpty (NonEmpty String) -> GE a
FatalError NonEmpty (NonEmpty String)
es
  GenError NonEmpty (NonEmpty String)
es >>= a -> GE b
_ = NonEmpty (NonEmpty String) -> GE b
forall a. NonEmpty (NonEmpty String) -> GE a
GenError NonEmpty (NonEmpty String)
es
  Result a
a >>= a -> GE b
k = a -> GE b
k a
a

------------------------------------------------------------------------
-- The GenT monad
-- An environment monad on top of GE
------------------------------------------------------------------------

-- | Generation mode - how strict are we about requiring the generator to
-- succeed. This is necessary because sometimes failing to find a value means
-- there is an actual problem (a generator _should_ be satisfiable but for
-- whatever buggy reason it isn't) and sometimes failing to find a value just
-- means there are no values. The latter case is very relevant when you're
-- generating e.g. lists or sets of values that can be empty.
data GenMode
  = Loose
  | Strict
  deriving (Eq GenMode
Eq GenMode =>
(GenMode -> GenMode -> Ordering)
-> (GenMode -> GenMode -> Bool)
-> (GenMode -> GenMode -> Bool)
-> (GenMode -> GenMode -> Bool)
-> (GenMode -> GenMode -> Bool)
-> (GenMode -> GenMode -> GenMode)
-> (GenMode -> GenMode -> GenMode)
-> Ord GenMode
GenMode -> GenMode -> Bool
GenMode -> GenMode -> Ordering
GenMode -> GenMode -> GenMode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: GenMode -> GenMode -> Ordering
compare :: GenMode -> GenMode -> Ordering
$c< :: GenMode -> GenMode -> Bool
< :: GenMode -> GenMode -> Bool
$c<= :: GenMode -> GenMode -> Bool
<= :: GenMode -> GenMode -> Bool
$c> :: GenMode -> GenMode -> Bool
> :: GenMode -> GenMode -> Bool
$c>= :: GenMode -> GenMode -> Bool
>= :: GenMode -> GenMode -> Bool
$cmax :: GenMode -> GenMode -> GenMode
max :: GenMode -> GenMode -> GenMode
$cmin :: GenMode -> GenMode -> GenMode
min :: GenMode -> GenMode -> GenMode
Ord, GenMode -> GenMode -> Bool
(GenMode -> GenMode -> Bool)
-> (GenMode -> GenMode -> Bool) -> Eq GenMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GenMode -> GenMode -> Bool
== :: GenMode -> GenMode -> Bool
$c/= :: GenMode -> GenMode -> Bool
/= :: GenMode -> GenMode -> Bool
Eq, Int -> GenMode -> ShowS
[GenMode] -> ShowS
GenMode -> String
(Int -> GenMode -> ShowS)
-> (GenMode -> String) -> ([GenMode] -> ShowS) -> Show GenMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GenMode -> ShowS
showsPrec :: Int -> GenMode -> ShowS
$cshow :: GenMode -> String
show :: GenMode -> String
$cshowList :: [GenMode] -> ShowS
showList :: [GenMode] -> ShowS
Show)

newtype GenT m a = GenT {forall (m :: * -> *) a.
GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
runGenT :: GenMode -> [NonEmpty String] -> Gen (m a)}
  deriving ((forall a b. (a -> b) -> GenT m a -> GenT m b)
-> (forall a b. a -> GenT m b -> GenT m a) -> Functor (GenT m)
forall a b. a -> GenT m b -> GenT m a
forall a b. (a -> b) -> GenT m a -> GenT m b
forall (m :: * -> *) a b. Functor m => a -> GenT m b -> GenT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GenT m a -> GenT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GenT m a -> GenT m b
fmap :: forall a b. (a -> b) -> GenT m a -> GenT m b
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> GenT m b -> GenT m a
<$ :: forall a b. a -> GenT m b -> GenT m a
Functor)

instance Monad m => Applicative (GenT m) where
  pure :: forall a. a -> GenT m a
pure a
a = (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT (\GenMode
_ [NonEmpty String]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure @Gen (forall (f :: * -> *) a. Applicative f => a -> f a
pure @m a
a))
  <*> :: forall a b. GenT m (a -> b) -> GenT m a -> GenT m b
(<*>) = GenT m (a -> b) -> GenT m a -> GenT m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

-- I think this might be an inlined use of the Gen monad transformer?
instance Monad m => Monad (GenT m) where
  GenT GenMode -> [NonEmpty String] -> Gen (m a)
m >>= :: forall a b. GenT m a -> (a -> GenT m b) -> GenT m b
>>= a -> GenT m b
k = (GenMode -> [NonEmpty String] -> Gen (m b)) -> GenT m b
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT ((GenMode -> [NonEmpty String] -> Gen (m b)) -> GenT m b)
-> (GenMode -> [NonEmpty String] -> Gen (m b)) -> GenT m b
forall a b. (a -> b) -> a -> b
$ \GenMode
mode -> \[NonEmpty String]
msgs -> (QCGen -> Int -> m b) -> Gen (m b)
forall a. (QCGen -> Int -> a) -> Gen a
MkGen ((QCGen -> Int -> m b) -> Gen (m b))
-> (QCGen -> Int -> m b) -> Gen (m b)
forall a b. (a -> b) -> a -> b
$ \QCGen
r Int
n -> do
    let (QCGen
r1, QCGen
r2) = QCGen -> (QCGen, QCGen)
forall g. RandomGen g => g -> (g, g)
split QCGen
r
    a
a <- Gen (m a) -> QCGen -> Int -> m a
forall a. Gen a -> QCGen -> Int -> a
unGen (GenMode -> [NonEmpty String] -> Gen (m a)
m GenMode
mode [NonEmpty String]
msgs) QCGen
r1 Int
n
    Gen (m b) -> QCGen -> Int -> m b
forall a. Gen a -> QCGen -> Int -> a
unGen (GenT m b -> GenMode -> [NonEmpty String] -> Gen (m b)
forall (m :: * -> *) a.
GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
runGenT (a -> GenT m b
k a
a) GenMode
mode [NonEmpty String]
msgs) QCGen
r2 Int
n

instance MonadGenError m => MonadFail (GenT m) where
  fail :: forall a. String -> GenT m a
fail String
s = String -> GenT m a
forall (m :: * -> *) a. MonadGenError m => String -> m a
genError String
s

------------------------------------------------------------------------
-- The MonadGenError transformer
----------------------------------------------------------------------

-- | A class for different types of errors with a stack of `explain` calls to
-- narrow down problems. The (NonEmpty String) means one cannot cause an
-- Error without at least 1 string to explain it.
class Monad m => MonadGenError m where
  genErrors :: HasCallStack => NonEmpty (NonEmpty String) -> m a
  fatalErrors :: HasCallStack => NonEmpty (NonEmpty String) -> m a
  genErrorNE :: HasCallStack => NonEmpty String -> m a
  fatalErrorNE :: HasCallStack => NonEmpty String -> m a
  explainNE :: HasCallStack => NonEmpty String -> m a -> m a

-- | genError with one line of explanation
genError :: MonadGenError m => String -> m a
genError :: forall (m :: * -> *) a. MonadGenError m => String -> m a
genError = NonEmpty String -> m a
forall a. HasCallStack => NonEmpty String -> m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a
genErrorNE (NonEmpty String -> m a)
-> (String -> NonEmpty String) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NonEmpty String
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | fatalError with one line of explanation
fatalError :: MonadGenError m => String -> m a
fatalError :: forall (m :: * -> *) a. MonadGenError m => String -> m a
fatalError = NonEmpty String -> m a
forall a. HasCallStack => NonEmpty String -> m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a
fatalErrorNE (NonEmpty String -> m a)
-> (String -> NonEmpty String) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NonEmpty String
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | explain with one line of explanation
explain :: MonadGenError m => String -> m a -> m a
explain :: forall (m :: * -> *) a. MonadGenError m => String -> m a -> m a
explain String
s
  | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s = m a -> m a
forall a. a -> a
id
  | Bool
otherwise = NonEmpty String -> m a -> m a
forall a. HasCallStack => NonEmpty String -> m a -> m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a -> m a
explainNE (String -> NonEmpty String
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
s)

-- GE instance

instance MonadGenError GE where
  genErrorNE :: forall a. HasCallStack => NonEmpty String -> GE a
genErrorNE NonEmpty String
msg = NonEmpty (NonEmpty String) -> GE a
forall a. NonEmpty (NonEmpty String) -> GE a
GenError (NonEmpty String -> NonEmpty (NonEmpty String)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty String
msg)
  genErrors :: forall a. HasCallStack => NonEmpty (NonEmpty String) -> GE a
genErrors NonEmpty (NonEmpty String)
msgs = NonEmpty (NonEmpty String) -> GE a
forall a. NonEmpty (NonEmpty String) -> GE a
GenError NonEmpty (NonEmpty String)
msgs
  fatalErrorNE :: forall a. HasCallStack => NonEmpty String -> GE a
fatalErrorNE NonEmpty String
msg = NonEmpty (NonEmpty String) -> GE a
forall a. NonEmpty (NonEmpty String) -> GE a
FatalError (NonEmpty String -> NonEmpty (NonEmpty String)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty String
msg)
  fatalErrors :: forall a. HasCallStack => NonEmpty (NonEmpty String) -> GE a
fatalErrors NonEmpty (NonEmpty String)
msgs = NonEmpty (NonEmpty String) -> GE a
forall a. NonEmpty (NonEmpty String) -> GE a
FatalError NonEmpty (NonEmpty String)
msgs
  explainNE :: forall a. HasCallStack => NonEmpty String -> GE a -> GE a
explainNE NonEmpty String
m (GenError NonEmpty (NonEmpty String)
ms) = NonEmpty (NonEmpty String) -> GE a
forall a. NonEmpty (NonEmpty String) -> GE a
GenError (NonEmpty String
m NonEmpty String
-> NonEmpty (NonEmpty String) -> NonEmpty (NonEmpty String)
forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (NonEmpty String)
ms)
  explainNE NonEmpty String
m (FatalError NonEmpty (NonEmpty String)
ms) = NonEmpty (NonEmpty String) -> GE a
forall a. NonEmpty (NonEmpty String) -> GE a
FatalError (NonEmpty String
m NonEmpty String
-> NonEmpty (NonEmpty String) -> NonEmpty (NonEmpty String)
forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (NonEmpty String)
ms)
  explainNE NonEmpty String
_ (Result a
x) = a -> GE a
forall a. a -> GE a
Result a
x

-- GenT instance

-- | calls to genError and fatalError, add the stacked messages in the monad.
instance MonadGenError m => MonadGenError (GenT m) where
  genErrorNE :: forall a. HasCallStack => NonEmpty String -> GenT m a
genErrorNE NonEmpty String
e = (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT ((GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a)
-> (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall a b. (a -> b) -> a -> b
$ \GenMode
_ [NonEmpty String]
xs -> m a -> Gen (m a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m a -> Gen (m a)) -> m a -> Gen (m a)
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty String) -> m a
forall a. HasCallStack => NonEmpty (NonEmpty String) -> m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
genErrors (NonEmpty String -> [NonEmpty String] -> NonEmpty (NonEmpty String)
forall a. NonEmpty a -> [NonEmpty a] -> NonEmpty (NonEmpty a)
add NonEmpty String
e [NonEmpty String]
xs)
  genErrors :: forall a. HasCallStack => NonEmpty (NonEmpty String) -> GenT m a
genErrors NonEmpty (NonEmpty String)
es = (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT ((GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a)
-> (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall a b. (a -> b) -> a -> b
$ \GenMode
_ [NonEmpty String]
xs -> m a -> Gen (m a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m a -> Gen (m a)) -> m a -> Gen (m a)
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty String) -> m a
forall a. HasCallStack => NonEmpty (NonEmpty String) -> m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
genErrors (NonEmpty (NonEmpty String)
-> [NonEmpty String] -> NonEmpty (NonEmpty String)
forall a.
NonEmpty (NonEmpty a) -> [NonEmpty a] -> NonEmpty (NonEmpty a)
cat NonEmpty (NonEmpty String)
es [NonEmpty String]
xs)

  -- Perhaps we want to turn genError into fatalError, if mode_ is Strict?
  fatalErrorNE :: forall a. HasCallStack => NonEmpty String -> GenT m a
fatalErrorNE NonEmpty String
e = (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT ((GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a)
-> (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall a b. (a -> b) -> a -> b
$ \GenMode
_ [NonEmpty String]
xs -> m a -> Gen (m a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m a -> Gen (m a)) -> m a -> Gen (m a)
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty String) -> m a
forall a. HasCallStack => NonEmpty (NonEmpty String) -> m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
fatalErrors (NonEmpty String -> [NonEmpty String] -> NonEmpty (NonEmpty String)
forall a. NonEmpty a -> [NonEmpty a] -> NonEmpty (NonEmpty a)
add NonEmpty String
e [NonEmpty String]
xs)
  fatalErrors :: forall a. HasCallStack => NonEmpty (NonEmpty String) -> GenT m a
fatalErrors NonEmpty (NonEmpty String)
es = (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT ((GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a)
-> (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall a b. (a -> b) -> a -> b
$ \GenMode
_ [NonEmpty String]
xs -> m a -> Gen (m a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m a -> Gen (m a)) -> m a -> Gen (m a)
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty String) -> m a
forall a. HasCallStack => NonEmpty (NonEmpty String) -> m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
fatalErrors (NonEmpty (NonEmpty String)
-> [NonEmpty String] -> NonEmpty (NonEmpty String)
forall a.
NonEmpty (NonEmpty a) -> [NonEmpty a] -> NonEmpty (NonEmpty a)
cat NonEmpty (NonEmpty String)
es [NonEmpty String]
xs)

  -- Perhaps we want to turn fatalError into genError, if mode_ is Loose?
  explainNE :: forall a. HasCallStack => NonEmpty String -> GenT m a -> GenT m a
explainNE NonEmpty String
e (GenT GenMode -> [NonEmpty String] -> Gen (m a)
f) = (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT ((GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a)
-> (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall a b. (a -> b) -> a -> b
$ \GenMode
mode [NonEmpty String]
es -> (m a -> m a) -> Gen (m a) -> Gen (m a)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NonEmpty String -> m a -> m a
forall a. HasCallStack => NonEmpty String -> m a -> m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a -> m a
explainNE NonEmpty String
e) (GenMode -> [NonEmpty String] -> Gen (m a)
f GenMode
mode [NonEmpty String]
es)

-- ====================================================
-- useful operations on NonEmpty

add :: NonEmpty a -> [NonEmpty a] -> NonEmpty (NonEmpty a)
add :: forall a. NonEmpty a -> [NonEmpty a] -> NonEmpty (NonEmpty a)
add NonEmpty a
a [] = NonEmpty a -> NonEmpty (NonEmpty a)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty a
a
add NonEmpty a
a (NonEmpty a
x : [NonEmpty a]
xs) = NonEmpty a
a NonEmpty a -> NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
forall a. a -> NonEmpty a -> NonEmpty a
<| (NonEmpty a
x NonEmpty a -> [NonEmpty a] -> NonEmpty (NonEmpty a)
forall a. a -> [a] -> NonEmpty a
:| [NonEmpty a]
xs)

cat :: NonEmpty (NonEmpty a) -> [NonEmpty a] -> NonEmpty (NonEmpty a)
cat :: forall a.
NonEmpty (NonEmpty a) -> [NonEmpty a] -> NonEmpty (NonEmpty a)
cat NonEmpty (NonEmpty a)
a [] = NonEmpty (NonEmpty a)
a
cat NonEmpty (NonEmpty a)
a (NonEmpty a
x : [NonEmpty a]
xs) = NonEmpty (NonEmpty a)
a NonEmpty (NonEmpty a)
-> NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
forall a. Semigroup a => a -> a -> a
<> (NonEmpty a
x NonEmpty a -> [NonEmpty a] -> NonEmpty (NonEmpty a)
forall a. a -> [a] -> NonEmpty a
:| [NonEmpty a]
xs)

-- | Sometimes we have a bunch of genError or fatalError
--   messages we want to combine into one big message.
--   This happens when we want to lift one of these into an input for 'error'
catMessages :: NonEmpty (NonEmpty String) -> String
catMessages :: NonEmpty (NonEmpty String) -> String
catMessages NonEmpty (NonEmpty String)
xs = [String] -> String
unlines (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (NonEmpty String) -> NonEmpty String
catMessageList NonEmpty (NonEmpty String)
xs))

-- | Turn each inner (NonEmpty String) into a String
catMessageList :: NonEmpty (NonEmpty String) -> NonEmpty String
catMessageList :: NonEmpty (NonEmpty String) -> NonEmpty String
catMessageList = (NonEmpty String -> String)
-> NonEmpty (NonEmpty String) -> NonEmpty String
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> String
unlines ([String] -> String)
-> (NonEmpty String -> [String]) -> NonEmpty String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList)

-- ========================================================
-- Useful operations on GE

-- If none of the GE's are FatalError, then concat together all the
-- Result's (skipping over GenError). If there is at least one
-- (FatalError xs) abort, and lift all those 'xs' as errors in the monad 'm'
catGEs :: forall m a. MonadGenError m => [GE a] -> m [a]
catGEs :: forall (m :: * -> *) a. MonadGenError m => [GE a] -> m [a]
catGEs [GE a]
ges0 = [a] -> [GE a] -> m [a]
forall {f :: * -> *} {a}. MonadGenError f => [a] -> [GE a] -> f [a]
go [] [GE a]
ges0
  where
    go :: [a] -> [GE a] -> f [a]
go [a]
acc [] = [a] -> f [a]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> f [a]) -> [a] -> f [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc
    go ![a]
acc (GE a
g : [GE a]
ges) =
      case GE a
g of
        Result a
a -> [a] -> [GE a] -> f [a]
go (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc) [GE a]
ges
        GenError NonEmpty (NonEmpty String)
_ -> [a] -> [GE a] -> f [a]
go [a]
acc [GE a]
ges
        FatalError NonEmpty (NonEmpty String)
xs -> NonEmpty (NonEmpty String) -> f [a]
forall a. HasCallStack => NonEmpty (NonEmpty String) -> f a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
fatalErrors NonEmpty (NonEmpty String)
xs

-- | Given a function for handling GenError,
--   and handling FatalError by using 'error'
--   Turn (GE a) into 'a'
fromGE :: HasCallStack => (NonEmpty (NonEmpty String) -> a) -> GE a -> a
fromGE :: forall a.
HasCallStack =>
(NonEmpty (NonEmpty String) -> a) -> GE a -> a
fromGE NonEmpty (NonEmpty String) -> a
f GE a
ge = case GE a
ge of
  Result a
a -> a
a
  GenError NonEmpty (NonEmpty String)
xs -> NonEmpty (NonEmpty String) -> a
f NonEmpty (NonEmpty String)
xs
  FatalError NonEmpty (NonEmpty String)
es -> String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty String) -> String
catMessages NonEmpty (NonEmpty String)
es

-- | Turn (GE a) into a
--   both GenError and FatalErrors are handled by using 'error'
errorGE :: GE a -> a
errorGE :: forall a. GE a -> a
errorGE GE a
ge = case GE a
ge of
  FatalError NonEmpty (NonEmpty String)
xs -> String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty String) -> String
catMessages NonEmpty (NonEmpty String)
xs
  GenError NonEmpty (NonEmpty String)
xs -> String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty String) -> String
catMessages NonEmpty (NonEmpty String)
xs
  Result a
x -> a
x

isOk :: GE a -> Bool
isOk :: forall a. GE a -> Bool
isOk GE a
ge = case GE a
ge of
  GenError {} -> Bool
False
  FatalError {} -> Bool
False
  Result {} -> Bool
True

runGE :: forall m r. MonadGenError m => GE r -> m r
runGE :: forall (m :: * -> *) r. MonadGenError m => GE r -> m r
runGE GE r
ge = case GE r
ge of
  GenError NonEmpty (NonEmpty String)
es -> NonEmpty (NonEmpty String) -> m r
forall a. HasCallStack => NonEmpty (NonEmpty String) -> m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
genErrors NonEmpty (NonEmpty String)
es
  FatalError NonEmpty (NonEmpty String)
es -> NonEmpty (NonEmpty String) -> m r
forall a. HasCallStack => NonEmpty (NonEmpty String) -> m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
fatalErrors NonEmpty (NonEmpty String)
es
  Result r
a -> r -> m r
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
a

fromGEProp :: Testable p => GE p -> Property
fromGEProp :: forall p. Testable p => GE p -> Property
fromGEProp GE p
ge = case GE p
ge of
  GenError NonEmpty (NonEmpty String)
es -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (NonEmpty (NonEmpty String) -> String
catMessages NonEmpty (NonEmpty String)
es) Bool
False
  FatalError NonEmpty (NonEmpty String)
es -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (NonEmpty (NonEmpty String) -> String
catMessages NonEmpty (NonEmpty String)
es) Bool
False
  Result p
p -> p -> Property
forall prop. Testable prop => prop -> Property
property p
p

fromGEDiscard :: Testable p => GE p -> Property
fromGEDiscard :: forall p. Testable p => GE p -> Property
fromGEDiscard GE p
ge = case GE p
ge of
  Result p
p -> p -> Property
forall prop. Testable prop => prop -> Property
property p
p
  GE p
_ -> Property
forall a. a
discard

headGE :: Foldable t => t a -> GE a
headGE :: forall (t :: * -> *) a. Foldable t => t a -> GE a
headGE t a
t
  | a
x : [a]
_ <- t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a
t = a -> GE a
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  | Bool
otherwise = String -> GE a
forall (m :: * -> *) a. MonadGenError m => String -> m a
fatalError String
"head of empty structure"

-- | Turn a `GE [a]` to `[a]`, `genError` goes to `[]` and `fatalError` to `error`.
listFromGE :: GE [a] -> [a]
listFromGE :: forall a. GE [a] -> [a]
listFromGE = (NonEmpty (NonEmpty String) -> [a]) -> GE [a] -> [a]
forall a.
HasCallStack =>
(NonEmpty (NonEmpty String) -> a) -> GE a -> a
fromGE ([a] -> NonEmpty (NonEmpty String) -> [a]
forall a b. a -> b -> a
const []) (GE [a] -> [a]) -> (GE [a] -> GE [a]) -> GE [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GE [a] -> GE [a]
forall (m :: * -> *) a. MonadGenError m => String -> m a -> m a
explain String
"listFromGE"

-- ========================================================
-- Useful operations on GenT

strictGen :: GenT m a -> Gen (m a)
strictGen :: forall (m :: * -> *) a. GenT m a -> Gen (m a)
strictGen GenT m a
genT = GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
forall (m :: * -> *) a.
GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
runGenT GenT m a
genT GenMode
Strict []

genFromGenT :: GenT GE a -> Gen a
genFromGenT :: forall a. GenT GE a -> Gen a
genFromGenT GenT GE a
genT = GE a -> a
forall a. GE a -> a
errorGE (GE a -> a) -> Gen (GE a) -> Gen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT GE a -> GenMode -> [NonEmpty String] -> Gen (GE a)
forall (m :: * -> *) a.
GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
runGenT GenT GE a
genT GenMode
Strict []

resizeT :: (Int -> Int) -> GenT m a -> GenT m a
resizeT :: forall (m :: * -> *) a. (Int -> Int) -> GenT m a -> GenT m a
resizeT Int -> Int
f (GenT GenMode -> [NonEmpty String] -> Gen (m a)
gm) = (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT ((GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a)
-> (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall a b. (a -> b) -> a -> b
$ \GenMode
mode [NonEmpty String]
msgs -> (Int -> Gen (m a)) -> Gen (m a)
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen (m a)) -> Gen (m a))
-> (Int -> Gen (m a)) -> Gen (m a)
forall a b. (a -> b) -> a -> b
$ \Int
sz -> Int -> Gen (m a) -> Gen (m a)
forall a. HasCallStack => Int -> Gen a -> Gen a
resize (Int -> Int
f Int
sz) (GenMode -> [NonEmpty String] -> Gen (m a)
gm GenMode
mode [NonEmpty String]
msgs)

pureGen :: Applicative m => Gen a -> GenT m a
pureGen :: forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen Gen a
gen = (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT ((GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a)
-> (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall a b. (a -> b) -> a -> b
$ \GenMode
_ [NonEmpty String]
_ -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> Gen a -> Gen (m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
gen

listOfT :: MonadGenError m => GenT GE a -> GenT m [a]
listOfT :: forall (m :: * -> *) a. MonadGenError m => GenT GE a -> GenT m [a]
listOfT GenT GE a
gen = do
  [GE a]
lst <- Gen [GE a] -> GenT m [GE a]
forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen (Gen [GE a] -> GenT m [GE a])
-> (Gen (GE a) -> Gen [GE a]) -> Gen (GE a) -> GenT m [GE a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gen (GE a) -> Gen [GE a]
forall a. Gen a -> Gen [a]
listOf (Gen (GE a) -> GenT m [GE a]) -> Gen (GE a) -> GenT m [GE a]
forall a b. (a -> b) -> a -> b
$ GenT GE a -> GenMode -> [NonEmpty String] -> Gen (GE a)
forall (m :: * -> *) a.
GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
runGenT GenT GE a
gen GenMode
Loose []
  [GE a] -> GenT m [a]
forall (m :: * -> *) a. MonadGenError m => [GE a] -> m [a]
catGEs [GE a]
lst

-- | Generate a list of elements of length at most `goalLen`, but accepting failure
-- to get that many elements so long as `validLen` is true.
-- TODO: possibly one could return "more, fewer, ok" in the `validLen` instead
-- of `Bool`
listOfUntilLenT :: (Typeable a, MonadGenError m) => GenT GE a -> Int -> (Int -> Bool) -> GenT m [a]
listOfUntilLenT :: forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
GenT GE a -> Int -> (Int -> Bool) -> GenT m [a]
listOfUntilLenT GenT GE a
gen Int
goalLen Int -> Bool
validLen =
  GenT m [a]
genList GenT m [a] -> ([a] -> Bool) -> GenT m [a]
forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
GenT m a -> (a -> Bool) -> GenT m a
`suchThatT` Int -> Bool
validLen (Int -> Bool) -> ([a] -> Int) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
  where
    genList :: GenT m [a]
genList = do
      [GE a]
res <- Gen [GE a] -> GenT m [GE a]
forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen (Gen [GE a] -> GenT m [GE a])
-> (Gen (GE a) -> Gen [GE a]) -> Gen (GE a) -> GenT m [GE a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Gen (GE a) -> Gen [GE a]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
goalLen (Gen (GE a) -> GenT m [GE a]) -> Gen (GE a) -> GenT m [GE a]
forall a b. (a -> b) -> a -> b
$ GenT GE a -> GenMode -> [NonEmpty String] -> Gen (GE a)
forall (m :: * -> *) a.
GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
runGenT GenT GE a
gen GenMode
Loose []
      [GE a] -> GenT m [a]
forall (m :: * -> *) a. MonadGenError m => [GE a] -> m [a]
catGEs [GE a]
res

vectorOfT :: MonadGenError m => Int -> GenT GE a -> GenT m [a]
vectorOfT :: forall (m :: * -> *) a.
MonadGenError m =>
Int -> GenT GE a -> GenT m [a]
vectorOfT Int
i GenT GE a
gen = (GenMode -> [NonEmpty String] -> Gen (m [a])) -> GenT m [a]
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT ((GenMode -> [NonEmpty String] -> Gen (m [a])) -> GenT m [a])
-> (GenMode -> [NonEmpty String] -> Gen (m [a])) -> GenT m [a]
forall a b. (a -> b) -> a -> b
$ \GenMode
mode [NonEmpty String]
_ -> do
  GE [a]
res <- ([GE a] -> GE [a]) -> Gen [GE a] -> Gen (GE [a])
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GE a] -> GE [a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (Gen [GE a] -> Gen (GE [a]))
-> (Gen (GE a) -> Gen [GE a]) -> Gen (GE a) -> Gen (GE [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Gen (GE a) -> Gen [GE a]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
i (Gen (GE a) -> Gen (GE [a])) -> Gen (GE a) -> Gen (GE [a])
forall a b. (a -> b) -> a -> b
$ GenT GE a -> GenMode -> [NonEmpty String] -> Gen (GE a)
forall (m :: * -> *) a.
GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
runGenT GenT GE a
gen GenMode
Strict []
  case GenMode
mode of
    GenMode
Strict -> m [a] -> Gen (m [a])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m [a] -> Gen (m [a])) -> m [a] -> Gen (m [a])
forall a b. (a -> b) -> a -> b
$ GE [a] -> m [a]
forall (m :: * -> *) r. MonadGenError m => GE r -> m r
runGE GE [a]
res
    GenMode
Loose -> case GE [a]
res of
      FatalError NonEmpty (NonEmpty String)
es -> m [a] -> Gen (m [a])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m [a] -> Gen (m [a])) -> m [a] -> Gen (m [a])
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty String) -> m [a]
forall a. HasCallStack => NonEmpty (NonEmpty String) -> m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
genErrors NonEmpty (NonEmpty String)
es
      GE [a]
_ -> m [a] -> Gen (m [a])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m [a] -> Gen (m [a])) -> m [a] -> Gen (m [a])
forall a b. (a -> b) -> a -> b
$ GE [a] -> m [a]
forall (m :: * -> *) r. MonadGenError m => GE r -> m r
runGE GE [a]
res

infixl 2 `suchThatT`

suchThatT :: (Typeable a, MonadGenError m) => GenT m a -> (a -> Bool) -> GenT m a
suchThatT :: forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
GenT m a -> (a -> Bool) -> GenT m a
suchThatT GenT m a
g a -> Bool
p = Int -> GenT m a -> (a -> Bool) -> GenT m a
forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
Int -> GenT m a -> (a -> Bool) -> GenT m a
suchThatWithTryT Int
100 GenT m a
g a -> Bool
p

suchThatWithTryT ::
  forall a m. (Typeable a, MonadGenError m) => Int -> GenT m a -> (a -> Bool) -> GenT m a
suchThatWithTryT :: forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
Int -> GenT m a -> (a -> Bool) -> GenT m a
suchThatWithTryT Int
tries GenT m a
g a -> Bool
p = do
  GenMode
mode <- GenT m GenMode
forall (m :: * -> *). Applicative m => GenT m GenMode
getMode
  let (Int
n, String -> GenT m a
cont) = case GenMode
mode of
        GenMode
Strict -> (Int
tries, String -> GenT m a
forall (m :: * -> *) a. MonadGenError m => String -> m a
fatalError)
        GenMode
Loose -> (Int
1 :: Int, String -> GenT m a
forall (m :: * -> *) a. MonadGenError m => String -> m a
genError) -- TODO: Maybe 1 is not the right number here!
  Int -> (String -> GenT m a) -> GenT m a
go Int
n String -> GenT m a
cont
  where
    go :: Int -> (String -> GenT m a) -> GenT m a
go Int
0 String -> GenT m a
cont =
      String -> GenT m a
cont
        (String
"Ran out of tries (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tries String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") on suchThatWithTryT at type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)))
    go Int
n String -> GenT m a
cont = do
      a
a <- GenT m a
g
      if a -> Bool
p a
a then a -> GenT m a
forall a. a -> GenT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a else (Int -> Int) -> GenT m a -> GenT m a
forall (m :: * -> *) a. (Int -> Int) -> GenT m a -> GenT m a
scaleT (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (GenT m a -> GenT m a) -> GenT m a -> GenT m a
forall a b. (a -> b) -> a -> b
$ Int -> (String -> GenT m a) -> GenT m a
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String -> GenT m a
cont

scaleT :: (Int -> Int) -> GenT m a -> GenT m a
scaleT :: forall (m :: * -> *) a. (Int -> Int) -> GenT m a -> GenT m a
scaleT Int -> Int
sc (GenT GenMode -> [NonEmpty String] -> Gen (m a)
gen) = (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT ((GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a)
-> (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall a b. (a -> b) -> a -> b
$ \GenMode
mode [NonEmpty String]
msgs -> (Int -> Int) -> Gen (m a) -> Gen (m a)
forall a. (Int -> Int) -> Gen a -> Gen a
scale Int -> Int
sc (Gen (m a) -> Gen (m a)) -> Gen (m a) -> Gen (m a)
forall a b. (a -> b) -> a -> b
$ GenMode -> [NonEmpty String] -> Gen (m a)
gen GenMode
mode [NonEmpty String]
msgs

getMode :: Applicative m => GenT m GenMode
getMode :: forall (m :: * -> *). Applicative m => GenT m GenMode
getMode = (GenMode -> [NonEmpty String] -> Gen (m GenMode)) -> GenT m GenMode
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT ((GenMode -> [NonEmpty String] -> Gen (m GenMode))
 -> GenT m GenMode)
-> (GenMode -> [NonEmpty String] -> Gen (m GenMode))
-> GenT m GenMode
forall a b. (a -> b) -> a -> b
$ \GenMode
mode [NonEmpty String]
_ -> m GenMode -> Gen (m GenMode)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenMode -> m GenMode
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenMode
mode)

getMessages :: Applicative m => GenT m [NonEmpty String]
getMessages :: forall (m :: * -> *). Applicative m => GenT m [NonEmpty String]
getMessages = (GenMode -> [NonEmpty String] -> Gen (m [NonEmpty String]))
-> GenT m [NonEmpty String]
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT ((GenMode -> [NonEmpty String] -> Gen (m [NonEmpty String]))
 -> GenT m [NonEmpty String])
-> (GenMode -> [NonEmpty String] -> Gen (m [NonEmpty String]))
-> GenT m [NonEmpty String]
forall a b. (a -> b) -> a -> b
$ \GenMode
_ [NonEmpty String]
msgs -> m [NonEmpty String] -> Gen (m [NonEmpty String])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([NonEmpty String] -> m [NonEmpty String]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [NonEmpty String]
msgs)

withMode :: GenMode -> GenT m a -> GenT m a
withMode :: forall (m :: * -> *) a. GenMode -> GenT m a -> GenT m a
withMode GenMode
mode GenT m a
gen = (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT ((GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a)
-> (GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
forall a b. (a -> b) -> a -> b
$ \GenMode
_ [NonEmpty String]
msgs -> GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
forall (m :: * -> *) a.
GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
runGenT GenT m a
gen GenMode
mode [NonEmpty String]
msgs

oneofT :: (Typeable a, MonadGenError m) => [GenT GE a] -> GenT m a
oneofT :: forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
[GenT GE a] -> GenT m a
oneofT [GenT GE a]
gs = do
  GenMode
mode <- GenT m GenMode
forall (m :: * -> *). Applicative m => GenT m GenMode
getMode
  [NonEmpty String]
msgs <- GenT m [NonEmpty String]
forall (m :: * -> *). Applicative m => GenT m [NonEmpty String]
getMessages
  GE a
r <-
    String -> GenT m (GE a) -> GenT m (GE a)
forall (m :: * -> *) a. MonadGenError m => String -> m a -> m a
explain String
"suchThatT in oneofT" (GenT m (GE a) -> GenT m (GE a)) -> GenT m (GE a) -> GenT m (GE a)
forall a b. (a -> b) -> a -> b
$
      Gen (GE a) -> GenT m (GE a)
forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen ([Gen (GE a)] -> Gen (GE a)
forall a. HasCallStack => [Gen a] -> Gen a
oneof [GenT GE a -> GenMode -> [NonEmpty String] -> Gen (GE a)
forall (m :: * -> *) a.
GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
runGenT GenT GE a
g GenMode
mode [NonEmpty String]
msgs | GenT GE a
g <- [GenT GE a]
gs]) GenT m (GE a) -> (GE a -> Bool) -> GenT m (GE a)
forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
GenT m a -> (a -> Bool) -> GenT m a
`suchThatT` GE a -> Bool
forall a. GE a -> Bool
isOk
  GE a -> GenT m a
forall (m :: * -> *) r. MonadGenError m => GE r -> m r
runGE GE a
r

frequencyT :: (Typeable a, MonadGenError m) => [(Int, GenT GE a)] -> GenT m a
frequencyT :: forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
[(Int, GenT GE a)] -> GenT m a
frequencyT [(Int, GenT GE a)]
gs = do
  GenMode
mode <- GenT m GenMode
forall (m :: * -> *). Applicative m => GenT m GenMode
getMode
  [NonEmpty String]
msgs <- GenT m [NonEmpty String]
forall (m :: * -> *). Applicative m => GenT m [NonEmpty String]
getMessages
  GE a
r <-
    String -> GenT m (GE a) -> GenT m (GE a)
forall (m :: * -> *) a. MonadGenError m => String -> m a -> m a
explain String
"suchThatT in oneofT" (GenT m (GE a) -> GenT m (GE a)) -> GenT m (GE a) -> GenT m (GE a)
forall a b. (a -> b) -> a -> b
$
      Gen (GE a) -> GenT m (GE a)
forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen ([(Int, Gen (GE a))] -> Gen (GE a)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
f, GenT GE a -> GenMode -> [NonEmpty String] -> Gen (GE a)
forall (m :: * -> *) a.
GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
runGenT GenT GE a
g GenMode
mode [NonEmpty String]
msgs) | (Int
f, GenT GE a
g) <- [(Int, GenT GE a)]
gs]) GenT m (GE a) -> (GE a -> Bool) -> GenT m (GE a)
forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
GenT m a -> (a -> Bool) -> GenT m a
`suchThatT` GE a -> Bool
forall a. GE a -> Bool
isOk
  GE a -> GenT m a
forall (m :: * -> *) r. MonadGenError m => GE r -> m r
runGE GE a
r

chooseT :: (Random a, Ord a, Show a, MonadGenError m) => (a, a) -> GenT m a
chooseT :: forall a (m :: * -> *).
(Random a, Ord a, Show a, MonadGenError m) =>
(a, a) -> GenT m a
chooseT (a
a, a
b)
  | a
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
a = String -> GenT m a
forall (m :: * -> *) a. MonadGenError m => String -> m a
genError (String
"chooseT (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")")
  | Bool
otherwise = Gen a -> GenT m a
forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen (Gen a -> GenT m a) -> Gen a -> GenT m a
forall a b. (a -> b) -> a -> b
$ (a, a) -> Gen a
forall a. Random a => (a, a) -> Gen a
choose (a
a, a
b)

sizeT :: Monad m => GenT m Int
sizeT :: forall (m :: * -> *). Monad m => GenT m Int
sizeT = (GenMode -> [NonEmpty String] -> Gen (m Int)) -> GenT m Int
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT ((GenMode -> [NonEmpty String] -> Gen (m Int)) -> GenT m Int)
-> (GenMode -> [NonEmpty String] -> Gen (m Int)) -> GenT m Int
forall a b. (a -> b) -> a -> b
$ \GenMode
mode [NonEmpty String]
msgs -> (Int -> Gen (m Int)) -> Gen (m Int)
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen (m Int)) -> Gen (m Int))
-> (Int -> Gen (m Int)) -> Gen (m Int)
forall a b. (a -> b) -> a -> b
$ \Int
n -> GenT m Int -> GenMode -> [NonEmpty String] -> Gen (m Int)
forall (m :: * -> *) a.
GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
runGenT (Int -> GenT m Int
forall a. a -> GenT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n) GenMode
mode [NonEmpty String]
msgs

-- ==================================================================
-- Reflective analysis of the internal GE structure of (GenT GE x)
-- This allows "catching" internal FatalError and GenError, and allowing
-- the program to control what happens in those cases.

-- | Always succeeds, but returns the internal GE structure for analysis
inspect :: forall m x. MonadGenError m => GenT GE x -> GenT m (GE x)
inspect :: forall (m :: * -> *) x.
MonadGenError m =>
GenT GE x -> GenT m (GE x)
inspect (GenT GenMode -> [NonEmpty String] -> Gen (GE x)
f) = (GenMode -> [NonEmpty String] -> Gen (m (GE x))) -> GenT m (GE x)
forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT GenMode -> [NonEmpty String] -> Gen (m (GE x))
g
  where
    g :: GenMode -> [NonEmpty String] -> Gen (m (GE x))
g GenMode
mode [NonEmpty String]
msgs = do GE x
geThing <- GenMode -> [NonEmpty String] -> Gen (GE x)
f GenMode
mode [NonEmpty String]
msgs; forall (f :: * -> *) a. Applicative f => a -> f a
pure @Gen (forall (f :: * -> *) a. Applicative f => a -> f a
pure @m GE x
geThing)

-- | Ignore all kinds of Errors, by squashing them into Nothing
tryGenT :: MonadGenError m => GenT GE a -> GenT m (Maybe a)
tryGenT :: forall (m :: * -> *) a.
MonadGenError m =>
GenT GE a -> GenT m (Maybe a)
tryGenT GenT GE a
g = do
  GE a
r <- GenT GE a -> GenT m (GE a)
forall (m :: * -> *) x.
MonadGenError m =>
GenT GE x -> GenT m (GE x)
inspect GenT GE a
g
  case GE a
r of
    FatalError NonEmpty (NonEmpty String)
_ -> Maybe a -> GenT m (Maybe a)
forall a. a -> GenT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    GenError NonEmpty (NonEmpty String)
_ -> Maybe a -> GenT m (Maybe a)
forall a. a -> GenT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    Result a
a -> Maybe a -> GenT m (Maybe a)
forall a. a -> GenT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> GenT m (Maybe a)) -> Maybe a -> GenT m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a

-- Pass on the error messages of both kinds of Errors, by squashing and combining both of them into Left constructor
catchGenT :: MonadGenError m => GenT GE a -> GenT m (Either (NonEmpty (NonEmpty String)) a)
catchGenT :: forall (m :: * -> *) a.
MonadGenError m =>
GenT GE a -> GenT m (Either (NonEmpty (NonEmpty String)) a)
catchGenT GenT GE a
g = do
  GE a
r <- GenT GE a -> GenT m (GE a)
forall (m :: * -> *) x.
MonadGenError m =>
GenT GE x -> GenT m (GE x)
inspect GenT GE a
g
  case GE a
r of
    FatalError NonEmpty (NonEmpty String)
es -> Either (NonEmpty (NonEmpty String)) a
-> GenT m (Either (NonEmpty (NonEmpty String)) a)
forall a. a -> GenT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (NonEmpty (NonEmpty String)) a
 -> GenT m (Either (NonEmpty (NonEmpty String)) a))
-> Either (NonEmpty (NonEmpty String)) a
-> GenT m (Either (NonEmpty (NonEmpty String)) a)
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty String) -> Either (NonEmpty (NonEmpty String)) a
forall a b. a -> Either a b
Left NonEmpty (NonEmpty String)
es
    GenError NonEmpty (NonEmpty String)
es -> Either (NonEmpty (NonEmpty String)) a
-> GenT m (Either (NonEmpty (NonEmpty String)) a)
forall a. a -> GenT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (NonEmpty (NonEmpty String)) a
 -> GenT m (Either (NonEmpty (NonEmpty String)) a))
-> Either (NonEmpty (NonEmpty String)) a
-> GenT m (Either (NonEmpty (NonEmpty String)) a)
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty String) -> Either (NonEmpty (NonEmpty String)) a
forall a b. a -> Either a b
Left NonEmpty (NonEmpty String)
es
    Result a
a -> Either (NonEmpty (NonEmpty String)) a
-> GenT m (Either (NonEmpty (NonEmpty String)) a)
forall a. a -> GenT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (NonEmpty (NonEmpty String)) a
 -> GenT m (Either (NonEmpty (NonEmpty String)) a))
-> Either (NonEmpty (NonEmpty String)) a
-> GenT m (Either (NonEmpty (NonEmpty String)) a)
forall a b. (a -> b) -> a -> b
$ a -> Either (NonEmpty (NonEmpty String)) a
forall a b. b -> Either a b
Right a
a

-- | Pass on the error messages of both kinds of Errors in the Gen (not the GenT) monad
catchGen :: GenT GE a -> Gen (Either (NonEmpty (NonEmpty String)) a)
catchGen :: forall a. GenT GE a -> Gen (Either (NonEmpty (NonEmpty String)) a)
catchGen GenT GE a
g = GenT GE (Either (NonEmpty (NonEmpty String)) a)
-> Gen (Either (NonEmpty (NonEmpty String)) a)
forall a. GenT GE a -> Gen a
genFromGenT (GenT GE a -> GenT GE (Either (NonEmpty (NonEmpty String)) a)
forall (m :: * -> *) a.
MonadGenError m =>
GenT GE a -> GenT m (Either (NonEmpty (NonEmpty String)) a)
catchGenT GenT GE a
g)

-- | Return the first successfull result from a list of computations, if they all fail
--   return a list of the error messages from each one.
firstGenT ::
  forall m a. MonadGenError m => [GenT GE a] -> GenT m (Either [(NonEmpty (NonEmpty String))] a)
firstGenT :: forall (m :: * -> *) a.
MonadGenError m =>
[GenT GE a] -> GenT m (Either [NonEmpty (NonEmpty String)] a)
firstGenT [GenT GE a]
gs = [GenT GE a]
-> [NonEmpty (NonEmpty String)]
-> GenT m (Either [NonEmpty (NonEmpty String)] a)
loop [GenT GE a]
gs []
  where
    loop ::
      [GenT GE a] -> [NonEmpty (NonEmpty String)] -> GenT m (Either [NonEmpty (NonEmpty String)] a)
    loop :: [GenT GE a]
-> [NonEmpty (NonEmpty String)]
-> GenT m (Either [NonEmpty (NonEmpty String)] a)
loop [] [NonEmpty (NonEmpty String)]
ys = Either [NonEmpty (NonEmpty String)] a
-> GenT m (Either [NonEmpty (NonEmpty String)] a)
forall a. a -> GenT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([NonEmpty (NonEmpty String)]
-> Either [NonEmpty (NonEmpty String)] a
forall a b. a -> Either a b
Left ([NonEmpty (NonEmpty String)] -> [NonEmpty (NonEmpty String)]
forall a. [a] -> [a]
reverse [NonEmpty (NonEmpty String)]
ys))
    loop (GenT GE a
x : [GenT GE a]
xs) [NonEmpty (NonEmpty String)]
ys = do
      Either (NonEmpty (NonEmpty String)) a
this <- GenT GE a -> GenT m (Either (NonEmpty (NonEmpty String)) a)
forall (m :: * -> *) a.
MonadGenError m =>
GenT GE a -> GenT m (Either (NonEmpty (NonEmpty String)) a)
catchGenT GenT GE a
x
      case Either (NonEmpty (NonEmpty String)) a
this of
        Left NonEmpty (NonEmpty String)
zs -> [GenT GE a]
-> [NonEmpty (NonEmpty String)]
-> GenT m (Either [NonEmpty (NonEmpty String)] a)
loop [GenT GE a]
xs (NonEmpty (NonEmpty String)
zs NonEmpty (NonEmpty String)
-> [NonEmpty (NonEmpty String)] -> [NonEmpty (NonEmpty String)]
forall a. a -> [a] -> [a]
: [NonEmpty (NonEmpty String)]
ys)
        Right a
a -> Either [NonEmpty (NonEmpty String)] a
-> GenT m (Either [NonEmpty (NonEmpty String)] a)
forall a. a -> GenT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either [NonEmpty (NonEmpty String)] a
forall a b. b -> Either a b
Right a
a)

liftGen :: forall x. (forall m. MonadGenError m => GenT m x) -> GenT GE x
liftGen :: forall x.
(forall (m :: * -> *). MonadGenError m => GenT m x) -> GenT GE x
liftGen forall (m :: * -> *). MonadGenError m => GenT m x
x = GenT GE x
forall (m :: * -> *). MonadGenError m => GenT m x
x

-- Drop a (GenT GE) computation into a (GenT m) computation.
-- Depending on the monad 'm' Some error information might be lost as
-- the monad m might fold FatalError's and GenError's together.
dropGen :: MonadGenError m => GenT GE a -> GenT m a
dropGen :: forall (m :: * -> *) a. MonadGenError m => GenT GE a -> GenT m a
dropGen GenT GE a
y = do
  GE a
r <- GenT GE a -> GenT m (GE a)
forall (m :: * -> *) x.
MonadGenError m =>
GenT GE x -> GenT m (GE x)
inspect GenT GE a
y
  case GE a
r of
    FatalError NonEmpty (NonEmpty String)
es -> NonEmpty (NonEmpty String) -> GenT m a
forall a. HasCallStack => NonEmpty (NonEmpty String) -> GenT m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
fatalErrors NonEmpty (NonEmpty String)
es
    GenError NonEmpty (NonEmpty String)
es -> NonEmpty (NonEmpty String) -> GenT m a
forall a. HasCallStack => NonEmpty (NonEmpty String) -> GenT m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
genErrors NonEmpty (NonEmpty String)
es
    Result a
a -> a -> GenT m a
forall a. a -> GenT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- | Run one of the actions with frequency proportional to the count. If it fails, run the other.
frequency2 :: forall m a. MonadGenError m => (Int, GenT GE a) -> (Int, GenT GE a) -> GenT m a
frequency2 :: forall (m :: * -> *) a.
MonadGenError m =>
(Int, GenT GE a) -> (Int, GenT GE a) -> GenT m a
frequency2 (Int
n, GenT GE a
g1) (Int
m, GenT GE a
g2)
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> GenT m a
forall (m :: * -> *) a. MonadGenError m => String -> m a
fatalError (String -> GenT m a) -> String -> GenT m a
forall a b. (a -> b) -> a -> b
$ String
"Non positive frequencies in frequency2 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
forall a. Show a => a -> String
show (Int
n, Int
m)
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = GenT GE a -> GenT m a
forall (m :: * -> *) a. MonadGenError m => GenT GE a -> GenT m a
dropGen GenT GE a
g2
  | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = GenT GE a -> GenT m a
forall (m :: * -> *) a. MonadGenError m => GenT GE a -> GenT m a
dropGen GenT GE a
g1
  | Bool
True = do
      Int
i <- Gen Int -> GenT m Int
forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen (Gen Int -> GenT m Int) -> Gen Int -> GenT m Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m)
      Either [NonEmpty (NonEmpty String)] a
ans <- if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n then [GenT GE a] -> GenT m (Either [NonEmpty (NonEmpty String)] a)
forall (m :: * -> *) a.
MonadGenError m =>
[GenT GE a] -> GenT m (Either [NonEmpty (NonEmpty String)] a)
firstGenT [GenT GE a
g1, GenT GE a
g2] else [GenT GE a] -> GenT m (Either [NonEmpty (NonEmpty String)] a)
forall (m :: * -> *) a.
MonadGenError m =>
[GenT GE a] -> GenT m (Either [NonEmpty (NonEmpty String)] a)
firstGenT [GenT GE a
g2, GenT GE a
g1]
      case Either [NonEmpty (NonEmpty String)] a
ans of
        Left [NonEmpty (NonEmpty String)]
_ -> String -> GenT m a
forall (m :: * -> *) a. MonadGenError m => String -> m a
fatalError String
"Both branches of frequency2 fail"
        Right a
x -> a -> GenT m a
forall a. a -> GenT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

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

-- | like explain for GenT, but uses [String] rather than (NonEmpty String)
--   if the list is null, it becomes the identity
push :: forall m a. MonadGenError m => [String] -> m a -> m a
push :: forall (m :: * -> *) a. MonadGenError m => [String] -> m a -> m a
push [] m a
m = m a
m
push (String
x : [String]
xs) m a
m = NonEmpty String -> m a -> m a
forall a. HasCallStack => NonEmpty String -> m a -> m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a -> m a
explainNE (String
x String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String]
xs) m a
m

-- | like explain for GE, but uses [String] rather than (NonEmpty String)
--   if the list is null, it becomes the identity
pushGE :: forall a. [String] -> GE a -> GE a
pushGE :: forall a. [String] -> GE a -> GE a
pushGE [] GE a
x = GE a
x
pushGE (String
x : [String]
xs) GE a
m = NonEmpty String -> GE a -> GE a
forall a. HasCallStack => NonEmpty String -> GE a -> GE a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a -> m a
explainNE (String
x String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String]
xs) GE a
m