-
Notifications
You must be signed in to change notification settings - Fork 1
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
1 parent
1415d88
commit 075c8eb
Showing
4 changed files
with
121 additions
and
2 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters