    {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables,
                 GeneralizedNewtypeDeriving, DeriveDataTypeable #-}

    -- TODO: Can we pattern match on functions?
    -- What about functions of several arguments? Can we have interleaved
    -- pattern matching? Do we need to use currying to achieve this? What
    -- limitations does that lead to?
    -- TODO: getMatches: What happens with infinite input? Hmm... We do want the
    -- possibility of non-termination, right?
    -- TODO: getMatches: Frequencies?
    -- TODO: match: Document limitations. Can functions be handled?

    -- |
    -- Module      :  Test.ChasingBottoms.ContinuousFunctions
    -- Copyright   :  (c) Nils Anders Danielsson 2005-2022
    -- License     :  See the file LICENCE.
    --
    -- Maintainer  :  http://www.cse.chalmers.se/~nad/
    -- Stability   :  experimental
    -- Portability :  non-portable (GHC-specific)
    --
    -- Note: /This module is unfinished and experimental. However, I do not think that I will ever finish it, so I have released it in its current state. The documentation below may not be completely correct. The source code lists some things which should be addressed./
    --
    -- A framework for generating possibly non-strict, partial,
    -- continuous functions.
    --
    -- The functions generated using the standard QuickCheck 'Arbitrary'
    -- instances are all strict. In the presence of partial and infinite
    -- values testing using only strict functions leads to worse coverage
    -- than if more general functions are used, though.
    --
    -- Using 'isBottom' it is relatively easy to generate possibly
    -- non-strict functions that are, in general, not monotone. For
    -- instance, using
    --
    -- > type Cogen a = forall b. a -> Gen b -> Gen b
    -- >
    -- > integer :: Gen Integer
    -- > integer = frequency [ (1, return bottom), (10, arbitrary) ]
    -- >
    -- > coBool :: CoGen Bool
    -- > coBool b | isBottom b = variant 0
    -- > coBool False          = variant 1
    -- > coBool True           = variant 2
    -- >
    -- > function :: Cogen a -> Gen b -> Gen (a -> b)
    -- > function coGen gen = promote (\a -> coGen a gen)
    --
    -- we can generate possibly non-strict functions from 'Bool' to
    -- 'Integer' using @function coBool integer@. There is a high
    -- likelihood that the functions generated are not monotone, though.
    -- The reason that we can get non-monotone functions in a language
    -- like Haskell is that we are using the impure function 'isBottom'.
    --
    -- Sometimes using possibly non-monotone functions is good enough,
    -- since that set of functions is a superset of the continuous
    -- functions. However, say that we want to test that @x 'O.<=!' y@
    -- implies that @f x 'O.<=!' f y@ for all functions @f@ (whenever the
    -- latter expression returns a total result). This property is not
    -- valid in the presence of non-monotone functions.
    --
    -- By avoiding 'isBottom' and, unlike the standard 'coarbitrary'
    -- functions, deferring some pattern matches, we can generate
    -- continuous, possibly non-strict functions. There are two steps
    -- involved in generating a continuous function using the framework
    -- defined here.
    --
    -- (1) First the argument to the function is turned into a
    --     'PatternMatch'. A 'PatternMatch' wraps up the pattern match on
    --     the top-level constructor of the argument, plus all further
    --     pattern matches on the children of the argument. Just like when
    --     'coarbitrary' is used a pattern match is represented as a
    --     generator transformer. The difference here is that there is not
    --     just one transformation per input, but one transformation per
    --     constructor in the input. 'PatternMatch'es can be constructed
    --     generically using 'match'.
    --
    -- (2) Then the result is generated, almost like for a normal
    --     'Arbitrary' instance. However, for each constructor generated a
    --     subset of the transformations from step 1 are applied. This
    --     transformation application is wrapped up in the function
    --     'transform'.
    --
    -- The net result of this is that some pattern matches are performed
    -- later, or not at all, so functions can be lazy.
    --
    -- Here is an example illustrating typical use of this framework:
    --
    -- > data Tree a
    -- >   = Branch (Tree a) (Tree a)
    -- >   | Leaf a
    -- >     deriving (Show, Typeable, Data)
    -- >
    -- > finiteTreeOf :: MakeResult a -> MakeResult (Tree a)
    -- > finiteTreeOf makeResult = sized' tree
    -- >   where
    -- >   tree size = transform $
    -- >     if size == 0 then
    -- >       baseCase
    -- >      else
    -- >       frequency' [ (1, baseCase)
    -- >                  , (1, liftM2 Branch tree' tree')
    -- >                  ]
    -- >     where
    -- >     tree' = tree (size `div` 2)
    -- >
    -- >     baseCase =
    -- >       frequency' [ (1, return bottom)
    -- >                  , (2, liftM Leaf makeResult)
    -- >                  ]
    --
    -- Note the use of 'transform'. To use this function to generate
    -- functions of type @Bool -> Tree Integer@ we can use
    --
    -- > forAll (functionTo (finiteTreeOf flat)) $
    -- >   \(f :: Bool -> Tree Integer) ->
    -- >     ...

    module Test.ChasingBottoms.ContinuousFunctions
      ( -- * Basic framework
        function
      , functionTo
      , PatternMatch(..)
      , GenTransformer
      , MakePM
      , MakeResult
      , transform
        -- * Liftings of some QuickCheck functionality
      , lift'
      , arbitrary'
      , choose'
      , elements'
      , oneof'
      , frequency'
      , sized'
      , resize'
        -- * Generic @MakePM@
      , match
        -- * Some @MakeResult@s
      , flat
      , finiteListOf
      , infiniteListOf
      , listOf
      ) where

    import Test.QuickCheck
      hiding ( (><)
             , listOf
             , infiniteListOf
             , function
             )
    import Test.QuickCheck.Arbitrary (CoArbitrary(..))
    import Test.QuickCheck.Gen.Unsafe (promote)
    import Data.Sequence as Seq
    import Data.Foldable as Seq (foldr)
    import Prelude as P hiding (concat)
    import Test.ChasingBottoms.IsBottom
    import Control.Monad
    import Control.Monad.Reader
    import Control.Applicative
    import Control.Arrow
    import System.Random
    import Data.Generics
    import qualified Data.List as L

    import qualified Test.ChasingBottoms.SemanticOrd as O

    ------------------------------------------------------------------------
    -- Generation of functions

    -- | Generator for continuous, not necessarily strict functions.
    -- Functions are generated by first generating pattern matches, and
    -- then generating a result.

    function :: MakePM a -> MakeResult b -> Gen (a -> b)
    function :: forall a b. MakePM a -> MakeResult b -> Gen (a -> b)
    function MakePM a
    makePM MakeResult b
    makeResult =
       (a -> Gen b) -> Gen (a -> b)
    forall (m :: * -> *) a. Monad m => m (Gen a) -> Gen (m a)
    promote ((a -> Gen b) -> Gen (a -> b)) -> (a -> Gen b) -> Gen (a -> b)
    forall a b. (a -> b) -> a -> b
    $ \a
    a -> MakeResult b -> PatternMatches -> Gen b
    forall a. MakeResult a -> PatternMatches -> Gen a
    run MakeResult b
    makeResult (PatternMatch -> PatternMatches
    forall a. a -> Seq a
    singleton (PatternMatch -> PatternMatches) -> PatternMatch -> PatternMatches
    forall a b. (a -> b) -> a -> b
    $ MakePM a
    makePM a
    a)

    -- | 'functionTo' specialises 'function':
    --
    -- @
    --  'functionTo' = 'function' 'match'
    -- @

    functionTo :: Data a => MakeResult b -> Gen (a -> b)
    functionTo :: forall a b. Data a => MakeResult b -> Gen (a -> b)
    functionTo = MakePM a -> MakeResult b -> Gen (a -> b)
    forall a b. MakePM a -> MakeResult b -> Gen (a -> b)
    function MakePM a
    forall a. Data a => MakePM a
    match

    ------------------------------------------------------------------------
    -- Pattern matching

    -- | 'PatternMatch' packages up the possible outcomes of a pattern
    -- match in a style suitable for generating functions. A pattern match
    -- is a generator ('Gen') transformer based on the top-level
    -- constructor, and a sequence of 'PatternMatch'es based on the
    -- children of that constructor.

    data PatternMatch
      = PatternMatch { PatternMatch -> GenTransformer
    apply :: GenTransformer
                       -- ^ A generator transformer, in the style of 'coarbitrary'.
                     , PatternMatch -> PatternMatches
    more :: Seq PatternMatch
                       -- ^ Further pattern matches made possible by this
                       -- match.
                     }

    -- | The type of a generator transformer.

    type GenTransformer = forall a. Gen a -> Gen a

    -- | This newtype is (currently) necessary if we want to use
    -- 'GenTransformer' as an argument to a type constructor.

    newtype GenTransformer' = GenT GenTransformer

    -- | The type of a 'PatternMatch' generator.

    type MakePM a = a -> PatternMatch

    ------------------------------------------------------------------------
    -- Generic MakePM

    -- These functions provided inspiration for the generic one below.

    matchFlat :: CoArbitrary a => MakePM a
    matchFlat :: forall a. CoArbitrary a => MakePM a
    matchFlat a
    a = PatternMatch { apply :: GenTransformer
    apply = a -> Gen a -> Gen a
    forall b. a -> Gen b -> Gen b
    forall a b. CoArbitrary a => a -> Gen b -> Gen b
    coarbitrary a
    a, more :: PatternMatches
    more = PatternMatches
    forall a. Seq a
    Seq.empty }

    data Tree a
       = Branch (Tree a) (Tree a)
       | Leaf a
         deriving (Int -> Tree a -> ShowS
    [Tree a] -> ShowS
    Tree a -> String
    (Int -> Tree a -> ShowS)
    -> (Tree a -> String) -> ([Tree a] -> ShowS) -> Show (Tree a)
    forall a. Show a => Int -> Tree a -> ShowS
    forall a. Show a => [Tree a] -> ShowS
    forall a. Show a => Tree a -> String
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: forall a. Show a => Int -> Tree a -> ShowS
    showsPrec :: Int -> Tree a -> ShowS
    $cshow :: forall a. Show a => Tree a -> String
    show :: Tree a -> String
    $cshowList :: forall a. Show a => [Tree a] -> ShowS
    showList :: [Tree a] -> ShowS
    Show, Typeable, Typeable (Tree a)
    Typeable (Tree a)
    -> (forall (c :: * -> *).
        (forall d b. Data d => c (d -> b) -> d -> c b)
        -> (forall g. g -> c g) -> Tree a -> c (Tree a))
    -> (forall (c :: * -> *).
        (forall b r. Data b => c (b -> r) -> c r)
        -> (forall r. r -> c r) -> Constr -> c (Tree a))
    -> (Tree a -> Constr)
    -> (Tree a -> DataType)
    -> (forall (t :: * -> *) (c :: * -> *).
        Typeable t =>
        (forall d. Data d => c (t d)) -> Maybe (c (Tree a)))
    -> (forall (t :: * -> * -> *) (c :: * -> *).
        Typeable t =>
        (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Tree a)))
    -> ((forall b. Data b => b -> b) -> Tree a -> Tree a)
    -> (forall r r'.
        (r -> r' -> r)
        -> r -> (forall d. Data d => d -> r') -> Tree a -> r)
    -> (forall r r'.
        (r' -> r -> r)
        -> r -> (forall d. Data d => d -> r') -> Tree a -> r)
    -> (forall u. (forall d. Data d => d -> u) -> Tree a -> [u])
    -> (forall u. Int -> (forall d. Data d => d -> u) -> Tree a -> u)
    -> (forall (m :: * -> *).
        Monad m =>
        (forall d. Data d => d -> m d) -> Tree a -> m (Tree a))
    -> (forall (m :: * -> *).
        MonadPlus m =>
        (forall d. Data d => d -> m d) -> Tree a -> m (Tree a))
    -> (forall (m :: * -> *).
        MonadPlus m =>
        (forall d. Data d => d -> m d) -> Tree a -> m (Tree a))
    -> Data (Tree a)
    Tree a -> Constr
    Tree a -> DataType
    (forall b. Data b => b -> b) -> Tree a -> Tree a
    forall {a}. Data a => Typeable (Tree a)
    forall a. Data a => Tree a -> Constr
    forall a. Data a => Tree a -> DataType
    forall a.
    Data a =>
    (forall b. Data b => b -> b) -> Tree a -> Tree a
    forall a u.
    Data a =>
    Int -> (forall d. Data d => d -> u) -> Tree a -> u
    forall a u. Data a => (forall d. Data d => d -> u) -> Tree a -> [u]
    forall a r r'.
    Data a =>
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Tree a -> r
    forall a r r'.
    Data a =>
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Tree a -> r
    forall a (m :: * -> *).
    (Data a, Monad m) =>
    (forall d. Data d => d -> m d) -> Tree a -> m (Tree a)
    forall a (m :: * -> *).
    (Data a, MonadPlus m) =>
    (forall d. Data d => d -> m d) -> Tree a -> m (Tree a)
    forall a (c :: * -> *).
    Data a =>
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Tree a)
    forall a (c :: * -> *).
    Data a =>
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Tree a -> c (Tree a)
    forall a (t :: * -> *) (c :: * -> *).
    (Data a, Typeable t) =>
    (forall d. Data d => c (t d)) -> Maybe (c (Tree a))
    forall a (t :: * -> * -> *) (c :: * -> *).
    (Data a, Typeable t) =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Tree a))
    forall a.
    Typeable a
    -> (forall (c :: * -> *).
        (forall d b. Data d => c (d -> b) -> d -> c b)
        -> (forall g. g -> c g) -> a -> c a)
    -> (forall (c :: * -> *).
        (forall b r. Data b => c (b -> r) -> c r)
        -> (forall r. r -> c r) -> Constr -> c a)
    -> (a -> Constr)
    -> (a -> DataType)
    -> (forall (t :: * -> *) (c :: * -> *).
        Typeable t =>
        (forall d. Data d => c (t d)) -> Maybe (c a))
    -> (forall (t :: * -> * -> *) (c :: * -> *).
        Typeable t =>
        (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
    -> ((forall b. Data b => b -> b) -> a -> a)
    -> (forall r r'.
        (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
    -> (forall r r'.
        (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
    -> (forall u. (forall d. Data d => d -> u) -> a -> [u])
    -> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
    -> (forall (m :: * -> *).
        Monad m =>
        (forall d. Data d => d -> m d) -> a -> m a)
    -> (forall (m :: * -> *).
        MonadPlus m =>
        (forall d. Data d => d -> m d) -> a -> m a)
    -> (forall (m :: * -> *).
        MonadPlus m =>
        (forall d. Data d => d -> m d) -> a -> m a)
    -> Data a
    forall u. Int -> (forall d. Data d => d -> u) -> Tree a -> u
    forall u. (forall d. Data d => d -> u) -> Tree a -> [u]
    forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Tree a -> r
    forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Tree a -> r
    forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Tree a -> m (Tree a)
    forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Tree a -> m (Tree a)
    forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Tree a)
    forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Tree a -> c (Tree a)
    forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Tree a))
    forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Tree a))
    $cgfoldl :: forall a (c :: * -> *).
    Data a =>
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Tree a -> c (Tree a)
    gfoldl :: forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Tree a -> c (Tree a)
    $cgunfold :: forall a (c :: * -> *).
    Data a =>
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Tree a)
    gunfold :: forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Tree a)
    $ctoConstr :: forall a. Data a => Tree a -> Constr
    toConstr :: Tree a -> Constr
    $cdataTypeOf :: forall a. Data a => Tree a -> DataType
    dataTypeOf :: Tree a -> DataType
    $cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
    (Data a, Typeable t) =>
    (forall d. Data d => c (t d)) -> Maybe (c (Tree a))
    dataCast1 :: forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Tree a))
    $cdataCast2 :: forall a (t :: * -> * -> *) (c :: * -> *).
    (Data a, Typeable t) =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Tree a))
    dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Tree a))
    $cgmapT :: forall a.
    Data a =>
    (forall b. Data b => b -> b) -> Tree a -> Tree a
    gmapT :: (forall b. Data b => b -> b) -> Tree a -> Tree a
    $cgmapQl :: forall a r r'.
    Data a =>
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Tree a -> r
    gmapQl :: forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Tree a -> r
    $cgmapQr :: forall a r r'.
    Data a =>
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Tree a -> r
    gmapQr :: forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Tree a -> r
    $cgmapQ :: forall a u. Data a => (forall d. Data d => d -> u) -> Tree a -> [u]
    gmapQ :: forall u. (forall d. Data d => d -> u) -> Tree a -> [u]
    $cgmapQi :: forall a u.
    Data a =>
    Int -> (forall d. Data d => d -> u) -> Tree a -> u
    gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Tree a -> u
    $cgmapM :: forall a (m :: * -> *).
    (Data a, Monad m) =>
    (forall d. Data d => d -> m d) -> Tree a -> m (Tree a)
    gmapM :: forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Tree a -> m (Tree a)
    $cgmapMp :: forall a (m :: * -> *).
    (Data a, MonadPlus m) =>
    (forall d. Data d => d -> m d) -> Tree a -> m (Tree a)
    gmapMp :: forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Tree a -> m (Tree a)
    $cgmapMo :: forall a (m :: * -> *).
    (Data a, MonadPlus m) =>
    (forall d. Data d => d -> m d) -> Tree a -> m (Tree a)
    gmapMo :: forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Tree a -> m (Tree a)
    Data)

    matchTree :: MakePM a -> MakePM (Tree a)
    matchTree :: forall a. MakePM a -> MakePM (Tree a)
    matchTree MakePM a
    match Tree a
    t = PatternMatch { apply :: GenTransformer
    apply = Tree a -> Gen a -> Gen a
    forall {a} {a}. Tree a -> Gen a -> Gen a
    toVariant Tree a
    t, more :: PatternMatches
    more = Tree a -> PatternMatches
    moreT Tree a
    t }
      where
      toVariant :: Tree a -> Gen a -> Gen a
    toVariant (Branch {}) = Integer -> Gen a -> Gen a
    forall n a. Integral n => n -> Gen a -> Gen a
    variant Integer
    1
      toVariant (Leaf {})   = Integer -> Gen a -> Gen a
    forall n a. Integral n => n -> Gen a -> Gen a
    variant Integer
    0

      moreT :: Tree a -> PatternMatches
    moreT (Branch Tree a
    l Tree a
    r) = [PatternMatch] -> PatternMatches
    forall a. [a] -> Seq a
    fromList [MakePM a -> MakePM (Tree a)
    forall a. MakePM a -> MakePM (Tree a)
    matchTree MakePM a
    match Tree a
    l, MakePM a -> MakePM (Tree a)
    forall a. MakePM a -> MakePM (Tree a)
    matchTree MakePM a
    match Tree a
    r]
      moreT (Leaf a
    x)     = PatternMatch -> PatternMatches
    forall a. a -> Seq a
    singleton (MakePM a
    match a
    x)

    -- | Generic implementation of 'PatternMatch' construction.

    match :: forall a. Data a => MakePM a
    match :: forall a. Data a => MakePM a
    match a
    x = PatternMatch
                { apply :: GenTransformer
    apply = a -> Gen a -> Gen a
    forall a b. Data a => a -> Gen b -> Gen b
    toVariant a
    x
                , more :: PatternMatches
    more  = a -> PatternMatches
    forall a. Data a => a -> PatternMatches
    more a
    x
                }
      where
      toVariant :: forall a b. Data a => a -> Gen b -> Gen b
      toVariant :: forall a b. Data a => a -> Gen b -> Gen b
    toVariant a
    x = case Constr -> ConstrRep
    constrRep (a -> Constr
    forall a. Data a => a -> Constr
    toConstr a
    x) of
        AlgConstr Int
    n   -> Int -> Gen b -> Gen b
    forall n a. Integral n => n -> Gen a -> Gen a
    variant (Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1)  -- n >= 1.
        IntConstr Integer
    i   -> Integer -> Gen b -> Gen b
    forall b. Integer -> Gen b -> Gen b
    forall a b. CoArbitrary a => a -> Gen b -> Gen b
    coarbitrary Integer
    i
        FloatConstr Rational
    d -> Rational -> Gen b -> Gen b
    forall b. Rational -> Gen b -> Gen b
    forall a b. CoArbitrary a => a -> Gen b -> Gen b
    coarbitrary Rational
    d
        CharConstr Char
    s  -> String -> Gen b -> Gen b
    forall a. String -> a
    nonBottomError String
    "match: Encountered CharConstr."

      more :: forall a. Data a => a -> Seq PatternMatch
      more :: forall a. Data a => a -> PatternMatches
    more = (PatternMatch -> PatternMatches -> PatternMatches)
    -> PatternMatches
    -> (forall a. Data a => MakePM a)
    -> a
    -> PatternMatches
    forall a r r'.
    Data a =>
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
    forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
    gmapQr PatternMatch -> PatternMatches -> PatternMatches
    forall a. a -> Seq a -> Seq a
    (<|) PatternMatches
    forall a. Seq a
    Seq.empty MakePM d
    forall a. Data a => MakePM a
    match

    ------------------------------------------------------------------------
    -- MakeResult monad

    -- | Monad for generating results given previously generated pattern
    -- matches.
    --
    -- A @'MakeResult' a@ should be implemented almost as other generators for
    -- the type @a@, with the difference that 'transform' should be
    -- used wherever the resulting function should be allowed to pattern
    -- match (typically for each constructor emitted). See example above.

    -- Note that we do not want to export a 'MonadReader' instance, so we
    -- cannot define one...

    newtype MakeResult a
      = MR { forall a. MakeResult a -> ReaderT PatternMatches Gen a
    unMR :: ReaderT PatternMatches Gen a }
        deriving ((forall a b. (a -> b) -> MakeResult a -> MakeResult b)
    -> (forall a b. a -> MakeResult b -> MakeResult a)
    -> Functor MakeResult
    forall a b. a -> MakeResult b -> MakeResult a
    forall a b. (a -> b) -> MakeResult a -> MakeResult 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) -> MakeResult a -> MakeResult b
    fmap :: forall a b. (a -> b) -> MakeResult a -> MakeResult b
    $c<$ :: forall a b. a -> MakeResult b -> MakeResult a
    <$ :: forall a b. a -> MakeResult b -> MakeResult a
    Functor, Functor MakeResult
    Functor MakeResult
    -> (forall a. a -> MakeResult a)
    -> (forall a b.
        MakeResult (a -> b) -> MakeResult a -> MakeResult b)
    -> (forall a b c.
        (a -> b -> c) -> MakeResult a -> MakeResult b -> MakeResult c)
    -> (forall a b. MakeResult a -> MakeResult b -> MakeResult b)
    -> (forall a b. MakeResult a -> MakeResult b -> MakeResult a)
    -> Applicative MakeResult
    forall a. a -> MakeResult a
    forall a b. MakeResult a -> MakeResult b -> MakeResult a
    forall a b. MakeResult a -> MakeResult b -> MakeResult b
    forall a b. MakeResult (a -> b) -> MakeResult a -> MakeResult b
    forall a b c.
    (a -> b -> c) -> MakeResult a -> MakeResult b -> MakeResult c
    forall (f :: * -> *).
    Functor f
    -> (forall a. a -> f a)
    -> (forall a b. f (a -> b) -> f a -> f b)
    -> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
    -> (forall a b. f a -> f b -> f b)
    -> (forall a b. f a -> f b -> f a)
    -> Applicative f
    $cpure :: forall a. a -> MakeResult a
    pure :: forall a. a -> MakeResult a
    $c<*> :: forall a b. MakeResult (a -> b) -> MakeResult a -> MakeResult b
    <*> :: forall a b. MakeResult (a -> b) -> MakeResult a -> MakeResult b
    $cliftA2 :: forall a b c.
    (a -> b -> c) -> MakeResult a -> MakeResult b -> MakeResult c
    liftA2 :: forall a b c.
    (a -> b -> c) -> MakeResult a -> MakeResult b -> MakeResult c
    $c*> :: forall a b. MakeResult a -> MakeResult b -> MakeResult b
    *> :: forall a b. MakeResult a -> MakeResult b -> MakeResult b
    $c<* :: forall a b. MakeResult a -> MakeResult b -> MakeResult a
    <* :: forall a b. MakeResult a -> MakeResult b -> MakeResult a
    Applicative, Applicative MakeResult
    Applicative MakeResult
    -> (forall a b.
        MakeResult a -> (a -> MakeResult b) -> MakeResult b)
    -> (forall a b. MakeResult a -> MakeResult b -> MakeResult b)
    -> (forall a. a -> MakeResult a)
    -> Monad MakeResult
    forall a. a -> MakeResult a
    forall a b. MakeResult a -> MakeResult b -> MakeResult b
    forall a b. MakeResult a -> (a -> MakeResult b) -> MakeResult b
    forall (m :: * -> *).
    Applicative m
    -> (forall a b. m a -> (a -> m b) -> m b)
    -> (forall a b. m a -> m b -> m b)
    -> (forall a. a -> m a)
    -> Monad m
    $c>>= :: forall a b. MakeResult a -> (a -> MakeResult b) -> MakeResult b
    >>= :: forall a b. MakeResult a -> (a -> MakeResult b) -> MakeResult b
    $c>> :: forall a b. MakeResult a -> MakeResult b -> MakeResult b
    >> :: forall a b. MakeResult a -> MakeResult b -> MakeResult b
    $creturn :: forall a. a -> MakeResult a
    return :: forall a. a -> MakeResult a
    Monad)

    type PatternMatches = Seq PatternMatch

    -- | Lowering of a 'MakeResult'.

    run :: MakeResult a -> PatternMatches -> Gen a
    run :: forall a. MakeResult a -> PatternMatches -> Gen a
    run MakeResult a
    mr PatternMatches
    pms = ReaderT PatternMatches Gen a -> PatternMatches -> Gen a
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
    runReaderT (MakeResult a -> ReaderT PatternMatches Gen a
    forall a. MakeResult a -> ReaderT PatternMatches Gen a
    unMR MakeResult a
    mr) PatternMatches
    pms

    -- | Lifting of a 'Gen'.

    lift' :: Gen a -> MakeResult a
    lift' :: forall a. Gen a -> MakeResult a
    lift' Gen a
    gen = ReaderT PatternMatches Gen a -> MakeResult a
    forall a. ReaderT PatternMatches Gen a -> MakeResult a
    MR (ReaderT PatternMatches Gen a -> MakeResult a)
    -> ReaderT PatternMatches Gen a -> MakeResult a
    forall a b. (a -> b) -> a -> b
    $ Gen a -> ReaderT PatternMatches Gen a
    forall (m :: * -> *) a.
    Monad m =>
    m a -> ReaderT PatternMatches m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift Gen a
    gen

    -- | Returns the 'PatternMatches' in scope.

    getPMs :: MakeResult PatternMatches
    getPMs :: MakeResult PatternMatches
    getPMs = ReaderT PatternMatches Gen PatternMatches
    -> MakeResult PatternMatches
    forall a. ReaderT PatternMatches Gen a -> MakeResult a
    MR ReaderT PatternMatches Gen PatternMatches
    forall r (m :: * -> *). MonadReader r m => m r
    ask

    withPMs :: (PatternMatches -> Gen a) -> MakeResult a
    withPMs :: forall a. (PatternMatches -> Gen a) -> MakeResult a
    withPMs PatternMatches -> Gen a
    f = do
      PatternMatches
    pms <- MakeResult PatternMatches
    getPMs
      Gen a -> MakeResult a
    forall a. Gen a -> MakeResult a
    lift' (Gen a -> MakeResult a) -> Gen a -> MakeResult a
    forall a b. (a -> b) -> a -> b
    $ PatternMatches -> Gen a
    f PatternMatches
    pms

    -- | 'transform' makes sure that the pattern matches get to influence
    -- the generated value. See 'MakeResult'.

    transform :: MakeResult a -> MakeResult a
    transform :: forall a. MakeResult a -> MakeResult a
    transform MakeResult a
    makeResult = (PatternMatches -> Gen a) -> MakeResult a
    forall a. (PatternMatches -> Gen a) -> MakeResult a
    withPMs ((PatternMatches -> Gen a) -> MakeResult a)
    -> (PatternMatches -> Gen a) -> MakeResult a
    forall a b. (a -> b) -> a -> b
    $ \PatternMatches
    pms -> do
      (GenT GenTransformer
    trans, PatternMatches
    keep) <- PatternMatches -> Gen (GenTransformer', PatternMatches)
    getMatches PatternMatches
    pms
      Gen a -> Gen a
    GenTransformer
    trans (MakeResult a -> PatternMatches -> Gen a
    forall a. MakeResult a -> PatternMatches -> Gen a
    run MakeResult a
    makeResult PatternMatches
    keep)

    -- | Extracts some pattern matches to trigger right away. These
    -- triggered pattern matches may result in new pattern matches which
    -- may in turn also be triggered, and so on.

    getMatches :: Seq PatternMatch -> Gen (GenTransformer', Seq PatternMatch)
    getMatches :: PatternMatches -> Gen (GenTransformer', PatternMatches)
    getMatches PatternMatches
    pms = do
      -- Throw away pattern matches with probability 0.1.
      (PatternMatches
    _, PatternMatches
    pms') <- Int -> PatternMatches -> Gen (PatternMatches, PatternMatches)
    forall a. Int -> Seq a -> Gen (Seq a, Seq a)
    partition' Int
    9 PatternMatches
    pms
      -- Use pattern matches with probability 0.33.
      (PatternMatches
    use, PatternMatches
    keep) <- Int -> PatternMatches -> Gen (PatternMatches, PatternMatches)
    forall a. Int -> Seq a -> Gen (Seq a, Seq a)
    partition' Int
    2 PatternMatches
    pms'
      let transform :: Gen a -> Gen a
    transform = Seq (Gen a -> Gen a) -> Gen a -> Gen a
    forall a. Seq (a -> a) -> a -> a
    compose (Seq (Gen a -> Gen a) -> Gen a -> Gen a)
    -> Seq (Gen a -> Gen a) -> Gen a -> Gen a
    forall a b. (a -> b) -> a -> b
    $ (PatternMatch -> Gen a -> Gen a)
    -> PatternMatches -> Seq (Gen a -> Gen a)
    forall a b. (a -> b) -> Seq a -> Seq b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\PatternMatch
    pm -> PatternMatch -> GenTransformer
    apply PatternMatch
    pm) PatternMatches
    use
          further :: PatternMatches
    further = Seq PatternMatches -> PatternMatches
    forall a. Seq (Seq a) -> Seq a
    concat (Seq PatternMatches -> PatternMatches)
    -> Seq PatternMatches -> PatternMatches
    forall a b. (a -> b) -> a -> b
    $ (PatternMatch -> PatternMatches)
    -> PatternMatches -> Seq PatternMatches
    forall a b. (a -> b) -> Seq a -> Seq b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap PatternMatch -> PatternMatches
    more PatternMatches
    use
      if PatternMatches -> Bool
    forall a. Seq a -> Bool
    Seq.null PatternMatches
    further then
        (GenTransformer', PatternMatches)
    -> Gen (GenTransformer', PatternMatches)
    forall a. a -> Gen a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (GenTransformer -> GenTransformer'
    GenT Gen a -> Gen a
    GenTransformer
    transform, PatternMatches
    keep)
       else do
        (GenT GenTransformer
    transform', PatternMatches
    keep') <- PatternMatches -> Gen (GenTransformer', PatternMatches)
    getMatches PatternMatches
    further
        (GenTransformer', PatternMatches)
    -> Gen (GenTransformer', PatternMatches)
    forall a. a -> Gen a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (GenTransformer -> GenTransformer'
    GenT (Gen a -> Gen a
    GenTransformer
    transform (Gen a -> Gen a) -> (Gen a -> Gen a) -> Gen a -> Gen a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Gen a -> Gen a
    GenTransformer
    transform'), PatternMatches
    keep PatternMatches -> PatternMatches -> PatternMatches
    forall a. Seq a -> Seq a -> Seq a
    >< PatternMatches
    keep')

    ------------------------------------------------------------------------
    -- Sequence helpers

    -- | Concatenates arguments.

    concat :: Seq (Seq a) -> Seq a
    concat :: forall a. Seq (Seq a) -> Seq a
    concat = (Seq a -> Seq a -> Seq a) -> Seq a -> Seq (Seq a) -> Seq a
    forall a b. (a -> b -> b) -> b -> Seq a -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    Seq.foldr Seq a -> Seq a -> Seq a
    forall a. Seq a -> Seq a -> Seq a
    (><) Seq a
    forall a. Seq a
    Seq.empty

    -- | Composes arguments.

    compose :: Seq (a -> a) -> a -> a
    compose :: forall a. Seq (a -> a) -> a -> a
    compose = ((a -> a) -> (a -> a) -> a -> a)
    -> (a -> a) -> Seq (a -> a) -> a -> a
    forall a b. (a -> b -> b) -> b -> Seq a -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    Seq.foldr (a -> a) -> (a -> a) -> a -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    (.) a -> a
    forall a. a -> a
    id

    -- | Partitions a 'Seq'. The first argument (a positive integer) is
    -- the relative probability with which elements end up in the second
    -- part compared to the first one.

    partition' :: Int -> Seq a -> Gen (Seq a, Seq a)
    partition' :: forall a. Int -> Seq a -> Gen (Seq a, Seq a)
    partition' Int
    freq Seq a
    ss = case Seq a -> ViewL a
    forall a. Seq a -> ViewL a
    viewl Seq a
    ss of
      ViewL a
    EmptyL  -> (Seq a, Seq a) -> Gen (Seq a, Seq a)
    forall a. a -> Gen a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Seq a
    forall a. Seq a
    Seq.empty, Seq a
    forall a. Seq a
    Seq.empty)
      a
    x :< Seq a
    xs -> do
        (Seq a
    ys, Seq a
    zs) <- Int -> Seq a -> Gen (Seq a, Seq a)
    forall a. Int -> Seq a -> Gen (Seq a, Seq a)
    partition' Int
    freq Seq a
    xs
        [(Int, Gen (Seq a, Seq a))] -> Gen (Seq a, Seq a)
    forall a. [(Int, Gen a)] -> Gen a
    frequency [ (Int
    1,    (Seq a, Seq a) -> Gen (Seq a, Seq a)
    forall a. a -> Gen a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    x a -> Seq a -> Seq a
    forall a. a -> Seq a -> Seq a
    <| Seq a
    ys, Seq a
    zs))
                  , (Int
    freq, (Seq a, Seq a) -> Gen (Seq a, Seq a)
    forall a. a -> Gen a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Seq a
    ys, a
    x a -> Seq a -> Seq a
    forall a. a -> Seq a -> Seq a
    <| Seq a
    zs))
                  ]

    ------------------------------------------------------------------------
    -- Lifting of QuickCheck's Gen monad

    -- | Lifting of 'arbitrary'.

    arbitrary' :: Arbitrary a => MakeResult a
    arbitrary' :: forall a. Arbitrary a => MakeResult a
    arbitrary' = Gen a -> MakeResult a
    forall a. Gen a -> MakeResult a
    lift' Gen a
    forall a. Arbitrary a => Gen a
    arbitrary

    -- | Lifting of 'choose'.

    choose' :: Random a => (a, a) -> MakeResult a
    choose' :: forall a. Random a => (a, a) -> MakeResult a
    choose' = Gen a -> MakeResult a
    forall a. Gen a -> MakeResult a
    lift' (Gen a -> MakeResult a)
    -> ((a, a) -> Gen a) -> (a, a) -> MakeResult a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a, a) -> Gen a
    forall a. Random a => (a, a) -> Gen a
    choose

    -- | Lifting of 'elements'.

    elements' :: [a] -> MakeResult a
    elements' :: forall a. [a] -> MakeResult a
    elements' = Gen a -> MakeResult a
    forall a. Gen a -> MakeResult a
    lift' (Gen a -> MakeResult a) -> ([a] -> Gen a) -> [a] -> MakeResult a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [a] -> Gen a
    forall a. [a] -> Gen a
    elements

    -- | Lifting of 'oneof'.

    oneof' :: [MakeResult a] -> MakeResult a
    oneof' :: forall a. [MakeResult a] -> MakeResult a
    oneof' [MakeResult a]
    mrs = (PatternMatches -> Gen a) -> MakeResult a
    forall a. (PatternMatches -> Gen a) -> MakeResult a
    withPMs ((PatternMatches -> Gen a) -> MakeResult a)
    -> (PatternMatches -> Gen a) -> MakeResult a
    forall a b. (a -> b) -> a -> b
    $ \PatternMatches
    pms -> [Gen a] -> Gen a
    forall a. [Gen a] -> Gen a
    oneof ([Gen a] -> Gen a) -> [Gen a] -> Gen a
    forall a b. (a -> b) -> a -> b
    $ (MakeResult a -> Gen a) -> [MakeResult a] -> [Gen a]
    forall a b. (a -> b) -> [a] -> [b]
    map (\MakeResult a
    mr -> MakeResult a -> PatternMatches -> Gen a
    forall a. MakeResult a -> PatternMatches -> Gen a
    run MakeResult a
    mr PatternMatches
    pms) [MakeResult a]
    mrs

    -- | Lifting of 'frequency'.

    frequency' :: [(Int, MakeResult a)] -> MakeResult a
    frequency' :: forall a. [(Int, MakeResult a)] -> MakeResult a
    frequency' [(Int, MakeResult a)]
    freqs = (PatternMatches -> Gen a) -> MakeResult a
    forall a. (PatternMatches -> Gen a) -> MakeResult a
    withPMs ((PatternMatches -> Gen a) -> MakeResult a)
    -> (PatternMatches -> Gen a) -> MakeResult a
    forall a b. (a -> b) -> a -> b
    $ \PatternMatches
    pms ->
      [(Int, Gen a)] -> Gen a
    forall a. [(Int, Gen a)] -> Gen a
    frequency ([(Int, Gen a)] -> Gen a) -> [(Int, Gen a)] -> Gen a
    forall a b. (a -> b) -> a -> b
    $ ((Int, MakeResult a) -> (Int, Gen a))
    -> [(Int, MakeResult a)] -> [(Int, Gen a)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> Int
    forall a. a -> a
    id (Int -> Int)
    -> (MakeResult a -> Gen a) -> (Int, MakeResult a) -> (Int, Gen a)
    forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
    forall (a :: * -> * -> *) b c b' c'.
    Arrow a =>
    a b c -> a b' c' -> a (b, b') (c, c')
    *** (MakeResult a -> PatternMatches -> Gen a)
    -> PatternMatches -> MakeResult a -> Gen a
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip MakeResult a -> PatternMatches -> Gen a
    forall a. MakeResult a -> PatternMatches -> Gen a
    run PatternMatches
    pms) [(Int, MakeResult a)]
    freqs

    -- | Lifting of 'sized'.

    sized' :: (Int -> MakeResult a) -> MakeResult a
    sized' :: forall a. (Int -> MakeResult a) -> MakeResult a
    sized' Int -> MakeResult a
    mr = (PatternMatches -> Gen a) -> MakeResult a
    forall a. (PatternMatches -> Gen a) -> MakeResult a
    withPMs ((PatternMatches -> Gen a) -> MakeResult a)
    -> (PatternMatches -> Gen a) -> MakeResult a
    forall a b. (a -> b) -> a -> b
    $ \PatternMatches
    pms -> (Int -> Gen a) -> Gen a
    forall a. (Int -> Gen a) -> Gen a
    sized (\Int
    size -> MakeResult a -> PatternMatches -> Gen a
    forall a. MakeResult a -> PatternMatches -> Gen a
    run (Int -> MakeResult a
    mr Int
    size) PatternMatches
    pms)

    -- | Lifting of 'resize'.

    resize' :: Int -> MakeResult a -> MakeResult a
    resize' :: forall a. Int -> MakeResult a -> MakeResult a
    resize' Int
    n MakeResult a
    mr = (PatternMatches -> Gen a) -> MakeResult a
    forall a. (PatternMatches -> Gen a) -> MakeResult a
    withPMs ((PatternMatches -> Gen a) -> MakeResult a)
    -> (PatternMatches -> Gen a) -> MakeResult a
    forall a b. (a -> b) -> a -> b
    $ \PatternMatches
    pms -> Int -> Gen a -> Gen a
    forall a. Int -> Gen a -> Gen a
    resize Int
    n (MakeResult a -> PatternMatches -> Gen a
    forall a. MakeResult a -> PatternMatches -> Gen a
    run MakeResult a
    mr PatternMatches
    pms)

    ------------------------------------------------------------------------
    -- Some predefined generators

    -- | An implementation of @'MakeResult' a@ which is suitable when @a@
    -- is flat and has an 'Arbitrary' instance. Yields bottoms around 10%
    -- of the time.

    flat :: Arbitrary a => MakeResult a
    flat :: forall a. Arbitrary a => MakeResult a
    flat = MakeResult a -> MakeResult a
    forall a. MakeResult a -> MakeResult a
    transform (MakeResult a -> MakeResult a) -> MakeResult a -> MakeResult a
    forall a b. (a -> b) -> a -> b
    $
      [(Int, MakeResult a)] -> MakeResult a
    forall a. [(Int, MakeResult a)] -> MakeResult a
    frequency' [ (Int
    1, a -> MakeResult a
    forall a. a -> MakeResult a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    forall a. a
    bottom)
                 , (Int
    9, MakeResult a
    forall a. Arbitrary a => MakeResult a
    arbitrary')
                 ]

    -- | This 'MakeResult' yields finite partial lists.

    finiteListOf :: MakeResult a -> MakeResult [a]
    finiteListOf :: forall a. MakeResult a -> MakeResult [a]
    finiteListOf MakeResult a
    makeResult = (Int -> MakeResult [a]) -> MakeResult [a]
    forall a. (Int -> MakeResult a) -> MakeResult a
    sized' Int -> MakeResult [a]
    forall {t}. (Eq t, Num t) => t -> MakeResult [a]
    list
        where
        list :: t -> MakeResult [a]
    list t
    size = MakeResult [a] -> MakeResult [a]
    forall a. MakeResult a -> MakeResult a
    transform (MakeResult [a] -> MakeResult [a])
    -> MakeResult [a] -> MakeResult [a]
    forall a b. (a -> b) -> a -> b
    $
          if t
    size t -> t -> Bool
    forall a. Eq a => a -> a -> Bool
    == t
    0 then
            MakeResult [a]
    forall {a}. MakeResult [a]
    baseCase
           else
            [(Int, MakeResult [a])] -> MakeResult [a]
    forall a. [(Int, MakeResult a)] -> MakeResult a
    frequency' [ (Int
    1, MakeResult [a]
    forall {a}. MakeResult [a]
    baseCase)
                       , (Int
    9, (a -> [a] -> [a])
    -> MakeResult a -> MakeResult [a] -> MakeResult [a]
    forall (m :: * -> *) a1 a2 r.
    Monad m =>
    (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
    liftM2 (:) MakeResult a
    makeResult (t -> MakeResult [a]
    list (t
    size t -> t -> t
    forall a. Num a => a -> a -> a
    - t
    1)))
                       ]

        baseCase :: MakeResult [a]
    baseCase =
          [(Int, MakeResult [a])] -> MakeResult [a]
    forall a. [(Int, MakeResult a)] -> MakeResult a
    frequency' [(Int
    1, [a] -> MakeResult [a]
    forall a. a -> MakeResult a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [a]
    forall a. a
    bottom), (Int
    1, [a] -> MakeResult [a]
    forall a. a -> MakeResult a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [])]

    -- | This 'MakeResult' yields infinite partial lists.

    infiniteListOf :: MakeResult a -> MakeResult [a]
    infiniteListOf :: forall a. MakeResult a -> MakeResult [a]
    infiniteListOf MakeResult a
    makeResult = MakeResult [a] -> MakeResult [a]
    forall a. MakeResult a -> MakeResult a
    transform (MakeResult [a] -> MakeResult [a])
    -> MakeResult [a] -> MakeResult [a]
    forall a b. (a -> b) -> a -> b
    $
      (a -> [a] -> [a])
    -> MakeResult a -> MakeResult [a] -> MakeResult [a]
    forall (m :: * -> *) a1 a2 r.
    Monad m =>
    (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
    liftM2 (:) MakeResult a
    makeResult (MakeResult a -> MakeResult [a]
    forall a. MakeResult a -> MakeResult [a]
    infiniteListOf MakeResult a
    makeResult)

    -- | This 'MakeResult' yields finite or infinite partial lists.

    listOf :: MakeResult a -> MakeResult [a]
                        -- Not really necessary to have a transform here...
    listOf :: forall a. MakeResult a -> MakeResult [a]
    listOf MakeResult a
    makeResult = MakeResult [a] -> MakeResult [a]
    forall a. MakeResult a -> MakeResult a
    transform (MakeResult [a] -> MakeResult [a])
    -> MakeResult [a] -> MakeResult [a]
    forall a b. (a -> b) -> a -> b
    $
       [MakeResult [a]] -> MakeResult [a]
    forall a. [MakeResult a] -> MakeResult a
    oneof' [ MakeResult a -> MakeResult [a]
    forall a. MakeResult a -> MakeResult [a]
    finiteListOf MakeResult a
    makeResult
              , MakeResult a -> MakeResult [a]
    forall a. MakeResult a -> MakeResult [a]
    infiniteListOf MakeResult a
    makeResult
              ]

    ------------------------------------------------------------------------
    -- Failed attempt at a generic implementation of MakeResult

    -- Main problem: Getting the frequencies right. Lists are very short
    -- right now.

    -- Other problem: Int and Float.

    -- Further remark: We need finite and infinite versions of this
    -- function.

    makeResult :: forall a. Data a => MakeResult a
    makeResult :: forall a. Data a => MakeResult a
    makeResult = MakeResult a -> MakeResult a
    forall a. MakeResult a -> MakeResult a
    transform ([(Int, MakeResult a)] -> MakeResult a
    forall a. [(Int, MakeResult a)] -> MakeResult a
    frequency' ([(Int, MakeResult a)] -> MakeResult a)
    -> [(Int, MakeResult a)] -> MakeResult a
    forall a b. (a -> b) -> a -> b
    $ (Int
    1, a -> MakeResult a
    forall a. a -> MakeResult a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    forall a. a
    bottom) (Int, MakeResult a)
    -> [(Int, MakeResult a)] -> [(Int, MakeResult a)]
    forall a. a -> [a] -> [a]
    : [(Int, MakeResult a)]
    others)
      where
      others :: [(Int, MakeResult a)]
    others = case DataType -> DataRep
    dataTypeRep (a -> DataType
    forall a. Data a => a -> DataType
    dataTypeOf (a
    forall a. HasCallStack => a
    undefined :: a)) of
                 AlgRep [Constr]
    constrs ->
                   (Constr -> (Int, MakeResult a))
    -> [Constr] -> [(Int, MakeResult a)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Double -> Constr -> (Int, MakeResult a)
    forall {p} {a}.
    (RealFrac p, Integral a) =>
    p -> Constr -> (a, MakeResult a)
    handle ([Constr] -> Double
    forall i a. Num i => [a] -> i
    L.genericLength [Constr]
    constrs)) [Constr]
    constrs
                 DataRep
    IntRep         -> [(Int
    9, MakeResult Integer -> MakeResult a
    forall {f :: * -> *} {a} {b}.
    (Functor f, Typeable a, Typeable b) =>
    f a -> f b
    cast' (MakeResult Integer
    forall a. Arbitrary a => MakeResult a
    arbitrary' :: MakeResult Integer))]
                 DataRep
    FloatRep       -> [(Int
    9, MakeResult Double -> MakeResult a
    forall {f :: * -> *} {a} {b}.
    (Functor f, Typeable a, Typeable b) =>
    f a -> f b
    cast' (MakeResult Double
    forall a. Arbitrary a => MakeResult a
    arbitrary' :: MakeResult Double))]
                 DataRep
    CharRep        -> String -> [(Int, MakeResult a)]
    forall a. String -> a
    nonBottomError String
    "makeResult: CharRep."
                 DataRep
    NoRep          -> String -> [(Int, MakeResult a)]
    forall a. String -> a
    nonBottomError String
    "makeResult: NoRep."

      handle :: p -> Constr -> (a, MakeResult a)
    handle p
    noConstrs Constr
    con =
        (a
    freq, (forall a. Data a => MakeResult a) -> Constr -> MakeResult a
    forall (m :: * -> *) a.
    (Monad m, Data a) =>
    (forall d. Data d => m d) -> Constr -> m a
    fromConstrM MakeResult d
    forall a. Data a => MakeResult a
    makeResult Constr
    con :: MakeResult a)
        where noArgs :: Int
    noArgs = a -> Int
    GenericQ Int
    glength (Constr -> a
    forall a. Data a => Constr -> a
    fromConstr Constr
    con :: a)
              -- Aim for at most 10% bottoms (on average).
              freq :: a
    freq = a
    1 a -> a -> a
    forall a. Ord a => a -> a -> a
    `max` p -> a
    forall b. Integral b => p -> b
    forall a b. (RealFrac a, Integral b) => a -> b
    ceiling (p
    9 p -> p -> p
    forall a. Fractional a => a -> a -> a
    / p
    noConstrs)

      cast' :: f a -> f b
    cast' f a
    gen = ((a -> b) -> f a -> f b) -> f a -> (a -> b) -> f b
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (a -> b) -> f a -> f b
    forall a b. (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap f a
    gen ((a -> b) -> f b) -> (a -> b) -> f b
    forall a b. (a -> b) -> a -> b
    $ \a
    x -> case a -> Maybe b
    forall a b. (Typeable a, Typeable b) => a -> Maybe b
    cast a
    x of
        Just b
    x' -> b
    x'
        Maybe b
    Nothing -> String -> b
    forall a. String -> a
    nonBottomError (String -> b) -> String -> b
    forall a b. (a -> b) -> a -> b
    $
                     String
    "makeResult: Cannot handle Int and Float." String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
                     String
    " Use Integer or Double instead."