{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoStarIsType #-}
{-# 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
  , insertKey
  , insertUnique
  )
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
  { Args backend n m -> RunDB backend n m
dbRunner :: RunDB 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 { GraphulaT n m a -> ReaderT (Args SqlBackend n m) m a
runGraphulaT' :: ReaderT (Args SqlBackend n m) m a }
  deriving newtype (a -> GraphulaT n m b -> GraphulaT n m a
(a -> b) -> GraphulaT n m a -> GraphulaT n m b
(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 :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (n :: Type -> Type) (m :: Type -> Type) a b.
Functor m =>
a -> GraphulaT n m b -> GraphulaT n m a
forall (n :: Type -> Type) (m :: Type -> Type) a b.
Functor m =>
(a -> b) -> GraphulaT n m a -> GraphulaT n m b
<$ :: a -> GraphulaT n m b -> GraphulaT n m a
$c<$ :: forall (n :: Type -> Type) (m :: Type -> Type) a b.
Functor m =>
a -> GraphulaT n m b -> GraphulaT n m a
fmap :: (a -> b) -> GraphulaT n m a -> GraphulaT n m b
$cfmap :: forall (n :: Type -> Type) (m :: Type -> Type) a b.
Functor m =>
(a -> b) -> GraphulaT n m a -> GraphulaT n m b
Functor, Functor (GraphulaT n m)
a -> GraphulaT n m a
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)
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m a
GraphulaT n m (a -> b) -> GraphulaT n m a -> GraphulaT n m b
(a -> b -> c)
-> GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m c
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 :: Type -> Type).
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 :: Type -> Type) (m :: Type -> Type).
Applicative m =>
Functor (GraphulaT n m)
forall (n :: Type -> Type) (m :: Type -> Type) a.
Applicative m =>
a -> GraphulaT n m a
forall (n :: Type -> Type) (m :: Type -> Type) a b.
Applicative m =>
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m a
forall (n :: Type -> Type) (m :: Type -> Type) a b.
Applicative m =>
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
forall (n :: Type -> Type) (m :: Type -> Type) a b.
Applicative m =>
GraphulaT n m (a -> b) -> GraphulaT n m a -> GraphulaT n m b
forall (n :: Type -> Type) (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> c)
-> GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m c
<* :: GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m a
$c<* :: forall (n :: Type -> Type) (m :: Type -> Type) a b.
Applicative m =>
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m a
*> :: GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
$c*> :: forall (n :: Type -> Type) (m :: Type -> Type) a b.
Applicative m =>
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
liftA2 :: (a -> b -> c)
-> GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m c
$cliftA2 :: forall (n :: Type -> Type) (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> c)
-> GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m c
<*> :: GraphulaT n m (a -> b) -> GraphulaT n m a -> GraphulaT n m b
$c<*> :: forall (n :: Type -> Type) (m :: Type -> Type) a b.
Applicative m =>
GraphulaT n m (a -> b) -> GraphulaT n m a -> GraphulaT n m b
pure :: a -> GraphulaT n m a
$cpure :: forall (n :: Type -> Type) (m :: Type -> Type) a.
Applicative m =>
a -> GraphulaT n m a
$cp1Applicative :: forall (n :: Type -> Type) (m :: Type -> Type).
Applicative m =>
Functor (GraphulaT n m)
Applicative, Applicative (GraphulaT n m)
a -> GraphulaT n m a
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)
GraphulaT n m a -> (a -> GraphulaT n m b) -> GraphulaT n m b
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
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 :: Type -> Type).
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 :: Type -> Type) (m :: Type -> Type).
Monad m =>
Applicative (GraphulaT n m)
forall (n :: Type -> Type) (m :: Type -> Type) a.
Monad m =>
a -> GraphulaT n m a
forall (n :: Type -> Type) (m :: Type -> Type) a b.
Monad m =>
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
forall (n :: Type -> Type) (m :: Type -> Type) a b.
Monad m =>
GraphulaT n m a -> (a -> GraphulaT n m b) -> GraphulaT n m b
return :: a -> GraphulaT n m a
$creturn :: forall (n :: Type -> Type) (m :: Type -> Type) a.
Monad m =>
a -> GraphulaT n m a
>> :: GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
$c>> :: forall (n :: Type -> Type) (m :: Type -> Type) a b.
Monad m =>
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
>>= :: GraphulaT n m a -> (a -> GraphulaT n m b) -> GraphulaT n m b
$c>>= :: forall (n :: Type -> Type) (m :: Type -> Type) a b.
Monad m =>
GraphulaT n m a -> (a -> GraphulaT n m b) -> GraphulaT n m b
$cp1Monad :: forall (n :: Type -> Type) (m :: Type -> Type).
Monad m =>
Applicative (GraphulaT n m)
Monad, Monad (GraphulaT n m)
Monad (GraphulaT n m)
-> (forall a. IO a -> GraphulaT n m a) -> MonadIO (GraphulaT n m)
IO a -> GraphulaT n m a
forall a. IO a -> GraphulaT n m a
forall (m :: Type -> Type).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (n :: Type -> Type) (m :: Type -> Type).
MonadIO m =>
Monad (GraphulaT n m)
forall (n :: Type -> Type) (m :: Type -> Type) a.
MonadIO m =>
IO a -> GraphulaT n m a
liftIO :: IO a -> GraphulaT n m a
$cliftIO :: forall (n :: Type -> Type) (m :: Type -> Type) a.
MonadIO m =>
IO a -> GraphulaT n m a
$cp1MonadIO :: forall (n :: Type -> Type) (m :: Type -> Type).
MonadIO m =>
Monad (GraphulaT n m)
MonadIO, MonadReader (Args SqlBackend n m))

