{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PartialTypeSignatures #-}

module Data.Registry.Internal.Hedgehog
  ( Chooser (..),
    chooseOne,
    choiceChooser,
    -- utilities
    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)

-- | Lift a pure generator into another monad like IO
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)

-- * CHOOSING VALUES DETERMINISTICALLY

-- | Given a choosing strategy pick a generator
--   This is possibly a stateful operation
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

-- | Chooser for randomly selecting a generator
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}

-- | A "chooser" strategy
--   The type can be used to debug specializations
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)

-- * UTILITIES

-- | Sample Gen values
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)