graphula 2.0.0.5 → 2.0.1.0

raw patch · 16 files changed

+1121/−993 lines, 16 filesdep +generic-arbitrarydep −uuidPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: generic-arbitrary

Dependencies removed: uuid

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−1
• README.md +80/−144
• graphula.cabal +12/−9
• src/Graphula.hs +110/−401
• src/Graphula/Arbitrary.hs +3/−8
• src/Graphula/Class.hs +45/−0
• src/Graphula/Dependencies.hs +194/−0
• src/Graphula/Dependencies/Generic.hs +141/−0
• src/Graphula/Idempotent.hs +81/−0
• src/Graphula/Internal.hs +0/−237
• src/Graphula/Key.hs +27/−2
• src/Graphula/Logged.hs +124/−0
• src/Graphula/NoConstraint.hs +14/−0
• src/Graphula/Node.hs +204/−0
• test/Graphula/UUIDKey.hs +0/−47
• test/README.lhs +80/−144

@@ -1,6 +1,11 @@-## [*Unreleased*](https://github.com/freckle/graphula/compare/v2.0.0.5...main)+## [*Unreleased*](https://github.com/freckle/graphula/compare/v2.0.1.0...main)  None++## [v2.0.1.0](https://github.com/freckle/graphula/compare/v2.0.0.5...v2.0.1.0)++- Add/improve documentation+- Re-organize previously-internal module  ## [v2.0.0.5](https://github.com/freckle/graphula/compare/v2.0.0.4...v2.0.0.5) 

@@ -1,6 +1,7 @@-# Graphula Core+# Graphula -Graphula is a simple interface for generating persistent data and linking its dependencies. We use this interface to generate fixtures for automated testing. The interface is extensible and supports pluggable front-ends.+Graphula is a simple interface for generating persistent data and linking its+dependencies. We use this interface to generate fixtures for automated testing.   <!--@@ -24,7 +25,6 @@  module Main (module Main) where -import Control.Monad (replicateM_) import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger (NoLoggingT)@@ -32,12 +32,11 @@ import Control.Monad.Trans.Resource (ResourceT) import Database.Persist.Sqlite import Database.Persist.TH-import Data.Typeable import GHC.Generics (Generic) import Graphula-import Graphula.UUIDKey import Test.Hspec import Test.QuickCheck+import Test.QuickCheck.Arbitrary.Generic import Text.Markdown.Unlit ()  instance (ToBackendKey SqlBackend a) => Arbitrary (Key a) where@@ -47,115 +46,98 @@  ## Arbitrary Data -Graphula utilizes `QuickCheck` to generate random data. We need to declare `Arbitrary` instances for our types.+Graphula utilizes `QuickCheck` to generate random data. We need to declare+`Arbitrary` instances for our models.  ```haskell share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|-A-  a String-  b Int+School+  name String   deriving Show Eq Generic -B-  a AId-  b String+Teacher+  schoolId SchoolId+  name String   deriving Show Eq Generic -C-  a AId-  b BId-  c String+Course+  schoolId SchoolId+  teacherId TeacherId+  name String   deriving Show Eq Generic -D-  Id UUIDKey-  a Int-  b String+Student+  name String   deriving Show Eq Generic -E-  Id DId sqltype=uuid-  a String+Question+  content String   deriving Show Eq Generic -F-  a Bool-  UniqueFA a+Answer+  questionId QuestionId+  studentId StudentId+  yes Bool+  UniqueAnswer questionId studentId   deriving Show Eq Generic |] -instance Arbitrary A where-  arbitrary = A <$> arbitrary <*> arbitrary+instance Arbitrary School where+  arbitrary = genericArbitrary -instance Arbitrary B where-  arbitrary = B <$> arbitrary <*> arbitrary+instance Arbitrary Teacher where+  arbitrary = genericArbitrary -instance Arbitrary C where-  arbitrary = C <$> arbitrary <*> arbitrary <*> arbitrary+instance Arbitrary Course where+  arbitrary = genericArbitrary -instance Arbitrary D where-  arbitrary = D <$> arbitrary <*> arbitrary+instance Arbitrary Student where+  arbitrary = genericArbitrary -instance Arbitrary E where-  arbitrary = E <$> arbitrary+instance Arbitrary Question where+  arbitrary = genericArbitrary -instance Arbitrary F where-  arbitrary = F <$> arbitrary+instance Arbitrary Answer where+  arbitrary = genericArbitrary ```  ## Dependencies -We declare dependencies via the `HasDependencies` typeclass and its associated type `Dependencies`.--By default a type does not have any dependencies. We only need to declare an empty instance.+We declare dependencies via the `HasDependencies` typeclass and its associated+type `Dependencies`. If a model does not have any dependencies, we only need to+declare an empty instance.  ```haskell-instance HasDependencies A-instance HasDependencies F-```+instance HasDependencies School -For single dependencies we use the `Only` type.+instance HasDependencies Student -```haskell-instance HasDependencies B where-  type Dependencies B = Only AId+instance HasDependencies Question ``` -Groups of dependencies use tuples. Declare these dependencies in the order they appear in the type. `HasDependencies` leverages generic programming to inject dependencies for you.+For single-dependency models, we use the `Only` type.  ```haskell-instance HasDependencies C where-  type Dependencies C = (AId, BId)+instance HasDependencies Teacher where+  type Dependencies Teacher = Only SchoolId ``` -## Non Sequential Keys--Graphula supports non-sequential keys with the `KeySource` associated type. To generate a key using-its `Arbitrary` instance, use `'SourceArbitrary`. Non-serial keys will need to also derive-an overlapping `Arbitrary` instance.+Multi-dependency models use tuples. Declare these dependencies in the order they+appear in the model's type definition. `HasDependencies` leverages generic+programming to inject dependencies for you.  ```haskell-instance HasDependencies D where-  type KeySource D = 'SourceArbitrary--deriving newtype instance {-# OVERLAPPING #-} Arbitrary (Key D)-```--You can also elect to always specify an external key using `'SourceExternal`. This means that-this type cannot be constructed with `node`; use `nodeKeyed` instead.+instance HasDependencies Course where+  type Dependencies Course = (SchoolId, TeacherId) -```haskell-instance HasDependencies E where-  type KeySource E = 'SourceExternal+instance HasDependencies Answer where+  type Dependencies Answer = (QuestionId, StudentId) ``` -By default, `HasDependencies` instances use `type KeySource _ = 'SourceDefault`, which means-that graphula will expect the database to provide a key.--## Serialization+## Logging failures -Graphula allows logging of graphs via `runGraphulaLogged`. Graphula dumps graphs-to a temp file on test failure.+`runGraphulaLogged` will dump generated data to a temporary file. Or+`runGraphulaLoggedWithFileT` can be used to pass an explicit path.  ```haskell loggingSpec :: IO ()@@ -164,17 +146,20 @@     logFile :: FilePath     logFile = "test.graphula" -    -- We'd typically use `runGraphulaLogged` which utilizes a temp file.     failingGraph :: IO ()     failingGraph = runGraphulaT Nothing runDB . runGraphulaLoggedWithFileT logFile $ do-      Entity _ a <- node @A () $ edit $ \n ->-        n {aA = "success"}-      liftIO $ aA a `shouldBe` "failed"+      student <- node @Student () mempty+      question <- node @Question () mempty+      answer <- node @Answer+        (entityKey question, entityKey student)+        $ edit $ \a -> a { answerYes = True } -  failingGraph-    `shouldThrow` anyException+      -- Test failures will cause the graph to be logged (not any exception)+      liftIO $ answerYes (entityVal answer) `shouldBe` False -  n <- lines <$> readFile "test.graphula"+  failingGraph `shouldThrow` anyException++  n <- lines <$> readFile logFile   n `shouldSatisfy` (not . null) ``` @@ -184,69 +169,23 @@ simpleSpec :: IO () simpleSpec =   runGraphulaT Nothing runDB $ do-    -- Type application is not necessary, but recommended for clarity.-    Entity aId _ <- node @A () mempty-    Entity bId b <- node @B (only aId) mempty-    Entity _ c <- node @C (aId, bId) $ edit $ \n -> n { cC = "edited" }-    Entity dId _ <- node @D () mempty-    Entity eId _ <- nodeKeyed @E (EKey dId) () mempty+    school <- node @School () mempty+    teacher <- node @Teacher (Only $ entityKey school) mempty+    course <- node @Course (entityKey school, entityKey teacher) mempty+    student <- node @Student () $ edit $ \s -> s { studentName = "Pat" }+    question <- node @Question () mempty+    answer <- node @Answer+      (entityKey question, entityKey student)+      $ edit $ \a -> a { answerYes = True } -    -- Do something with your data     liftIO $ do-      cC c `shouldBe` "edited"-      cA c `shouldBe` bA b-      unEKey eId `shouldBe` dId-```--`runGraphulaT` carries frontend instructions. If we'd like to override them we need to declare our own frontend.--For example, a front-end that always fails to insert.--```haskell-newtype GraphulaFailT m a = GraphulaFailT { runGraphulaFailT :: m a }-  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadGraphulaBackend)--instance MonadGraphulaFrontend (GraphulaFailT m) where-  insert _ _ = pure Nothing-  remove = const (pure ())--insertionFailureSpec :: IO ()-insertionFailureSpec = do-  let-    failingGraph :: IO ()-    failingGraph =  runGraphulaT Nothing runDB . runGraphulaFailT $ do-      Entity _ _ <- node @A () mempty-      pure ()-  failingGraph-    `shouldThrow` (== (GenerationFailureMaxAttemptsToInsert (typeRep $ Proxy @A)))-```--Note that graphula can fail naturally if we define a graph that violates unique constraints-in the database:--```haskell-constraintFailureSpec :: IO ()-constraintFailureSpec = do-  let-    failingGraph :: IO ()-    failingGraph =  runGraphulaT Nothing runDB $-      replicateM_ 3 $ node @F () mempty-  failingGraph-    `shouldThrow` (== (GenerationFailureMaxAttemptsToInsert (typeRep $ Proxy @F)))-```--or if we define a graph with an unsatisfiable predicates:--```haskell-ensureFailureSpec :: IO ()-ensureFailureSpec = do-  let-    failingGraph :: IO ()-    failingGraph =  runGraphulaT Nothing runDB $ do-      Entity _ _ <- node @A () $ ensure $ \a -> a /= a-      pure ()-  failingGraph-    `shouldThrow` (== (GenerationFailureMaxAttemptsToConstrain (typeRep $ Proxy @A)))+      -- Typically, you would run some other function like "fetch correct+      -- answers at school" and assert you found the correct answers you+      -- generated. In this example we just assert some things about the data+      -- directly:+      teacherSchoolId (entityVal teacher) `shouldBe` entityKey school+      courseTeacherId (entityVal course) `shouldBe` entityKey teacher+      answerYes (entityVal answer) `shouldBe` True ```  <!--@@ -256,9 +195,6 @@   describe "graphula" . parallel $ do     it "generates and links arbitrary graphs of data" simpleSpec     it "allows logging graphs" loggingSpec-    it "attempts to retry node generation on insertion failure" insertionFailureSpec-    it "attempts to retry node generation on a database constraint violation" constraintFailureSpec-    it "attempts to retry node generation on unsatisfiable predicates" ensureFailureSpec  runDB :: MonadUnliftIO m => ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a runDB f = runSqlite "test.db" $ do

