{-# 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 a. Identity a -> m a) -> GenT Identity a -> GenT m a
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 (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> (Identity a -> a) -> Identity a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> a
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 :: Text -> (forall a. [Gen a] -> Gen a) -> Chooser
Chooser {chooserType :: Text
chooserType = Text
"choice", pickOne :: forall a. [Gen a] -> Gen a
pickOne = forall a. [Gen a] -> Gen a
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 = Text -> String
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
then Text -> IO a
forall a. HasCallStack => Text -> a
panic Text
"Hedgehog.Gen.sample: too many discards, could not generate a sample"
else do
Seed
seed <- IO Seed
forall (m :: * -> *). MonadIO m => m Seed
Seed.random
NodeT Maybe a
r [TreeT IO (Maybe a)]
_ <- TreeT IO (Maybe a) -> IO (NodeT IO (Maybe a))
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT (TreeT IO (Maybe a) -> IO (NodeT IO (Maybe a)))
-> TreeT IO (Maybe a) -> IO (NodeT IO (Maybe a))
forall a b. (a -> b) -> a -> b
$ Size -> Seed -> GenT IO a -> TreeT IO (Maybe a)
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
Just a
a ->
a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
in Int -> IO a
loop (Int
100 :: Int)