feat: include insert error messages in GenerationFailure

src/Graphula.hs

@@ -211,39 +211,43 @@ instance MonadIO m => MonadGraphulaBackend (GraphulaT n m) where
   logNode _ = pure ()
 
 instance (MonadIO m, MonadIO n) => MonadGraphulaFrontend (GraphulaT n m) where
-  insert mKey n = do
+  insertEither mKey n = do
     RunDB runDB <- asks dbRunner
     lift . runDB $ case mKey of
       Nothing ->
         insertUnique n >>= \case
-          Nothing -> pure Nothing
-          Just key -> getEntity key
+          Nothing -> pure $ Left "entity violated a unique constraint"
+          Just key -> maybe (Left "inserted entity not found") Right <$> getEntity key
       Just key -> do
         existingKey <- get key
-        whenNothing existingKey $ do
-          existingUnique <- checkUnique n
-          whenNothing existingUnique $ do
-            Persist.insertKey key n
-            getEntity key
+        case existingKey of
+          Just _ -> pure $ Left "entity already exists by this key"
+          Nothing -> do
+            existingUnique <- checkUnique n
+            case existingUnique of
+              Just _ -> pure $ Left "entity would violate unique constraint"
+              Nothing -> do
+                Persist.insertKey key n
+                maybe (Left "inserted entity not found") Right <$> getEntity key
 
-  insertKeyed key n = do
+  insertKeyedEither 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
+      case existingKey of
+        Just _ -> pure $ Left "entity already exists by this key"
+        Nothing -> do
+          existingUnique <- checkUnique n
+          case existingUnique of
+            Just _ -> pure $ Left "entity would violate unique constraint"
+            Nothing -> do
+              Persist.insertKey key n
+              maybe (Left "inserted entity not found") Right <$> getEntity key
 
   remove key = do
     RunDB runDB <- asks dbRunner
     lift . runDB $ delete key
 
-whenNothing :: Applicative m => Maybe a -> m (Maybe b) -> m (Maybe b)
-whenNothing Nothing f = f
-whenNothing (Just _) _ = pure Nothing
-
 runGraphulaT
   :: MonadUnliftIO m
   => Maybe Int

src/Graphula/Class.hs

@@ -66,6 +66,18 @@ class MonadGraphulaFrontend m where
     => Maybe (Key a)
     -> a
     -> m (Maybe (Entity a))
+  insert mk a = either (const Nothing) Just <$> insertEither mk a
+
+  insertEither
+    :: ( PersistEntityBackend a ~ SqlBackend
+       , PersistEntity a
+       , Monad m
+       , GraphulaSafeToInsert a
+       )
+    => Maybe (Key a)
+    -> a
+    -> m (Either String (Entity a))
+  insertEither mk a = maybe (Left "Unable to insert entity") Right <$> insert mk a
 
   insertKeyed
     :: ( PersistEntityBackend a ~ SqlBackend
@@ -75,12 +87,25 @@ class MonadGraphulaFrontend m where
     => Key a
     -> a
     -> m (Maybe (Entity a))
+  insertKeyed k a = either (const Nothing) Just <$> insertKeyedEither k a
+
+  insertKeyedEither
+    :: ( PersistEntityBackend a ~ SqlBackend
+       , PersistEntity a
+       , Monad m
+       )
+    => Key a
+    -> a
+    -> m (Either String (Entity a))
+  insertKeyedEither k a = maybe (Left "Unable to insert keyed entity") Right <$> insertKeyed k a
 
   remove
     :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m)
     => Key a
     -> m ()
 
