{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

-- |
--
-- Graphula is a compact interface for generating data and linking its
-- dependencies. You can use this interface to generate fixtures for automated
-- testing.
--
-- @
-- {- 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
  ( -- * Basic usage

    -- ** Model requirements
    HasDependencies (..)
  , Only (..)
  , only

    -- ** 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

    -- ** Running idempotently
  , GraphulaIdempotentT
  , runGraphulaIdempotentT

    -- * Useful synonymns

    -- |
    --
    -- When declaring your own functions that call 'node', these synonyms can help
    -- with the constraint soup.
    --
    -- > genSchoolWithTeacher
    -- >   :: GraphulaContext m '[School, Teacher]
    -- >   -> m (Entity Teacher)
    -- > genSchoolWithTeacher = do
    -- >   school <- node @School () mempty
    -- >   node @Teacher (onlyKey school) mempty
  , 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
  ) where

import Prelude hiding (readFile)

import Control.Monad.IO.Unlift
import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT)
import Control.Monad.Trans (MonadTrans, lift)
import Data.IORef (IORef, newIORef)
import Data.Kind (Constraint, Type)
import Data.Typeable (Typeable)
import Database.Persist
  ( PersistEntity
  , PersistEntityBackend
  , checkUnique
  , delete
  , get
  , getEntity
  , insertUnique
  )
import qualified Database.Persist as Persist
import Database.Persist.Sql (SqlBackend)
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 (catch, throwIO)

-- | A constraint over lists of nodes for 'MonadGraphula', and 'GraphulaNode'.
--
-- Helpful for defining utility functions over many nodes.
--
-- @
-- mkABC :: (GraphulaContext m '[A, B, C]) => m (Node m C)
-- mkABC = do
--   a <- node @A () mempty
--   b <- node @B (only a) mempty
--   node @C (a, b) $ edit $ \n ->
--     n { cc = "spanish" }
-- @
type family GraphulaContext (m :: Type -> Type) (ts :: [Type]) :: Constraint where
  GraphulaContext m '[] = MonadGraphula m
  GraphulaContext m (t ': ts) = (GraphulaNode m t, GraphulaContext m ts)

data Args backend n m = Args
  { forall backend (n :: * -> *) (m :: * -> *).
Args backend n m -> RunDB backend n m
dbRunner :: RunDB backend n m
  , forall backend (n :: * -> *) (m :: * -> *).
Args backend n m -> IORef QCGen
gen :: IORef QCGen
  }

newtype RunDB backend n m = RunDB (forall b. ReaderT backend n b -> m b)

newtype GraphulaT n m a = GraphulaT {forall (n :: * -> *) (m :: * -> *) a.
GraphulaT n m a -> ReaderT (Args SqlBackend n m) m a
runGraphulaT' :: ReaderT (Args SqlBackend n m) m a}
  deriving newtype
    ((forall a b. (a -> b) -> GraphulaT n m a -> GraphulaT n m b)
-> (forall a b. a -> GraphulaT n m b -> GraphulaT n m a)
-> Functor (GraphulaT n m)
forall a b. a -> GraphulaT n m b -> GraphulaT n m a
forall a b. (a -> b) -> GraphulaT n m a -> GraphulaT n m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (n :: * -> *) (m :: * -> *) a b.
Functor m =>
a -> GraphulaT n m b -> GraphulaT n m a
forall (n :: * -> *) (m :: * -> *) a b.
Functor m =>
(a -> b) -> GraphulaT n m a -> GraphulaT n m b
$cfmap :: forall (n :: * -> *) (m :: * -> *) a b.
Functor m =>
(a -> b) -> GraphulaT n m a -> GraphulaT n m b
fmap :: forall a b. (a -> b) -> GraphulaT n m a -> GraphulaT n m b
$c<$ :: forall (n :: * -> *) (m :: * -> *) a b.
Functor m =>
a -> GraphulaT n m b -> GraphulaT n m a
<$ :: forall a b. a -> GraphulaT n m b -> GraphulaT n m a
Functor, Functor (GraphulaT n m)
Functor (GraphulaT n m) =>
(forall a. a -> GraphulaT n m a)
-> (forall a b.
    GraphulaT n m (a -> b) -> GraphulaT n m a -> GraphulaT n m b)
-> (forall a b c.
    (a -> b -> c)
    -> GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m c)
-> (forall a b.
    GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b)
-> (forall a b.
    GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m a)
-> Applicative (GraphulaT n m)
forall a. a -> GraphulaT n m a
forall a b. GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m a
forall a b. GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
forall a b.
GraphulaT n m (a -> b) -> GraphulaT n m a -> GraphulaT n m b
forall a b c.
(a -> b -> c)
-> GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (n :: * -> *) (m :: * -> *).
Applicative m =>
Functor (GraphulaT n m)
forall (n :: * -> *) (m :: * -> *) a.
Applicative m =>
a -> GraphulaT n m a
forall (n :: * -> *) (m :: * -> *) a b.
Applicative m =>
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m a
forall (n :: * -> *) (m :: * -> *) a b.
Applicative m =>
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
forall (n :: * -> *) (m :: * -> *) a b.
Applicative m =>
GraphulaT n m (a -> b) -> GraphulaT n m a -> GraphulaT n m b
forall (n :: * -> *) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m c
$cpure :: forall (n :: * -> *) (m :: * -> *) a.
Applicative m =>
a -> GraphulaT n m a
pure :: forall a. a -> GraphulaT n m a
$c<*> :: forall (n :: * -> *) (m :: * -> *) a b.
Applicative m =>
GraphulaT n m (a -> b) -> GraphulaT n m a -> GraphulaT n m b
<*> :: forall a b.
GraphulaT n m (a -> b) -> GraphulaT n m a -> GraphulaT n m b
$cliftA2 :: forall (n :: * -> *) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m c
liftA2 :: forall a b c.
(a -> b -> c)
-> GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m c
$c*> :: forall (n :: * -> *) (m :: * -> *) a b.
Applicative m =>
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
*> :: forall a b. GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
$c<* :: forall (n :: * -> *) (m :: * -> *) a b.
Applicative m =>
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m a
<* :: forall a b. GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m a
Applicative, Applicative (GraphulaT n m)
Applicative (GraphulaT n m) =>
(forall a b.
 GraphulaT n m a -> (a -> GraphulaT n m b) -> GraphulaT n m b)
-> (forall a b.
    GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b)
-> (forall a. a -> GraphulaT n m a)
-> Monad (GraphulaT n m)
forall a. a -> GraphulaT n m a
forall a b. GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
forall a b.
GraphulaT n m a -> (a -> GraphulaT n m b) -> GraphulaT n m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (n :: * -> *) (m :: * -> *).
Monad m =>
Applicative (GraphulaT n m)
forall (n :: * -> *) (m :: * -> *) a.
Monad m =>
a -> GraphulaT n m a
forall (n :: * -> *) (m :: * -> *) a b.
Monad m =>
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
forall (n :: * -> *) (m :: * -> *) a b.
Monad m =>
GraphulaT n m a -> (a -> GraphulaT n m b) -> GraphulaT n m b
$c>>= :: forall (n :: * -> *) (m :: * -> *) a b.
Monad m =>
GraphulaT n m a -> (a -> GraphulaT n m b) -> GraphulaT n m b
>>= :: forall a b.
GraphulaT n m a -> (a -> GraphulaT n m b) -> GraphulaT n m b
$c>> :: forall (n :: * -> *) (m :: * -> *) a b.
Monad m =>
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
>> :: forall a b. GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
$creturn :: forall (n :: * -> *) (m :: * -> *) a.
Monad m =>
a -> GraphulaT n m a
return :: forall a. a -> GraphulaT n m a
Monad, Monad (GraphulaT n m)
Monad (GraphulaT n m) =>
(forall a. IO a -> GraphulaT n m a) -> MonadIO (GraphulaT n m)
forall a. IO a -> GraphulaT n m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (n :: * -> *) (m :: * -> *).
MonadIO m =>
Monad (GraphulaT n m)
forall (n :: * -> *) (m :: * -> *) a.
MonadIO m =>
IO a -> GraphulaT n m a
$cliftIO :: forall (n :: * -> *) (m :: * -> *) a.
MonadIO m =>
IO a -> GraphulaT n m a
liftIO :: forall a. IO a -> GraphulaT n m a
MonadIO, MonadReader (Args SqlBackend n m))

instance MonadTrans (GraphulaT n) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> GraphulaT n m a
lift = ReaderT (Args SqlBackend n m) m a -> GraphulaT n m a
forall (n :: * -> *) (m :: * -> *) a.
ReaderT (Args SqlBackend n m) m a -> GraphulaT n m a
GraphulaT (ReaderT (Args SqlBackend n m) m a -> GraphulaT n m a)
-> (m a -> ReaderT (Args SqlBackend n m) m a)
-> m a
-> GraphulaT n m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT (Args SqlBackend n m) m a
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (Args SqlBackend n m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MonadUnliftIO m => MonadUnliftIO (GraphulaT n m) where
  {-# INLINE withRunInIO #-}
  withRunInIO :: forall b.
((forall a. GraphulaT n m a -> IO a) -> IO b) -> GraphulaT n m b
withRunInIO (forall a. GraphulaT n m a -> IO a) -> IO b
inner =
    ReaderT (Args SqlBackend n m) m b -> GraphulaT n m b
forall (n :: * -> *) (m :: * -> *) a.
ReaderT (Args SqlBackend n m) m a -> GraphulaT n m a
GraphulaT (ReaderT (Args SqlBackend n m) m b -> GraphulaT n m b)
-> ReaderT (Args SqlBackend n m) m b -> GraphulaT n m b
forall a b. (a -> b) -> a -> b
$ ((forall a. ReaderT (Args SqlBackend n m) m a -> IO a) -> IO b)
-> ReaderT (Args SqlBackend n m) m b
forall b.
((forall a. ReaderT (Args SqlBackend n m) m a -> IO a) -> IO b)
-> ReaderT (Args SqlBackend n m) m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. ReaderT (Args SqlBackend n m) m a -> IO a) -> IO b)
 -> ReaderT (Args SqlBackend n m) m b)
-> ((forall a. ReaderT (Args SqlBackend n m) m a -> IO a) -> IO b)
-> ReaderT (Args SqlBackend n m) m b
forall a b. (a -> b) -> a -> b
$ \forall a. ReaderT (Args SqlBackend n m) m a -> IO a
run -> (forall a. GraphulaT n m a -> IO a) -> IO b
inner ((forall a. GraphulaT n m a -> IO a) -> IO b)
-> (forall a. GraphulaT n m a -> IO a) -> IO b
forall a b. (a -> b) -> a -> b
$ ReaderT (Args SqlBackend n m) m a -> IO a
forall a. ReaderT (Args SqlBackend n m) m a -> IO a
run (ReaderT (Args SqlBackend n m) m a -> IO a)
-> (GraphulaT n m a -> ReaderT (Args SqlBackend n m) m a)
-> GraphulaT n m a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GraphulaT n m a -> ReaderT (Args SqlBackend n m) m a
forall (n :: * -> *) (m :: * -> *) a.
GraphulaT n m a -> ReaderT (Args SqlBackend n m) m a
runGraphulaT'

instance MonadIO m => MonadGraphulaBackend (GraphulaT n m) where
  type Logging (GraphulaT n m) = NoConstraint
  askGen :: GraphulaT n m (IORef QCGen)
askGen = (Args SqlBackend n m -> IORef QCGen) -> GraphulaT n m (IORef QCGen)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Args SqlBackend n m -> IORef QCGen
forall backend (n :: * -> *) (m :: * -> *).
Args backend n m -> IORef QCGen
gen
  logNode :: forall a. Logging (GraphulaT n m) a => a -> GraphulaT n m ()
logNode a
_ = () -> GraphulaT n m ()
forall a. a -> GraphulaT n m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance (MonadIO m, MonadIO n) => MonadGraphulaFrontend (GraphulaT n m) where
  insert :: forall a.
(PersistEntityBackend a ~ SqlBackend, PersistEntity a,
 Monad (GraphulaT n m), GraphulaSafeToInsert a) =>
Maybe (Key a) -> a -> GraphulaT n m (Maybe (Entity a))
insert Maybe (Key a)
mKey a
n = do
    RunDB forall b. ReaderT SqlBackend n b -> m b
runDB <- (Args SqlBackend n m -> RunDB SqlBackend n m)
-> GraphulaT n m (RunDB SqlBackend n m)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Args SqlBackend n m -> RunDB SqlBackend n m
forall backend (n :: * -> *) (m :: * -> *).
Args backend n m -> RunDB backend n m
dbRunner
    m (Maybe (Entity a)) -> GraphulaT n m (Maybe (Entity a))
forall (m :: * -> *) a. Monad m => m a -> GraphulaT n m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (Entity a)) -> GraphulaT n m (Maybe (Entity a)))
-> (ReaderT SqlBackend n (Maybe (Entity a))
    -> m (Maybe (Entity a)))
-> ReaderT SqlBackend n (Maybe (Entity a))
-> GraphulaT n m (Maybe (Entity a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend n (Maybe (Entity a)) -> m (Maybe (Entity a))
forall b. ReaderT SqlBackend n b -> m b
runDB (ReaderT SqlBackend n (Maybe (Entity a))
 -> GraphulaT n m (Maybe (Entity a)))
-> ReaderT SqlBackend n (Maybe (Entity a))
-> GraphulaT n m (Maybe (Entity a))
forall a b. (a -> b) -> a -> b
$ case Maybe (Key a)
mKey of
      Maybe (Key a)
Nothing ->
        a -> ReaderT SqlBackend n (Maybe (Key a))
forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Maybe (Key record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend m (Maybe (Key record))
insertUnique a
n ReaderT SqlBackend n (Maybe (Key a))
-> (Maybe (Key a) -> ReaderT SqlBackend n (Maybe (Entity a)))
-> ReaderT SqlBackend n (Maybe (Entity a))
forall a b.
ReaderT SqlBackend n a
-> (a -> ReaderT SqlBackend n b) -> ReaderT SqlBackend n b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe (Key a)
Nothing -> Maybe (Entity a) -> ReaderT SqlBackend n (Maybe (Entity a))
forall a. a -> ReaderT SqlBackend n a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Entity a)
forall a. Maybe a
Nothing
          Just Key a
key -> Key a -> ReaderT SqlBackend n (Maybe (Entity a))
forall e backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend e backend,
 MonadIO m) =>
Key e -> ReaderT backend m (Maybe (Entity e))
getEntity Key a
key
      Just Key a
key -> do
        Maybe a
existingKey <- Key a -> ReaderT SqlBackend n (Maybe a)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> ReaderT SqlBackend m (Maybe record)
get Key a
key
        Maybe a
-> ReaderT SqlBackend n (Maybe (Entity a))
-> ReaderT SqlBackend n (Maybe (Entity a))
forall (m :: * -> *) a b.
Applicative m =>
Maybe a -> m (Maybe b) -> m (Maybe b)
whenNothing Maybe a
existingKey (ReaderT SqlBackend n (Maybe (Entity a))
 -> ReaderT SqlBackend n (Maybe (Entity a)))
-> ReaderT SqlBackend n (Maybe (Entity a))
-> ReaderT SqlBackend n (Maybe (Entity a))
forall a b. (a -> b) -> a -> b
$ do
          Maybe (Unique a)
existingUnique <- a -> ReaderT SqlBackend n (Maybe (Unique a))
forall record backend (m :: * -> *).
(MonadIO m, PersistRecordBackend record backend,
 PersistUniqueRead backend) =>
record -> ReaderT backend m (Maybe (Unique record))
checkUnique a
n
          Maybe (Unique a)
-> ReaderT SqlBackend n (Maybe (Entity a))
-> ReaderT SqlBackend n (Maybe (Entity a))
forall (m :: * -> *) a b.
Applicative m =>
Maybe a -> m (Maybe b) -> m (Maybe b)
whenNothing Maybe (Unique a)
existingUnique (ReaderT SqlBackend n (Maybe (Entity a))
 -> ReaderT SqlBackend n (Maybe (Entity a)))
-> ReaderT SqlBackend n (Maybe (Entity a))
-> ReaderT SqlBackend n (Maybe (Entity a))
forall a b. (a -> b) -> a -> b
$ do
            Key a -> a -> ReaderT SqlBackend n ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> record -> ReaderT SqlBackend m ()
Persist.insertKey Key a
key a
n
            Key a -> ReaderT SqlBackend n (Maybe (Entity a))
forall e backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend e backend,
 MonadIO m) =>
Key e -> ReaderT backend m (Maybe (Entity e))
getEntity Key a
key

  insertKeyed :: forall a.
(PersistEntityBackend a ~ SqlBackend, PersistEntity a,
 Monad (GraphulaT n m)) =>
Key a -> a -> GraphulaT n m (Maybe (Entity a))
insertKeyed Key a
key a
n = do
    RunDB forall b. ReaderT SqlBackend n b -> m b
runDB <- (Args SqlBackend n m -> RunDB SqlBackend n m)
-> GraphulaT n m (RunDB SqlBackend n m)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Args SqlBackend n m -> RunDB SqlBackend n m
forall backend (n :: * -> *) (m :: * -> *).
Args backend n m -> RunDB backend n m
dbRunner
    m (Maybe (Entity a)) -> GraphulaT n m (Maybe (Entity a))
forall (m :: * -> *) a. Monad m => m a -> GraphulaT n m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (Entity a)) -> GraphulaT n m (Maybe (Entity a)))
-> (ReaderT SqlBackend n (Maybe (Entity a))
    -> m (Maybe (Entity a)))
