packages feed

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 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 +[![Hackage](https://img.shields.io/hackage/v/graphula.svg?style=flat)](https://hackage.haskell.org/package/graphula)+[![Stackage Nightly](http://stackage.org/package/graphula/badge/nightly)](http://stackage.org/nightly/package/graphula)+[![Stackage LTS](http://stackage.org/package/graphula/badge/lts)](http://stackage.org/lts/package/graphula)+[![CI](https://github.com/freckle/graphula/actions/workflows/ci.yml/badge.svg)](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 +[![Hackage](https://img.shields.io/hackage/v/graphula.svg?style=flat)](https://hackage.haskell.org/package/graphula)+[![Stackage Nightly](http://stackage.org/package/graphula/badge/nightly)](http://stackage.org/nightly/package/graphula)+[![Stackage LTS](http://stackage.org/package/graphula/badge/lts)](http://stackage.org/lts/package/graphula)+[![CI](https://github.com/freckle/graphula/actions/workflows/ci.yml/badge.svg)](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 #-}