{-# 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
, 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)
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
-> (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
)