lift inappropriate SafeToInsert constraints (#73)

CHANGELOG.md

@@ -1,6 +1,12 @@
-## [*Unreleased*](https://github.com/freckle/graphula/compare/v2.0.2.1...main)
+## [_Unreleased_](https://github.com/freckle/graphula/compare/v2.1.0.0...main)
 
-None
+## [v2.1.0.0](https://github.com/freckle/graphula/compare/v2.0.2.2...v2.1.0.0)
+
+- Some unnecessary `SafeToInsert` have been removed from `node` and `nodeKeyed`.
+  - `node` only requires `SafeToInsert` when the `KeySource` is `SourceDefault`,
+    not when the `KeySource` is `KeyArbitrary`.
+  - `nodeKeyed` no longer ever requires `SafeToInsert`
+- `MonadGraphulaFrontend` has a new `insertKeyed` method.
 
 ## [v2.0.2.2](https://github.com/freckle/graphula/compare/v2.0.2.1...v2.0.2.2)
 

graphula.cabal

@@ -4,10 +4,10 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: ca3c9631f0eb250d085bf4e69cf99d4cd5d82c6c7975a14ce18b57fc549575c5
+-- hash: 77f36204ab2afc392bf0f4eb7413aaf8ff36c25b86f28dde5747f3ed9121f0d4
 
 name:           graphula
-version:        2.0.2.2
+version:        2.1.0.0
 synopsis:       A simple interface for generating persistent data and linking its dependencies
 description:    Please see README.md
 category:       Network

package.yaml

@@ -1,12 +1,11 @@
 name: graphula
-version: 2.0.2.2
+version: 2.1.0.0
 maintainer: Freckle Education
 category: Network
 github: freckle/graphula
 synopsis: >-
   A simple interface for generating persistent data and linking its dependencies
 description: Please see README.md
-
 extra-source-files:
   - README.md
   - CHANGELOG.md

src/Graphula.hs

@@ -150,9 +150,9 @@ import Database.Persist
   , delete
   , get
   , getEntity
-  , insertKey
   , insertUnique
   )
+import qualified Database.Persist as Persist
 import Database.Persist.Sql (SqlBackend)
 import Graphula.Class
 import Graphula.Dependencies
@@ -223,9 +223,19 @@ instance (MonadIO m, MonadIO n) => MonadGraphulaFrontend (GraphulaT n m) where
         whenNothing existingKey $ do
           existingUnique <- checkUnique n
           whenNothing existingUnique $ do
-            insertKey key n
+            Persist.insertKey key n
             getEntity key
 
+  insertKeyed key n = do
+    RunDB runDB <- asks dbRunner
+    lift . runDB $ do
+      existingKey <- get key
+      whenNothing existingKey $ do
+        existingUnique <- checkUnique n
+        whenNothing existingUnique $ do
+          Persist.insertKey key n
+          getEntity key
+
   remove key = do
     RunDB runDB <- asks dbRunner
     lift . runDB $ delete key

src/Graphula/Class.hs

@@ -67,6 +67,15 @@ class MonadGraphulaFrontend m where
     -> a
     -> m (Maybe (Entity a))
 
+  insertKeyed
+    :: ( PersistEntityBackend a ~ SqlBackend
+       , PersistEntity a
+       , Monad m
+       )
+    => Key a
+    -> a
+    -> m (Maybe (Entity a))
+
   remove
     :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m)
     => Key a

src/Graphula/Dependencies.hs

@@ -24,18 +24,29 @@ module Graphula.Dependencies
 
     -- * Non-serial keys
   , KeySourceType (..)
+  , KeySourceTypeM
+  , KeyForInsert
+  , KeyRequirementForInsert
+  , InsertWithPossiblyRequiredKey (..)
+  , Required (..)
+  , Optional (..)
   , GenerateKey
   , generateKey
   ) where
 
 import Prelude
 
-import Data.Kind (Constraint)
+import Data.Kind (Constraint, Type)
 import Data.Proxy (Proxy (..))
-import Database.Persist (Key)
+import Database.Persist (Entity (..), Key, PersistEntity, PersistEntityBackend)
+import Database.Persist.Sql (SqlBackend)
 import GHC.Generics (Generic)
 import GHC.TypeLits (ErrorMessage (..), TypeError)
 import Generics.Eot (Eot, HasEot, fromEot, toEot)
+import Graphula.Class (GraphulaSafeToInsert, MonadGraphulaFrontend)
+import qualified Graphula.Class as MonadGraphulaFrontend
+  ( MonadGraphulaFrontend (..)
+  )
 import Graphula.Dependencies.Generic
 import Graphula.NoConstraint
 import Test.QuickCheck.Arbitrary (Arbitrary (..))
@@ -129,28 +140,85 @@ data KeySourceType
     -- See 'nodeKeyed'.
     SourceExternal
 
