diff --git a/package.yaml b/package.yaml index 5f403c9..447b73e 100644 --- a/package.yaml +++ b/package.yaml @@ -26,6 +26,7 @@ dependencies: - data-diverse - containers - unordered-containers +- hedgehog default-extensions: - NoImplicitPrelude @@ -63,7 +64,6 @@ default-extensions: - TypeFamilies - TypeFamilyDependencies - TypeOperators - - UndecidableInstances library: source-dirs: src diff --git a/src/HedgehogExample.hs b/src/HedgehogExample.hs new file mode 100644 index 0000000..a1a4646 --- /dev/null +++ b/src/HedgehogExample.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE ApplicativeDo #-} +module HedgehogExample where + +import Hedgehog +import Hedgehog.Gen as Gen +import Hedgehog.Range as Range +import Universum +import V2 +import Data.Diverse + +newtype Name = Name Text +newtype Address = Address Text +newtype Email = Email Text + +data Person = Person + { _name :: Name + , _address :: Address + , _email :: Email + } + +data Company = Company + { _employees :: [Person] + , _ceo :: Person } + +instance MonadGen m => DefaultRecipe Identity (m Name) where + type DefaultRecipeDeps Identity (m Name) = '[] + def = pureRecipe $ do + name <- text (linear 3 20) unicode + pure $ Name name + +instance MonadGen m => DefaultRecipe Identity (m Address) where + type DefaultRecipeDeps Identity (m Address) = '[] + def = pureRecipe $ do + name <- text (linear 3 20) unicode + pure $ Address name + +instance MonadGen m => DefaultRecipe Identity (m Email) where + type DefaultRecipeDeps Identity (m Email) = '[] + def = pureRecipe $ do + user <- text (linear 3 20) ascii + host <- text (linear 3 10) ascii + pure $ Email $ (user <> "@" <> host) + +instance MonadGen m => DefaultRecipe Identity (m Person) where + type DefaultRecipeDeps Identity (m Person) = '[m Name, m Address, m Email] + def = Recipe $ \deps -> pure $ do + name <- grab deps + address <- grab deps + email <- grab deps + pure $ Person name address email + +instance MonadGen m => DefaultRecipe Identity (m Company) where + type DefaultRecipeDeps Identity (m Company) = '[m Person] + def = Recipe $ \deps -> pure $ do + ceo <- grab deps + employees <- Gen.list (linear 3 10) (grab deps) + pure $ Company employees ceo + +regularGen :: MonadGen m => m Company +regularGen = runIdentity $ finish nil + +largeCompanyGen' :: forall (m :: * -> *). MonadGen m => Recipe Identity (m Company) '[m Person] +largeCompanyGen' = Recipe $ \deps -> pure $ do + ceo <- grab deps + employees <- Gen.list (linear 100 1000) (grab deps) + pure $ Company employees ceo + +largeCompanyGen :: forall m. MonadGen m => (m Company) +largeCompanyGen = runIdentity $ finish (largeCompanyGen' @m ./ nil) -- TODO why is this annotation required? + +fixedEmailGen' :: forall m. MonadGen m => Text -> Recipe Identity (m Email) '[] +fixedEmailGen' domain = pureRecipe $ do + user <- text (linear 3 20) ascii + pure $ Email $ (user <> "@" <> domain) + +fixedEmailGen :: forall m. MonadGen m => (m Company) +fixedEmailGen = runIdentity $ finish (fixedEmailGen' @m "company.com" ./ nil) diff --git a/src/TestData.hs b/src/TestData.hs new file mode 100644 index 0000000..749a712 --- /dev/null +++ b/src/TestData.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} + +module TestData where + +import V2 +import Universum hiding (Nat) +import Data.Diverse + +forceResult :: Proxy a -> Proxy a -> Proxy a +forceResult _ _ = Proxy + +data M0 = M0 M1 M3 +data M1 = M1 M2 M3 +newtype M2 = M2 () +newtype M3 = M3 M4 +newtype M4 = M4 () +newtype M5 = M5 M0 + +instance DefaultRecipe Identity M0 where + type DefaultRecipeDeps Identity M0 = '[M1, M3] + def = Recipe $ \deps -> pure $ M0 (grab deps) (grab deps) + +instance DefaultRecipe Identity M1 where + type DefaultRecipeDeps Identity M1 = '[M2, M3] + def = Recipe $ \deps -> pure $ M1 (grab deps) (grab deps) + +instance DefaultRecipe Identity M2 where + type DefaultRecipeDeps Identity M2 = '[] + def = Recipe $ \deps -> pure $ M2 () + +instance DefaultRecipe Identity M3 where + type DefaultRecipeDeps Identity M3 = '[M4] + def = Recipe $ \deps -> pure $ M3 (grab deps) + +instance DefaultRecipe Identity M4 where + type DefaultRecipeDeps Identity M4 = '[] + def = Recipe $ \deps -> pure $ M4 () + +instance DefaultRecipe Identity M5 where + type DefaultRecipeDeps Identity M5 = '[M0] + def = Recipe $ \deps -> pure $ M5 (grab deps) diff --git a/src/V2.hs b/src/V2.hs index 5b05639..3d5053e 100644 --- a/src/V2.hs +++ b/src/V2.hs @@ -15,7 +15,7 @@ import Unsafe.Coerce import Numbers -- import GHC.TypeLits as Lits -pureRecipe :: Applicative effect => target -> Recipe effect target $ empty +pureRecipe :: Applicative effect => target -> Recipe effect target '[] pureRecipe target = Recipe $ \_ -> pure target -- - first calculate the required storage for state via type family