{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PartialTypeSignatures #-}
module Data.Registry.Internal.Hedgehog
( Chooser (..),
chooseOne,
choiceChooser,
liftGen,
sampleIO,
)
where
import Control.Monad.Morph
import Data.Maybe as Maybe
import Hedgehog
import Hedgehog.Gen as Gen
import Hedgehog.Internal.Gen as Gen
import Hedgehog.Internal.Seed as Seed (random)
import Hedgehog.Internal.Tree as Tree (NodeT (..), runTreeT)
import Protolude as P
import Prelude (show)
liftGen :: (Monad m) => Gen a -> GenT m a
liftGen :: forall (m :: * -> *) a. Monad m => Gen a -> GenT m a
liftGen = forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
(b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity)
chooseOne :: Gen Chooser -> [Gen a] -> Gen a
chooseOne :: forall a. Gen Chooser -> [Gen a] -> Gen a
chooseOne Gen Chooser
chooser [Gen a]
gs = do
Chooser
c <- Gen Chooser
chooser
Chooser -> forall a. [Gen a] -> Gen a
pickOne Chooser
c [Gen a]
gs
choiceChooser :: Chooser
choiceChooser :: Chooser
choiceChooser = Chooser {chooserType :: Text
chooserType = Text
"choice", pickOne :: forall a. [Gen a] -> Gen a
pickOne = forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice}
data Chooser = Chooser
{ Chooser -> Text
chooserType :: Text,
Chooser -> forall a. [Gen a] -> Gen a
pickOne :: forall a. [Gen a] -> Gen a
}
instance Show Chooser where
show :: Chooser -> String
show Chooser
c = forall a b. ConvertText a b => a -> b
toS (Chooser -> Text
chooserType Chooser
c)
sampleIO :: GenT IO a -> IO a
sampleIO :: forall a. GenT IO a -> IO a
sampleIO GenT IO a
gen =
let loop :: Int -> IO a
loop Int
n =
if Int
n forall a. Ord a => a -> a -> Bool
<= Int
0
then forall a. HasCallStack => Text -> a
panic Text
"Hedgehog.Gen.sample: too many discards, could not generate a sample"
else do
Seed
seed <- forall (m :: * -> *). MonadIO m => m Seed
Seed.random
NodeT Maybe a
r [TreeT IO (Maybe a)]
_ <- forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
Size -> Seed -> GenT m a -> TreeT m (Maybe a)
evalGenT Size
30 Seed
seed GenT IO a
gen
case Maybe a
r of
Maybe a
Nothing ->
Int -> IO a
loop (Int
n forall a. Num a => a -> a -> a
- Int
1)
Just a
a ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
in Int -> IO a
loop (Int
100 :: Int)