packages feed

registry-hedgehog 0.2.1.1 → 0.3.0.0

raw patch · 18 files changed

+822/−573 lines, 18 files

Files

registry-hedgehog.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: 8e9ef405c71b1f7fffa4735a082d31c503420e8345fd885ef0408becd6689cc4+-- hash: 5172e9a2dee2ae8064a8ddd51dbad2923b92ace8e8141381ba7b40be413c7bdb  name:           registry-hedgehog-version:        0.2.1.1+version:        0.3.0.0 synopsis:       utilities to work with Hedgehog generators and `registry` description:    This library provides some functions to extract generators from a "Registry" and make stateful modifications of that Registry to precisely control the generation of data category:       Control@@ -26,6 +26,7 @@       Data.Registry.Hedgehog.TH       Data.Registry.Internal.Hedgehog       Data.Registry.Internal.TH+      Test.Tasty.HedgehogTest       Test.Tasty.Hedgehogx   other-modules:       Paths_registry_hedgehog
src/Data/Registry/Hedgehog.hs view
@@ -1,167 +1,163 @@-{-# LANGUAGE AllowAmbiguousTypes   #-}-{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE UndecidableInstances  #-}--module Data.Registry.Hedgehog (-  -- creation / tweaking functions-  GenIO-, Chooser (..)-, forallS-, forAllT -- re-export of forAllT for convenience purpose since we are working in GenIO-, filterGenS-, genFun-, genVal-, genWith-, modifyGenS-, setGen-, setGenIO-, setGenS-, specializeGen-, specializeGenIO-, specializeGenS-, tweakGen-, tweakGenS-, makeNonEmpty-, makeNonEmptyS---- combinators to compose different types of generators-, eitherOf-, hashMapOf-, listOf-, listOfMinMax-, mapOf-, maybeOf-, nonEmptyMapOf-, nonEmptyOf-, pairOf-, setOf-, tripleOf---- cycling values-, choiceChooser-, chooseOne-, setCycleChooser-, setCycleChooserS---- making distinct values-, distinct-, setDistinct-, setDistinctFor-, setDistinctForS-, setDistinctS+{-# LANGUAGE UndecidableInstances #-} --- sampling for GenIO generators-, sampleIO-) where+module Data.Registry.Hedgehog+  ( -- creation / tweaking functions+    GenIO,+    Chooser (..),+    forallS,+    forAllT, -- re-export of forAllT for convenience purpose since we are working in GenIO+    filterGenS,+    genFun,+    genVal,+    genWith,+    modifyGenS,+    setGen,+    setGenIO,+    setGenS,+    specializeGen,+    specializeGenIO,+    specializeGenS,+    tweakGen,+    tweakGenS,+    makeNonEmpty,+    makeNonEmptyS,+    -- combinators to compose different types of generators+    eitherOf,+    hashMapOf,+    listOf,+    listOfMinMax,+    mapOf,+    maybeOf,+    nonEmptyMapOf,+    nonEmptyOf,+    pairOf,+    setOf,+    tripleOf,+    -- cycling values+    choiceChooser,+    chooseOne,+    setCycleChooser,+    setCycleChooserS,+    -- making distinct values+    distinct,+    setDistinct,+    setDistinctFor,+    setDistinctForS,+    setDistinctS,+    -- sampling for GenIO generators+    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-import           System.IO.Unsafe+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.Property (forAllT)+import Hedgehog.Range+import Protolude as P+import System.IO.Unsafe  -- * CREATION / TWEAKING OF REGISTRY GENERATORS  -- | Create a GenIO a for a given constructor of type a-genFun :: forall a b . (ApplyVariadic GenIO a b, Typeable a, Typeable b) => a -> Typed b+genFun :: forall a b. (ApplyVariadic GenIO a b, Typeable a, Typeable b) => a -> Typed b genFun = funTo @GenIO  -- | Lift a Gen a into GenIO a to be added to a registry-genVal :: forall a . (Typeable a) => Gen a -> Typed (GenIO a)+genVal :: forall a. (Typeable a) => Gen a -> Typed (GenIO a) genVal g = fun (liftGen g)  -- | Extract a generator from a registry --   We use makeUnsafe assuming that the registry has been checked before-genWith :: forall a ins out . (Typeable a) => Registry ins out -> GenIO a+genWith :: forall a ins out. (Typeable a) => Registry ins out -> GenIO a genWith = makeUnsafe @(GenIO a)  -- | Modify the value of a generator in a given registry-tweakGen :: forall a ins out . (Typeable a) => (a -> a) -> Registry ins out -> Registry ins out+tweakGen :: forall a ins out. (Typeable a) => (a -> a) -> Registry ins out -> Registry ins out tweakGen f = tweakUnsafe @(GenIO a) (\genA -> f <$> genA)  -- | Modify the registry for a given generator in a State monad-tweakGenS :: forall a m ins out . (Typeable a, MonadState (Registry ins out) m) => (a -> a) -> m ()+tweakGenS :: forall a m ins out. (Typeable a, MonadState (Registry ins out) m) => (a -> a) -> m () tweakGenS f = modify (tweakGen f)  -- | Set a specific generator on the registry the value of a generator in a given registry-setGen :: forall a ins out . (Typeable a) => Gen a -> Registry ins out -> Registry ins out+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 :: forall a ins out. (Typeable a) => GenIO a -> Registry ins out -> Registry ins out setGenIO genA = tweakUnsafe @(GenIO a) (const genA)  -- | Set a specific generator on the registry the value of a generator in a given registry in a State monad-setGenS :: forall a m ins out . (Typeable a, MonadState (Registry ins out) m) => Gen a -> m ()+setGenS :: forall a m ins out. (Typeable a, MonadState (Registry ins out) m) => Gen a -> m () setGenS genA = modify (setGen genA)  -- | Specialize a generator in a given context-specializeGen :: forall a b ins out . (Typeable a, Typeable b, Contains (GenIO a) out) => Gen b -> Registry ins out -> Registry ins out+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)  -- | Specialize a generator in a given context-specializeGenIO :: forall a b ins out . (Typeable a, Typeable b, Contains (GenIO a) out) => GenIO b -> Registry ins out -> Registry ins out+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)  -- | Specialize a generator in a given context-specializeGenS :: forall a b m ins out . (Typeable a, Typeable b, Contains (GenIO a) out, MonadState (Registry ins out) m) => Gen b -> m ()+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)  -- | Modify a generator-modifyGenS :: forall a ins out . (Typeable a) => (GenIO a -> GenIO a) -> PropertyT (StateT (Registry ins out) IO) ()+modifyGenS :: forall a ins out. (Typeable a) => (GenIO a -> GenIO a) -> PropertyT (StateT (Registry ins out) IO) () modifyGenS f = modify (tweakUnsafe @(GenIO a) f)  -- | Filter a generator-filterGenS :: forall a ins out . (Typeable a) => (a -> Bool) -> PropertyT (StateT (Registry ins out) IO) ()+filterGenS :: forall a ins out. (Typeable a) => (a -> Bool) -> PropertyT (StateT (Registry ins out) IO) () filterGenS = modifyGenS . Gen.filterT  -- | Get a value generated from one of the generators in the registry and modify the registry --   using a state monad-forallS :: forall a m out . (Typeable a, Show a, MonadIO m) => PropertyT (StateT (Registry _ out) m) a+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)  -- | Make sure there is always one element of a given type in a list of elements-makeNonEmpty :: forall a ins out . (Typeable a) => Registry ins out -> Registry ins out+makeNonEmpty :: forall a ins out. (Typeable a) => Registry ins out -> Registry ins out makeNonEmpty r =   -- extract a generator for one element only   let genA = genWith @a r-  -- add that element in front of a list of generated elements-  in  tweakUnsafe @(GenIO [a]) (\genAs -> (:) <$> genA <*> genAs) r+   in -- add that element in front of a list of generated elements+      tweakUnsafe @(GenIO [a]) (\genAs -> (:) <$> genA <*> genAs) r  -- | Make sure there is always one element of a given type in a list of elements in a State monad-makeNonEmptyS :: forall a m ins out . (Typeable a, MonadState (Registry ins out) m) => m ()+makeNonEmptyS :: forall a m ins out. (Typeable a, MonadState (Registry ins out) m) => m () makeNonEmptyS = modify (makeNonEmpty @a)  -- * CONTAINERS COMBINATORS  -- | Create a generator for a pair-pairOf :: forall a b . GenIO a -> GenIO b -> GenIO (a, b)+pairOf :: forall a b. GenIO a -> GenIO b -> GenIO (a, b) pairOf ga gb = (,) <$> ga <*> gb  -- | Create a generator for a triple-tripleOf :: forall a b c . GenIO a -> GenIO b -> GenIO c -> GenIO (a, b, c)+tripleOf :: forall a b c. GenIO a -> GenIO b -> GenIO c -> GenIO (a, b, c) tripleOf ga gb gc = (,,) <$> ga <*> gb <*> gc  -- | Create a default generator for a small list of elements-listOf :: forall a . GenIO a -> GenIO [a]+listOf :: forall a. GenIO a -> GenIO [a] listOf = Gen.list (linear 0 10)  -- | Create a default generator for a list of elements of min elements and max elements-listOfMinMax :: forall a . Int -> Int -> GenIO a -> GenIO [a]+listOfMinMax :: forall a. Int -> Int -> GenIO a -> GenIO [a] listOfMinMax min' max' = Gen.list (linear min' max')  -- | Create a default generator for a small non-empty list of elements@@ -169,27 +165,27 @@ nonEmptyOf = Gen.nonEmpty (linear 1 10)  -- | Create a default generator for a Maybe, choosing evenly between Nothing and Just-maybeOf :: forall a . GenIO a -> GenIO (Maybe a)+maybeOf :: forall a. GenIO a -> GenIO (Maybe a) maybeOf genA = choice [pure Nothing, Just <$> genA]  -- | Create a default generator for a Either, choosing evenly between Left and Right-eitherOf :: forall a b . GenIO a -> GenIO b -> GenIO (Either a b)+eitherOf :: forall a b. GenIO a -> GenIO b -> GenIO (Either a b) eitherOf genA genB = choice [Left <$> genA, Right <$> genB]  -- | Create a default generator for a small set of elements-setOf :: forall a . (Ord a) => GenIO a -> GenIO (Set a)+setOf :: forall a. (Ord a) => GenIO a -> GenIO (Set a) setOf = fmap Set.fromList . listOf  -- | Create a default generator for map of key/values-mapOf :: forall k v . (Ord k) => GenIO k -> GenIO v -> GenIO (Map k v)+mapOf :: forall k v. (Ord k) => GenIO k -> GenIO v -> GenIO (Map k v) mapOf gk gv = Map.fromList <$> listOf (pairOf gk gv)  -- | Create a default generator for HashMap of key/values-hashMapOf :: forall k v . (Ord k, Hashable k) => GenIO k -> GenIO v -> GenIO (HashMap k v)+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)  -- | Create a default generator for a small non-empty map of elements-nonEmptyMapOf :: forall k v . (Ord k) => GenIO k -> GenIO v -> GenIO (Map k v)+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)@@ -201,17 +197,18 @@  -- | Set a cycling chooser for a specific data type {-# NOINLINE setCycleChooser #-}-setCycleChooser :: forall a ins out . (Typeable a, Contains (GenIO a) out) => Registry ins out -> Registry ins out+setCycleChooser :: forall a ins out. (Typeable a, Contains (GenIO a) out) => Registry ins out -> Registry ins out setCycleChooser r = unsafePerformIO $ do   c <- cycleChooser   pure $ specializeValTo @GenIO @(GenIO a) c r  -- | Set a cycling chooser for a specific data type {-# NOINLINE setCycleChooserS #-}-setCycleChooserS :: forall a m ins out . (Typeable a, Contains (GenIO a) out, MonadState (Registry ins out) m, MonadIO m) => m ()+setCycleChooserS :: forall a m ins out. (Typeable a, Contains (GenIO a) out, MonadState (Registry ins out) m, MonadIO m) => m () setCycleChooserS =   let c = unsafePerformIO cycleChooser-  in do r <- get+   in do+        r <- get         let r' = specializeValTo @GenIO @(GenIO a) c r         put r' @@ -219,30 +216,30 @@  -- | Generate distinct values for a specific data type {-# NOINLINE setDistinct #-}-setDistinct :: forall a ins out . (Eq a, Typeable a, Contains (GenIO a) out) => Registry ins out -> Registry ins out+setDistinct :: forall a ins out. (Eq a, Typeable a, Contains (GenIO a) out) => Registry ins out -> Registry ins out setDistinct = setDistinctWithRef @a (unsafePerformIO $ newIORef []) -setDistinctWithRef :: forall a ins out . (Eq a, Typeable a, Contains (GenIO a) out) => IORef [a] -> Registry ins out -> Registry ins out+setDistinctWithRef :: forall a ins out. (Eq a, Typeable a, Contains (GenIO a) out) => IORef [a] -> Registry ins out -> Registry ins out setDistinctWithRef ref r = setGenIO (distinctWith ref (makeFast @(GenIO a) r)) r  -- | Generate distinct values for a specific data type {-# NOINLINE setDistinctS #-}-setDistinctS :: forall a m ins out . (Eq a, Typeable a, Contains (GenIO a) out, MonadState (Registry ins out) m, MonadIO m) => m ()+setDistinctS :: forall a m ins out. (Eq a, Typeable a, Contains (GenIO a) out, MonadState (Registry ins out) m, MonadIO m) => m () setDistinctS =   let ref = unsafePerformIO $ newIORef []-  in  modify (setDistinctWithRef @a ref)+   in modify (setDistinctWithRef @a ref)  -- | Generate distinct values for a specific data type, when used inside another data type {-# NOINLINE setDistinctFor #-}-setDistinctFor :: forall a b ins out . (Typeable a, Contains (GenIO a) out, Eq b, Typeable b, Contains (GenIO b) out) => Registry ins out -> Registry ins out+setDistinctFor :: forall a b ins out. (Typeable a, Contains (GenIO a) out, Eq b, Typeable b, Contains (GenIO b) out) => Registry ins out -> Registry ins out setDistinctFor = setDistinctForWithRef @a @b (unsafePerformIO $ newIORef []) -setDistinctForWithRef :: forall a b ins out . (Typeable a, Contains (GenIO a) out, Eq b, Typeable b, Contains (GenIO b) out) => IORef [b] -> Registry ins out -> Registry ins out+setDistinctForWithRef :: forall a b ins out. (Typeable a, Contains (GenIO a) out, Eq b, Typeable b, Contains (GenIO b) out) => IORef [b] -> Registry ins out -> Registry ins out setDistinctForWithRef ref r = specializeGenIO @a (distinctWith ref (makeFast @(GenIO b) r)) r  -- | Generate distinct values for a specific data type, when used inside another data type {-# NOINLINE setDistinctForS #-}-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 :: 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 =   let ref = unsafePerformIO $ newIORef []-  in  modify (setDistinctForWithRef @a @b ref)+   in modify (setDistinctForWithRef @a @b ref)
src/Data/Registry/Hedgehog/TH.hs view
@@ -1,14 +1,14 @@-{-# LANGUAGE DataKinds       #-}-{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}  module Data.Registry.Hedgehog.TH where -import           Control.Monad.Fail              (fail)-import           Data.Registry.Internal.TH-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax-import           Protolude+import Control.Monad.Fail (fail)+import Data.Registry.Internal.TH+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Protolude  -- | Make a registry containing generators for an ADT --   We  want to generate the following@@ -19,7 +19,6 @@ -- -- genEmployeeStatus :: GenIO Chooser -> GenIO (Tag "permanent" EmployeeStatus) -> GenIO (Tag "temporary" EmployeeStatus) -> GenIO EmployeeStatus -- genEmployeeStatus chooser g1 g2 = chooseOne chooser [fmap unTagg1, fmap unTag g2]--- makeGenerators :: Name -> ExpQ makeGenerators genType = do   info <- reify genType@@ -28,7 +27,6 @@       selector <- makeSelectGenerator name constructors       generators <- traverse makeConstructorGenerator constructors       assembleGeneratorsToRegistry selector generators-     other -> do       qReport True ("can only create generators for an ADT, got: " <> show other)       fail "generators creation failed"
src/Data/Registry/Internal/Hedgehog.hs view
@@ -1,35 +1,33 @@-{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE PartialTypeSignatures #-} -module Data.Registry.Internal.Hedgehog (-  GenIO-, Chooser (..)---- cycling values-, cycleWith-, chooseOne-, choiceChooser-, cycleChooser---- making distinct values-, distinct-, distinctWith---- utilities-, liftGen-, sampleIO-) where+module Data.Registry.Internal.Hedgehog+  ( GenIO,+    Chooser (..),+    -- cycling values+    cycleWith,+    chooseOne,+    choiceChooser,+    cycleChooser,+    -- making distinct values+    distinct,+    distinctWith,+    -- utilities+    liftGen,+    sampleIO,+  )+where -import           Control.Monad.Morph-import           Data.IORef-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           Prelude                (show, (!!))-import           Protolude              as P+import Control.Monad.Morph+import Data.IORef+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, (!!))  -- | All the generators we use are lifted into GenIO to allow some generators to be stateful type GenIO = GenT IO@@ -49,21 +47,21 @@  -- | Chooser for randomly selecting a generator choiceChooser :: Chooser-choiceChooser = Chooser { chooserType = "choice", pickOne = pure . Gen.choice }+choiceChooser = Chooser {chooserType = "choice", pickOne = pure . Gen.choice}  -- | Chooser for deterministically choosing elements in a list --   by cycling over them, which requires to maintain some state about the last position cycleChooser :: IO Chooser cycleChooser = do   ref <- newIORef 0-  pure $ Chooser { chooserType = "cycle", pickOne = cycleWith ref }+  pure $ Chooser {chooserType = "cycle", pickOne = cycleWith ref}  -- | A "chooser" strategy --   The type can be used to debug specializations-data Chooser = Chooser {-  chooserType :: Text-, pickOne     :: forall a . [GenIO a] -> IO (GenIO a)-}+data Chooser = Chooser+  { chooserType :: Text,+    pickOne :: forall a. [GenIO a] -> IO (GenIO a)+  }  instance Show Chooser where   show c = toS (chooserType c)@@ -74,8 +72,8 @@   n <- readIORef ref   modifyIORef ref increment   pure (gs !! n)--  where increment i = if i == P.length gs - 1 then 0 else i + 1+  where+    increment i = if i == P.length gs - 1 then 0 else i + 1  -- * MAKING DISTINCT VALUES @@ -91,7 +89,7 @@ distinctWith ref g = GenT $ \size seed -> do   as <- liftIO $ readIORef ref   a <- runGenT size seed $ (Gen.filterT (not . flip elem as)) g-  liftIO $ writeIORef ref (a:as)+  liftIO $ writeIORef ref (a : as)   pure a  -- * UTILITIES@@ -99,17 +97,15 @@ -- | Sample GenIO values sampleIO :: GenIO a -> IO a sampleIO gen =-    let-      loop n =-        if n <= 0 then-          panic "Hedgehog.Gen.sample: too many discards, could not generate a sample"-        else do-          seed <- Seed.random-          NodeT r _  <- runTreeT $ evalGenT 30 seed gen-          case r of-            Nothing ->-              loop (n - 1)-            Just a ->-              pure a-    in-      loop (100 :: Int)+  let loop n =+        if n <= 0+          then panic "Hedgehog.Gen.sample: too many discards, could not generate a sample"+          else do+            seed <- Seed.random+            NodeT r _ <- runTreeT $ evalGenT 30 seed gen+            case r of+              Nothing ->+                loop (n - 1)+              Just a ->+                pure a+   in loop (100 :: Int)
src/Data/Registry/Internal/TH.hs view
@@ -1,30 +1,28 @@-{-# LANGUAGE DataKinds       #-}-{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}  module Data.Registry.Internal.TH where -import           Control.Monad.Fail              (fail)-import           Data.Registry.Internal.Hedgehog-import           Data.Text                       (splitOn, toLower)-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax-import           Prelude                         (last)-import           Protolude                       hiding (Type)+import Control.Monad.Fail (fail)+import Data.Registry.Internal.Hedgehog+import Data.Text (splitOn, toLower)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Protolude hiding (Type)+import Prelude (last)  -- | Create a generator for selecting between constructors of an ADT --   One parameter is a GenIO Chooser in order to be able to later on --   switch the selection strategy makeSelectGenerator :: Name -> [Con] -> ExpQ makeSelectGenerator name constructors = do-  chooserParam <- [p| (chooser :: GenIO Chooser) |]+  chooserParam <- [p|(chooser :: GenIO Chooser)|]   otherParams <- traverse (parameterFor name) constructors   untaggedGenerators <- traverse untagGenerator constructors   expression <- appE (appE (varE (mkName "chooseOne")) (varE (mkName "chooser"))) (pure $ ListE untaggedGenerators)   pure $ LamE (chooserParam : otherParams) expression-   where-    -- | Create a parameters for the selection function     parameterFor :: Name -> Con -> Q Pat     parameterFor typeName constructor = do       constructorParam <- constructorParameterName constructor@@ -36,7 +34,7 @@ -- AppE (AppTypeE (VarE Data.Registry.Lift.tag) (LitT (StrTyLit "permanent"))) (ConE Test.Data.Registry.Generators.Permanent) makeConstructorGenerator :: Con -> ExpQ makeConstructorGenerator constructor = do-  constructorTag  <- tagName constructor+  constructorTag <- tagName constructor   constructorType <- nameOf constructor   appE (appTypeE (varE (mkName "tag")) (litT (strTyLit (show constructorTag)))) (conE constructorType) @@ -67,7 +65,7 @@ -- | The name of a given constructor nameOf :: Con -> Q Name nameOf (NormalC n _) = pure n-nameOf (RecC n _)    = pure n+nameOf (RecC n _) = pure n nameOf other = do   qReport True ("we can only create generators for normal constructors and records, got: " <> show other)   fail "generators creation failed"@@ -75,7 +73,7 @@ -- | The list of types necessary to create a given constructor typesOf :: Con -> Q [Type] typesOf (NormalC _ types) = pure (snd <$> types)-typesOf (RecC _ types)    = pure $ (\(_,_,t) -> t)  <$> types+typesOf (RecC _ types) = pure $ (\(_, _, t) -> t) <$> types typesOf other = do   qReport True ("we can only create generators for normal constructors and records, got: " <> show other)   fail "generators creation failed"@@ -86,12 +84,10 @@ assembleGeneratorsToRegistry :: Exp -> [Exp] -> ExpQ assembleGeneratorsToRegistry _ [] =   fail "generators creation failed"- assembleGeneratorsToRegistry selectorGenerator [g] =   let r = appendExpressions (genFunOf (pure g)) (funOf (pure selectorGenerator))-  in  appendExpressions r (genFunOf (varE (mkName "choiceChooser")))--assembleGeneratorsToRegistry selectorGenerator (g:gs) =+   in appendExpressions r (genFunOf (varE (mkName "choiceChooser")))+assembleGeneratorsToRegistry selectorGenerator (g : gs) =   appendExpressions (genFunOf (pure g)) (assembleGeneratorsToRegistry selectorGenerator gs)  appendExpressions :: ExpQ -> ExpQ -> ExpQ
+ src/Test/Tasty/HedgehogTest.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+--+-- This redefines the HedgehogTest from tasty-hedgehog to display+-- color during the reporting+module Test.Tasty.HedgehogTest+  ( HedgehogTest (..),+    HedgehogTestLimit (..),+    HedgehogDiscardLimit (..),+    HedgehogShrinkLimit (..),+    HedgehogShrinkRetries (..),+    HedgehogReplay (..),+    HedgehogShowReplay (..),+    ModuleName (..),+    testProperty,+    groupByModuleName,+    getModuleName,+  )+where++import Data.MultiMap hiding (foldr, size)+import GHC.Stack+import Hedgehog hiding (test, (===))+import Hedgehog.Internal.Config (UseColor, detectColor)+import Hedgehog.Internal.Property+import Hedgehog.Internal.Report as Hedgehog+import Hedgehog.Internal.Runner as Hedgehog+import Hedgehog.Internal.Seed as Seed+import Protolude as P hiding (empty, toList, unwords, words)+import qualified Protolude as P+import Test.Tasty as Tasty+import Test.Tasty.Options as Tasty+import Test.Tasty.Providers as Tasty+import Test.Tasty.Runners as Tasty+  ( TestTree (..),+    foldSingle,+    foldTestTree,+    trivialFold,+  )+import Prelude (String, unwords, words)++-- | Hedgehog Property as a Tasty Test+data HedgehogTest = HedgehogTest Tasty.TestName Property+  deriving (Typeable)++-- | Create a 'Test' from a Hedgehog property+testProperty :: Tasty.TestName -> Property -> Tasty.TestTree+testProperty name prop = singleTest name (HedgehogTest name prop)++instance Tasty.IsTest HedgehogTest where+  testOptions =+    return+      [ Tasty.Option (Proxy :: Proxy HedgehogReplay),+        Tasty.Option (Proxy :: Proxy HedgehogShowReplay),+        Tasty.Option (Proxy :: Proxy HedgehogTestLimit),+        Tasty.Option (Proxy :: Proxy HedgehogDiscardLimit),+        Tasty.Option (Proxy :: Proxy HedgehogShrinkLimit),+        Tasty.Option (Proxy :: Proxy HedgehogShrinkRetries)+      ]++  run opts (HedgehogTest name (Property pConfig pTest)) yieldProgress = do+    useColor <- detectColor+    let HedgehogReplay replay = lookupOption opts+        HedgehogTestLimit mTests = lookupOption opts+        HedgehogDiscardLimit mDiscards = lookupOption opts+        HedgehogShrinkLimit mShrinks = lookupOption opts+        HedgehogShrinkRetries mRetries = lookupOption opts+        showReplay = lookupOption opts+        config =+          PropertyConfig+            (fromMaybe (propertyDiscardLimit pConfig) mDiscards)+            (fromMaybe (propertyShrinkLimit pConfig) mShrinks)+            (fromMaybe (propertyShrinkRetries pConfig) mRetries)+            (NoConfidenceTermination $ fromMaybe (propertyTestLimit pConfig) mTests)+    randSeed <- Seed.random+    -- if we just run one test we choose a high size (knowing that the max size is 99)+    -- if the test fails we can turn it to a prop and let the shrinking process find a+    -- smaller counter-example+    let minSize = if propertyTestLimit config == 1 then 50 else 0+    let size = P.maybe minSize fst replay+        seed = P.maybe randSeed snd replay+    report <- checkReport config size seed pTest (yieldProgress . reportToProgress config)+    let resultFn =+          if reportStatus report == OK+            then testPassed+            else testFailed+    out <- reportOutput showReplay useColor name report+    return $ resultFn out++reportToProgress ::+  PropertyConfig ->+  Report Hedgehog.Progress ->+  Tasty.Progress+reportToProgress config (Report testsDone _ _ status) =+  let TestLimit testLimit = propertyTestLimit config+      ShrinkLimit shrinkLimit = propertyShrinkLimit config+      ratio x y = 1.0 * fromIntegral x / fromIntegral y+   in -- TODO add details for tests run / discarded / shrunk+      case status of+        Running ->+          Tasty.Progress "Running" (ratio testsDone testLimit)+        Shrinking fr ->+          Tasty.Progress "Shrinking" (ratio (failureShrinks fr) shrinkLimit)++reportOutput ::+  HedgehogShowReplay ->+  UseColor ->+  String ->+  Report Hedgehog.Result ->+  IO String+reportOutput (HedgehogShowReplay showReplay) useColor name report = do+  s <- renderResult useColor (Just (PropertyName name)) report+  pure $ case reportStatus report of+    Failed fr ->+      let size = failureSize fr+          seed = failureSeed fr+          replayStr =+            if showReplay+              then+                "  --hedgehog-replay \""+                  ++ show size+                  ++ " "+                  ++ show seed+                  ++ "\""+              else ""+       in s ++ replayStr ++ "\n"+    GaveUp ->+      s+    OK ->+      -- do not report hedgehog successes because they are redundant with the Tasty report+      -- except if there is coverage information+      if not . P.null . P.toList . coverageLabels . reportCoverage $ report+        then s+        else ""++propertyTestLimit :: PropertyConfig -> TestLimit+propertyTestLimit =+  let getTestLimit (EarlyTermination _ tests) = tests+      getTestLimit (NoEarlyTermination _ tests) = tests+      getTestLimit (NoConfidenceTermination tests) = tests+   in getTestLimit . propertyTerminationCriteria++-- * OPTIONS DEFINITIONS++-- | The replay token to use for replaying a previous test run+newtype HedgehogReplay = HedgehogReplay (Maybe (Size, Seed))+  deriving (Typeable)++instance IsOption HedgehogReplay where+  defaultValue = HedgehogReplay Nothing++  parseValue v = HedgehogReplay . Just <$> replay+    where+      -- Reads a replay token in the form "{size} {seed}"+      replay = (,) <$> safeRead (unwords size) <*> safeRead (unwords seed)+      (size, seed) = splitAt 2 $ words v++  optionName = return "hedgehog-replay"++  optionHelp = return "Replay token to use for replaying a previous test run"++-- | If a test case fails, show a replay token for replaying tests+newtype HedgehogShowReplay = HedgehogShowReplay Bool+  deriving (Typeable)++instance IsOption HedgehogShowReplay where+  defaultValue = HedgehogShowReplay True++  parseValue = fmap HedgehogShowReplay . safeRead++  optionName = return "hedgehog-show-replay"++  optionHelp = return "Show a replay token for replaying tests"++-- | The number of successful test cases required before Hedgehog will pass a test+newtype HedgehogTestLimit = HedgehogTestLimit (Maybe TestLimit)+  deriving (Eq, Ord, Show, Typeable)++instance IsOption HedgehogTestLimit where+  defaultValue = HedgehogTestLimit Nothing++  parseValue = fmap (HedgehogTestLimit . Just . TestLimit) . safeRead++  optionName = return "hedgehog-tests"++  optionHelp = return "Number of successful test cases required before Hedgehog will pass a test"++-- | The number of discarded cases allowed before Hedgehog will fail a test+newtype HedgehogDiscardLimit = HedgehogDiscardLimit (Maybe DiscardLimit)+  deriving (Eq, Ord, Show, Typeable)++instance IsOption HedgehogDiscardLimit where+  defaultValue = HedgehogDiscardLimit Nothing++  parseValue = fmap (HedgehogDiscardLimit . Just . DiscardLimit) . safeRead++  optionName = return "hedgehog-discards"++  optionHelp = return "Number of discarded cases allowed before Hedgehog will fail a test"++-- | The number of shrinks allowed before Hedgehog will fail a test+newtype HedgehogShrinkLimit = HedgehogShrinkLimit (Maybe ShrinkLimit)+  deriving (Eq, Ord, Show, Typeable)++instance IsOption HedgehogShrinkLimit where+  defaultValue = HedgehogShrinkLimit Nothing++  parseValue = fmap (HedgehogShrinkLimit . Just . ShrinkLimit) . safeRead++  optionName = return "hedgehog-shrinks"++  optionHelp = return "Number of shrinks allowed before Hedgehog will fail a test"++-- | The number of times to re-run a test during shrinking+newtype HedgehogShrinkRetries = HedgehogShrinkRetries (Maybe ShrinkRetries)+  deriving (Eq, Ord, Show, Typeable)++instance IsOption HedgehogShrinkRetries where+  defaultValue = HedgehogShrinkRetries Nothing++  parseValue = fmap (HedgehogShrinkRetries . Just . ShrinkRetries) . safeRead++  optionName = return "hedgehog-retries"++  optionHelp = return "Number of times to re-run a test during shrinking"++-- * GROUPING++-- | This allows the discovery of Hedgehog properties and their grouping by module name+--   in the test report.+--   Extract the ModuleName option value for a given test and+--   group all the tests with that option into the same test group+groupByModuleName :: TestTree -> TestTree+groupByModuleName testTree =+  let grouped =+        assocs $+          foldTestTree+            ( trivialFold+                { foldSingle = \os n t ->+                    let (ModuleName aModuleName) = lookupOption os :: ModuleName+                     in insert (toS aModuleName) (setOptionSet os $ singleTest n t) empty+                }+            )+            mempty+            testTree+   in TestGroup "All" (uncurry TestGroup <$> grouped)++-- | Option describing the current module name+newtype ModuleName = ModuleName Text deriving (Eq, Show)++-- | This option is not used on the command line, it is just used to annotate test groups+instance IsOption ModuleName where+  defaultValue = ModuleName "root"+  parseValue = fmap ModuleName . safeRead+  optionName = pure "module-name"+  optionHelp = pure "internal option used to group tests into the same module"+  optionCLParser = mkFlagCLParser mempty (ModuleName "root")++instance (Ord k) => Semigroup (MultiMap k v) where+  (<>) m1 m2 = fromList (toList m1 <> toList m2)++instance (Ord k) => Monoid (MultiMap k v) where+  mempty = empty+  mappend = (<>)++-- | This is unfortunate. Due to the API for `foldTestTree` in Tasty+--   giving back the current `OptionSet` applicable to a single test+--   it is not possible to re-set those option values on that test+--   without listing them exhaustively. This means+--   that if other options are set on tests in that file, they need to be+--   added in that function+setOptionSet :: OptionSet -> TestTree -> TestTree+setOptionSet os =+  localOption (lookupOption os :: HedgehogTestLimit)+    . localOption (lookupOption os :: HedgehogShrinkLimit)+    . localOption (lookupOption os :: HedgehogReplay)++-- | Return the module name of the current callstack+getModuleName :: HasCallStack => Prelude.String+getModuleName =+  case getCallStack callStack of+    ((_, loc) : _) -> srcLocModule loc+    _ -> "root"
src/Test/Tasty/Hedgehogx.hs view
@@ -1,47 +1,58 @@-{-# LANGUAGE AllowAmbiguousTypes   #-}-{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  {-  This module unifies property based testing with Hedgehog and one-off tests.  -}-module Test.Tasty.Hedgehogx (-  module Hedgehog-, module Tasty-, gotException-, groupByModuleName-, minTestsOk-, mustBe-, noShrink-, prop-, run-, runOnly-, test-, withSeed-, (===)-) where+module Test.Tasty.Hedgehogx+  ( module Hedgehog,+    module Tasty,+    module Test.Tasty.HedgehogTest,+    -- * Tests definition+    prop,+    test,+    -- * Tests settings+    minTestsOk,+    noShrink,+    withSeed,+    -- * Running tests+    run,+    runOnly,+    -- * Assertions+    gotException,+    -- * Display+    printDifference,+    display,+  )+where -import           Data.Maybe           (fromJust)-import           Data.MultiMap        hiding (foldr)-import           GHC.Stack-import           Hedgehog             as Hedgehog hiding (test, (===))-import qualified Hedgehog             as Hedgehog ((===))-import           Hedgehog.Gen         as Hedgehog hiding (discard, print)-import           Prelude              (String)-import           Protolude            hiding (SrcLoc, empty, toList, (.&.))-import           System.Environment-import           Test.Tasty           as Tasty-import           Test.Tasty.Hedgehog  as Tasty-import           Test.Tasty.Options   as Tasty-import           Test.Tasty.Providers as Tasty (singleTest)-import           Test.Tasty.Runners   as Tasty (TestTree (..), foldSingle,-                                                foldTestTree, trivialFold)+import qualified Data.Text as T+import GHC.Stack+import Hedgehog hiding (test)+import Hedgehog.Gen as Hedgehog hiding (discard, print)+import Hedgehog.Internal.Config (UseColor (EnableColor))+import Hedgehog.Internal.Property (Coverage (..), Diff (..), DiscardCount (..), ShrinkCount (..), TestCount (..))+import Hedgehog.Internal.Report+import Hedgehog.Internal.Show (mkValue, valueDiff)+import Protolude hiding (SrcLoc, empty, toList, (.&.))+import System.Environment+import Test.Tasty as Tasty+import Test.Tasty.HedgehogTest+import Test.Tasty.Options as Tasty+import Test.Tasty.Providers as Tasty (singleTest)+import Test.Tasty.Runners as Tasty+  ( TestTree (..),+    foldSingle,+    foldTestTree,+    trivialFold,+  )+import Prelude (String)  -- * TESTS AND PROPERTIES @@ -49,141 +60,59 @@ prop :: HasCallStack => TestName -> PropertyT IO () -> TestTree prop name p =   let aModuleName = getModuleName-  in  withFrozenCallStack . localOption (ModuleName (toS aModuleName)) $-      testProperty name (Hedgehog.property p)+   in withFrozenCallStack . localOption (ModuleName (toS aModuleName)) $+        testProperty name (Hedgehog.property p)  -- | Create a Tasty test from a Hedgehog property called only once test :: HasCallStack => TestName -> PropertyT IO () -> TestTree test name p = withFrozenCallStack (minTestsOk 1 . noShrink $ prop name p) --- * ASSERTIONS---- | Assert that an exception is thrown-gotException :: forall a . (HasCallStack, Show a) => a -> PropertyT IO ()-gotException a = withFrozenCallStack $ do-  res <- liftIO (try (evaluate a) :: IO (Either SomeException a))-  case res of-    Left _  -> assert True-    Right _ -> annotateShow ("excepted an exception" :: Text) >> assert False----- | Redefinition of Hedgehog's === operator to add better source file information------   It adds a link to the source file which is conforms to---   output of GHC.Exception. See makeSourceLink---   It also displays the actual and expected values in a compact form before---   the pretty-printed form provided by Hedgehog-infix 4 ===-(===) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()-actual === expected = withFrozenCallStack $ do-  displayActualAndExpectedValues actual expected-  actual Hedgehog.=== expected---- | An equality assertion which does not try to do a smart diffs for cases---   where the output is too large.-mustBe :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()-actual `mustBe` expected = do-  ok <- eval (actual == expected)-  if ok then-    success-  else withFrozenCallStack $ do-    displayActualAndExpectedValues actual expected-    failure---- | Display actual and expected values as a footnote, using the Show a instance-displayActualAndExpectedValues :: (Show a, MonadTest m, HasCallStack) => a -> a -> m ()-displayActualAndExpectedValues actual expected =-  withFrozenCallStack $ do-    footnote makeSourceLink-    footnote "\n"-    footnote $ "Expected\n" <> (show expected)-    footnote "\n"-    footnote $ "Actual\n" <> (show actual)---- | This function creates a link to the source file which is conforms to---   the output of GHC.Exception and thus can be navigated to with some text editors (like emacs)---   by specifying a regular expression like---   (".*error, called at \\(.*\\.hs\\):\\([0-9]+\\):\\([0-9]+\\) in .*" 1 2 3 2 1)---      (" +\\(.*\\.hs\\):\\([0-9]+\\):$" 1 2 nil 2 1)-makeSourceLink :: (HasCallStack) => String-makeSourceLink =-  case getCallStack callStack of-    [] -> "FAIL!"-    (f, SrcLoc {..}) : _ ->-      f ++ " error, called at " ++-      foldr (++) ""-      [ srcLocFile, ":"-      , show srcLocStartLine, ":"-      , show srcLocStartCol, " in "-      , srcLocPackage, ":", srcLocModule-      ]----- * SETTINGS+-- * SETTING TEST OPTIONS --- | Set a mininum number of tests to be successful on a property+-- | Set the minimum number of tests which must be successful for a property to pass minTestsOk :: Int -> TestTree -> TestTree minTestsOk n = localOption (HedgehogTestLimit (Just (toEnum n :: TestLimit))) --- | Don't shrink failures+-- | Do not shrink failures noShrink :: TestTree -> TestTree noShrink = localOption (HedgehogShrinkLimit (Just (0 :: ShrinkLimit))) --- | Run a property with a specify seed. You can copy and paste the exact string---   which Hedgehog outputs when there is a failure+-- | Execute a property with a specific seed withSeed :: Prelude.String -> TestTree -> TestTree-withSeed seed = localOption (fromJust (parseValue seed :: Maybe HedgehogReplay))---- * GROUPING---- | This allows the discovery of Hedgehog properties and their grouping by module name---   in the test report.---   Extract the ModuleName option value for a given test and---   group all the tests with that option into the same test group-groupByModuleName :: TestTree -> TestTree-groupByModuleName testTree =-  let grouped = assocs $ foldTestTree (trivialFold { foldSingle = \os n t ->-        let (ModuleName aModuleName) = lookupOption os :: ModuleName-        in insert (toS aModuleName) (setOptionSet os $ singleTest n t) empty-        }) mempty testTree-  in  TestGroup "All" (uncurry TestGroup <$> grouped)+withSeed seed tree =+  case parseValue seed of+    Nothing -> prop ("cannot parse seed " <> seed) failure+    Just (s :: HedgehogReplay) -> localOption s tree -instance (Ord k) => Semigroup (MultiMap k v) where-  (<>) m1 m2 = fromList (toList m1 <> toList m2)+-- * ASSERTIONS -instance (Ord k) => Monoid (MultiMap k v) where-  mempty = empty-  mappend = (<>)+-- | Assert that an exception is thrown+gotException :: forall a. (HasCallStack, Show a) => a -> PropertyT IO ()+gotException a = withFrozenCallStack $ do+  res <- liftIO (try (evaluate a) :: IO (Either SomeException a))+  case res of+    Left _ -> assert True+    Right _ -> annotateShow ("excepted an exception" :: Text) >> assert False --- | This is unfortunate. Due to the API for `foldTestTree` in Tasty---   giving back the current `OptionSet` applicable to a single test---   it is not possible to re-set those option values on that test---   without listing them exhaustively. This means---   that if other options are set on tests in that file, they need to be---   added in that function-setOptionSet :: OptionSet -> TestTree -> TestTree-setOptionSet os =-  localOption (lookupOption os :: HedgehogTestLimit) .-  localOption (lookupOption os :: HedgehogShrinkLimit) .-  localOption (lookupOption os :: HedgehogReplay)+-- * REPORTING --- | Return the module name of the current callstack-getModuleName :: HasCallStack => Prelude.String-getModuleName =-  case getCallStack  callStack of-    ((_, loc):_) -> srcLocModule loc-    _            -> "root"+printDifference :: (MonadIO m, Show a, Show b, HasCallStack) => a -> b -> m ()+printDifference actual expected = withFrozenCallStack $ do+  let failureReport = mkFailure (Size 0) (Seed 0 0) (ShrinkCount 0) Nothing Nothing "" (failureDifference actual expected) []+  report <- renderResult EnableColor Nothing (Report (TestCount 0) (DiscardCount 0) (Coverage mempty) (Failed failureReport))+  putText (T.unlines . drop 3 . T.lines . toS $ report) --- | Option describing the current module name-newtype ModuleName = ModuleName Text deriving (Eq, Show)+failureDifference :: (Show a, Show b, HasCallStack) => a -> b -> Maybe Diff+failureDifference x y = withFrozenCallStack $+  case valueDiff <$> mkValue x <*> mkValue y of+    Nothing ->+      Nothing+    Just d ->+      withFrozenCallStack $+        Just $ Diff "━━━ Failed (" "- lhs" ") (" "+ rhs" ") ━━━" d --- | This option is not used on the command line, it is just used to annotate test groups-instance IsOption ModuleName where-  defaultValue = ModuleName "root"-  parseValue = fmap ModuleName . safeRead-  optionName = pure "module-name"-  optionHelp = pure "internal option used to group tests into the same module"-  optionCLParser = mkFlagCLParser mempty (ModuleName "root")+display :: (Show a, Monad m, HasCallStack) => a -> PropertyT m a+display a = withFrozenCallStack (annotateShow a $> a)  -- * GHCi run functions
test/Test/Data/Registry/Company.hs view
@@ -1,27 +1,30 @@ module Test.Data.Registry.Company where -import           Protolude+import Protolude  -- Some complex nested data-data Company = Company {-  companyName :: Text-, departments :: [Department]-} deriving (Eq, Show)+data Company = Company+  { companyName :: Text,+    departments :: [Department]+  }+  deriving (Eq, Show) -data Department = Department {-  departmentName :: Text-, employees      :: [Employee]-} deriving (Eq, Show)+data Department = Department+  { departmentName :: Text,+    employees :: [Employee]+  }+  deriving (Eq, Show) -data Employee = Employee {-  employeeName   :: Text-, employeeStatus :: EmployeeStatus-, salary         :: Int-, bonus          :: Maybe Int-} deriving (Eq, Show)+data Employee = Employee+  { employeeName :: Text,+    employeeStatus :: EmployeeStatus,+    salary :: Int,+    bonus :: Maybe Int+  }+  deriving (Eq, Show)  -- | Note that this is an ADT with several constructors-data EmployeeStatus =-   Permanent- | Temporary Int -- number of days- deriving (Eq, Show)+data EmployeeStatus+  = Permanent+  | Temporary Int -- number of days+  deriving (Eq, Show)
test/Test/Data/Registry/Generators.hs view
@@ -1,35 +1,35 @@-{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}  module Test.Data.Registry.Generators where -import           Data.Registry-import           Data.Registry.Hedgehog-import           Data.Registry.Hedgehog.TH-import           Data.Registry.TH-import           Hedgehog.Gen               as Gen hiding (print)-import           Hedgehog.Internal.Gen      hiding (print)-import           Hedgehog.Range-import           Protolude                  hiding (list)-import           Test.Data.Registry.Company-import           Test.Tasty.Hedgehogx+import Data.Registry+import Data.Registry.Hedgehog+import Data.Registry.Hedgehog.TH+import Data.Registry.TH+import Hedgehog.Gen as Gen hiding (print)+import Hedgehog.Internal.Gen hiding (print)+import Hedgehog.Range+import Protolude hiding (list)+import Test.Data.Registry.Company+import Test.Tasty.Hedgehogx  registry =-    genFun Company- <: genFun Department- <: genFun Employee- -- we can generate data for different constructors in an ADT with some Template Haskell- <: $(makeGenerators ''EmployeeStatus)- -- we can generate Lists or Maybe of elements- <: fun (listOf @Department)- <: fun (listOf @Employee)- <: fun (maybeOf @Int)- <: genVal genInt- <: genVal genText+  genFun Company+    <: genFun Department+    <: genFun Employee+    -- we can generate data for different constructors in an ADT with some Template Haskell+    <: $(makeGenerators ''EmployeeStatus)+    -- we can generate Lists or Maybe of elements+    <: fun (listOf @Department)+    <: fun (listOf @Employee)+    <: fun (maybeOf @Int)+    <: genVal genInt+    <: genVal genText  genInt :: Gen Int genInt = integral (linear 1 3)@@ -46,5 +46,5 @@ generators = $(checkRegistry 'registry)  -- | We create a forall function using all the generators-forall :: forall a . _ => PropertyT IO a+forall :: forall a. _ => PropertyT IO a forall = withFrozenCallStack $ forAllT (genWith @a generators)
test/Test/Data/Registry/HedgehogSpec.hs view
@@ -1,29 +1,54 @@-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE PartialTypeSignatures      #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}  module Test.Data.Registry.HedgehogSpec where -import           Control.Monad.Morph (hoist)-import           Data.IORef-import           Data.Registry-import           Data.Registry.Hedgehog-import           Hedgehog.Internal.Gen         hiding (print)-import           Hedgehog.Range-import           Hedgehog.Gen as Gen-import           Protolude                     hiding (list)-import           System.IO.Unsafe-import           Test.Data.Registry.Company-import           Test.Data.Registry.Generators-import           Test.Tasty.Hedgehogx-import           Hedgehog.Internal.Seed as Seed (random)-import           Hedgehog.Internal.Tree as Tree (NodeT (..), runTreeT)-+import Control.Monad.Morph (hoist)+import Data.IORef+import Data.Registry+import Data.Registry.Hedgehog import qualified Data.Text as T import qualified Data.Text.IO as T+import Hedgehog.Gen as Gen+import Hedgehog.Internal.Gen hiding (print)+import Hedgehog.Internal.Seed as Seed (random)+import Hedgehog.Internal.Tree as Tree (NodeT (..), runTreeT)+import Hedgehog.Range+import Protolude+  ( Applicative (pure),+    Bool (True),+    Eq,+    Foldable (length),+    IO,+    Int,+    Maybe (Just, Nothing),+    Monad ((>>)),+    MonadIO (..),+    MonadState (get, put),+    Num ((+), (-)),+    Ord ((<=), (>=)),+    Show,+    State,+    Text,+    evalState,+    flip,+    head,+    lift,+    panic,+    ($),+    (.),+    (<$>),+  )+import System.IO.Unsafe+import Test.Data.Registry.Company+import Test.Data.Registry.Generators+import Test.Tasty.Hedgehogx+ -- * This specification shows the usage of several features of this library+ --   First of all you will notice that if you run `stack test` --   all the properties of this file will be grouped under the Test.Data.Registry.HedgehogSpec test group @@ -68,59 +93,67 @@  -- Let's create some registry modifiers to constrain the generation setOneDepartment = addFunS $ listOfMinMax @Department 1 1-setOneEmployee   = addFunS $ listOfMinMax @Employee 1 1++setOneEmployee = addFunS $ listOfMinMax @Employee 1 1+ setSmallCompany = setOneEmployee >> setOneDepartment  test_small_company =-  prop "a small company has just one department and one employee" $ runS generators $ do-    setSmallCompany-    company <- forallS @Company-    length (departments company) === 1-    let Just d = head $ departments company-    length (employees d) === 1+  prop "a small company has just one department and one employee" $+    runS generators $ do+      setSmallCompany+      company <- forallS @Company+      length (departments company) === 1+      let Just d = head $ departments company+      length (employees d) === 1  -- * We can also specialize some generators in a given context+ --   For example we might want to generate shorter department names even --   if Department is using Text values. To do this we specialize the Text --   generator in the context of a Gen Department  genDepartmentName = T.take 5 . T.toUpper <$> genText+ setDepartmentName = specializeGenS @Department genDepartmentName  test_with_better_department_name = noShrink $-  prop "a department must have a short capitalized name" $ runS generators $ do-    setSmallCompany-    setDepartmentName-    company <- forallS @Company+  prop "a department must have a short capitalized name" $+    runS generators $ do+      setSmallCompany+      setDepartmentName+      company <- forallS @Company -    -- uncomment to print the department names and inspect them-    -- print company-    let Just d = head $ departments company-    (T.length (departmentName d) <= 5) === True+      -- uncomment to print the department names and inspect them+      -- print company+      let Just d = head $ departments company+      (T.length (departmentName d) <= 5) === True  -- * It would be also very nice to have stateful generation where we can cycle+ --   across different constructors for a given data type  test_cycle_constructors =-  prop "we can cycle deterministically across all the constructors of a data type" $ runS generators $ do-    setCycleChooserS @EmployeeStatus-    -- uncomment to check-    -- collect =<< forallS @EmployeeStatus-    success+  prop "we can cycle deterministically across all the constructors of a data type" $+    runS generators $ do+      setCycleChooserS @EmployeeStatus+      -- uncomment to check+      -- collect =<< forallS @EmployeeStatus+      success  -- We can also make sure we generate distinct values for a given type test_distinct_values =-  prop "we can generate distinct values for a given data type when used in a specific context" $ runS generators $ do-   setDistinctForS @Department @Text-   -- uncomment to check-   -- collect =<< departmentName <$> forallS @Department-   success-+  prop "we can generate distinct values for a given data type when used in a specific context" $+    runS generators $ do+      setDistinctForS @Department @Text+      -- uncomment to check+      -- collect =<< departmentName <$> forallS @Department+      success  test_ints_generator =   prop "we can generate ints" $ do-   n <- forAllT distinctInt-   n === n -- collect n+    n <- forAllT distinctInt+    n === n -- collect n  test_fresh = minTestsOk 10000 $   prop "we can generate terms with fresh ids" $ do@@ -140,8 +173,8 @@   t <- g   makeValue t -data Term =-    Value Int Text+data Term+  = Value Int Text   | Exp Int Term Term   deriving (Eq, Show) @@ -162,7 +195,7 @@ runFresh = forAll . runStateGen  runStateGen :: (Show a) => GenT (State Int) a -> Gen a-runStateGen = hoist (pure . flip evalState 0  )+runStateGen = hoist (pure . flip evalState 0)  instance Fresh (GenT (State Int)) where   fresh = do@@ -173,20 +206,18 @@ -- | Sample GenT IO values sampleGenIO :: GenT IO a -> IO a sampleGenIO gen =-    let-      loop n =-        if n <= 0 then-          panic "Hedgehog.Gen.sample: too many discards, could not generate a sample"-        else do-          seed <- Seed.random-          NodeT r _  <- runTreeT $ evalGenT 30 seed gen-          case r of-            Nothing ->-              loop (n - 1)-            Just a ->-              pure a-    in-      loop (100 :: Int)+  let loop n =+        if n <= 0+          then panic "Hedgehog.Gen.sample: too many discards, could not generate a sample"+          else do+            seed <- Seed.random+            NodeT r _ <- runTreeT $ evalGenT 30 seed gen+            case r of+              Nothing ->+                loop (n - 1)+              Just a ->+                pure a+   in loop (100 :: Int)  {-# NOINLINE distinctInt #-} distinctInt :: GenIO Int
test/Test/Tutorial/DataModel.hs view
@@ -1,25 +1,28 @@ module Test.Tutorial.DataModel where -import           Protolude+import Protolude -data Company = Company {-  companyName :: Text-, departments :: [Department]-} deriving (Eq, Show)+data Company = Company+  { companyName :: Text,+    departments :: [Department]+  }+  deriving (Eq, Show) -data Department = Department {-  departmentName :: Text-, employees      :: [Employee]-} deriving (Eq, Show)+data Department = Department+  { departmentName :: Text,+    employees :: [Employee]+  }+  deriving (Eq, Show) -data Employee = Employee {-  employeeName   :: Text-, employeeStatus :: EmployeeStatus-, salary         :: Int-, bonus          :: Maybe Int-} deriving (Eq, Show)+data Employee = Employee+  { employeeName :: Text,+    employeeStatus :: EmployeeStatus,+    salary :: Int,+    bonus :: Maybe Int+  }+  deriving (Eq, Show) -data EmployeeStatus =-   Permanent- | Temporary Int -- number of days- deriving (Eq, Show)+data EmployeeStatus+  = Permanent+  | Temporary Int -- number of days+  deriving (Eq, Show)
test/Test/Tutorial/Exercise1.hs view
@@ -1,26 +1,26 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}  module Test.Tutorial.Exercise1 where -import           Data.Registry-import           Data.Registry.Hedgehog-import           Hedgehog                hiding (test)-import           Hedgehog.Gen-import           Hedgehog.Range-import           Protolude-import           Test.Tutorial.DataModel+import Data.Registry+import Data.Registry.Hedgehog+import Hedgehog hiding (test)+import Hedgehog.Gen+import Hedgehog.Range+import Protolude+import Test.Tutorial.DataModel  registry :: Registry _ _ registry =-     genFun Company-  <: genFun Department-  <: genFun Employee-  <: genVal genEmployeeStatus-  <: genVal genInt-  <: genVal genText+  genFun Company+    <: genFun Department+    <: genFun Employee+    <: genVal genEmployeeStatus+    <: genVal genInt+    <: genVal genText  genInt :: Gen Int genInt = integral (linear 1 3)
test/Test/Tutorial/Exercise2.hs view
@@ -1,30 +1,30 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}  module Test.Tutorial.Exercise2 where -import           Data.Registry-import           Data.Registry.Hedgehog-import           Hedgehog                hiding (test)-import           Hedgehog.Gen-import           Hedgehog.Range-import           Protolude-import           Test.Tasty.Hedgehogx-import           Test.Tutorial.DataModel+import Data.Registry+import Data.Registry.Hedgehog+import Hedgehog hiding (test, (===))+import Hedgehog.Gen+import Hedgehog.Range+import Protolude+import Test.Tasty.Hedgehogx+import Test.Tutorial.DataModel  registry :: Registry _ _ registry =-     genFun Company-  <: genFun Department-  <: genFun Employee-  <: fun    (listOf @Employee)-  <: fun    (listOf @Department)-  <: fun    (maybeOf @Int)-  <: genVal genEmployeeStatus-  <: genVal genInt-  <: genVal genText+  genFun Company+    <: genFun Department+    <: genFun Employee+    <: fun (listOf @Employee)+    <: fun (listOf @Department)+    <: fun (maybeOf @Int)+    <: genVal genEmployeeStatus+    <: genVal genInt+    <: genVal genText  genInt :: Gen Int genInt = integral (linear 1 3)@@ -39,8 +39,8 @@ makeCompanyGen :: GenIO Company makeCompanyGen = make @(GenIO Company) registry -forall :: forall a . (Typeable a, Show a) => PropertyT IO a-forall = forAllT $ genWith @a registry+forall :: forall a. (Typeable a, Show a) => PropertyT IO a+forall = withFrozenCallStack $ forAllT $ genWith @a registry  test_company = test "make a company" $ do   _ <- forall @Company
test/Test/Tutorial/Exercise3.hs view
@@ -1,25 +1,25 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}  module Test.Tutorial.Exercise3 where -import           Data.Registry-import           Data.Registry.Hedgehog-import           Data.Registry.Hedgehog.TH-import           Hedgehog                hiding (test)-import           Protolude-import           Test.Tasty.Hedgehogx-import           Test.Tutorial.DataModel-import           Test.Tutorial.Exercise2 (registry)+import Data.Registry+import Data.Registry.Hedgehog+import Data.Registry.Hedgehog.TH+import Hedgehog hiding (test)+import Protolude+import Test.Tasty.Hedgehogx+import Test.Tutorial.DataModel+import Test.Tutorial.Exercise2 (registry)  registry3 :: Registry _ _ registry3 = $(makeGenerators ''EmployeeStatus) <: registry -forall :: forall a . (Typeable a, Show a) => PropertyT IO a-forall = forAllT $ genWith @a registry3+forall :: forall a. (Typeable a, Show a) => PropertyT IO a+forall = withFrozenCallStack $ forAllT $ genWith @a registry3  test_employee_status = prop "make an employee status" $ do   status <- forall @EmployeeStatus
test/Test/Tutorial/Exercise4.hs view
@@ -1,19 +1,19 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}  module Test.Tutorial.Exercise4 where -import           Data.Registry-import           Data.Registry.Hedgehog-import           Data.Text                as T-import           Hedgehog                 hiding (test)-import           Protolude-import           Test.Tasty.Hedgehogx-import           Test.Tutorial.DataModel-import           Test.Tutorial.Exercise2 (genText)-import           Test.Tutorial.Exercise3 (registry3)+import Data.Registry+import Data.Registry.Hedgehog+import Data.Text as T+import Hedgehog hiding (test)+import Protolude+import Test.Tasty.Hedgehogx+import Test.Tutorial.DataModel+import Test.Tutorial.Exercise2 (genText)+import Test.Tutorial.Exercise3 (registry3)  registry12 :: Registry _ _ registry12 = specializeGen @Department genDepartmentName $ registry3@@ -21,8 +21,8 @@ genDepartmentName :: Gen Text genDepartmentName = T.take 5 . T.toUpper <$> genText -forall :: forall a . (Typeable a, Show a) => PropertyT IO a-forall = forAllT $ genWith @a registry12+forall :: forall a. (Typeable a, Show a) => PropertyT IO a+forall = withFrozenCallStack $ forAllT $ genWith @a registry12  test_deparment_name = prop "make a department" $ do   department <- forall @Department
test/Test/Tutorial/Exercise5.hs view
@@ -1,20 +1,20 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}  module Test.Tutorial.Exercise5 where -import           Data.Registry-import           Data.Text as T-import           Data.Registry.Hedgehog-import           Hedgehog                 hiding (test)-import           Protolude-import           Test.Tasty.Hedgehogx-import           Test.Tutorial.DataModel-import           Test.Tutorial.Exercise2 (genText)-import           Test.Tutorial.Exercise3 (registry3)-import           Test.Tutorial.Exercise4 (genDepartmentName)+import Data.Registry+import Data.Registry.Hedgehog+import Data.Text as T+import Hedgehog hiding (test)+import Protolude+import Test.Tasty.Hedgehogx+import Test.Tutorial.DataModel+import Test.Tutorial.Exercise2 (genText)+import Test.Tutorial.Exercise3 (registry3)+import Test.Tutorial.Exercise4 (genDepartmentName)  runGens = runS registry3 @@ -22,14 +22,18 @@ genEmployeeName = T.take 10 . T.toLower <$> genText  setDepartmentName = specializeGenS @Department genDepartmentName-setEmployeeName   = specializeGenS @Employee genEmployeeName +setEmployeeName = specializeGenS @Employee genEmployeeName+ setOneDepartment = addFunS $ listOfMinMax @Department 1 1-setOneEmployee   = addFunS $ listOfMinMax @Employee 1 1++setOneEmployee = addFunS $ listOfMinMax @Employee 1 1+ setSmallCompany = setOneEmployee >> setOneDepartment -test_small_company = prop "make a small company" $ runGens $ do-  setSmallCompany-  setEmployeeName-  setDepartmentName-  collect =<< forallS @Company+test_small_company = prop "make a small company" $+  runGens $ do+    setSmallCompany+    setEmployeeName+    setDepartmentName+    collect =<< forallS @Company
test/Test/Tutorial/Exercise6.hs view
@@ -1,27 +1,28 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}  module Test.Tutorial.Exercise6 where -import           Data.Registry.Hedgehog-import           Data.Text                 as T-import           Hedgehog                  hiding (test)-import           Protolude-import           Test.Tasty.Hedgehogx-import           Test.Tutorial.DataModel-import           Test.Tutorial.Exercise5+import Data.Registry.Hedgehog+import Data.Text as T+import Hedgehog hiding (test)+import Protolude+import Test.Tasty.Hedgehogx+import Test.Tutorial.DataModel+import Test.Tutorial.Exercise5 -test_another_small_company = prop "make a small company" $ runGens $ do-  setSmallCompany-  setEmployeeName-  setDepartmentName-  setGenS @Int (pure 1)-  setDistinctForS @Department @Text+test_another_small_company = prop "make a small company" $+  runGens $ do+    setSmallCompany+    setEmployeeName+    setDepartmentName+    setGenS @Int (pure 1)+    setDistinctForS @Department @Text -  collect =<< forallS @Company+    collect =<< forallS @Company -  setCycleChooserS @EmployeeStatus-  collect =<< forallS @EmployeeStatus+    setCycleChooserS @EmployeeStatus+    collect =<< forallS @EmployeeStatus
test/test.hs view
@@ -1,5 +1,5 @@-import           AutoDiscoveredSpecs   (tests)-import           Protolude-import           Test.Tasty.Hedgehogx+import AutoDiscoveredSpecs (tests)+import Protolude+import Test.Tasty.Hedgehogx  main = tests >>= defaultMain . groupByModuleName