+newtype Required a = Required a
+
+newtype Optional a = Optional (Maybe a)
+
+-- | When a user of Graphula inserts, this wraps the key they provide.
+--   For 'SourceExternal' a key is required; for others it's optional.
+type family KeySourceTypeM (t :: KeySourceType) :: Type -> Type where
+  KeySourceTypeM 'SourceExternal = Required
+  KeySourceTypeM _ = Optional
+
+type KeyRequirementForInsert record = KeySourceTypeM (KeySource record)
+
+-- | When Graphula inserts into Persistent, this wraps the key is provides.
+--   For 'SourceDefault', a key is optional; for others it has always been
+--   generated.
+type family KeySourceTypeInternalM (t :: KeySourceType) :: Type -> Type where
+  KeySourceTypeInternalM 'SourceDefault = Optional
+  KeySourceTypeInternalM _ = Required
+
+type KeyRequirementForInsertInternal record =
+  KeySourceTypeInternalM (KeySource record)
+
+-- | When Graphula inserts into Persistent, this is the record's key.
+type KeyForInsert record = KeyRequirementForInsertInternal record (Key record)
+
+class InsertWithPossiblyRequiredKey (requirement :: Type -> Type) where
+  type InsertConstraint requirement :: Type -> Constraint
+  insertWithPossiblyRequiredKey
+    :: ( PersistEntityBackend record ~ SqlBackend
+       , PersistEntity record
+       , Monad m
+       , MonadGraphulaFrontend m
+       , InsertConstraint requirement record
+       )
+    => requirement (Key record)
+    -> record
+    -> m (Maybe (Entity record))
+  justKey :: key -> requirement key
+
+instance InsertWithPossiblyRequiredKey Optional where
+  type InsertConstraint Optional = GraphulaSafeToInsert
+  insertWithPossiblyRequiredKey (Optional key) = MonadGraphulaFrontend.insert key
+  justKey = Optional . Just
+
+instance InsertWithPossiblyRequiredKey Required where
+  type InsertConstraint Required = NoConstraint
+  insertWithPossiblyRequiredKey (Required key) = MonadGraphulaFrontend.insertKeyed key
+  justKey = Required
+
 -- | Abstract constraint that some @a@ can generate a key
 --
 -- This is part of ensuring better error messages.
 class
-  (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a) =>
+  ( GenerateKeyInternal (KeySource a) a
+  , KeyConstraint (KeySource a) a
+  , InsertWithPossiblyRequiredKey (KeySourceTypeInternalM (KeySource a))
+  , InsertConstraint (KeySourceTypeInternalM (KeySource a)) a
+  ) =>
   GenerateKey a
 
 instance
-  (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a)
+  ( GenerateKeyInternal (KeySource a) a
+  , KeyConstraint (KeySource a) a
+  , InsertWithPossiblyRequiredKey (KeySourceTypeInternalM (KeySource a))
+  , InsertConstraint (KeySourceTypeInternalM (KeySource a)) a
+  )
   => GenerateKey a
 
 class GenerateKeyInternal (s :: KeySourceType) a where
   type KeyConstraint s a :: Constraint
-  generateKey :: KeyConstraint s a => Gen (Maybe (Key a))
+  generateKey :: KeyConstraint s a => Gen (KeySourceTypeInternalM s (Key a))
 
 instance GenerateKeyInternal 'SourceDefault a where
-  type KeyConstraint 'SourceDefault a = NoConstraint a
-  generateKey = pure Nothing
+  type KeyConstraint 'SourceDefault a = GraphulaSafeToInsert a
+  generateKey = pure (Optional Nothing)
 
 instance GenerateKeyInternal 'SourceArbitrary a where
   type KeyConstraint 'SourceArbitrary a = Arbitrary (Key a)
-  generateKey = Just <$> arbitrary
+  generateKey = Required <$> arbitrary
 
 -- Rendered:
 --

src/Graphula/Idempotent.hs

@@ -61,6 +61,12 @@ instance
     for_ (entityKey <$> mEnt) $
       \key -> liftIO $ modifyIORef' finalizersRef (remove key >>)
     pure mEnt
+  insertKeyed key n = do
+    finalizersRef <- ask
+    mEnt <- lift $ insertKeyed key n
+    for_ (entityKey <$> mEnt) $
+      \key' -> liftIO $ modifyIORef' finalizersRef (remove key' >>)
+    pure mEnt
   remove = lift . remove
 
 runGraphulaIdempotentT :: MonadUnliftIO m => GraphulaIdempotentT m a -> m a

src/Graphula/Logged.hs

@@ -73,6 +73,7 @@ instance (MonadGraphulaBackend m, MonadIO m) => MonadGraphulaBackend (GraphulaLo
 
 instance (Monad m, MonadGraphulaFrontend m) => MonadGraphulaFrontend (GraphulaLoggedT m) where
   insert mKey = lift . insert mKey
+  insertKeyed key = lift . insertKeyed key
   remove = lift . remove
 
 -- | Run the graph while logging to a temporary file