-> ReaderT SqlBackend n (Maybe (Entity a))
-> GraphulaT n m (Maybe (Entity a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend n (Maybe (Entity a)) -> m (Maybe (Entity a))
forall b. ReaderT SqlBackend n b -> m b
runDB (ReaderT SqlBackend n (Maybe (Entity a))
 -> GraphulaT n m (Maybe (Entity a)))
-> ReaderT SqlBackend n (Maybe (Entity a))
-> GraphulaT n m (Maybe (Entity a))
forall a b. (a -> b) -> a -> b
$ do
      Maybe a
existingKey <- Key a -> ReaderT SqlBackend n (Maybe a)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> ReaderT SqlBackend m (Maybe record)
get Key a
key
      Maybe a
-> ReaderT SqlBackend n (Maybe (Entity a))
-> ReaderT SqlBackend n (Maybe (Entity a))
forall (m :: * -> *) a b.
Applicative m =>
Maybe a -> m (Maybe b) -> m (Maybe b)
whenNothing Maybe a
existingKey (ReaderT SqlBackend n (Maybe (Entity a))
 -> ReaderT SqlBackend n (Maybe (Entity a)))
-> ReaderT SqlBackend n (Maybe (Entity a))
-> ReaderT SqlBackend n (Maybe (Entity a))
forall a b. (a -> b) -> a -> b
$ do
        Maybe (Unique a)
existingUnique <- a -> ReaderT SqlBackend n (Maybe (Unique a))
forall record backend (m :: * -> *).
(MonadIO m, PersistRecordBackend record backend,
 PersistUniqueRead backend) =>
record -> ReaderT backend m (Maybe (Unique record))
checkUnique a
n
        Maybe (Unique a)
-> ReaderT SqlBackend n (Maybe (Entity a))
-> ReaderT SqlBackend n (Maybe (Entity a))
forall (m :: * -> *) a b.
Applicative m =>
Maybe a -> m (Maybe b) -> m (Maybe b)
whenNothing Maybe (Unique a)
existingUnique (ReaderT SqlBackend n (Maybe (Entity a))
 -> ReaderT SqlBackend n (Maybe (Entity a)))
-> ReaderT SqlBackend n (Maybe (Entity a))
-> ReaderT SqlBackend n (Maybe (Entity a))
forall a b. (a -> b) -> a -> b
$ do
          Key a -> a -> ReaderT SqlBackend n ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> record -> ReaderT SqlBackend m ()
Persist.insertKey Key a
key a
n
          Key a -> ReaderT SqlBackend n (Maybe (Entity a))
forall e backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend e backend,
 MonadIO m) =>
Key e -> ReaderT backend m (Maybe (Entity e))
getEntity Key a
key

  remove :: forall a.
(PersistEntityBackend a ~ SqlBackend, PersistEntity a,
 Monad (GraphulaT n m)) =>
Key a -> GraphulaT n m ()
remove Key a
key = do
    RunDB forall b. ReaderT SqlBackend n b -> m b
runDB <- (Args SqlBackend n m -> RunDB SqlBackend n m)
-> GraphulaT n m (RunDB SqlBackend n m)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Args SqlBackend n m -> RunDB SqlBackend n m
forall backend (n :: * -> *) (m :: * -> *).
Args backend n m -> RunDB backend n m
dbRunner
    m () -> GraphulaT n m ()
forall (m :: * -> *) a. Monad m => m a -> GraphulaT n m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> GraphulaT n m ())
-> (ReaderT SqlBackend n () -> m ())
-> ReaderT SqlBackend n ()
-> GraphulaT n m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend n () -> m ()
forall b. ReaderT SqlBackend n b -> m b
runDB (ReaderT SqlBackend n () -> GraphulaT n m ())
-> ReaderT SqlBackend n () -> GraphulaT n m ()
forall a b. (a -> b) -> a -> b
$ Key a -> ReaderT SqlBackend n ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> ReaderT SqlBackend m ()
delete Key a
key

