{-# 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 (GE a -> GE a -> Bool
GE a -> GE a -> Ordering
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
min :: GE a -> GE a -> GE a
$cmin :: forall a. Ord a => GE a -> GE a -> GE a
max :: GE a -> GE a -> GE a
$cmax :: forall a. Ord a => GE a -> GE a -> GE a
>= :: 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
$c< :: forall a. Ord a => GE a -> GE a -> Bool
compare :: GE a -> GE a -> Ordering
$ccompare :: forall a. Ord a => GE a -> GE a -> Ordering
Ord, GE a -> GE a -> Bool
forall a. Eq a => GE a -> GE a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GE a -> GE a -> Bool
$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
Eq, Int -> GE a -> ShowS
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
showList :: [GE a] -> ShowS
$cshowList :: forall a. Show a => [GE a] -> ShowS
show :: GE a -> String
$cshow :: forall a. Show a => GE a -> String
showsPrec :: Int -> GE a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> GE a -> ShowS
Show, 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
<$ :: forall a b. a -> GE b -> GE a
$c<$ :: forall a b. a -> GE b -> GE a
fmap :: forall a b. (a -> b) -> GE a -> GE b
$cfmap :: forall a b. (a -> b) -> GE a -> GE b
Functor)

instance Applicative GE where
  pure :: forall a. a -> GE a
pure = forall a. a -> GE a
Result
  <*> :: forall a 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
_ = forall a. NonEmpty (NonEmpty String) -> GE a
FatalError NonEmpty (NonEmpty String)
es
  GenError NonEmpty (NonEmpty String)
es >>= a -> 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
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
min :: GenMode -> GenMode -> GenMode
$cmin :: GenMode -> GenMode -> GenMode
max :: GenMode -> GenMode -> GenMode
$cmax :: GenMode -> GenMode -> GenMode
>= :: GenMode -> GenMode -> Bool
$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
compare :: GenMode -> GenMode -> Ordering
$ccompare :: GenMode -> GenMode -> Ordering
Ord, GenMode -> GenMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenMode -> GenMode -> Bool
$c/= :: GenMode -> GenMode -> Bool
== :: GenMode -> GenMode -> Bool
$c== :: GenMode -> GenMode -> Bool
Eq, Int -> GenMode -> ShowS
[GenMode] -> ShowS
GenMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenMode] -> ShowS
$cshowList :: [GenMode] -> ShowS
show :: GenMode -> String
$cshow :: GenMode -> String
showsPrec :: Int -> GenMode -> ShowS
$cshowsPrec :: Int -> 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 -> 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
<$ :: forall a b. a -> GenT m b -> GenT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> GenT m b -> GenT m a
fmap :: forall a b. (a -> b) -> GenT m a -> GenT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GenT m a -> GenT m b
Functor)

instance Monad m => Applicative (GenT m) where
  pure :: forall a. a -> GenT m a
pure a
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
(<*>) = 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 = forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \GenMode
mode -> \[NonEmpty String]
msgs -> forall a. (QCGen -> Int -> a) -> Gen a
MkGen forall a b. (a -> b) -> a -> b
$ \QCGen
r Int
n -> do
    let (QCGen
r1, QCGen
r2) = forall g. RandomGen g => g -> (g, g)
split QCGen
r
    a
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
    forall a. Gen a -> QCGen -> Int -> a
