diff --git a/.gitignore b/.gitignore index 6106a19..b4458a7 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ *.stack-work *.graphula test.db +dist-newstyle/ \ No newline at end of file diff --git a/src/Graphula/Class.hs b/src/Graphula/Class.hs index 199de82..71a2cb9 100644 --- a/src/Graphula/Class.hs +++ b/src/Graphula/Class.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE LambdaCase #-} -- | Internal type class(es) for Graphula-related behaviors module Graphula.Class @@ -18,6 +19,7 @@ module Graphula.Class , GraphulaSafeToInsert ) where +import Control.Exception (SomeException) import Control.Monad.IO.Class (MonadIO) import Data.IORef (IORef) import Data.Kind (Constraint, Type) @@ -57,6 +59,19 @@ type MonadGraphula m = (Monad m, MonadIO m, MonadGraphulaBackend m, MonadGraphulaFrontend m) class MonadGraphulaFrontend m where + insertVerbose + :: ( PersistEntityBackend a ~ SqlBackend + , PersistEntity a + , Monad m + , GraphulaSafeToInsert a + ) + => Maybe (Key a) + -> a + -> m (Either (Maybe SomeException) (Entity a)) + insertVerbose mk a = insert mk a >>= \case + Just ea -> pure (Right ea) + Nothing -> pure (Left Nothing) + insert :: ( PersistEntityBackend a ~ SqlBackend , PersistEntity a @@ -66,11 +81,15 @@ class MonadGraphulaFrontend m where => Maybe (Key a) -> a -> m (Maybe (Entity a)) + insert mk a = insertVerbose mk a >>= \case + Right ea -> pure (Just ea) + Left _ -> pure Nothing remove :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m) => Key a -> m () + {-# MINIMAL remove, insert | remove, insertVerbose #-} class MonadGraphulaBackend m where type Logging m :: Type -> Constraint diff --git a/src/Graphula/Node.hs b/src/Graphula/Node.hs index 9b8cf24..476791b 100644 --- a/src/Graphula/Node.hs +++ b/src/Graphula/Node.hs @@ -36,6 +36,7 @@ module Graphula.Node import Prelude import Control.Monad (guard, (<=<)) +import Data.Maybe (maybeToList) import Data.Proxy (Proxy (..)) import Data.Semigroup.Generic (gmappend, gmempty) import Data.Traversable (for) @@ -47,7 +48,7 @@ import Graphula.Arbitrary import Graphula.Class import Graphula.Dependencies import Test.QuickCheck (Arbitrary (..)) -import UnliftIO.Exception (Exception, throwIO) +import UnliftIO.Exception (Exception, SomeException, throwIO) -- | Options for generating an individual node -- @@ -164,10 +165,10 @@ nodeImpl genKey dependencies NodeOptions {..} = attempt 100 10 $ do data GenerationFailure = -- | Could not satisfy constraints defined using 'ensure' - GenerationFailureMaxAttemptsToConstrain TypeRep + GenerationFailureMaxAttemptsToConstrain TypeRep [SomeException] | -- | Could not satisfy database constraints on 'insert' - GenerationFailureMaxAttemptsToInsert TypeRep - deriving stock (Show, Eq) + GenerationFailureMaxAttemptsToInsert TypeRep [SomeException] + deriving stock (Show) instance Exception GenerationFailure @@ -183,22 +184,22 @@ attempt -> Int -> m (Maybe (Maybe (Key a), a)) -> m (Entity a) -attempt maxEdits maxInserts source = loop 0 0 +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 + loop :: Int -> Int -> [SomeException] -> m (Entity a) + loop numEdits numInserts errs + | numEdits >= maxEdits = die $ flip GenerationFailureMaxAttemptsToConstrain errs + | numInserts >= maxInserts = die $ flip GenerationFailureMaxAttemptsToInsert errs | otherwise = source >>= \case - Nothing -> loop (succ numEdits) numInserts + Nothing -> loop (succ numEdits) numInserts errs -- ^ failed to edit, only increments this Just (mKey, value) -> - insert mKey value >>= \case - Nothing -> loop (succ numEdits) (succ numInserts) + insertVerbose mKey value >>= \case + Left errMay -> loop (succ numEdits) (succ numInserts) (maybeToList errMay ++ errs) -- ^ failed to insert, but also increments this. Are we -- sure that's what we want? - Just a -> pure a + Right a -> pure a die :: (TypeRep -> GenerationFailure) -> m (Entity a) die e = throwIO $ e $ typeRep (Proxy :: Proxy a)