graphula 2.0.2.2 → 2.1.0.0
raw patch · 15 files changed
+499/−298 lines, 15 filesdep ~HUnitdep ~QuickCheckdep ~containerssetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: HUnit, QuickCheck, containers, directory, generic-arbitrary, generics-eot, hspec, markdown-unlit, monad-logger, mtl, persistent, persistent-sqlite, persistent-template, random, resourcet, semigroups, temporary, text, transformers, unliftio, unliftio-core
API changes (from Hackage documentation)
- Graphula.Dependencies: instance (Graphula.Dependencies.GenerateKeyInternal (Graphula.Dependencies.KeySource a) a, Graphula.Dependencies.KeyConstraint (Graphula.Dependencies.KeySource a) a) => Graphula.Dependencies.GenerateKey a
+ Graphula: insertKeyed :: (MonadGraphulaFrontend m, PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m) => Key a -> a -> m (Maybe (Entity a))
+ Graphula.Class: insertKeyed :: (MonadGraphulaFrontend m, PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m) => Key a -> a -> m (Maybe (Entity a))
+ Graphula.Dependencies: Optional :: Maybe a -> Optional a
+ Graphula.Dependencies: Required :: a -> Required a
+ Graphula.Dependencies: class InsertWithPossiblyRequiredKey (requirement :: Type -> Type) where {
+ Graphula.Dependencies: insertWithPossiblyRequiredKey :: (InsertWithPossiblyRequiredKey requirement, PersistEntityBackend record ~ SqlBackend, PersistEntity record, Monad m, MonadGraphulaFrontend m, InsertConstraint requirement record) => requirement (Key record) -> record -> m (Maybe (Entity record))
+ Graphula.Dependencies: instance (Graphula.Dependencies.GenerateKeyInternal (Graphula.Dependencies.KeySource a) a, Graphula.Dependencies.KeyConstraint (Graphula.Dependencies.KeySource a) a, Graphula.Dependencies.InsertWithPossiblyRequiredKey (Graphula.Dependencies.KeySourceTypeInternalM (Graphula.Dependencies.KeySource a)), Graphula.Dependencies.InsertConstraint (Graphula.Dependencies.KeySourceTypeInternalM (Graphula.Dependencies.KeySource a)) a) => Graphula.Dependencies.GenerateKey a
+ Graphula.Dependencies: instance Graphula.Dependencies.InsertWithPossiblyRequiredKey Graphula.Dependencies.Optional
+ Graphula.Dependencies: instance Graphula.Dependencies.InsertWithPossiblyRequiredKey Graphula.Dependencies.Required
+ Graphula.Dependencies: justKey :: InsertWithPossiblyRequiredKey requirement => key -> requirement key
+ Graphula.Dependencies: newtype Optional a
+ Graphula.Dependencies: newtype Required a
+ Graphula.Dependencies: type InsertConstraint requirement :: Type -> Constraint;
+ Graphula.Dependencies: type KeyForInsert record = KeyRequirementForInsertInternal record (Key record)
+ Graphula.Dependencies: type KeyRequirementForInsert record = KeySourceTypeM (KeySource record)
+ Graphula.Dependencies: type family KeySourceTypeM (t :: KeySourceType) :: Type -> Type
- Graphula: class (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a) => GenerateKey a
+ Graphula: class (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a, InsertWithPossiblyRequiredKey (KeySourceTypeInternalM (KeySource a)), InsertConstraint (KeySourceTypeInternalM (KeySource a)) a) => GenerateKey a
- Graphula: node :: forall a m. (MonadGraphula m, Logging m a, Arbitrary a, HasDependencies a, GenerateKey a, PersistEntityBackend a ~ SqlBackend, PersistEntity a, Typeable a, GraphulaSafeToInsert a) => Dependencies a -> NodeOptions a -> m (Entity a)
+ Graphula: node :: forall a m. (MonadGraphula m, Logging m a, Arbitrary a, HasDependencies a, GenerateKey a, PersistEntityBackend a ~ SqlBackend, PersistEntity a, Typeable a) => Dependencies a -> NodeOptions a -> m (Entity a)
- Graphula: nodeKeyed :: forall a m. (MonadGraphula m, Logging m a, Arbitrary a, HasDependencies a, PersistEntityBackend a ~ SqlBackend, PersistEntity a, Typeable a, GraphulaSafeToInsert a) => Key a -> Dependencies a -> NodeOptions a -> m (Entity a)
+ Graphula: nodeKeyed :: forall a m. (MonadGraphula m, Logging m a, Arbitrary a, HasDependencies a, PersistEntityBackend a ~ SqlBackend, PersistEntity a, Typeable a) => Key a -> Dependencies a -> NodeOptions a -> m (Entity a)
- Graphula.Dependencies: class (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a) => GenerateKey a
+ Graphula.Dependencies: class (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a, InsertWithPossiblyRequiredKey (KeySourceTypeInternalM (KeySource a)), InsertConstraint (KeySourceTypeInternalM (KeySource a)) a) => GenerateKey a
- Graphula.Dependencies: generateKey :: (GenerateKeyInternal s a, KeyConstraint s a) => Gen (Maybe (Key a))
+ Graphula.Dependencies: generateKey :: (GenerateKeyInternal s a, KeyConstraint s a) => Gen (KeySourceTypeInternalM s (Key a))
- Graphula.Node: node :: forall a m. (MonadGraphula m, Logging m a, Arbitrary a, HasDependencies a, GenerateKey a, PersistEntityBackend a ~ SqlBackend, PersistEntity a, Typeable a, GraphulaSafeToInsert a) => Dependencies a -> NodeOptions a -> m (Entity a)
+ Graphula.Node: node :: forall a m. (MonadGraphula m, Logging m a, Arbitrary a, HasDependencies a, GenerateKey a, PersistEntityBackend a ~ SqlBackend, PersistEntity a, Typeable a) => Dependencies a -> NodeOptions a -> m (Entity a)
- Graphula.Node: nodeKeyed :: forall a m. (MonadGraphula m, Logging m a, Arbitrary a, HasDependencies a, PersistEntityBackend a ~ SqlBackend, PersistEntity a, Typeable a, GraphulaSafeToInsert a) => Key a -> Dependencies a -> NodeOptions a -> m (Entity a)
+ Graphula.Node: nodeKeyed :: forall a m. (MonadGraphula m, Logging m a, Arbitrary a, HasDependencies a, PersistEntityBackend a ~ SqlBackend, PersistEntity a, Typeable a) => Key a -> Dependencies a -> NodeOptions a -> m (Entity a)
Files
- CHANGELOG.md +8/−2
- README.md +6/−0
- Setup.hs +1/−0
- graphula.cabal +27/−27
- src/Graphula.hs +74/−59
- src/Graphula/Arbitrary.hs +0/−1
- src/Graphula/Class.hs +24/−7
- src/Graphula/Dependencies.hs +143/−65
- src/Graphula/Dependencies/Generic.hs +73/−40
- src/Graphula/Idempotent.hs +16/−7
- src/Graphula/Key.hs +15/−10
- src/Graphula/Logged.hs +17/−11
- src/Graphula/NoConstraint.hs +0/−1
- src/Graphula/Node.hs +89/−68
- test/README.lhs +6/−0
CHANGELOG.md view
@@ -1,6 +1,12 @@-## [*Unreleased*](https://github.com/freckle/graphula/compare/v2.0.2.1...main)+## [_Unreleased_](https://github.com/freckle/graphula/compare/v2.1.0.0...main) -None+## [v2.1.0.0](https://github.com/freckle/graphula/compare/v2.0.2.2...v2.1.0.0)++- Some unnecessary `SafeToInsert` have been removed from `node` and `nodeKeyed`.+ - `node` only requires `SafeToInsert` when the `KeySource` is `SourceDefault`,+ not when the `KeySource` is `KeyArbitrary`.+ - `nodeKeyed` no longer ever requires `SafeToInsert`+- `MonadGraphulaFrontend` has a new `insertKeyed` method. ## [v2.0.2.2](https://github.com/freckle/graphula/compare/v2.0.2.1...v2.0.2.2)
README.md view
@@ -1,5 +1,10 @@ # Graphula +[](https://hackage.haskell.org/package/graphula)+[](http://stackage.org/nightly/package/graphula)+[](http://stackage.org/lts/package/graphula)+[](https://github.com/freckle/graphula/actions/workflows/ci.yml)+ Graphula is a simple interface for generating persistent data and linking its dependencies. We use this interface to generate fixtures for automated testing. @@ -20,6 +25,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
graphula.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: graphula-version: 2.0.2.2+version: 2.1.0.0 license: MIT license-file: LICENSE maintainer: Freckle Education@@ -45,23 +45,23 @@ -Wno-missing-import-lists -Wno-safe -Wno-unsafe build-depends:- HUnit,- QuickCheck,+ HUnit >=1.6.0.0,+ QuickCheck >=2.11.3, base >=4.11.1.0 && <5,- containers,- directory,- generics-eot,- mtl,- persistent,- random,- semigroups,- temporary,- text,- unliftio,- unliftio-core+ containers >=0.5.11.0,+ directory >=1.3.1.5,+ generics-eot >=0.4,+ mtl >=2.2.2,+ persistent >=2.8.2,+ random >=1.1,+ semigroups >=0.18.5,+ temporary >=1.3,+ text >=1.2.3.1,+ unliftio >=0.2.9.0,+ unliftio-core >=0.1.2.0 if impl(ghc >=9.2)- ghc-options: -Wno-missing-kind-signatures+ ghc-options: -Wno-missing-kind-signatures -Wno-operator-whitespace if impl(ghc >=8.10) ghc-options:@@ -82,21 +82,21 @@ markdown-unlit build-depends:- QuickCheck,+ QuickCheck >=2.11.3, base >=4.11.1.0 && <5,- generic-arbitrary,+ generic-arbitrary >=0.1.0, graphula,- hspec,- markdown-unlit,- monad-logger,- persistent,- persistent-sqlite,- resourcet,- transformers,- unliftio-core+ hspec >=2.5.5,+ markdown-unlit >=0.5.0,+ monad-logger >=0.3.30,+ persistent >=2.8.2,+ persistent-sqlite >=2.8.2,+ resourcet >=1.2.2,+ transformers >=0.5.5.0,+ unliftio-core >=0.1.2.0 if impl(ghc >=9.2)- ghc-options: -Wno-missing-kind-signatures+ ghc-options: -Wno-missing-kind-signatures -Wno-operator-whitespace if impl(ghc >=8.10) ghc-options:@@ -109,4 +109,4 @@ ghc-options: -Wno-missing-deriving-strategies if flag(persistent-template)- build-depends: persistent-template+ build-depends: persistent-template >=2.5.4
src/Graphula.hs view
@@ -72,64 +72,64 @@ -- $ 'ensure' -- $ not . courseIsArchived -- @--- module Graphula- (- -- * Basic usage- -- ** Model requirements- HasDependencies(..)- , Only(..)+ ( -- * Basic usage++ -- ** Model requirements+ HasDependencies (..)+ , Only (..) , only - -- ** Defining the graph+ -- ** Defining the graph , node , edit , ensure - -- ** Running the graph+ -- ** Running the graph , GraphulaT , runGraphulaT- , GenerationFailure(..)+ , GenerationFailure (..) - -- * Advanced usage- -- ** Non-serial keys- , KeySourceType(..)+ -- * Advanced usage++ -- ** Non-serial keys+ , KeySourceType (..) , nodeKeyed - -- ** Running with logging+ -- ** Running with logging , GraphulaLoggedT , runGraphulaLoggedT , runGraphulaLoggedWithFileT - -- ** Running idempotently+ -- ** Running idempotently , GraphulaIdempotentT , runGraphulaIdempotentT - -- * Useful synonymns- -- |- --- -- When declaring your own functions that call 'node', these synonyms can help- -- with the constraint soup.- --- -- > genSchoolWithTeacher- -- > :: GraphulaContext m '[School, Teacher]- -- > -> m (Entity Teacher)- -- > genSchoolWithTeacher = do- -- > school <- node @School () mempty- -- > node @Teacher (onlyKey school) mempty- --+ -- * Useful synonymns++ -- |+ --+ -- When declaring your own functions that call 'node', these synonyms can help+ -- with the constraint soup.+ --+ -- > genSchoolWithTeacher+ -- > :: GraphulaContext m '[School, Teacher]+ -- > -> m (Entity Teacher)+ -- > genSchoolWithTeacher = do+ -- > school <- node @School () mempty+ -- > node @Teacher (onlyKey school) mempty , GraphulaContext , GraphulaNode - -- * Lower-level details- -- |- --- -- These exports are likely to be removed from this module in a future- -- version. If you are using them, consider importing from their own modules.- --+ -- * Lower-level details++ -- |+ --+ -- These exports are likely to be removed from this module in a future+ -- version. If you are using them, consider importing from their own modules. , MonadGraphula- , MonadGraphulaBackend(..)- , MonadGraphulaFrontend(..)+ , MonadGraphulaBackend (..)+ , MonadGraphulaFrontend (..) , NodeOptions , GenerateKey , NoConstraint@@ -150,9 +150,9 @@ , delete , get , getEntity- , insertKey , insertUnique )+import qualified Database.Persist as Persist import Database.Persist.Sql (SqlBackend) import Graphula.Class import Graphula.Dependencies@@ -162,8 +162,11 @@ import Graphula.Node import System.Random (randomIO) import Test.HUnit.Lang- (FailureReason(..), HUnitFailure(..), formatFailureReason)-import Test.QuickCheck (Arbitrary(..))+ ( FailureReason (..)+ , HUnitFailure (..)+ , formatFailureReason+ )+import Test.QuickCheck (Arbitrary (..)) import Test.QuickCheck.Random (QCGen, mkQCGen) import UnliftIO.Exception (catch, throwIO) @@ -179,10 +182,9 @@ -- node @C (a, b) $ edit $ \n -> -- n { cc = "spanish" } -- @--- type family GraphulaContext (m :: Type -> Type) (ts :: [Type]) :: Constraint where- GraphulaContext m '[] = MonadGraphula m- GraphulaContext m (t ': ts) = (GraphulaNode m t, GraphulaContext m ts)+ GraphulaContext m '[] = MonadGraphula m+ GraphulaContext m (t ': ts) = (GraphulaNode m t, GraphulaContext m ts) data Args backend n m = Args { dbRunner :: RunDB backend n m@@ -191,9 +193,9 @@ newtype RunDB backend n m = RunDB (forall b. ReaderT backend n b -> m b) -newtype GraphulaT n m a =- GraphulaT { runGraphulaT' :: ReaderT (Args SqlBackend n m) m a }- deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (Args SqlBackend n m))+newtype GraphulaT n m a = GraphulaT {runGraphulaT' :: ReaderT (Args SqlBackend n m) m a}+ deriving newtype+ (Functor, Applicative, Monad, MonadIO, MonadReader (Args SqlBackend n m)) instance MonadTrans (GraphulaT n) where lift = GraphulaT . lift@@ -212,17 +214,28 @@ insert mKey n = do RunDB runDB <- asks dbRunner lift . runDB $ case mKey of- Nothing -> insertUnique n >>= \case- Nothing -> pure Nothing- Just key -> getEntity key+ Nothing ->+ insertUnique n >>= \case+ Nothing -> pure Nothing+ Just key -> getEntity key Just key -> do existingKey <- get key whenNothing existingKey $ do existingUnique <- checkUnique n whenNothing existingUnique $ do- insertKey key n+ Persist.insertKey key n getEntity key + insertKeyed key n = do+ RunDB runDB <- asks dbRunner+ lift . runDB $ do+ existingKey <- get key+ whenNothing existingKey $ do+ existingUnique <- checkUnique n+ whenNothing existingUnique $ do+ Persist.insertKey key n+ getEntity key+ remove key = do RunDB runDB <- asks dbRunner lift . runDB $ delete key@@ -232,9 +245,11 @@ whenNothing (Just _) _ = pure Nothing runGraphulaT- :: (MonadUnliftIO m)- => Maybe Int -- ^ Optional seed- -> (forall b . ReaderT SqlBackend n b -> m b) -- ^ Database runner+ :: MonadUnliftIO m+ => Maybe Int+ -- ^ Optional seed+ -> (forall b. ReaderT SqlBackend n b -> m b)+ -- ^ Database runner -> GraphulaT n m a -> m a runGraphulaT mSeed runDB action = do@@ -250,11 +265,11 @@ rethrowHUnitWith message (HUnitFailure l r) = throwIO . HUnitFailure l . Reason $ message ++ "\n\n" ++ formatFailureReason r -type GraphulaNode m a- = ( HasDependencies a- , Logging m a- , PersistEntityBackend a ~ SqlBackend- , PersistEntity a- , Typeable a- , Arbitrary a- )+type GraphulaNode m a =+ ( HasDependencies a+ , Logging m a+ , PersistEntityBackend a ~ SqlBackend+ , PersistEntity a+ , Typeable a+ , Arbitrary a+ )
src/Graphula/Arbitrary.hs view
@@ -17,7 +17,6 @@ -- This is akin to 'Test.QuickCheck.generate', but utilizing graphula's -- generation. The size passed to the generator is always 30; if you want -- another size then you should explicitly use 'Test.QuickCheck.resize'.--- generate :: (MonadIO m, MonadGraphulaBackend m) => Gen a -> m a generate gen = do genRef <- askGen
src/Graphula/Class.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -13,21 +13,23 @@ -- | Internal type class(es) for Graphula-related behaviors module Graphula.Class ( MonadGraphula- , MonadGraphulaFrontend(..)- , MonadGraphulaBackend(..)+ , MonadGraphulaFrontend (..)+ , MonadGraphulaBackend (..) , GraphulaSafeToInsert ) where import Control.Monad.IO.Class (MonadIO) import Data.IORef (IORef) import Data.Kind (Constraint, Type)-import Database.Persist (Entity(..), Key, PersistEntity, PersistEntityBackend)+import Database.Persist (Entity (..), Key, PersistEntity, PersistEntityBackend) import Database.Persist.Sql (SqlBackend) import Test.QuickCheck.Random (QCGen) #if MIN_VERSION_persistent(2,14,0) import Database.Persist.Class.PersistEntity (SafeToInsert) #endif +{- FOURMOLU_DISABLE -}+ -- | A class that provides backwards compatibility with @persistent-2.14@ -- -- If you are using that version or above, then this is a class alias for@@ -49,13 +51,28 @@ #endif GraphulaSafeToInsert a -type MonadGraphula m- = (Monad m, MonadIO m, MonadGraphulaBackend m, MonadGraphulaFrontend m)+{- FOURMOLU_ENABLE -} +type MonadGraphula m =+ (Monad m, MonadIO m, MonadGraphulaBackend m, MonadGraphulaFrontend m)+ class MonadGraphulaFrontend m where insert- :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m, GraphulaSafeToInsert a)+ :: ( PersistEntityBackend a ~ SqlBackend+ , PersistEntity a+ , Monad m+ , GraphulaSafeToInsert a+ ) => Maybe (Key a)+ -> a+ -> m (Maybe (Entity a))++ insertKeyed+ :: ( PersistEntityBackend a ~ SqlBackend+ , PersistEntity a+ , Monad m+ )+ => Key a -> a -> m (Maybe (Entity a))
src/Graphula/Dependencies.hs view
@@ -18,27 +18,38 @@ {-# LANGUAGE UndecidableSuperClasses #-} module Graphula.Dependencies- ( HasDependencies(..)- , Only(..)+ ( HasDependencies (..)+ , Only (..) , only - -- * Non-serial keys- , KeySourceType(..)+ -- * Non-serial keys+ , KeySourceType (..)+ , KeySourceTypeM+ , KeyForInsert+ , KeyRequirementForInsert+ , InsertWithPossiblyRequiredKey (..)+ , Required (..)+ , Optional (..) , GenerateKey , generateKey ) where import Prelude -import Data.Kind (Constraint)-import Data.Proxy (Proxy(..))-import Database.Persist (Key)+import Data.Kind (Constraint, Type)+import Data.Proxy (Proxy (..))+import Database.Persist (Entity (..), Key, PersistEntity, PersistEntityBackend)+import Database.Persist.Sql (SqlBackend) import GHC.Generics (Generic)-import GHC.TypeLits (ErrorMessage(..), TypeError)+import GHC.TypeLits (ErrorMessage (..), TypeError) import Generics.Eot (Eot, HasEot, fromEot, toEot)+import Graphula.Class (GraphulaSafeToInsert, MonadGraphulaFrontend)+import qualified Graphula.Class as MonadGraphulaFrontend+ ( MonadGraphulaFrontend (..)+ ) import Graphula.Dependencies.Generic import Graphula.NoConstraint-import Test.QuickCheck.Arbitrary (Arbitrary(..))+import Test.QuickCheck.Arbitrary (Arbitrary (..)) import Test.QuickCheck.Gen (Gen) class HasDependencies a where@@ -63,10 +74,10 @@ -- instance 'HasDependencies' Course where -- type Dependencies Course = (SchoolId, TeacherId) -- @- -- type Dependencies a- type instance Dependencies _a = () + type Dependencies _a = ()+ -- | Specify the method for resolving a node's key -- -- This can be@@ -79,10 +90,10 @@ -- -- Most types will use 'SourceDefault' or 'SourceArbitrary'. Only use -- 'SourceExternal' if the key for a value is always defined externally.- -- type KeySource a :: KeySourceType- type instance KeySource _a = 'SourceDefault + type KeySource _a = 'SourceDefault+ -- | Assign values from the 'Dependencies' collection to a value -- -- This must be an idempotent operation. Law:@@ -91,15 +102,19 @@ -- -- The default, 'Generic'-based implementation will assign values by the order -- of the fields in the model's type.- -- dependsOn :: a -> Dependencies a -> a default dependsOn- ::- ( HasEot a- , HasEot (Dependencies a)- , GHasDependencies (Proxy a) (Proxy (Dependencies a)) (Eot a) (Eot (Dependencies a))- )- => a -> Dependencies a -> a+ :: ( HasEot a+ , HasEot (Dependencies a)+ , GHasDependencies+ (Proxy a)+ (Proxy (Dependencies a))+ (Eot a)+ (Eot (Dependencies a))+ )+ => a+ -> Dependencies a+ -> a dependsOn a dependencies = fromEot $ genericDependsOn@@ -109,41 +124,101 @@ (toEot dependencies) -- | For entities that only have singular 'Dependencies'-newtype Only a = Only { fromOnly :: a }+newtype Only a = Only {fromOnly :: a} deriving stock (Eq, Show, Ord, Generic, Functor, Foldable, Traversable) only :: a -> Only a only = Only data KeySourceType- = SourceDefault- -- ^ Generate keys using the database's @DEFAULT@ strategy- | SourceArbitrary- -- ^ Generate keys using the 'Arbitrary' instance for the 'Key'- | SourceExternal- -- ^ Always explicitly pass an external key- --- -- See 'nodeKeyed'.- --+ = -- | Generate keys using the database's @DEFAULT@ strategy+ SourceDefault+ | -- | Generate keys using the 'Arbitrary' instance for the 'Key'+ SourceArbitrary+ | -- | Always explicitly pass an external key+ --+ -- See 'nodeKeyed'.+ SourceExternal +newtype Required a = Required a++newtype Optional a = Optional (Maybe a)++-- | When a user of Graphula inserts, this wraps the key they provide.+-- For 'SourceExternal' a key is required; for others it's optional.+type family KeySourceTypeM (t :: KeySourceType) :: Type -> Type where+ KeySourceTypeM 'SourceExternal = Required+ KeySourceTypeM _ = Optional++type KeyRequirementForInsert record = KeySourceTypeM (KeySource record)++-- | When Graphula inserts into Persistent, this wraps the key is provides.+-- For 'SourceDefault', a key is optional; for others it has always been+-- generated.+type family KeySourceTypeInternalM (t :: KeySourceType) :: Type -> Type where+ KeySourceTypeInternalM 'SourceDefault = Optional+ KeySourceTypeInternalM _ = Required++type KeyRequirementForInsertInternal record =+ KeySourceTypeInternalM (KeySource record)++-- | When Graphula inserts into Persistent, this is the record's key.+type KeyForInsert record = KeyRequirementForInsertInternal record (Key record)++class InsertWithPossiblyRequiredKey (requirement :: Type -> Type) where+ type InsertConstraint requirement :: Type -> Constraint+ insertWithPossiblyRequiredKey+ :: ( PersistEntityBackend record ~ SqlBackend+ , PersistEntity record+ , Monad m+ , MonadGraphulaFrontend m+ , InsertConstraint requirement record+ )+ => requirement (Key record)+ -> record+ -> m (Maybe (Entity record))+ justKey :: key -> requirement key++instance InsertWithPossiblyRequiredKey Optional where+ type InsertConstraint Optional = GraphulaSafeToInsert+ insertWithPossiblyRequiredKey (Optional key) = MonadGraphulaFrontend.insert key+ justKey = Optional . Just++instance InsertWithPossiblyRequiredKey Required where+ type InsertConstraint Required = NoConstraint+ insertWithPossiblyRequiredKey (Required key) = MonadGraphulaFrontend.insertKeyed key+ justKey = Required+ -- | Abstract constraint that some @a@ can generate a key -- -- This is part of ensuring better error messages.----class (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a) => GenerateKey a-instance (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a) => GenerateKey a+class+ ( GenerateKeyInternal (KeySource a) a+ , KeyConstraint (KeySource a) a+ , InsertWithPossiblyRequiredKey (KeySourceTypeInternalM (KeySource a))+ , InsertConstraint (KeySourceTypeInternalM (KeySource a)) a+ ) =>+ GenerateKey a +instance+ ( GenerateKeyInternal (KeySource a) a+ , KeyConstraint (KeySource a) a+ , InsertWithPossiblyRequiredKey (KeySourceTypeInternalM (KeySource a))+ , InsertConstraint (KeySourceTypeInternalM (KeySource a)) a+ )+ => GenerateKey a+ class GenerateKeyInternal (s :: KeySourceType) a where type KeyConstraint s a :: Constraint- generateKey :: KeyConstraint s a => Gen (Maybe (Key a))+ generateKey :: KeyConstraint s a => Gen (KeySourceTypeInternalM s (Key a)) instance GenerateKeyInternal 'SourceDefault a where- type KeyConstraint 'SourceDefault a = NoConstraint a- generateKey = pure Nothing+ type KeyConstraint 'SourceDefault a = GraphulaSafeToInsert a+ generateKey = pure (Optional Nothing) instance GenerateKeyInternal 'SourceArbitrary a where type KeyConstraint 'SourceArbitrary a = Arbitrary (Key a)- generateKey = Just <$> arbitrary+ generateKey = Required <$> arbitrary -- Rendered: --@@ -158,34 +233,37 @@ -- • Change ‘KeySource X’ to 'SourceDefault or 'SourceArbitrary -- @ ---instance TypeError- ( 'Text "Cannot generate a value of type "- ':<>: Quote ('ShowType a)- ':<>: 'Text " using "- ':<>: Quote ('Text "node")- ':<>: 'Text " since"- ':$$: 'Text ""- ':$$: 'Text " instance HasDependencies "- ':<>: 'ShowType a- ':<>: 'Text " where"- ':$$: 'Text " "- ':<>: 'Text "type KeySource "- ':<>: 'ShowType a- ':<>: 'Text " = "- ':<>: 'ShowType 'SourceExternal- ':$$: 'Text ""- ':$$: 'Text "Possible fixes include:"- ':$$: 'Text "• Use "- ':<>: Quote ('Text "nodeKeyed")- ':<>: 'Text " instead of "- ':<>: Quote ('Text "node")- ':$$: 'Text "• Change "- ':<>: Quote ('Text "KeySource " ':<>: 'ShowType a)- ':<>: 'Text " to "- ':<>: 'Text "'SourceDefault"- ':<>: 'Text " or "- ':<>: 'Text "'SourceArbitrary"- ) => GenerateKeyInternal 'SourceExternal a where+instance+ TypeError+ ( 'Text "Cannot generate a value of type "+ ':<>: Quote ('ShowType a)+ ':<>: 'Text " using "+ ':<>: Quote ('Text "node")+ ':<>: 'Text " since"+ ':$$: 'Text ""+ ':$$: 'Text " instance HasDependencies "+ ':<>: 'ShowType a+ ':<>: 'Text " where"+ ':$$: 'Text " "+ ':<>: 'Text "type KeySource "+ ':<>: 'ShowType a+ ':<>: 'Text " = "+ ':<>: 'ShowType 'SourceExternal+ ':$$: 'Text ""+ ':$$: 'Text "Possible fixes include:"+ ':$$: 'Text "• Use "+ ':<>: Quote ('Text "nodeKeyed")+ ':<>: 'Text " instead of "+ ':<>: Quote ('Text "node")+ ':$$: 'Text "• Change "+ ':<>: Quote ('Text "KeySource " ':<>: 'ShowType a)+ ':<>: 'Text " to "+ ':<>: 'Text "'SourceDefault"+ ':<>: 'Text " or "+ ':<>: 'Text "'SourceArbitrary"+ )+ => GenerateKeyInternal 'SourceExternal a+ where type KeyConstraint 'SourceExternal a = NoConstraint a generateKey = error "unreachable"
src/Graphula/Dependencies/Generic.hs view
@@ -11,12 +11,12 @@ -- | Machinery for the 'Generic'-based 'HasDependencies' instance module Graphula.Dependencies.Generic- ( GHasDependencies(..)+ ( GHasDependencies (..) ) where import Data.Kind (Type)-import GHC.TypeLits (ErrorMessage(..), TypeError)-import Generics.Eot (Proxy(..), Void)+import GHC.TypeLits (ErrorMessage (..), TypeError)+import Generics.Eot (Proxy (..), Void) data Match t = NoMatch t@@ -24,31 +24,37 @@ type family DependenciesTypeInstance nodeTy depsTy where DependenciesTypeInstance nodeTy depsTy =- 'Text "‘type Dependencies " ':<>: 'ShowType nodeTy ':<>:- 'Text " = " ':<>: 'ShowType depsTy ':<>: 'Text "’"+ 'Text "‘type Dependencies "+ ':<>: 'ShowType nodeTy+ ':<>: 'Text " = "+ ':<>: 'ShowType depsTy+ ':<>: 'Text "’" -- Walk through the fields of our node and match them up with fields from the dependencies. type family FindMatches nodeTy depsTy as ds :: [Match Type] where -- Excess dependencies FindMatches nodeTy depsTy () (d, _ds) = TypeError- ( 'Text "Excess dependency ‘" ':<>: 'ShowType d ':<>:- 'Text "’ in " ':$$: DependenciesTypeInstance nodeTy depsTy ':$$:- 'Text "Ordering of dependencies must match their occurrence in the target type ‘" ':<>:- 'ShowType nodeTy ':<>: 'Text "’"+ ( 'Text "Excess dependency ‘"+ ':<>: 'ShowType d+ ':<>: 'Text "’ in "+ ':$$: DependenciesTypeInstance nodeTy depsTy+ ':$$: 'Text+ "Ordering of dependencies must match their occurrence in the target type ‘"+ ':<>: 'ShowType nodeTy+ ':<>: 'Text "’" )- -- No more fields or dependencies left FindMatches _nodeTy _depsTy () () = '[]- -- Fields left, but no more dependencies- FindMatches nodeTy depsTy (a, as) () = 'NoMatch a ': FindMatches nodeTy depsTy as ()-+ FindMatches nodeTy depsTy (a, as) () =+ 'NoMatch a ': FindMatches nodeTy depsTy as () -- Field matches dependency, keep going- FindMatches nodeTy depsTy (a, as) (a, ds) = 'Match a ': FindMatches nodeTy depsTy as ds-+ FindMatches nodeTy depsTy (a, as) (a, ds) =+ 'Match a ': FindMatches nodeTy depsTy as ds -- Field does not match dependency, keep going- FindMatches nodeTy depsTy (a, as) (d, ds) = 'NoMatch a ': FindMatches nodeTy depsTy as (d, ds)+ FindMatches nodeTy depsTy (a, as) (d, ds) =+ 'NoMatch a ': FindMatches nodeTy depsTy as (d, ds) class GHasDependencies nodeTyProxy depsTyProxy node deps where genericDependsOn :: nodeTyProxy -> depsTyProxy -> node -> deps -> node@@ -65,11 +71,12 @@ -- to a datatype with no constructors instance {-# OVERLAPPABLE #-}- ( TypeError- ( 'Text "A datatype with no constructors can't use the dependencies in" ':$$:- DependenciesTypeInstance nodeTy depsTy+ TypeError+ ( 'Text "A datatype with no constructors can't use the dependencies in"+ ':$$: DependenciesTypeInstance nodeTy depsTy )- ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) Void (Either deps rest) where+ => GHasDependencies (Proxy nodeTy) (Proxy depsTy) Void (Either deps rest)+ where genericDependsOn _ _ _ _ = error "Impossible" -- This instance head only matches EoT representations of@@ -77,7 +84,13 @@ instance ( FindMatches nodeTy depsTy node deps ~ fields , GHasDependenciesRecursive (Proxy fields) node deps- ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either node Void) (Either deps Void) where+ )+ => GHasDependencies+ (Proxy nodeTy)+ (Proxy depsTy)+ (Either node Void)+ (Either deps Void)+ where genericDependsOn _ _ (Left node) (Left deps) = Left (genericDependsOnRecursive (Proxy :: Proxy fields) node deps) genericDependsOn _ _ _ _ = error "Impossible" -- EoT never generates an actual `Right (x :: Void)` here@@ -85,52 +98,72 @@ -- This instance matches a sum type as both node and dependencies. -- We use this to report an error to the user. instance- ( TypeError- ( 'Text "Cannot automatically find dependencies for sum type in" ':$$:- DependenciesTypeInstance nodeTy depsTy+ TypeError+ ( 'Text "Cannot automatically find dependencies for sum type in"+ ':$$: DependenciesTypeInstance nodeTy depsTy )- ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either left (Either right rest)) (Either deps Void) where+ => GHasDependencies+ (Proxy nodeTy)+ (Proxy depsTy)+ (Either left (Either right rest))+ (Either deps Void)+ where genericDependsOn _ _ _ _ = error "Impossible" -- This instance matches a sum type as the node. -- This is also an error. instance- ( TypeError- ( 'Text "Cannot automatically use a sum type as dependencies in" ':$$:- DependenciesTypeInstance nodeTy depsTy+ TypeError+ ( 'Text "Cannot automatically use a sum type as dependencies in"+ ':$$: DependenciesTypeInstance nodeTy depsTy )- ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either node Void) (Either left (Either right rest)) where+ => GHasDependencies+ (Proxy nodeTy)+ (Proxy depsTy)+ (Either node Void)+ (Either left (Either right rest))+ where genericDependsOn _ _ _ _ = error "Impossible" -- This instance matches a sum type as the dependencies. -- This is also an error. instance- ( TypeError- ( 'Text "Cannot automatically find dependencies for sum type or use a sum type as a dependency in" ':$$:- DependenciesTypeInstance nodeTy depsTy+ TypeError+ ( 'Text+ "Cannot automatically find dependencies for sum type or use a sum type as a dependency in"+ ':$$: DependenciesTypeInstance nodeTy depsTy )- ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either left1 (Either right1 rest1)) (Either left2 (Either right2 rest2)) where+ => GHasDependencies+ (Proxy nodeTy)+ (Proxy depsTy)+ (Either left1 (Either right1 rest1))+ (Either left2 (Either right2 rest2))+ where genericDependsOn _ _ _ _ = error "Impossible" -- Don't let the user specify `Void` as a dependency instance- ( TypeError- ( 'Text "Use ‘()’ instead of ‘Void’ for datatypes with no dependencies in" ':$$:- DependenciesTypeInstance nodeTy depsTy+ TypeError+ ( 'Text "Use ‘()’ instead of ‘Void’ for datatypes with no dependencies in"+ ':$$: DependenciesTypeInstance nodeTy depsTy )- ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) node Void where+ => GHasDependencies (Proxy nodeTy) (Proxy depsTy) node Void+ where genericDependsOn _ _ _ _ = error "Impossible" instance ( a ~ dep , GHasDependenciesRecursive (Proxy fields) as deps- ) => GHasDependenciesRecursive (Proxy ('Match a ': fields)) (a, as) (dep, deps) where+ )+ => GHasDependenciesRecursive (Proxy ('Match a ': fields)) (a, as) (dep, deps)+ where genericDependsOnRecursive _ (_, as) (dep, deps) = (dep, genericDependsOnRecursive (Proxy :: Proxy fields) as deps) instance- ( GHasDependenciesRecursive (Proxy fields) as deps- ) => GHasDependenciesRecursive (Proxy ('NoMatch a ': fields)) (a, as) deps where+ GHasDependenciesRecursive (Proxy fields) as deps+ => GHasDependenciesRecursive (Proxy ('NoMatch a ': fields)) (a, as) deps+ where genericDependsOnRecursive _ (a, as) deps = (a, genericDependsOnRecursive (Proxy :: Proxy fields) as deps)
src/Graphula/Idempotent.hs view
@@ -28,7 +28,7 @@ import Control.Monad.Trans (MonadTrans, lift) import Data.Foldable (for_) import Data.IORef (IORef, modifyIORef', newIORef, readIORef)-import Database.Persist (Entity(..))+import Database.Persist (Entity (..)) import Graphula.Class import UnliftIO.Exception (SomeException, catch, mask, throwIO) @@ -51,22 +51,31 @@ instance MonadTrans GraphulaIdempotentT where lift = GraphulaIdempotentT . lift -instance (MonadIO m, MonadGraphulaFrontend m) => MonadGraphulaFrontend (GraphulaIdempotentT m) where+instance+ (MonadIO m, MonadGraphulaFrontend m)+ => MonadGraphulaFrontend (GraphulaIdempotentT m)+ where insert mKey n = do finalizersRef <- ask mEnt <- lift $ insert mKey n- for_ (entityKey <$> mEnt)- $ \key -> liftIO $ modifyIORef' finalizersRef (remove key >>)+ for_ (entityKey <$> mEnt) $+ \key -> liftIO $ modifyIORef' finalizersRef (remove key >>) pure mEnt+ insertKeyed key n = do+ finalizersRef <- ask+ mEnt <- lift $ insertKeyed key n+ for_ (entityKey <$> mEnt) $+ \key' -> liftIO $ modifyIORef' finalizersRef (remove key' >>)+ pure mEnt remove = lift . remove runGraphulaIdempotentT :: MonadUnliftIO m => GraphulaIdempotentT m a -> m a runGraphulaIdempotentT action = mask $ \unmasked -> do finalizersRef <- liftIO . newIORef $ pure () x <-- unmasked- $ runReaderT (runGraphulaIdempotentT' action) finalizersRef- `catch` rollbackRethrow finalizersRef+ unmasked $+ runReaderT (runGraphulaIdempotentT' action) finalizersRef+ `catch` rollbackRethrow finalizersRef rollback finalizersRef $ pure x where rollback :: MonadIO m => IORef (m a) -> m b -> m b
src/Graphula/Key.hs view
@@ -12,8 +12,8 @@ ) where import Database.Persist-import GHC.TypeLits (ErrorMessage(..), TypeError)-import Graphula (Only(..), only)+import GHC.TypeLits (ErrorMessage (..), TypeError)+import Graphula (Only (..), only) class EntityKeys a where -- | Type-class for turning a tuple of 'Entity' into a tuple of 'Key'@@ -38,18 +38,21 @@ -- @ -- -- The type class instances currently scale up 4-tuple 'Dependencies'.- -- type Keys a+ keys :: a -> Keys a instance- ( TypeError- ( 'Text "Cannot use naked ‘" ':<>: 'ShowType (Entity a) ':<>:- 'Text "’ as argument to ‘keys’." ':$$:- 'Text "Did you mean ‘Only (" ':<>:- 'ShowType (Entity a) ':<>: 'Text ")’?"+ TypeError+ ( 'Text "Cannot use naked ‘"+ ':<>: 'ShowType (Entity a)+ ':<>: 'Text "’ as argument to ‘keys’."+ ':$$: 'Text "Did you mean ‘Only ("+ ':<>: 'ShowType (Entity a)+ ':<>: 'Text ")’?" )- ) => EntityKeys (Entity a) where+ => EntityKeys (Entity a)+ where type Keys (Entity a) = Key a keys = entityKey @@ -76,5 +79,7 @@ -- brittany-disable-next-binding instance EntityKeys (Entity a, Entity b, Entity c, Entity d) where- type Keys (Entity a, Entity b, Entity c, Entity d) = (Key a, Key b, Key c, Key d)+ type+ Keys (Entity a, Entity b, Entity c, Entity d) =+ (Key a, Key b, Key c, Key d) keys (a, b, c, d) = (entityKey a, entityKey b, entityKey c, entityKey d)
src/Graphula/Logged.hs view
@@ -36,10 +36,13 @@ import qualified Data.Text.IO as T import Graphula.Class import System.Directory (createDirectoryIfMissing, getTemporaryDirectory)-import System.IO (Handle, IOMode(..), hClose, openFile)+import System.IO (Handle, IOMode (..), hClose, openFile) import System.IO.Temp (openTempFile) import Test.HUnit.Lang- (FailureReason(..), HUnitFailure(..), formatFailureReason)+ ( FailureReason (..)+ , HUnitFailure (..)+ , formatFailureReason+ ) import UnliftIO.Exception (bracket, catch, throwIO) newtype GraphulaLoggedT m a = GraphulaLoggedT@@ -70,6 +73,7 @@ instance (Monad m, MonadGraphulaFrontend m) => MonadGraphulaFrontend (GraphulaLoggedT m) where insert mKey = lift . insert mKey+ insertKeyed key = lift . insertKeyed key remove = lift . remove -- | Run the graph while logging to a temporary file@@ -101,7 +105,7 @@ flip rethrowHUnitLogged hunitfailure =<< logGraphToHandle graphLog f logFailFile :: MonadIO m => FilePath -> IORef (Seq Text) -> HUnitFailure -> m a-logFailFile path = logFailUsing ((path, ) <$> openFile path WriteMode)+logFailFile path = logFailUsing ((path,) <$> openFile path WriteMode) logFailTemp :: MonadIO m => IORef (Seq Text) -> HUnitFailure -> m a logFailTemp = logFailUsing $ do@@ -110,14 +114,16 @@ openTempFile tmp "fail-.graphula" logGraphToHandle- :: (MonadIO m) => IORef (Seq Text) -> IO (FilePath, Handle) -> m FilePath-logGraphToHandle graphLog openHandle = liftIO $ bracket- openHandle- (hClose . snd)- (\(path, handle) -> do- nodes <- readIORef graphLog- path <$ traverse_ (T.hPutStrLn handle) nodes- )+ :: MonadIO m => IORef (Seq Text) -> IO (FilePath, Handle) -> m FilePath+logGraphToHandle graphLog openHandle =+ liftIO $+ bracket+ openHandle+ (hClose . snd)+ ( \(path, handle) -> do+ nodes <- readIORef graphLog+ path <$ traverse_ (T.hPutStrLn handle) nodes+ ) rethrowHUnitLogged :: MonadIO m => FilePath -> HUnitFailure -> m a rethrowHUnitLogged path =
src/Graphula/NoConstraint.hs view
@@ -5,7 +5,6 @@ -- Graphula accepts constraints for various uses. Frontends do not always -- utilize these constraints. 'NoConstraint' is a universal class that all types -- inhabit. It has no behavior and no additional constraints.--- module Graphula.NoConstraint ( NoConstraint ) where
src/Graphula/Node.hs view
@@ -15,38 +15,39 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} module Graphula.Node- (- -- * Generating+ ( -- * Generating node , nodeKeyed - -- * 'NodeOptions'+ -- * 'NodeOptions' , NodeOptions , edit , ensure - -- * Exceptions- , GenerationFailure(..)+ -- * Exceptions+ , GenerationFailure (..) ) where import Prelude import Control.Monad (guard, (<=<))-import Data.Proxy (Proxy(..))+import Data.Proxy (Proxy (..)) import Data.Semigroup.Generic (gmappend, gmempty) import Data.Traversable (for) import Data.Typeable (TypeRep, Typeable, typeRep)-import Database.Persist (Entity(..), Key, PersistEntity, PersistEntityBackend)+import Database.Persist (Entity (..), Key, PersistEntity, PersistEntityBackend) import Database.Persist.Sql (SqlBackend) import GHC.Generics (Generic) import Graphula.Arbitrary import Graphula.Class import Graphula.Dependencies-import Test.QuickCheck (Arbitrary(..))+import Test.QuickCheck (Arbitrary (..))+import UnliftIO (MonadIO) import UnliftIO.Exception (Exception, throwIO) -- | Options for generating an individual node@@ -58,11 +59,10 @@ -- > a1 <- node @A () mempty -- > a2 <- node @A () $ edit $ \a -> a { someField = True } -- > a3 <- node @A () $ ensure $ (== True) . someField--- newtype NodeOptions a = NodeOptions { nodeOptionsEdit :: Kendo Maybe a }- deriving stock Generic+ deriving stock (Generic) instance Semigroup (NodeOptions a) where (<>) = gmappend@@ -73,8 +73,8 @@ {-# INLINE mempty #-} -- | Like @'Endo'@ but uses Kliesli composition-newtype Kendo m a = Kendo { appKendo :: a -> m a }- deriving stock Generic+newtype Kendo m a = Kendo {appKendo :: a -> m a}+ deriving stock (Generic) instance Monad m => Semigroup (Kendo m a) where Kendo f <> Kendo g = Kendo $ f <=< g@@ -87,23 +87,20 @@ -- | Modify the node after it's been generated -- -- > a <- node @A () $ edit $ \a -> a { someField = True }--- edit :: (a -> a) -> NodeOptions a-edit f = mempty { nodeOptionsEdit = Kendo $ Just . f }+edit f = mempty {nodeOptionsEdit = Kendo $ Just . f} -- | Require a node to satisfy the specified predicate -- -- > a <- node @A () $ ensure $ (== True) . someField -- -- N.B. ensuring a condition that is infrequently met can be innefficient.--- ensure :: (a -> Bool) -> NodeOptions a-ensure f = mempty { nodeOptionsEdit = Kendo $ \a -> a <$ guard (f a) }+ensure f = mempty {nodeOptionsEdit = Kendo $ \a -> a <$ guard (f a)} --- | Generate a node with a default (Database-provided) key+-- | Generate a node with a default (Arbitrary or database-provided) key -- -- > a <- node @A () mempty--- node :: forall a m . ( MonadGraphula m@@ -114,36 +111,55 @@ , PersistEntityBackend a ~ SqlBackend , PersistEntity a , Typeable a- , GraphulaSafeToInsert a ) => Dependencies a -> NodeOptions a -> m (Entity a)-node = nodeImpl $ generate $ generateKey @(KeySource a) @a+node dependencies NodeOptions {..} =+ let genKey = generate $ generateKey @(KeySource a) @a+ in attempt 100 10 $ do+ initial <- generate arbitrary+ for (appKendo nodeOptionsEdit initial) $ \edited -> do+ -- N.B. dependencies setting always overrules edits+ let hydrated = edited `dependsOn` dependencies+ logNode hydrated+ mKey <- genKey+ pure (mKey, hydrated) --- | Generate a node with an explictly-given key------ > let someKey = UUID.fromString "..."--- > a <- nodeKeyed @A someKey () mempty----nodeKeyed+attempt :: forall a m . ( MonadGraphula m- , Logging m a- , Arbitrary a- , HasDependencies a , PersistEntityBackend a ~ SqlBackend , PersistEntity a+ , GenerateKey a , Typeable a- , GraphulaSafeToInsert a )- => Key a- -> Dependencies a- -> NodeOptions a+ => Int+ -> Int+ -> m (Maybe (KeyForInsert a, a)) -> m (Entity a)-nodeKeyed key = nodeImpl $ pure $ Just key+attempt maxEdits maxInserts source = loop 0 0+ where+ loop :: Int -> Int -> m (Entity a)+ loop numEdits numInserts+ | numEdits >= maxEdits = die GenerationFailureMaxAttemptsToConstrain+ | numInserts >= maxInserts = die GenerationFailureMaxAttemptsToInsert+ | otherwise =+ source >>= \case+ Nothing -> loop (succ numEdits) numInserts+ -- ^ failed to edit, only increments this+ Just (mKey, value) ->+ insertWithPossiblyRequiredKey mKey value >>= \case+ Nothing -> loop (succ numEdits) (succ numInserts)+ -- ^ failed to insert, but also increments this. Are we+ -- sure that's what we want?+ Just a -> pure a -nodeImpl+-- | Generate a node with an explictly-given key+--+-- > let someKey = UUID.fromString "..."+-- > a <- nodeKeyed @A someKey () mempty+nodeKeyed :: forall a m . ( MonadGraphula m , Logging m a@@ -152,56 +168,61 @@ , PersistEntityBackend a ~ SqlBackend , PersistEntity a , Typeable a- , GraphulaSafeToInsert a )- => m (Maybe (Key a))+ => Key a -> Dependencies a -> NodeOptions a -> m (Entity a)-nodeImpl genKey dependencies NodeOptions {..} = attempt 100 10 $ do- initial <- generate arbitrary- for (appKendo nodeOptionsEdit initial) $ \edited -> do- -- N.B. dependencies setting always overrules edits- let hydrated = edited `dependsOn` dependencies- logNode hydrated- mKey <- genKey- pure (mKey, hydrated)--data GenerationFailure- = GenerationFailureMaxAttemptsToConstrain TypeRep- -- ^ Could not satisfy constraints defined using 'ensure'- | GenerationFailureMaxAttemptsToInsert TypeRep- -- ^ Could not satisfy database constraints on 'insert'- deriving stock (Show, Eq)--instance Exception GenerationFailure+nodeKeyed key dependencies NodeOptions {..} =+ attempt' 100 10 key $ do+ initial <- generate arbitrary+ for (appKendo nodeOptionsEdit initial) $ \edited -> do+ -- N.B. dependencies setting always overrules edits+ let hydrated = edited `dependsOn` dependencies+ logNode hydrated+ pure hydrated -attempt+attempt' :: forall a m . ( MonadGraphula m , PersistEntityBackend a ~ SqlBackend , PersistEntity a , Typeable a- , GraphulaSafeToInsert a ) => Int -> Int- -> m (Maybe (Maybe (Key a), a))+ -> Key a+ -> m (Maybe a) -> m (Entity a)-attempt maxEdits maxInserts source = loop 0 0+attempt' maxEdits maxInserts key source = loop 0 0 where loop :: Int -> Int -> m (Entity a) loop numEdits numInserts | numEdits >= maxEdits = die GenerationFailureMaxAttemptsToConstrain | numInserts >= maxInserts = die GenerationFailureMaxAttemptsToInsert- | otherwise = source >>= \case- Nothing -> loop (succ numEdits) numInserts- -- ^ failed to edit, only increments this- Just (mKey, value) -> insert mKey value >>= \case- Nothing -> loop (succ numEdits) (succ numInserts)- -- ^ failed to insert, but also increments this. Are we- -- sure that's what we want?- Just a -> pure a+ | otherwise =+ source >>= \case+ Nothing -> loop (succ numEdits) numInserts+ -- ^ failed to edit, only increments this+ Just value ->+ insertKeyed key value >>= \case+ Nothing -> loop (succ numEdits) (succ numInserts)+ -- ^ failed to insert, but also increments this. Are we+ -- sure that's what we want?+ Just a -> pure a - die :: (TypeRep -> GenerationFailure) -> m (Entity a)- die e = throwIO $ e $ typeRep (Proxy :: Proxy a)+die+ :: forall a m+ . (MonadIO m, Typeable a)+ => (TypeRep -> GenerationFailure)+ -> m (Entity a)+die e = throwIO $ e $ typeRep $ Proxy @a++data GenerationFailure+ = -- | Could not satisfy constraints defined using 'ensure'+ GenerationFailureMaxAttemptsToConstrain TypeRep+ | -- | Could not satisfy database constraints on 'insert'+ GenerationFailureMaxAttemptsToInsert TypeRep+ deriving stock (Show, Eq)++instance Exception GenerationFailure
test/README.lhs view
@@ -1,5 +1,10 @@ # Graphula +[](https://hackage.haskell.org/package/graphula)+[](http://stackage.org/nightly/package/graphula)+[](http://stackage.org/lts/package/graphula)+[](https://github.com/freckle/graphula/actions/workflows/ci.yml)+ Graphula is a simple interface for generating persistent data and linking its dependencies. We use this interface to generate fixtures for automated testing. @@ -20,6 +25,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-orphans #-}