{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Registry.Hedgehog (
GenIO
, Chooser (..)
, forallS
, forAllT
, filterGenS
, genFun
, genVal
, genWith
, modifyGenS
, setGen
, setGenIO
, setGenS
, specializeGen
, specializeGenIO
, specializeGenS
, tweakGen
, tweakGenS
, makeNonEmpty
, makeNonEmptyS
, eitherOf
, hashMapOf
, listOf
, listOfMinMax
, mapOf
, maybeOf
, nonEmptyMapOf
, nonEmptyOf
, pairOf
, setOf
, tripleOf
, choiceChooser
, chooseOne
, setCycleChooser
, setCycleChooserS
, distinct
, setDistinct
, setDistinctFor
, setDistinctForS
, setDistinctS
, sampleIO
) where
import Control.Monad.Morph
import Data.HashMap.Strict as HashMap (HashMap, fromList)
import Data.IORef
import Data.List.NonEmpty hiding (cycle, nonEmpty, (!!))
import Data.Map as Map (fromList)
import Data.Maybe as Maybe
import Data.Registry
import Data.Registry.Internal.Hedgehog
import Data.Registry.Internal.Types
import Data.Set as Set (fromList)
import Hedgehog
import Hedgehog.Gen as Gen
import Hedgehog.Internal.Gen as Gen
import Hedgehog.Internal.Property (forAllT)
import Hedgehog.Range
import Protolude as P
genFun :: forall a b . (ApplyVariadic GenIO a b, Typeable a, Typeable b) => a -> Typed b
genFun = funTo @GenIO
genVal :: forall a . (Typeable a) => Gen a -> Typed (GenIO a)
genVal g = fun (liftGen g)
genWith :: forall a ins out . (Typeable a) => Registry ins out -> GenIO a
genWith = makeUnsafe @(GenIO a)
tweakGen :: forall a ins out . (Typeable a) => (a -> a) -> Registry ins out -> Registry ins out
tweakGen f = tweakUnsafe @(GenIO a) (\genA -> f <$> genA)
tweakGenS :: forall a m ins out . (Typeable a, MonadState (Registry ins out) m) => (a -> a) -> m ()
tweakGenS f = modify (tweakGen f)
setGen :: forall a ins out . (Typeable a) => Gen a -> Registry ins out -> Registry ins out
setGen = setGenIO . liftGen
setGenIO :: forall a ins out . (Typeable a) => GenIO a -> Registry ins out -> Registry ins out
setGenIO genA = tweakUnsafe @(GenIO a) (const genA)
setGenS :: forall a m ins out . (Typeable a, MonadState (Registry ins out) m) => Gen a -> m ()
setGenS genA = modify (setGen genA)
specializeGen :: forall a b ins out . (Typeable a, Typeable b, Contains (GenIO a) out) => Gen b -> Registry ins out -> Registry ins out
specializeGen g = specializeGenIO @a (liftGen g)
specializeGenIO :: forall a b ins out . (Typeable a, Typeable b, Contains (GenIO a) out) => GenIO b -> Registry ins out -> Registry ins out
specializeGenIO = specialize @(GenIO a)
specializeGenS :: forall a b m ins out . (Typeable a, Typeable b, Contains (GenIO a) out, MonadState (Registry ins out) m) => Gen b -> m ()
specializeGenS g = modify (specializeGen @a @b g)
modifyGenS :: forall a ins out . (Typeable a) => (GenIO a -> GenIO a) -> PropertyT (StateT (Registry ins out) IO) ()
modifyGenS f = modify (tweakUnsafe @(GenIO a) f)
filterGenS :: forall a ins out . (Typeable a) => (a -> Bool) -> PropertyT (StateT (Registry ins out) IO) ()
filterGenS = modifyGenS . Gen.filterT
forallS :: forall a m out . (Typeable a, Show a, MonadIO m) => PropertyT (StateT (Registry _ out) m) a
forallS = do
r <- P.lift $ get
withFrozenCallStack $ hoist liftIO $ forAllT (genWith @a r)
makeNonEmpty :: forall a ins out . (Typeable a) => Registry ins out -> Registry ins out
makeNonEmpty r =
let genA = genWith @a r
in tweakUnsafe @(GenIO [a]) (\genAs -> (:) <$> genA <*> genAs) r
makeNonEmptyS :: forall a m ins out . (Typeable a, MonadState (Registry ins out) m) => m ()
makeNonEmptyS = modify (makeNonEmpty @a)
pairOf :: forall a b . GenIO a -> GenIO b -> GenIO (a, b)
pairOf ga gb = (,) <$> ga <*> gb
tripleOf :: forall a b c . GenIO a -> GenIO b -> GenIO c -> GenIO (a, b, c)
tripleOf ga gb gc = (,,) <$> ga <*> gb <*> gc
listOf :: forall a . GenIO a -> GenIO [a]
listOf = Gen.list (linear 0 10)
listOfMinMax :: forall a . Int -> Int -> GenIO a -> GenIO [a]
listOfMinMax min' max' = Gen.list (linear min' max')
nonEmptyOf :: GenIO a -> GenIO (NonEmpty a)
nonEmptyOf = Gen.nonEmpty (linear 1 10)
maybeOf :: forall a . GenIO a -> GenIO (Maybe a)
maybeOf genA = choice [pure Nothing, Just <$> genA]
eitherOf :: forall a b . GenIO a -> GenIO b -> GenIO (Either a b)
eitherOf genA genB = choice [Left <$> genA, Right <$> genB]
setOf :: forall a . (Ord a) => GenIO a -> GenIO (Set a)
setOf = fmap Set.fromList . listOf
mapOf :: forall k v . (Ord k) => GenIO k -> GenIO v -> GenIO (Map k v)
mapOf gk gv = Map.fromList <$> listOf (pairOf gk gv)
hashMapOf :: forall k v . (Ord k, Hashable k) => GenIO k -> GenIO v -> GenIO (HashMap k v)
hashMapOf gk gv = HashMap.fromList <$> listOf (pairOf gk gv)
nonEmptyMapOf :: forall k v . (Ord k) => GenIO k -> GenIO v -> GenIO (Map k v)
nonEmptyMapOf gk gv = do
h <- pairOf gk gv
t <- listOf (pairOf gk gv)
pure (Map.fromList (h : t))
setCycleChooser :: forall a ins out . (Typeable a, Contains (GenIO a) out) => Registry ins out -> IO (Registry ins out)
setCycleChooser r = do
c <- cycleChooser
pure $ specializeValTo @GenIO @(GenIO a) c r
setCycleChooserS :: forall a m ins out . (Typeable a, Contains (GenIO a) out, MonadState (Registry ins out) m, MonadIO m) => m ()
setCycleChooserS = do
r <- get
r' <- liftIO $ setCycleChooser @a r
put r'
setDistinct :: forall a ins out . (Eq a, Typeable a, Contains (GenIO a) out) => Registry ins out -> IO (Registry ins out)
setDistinct r = do
ref <- newIORef []
let g = makeFast @(GenIO a) r
pure $ setGenIO (distinctWith ref g) r
setDistinctS :: forall a m ins out . (Eq a, Typeable a, Contains (GenIO a) out, MonadState (Registry ins out) m, MonadIO m) => m ()
setDistinctS = do
r <- get
r' <- liftIO $ setDistinct @a r
put r'
setDistinctFor :: forall a b ins out . (Typeable a, Contains (GenIO a) out, Eq b, Typeable b, Contains (GenIO b) out) => Registry ins out -> IO (Registry ins out)
setDistinctFor r = do
ref <- newIORef []
let g = makeFast @(GenIO b) r
pure $ specializeGenIO @a (distinctWith ref g) r
setDistinctForS :: forall a b m ins out . (Typeable a, Contains (GenIO a) out, Eq b, Typeable b, Contains (GenIO b) out, MonadState (Registry ins out) m, MonadIO m) => m ()
setDistinctForS = do
r <- get
r' <- liftIO $ setDistinctFor @a @b r
put r'