@@ -1,13 +1,13 @@ cabal-version:      1.12 name:               graphula-version:            2.0.0.5+version:            2.0.1.0 license:            MIT license-file:       LICENSE maintainer:         Freckle Education homepage:           https://github.com/freckle/graphula#readme bug-reports:        https://github.com/freckle/graphula/issues synopsis:-    A declarative library for describing dependencies between data+    A simple interface for generating persistent data and linking its dependencies  description:        Please see README.md category:           Network@@ -24,8 +24,14 @@     exposed-modules:         Graphula         Graphula.Arbitrary-        Graphula.Internal+        Graphula.Class+        Graphula.Dependencies+        Graphula.Dependencies.Generic+        Graphula.Idempotent         Graphula.Key+        Graphula.Logged+        Graphula.NoConstraint+        Graphula.Node      hs-source-dirs:   src     other-modules:    Paths_graphula@@ -59,10 +65,7 @@     type:             exitcode-stdio-1.0     main-is:          README.lhs     hs-source-dirs:   test-    other-modules:-        Graphula.UUIDKey-        Paths_graphula-+    other-modules:    Paths_graphula     default-language: Haskell2010     ghc-options:         -Weverything -Wno-unsafe -Wno-safe -Wno-missing-import-lists@@ -74,6 +77,7 @@         base >=4.14.1.0 && <5,         bytestring >=0.10.12.0,         containers >=0.6.2.1,+        generic-arbitrary >=0.1.0,         graphula -any,         hspec >=2.7.8,         http-api-data >=0.4.1.1,@@ -86,8 +90,7 @@         resourcet >=1.2.4.2,         text >=1.2.4.1,         transformers >=0.5.6.2,-        unliftio-core >=0.2.0.1,-        uuid >=1.3.14+        unliftio-core >=0.2.0.1      if impl(ghc >=8.10)         ghc-options:

