{-# 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 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)

-- * 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 :: 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}

-- | 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 = Text -> String
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 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)