diff --git a/registry-hedgehog.cabal b/registry-hedgehog.cabal --- a/registry-hedgehog.cabal +++ b/registry-hedgehog.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1. +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: 59c5449086a8961a437bf9bc91bda342652afd55b95b175fbf240a9f0c5537f8 +-- hash: 8e9ef405c71b1f7fffa4735a082d31c503420e8345fd885ef0408becd6689cc4 name: registry-hedgehog -version: 0.2.1.0 +version: 0.2.1.1 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 @@ -60,6 +60,13 @@ Test.Data.Registry.Company Test.Data.Registry.Generators Test.Data.Registry.HedgehogSpec + Test.Tutorial.DataModel + Test.Tutorial.Exercise1 + Test.Tutorial.Exercise2 + Test.Tutorial.Exercise3 + Test.Tutorial.Exercise4 + Test.Tutorial.Exercise5 + Test.Tutorial.Exercise6 Paths_registry_hedgehog hs-source-dirs: test diff --git a/src/Test/Tasty/Hedgehogx.hs b/src/Test/Tasty/Hedgehogx.hs --- a/src/Test/Tasty/Hedgehogx.hs +++ b/src/Test/Tasty/Hedgehogx.hs @@ -34,7 +34,6 @@ 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 @@ -199,7 +198,7 @@ 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 +-- and all the tests retrieved by tasty-discovery which have the type :: IO TestTree class Runnable t where runIt :: t -> IO TestTree diff --git a/test/Test/Data/Registry/HedgehogSpec.hs b/test/Test/Data/Registry/HedgehogSpec.hs --- a/test/Test/Data/Registry/HedgehogSpec.hs +++ b/test/Test/Data/Registry/HedgehogSpec.hs @@ -1,28 +1,39 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# 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 Control.Monad.Morph (hoist) +import Data.IORef import Data.Registry import Data.Registry.Hedgehog -import qualified Data.Text as T (length, take, toUpper) 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 qualified Data.Text as T +import qualified Data.Text.IO as T -- * 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 +genWord :: MonadIO m => GenT m Text +genWord = do + ws <- T.lines <$> liftIO (T.readFile "/usr/share/dict/words") + Gen.element ws + test_a_simple_test = test "make a simple assertion, tested only once" $ 1 === 1 @@ -104,3 +115,87 @@ -- uncomment to check -- collect =<< departmentName <$> forallS @Department success + + +test_ints_generator = + prop "we can generate ints" $ do + n <- forAllT distinctInt + n === n -- collect n + +test_fresh = minTestsOk 10000 $ + prop "we can generate terms with fresh ids" $ do + -- let termGenerator = genTerm :: GenT (StateT Int Identity) Term + m <- forAll $ runStateGen genTerm + -- collect m + m === m + +genFixedText :: (MonadGen m) => m Text +genFixedText = pure "xxx" + +genTerm :: (MonadGen m, Fresh m) => m Term +genTerm = Gen.recursive Gen.choice [genValue genFixedText] [Gen.subtermM2 genTerm genTerm makeExp] + +genValue :: (MonadGen m, Fresh m) => m Text -> m Term +genValue g = do + t <- g + makeValue t + +data Term = + Value Int Text + | Exp Int Term Term + deriving (Eq, Show) + +makeValue :: (Monad m, Fresh m) => Text -> m Term +makeValue t = do + n <- fresh + pure (Value n t) + +makeExp :: (Monad m, Fresh m) => Term -> Term -> m Term +makeExp t1 t2 = do + n <- fresh + pure (Exp n t1 t2) + +class Fresh m where + fresh :: m Int + +runFresh :: (Show a) => GenT (State Int) a -> PropertyT IO a +runFresh = forAll . runStateGen + +runStateGen :: (Show a) => GenT (State Int) a -> Gen a +runStateGen = hoist (pure . flip evalState 0 ) + +instance Fresh (GenT (State Int)) where + fresh = do + n <- get + put (n + 1) + pure n + +-- | 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) + +{-# NOINLINE distinctInt #-} +distinctInt :: GenIO Int +distinctInt = unsafePerformIO $ do + ref <- newIORef (0 :: Int) + pure $ distinctIntGenerator ref + +distinctIntGenerator :: IORef Int -> GenIO Int +distinctIntGenerator ref = do + i <- lift $ readIORef ref + lift $ writeIORef ref (i + 1) + pure i diff --git a/test/Test/Tutorial/DataModel.hs b/test/Test/Tutorial/DataModel.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/DataModel.hs @@ -0,0 +1,25 @@ +module Test.Tutorial.DataModel where + +import Protolude + +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) + +data EmployeeStatus = + Permanent + | Temporary Int -- number of days + deriving (Eq, Show) diff --git a/test/Test/Tutorial/Exercise1.hs b/test/Test/Tutorial/Exercise1.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Exercise1.hs @@ -0,0 +1,36 @@ +{-# 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 + +registry :: Registry _ _ +registry = + genFun Company + <: genFun Department + <: genFun Employee + <: genVal genEmployeeStatus + <: genVal genInt + <: genVal genText + +genInt :: Gen Int +genInt = integral (linear 1 3) + +genText :: Gen Text +genText = text (linear 1 10) alpha + +genEmployeeStatus :: Gen EmployeeStatus +genEmployeeStatus = pure Permanent + +-- this does not compile the registry is not complete +-- makeCompanyGen :: GenIO Company +-- makeCompanyGen = make @(GenIO Company) registry diff --git a/test/Test/Tutorial/Exercise2.hs b/test/Test/Tutorial/Exercise2.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Exercise2.hs @@ -0,0 +1,47 @@ +{-# 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 + +registry :: Registry _ _ +registry = + 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) + +genText :: Gen Text +genText = text (linear 1 10) alpha + +genEmployeeStatus :: Gen EmployeeStatus +genEmployeeStatus = pure Permanent + +-- this compiles ok now +makeCompanyGen :: GenIO Company +makeCompanyGen = make @(GenIO Company) registry + +forall :: forall a . (Typeable a, Show a) => PropertyT IO a +forall = forAllT $ genWith @a registry + +test_company = test "make a company" $ do + _ <- forall @Company + success diff --git a/test/Test/Tutorial/Exercise3.hs b/test/Test/Tutorial/Exercise3.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Exercise3.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# 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) + +registry3 :: Registry _ _ +registry3 = $(makeGenerators ''EmployeeStatus) <: registry + +forall :: forall a . (Typeable a, Show a) => PropertyT IO a +forall = forAllT $ genWith @a registry3 + +test_employee_status = prop "make an employee status" $ do + status <- forall @EmployeeStatus + collect status diff --git a/test/Test/Tutorial/Exercise4.hs b/test/Test/Tutorial/Exercise4.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Exercise4.hs @@ -0,0 +1,29 @@ +{-# 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) + +registry12 :: Registry _ _ +registry12 = specializeGen @Department genDepartmentName $ registry3 + +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 + +test_deparment_name = prop "make a department" $ do + department <- forall @Department + collect (departmentName department) diff --git a/test/Test/Tutorial/Exercise5.hs b/test/Test/Tutorial/Exercise5.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Exercise5.hs @@ -0,0 +1,35 @@ +{-# 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) + +runGens = runS registry3 + +genEmployeeName :: Gen Text +genEmployeeName = T.take 10 . T.toLower <$> genText + +setDepartmentName = specializeGenS @Department genDepartmentName +setEmployeeName = specializeGenS @Employee genEmployeeName + +setOneDepartment = addFunS $ listOfMinMax @Department 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 diff --git a/test/Test/Tutorial/Exercise6.hs b/test/Test/Tutorial/Exercise6.hs new file mode 100644 --- /dev/null +++ b/test/Test/Tutorial/Exercise6.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# 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 + +test_another_small_company = prop "make a small company" $ runGens $ do + setSmallCompany + setEmployeeName + setDepartmentName + setGenS @Int (pure 1) + setDistinctForS @Department @Text + + collect =<< forallS @Company + + setCycleChooserS @EmployeeStatus + collect =<< forallS @EmployeeStatus