@@ -1,9 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -16,10 +13,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -31,104 +25,148 @@ -- dependencies. You can use this interface to generate fixtures for automated -- testing. ----- The interface is extensible and supports pluggable front-ends.--- -- @--- runGraphIdentity . runGraphulaT $ do---   -- Compose dependencies at the value level---   Identity vet <- node @Veterinarian () mempty---   Identity owner <- node @Owner (only vet) mempty---   -- TypeApplications is not necessary, but recommended for clarity.---   Identity dog <- node @Dog (owner, vet) $ edit $ \d -> d { name = "fido" }+-- {- config/models+--+-- School+--   name Text+--   deriving Generic+--+-- Teacher+--   schoolId SchoolId+--   name Text+--   deriving Generic+--+-- Course+--   schoolId SchoolId+--   teacherId TeacherId+--   name Text+--   deriving Generic+--+-- -}+--+-- instance Arbitrary School where+--   -- ...+--+-- instance Arbitrary Teacher where+--   -- ...+--+-- instance Arbitrary Course where+--   -- ...+--+-- instance 'HasDependencies' School+--+-- instance 'HasDependencies' Teacher where+--   type Dependencies Teacher = Only SchoolId+--+-- instance 'HasDependencies' Course where+--   type Dependencies Course = (SchoolId, CourseId)+--+-- 'runGraphulaT' runDB $ do+--   school <- 'node' \@School () mempty+--+--   teacher <- 'node' \@Teacher ('onlyKey' school)+--      $ edit+--      $ \t -> t { teacherName = \"Alice\" }+--+--   course <- 'node' \@Course ('keys' (school, teacher))+--      $ 'ensure'+--      $ not . courseIsArchived -- @ -- module Graphula-  ( -- * Graph Declaration-    node-  , nodeKeyed-  , GraphulaNode-  , GraphulaContext-    -- ** Node options-  , NodeOptions-  , edit-  , ensure-    -- * Declaring Dependencies and key source-  , HasDependencies(..)-  , KeySourceType(..)-    -- * Abstract over how keys are generated using 'SourceDefault' or-    -- 'SourceArbitrary'-  , GenerateKey-    -- ** Singular Dependencies+  (+  -- * Basic usage+  -- ** Model requirements+    HasDependencies(..)   , Only(..)   , only-    -- * The Graph Monad-    -- ** Type Classes-  , MonadGraphula-  , MonadGraphulaBackend(..)-  , MonadGraphulaFrontend(..)-    -- ** Backends-  , runGraphulaT++  -- ** Defining the graph+  , node+  , edit+  , ensure++  -- ** Running the graph   , GraphulaT+  , runGraphulaT+  , GenerationFailure(..)++  -- * Advanced usage+  -- ** Non-serial keys+  , KeySourceType(..)+  , nodeKeyed++  -- ** Running with logging+  , GraphulaLoggedT   , runGraphulaLoggedT   , runGraphulaLoggedWithFileT-  , GraphulaLoggedT-    -- ** Frontends-  , runGraphulaIdempotentT++  -- ** Running idempotently   , GraphulaIdempotentT-    -- * Extras+  , 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+  --+  , 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.+  --+  , MonadGraphula+  , MonadGraphulaBackend(..)+  , MonadGraphulaFrontend(..)+  , NodeOptions+  , GenerateKey   , NoConstraint-    -- * Exceptions-  , GenerationFailure(..)-  )-where+  ) where  import Prelude hiding (readFile) -import Control.Monad (guard, (<=<)) import Control.Monad.IO.Unlift-import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT)+import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT) import Control.Monad.Trans (MonadTrans, lift)-import Data.Foldable (for_, traverse_)-import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.IORef (IORef, newIORef) import Data.Kind (Constraint, Type)-import Data.Proxy (Proxy(..))-import Data.Semigroup.Generic (gmappend, gmempty)-import Data.Sequence (Seq, empty, (|>))-import Data.Text (Text, pack)-import qualified Data.Text.IO as T-import Data.Traversable (for)-import Data.Typeable (TypeRep, Typeable, typeRep)+import Data.Typeable (Typeable) import Database.Persist-  ( Entity(..)-  , Key-  , PersistEntity+  ( PersistEntity   , PersistEntityBackend   , checkUnique   , delete-  , entityKey   , get   , getEntity   , insertKey   , insertUnique   ) import Database.Persist.Sql (SqlBackend)-import Generics.Eot (Eot, HasEot, fromEot, toEot)-import GHC.Generics (Generic)-import Graphula.Arbitrary (generate)-import Graphula.Internal-import System.Directory (createDirectoryIfMissing, getTemporaryDirectory)-import System.IO (Handle, IOMode(..), hClose, openFile)-import System.IO.Temp (openTempFile)+import Graphula.Class+import Graphula.Dependencies+import Graphula.Idempotent+import Graphula.Logged+import Graphula.NoConstraint+import Graphula.Node import System.Random (randomIO) import Test.HUnit.Lang   (FailureReason(..), HUnitFailure(..), formatFailureReason) import Test.QuickCheck (Arbitrary(..)) import Test.QuickCheck.Random (QCGen, mkQCGen)-import UnliftIO.Exception-  (Exception, SomeException, bracket, catch, mask, throwIO)--type MonadGraphula m-  = (Monad m, MonadGraphulaBackend m, MonadGraphulaFrontend m, MonadIO m)+import UnliftIO.Exception (catch, throwIO)  -- | A constraint over lists of nodes for 'MonadGraphula', and 'GraphulaNode'. --@@ -147,12 +185,6 @@    GraphulaContext m '[] = MonadGraphula m    GraphulaContext m (t ': ts) = (GraphulaNode m t, GraphulaContext m ts) -class MonadGraphulaFrontend m where-  insert-    :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m)-    => Maybe (Key a) -> a -> m (Maybe (Entity a))-  remove :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m) => Key a -> m ()- data Args backend n m = Args   { dbRunner :: RunDB backend n m   , gen :: IORef QCGen@@ -215,191 +247,10 @@ logFailingSeed :: MonadIO m => Int -> HUnitFailure -> m a logFailingSeed seed = rethrowHUnitWith ("Graphula with seed: " ++ show seed) -newtype GraphulaIdempotentT m a =-  GraphulaIdempotentT {runGraphulaIdempotentT' :: ReaderT (IORef (m ())) m a}-  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (IORef (m ())))--instance MonadUnliftIO m => MonadUnliftIO (GraphulaIdempotentT m) where-  {-# INLINE withRunInIO #-}-  withRunInIO inner = GraphulaIdempotentT $ withRunInIO $ \run ->-    inner $ run . runGraphulaIdempotentT'--instance MonadTrans GraphulaIdempotentT where-  lift = GraphulaIdempotentT . lift--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 >>)-    pure mEnt-  remove = lift . remove---- | A wrapper around a graphula frontend that produces finalizers to remove--- graph nodes on error or completion. An idempotent graph produces no data--- outside of its own closure.------ @--- runGraphIdentity . runGraphulaIdempotentT . runGraphulaT $ do---   node @PancakeBreakfast () mempty--- @----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-  rollback finalizersRef $ pure x- where-  rollback :: MonadIO m => IORef (m a) -> m b -> m b-  rollback finalizersRef x = do-    finalizers <- liftIO $ readIORef finalizersRef-    finalizers >> x--  rollbackRethrow :: MonadIO m => IORef (m a) -> SomeException -> m b-  rollbackRethrow finalizersRef (e :: SomeException) =-    rollback finalizersRef (throwIO e)--newtype GraphulaLoggedT m a =-  GraphulaLoggedT {runGraphulaLoggedT' :: ReaderT (IORef (Seq Text)) m a}-  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (IORef (Seq Text)))--instance MonadTrans GraphulaLoggedT where-  lift = GraphulaLoggedT . lift--instance (MonadGraphulaBackend m, MonadIO m) => MonadGraphulaBackend (GraphulaLoggedT m) where-  type Logging (GraphulaLoggedT m) = Show-  askGen = lift askGen-  logNode n = do-    graphLog <- ask-    liftIO $ modifyIORef' graphLog (|> pack (show n))--instance (Monad m, MonadGraphulaFrontend m) => MonadGraphulaFrontend (GraphulaLoggedT m) where-  insert mKey = lift . insert mKey-  remove = lift . remove---- | An extension of 'runGraphulaT' that logs all nodes to a temporary file on--- 'Exception' and re-throws the 'Exception'.-runGraphulaLoggedT :: MonadUnliftIO m => GraphulaLoggedT m a -> m a-runGraphulaLoggedT = runGraphulaLoggedUsingT logFailTemp---- | A variant of 'runGraphulaLoggedT' that accepts a file path to logged to--- instead of utilizing a temp file.-runGraphulaLoggedWithFileT-  :: MonadUnliftIO m => FilePath -> GraphulaLoggedT m a -> m a-runGraphulaLoggedWithFileT = runGraphulaLoggedUsingT . logFailFile--runGraphulaLoggedUsingT-  :: MonadUnliftIO m-  => (IORef (Seq Text) -> HUnitFailure -> m a)-  -> GraphulaLoggedT m a-  -> m a-runGraphulaLoggedUsingT logFail action = do-  graphLog <- liftIO $ newIORef empty-  runReaderT (runGraphulaLoggedT' action) graphLog `catch` logFail graphLog--logFailUsing-  :: MonadIO m-  => IO (FilePath, Handle)-  -> IORef (Seq Text)-  -> HUnitFailure-  -> m a-logFailUsing f graphLog hunitfailure =-  flip rethrowHUnitLogged hunitfailure =<< logGraphToHandle graphLog f--logFailFile :: MonadIO m => FilePath -> IORef (Seq Text) -> HUnitFailure -> m a-logFailFile path = logFailUsing ((path, ) <$> openFile path WriteMode)--logFailTemp :: MonadIO m => IORef (Seq Text) -> HUnitFailure -> m a-logFailTemp = logFailUsing $ do-  tmp <- (++ "/graphula") <$> getTemporaryDirectory-  createDirectoryIfMissing True tmp-  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-  )- rethrowHUnitWith :: MonadIO m => String -> HUnitFailure -> m a rethrowHUnitWith message (HUnitFailure l r) =   throwIO . HUnitFailure l . Reason $ message ++ "\n\n" ++ formatFailureReason r -rethrowHUnitLogged :: MonadIO m => FilePath -> HUnitFailure -> m a-rethrowHUnitLogged path =-  rethrowHUnitWith ("Graph dumped in temp file: " ++ path)--class HasDependencies a where-  -- | A data type that contains values to be injected into @a@ via-  -- `dependsOn`. The default generic implementation of `dependsOn` supports-  -- tuples as 'Dependencies'. Data types with a single dependency should use-  -- 'Only' as a 1-tuple.-  ---  -- note: The contents of a tuple must be ordered as they appear in the-  -- definition of @a@.-  type Dependencies a-  type instance Dependencies _a = ()--  -- | Specify the method for resolving a node's key-  ---  -- This can be-  ---  -- @-  -- 'SourceDefault   -- automatically generate keys from the database-  -- 'SourceArbitrary -- automatically generate keys using @'Arbitrary'@-  -- 'SourceExternal  -- explicitly pass a key using @'nodeKeyed'@-  -- @-  ---  -- 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--  -- | Assign values from the 'Dependencies' collection to a value.-  -- 'dependsOn' must be an idempotent operation.-  ---  -- Law:-  ---  -- prop> (\x d -> x `dependsOn` d `dependsOn` d) = dependsOn-  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-  dependsOn a dependencies =-    fromEot $-      genericDependsOn-        (Proxy :: Proxy a)-        (Proxy :: Proxy (Dependencies a))-        (toEot a)-        (toEot dependencies)---- | Abstract over how keys are generated using @'SourceDefault'@ or @'SourceArbitrary'@-class (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a) => GenerateKey a-instance (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a) => GenerateKey a--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- type GraphulaNode m a   = ( HasDependencies a     , Logging m a@@ -408,145 +259,3 @@     , Typeable a     , Arbitrary a     )--{-|-  Generate a value with data dependencies. This leverages-  'HasDependencies' to insert the specified data in the generated value. All-  dependency data is inserted after any editing operations.--  > node @Dog (ownerId, veterinarianId) mempty-  > node @Dog (ownerId, veterinarianId) $ edit $ \dog ->-  >   dog {name = "fido"}--  A value that has an externally managed key must use @'nodeKeyed'@ instead.--}-node-  :: forall a m-   . (GraphulaContext m '[a], GenerateKey a)-  => Dependencies a-  -> NodeOptions a-  -> m (Entity a)-node = nodeImpl $ generate $ generateKey @(KeySource a) @a--{-|-  Generate a value with data dependencies given an externally managed-  key. This leverages 'HasDependencies' to insert the specified data-  in the generated value. All dependency data is inserted after any-  editing operations.--  > someKey <- generateKey-  > node @Cat someKey (ownerId, veterinarianId) mempty-  > anotherKey <- generateKey-  > node @Cat anotherKey (ownerId, veterinarianId) $ edit $ \cat ->-  >   cat {name = "milo"}--  A value that has an automatically managed key may use @'node'@ instead.--}-nodeKeyed-  :: forall a m-   . GraphulaContext m '[a]-  => Key a-  -> Dependencies a-  -> NodeOptions a-  -> m (Entity a)-nodeKeyed key = nodeImpl $ pure $ Just key--nodeImpl-  :: forall a m-   . GraphulaContext m '[a]-  => m (Maybe (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-    let hydrated = edited `dependsOn` dependencies-    logNode hydrated-    mKey <- genKey-    pure (mKey, hydrated)---- | 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 }---- | Require a node to satisfy the specified predicate------ @--- a <- node @A () $ ensure $ (== True) . someField--- @----ensure :: (a -> Bool) -> NodeOptions a-ensure f = mempty { nodeOptionsEdit = Kendo $ \a -> a <$ guard (f a) }---- | Options for generating an individual node------ @'NodeOptions'@ can be created and combined with the Monoidal--- operations @'(<>)'@ and @'mempty'@.------ @--- 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--instance Semigroup (NodeOptions a) where-  (<>) = gmappend-  {-# INLINE (<>) #-}--instance Monoid (NodeOptions a) where-  mempty = gmempty-  {-# INLINE mempty #-}---- | Like @'Endo'@ but uses Kliesli composition-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-  {-# INLINE (<>) #-}--instance Monad m => Monoid (Kendo m a) where-  mempty = Kendo pure-  {-# INLINE mempty #-}--attempt-  :: forall a m-   . (GraphulaContext m '[a])-  => Int-  -> Int-  -> m (Maybe (Maybe (Key a), a))-  -> m (Entity a)-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) -> insert mKey value >>= \case-        Nothing -> loop (succ numEdits) (succ numInserts)-        --               ^ failed to insert, but also increments this-        Just a -> pure a--  die :: (TypeRep -> GenerationFailure) -> m (Entity a)-  die e = throwIO $ e $ typeRep (Proxy :: Proxy a)---- | For entities that only have singular 'Dependencies'-newtype Only a = Only { fromOnly :: a }-  deriving stock (Eq, Show, Ord, Generic, Functor, Foldable, Traversable)--only :: a -> Only a-only = Only

@@ -1,18 +1,13 @@-{-|-  Graphula tracks its own 'QCGen' for deterministic generation with 'Arbitrary'-  and 'Gen'. 'generate' can be used to produce arbitrary values utilizing-  graphula's generation.--}+-- | 'Arbitrary' operations that respect Graphula's seed module Graphula.Arbitrary   ( generate-  )-where+  ) where  import Prelude  import Control.Monad.IO.Unlift (MonadIO, liftIO) import Data.IORef (readIORef, writeIORef)-import Graphula.Internal (MonadGraphulaBackend, askGen)+import Graphula.Class (MonadGraphulaBackend, askGen) import System.Random (split) import Test.QuickCheck (Gen) import Test.QuickCheck.Gen (unGen)

@@ -0,0 +1,45 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Internal type class(es) for Graphula-related behaviors+module Graphula.Class+  ( MonadGraphula+  , MonadGraphulaFrontend(..)+  , MonadGraphulaBackend(..)+  ) 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.Sql (SqlBackend)+import Test.QuickCheck.Random (QCGen)++type MonadGraphula m+  = (Monad m, MonadIO m, MonadGraphulaBackend m, MonadGraphulaFrontend m)++class MonadGraphulaFrontend m where+  insert+    :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m)+    => Maybe (Key a)+    -> a+    -> m (Maybe (Entity a))++  remove+    :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m)+    => Key a+    -> m ()++class MonadGraphulaBackend m where+  type Logging m :: Type -> Constraint+  askGen :: m (IORef QCGen)+  logNode :: Logging m a => a -> m ()

