packages feed

registry-hedgehog (empty) → 0.1.0.0

raw patch · 13 files changed

+986/−0 lines, 13 filesdep +basedep +containersdep +generic-lenssetup-changed

Dependencies added: base, containers, generic-lens, hedgehog, hedgehog-corpus, mmorph, multimap, protolude, registry, registry-hedgehog, tasty, tasty-discover, tasty-hedgehog, tasty-th, template-haskell, text, transformers, universum, unordered-containers

Files

+ LICENSE.txt view
@@ -0,0 +1,16 @@+Copyright (c) 2019 Eric Torreborre <etorreborre@yahoo.com>++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated+documentation files (the "Software"), to deal in the Software without restriction, including without limitation+the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software,+and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of+the Software. Neither the name of specs nor the names of its contributors may be used to endorse or promote+products derived from this software without specific prior written permission.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED+TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL+THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF+CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER+DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,4 @@+import           Distribution.Simple++main :: IO ()+main = defaultMain
+ registry-hedgehog.cabal view
@@ -0,0 +1,88 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: afcc78ed8706fa89c2270d64ea3dd640a4afa2db1ed1c5982c7fcce7160ca4e5++name:           registry-hedgehog+version:        0.1.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+maintainer:     etorreborre@yahoo.com+license:        MIT+license-file:   LICENSE.txt+build-type:     Simple++source-repository head+  type: git+  location: https://github.com/etorreborre/registry-hedgehog++library+  exposed-modules:+      Data.Registry.Hedgehog+      Data.Registry.Hedgehog.TH+      Data.Registry.Internal.Hedgehog+      Data.Registry.Internal.TH+      Test.Tasty.Hedgehogx+  other-modules:+      Paths_registry_hedgehog+  hs-source-dirs:+      src+  default-extensions: BangPatterns DefaultSignatures EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms Rank2Types RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -fno-warn-partial-type-signatures -optP-Wno-nonportable-include-path -Wincomplete-uni-patterns+  build-depends:+      base >=4.7 && <5+    , containers >=0.2 && <1+    , hedgehog >=0.6 && <1+    , mmorph >=1 && <2+    , multimap >=1 && <2+    , protolude >=0.2 && <0.3+    , registry >=0.1.4 && <2+    , tasty >=1 && <2+    , tasty-discover >=2 && <5+    , tasty-hedgehog >=0.1 && <1+    , tasty-th >=0.1 && <1+    , template-haskell >=2.13 && <3.0+    , text >=1 && <2+    , transformers >=0.5 && <2+    , universum >=1 && <2+    , unordered-containers >=0.1 && <1+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: test.hs+  other-modules:+      AutoDiscoveredSpecs+      Test.Data.Registry.Company+      Test.Data.Registry.Generators+      Test.Data.Registry.HedgehogSpec+      Paths_registry_hedgehog+  hs-source-dirs:+      test+  default-extensions: BangPatterns DefaultSignatures EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms Rank2Types RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -fno-warn-partial-type-signatures -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans -fno-warn-missing-signatures -fno-warn-incomplete-uni-patterns -fno-warn-type-defaults -optP-Wno-nonportable-include-path+  build-depends:+      base >=4.7 && <5+    , containers >=0.2 && <1+    , generic-lens+    , hedgehog >=0.6 && <1+    , hedgehog-corpus+    , mmorph+    , multimap >=1 && <2+    , protolude >=0.2 && <0.3+    , registry+    , registry-hedgehog+    , tasty+    , tasty-discover+    , tasty-hedgehog+    , tasty-th+    , template-haskell >=2.13 && <3.0+    , text+    , transformers+    , universum+    , unordered-containers >=0.1 && <1+  default-language: Haskell2010
+ src/Data/Registry/Hedgehog.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE PartialTypeSignatures #-}++module Data.Registry.Hedgehog (+  -- creation / tweaking functions+  GenIO+, Chooser (..)+, genFun+, genVal+, genWith+, tweakGen+, tweakGenS+, setGen+, setGenIO+, setGenS+, specializeGen+, specializeGenIO+, specializeGenS+, makeNonEmpty+, makeNonEmptyS+, forallS+, forAllT -- re-export of forAllT for convenience purpose since we are working in GenIO++-- combinators to compose different types of generators+, pairOf+, tripleOf+, listOf+, listOfMinMax+, nonEmptyOf+, maybeOf+, eitherOf+, setOf+, mapOf+, nonEmptyMapOf+, hashMapOf++-- cycling values+, setCycleChooserS+, setCycleChooser+, choiceChooser+, chooseOne++-- making distinct values+, setDistinctS+, setDistinctForS+, setDistinct+, setDistinctFor+, distinct++-- 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.Property      (forAllT)+import           Hedgehog.Range+import           Protolude                       as P+++-- * 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 = 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 g = fun (Gen.lift 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 = 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 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 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 = setGenIO . Gen.lift++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 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 g = specializeGenIO @a (Gen.lift 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 = 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 g = modify (specializeGen @a @b g)++-- | 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 = 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 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++-- | 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 = modify (makeNonEmpty @a)++-- * CONTAINERS COMBINATORS++-- | Create a generator for a pair+pairOf :: forall a b m . (Monad m) => GenT m a -> GenT m b -> GenT m (a, b)+pairOf ga gb = (,) <$> ga <*> gb++-- | Create a generator for a triple+tripleOf :: forall a b c m . (Monad m) => GenT m a -> GenT m b -> GenT m c -> GenT m (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 = Gen.list (linear 0 3)++-- | 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 min' max' = Gen.list (linear min' max')++-- | Create a default generator for a small non-empty list of elements+nonEmptyOf :: GenIO a -> GenIO (NonEmpty a)+nonEmptyOf = Gen.nonEmpty (linear 1 3)++-- | Create a default generator for a Maybe, choosing evenly between Nothing and Just+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 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 = 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 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 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 gk gv = do+  h <- pairOf gk gv+  t <- listOf (pairOf gk gv)+  pure (Map.fromList (h : t))++-- * STATEFUL GENERATORS++-- * CHOOSING VALUES DETERMINISTICALLY++-- | Set a cycling chooser for a specific data type+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++-- | Set a cycling chooser for a specific data type+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'++-- * MAKING DISTINCT VALUES++-- | Generate distinct values for a specific data type+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++-- | Generate distinct values for a specific data type+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'++-- | Generate distinct values for a specific data type, when used inside another data type+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++-- | Generate distinct values for a specific data type, when used inside another data type+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'
+ src/Data/Registry/Hedgehog/TH.hs view
@@ -0,0 +1,34 @@+{-# 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++-- | Make a registry containing generators for an ADT+--   We  want to generate the following+--+--       fun genEmployeeStatus+--    <: genFun (tag @"permanent" Permanent)+--    <: genFun (tag @"temporary" Temporary)+--+-- 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+  case info of+    TyConI (DataD _context name _typeVars _kind constructors _deriving) -> do+      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
@@ -0,0 +1,118 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE PartialTypeSignatures #-}++module Data.Registry.Internal.Hedgehog (+  GenIO+, Chooser (..)++-- cycling values+, cycleWith+, chooseOne+, choiceChooser+, cycleChooser++-- making distinct values+, distinct+, distinctWith++-- utilities+, sampleIO+) where++import           Control.Monad.Trans.Maybe+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 (Node (..), Tree (..))+import           Prelude                   (show, (!!))+import           Protolude                 as P++-- | All the generators we use are lifted into GenIO to allow some generators to be stateful+type GenIO = GenT IO++-- * CHOOSING VALUES DETERMINISTICALLY++-- | Given a choosing strategy pick a generator+--   This is possibly a stateful operation+chooseOne :: GenIO Chooser -> [GenIO a] -> GenIO a+chooseOne chooser gs = do+  c <- chooser+  join $ P.lift $ pickOne c gs++-- | Chooser for randomly selecting a generator+choiceChooser :: Chooser+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 }++-- | A "chooser" strategy+--   The type can be used to debug specializations+data Chooser = Chooser {+  chooserType :: Text+, pickOne     :: forall a . [GenIO a] -> IO (GenIO a)+}++instance Show Chooser where+  show c = toS (chooserType c)++-- | Pick a generator in a list based on the previous position selected+cycleWith :: (MonadIO m) => IORef Int -> [GenT m a] -> IO (GenT m a)+cycleWith ref gs = do+  n <- readIORef ref+  modifyIORef ref increment+  pure (gs !! n)++  where increment i = if i == P.length gs - 1 then 0 else i + 1++-- * MAKING DISTINCT VALUES++-- | Create a generator for distinct values+--   This is a stateful operation+distinct :: (MonadIO m, Eq a) => GenT m a -> IO (GenT m a)+distinct g = do+  ref <- newIORef []+  pure $ distinctWith ref g++-- | Generate distinct values based on the values already generated+distinctWith :: (MonadIO m, Eq a) => IORef [a] -> GenT m a -> GenT m a+distinctWith ref g = GenT $ \size seed -> do+  as <- liftIO $ readIORef ref+  a <- runGenT size seed $ (Gen.filter (not . flip elem as)) g+  liftIO $ writeIORef ref (a:as)+  pure a++-- * UTILITIES++-- | 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+          r <- evalGenIO 30 seed gen+          case r of+            Nothing ->+              loop (n - 1)+            Just a ->+              pure a+    in+      loop (100 :: Int)++-- | Runs a generator in IO, to get a value+evalGenIO :: Size -> Seed -> GenIO a -> IO (Maybe a)+evalGenIO size seed g = do+  r <- runMaybeT . runTree $ runGenT size seed g+  pure $ case r of+    Nothing         -> Nothing+    Just (Node a _) -> Just a
+ src/Data/Registry/Internal/TH.hs view
@@ -0,0 +1,92 @@+{-# 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)++-- | 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) |]+  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+      constructorTag <- tagName constructor+      sigP (varP constructorTag) (appT (conT (mkName "GenIO")) (appT (appT (conT (mkName "Tag")) (litT (strTyLit (show constructorTag)))) (conT typeName)))++-- Create a generator expression for a specific constructor of a data type+-- runQ [|tag @"permanent" Permanent|]+-- 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+  constructorName <- nameOf constructor+  appE (appTypeE (varE (mkName "tag")) (litT (strTyLit (show constructorTag)))) (conE constructorName)++-- | Remove the tag of a given constructor: fmap unTag g :: GenIO (Tag "t" SomeType) -> GenIO SomeType+untagGenerator :: Con -> ExpQ+untagGenerator constructor = do+  constructorTag <- tagName constructor+  appE (appE (varE (mkName "fmap")) (varE (mkName "unTag"))) (varE constructorTag)++-- | Create a tag used to distinguish constructors in an ADT+tagName :: Con -> Q Name+tagName constructor = do+  n <- nameOf constructor+  pure $ mkName $ toS . last . splitOn "." . toLower $ show n++-- | The name of a given constructor+nameOf :: Con -> Q Name+nameOf (NormalC 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"++-- | 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 other = do+  qReport True ("we can only create generators for normal constructors and records, got: " <> show other)+  fail "generators creation failed"++-- | runQ [| fun g <: genFun e <: genFun f|]+--   InfixE (Just (AppE (VarE Data.Registry.Registry.fun) (UnboundVarE g))) (VarE <:) (Just (InfixE (Just (AppE (VarE Data.Registry.Hedgehog.genFun) (UnboundVarE e)))+--  (VarE Data.Registry.Registry.<:) (Just (AppE (VarE Data.Registry.Hedgehog.genFun) (UnboundVarE f)))))+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) =+  appendExpressions (genFunOf (pure g)) (assembleGeneratorsToRegistry selectorGenerator gs)++appendExpressions :: ExpQ -> ExpQ -> ExpQ+appendExpressions e1 e2 =+  infixE (Just e1) (varE (mkName "<:")) (Just e2)++genFunOf :: ExpQ -> ExpQ+genFunOf = appE (varE (mkName "genFun"))++funOf :: ExpQ -> ExpQ+funOf = appE (varE (mkName "fun"))
+ src/Test/Tasty/Hedgehogx.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++{-++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++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 qualified Prelude              as Prelude+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)++-- * TESTS AND PROPERTIES++-- | Create a Tasty test from a Hedgehog property+prop :: HasCallStack => TestName -> PropertyT IO () -> TestTree+prop name p =+  let aModuleName = getModuleName+  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++-- | Set a mininum number of tests to be successful on a property+minTestsOk :: Int -> TestTree -> TestTree+minTestsOk n = localOption (HedgehogTestLimit (Just (toEnum n :: TestLimit)))++-- | Don't 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+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)++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"++-- | 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")++-- * GHCi run functions++-- | Run either a test tree (a test or a property) whether it is in IO or not+run :: Runnable t => t -> IO ()+run tests = runIt tests >>= defaultMain . groupByModuleName++-- | Run only some tests by passing a tasty pattern+runOnly :: Runnable t => Text -> t -> IO ()+runOnly p tests = do+  setEnv "TASTY_PATTERN" (toS p)+  run tests `finally` unsetEnv "TASTY_PATTERN"++-- | Typeclass to unify a simple test in a file like test_simple :: TestTree+--   and all the tests retrieved by tasty-discovery which have the type :: IO TestTree  +class Runnable t where+  runIt :: t -> IO TestTree++instance Runnable (IO TestTree) where+  runIt t = t++instance Runnable TestTree where+  runIt = pure
+ test/AutoDiscoveredSpecs.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=AutoDiscoveredSpecs #-}
+ test/Test/Data/Registry/Company.hs view
@@ -0,0 +1,27 @@+module Test.Data.Registry.Company where++import           Protolude++-- Some complex nested data+data Company = Company {+  companyName :: Text+, departments :: [Department]+} 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)++-- | Note that this is an ADT with several constructors+data EmployeeStatus =+   Permanent+ | Temporary Int -- number of days+ deriving (Eq, Show)
+ test/Test/Data/Registry/Generators.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# 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 (lift, print)+import           Hedgehog.Internal.Gen      hiding (lift, print)+import           Hedgehog.Range+import           Protolude                  hiding (list)+import           Test.Data.Registry.Company+import           Test.Tasty.Hedgehogx       hiding (lift)++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++genInt :: Gen Int+genInt = integral (linear 1 3)++genText :: Gen Text+genText = text (linear 1 10) alpha++-- we need this if the registry and the TH check are done in the same file+-- See the gory details of why this is necessary: https://gitlab.haskell.org/ghc/ghc/issues/9813+$(return [])++-- | Check that the registry is complete. This speeds up compilation when there are lots of generators+generators :: Registry _ _+generators = $(checkRegistry 'registry)++-- | We create a forall function using all the generators+forall :: forall a . _ => PropertyT IO a+forall = withFrozenCallStack $ forAllT (genWith @a generators)
+ test/Test/Data/Registry/HedgehogSpec.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++module Test.Data.Registry.HedgehogSpec where++import           Data.List                     (nub)+import           Data.Registry+import           Data.Registry.Hedgehog+import qualified Data.Text                     as T (length, take, toUpper)+import           Hedgehog.Internal.Gen         hiding (lift, print)+import           Hedgehog.Range+import           Protolude                     hiding (list)+import           Test.Data.Registry.Company+import           Test.Data.Registry.Generators+import           Test.Tasty.Hedgehogx          hiding (lift)++-- * 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++-- * DECLARING PROPERTIES++test_a_simple_test =+  test "make a simple assertion, tested only once" $+    1 === 1++test_a_simple_property =+  prop "make a simple property, tested 100 times by default" $ do+    n <- forAll (integral (linear 1 3))+    n === n++test_a_property_200_times = minTestsOk 200 $+  prop "make a simple property, tested 200 times" $ do+    n <- forAll (integral (linear 1 3))+    n === n++test_a_property_no_shrinking = noShrink $+  prop "make a simple property, not shrinked in case of a failure" $ do+    n <- forAll (integral (linear 1 3))+    n === n++test_a_property_with_a_seed = withSeed "(Size 51) (Seed 35539461314630919 5029106023111197789)" $+  prop "make a simple property, with a specific seed to reproduce a failure" $ do+    n <- forAll (integral (linear 1 3))+    (n >= 1) === True++-- * USING GENERATORS++test_company_1 =+  prop "a company can be used for testing" $ do+    -- note that we are using forall and not forAll+    company <- forall @Company+    (length (departments company) >= 0) === True++-- Let's create some registry modifiers to constrain the generation+setOneDepartment = addFunS $ listOfMinMax @Department 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++-- * 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++    -- 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 = noShrink $+  prop "we can cycle deterministically across all the constructors of a data type" $ runS generators $ do+    setGenS @Int (pure 1)+    setCycleChooserS @EmployeeStatus++    names <- replicateM 10 (forallS @EmployeeStatus)+    names === take 10 (join $ repeat [Permanent, Temporary 1])++-- 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++   departments <- replicateM 10 (forallS @Department)+   let names = departmentName <$> departments+   names === nub names
+ test/test.hs view
@@ -0,0 +1,5 @@+import           AutoDiscoveredSpecs   (tests)+import           Protolude+import           Test.Tasty.Hedgehogx++main = tests >>= defaultMain . groupByModuleName