{-# 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. HasCallStack => [(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. HasCallStack => [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. HasCallStack => [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. HasCallStack => [(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. HasCallStack => 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."