@@ -0,0 +1,194 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++module Graphula.Dependencies+  ( HasDependencies(..)+  , Only(..)+  , only++  -- * Non-serial keys+  , KeySourceType(..)+  , GenerateKey+  , generateKey+  ) where++import Prelude++import Data.Kind (Constraint)+import Data.Proxy (Proxy(..))+import Database.Persist (Key)+import GHC.Generics (Generic)+import GHC.TypeLits (ErrorMessage(..), TypeError)+import Generics.Eot (Eot, HasEot, fromEot, toEot)+import Graphula.Dependencies.Generic+import Graphula.NoConstraint+import Test.QuickCheck.Arbitrary (Arbitrary(..))+import Test.QuickCheck.Gen (Gen)++class HasDependencies a where+  -- | A data type declaring the model's dependencies+  --+  -- Models with no dependencies can declare an empty instance,+  --+  -- @+  -- instance 'HasDependencies' School+  -- @+  --+  -- Models with one dependency must use the 'Only' 1-tuple constructor,+  --+  -- @+  -- instance 'HasDependencies' Teacher where+  --   type Dependencies Teacher = Only SchoolId+  -- @+  --+  -- Models with multiple dependencies use tuple syntax,+  --+  -- @+  -- instance 'HasDependencies' Course where+  --   type Dependencies Course = (SchoolId, TeacherId)+  -- @+  --+  type Dependencies a+  type instance Dependencies _a = ()++  -- | Specify the method for resolving a node's key+  --+  -- This can be+  --+  -- @+  -- 'SourceDefault   -- automatically generate keys from the database+  -- 'SourceArbitrary -- automatically generate keys using @'Arbitrary'@+  -- 'SourceExternal  -- explicitly pass a key using @'nodeKeyed'@+  -- @+  --+  -- 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++  -- | Assign values from the 'Dependencies' collection to a value+  --+  -- This must be an idempotent operation. Law:+  --+  -- prop> (\x d -> x `dependsOn` d `dependsOn` d) = dependsOn+  --+  -- 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+  dependsOn a dependencies =+    fromEot $+      genericDependsOn+        (Proxy :: Proxy a)+        (Proxy :: Proxy (Dependencies a))+        (toEot a)+        (toEot dependencies)++-- | For entities that only have singular 'Dependencies'+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'.+  --++-- | 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 (s :: KeySourceType) a where+  type KeyConstraint s a :: Constraint+  generateKey :: KeyConstraint s a => Gen (Maybe (Key a))++instance GenerateKeyInternal 'SourceDefault a where+  type KeyConstraint 'SourceDefault a = NoConstraint a+  generateKey = pure Nothing++instance GenerateKeyInternal 'SourceArbitrary a where+  type KeyConstraint 'SourceArbitrary a = Arbitrary (Key a)+  generateKey = Just <$> arbitrary++-- Rendered:+--+-- @+-- Cannot generate a value of type ‘X’ using ‘node’ since+--+--   instance HasDependencies X where+--     type KeySource X = 'SourceExternal+--+-- Possible fixes include:+-- • Use ‘nodeKeyed’ instead of ‘node’+-- • 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+  type KeyConstraint 'SourceExternal a = NoConstraint a+  generateKey = error "unreachable"++type family Quote t where+  Quote t = 'Text "‘" ':<>: t ':<>: 'Text "’"

