{-# 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 #-}
module Graphula
(
HasDependencies (..)
, Only (..)
, only
, node
, edit
, ensure
, GraphulaT
, runGraphulaT
, GenerationFailure (..)
, KeySourceType (..)
, nodeKeyed
, GraphulaLoggedT
, runGraphulaLoggedT
, runGraphulaLoggedWithFileT
, GraphulaIdempotentT
, runGraphulaIdempotentT
, GraphulaContext
, GraphulaNode
, 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)
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 ()
Persist.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
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 <- 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
$ 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 ()
Persist.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
-> (forall b. ReaderT SqlBackend n b -> m b)
-> 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
)