instance MonadTrans (GraphulaT n) where
  lift :: m a -> GraphulaT n m a
lift = ReaderT (Args SqlBackend n m) m a -> GraphulaT n m a
forall (n :: Type -> Type) (m :: Type -> Type) 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 (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MonadUnliftIO m => MonadUnliftIO (GraphulaT n m) where
  {-# INLINE withRunInIO #-}
  withRunInIO :: ((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 :: Type -> Type) (m :: Type -> Type) 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 (m :: Type -> Type) 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 :: Type -> Type) (m :: Type -> Type) 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 :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks Args SqlBackend n m -> IORef QCGen
forall backend (n :: Type -> Type) (m :: Type -> Type).
Args backend n m -> IORef QCGen
gen
  logNode :: a -> GraphulaT n m ()
logNode a
_ = () -> GraphulaT n m ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()

instance (MonadIO m, Applicative n, MonadIO n) => MonadGraphulaFrontend (GraphulaT n m) where
  insert :: 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 :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks Args SqlBackend n m -> RunDB SqlBackend n m
forall backend (n :: Type -> Type) (m :: Type -> Type).
Args backend n m -> RunDB backend n m
dbRunner
    m (Maybe (Entity a)) -> GraphulaT n m (Maybe (Entity a))
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) 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 :: Type -> Type).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
record -> ReaderT backend 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 (m :: Type -> Type) 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 (f :: Type -> Type) 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 :: Type -> Type).
(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 :: Type -> Type).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key a
key
        Maybe a
-> ReaderT SqlBackend n (Maybe (Entity a))
-> ReaderT SqlBackend n (Maybe (Entity a))
forall (m :: Type -> Type) 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 :: Type -> Type).
(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 :: Type -> Type) 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 :: Type -> Type).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
insertKey Key a
key a
n
            Key a -> ReaderT SqlBackend n (Maybe (Entity a))
forall e backend (m :: Type -> Type).
(PersistStoreRead backend, PersistRecordBackend e backend,
 MonadIO m) =>
Key e -> ReaderT backend m (Maybe (Entity e))
getEntity Key a
key

  remove :: 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 :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks Args SqlBackend n m -> RunDB SqlBackend n m
forall backend (n :: Type -> Type) (m :: Type -> Type).
Args backend n m -> RunDB backend n m
dbRunner
    m () -> GraphulaT n m ()
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) 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 :: Type -> Type).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m ()
delete Key a
key

whenNothing :: Applicative m => Maybe a -> m (Maybe b) -> m (Maybe b)
whenNothing :: 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 (f :: Type -> Type) 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 :: 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 (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO Int
forall a (m :: Type -> Type). (Random a, MonadIO m) => m a
randomIO) Int -> m Int
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe Int
mSeed
  IORef QCGen
qcGen <- IO (IORef QCGen) -> m (IORef QCGen)
forall (m :: Type -> Type) 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 :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (GraphulaT n m a -> ReaderT (Args SqlBackend n m) m a
forall (n :: Type -> Type) (m :: Type -> Type) 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 :: Type -> Type) (m :: Type -> Type).
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 :: Type -> Type) (m :: Type -> Type).
(forall b. ReaderT backend n b -> m b) -> RunDB backend n m
RunDB forall b. ReaderT SqlBackend n b -> m b
runDB) IORef QCGen
qcGen)
    m a -> (HUnitFailure -> m a) -> m a
forall (m :: Type -> Type) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` Int -> HUnitFailure -> m a
forall (m :: Type -> Type) a.
MonadIO m =>
Int -> HUnitFailure -> m a
logFailingSeed Int
seed

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

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

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