@@ -0,0 +1,141 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Machinery for the 'Generic'-based 'HasDependencies' instance+module Graphula.Dependencies.Generic+  ( GHasDependencies(..)+  ) where++import Data.Kind (Type)+import GHC.TypeLits (ErrorMessage(..), TypeError)+import Generics.Eot (Proxy(..), Void)++data Match t+  = NoMatch t+  | Match t++type family DependenciesTypeInstance nodeTy depsTy where+  DependenciesTypeInstance nodeTy depsTy =+    '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 "’"+      )++  -- 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 ()++  -- Field matches dependency, keep going+  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)++class GHasDependencies nodeTyProxy depsTyProxy node deps where+  genericDependsOn :: nodeTyProxy -> depsTyProxy -> node -> deps -> node++class GHasDependenciesRecursive fieldsProxy node deps where+  genericDependsOnRecursive :: fieldsProxy -> node -> deps -> node++-- This instance head only matches EoT representations of+-- datatypes with no constructors and no dependencies+instance {-# OVERLAPPING #-} GHasDependencies (Proxy nodeTy) (Proxy depsTy) Void (Either () Void) where+  genericDependsOn _ _ node _ = node++-- This instance warns the user if they give dependencies+-- to a datatype with no constructors+instance+  {-# OVERLAPPABLE #-}+  ( 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+  genericDependsOn _ _ _ _ = error "Impossible"++-- This instance head only matches EoT representations of+-- datatypes with a single constructor+instance+  ( FindMatches nodeTy depsTy node deps ~ fields+  , GHasDependenciesRecursive (Proxy fields) node deps+  ) => 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++-- 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+    )+  ) => 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+    )+  ) => 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+    )+  ) => 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+    )+  ) => 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+  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+  genericDependsOnRecursive _ (a, as) deps =+    (a, genericDependsOnRecursive (Proxy :: Proxy fields) as deps)++-- Without the kind-signature for '[], ghc will fail to find this+-- instance for nullary constructors+instance GHasDependenciesRecursive (Proxy ('[] :: [Match Type])) () () where+  genericDependsOnRecursive _ _ _ = ()

@@ -0,0 +1,81 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++-- | A version of 'GraphulaT' that @'remove'@s all @'insert'@ed data afterward+module Graphula.Idempotent+  ( GraphulaIdempotentT+  , runGraphulaIdempotentT+  ) where++import Prelude++import Control.Monad.IO.Unlift+import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)+import Control.Monad.Trans (MonadTrans, lift)+import Data.Foldable (for_)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Database.Persist (Entity(..))+import Graphula.Class+import UnliftIO.Exception (SomeException, catch, mask, throwIO)++newtype GraphulaIdempotentT m a = GraphulaIdempotentT+  { runGraphulaIdempotentT' :: ReaderT (IORef (m ())) m a+  }+  deriving newtype+    ( Functor+    , Applicative+    , Monad+    , MonadIO+    , MonadReader (IORef (m ()))+    )++instance MonadUnliftIO m => MonadUnliftIO (GraphulaIdempotentT m) where+  {-# INLINE withRunInIO #-}+  withRunInIO inner = GraphulaIdempotentT $ withRunInIO $ \run ->+    inner $ run . runGraphulaIdempotentT'++instance MonadTrans GraphulaIdempotentT where+  lift = GraphulaIdempotentT . lift++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 >>)+    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+  rollback finalizersRef $ pure x+ where+  rollback :: MonadIO m => IORef (m a) -> m b -> m b+  rollback finalizersRef x = do+    finalizers <- liftIO $ readIORef finalizersRef+    finalizers >> x++  rollbackRethrow :: MonadIO m => IORef (m a) -> SomeException -> m b+  rollbackRethrow finalizersRef (e :: SomeException) =+    rollback finalizersRef (throwIO e)

@@ -1,237 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoStarIsType #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--module Graphula.Internal-  ( MonadGraphulaBackend(..)-  , GHasDependencies(..)-  , KeySourceType(..)-  , GenerateKeyInternal(..)-  , NoConstraint-  )-where--import Data.IORef (IORef)-import Data.Kind (Constraint, Type)-import Database.Persist (Key)-import Generics.Eot (Proxy(..), Void)-import GHC.TypeLits (ErrorMessage(..), TypeError)-import Test.QuickCheck (Arbitrary(..), Gen)-import Test.QuickCheck.Random (QCGen)--class MonadGraphulaBackend m where-  type Logging m :: Type -> Constraint-  -- ^ A constraint provided to log details of the graph to some form of-  --   persistence. This is used by 'runGraphulaLogged' to store graph nodes as-  --   'Show'n 'Text' values-  askGen :: m (IORef QCGen)-  logNode :: Logging m a => a -> m ()--data Match t-  = NoMatch t-  | Match t--type family DependenciesTypeInstance nodeTy depsTy where-  DependenciesTypeInstance nodeTy depsTy =-    '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 "’"-      )--  -- 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 ()--  -- Field matches dependency, keep going-  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)--class GHasDependencies nodeTyProxy depsTyProxy node deps where-  genericDependsOn :: nodeTyProxy -> depsTyProxy -> node -> deps -> node--class GHasDependenciesRecursive fieldsProxy node deps where-  genericDependsOnRecursive :: fieldsProxy -> node -> deps -> node---- This instance head only matches EoT representations of--- datatypes with no constructors and no dependencies-instance {-# OVERLAPPING #-} GHasDependencies (Proxy nodeTy) (Proxy depsTy) Void (Either () Void) where-  genericDependsOn _ _ node _ = node---- This instance warns the user if they give dependencies--- to a datatype with no constructors-instance-  {-# OVERLAPPABLE #-}-  ( 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-  genericDependsOn _ _ _ _ = error "Impossible"---- This instance head only matches EoT representations of--- datatypes with a single constructor-instance-  ( FindMatches nodeTy depsTy node deps ~ fields-  , GHasDependenciesRecursive (Proxy fields) node deps-  ) => 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---- 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-    )-  ) => 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-    )-  ) => 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-    )-  ) => 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-    )-  ) => 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-  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-  genericDependsOnRecursive _ (a, as) deps =-    (a, genericDependsOnRecursive (Proxy :: Proxy fields) as deps)---- Without the kind-signature for '[], ghc will fail to find this--- instance for nullary constructors-instance GHasDependenciesRecursive (Proxy ('[] :: [Match Type])) () () where-  genericDependsOnRecursive _ _ _ = ()--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---- | Handle key generation for @'SourceDefault'@ and @'SourceArbitrary'@------ Ths could be a single-parameter class, but carrying the @a@ around--- lets us give a better error message when @'node'@ is called instead--- of @'nodeKeyed'@.----class GenerateKeyInternal (s :: KeySourceType) a where-  type KeyConstraint s a :: Constraint-  generateKey :: KeyConstraint s a => Gen (Maybe (Key a))--instance GenerateKeyInternal 'SourceDefault a where-  type KeyConstraint 'SourceDefault a = NoConstraint a-  generateKey = pure Nothing--instance GenerateKeyInternal 'SourceArbitrary a where-  type KeyConstraint 'SourceArbitrary a = Arbitrary (Key a)-  generateKey = Just <$> arbitrary---- | Explicit instance for @'SourceExternal'@ to give an actionable error message------ Rendered:------ @--- Cannot generate a value of type ‘X’ using ‘node’ since------   instance HasDependencies X where---     type KeySource X = 'SourceExternal------ Possible fixes include:--- • Use ‘nodeKeyed’ instead of ‘node’--- • 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-  type KeyConstraint 'SourceExternal a = NoConstraint a-  generateKey = error "unreachable"--type family Quote t where-  Quote t = 'Text "‘" ':<>: t ':<>: 'Text "’"---- | 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.-class NoConstraint a-instance NoConstraint a

@@ -3,18 +3,42 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}++-- | Convenience functions for working with 'Key' dependencies module Graphula.Key   ( onlyKey   , keys   , Keys-  )-where+  ) where  import Database.Persist 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'+  --+  -- For example, given:+  --+  -- @+  -- instance 'HasDependencies' Course where+  --   type Dependencies Course = (SchoolId, TeacherId)+  -- @+  --+  -- You would have to do,+  --+  -- @+  -- course <- 'node' @Course (entityKey school, entityKey teacher) mempty+  -- @+  --+  -- This type-class allows you to do:+  --+  -- @+  -- course <- 'node' @Course ('keys' (school, teacher)) mempty+  -- @+  --+  -- The type class instances currently scale up 4-tuple 'Dependencies'.+  --   type Keys a   keys :: a -> Keys a @@ -29,6 +53,7 @@   type Keys (Entity a) = Key a   keys = entityKey +-- | Equivalent to @'Only' . 'entityKey'@ onlyKey :: Entity a -> Only (Key a) onlyKey = keys . only 