+  {-# MINIMAL (insert | insertEither), (insertKeyed | insertKeyedEither), remove #-}
+
 class MonadGraphulaBackend m where
   type Logging m :: Type -> Constraint
   askGen :: m (IORef QCGen)

src/Graphula/Dependencies.hs

@@ -107,10 +107,10 @@ class HasDependencies a where
     :: ( HasEot a
        , HasEot (Dependencies a)
        , GHasDependencies
-          (Proxy a)
-          (Proxy (Dependencies a))
-          (Eot a)
-          (Eot (Dependencies a))
+           (Proxy a)
+           (Proxy (Dependencies a))
+           (Eot a)
+           (Eot (Dependencies a))
        )
     => a
     -> Dependencies a
@@ -177,16 +177,28 @@ class InsertWithPossiblyRequiredKey (requirement :: Type -> Type) where
     => requirement (Key record)
     -> record
     -> m (Maybe (Entity record))
+  insertWithPossiblyRequiredKeyEither
+    :: ( PersistEntityBackend record ~ SqlBackend
+       , PersistEntity record
+       , Monad m
+       , MonadGraphulaFrontend m
+       , InsertConstraint requirement record
+       )
+    => requirement (Key record)
+    -> record
+    -> m (Either String (Entity record))
   justKey :: key -> requirement key
 
 instance InsertWithPossiblyRequiredKey Optional where
   type InsertConstraint Optional = GraphulaSafeToInsert
   insertWithPossiblyRequiredKey (Optional key) = MonadGraphulaFrontend.insert key
+  insertWithPossiblyRequiredKeyEither (Optional key) = MonadGraphulaFrontend.insertEither key
   justKey = Optional . Just
 
 instance InsertWithPossiblyRequiredKey Required where
   type InsertConstraint Required = NoConstraint
   insertWithPossiblyRequiredKey (Required key) = MonadGraphulaFrontend.insertKeyed key
+  insertWithPossiblyRequiredKeyEither (Required key) = MonadGraphulaFrontend.insertKeyedEither key
   justKey = Required
 
 -- | Abstract constraint that some @a@ can generate a key

src/Graphula/Node.hs

@@ -142,22 +142,20 @@ attempt
   -> Int
   -> m (Maybe (KeyForInsert a, a))
   -> m (Entity a)
-attempt maxEdits maxInserts source = loop 0 0
+attempt maxEdits maxInserts source = loop 0 0 Nothing
  where
-  loop :: Int -> Int -> m (Entity a)
-  loop numEdits numInserts
-    | numEdits >= maxEdits = die GenerationFailureMaxAttemptsToConstrain
-    | numInserts >= maxInserts = die GenerationFailureMaxAttemptsToInsert
+  loop :: Int -> Int -> Maybe String -> m (Entity a)
+  loop numEdits numInserts mmsg
+    | numEdits >= maxEdits = die $ GenerationFailureMaxAttemptsToConstrain mmsg
+    | numInserts >= maxInserts = die $ GenerationFailureMaxAttemptsToInsert mmsg
     | otherwise =
         source >>= \case
-          Nothing -> loop (succ numEdits) numInserts
+          Nothing -> loop (succ numEdits) numInserts Nothing
           --               ^ 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
+            insertWithPossiblyRequiredKeyEither mKey value >>= \case
+              Left msg -> loop (succ numEdits) (succ numInserts) $ Just msg
+              Right a -> pure a
 
 -- | Generate a node with an explictly-given key
 --
@@ -198,22 +196,20 @@ attempt'
   -> Key a
   -> m (Maybe a)
   -> m (Entity a)
-attempt' maxEdits maxInserts key source = loop 0 0
+attempt' maxEdits maxInserts key source = loop 0 0 Nothing
  where
-  loop :: Int -> Int -> m (Entity a)
-  loop numEdits numInserts
-    | numEdits >= maxEdits = die GenerationFailureMaxAttemptsToConstrain
-    | numInserts >= maxInserts = die GenerationFailureMaxAttemptsToInsert
+  loop :: Int -> Int -> Maybe String -> m (Entity a)
+  loop numEdits numInserts mmsg
+    | numEdits >= maxEdits = die $ GenerationFailureMaxAttemptsToConstrain mmsg
+    | numInserts >= maxInserts = die $ GenerationFailureMaxAttemptsToInsert mmsg
     | otherwise =
         source >>= \case
-          Nothing -> loop (succ numEdits) numInserts
+          Nothing -> loop (succ numEdits) numInserts Nothing
           --               ^ 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
+            insertKeyedEither key value >>= \case
+              Left msg -> loop (succ numEdits) (succ numInserts) $ Just msg
+              Right a -> pure a
 
 die
   :: forall a m
@@ -224,9 +220,9 @@ die e = throwIO $ e $ typeRep $ Proxy @a
 
 data GenerationFailure
   = -- | Could not satisfy constraints defined using 'ensure'
-    GenerationFailureMaxAttemptsToConstrain TypeRep
+    GenerationFailureMaxAttemptsToConstrain (Maybe String) TypeRep
   | -- | Could not satisfy database constraints on 'insert'
-    GenerationFailureMaxAttemptsToInsert TypeRep
+    GenerationFailureMaxAttemptsToInsert (Maybe String) TypeRep
   deriving stock (Show, Eq)
 
 instance Exception GenerationFailure

test/README.lhs

@@ -32,6 +32,7 @@ dependencies. We use this interface to generate fixtures for automated testing.
 
 module Main (module Main) where
 
+import Control.Exception (try, Exception(..))
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger (NoLoggingT)
@@ -170,6 +171,28 @@ loggingSpec = do
   n `shouldSatisfy` (not . null)
 ```
 
+## Generation Failures
+
+Generating the graph can fail if you ask it do impossible things, such as
+generate entities that collide on a unique constraint. In such cases, you will
+receive an informative error:
+
+```haskell
+generationFailureSpec :: IO ()
+generationFailureSpec = do
+  result <- try $ runGraphulaT Nothing runDB $ do
+    school <- node @School () mempty
+
+    -- collision that will never resolve
+    nodeKeyed @School (entityKey school) () mempty
+
+  case result of
+    Left ex ->
+      displayException @GenerationFailure ex
+        `shouldBe` "GenerationFailureMaxAttemptsToInsert (Just \"entity already exists by this key\") School"
+    Right _ -> pure ()
+```
+
 ## Running It
 
 ```haskell
@@ -202,6 +225,7 @@ main = hspec $
   describe "graphula" . parallel $ do
     it "generates and links arbitrary graphs of data" simpleSpec
     it "allows logging graphs" loggingSpec
+    it "shows informative generation failures" generationFailureSpec
 
 runDB :: MonadUnliftIO m => ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a
 runDB f = runSqlite "test.db" $ do