diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,16 @@ +Copyright (c) 2019 Eric Torreborre + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/registry-hedgehog.cabal b/registry-hedgehog.cabal new file mode 100644 --- /dev/null +++ b/registry-hedgehog.cabal @@ -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 diff --git a/src/Data/Registry/Hedgehog.hs b/src/Data/Registry/Hedgehog.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Hedgehog.hs @@ -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' diff --git a/src/Data/Registry/Hedgehog/TH.hs b/src/Data/Registry/Hedgehog/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Hedgehog/TH.hs @@ -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" diff --git a/src/Data/Registry/Internal/Hedgehog.hs b/src/Data/Registry/Internal/Hedgehog.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Internal/Hedgehog.hs @@ -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 diff --git a/src/Data/Registry/Internal/TH.hs b/src/Data/Registry/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Internal/TH.hs @@ -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")) diff --git a/src/Test/Tasty/Hedgehogx.hs b/src/Test/Tasty/Hedgehogx.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Hedgehogx.hs @@ -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 diff --git a/test/AutoDiscoveredSpecs.hs b/test/AutoDiscoveredSpecs.hs new file mode 100644 --- /dev/null +++ b/test/AutoDiscoveredSpecs.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=AutoDiscoveredSpecs #-} diff --git a/test/Test/Data/Registry/Company.hs b/test/Test/Data/Registry/Company.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Company.hs @@ -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) diff --git a/test/Test/Data/Registry/Generators.hs b/test/Test/Data/Registry/Generators.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Generators.hs @@ -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) diff --git a/test/Test/Data/Registry/HedgehogSpec.hs b/test/Test/Data/Registry/HedgehogSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/HedgehogSpec.hs @@ -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 diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,5 @@ +import AutoDiscoveredSpecs (tests) +import Protolude +import Test.Tasty.Hedgehogx + +main = tests >>= defaultMain . groupByModuleName