whenNothing :: Applicative m => Maybe a -> m (Maybe b) -> m (Maybe b)
whenNothing :: forall (m :: * -> *) a b.
Applicative m =>
Maybe a -> m (Maybe b) -> m (Maybe b)
whenNothing Maybe a
Nothing m (Maybe b)
f = m (Maybe b)
f
whenNothing (Just a
_) m (Maybe b)
_ = Maybe b -> m (Maybe b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe b
forall a. Maybe a
Nothing

runGraphulaT
  :: MonadUnliftIO m
  => Maybe Int
  -- ^ Optional seed
  -> (forall b. ReaderT SqlBackend n b -> m b)
  -- ^ Database runner
  -> GraphulaT n m a
  -> m a
runGraphulaT :: forall (m :: * -> *) (n :: * -> *) a.
MonadUnliftIO m =>
Maybe Int
-> (forall b. ReaderT SqlBackend n b -> m b)
-> GraphulaT n m a
-> m a
runGraphulaT Maybe Int
mSeed forall b. ReaderT SqlBackend n b -> m b
runDB GraphulaT n m a
action = do
  Int
seed <- m Int -> (Int -> m Int) -> Maybe Int -> m Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO) Int -> m Int
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
mSeed
  IORef QCGen
qcGen <- IO (IORef QCGen) -> m (IORef QCGen)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef QCGen) -> m (IORef QCGen))
-> IO (IORef QCGen) -> m (IORef QCGen)
forall a b. (a -> b) -> a -> b
$ QCGen -> IO (IORef QCGen)
forall a. a -> IO (IORef a)
newIORef (QCGen -> IO (IORef QCGen)) -> QCGen -> IO (IORef QCGen)
forall a b. (a -> b) -> a -> b
$ Int -> QCGen
mkQCGen Int
seed
  ReaderT (Args SqlBackend n m) m a -> Args SqlBackend n m -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (GraphulaT n m a -> ReaderT (Args SqlBackend n m) m a
forall (n :: * -> *) (m :: * -> *) a.
GraphulaT n m a -> ReaderT (Args SqlBackend n m) m a
runGraphulaT' GraphulaT n m a
action) (RunDB SqlBackend n m -> IORef QCGen -> Args SqlBackend n m
forall backend (n :: * -> *) (m :: * -> *).
RunDB backend n m -> IORef QCGen -> Args backend n m
Args ((forall b. ReaderT SqlBackend n b -> m b) -> RunDB SqlBackend n m
forall backend (n :: * -> *) (m :: * -> *).
(forall b. ReaderT backend n b -> m b) -> RunDB backend n m
RunDB ReaderT SqlBackend n b -> m b
forall b. ReaderT SqlBackend n b -> m b
runDB) IORef QCGen
qcGen)
    m a -> (HUnitFailure -> m a) -> m a
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` Int -> HUnitFailure -> m a
forall (m :: * -> *) a. MonadIO m => Int -> HUnitFailure -> m a
logFailingSeed Int
seed

logFailingSeed :: MonadIO m => Int -> HUnitFailure -> m a
logFailingSeed :: forall (m :: * -> *) a. MonadIO m => Int -> HUnitFailure -> m a
logFailingSeed Int
seed = [Char] -> HUnitFailure -> m a
forall (m :: * -> *) a. MonadIO m => [Char] -> HUnitFailure -> m a
rethrowHUnitWith ([Char]
"Graphula with seed: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
seed)

rethrowHUnitWith :: MonadIO m => String -> HUnitFailure -> m a
rethrowHUnitWith :: forall (m :: * -> *) a. MonadIO m => [Char] -> HUnitFailure -> m a
rethrowHUnitWith [Char]
message (HUnitFailure Maybe SrcLoc
l FailureReason
r) =
  HUnitFailure -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (HUnitFailure -> m a) -> ([Char] -> HUnitFailure) -> [Char] -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SrcLoc -> FailureReason -> HUnitFailure
HUnitFailure Maybe SrcLoc
l (FailureReason -> HUnitFailure)
-> ([Char] -> FailureReason) -> [Char] -> HUnitFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FailureReason
Reason ([Char] -> m a) -> [Char] -> m a
forall a b. (a -> b) -> a -> b
$ [Char]
message [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FailureReason -> [Char]
formatFailureReason FailureReason
r

type GraphulaNode m a =
  ( HasDependencies a
  , Logging m a
  , PersistEntityBackend a ~ SqlBackend
  , PersistEntity a
  , Typeable a
  , Arbitrary a
  )