@@ -0,0 +1,124 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++-- | A version of 'GraphulaT' that logs the generated graph+module Graphula.Logged+  ( GraphulaLoggedT+  , runGraphulaLoggedT+  , runGraphulaLoggedWithFileT+  , runGraphulaLoggedUsingT+  ) where++import Prelude++import Control.Monad.IO.Unlift+import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)+import Control.Monad.Trans (MonadTrans, lift)+import Data.Foldable (traverse_)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.Sequence (Seq, empty, (|>))+import Data.Text (Text, pack)+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.Temp (openTempFile)+import Test.HUnit.Lang+  (FailureReason(..), HUnitFailure(..), formatFailureReason)+import UnliftIO.Exception (bracket, catch, throwIO)++newtype GraphulaLoggedT m a = GraphulaLoggedT+  { runGraphulaLoggedT' :: ReaderT (IORef (Seq Text)) m a+  }+  deriving newtype+    ( Functor+    , Applicative+    , Monad+    , MonadIO+    , MonadReader (IORef (Seq Text))+    )++instance MonadTrans GraphulaLoggedT where+  lift = GraphulaLoggedT . lift++instance (MonadGraphulaBackend m, MonadIO m) => MonadGraphulaBackend (GraphulaLoggedT m) where+  type Logging (GraphulaLoggedT m) = Show+  askGen = lift askGen+  logNode n = do+    graphLog <- ask+    liftIO $ modifyIORef' graphLog (|> pack (show n))++instance (Monad m, MonadGraphulaFrontend m) => MonadGraphulaFrontend (GraphulaLoggedT m) where+  insert mKey = lift . insert mKey+  remove = lift . remove++-- | Run the graph while logging to a temporary file+runGraphulaLoggedT :: MonadUnliftIO m => GraphulaLoggedT m a -> m a+runGraphulaLoggedT = runGraphulaLoggedUsingT logFailTemp++-- | 'runGraphulaLoggedT', but to the specified file+runGraphulaLoggedWithFileT+  :: MonadUnliftIO m => FilePath -> GraphulaLoggedT m a -> m a+runGraphulaLoggedWithFileT = runGraphulaLoggedUsingT . logFailFile++-- | 'runGraphulaLoggedT', but using the custom action to accumulate+runGraphulaLoggedUsingT+  :: MonadUnliftIO m+  => (IORef (Seq Text) -> HUnitFailure -> m a)+  -> GraphulaLoggedT m a+  -> m a+runGraphulaLoggedUsingT logFail action = do+  graphLog <- liftIO $ newIORef empty+  runReaderT (runGraphulaLoggedT' action) graphLog `catch` logFail graphLog++logFailUsing+  :: MonadIO m+  => IO (FilePath, Handle)+  -> IORef (Seq Text)+  -> HUnitFailure+  -> m a+logFailUsing f graphLog hunitfailure =+  flip rethrowHUnitLogged hunitfailure =<< logGraphToHandle graphLog f++logFailFile :: MonadIO m => FilePath -> IORef (Seq Text) -> HUnitFailure -> m a+logFailFile path = logFailUsing ((path, ) <$> openFile path WriteMode)++logFailTemp :: MonadIO m => IORef (Seq Text) -> HUnitFailure -> m a+logFailTemp = logFailUsing $ do+  tmp <- (++ "/graphula") <$> getTemporaryDirectory+  createDirectoryIfMissing True tmp+  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+  )++rethrowHUnitLogged :: MonadIO m => FilePath -> HUnitFailure -> m a+rethrowHUnitLogged path =+  rethrowHUnitWith ("Graph dumped in temp file: " ++ path)++rethrowHUnitWith :: MonadIO m => String -> HUnitFailure -> m a+rethrowHUnitWith message (HUnitFailure l r) =+  throwIO . HUnitFailure l . Reason $ message ++ "\n\n" ++ formatFailureReason r

@@ -0,0 +1,14 @@+{-# LANGUAGE FlexibleInstances #-}++-- | An empty 'Constraint'+--+-- 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++class NoConstraint a+instance NoConstraint a

@@ -0,0 +1,204 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++module Graphula.Node+  (+  -- * Generating+    node+  , nodeKeyed++  -- * 'NodeOptions'+  , NodeOptions+  , edit+  , ensure++  -- * Exceptions+  , GenerationFailure(..)+  ) where++import Prelude++import Control.Monad (guard, (<=<))+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.Sql (SqlBackend)+import GHC.Generics (Generic)+import Graphula.Arbitrary+import Graphula.Class+import Graphula.Dependencies+import Test.QuickCheck (Arbitrary(..))+import UnliftIO.Exception (Exception, throwIO)++-- | Options for generating an individual node+--+--+-- 'NodeOptions' can be created and combined with the Monoidal operations '(<>)'+-- and 'mempty'.+--+-- > 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++instance Semigroup (NodeOptions a) where+  (<>) = gmappend+  {-# INLINE (<>) #-}++instance Monoid (NodeOptions a) where+  mempty = gmempty+  {-# INLINE mempty #-}++-- | Like @'Endo'@ but uses Kliesli composition+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+  {-# INLINE (<>) #-}++instance Monad m => Monoid (Kendo m a) where+  mempty = Kendo pure+  {-# INLINE mempty #-}++-- | 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 }++-- | 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) }++-- | Generate a node with a default (Database-provided) key+--+-- > a <- node @A () mempty+--+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)+node = nodeImpl $ generate $ generateKey @(KeySource a) @a++-- | 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+     , Arbitrary a+     , HasDependencies a+     , PersistEntityBackend a ~ SqlBackend+     , PersistEntity a+     , Typeable a+     )+  => Key a+  -> Dependencies a+  -> NodeOptions a+  -> m (Entity a)+nodeKeyed key = nodeImpl $ pure $ Just key++nodeImpl+  :: forall a m+   . ( MonadGraphula m+     , Logging m a+     , Arbitrary a+     , HasDependencies a+     , PersistEntityBackend a ~ SqlBackend+     , PersistEntity a+     , Typeable a+     )+  => m (Maybe (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++attempt+  :: forall a m+   . ( MonadGraphula m+     , PersistEntityBackend a ~ SqlBackend+     , PersistEntity a+     , Typeable a+     )+  => Int+  -> Int+  -> m (Maybe (Maybe (Key a), a))+  -> m (Entity a)+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) -> 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++  die :: (TypeRep -> GenerationFailure) -> m (Entity a)+  die e = throwIO $ e $ typeRep (Proxy :: Proxy a)

@@ -1,47 +0,0 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}--module Graphula.UUIDKey-  ( UUIDKey-  )-where--import Prelude--import Data.Aeson (FromJSON, ToJSON)-import qualified Data.Text as Text-import Data.UUID (UUID)-import qualified Data.UUID as UUID-import Database.Persist-import Database.Persist.Sql-import Test.QuickCheck (Arbitrary(..), Gen, getLarge)-import Web.HttpApiData (FromHttpApiData, ToHttpApiData)-import Web.PathPieces (PathPiece(..))---- | Example non-serial key-newtype UUIDKey = UUIDKey { unUUIDKey :: UUID }-  deriving newtype (Eq, Show, Ord, Read, FromJSON, ToJSON, ToHttpApiData, FromHttpApiData)--instance Arbitrary UUIDKey where-  arbitrary = UUIDKey <$> uuid-    where uuid = UUID.fromWords <$> large <*> large <*> large <*> large--large :: (Integral a, Bounded a) => Gen a-large = getLarge <$> arbitrary--instance PathPiece UUIDKey where-  toPathPiece = Text.pack . UUID.toString . unUUIDKey-  fromPathPiece = fmap UUIDKey . UUID.fromString . Text.unpack--instance PersistField UUIDKey where-  toPersistValue = PersistText . Text.pack . UUID.toString . unUUIDKey-  fromPersistValue = \case-    PersistText t -> case UUID.fromString $ Text.unpack t of-      Just x -> Right $ UUIDKey x-      Nothing -> Left "Invalid UUID"-    _ -> Left "Not PersistText"--instance PersistFieldSql UUIDKey where-  sqlType _ = SqlOther "uuid"

@@ -1,6 +1,7 @@-# Graphula Core+# Graphula -Graphula is a simple interface for generating persistent data and linking its dependencies. We use this interface to generate fixtures for automated testing. The interface is extensible and supports pluggable front-ends.+Graphula is a simple interface for generating persistent data and linking its+dependencies. We use this interface to generate fixtures for automated testing.   <!--@@ -24,7 +25,6 @@  module Main (module Main) where -import Control.Monad (replicateM_) import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger (NoLoggingT)@@ -32,12 +32,11 @@ import Control.Monad.Trans.Resource (ResourceT) import Database.Persist.Sqlite import Database.Persist.TH-import Data.Typeable import GHC.Generics (Generic) import Graphula-import Graphula.UUIDKey import Test.Hspec import Test.QuickCheck+import Test.QuickCheck.Arbitrary.Generic import Text.Markdown.Unlit ()  instance (ToBackendKey SqlBackend a) => Arbitrary (Key a) where@@ -47,115 +46,98 @@  ## Arbitrary Data -Graphula utilizes `QuickCheck` to generate random data. We need to declare `Arbitrary` instances for our types.+Graphula utilizes `QuickCheck` to generate random data. We need to declare+`Arbitrary` instances for our models.  ```haskell share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|-A-  a String-  b Int+School+  name String   deriving Show Eq Generic -B-  a AId-  b String+Teacher+  schoolId SchoolId+  name String   deriving Show Eq Generic -C-  a AId-  b BId-  c String+Course+  schoolId SchoolId+  teacherId TeacherId+  name String   deriving Show Eq Generic -D-  Id UUIDKey-  a Int-  b String+Student+  name String   deriving Show Eq Generic -E-  Id DId sqltype=uuid-  a String+Question+  content String   deriving Show Eq Generic -F-  a Bool-  UniqueFA a+Answer+  questionId QuestionId+  studentId StudentId+  yes Bool+  UniqueAnswer questionId studentId   deriving Show Eq Generic |] -instance Arbitrary A where-  arbitrary = A <$> arbitrary <*> arbitrary+instance Arbitrary School where+  arbitrary = genericArbitrary -instance Arbitrary B where-  arbitrary = B <$> arbitrary <*> arbitrary+instance Arbitrary Teacher where+  arbitrary = genericArbitrary -instance Arbitrary C where-  arbitrary = C <$> arbitrary <*> arbitrary <*> arbitrary+instance Arbitrary Course where+  arbitrary = genericArbitrary -instance Arbitrary D where-  arbitrary = D <$> arbitrary <*> arbitrary+instance Arbitrary Student where+  arbitrary = genericArbitrary -instance Arbitrary E where-  arbitrary = E <$> arbitrary+instance Arbitrary Question where+  arbitrary = genericArbitrary -instance Arbitrary F where-  arbitrary = F <$> arbitrary+instance Arbitrary Answer where+  arbitrary = genericArbitrary ```  ## Dependencies -We declare dependencies via the `HasDependencies` typeclass and its associated type `Dependencies`.--By default a type does not have any dependencies. We only need to declare an empty instance.+We declare dependencies via the `HasDependencies` typeclass and its associated+type `Dependencies`. If a model does not have any dependencies, we only need to+declare an empty instance.  ```haskell-instance HasDependencies A-instance HasDependencies F-```+instance HasDependencies School -For single dependencies we use the `Only` type.+instance HasDependencies Student -```haskell-instance HasDependencies B where-  type Dependencies B = Only AId+instance HasDependencies Question ``` -Groups of dependencies use tuples. Declare these dependencies in the order they appear in the type. `HasDependencies` leverages generic programming to inject dependencies for you.+For single-dependency models, we use the `Only` type.  ```haskell-instance HasDependencies C where-  type Dependencies C = (AId, BId)+instance HasDependencies Teacher where+  type Dependencies Teacher = Only SchoolId ``` -## Non Sequential Keys--Graphula supports non-sequential keys with the `KeySource` associated type. To generate a key using-its `Arbitrary` instance, use `'SourceArbitrary`. Non-serial keys will need to also derive-an overlapping `Arbitrary` instance.+Multi-dependency models use tuples. Declare these dependencies in the order they+appear in the model's type definition. `HasDependencies` leverages generic+programming to inject dependencies for you.  ```haskell-instance HasDependencies D where-  type KeySource D = 'SourceArbitrary--deriving newtype instance {-# OVERLAPPING #-} Arbitrary (Key D)-```--You can also elect to always specify an external key using `'SourceExternal`. This means that-this type cannot be constructed with `node`; use `nodeKeyed` instead.+instance HasDependencies Course where+  type Dependencies Course = (SchoolId, TeacherId) -```haskell-instance HasDependencies E where-  type KeySource E = 'SourceExternal+instance HasDependencies Answer where+  type Dependencies Answer = (QuestionId, StudentId) ``` -By default, `HasDependencies` instances use `type KeySource _ = 'SourceDefault`, which means-that graphula will expect the database to provide a key.--## Serialization+## Logging failures -Graphula allows logging of graphs via `runGraphulaLogged`. Graphula dumps graphs-to a temp file on test failure.+`runGraphulaLogged` will dump generated data to a temporary file. Or+`runGraphulaLoggedWithFileT` can be used to pass an explicit path.  ```haskell loggingSpec :: IO ()@@ -164,17 +146,20 @@     logFile :: FilePath     logFile = "test.graphula" -    -- We'd typically use `runGraphulaLogged` which utilizes a temp file.     failingGraph :: IO ()     failingGraph = runGraphulaT Nothing runDB . runGraphulaLoggedWithFileT logFile $ do-      Entity _ a <- node @A () $ edit $ \n ->-        n {aA = "success"}-      liftIO $ aA a `shouldBe` "failed"+      student <- node @Student () mempty+      question <- node @Question () mempty+      answer <- node @Answer+        (entityKey question, entityKey student)+        $ edit $ \a -> a { answerYes = True } -  failingGraph-    `shouldThrow` anyException+      -- Test failures will cause the graph to be logged (not any exception)+      liftIO $ answerYes (entityVal answer) `shouldBe` False -  n <- lines <$> readFile "test.graphula"+  failingGraph `shouldThrow` anyException++  n <- lines <$> readFile logFile   n `shouldSatisfy` (not . null) ``` @@ -184,69 +169,23 @@ simpleSpec :: IO () simpleSpec =   runGraphulaT Nothing runDB $ do-    -- Type application is not necessary, but recommended for clarity.-    Entity aId _ <- node @A () mempty-    Entity bId b <- node @B (only aId) mempty-    Entity _ c <- node @C (aId, bId) $ edit $ \n -> n { cC = "edited" }-    Entity dId _ <- node @D () mempty-    Entity eId _ <- nodeKeyed @E (EKey dId) () mempty+    school <- node @School () mempty+    teacher <- node @Teacher (Only $ entityKey school) mempty+    course <- node @Course (entityKey school, entityKey teacher) mempty+    student <- node @Student () $ edit $ \s -> s { studentName = "Pat" }+    question <- node @Question () mempty+    answer <- node @Answer+      (entityKey question, entityKey student)+      $ edit $ \a -> a { answerYes = True } -    -- Do something with your data     liftIO $ do-      cC c `shouldBe` "edited"-      cA c `shouldBe` bA b-      unEKey eId `shouldBe` dId-```--`runGraphulaT` carries frontend instructions. If we'd like to override them we need to declare our own frontend.--For example, a front-end that always fails to insert.--```haskell-newtype GraphulaFailT m a = GraphulaFailT { runGraphulaFailT :: m a }-  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadGraphulaBackend)--instance MonadGraphulaFrontend (GraphulaFailT m) where-  insert _ _ = pure Nothing-  remove = const (pure ())--insertionFailureSpec :: IO ()-insertionFailureSpec = do-  let-    failingGraph :: IO ()-    failingGraph =  runGraphulaT Nothing runDB . runGraphulaFailT $ do-      Entity _ _ <- node @A () mempty-      pure ()-  failingGraph-    `shouldThrow` (== (GenerationFailureMaxAttemptsToInsert (typeRep $ Proxy @A)))-```--Note that graphula can fail naturally if we define a graph that violates unique constraints-in the database:--```haskell-constraintFailureSpec :: IO ()-constraintFailureSpec = do-  let-    failingGraph :: IO ()-    failingGraph =  runGraphulaT Nothing runDB $-      replicateM_ 3 $ node @F () mempty-  failingGraph-    `shouldThrow` (== (GenerationFailureMaxAttemptsToInsert (typeRep $ Proxy @F)))-```--or if we define a graph with an unsatisfiable predicates:--```haskell-ensureFailureSpec :: IO ()-ensureFailureSpec = do-  let-    failingGraph :: IO ()-    failingGraph =  runGraphulaT Nothing runDB $ do-      Entity _ _ <- node @A () $ ensure $ \a -> a /= a-      pure ()-  failingGraph-    `shouldThrow` (== (GenerationFailureMaxAttemptsToConstrain (typeRep $ Proxy @A)))+      -- Typically, you would run some other function like "fetch correct+      -- answers at school" and assert you found the correct answers you+      -- generated. In this example we just assert some things about the data+      -- directly:+      teacherSchoolId (entityVal teacher) `shouldBe` entityKey school+      courseTeacherId (entityVal course) `shouldBe` entityKey teacher+      answerYes (entityVal answer) `shouldBe` True ```  <!--@@ -256,9 +195,6 @@   describe "graphula" . parallel $ do     it "generates and links arbitrary graphs of data" simpleSpec     it "allows logging graphs" loggingSpec-    it "attempts to retry node generation on insertion failure" insertionFailureSpec-    it "attempts to retry node generation on a database constraint violation" constraintFailureSpec-    it "attempts to retry node generation on unsatisfiable predicates" ensureFailureSpec  runDB :: MonadUnliftIO m => ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a runDB f = runSqlite "test.db" $ do