diff --git a/src/HedgehogExample.hs b/src/HedgehogExample.hs index a1a4646..63ab184 100644 --- a/src/HedgehogExample.hs +++ b/src/HedgehogExample.hs @@ -9,30 +9,20 @@ 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 + def = pureRecipe $ Name <$> text (linear 3 20) unicode instance MonadGen m => DefaultRecipe Identity (m Email) where type DefaultRecipeDeps Identity (m Email) = '[] @@ -42,28 +32,25 @@ instance MonadGen m => DefaultRecipe Identity (m Email) where pure $ Email $ (user <> "@" <> host) instance MonadGen m => DefaultRecipe Identity (m Person) where - type DefaultRecipeDeps Identity (m Person) = '[m Name, m Address, m Email] + type DefaultRecipeDeps Identity (m Person) = '[m Name, m Email] def = Recipe $ \deps -> pure $ do name <- grab deps - address <- grab deps email <- grab deps - pure $ Person name address email + pure $ Person name 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 + pure $ Company employees 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 + pure $ Company employees largeCompanyGen :: forall m. MonadGen m => (m Company) largeCompanyGen = runIdentity $ finish (largeCompanyGen' @m ./ nil) -- TODO why is this annotation required? diff --git a/src/Tests.hs b/src/Tests.hs index 338ef6d..0c576dd 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -50,3 +50,7 @@ c5 = finish nil rc5 :: Identity M5 rc5 = finish (r5 ./ nil) + +-- Should fail with "not everything is applied" +-- rc4fail :: Identity M4 +-- rc4fail = finish (r5 ./ nil) diff --git a/src/V2.hs b/src/V2.hs index 3d5053e..d26be14 100644 --- a/src/V2.hs +++ b/src/V2.hs @@ -13,7 +13,7 @@ import qualified Data.Sequence as S import Data.Diverse.Many.Internal (Many(..)) import Unsafe.Coerce import Numbers --- import GHC.TypeLits as Lits +import GHC.TypeLits as Lits pureRecipe :: Applicative effect => target -> Recipe effect target '[] pureRecipe target = Recipe $ \_ -> pure target @@ -120,13 +120,28 @@ instance forall effect target book state. (s2r, deps) :: (Many state, Many (RecipeDeps effect target book)) <- s2 (res s2r deps) :: effect (Many state, target) -finish :: forall target (effect:: * -> *) (book :: [*]) (store :: [*]). +type family Contains (target :: *) (store :: [*]) :: Bool where + Contains target (target ': t) = True + Contains target (h ': t) = Contains target t + Contains target '[] = False + +type family EverythingIsAppliedTypeError (bool :: Bool) (s :: Type) (b :: [Type]) :: Constraint where + EverythingIsAppliedTypeError True s b = () + EverythingIsAppliedTypeError False s b = TypeError ('Text "The type " ':<>: ShowType s ':<>: 'Text " is not overriding anything in " ':<>: ShowType b) + +type family EverythingIsApplied (effect :: * -> *) target (book :: [*]) (store :: [*]) :: Constraint where + EverythingIsApplied effect target ((Recipe effect head _) ': tBook) store = (EverythingIsAppliedTypeError (Contains head store) head store, EverythingIsApplied effect target tBook store) + EverythingIsApplied effect target (head ': tBook) store = TypeError ('Text "The type " ':<>: ShowType head ':<>: 'Text " is not a Recipe") + EverythingIsApplied effect target '[] store = () + +finish :: forall (effect :: * -> *) target (book :: [*]) (store :: [*]). ( store ~ (LiftMaybe (Nub (RecipeDepsRec effect target book (RecipeDeps effect target book)))) , ToS (ListLen (EmptyStore effect target book)) , HasRecipe effect target book , Monad effect , (SubSelect effect book (RecipeDeps effect target book) store) , (UniqueMember (Maybe target) store) + , EverythingIsApplied effect target book (Nub (RecipeDepsRec effect target book (RecipeDeps effect target book))) ) => Many book -> effect target finish book = do @@ -136,8 +151,6 @@ finish book = do (_, target) <- cook book store (Proxy @target) pure target --- test - class DefaultRecipe (effect :: * -> *) target where type DefaultRecipeDeps effect target :: [*] def :: Recipe effect target (DefaultRecipeDeps effect target)