unGen (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 = 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 = forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a
genErrorNE forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a
fatalErrorNE forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s = forall a. a -> a
id
  | Bool
otherwise = forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a -> m a
explainNE (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 = forall a. NonEmpty (NonEmpty String) -> GE a
GenError (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 = forall a. NonEmpty (NonEmpty String) -> GE a
GenError NonEmpty (NonEmpty String)
msgs
  fatalErrorNE :: forall a. HasCallStack => NonEmpty String -> GE a
fatalErrorNE NonEmpty String
msg = forall a. NonEmpty (NonEmpty String) -> GE a
FatalError (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 = 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) = forall a. NonEmpty (NonEmpty String) -> GE a
GenError (NonEmpty String
m forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (NonEmpty String)
ms)
  explainNE NonEmpty String
m (FatalError NonEmpty (NonEmpty String)
ms) = forall a. NonEmpty (NonEmpty String) -> GE a
FatalError (NonEmpty String
m forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (NonEmpty String)
ms)
  explainNE NonEmpty String
_ (Result a
x) = 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 = forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \GenMode
_ [NonEmpty String]
xs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
genErrors (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 = forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \GenMode
_ [NonEmpty String]
xs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
genErrors (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 = forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \GenMode
_ [NonEmpty String]
xs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
fatalErrors (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 = forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \GenMode
_ [NonEmpty String]
xs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
fatalErrors (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) = forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \GenMode
mode [NonEmpty String]
es -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 [] = 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 forall a. a -> NonEmpty a -> NonEmpty a
<| (NonEmpty a
x 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 forall a. Semigroup a => a -> a -> a
<> (NonEmpty a
x 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 (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall {f :: * -> *} {a}. MonadGenError f => [a] -> [GE a] -> f [a]
go [] [GE a]
ges0
  where
    go :: [a] -> [GE a] -> f [a]
go [a]
acc [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 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 -> 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 -> forall a. HasCallStack => String -> a
error 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 -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty String) -> String
catMessages NonEmpty (NonEmpty String)
xs
  GenError NonEmpty (NonEmpty String)
xs -> forall a. HasCallStack => String -> a
error 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 -> forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
genErrors NonEmpty (NonEmpty String)
es
  FatalError NonEmpty (NonEmpty String)
es -> forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
fatalErrors NonEmpty (NonEmpty String)
es
  Result r
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 -> forall prop. Testable prop => String -> prop -> Property
counterexample (NonEmpty (NonEmpty String) -> String
catMessages NonEmpty (NonEmpty String)
es) Bool
False
  FatalError NonEmpty (NonEmpty String)
es -> forall prop. Testable prop => String -> prop -> Property
counterexample (NonEmpty (NonEmpty String) -> String
catMessages NonEmpty (NonEmpty String)
es) Bool
False
  Result p
p -> 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 -> forall prop. Testable prop => prop -> Property
property p
p
  GE p
_ -> 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]
_ <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a
t = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  | Bool
otherwise = 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 = forall a.
HasCallStack =>
(NonEmpty (NonEmpty String) -> a) -> GE a -> a
fromGE (forall a b. a -> b -> a
const []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 = forall a. GE a -> a
errorGE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) = forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \GenMode
mode [NonEmpty String]
msgs -> forall a. (Int -> Gen a) -> Gen a
sized forall a b. (a -> b) -> a -> b
$ \Int
sz -> 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 = forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \GenMode
_ [NonEmpty String]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Gen a -> Gen [a]
listOf forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
runGenT GenT GE a
gen GenMode
Loose []
  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 forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
GenT m a -> (a -> Bool) -> GenT m a
`suchThatT` Int -> Bool
validLen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length
  where
    genList :: GenT m [a]
genList = do
      [GE a]
res <- forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Gen a -> Gen [a]
vectorOf Int
goalLen forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
runGenT GenT GE a
gen GenMode
Loose []
      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 = forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \GenMode
mode [NonEmpty String]
_ -> do
  GE [a]
res <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Gen a -> Gen [a]
vectorOf Int
i forall a b. (a -> b) -> a -> b
$ 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
genErrors NonEmpty (NonEmpty String)
es
      GE [a]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 = 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 <- forall (m :: * -> *). Applicative m => GenT m GenMode
getMode
  let (Int
n, String -> GenT m a
cont) = case GenMode
mode of
        GenMode
Strict -> (Int
tries, forall (m :: * -> *) a. MonadGenError m => String -> m a
fatalError)
        GenMode
Loose -> (Int
1 :: Int, 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 (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
tries forall a. [a] -> [a] -> [a]
++ String
") on suchThatWithTryT at type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (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 forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a else forall (m :: * -> *) a. (Int -> Int) -> GenT m a -> GenT m a
scaleT (forall a. Num a => a -> a -> a
+ Int
1) forall a b. (a -> b) -> a -> b
$ Int -> (String -> GenT m a) -> GenT m a
go (Int
n 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) = forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \GenMode
mode [NonEmpty String]
msgs -> forall a. (Int -> Int) -> Gen a -> Gen a
scale Int -> Int
sc 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 = forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \GenMode
mode [NonEmpty String]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 = forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \GenMode
_ [NonEmpty String]
msgs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 = forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \GenMode
_ [NonEmpty String]
msgs -> 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 <- forall (m :: * -> *). Applicative m => GenT m GenMode
getMode
  [NonEmpty String]
msgs <- forall (m :: * -> *). Applicative m => GenT m [NonEmpty String]
getMessages
  GE a
r <-
    forall (m :: * -> *) a. MonadGenError m => String -> m a -> m a
explain String
"suchThatT in oneofT" forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen (forall a. HasCallStack => [Gen a] -> Gen a
oneof [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]) forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
GenT m a -> (a -> Bool) -> GenT m a
`suchThatT` forall a. GE a -> Bool
isOk
  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 <- forall (m :: * -> *). Applicative m => GenT m GenMode
getMode
  [NonEmpty String]
msgs <- forall (m :: * -> *). Applicative m => GenT m [NonEmpty String]
getMessages
  GE a
r <-
    forall (m :: * -> *) a. MonadGenError m => String -> m a -> m a
explain String
"suchThatT in oneofT" forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen (forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
f, 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]) forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
GenT m a -> (a -> Bool) -> GenT m a
`suchThatT` forall a. GE a -> Bool
isOk
  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 forall a. Ord a => a -> a -> Bool
< a
a = forall (m :: * -> *) a. MonadGenError m => String -> m a
genError (String
"chooseT (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
a forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
b forall a. [a] -> [a] -> [a]
++ String
")")
  | Bool
otherwise = forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a.
(GenMode -> [NonEmpty String] -> Gen (m a)) -> GenT m a
GenT forall a b. (a -> b) -> a -> b
$ \GenMode
mode [NonEmpty String]
msgs -> forall a. (Int -> Gen a) -> Gen a
sized forall a b. (a -> b) -> a -> b
$ \Int
n -> forall (m :: * -> *) a.
GenT m a -> GenMode -> [NonEmpty String] -> Gen (m a)
runGenT (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) = 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 <- 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)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    GenError NonEmpty (NonEmpty String)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Result a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 <- 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left NonEmpty (NonEmpty String)
es
    GenError NonEmpty (NonEmpty String)
es -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left NonEmpty (NonEmpty String)
es
    Result a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 = forall a. GenT GE a -> Gen a
genFromGenT (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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (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 <- 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 forall a. a -> [a] -> [a]
: [NonEmpty (NonEmpty String)]
ys)
        Right a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 = 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 <- 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 -> forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
fatalErrors NonEmpty (NonEmpty String)
es
    GenError NonEmpty (NonEmpty String)
es -> forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty (NonEmpty String) -> m a
genErrors NonEmpty (NonEmpty String)
es
    Result a
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 forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
&& Int
m forall a. Ord a => a -> a -> Bool
<= Int
0 = forall (m :: * -> *) a. MonadGenError m => String -> m a
fatalError forall a b. (a -> b) -> a -> b
$ String
"Non positive frequencies in frequency2 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
n, Int
m)
  | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = forall (m :: * -> *) a. MonadGenError m => GenT GE a -> GenT m a
dropGen GenT GE a
g2
  | Int
m forall a. Ord a => a -> a -> Bool
<= Int
0 = forall (m :: * -> *) a. MonadGenError m => GenT GE a -> GenT m a
dropGen GenT GE a
g1
  | Bool
True = do
      Int
i <- forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen forall a b. (a -> b) -> a -> b
$ forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
n forall a. Num a => a -> a -> a
+ Int
m)
      Either [NonEmpty (NonEmpty String)] a
ans <- if Int
i forall a. Ord a => a -> a -> Bool
<= Int
n then 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 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)]
_ -> forall (m :: * -> *) a. MonadGenError m => String -> m a
fatalError String
"Both branches of frequency2 fail"
        Right a
x -> 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 = forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a -> m a
explainNE (String
x 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 = forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a -> m a
explainNE (String
x forall a. a -> [a] -> NonEmpty a
:| [String]
xs) GE a
m