{-# 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
  , 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
  { 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 -> 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
<$ :: forall a b. a -> GraphulaT n m b -> GraphulaT n m a
$c<$ :: forall (n :: * -> *) (m :: * -> *) a b.
Functor m =>
a -> GraphulaT n m b -> GraphulaT n m a
fmap :: forall a b. (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
Functor, 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
<* :: forall a b. GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m a
$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 b
$c*> :: forall (n :: * -> *) (m :: * -> *) a b.
Applicative m =>
GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m b
liftA2 :: forall a b c.
(a -> b -> c)
-> GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m c
$cliftA2 :: forall (n :: * -> *) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> GraphulaT n m a -> GraphulaT n m b -> GraphulaT n m c
<*> :: forall a b.
GraphulaT n m (a -> b) -> GraphulaT n m a -> GraphulaT n m b
$c<*> :: forall (n :: * -> *) (m :: * -> *) a b.
Applicative m =>
GraphulaT n m (a -> b) -> GraphulaT n m a -> GraphulaT n m b
pure :: forall a. a -> GraphulaT n m a
$cpure :: forall (n :: * -> *) (m :: * -> *) a.
Applicative m =>
a -> GraphulaT n m a
Applicative, 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
return :: forall a. a -> GraphulaT n m a
$creturn :: forall (n :: * -> *) (m :: * -> *) a.
Monad m =>
a -> GraphulaT n m a
>> :: forall a b. GraphulaT n m 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 -> (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
Monad, 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
liftIO :: forall a. IO a -> GraphulaT n m a
$cliftIO :: forall (n :: * -> *) (m :: * -> *) a.
MonadIO m =>
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 = forall (n :: * -> *) (m :: * -> *) a.
ReaderT (Args SqlBackend n m) m a -> GraphulaT n m a
GraphulaT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
    forall (n :: * -> *) (m :: * -> *) a.
ReaderT (Args SqlBackend n m) m a -> GraphulaT n m a
GraphulaT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO 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 b. (a -> b) -> a -> b
$ forall a. ReaderT (Args SqlBackend n m) m a -> IO a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks 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
_ = 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall backend (n :: * -> *) (m :: * -> *).
Args backend n m -> RunDB backend n m
dbRunner
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. ReaderT SqlBackend n b -> m b
runDB forall a b. (a -> b) -> a -> b
$ case Maybe (Key a)
mKey of
      Maybe (Key a)
Nothing -> forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Maybe (Key record))
insertUnique a
n forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (Key a)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just Key a
key -> 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 <- forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key a
key
        forall (m :: * -> *) a b.
Applicative m =>
Maybe a -> m (Maybe b) -> m (Maybe b)
whenNothing Maybe a
existingKey forall a b. (a -> b) -> a -> b
$ do
          Maybe (Unique a)
existingUnique <- forall record backend (m :: * -> *).
(MonadIO m, PersistRecordBackend record backend,
 PersistUniqueRead backend) =>
record -> ReaderT backend m (Maybe (Unique record))
checkUnique a
n
          forall (m :: * -> *) a b.
Applicative m =>
Maybe a -> m (Maybe b) -> m (Maybe b)
whenNothing Maybe (Unique a)
existingUnique forall a b. (a -> b) -> a -> b
$ do
            forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
insertKey Key a
key a
n
            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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall backend (n :: * -> *) (m :: * -> *).
Args backend n m -> RunDB backend n m
dbRunner
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. ReaderT SqlBackend n b -> m b
runDB forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(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 :: 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)
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO) forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
mSeed
  IORef QCGen
qcGen <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ Int -> QCGen
mkQCGen Int
seed
  forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (n :: * -> *) (m :: * -> *) a.
GraphulaT n m a -> ReaderT (Args SqlBackend n m) m a
runGraphulaT' GraphulaT n m a
action) (forall backend (n :: * -> *) (m :: * -> *).
RunDB backend n m -> IORef QCGen -> Args backend n m
Args (forall backend (n :: * -> *) (m :: * -> *).
(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)
    forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` 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 = forall (m :: * -> *) a. MonadIO m => [Char] -> HUnitFailure -> m a
rethrowHUnitWith ([Char]
"Graphula with seed: " forall a. [a] -> [a] -> [a]
++ 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) =
  forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SrcLoc -> FailureReason -> HUnitFailure
HUnitFailure Maybe SrcLoc
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FailureReason
Reason forall a b. (a -> b) -> a -> b
$ [Char]
message forall a. [a] -> [a] -> [a]
++ [Char]
"\n\n" 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
    )