{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
module Graphula.Node
(
node
, nodeKeyed
, NodeOptions
, edit
, ensure
, GenerationFailure (..)
) where
import Prelude
import Control.Monad (guard, (<=<))
import Data.Proxy (Proxy (..))
import Data.Semigroup.Generic (gmappend, gmempty)
import Data.Traversable (for)
import Data.Typeable (TypeRep, Typeable, typeRep)
import Database.Persist (Entity (..), Key, PersistEntity, PersistEntityBackend)
import Database.Persist.Sql (SqlBackend)
import GHC.Generics (Generic)
import Graphula.Arbitrary
import Graphula.Class
import Graphula.Dependencies
import Test.QuickCheck (Arbitrary (..))
import UnliftIO (MonadIO)
import UnliftIO.Exception (Exception, throwIO)
newtype NodeOptions a = NodeOptions
{ forall a. NodeOptions a -> Kendo Maybe a
nodeOptionsEdit :: Kendo Maybe a
}
deriving stock (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (NodeOptions a) x -> NodeOptions a
forall a x. NodeOptions a -> Rep (NodeOptions a) x
$cto :: forall a x. Rep (NodeOptions a) x -> NodeOptions a
$cfrom :: forall a x. NodeOptions a -> Rep (NodeOptions a) x
Generic)
instance Semigroup (NodeOptions a) where
<> :: NodeOptions a -> NodeOptions a -> NodeOptions a
(<>) = forall a. (Generic a, GSemigroup (Rep a)) => a -> a -> a
gmappend
{-# INLINE (<>) #-}
instance Monoid (NodeOptions a) where
mempty :: NodeOptions a
mempty = forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
{-# INLINE mempty #-}
newtype Kendo m a = Kendo {forall (m :: * -> *) a. Kendo m a -> a -> m a
appKendo :: a -> m a}
deriving stock (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) a x. Rep (Kendo m a) x -> Kendo m a
forall (m :: * -> *) a x. Kendo m a -> Rep (Kendo m a) x
$cto :: forall (m :: * -> *) a x. Rep (Kendo m a) x -> Kendo m a
$cfrom :: forall (m :: * -> *) a x. Kendo m a -> Rep (Kendo m a) x
Generic)
instance Monad m => Semigroup (Kendo m a) where
Kendo a -> m a
f <> :: Kendo m a -> Kendo m a -> Kendo m a
<> Kendo a -> m a
g = forall (m :: * -> *) a. (a -> m a) -> Kendo m a
Kendo forall a b. (a -> b) -> a -> b
$ a -> m a
f forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< a -> m a
g
{-# INLINE (<>) #-}
instance Monad m => Monoid (Kendo m a) where
mempty :: Kendo m a
mempty = forall (m :: * -> *) a. (a -> m a) -> Kendo m a
Kendo forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE mempty #-}
edit :: (a -> a) -> NodeOptions a
edit :: forall a. (a -> a) -> NodeOptions a
edit a -> a
f = forall a. Monoid a => a
mempty {nodeOptionsEdit :: Kendo Maybe a
nodeOptionsEdit = forall (m :: * -> *) a. (a -> m a) -> Kendo m a
Kendo forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f}
ensure :: (a -> Bool) -> NodeOptions a
ensure :: forall a. (a -> Bool) -> NodeOptions a
ensure a -> Bool
f = forall a. Monoid a => a
mempty {nodeOptionsEdit :: Kendo Maybe a
nodeOptionsEdit = forall (m :: * -> *) a. (a -> m a) -> Kendo m a
Kendo forall a b. (a -> b) -> a -> b
$ \a
a -> a
a forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a -> Bool
f a
a)}
node
:: forall a m
. ( MonadGraphula m
, Logging m a
, Arbitrary a
, HasDependencies a
, GenerateKey a
, PersistEntityBackend a ~ SqlBackend
, PersistEntity a
, Typeable a
)
=> Dependencies a
-> NodeOptions a
-> m (Entity a)
node :: forall a (m :: * -> *).
(MonadGraphula m, Logging m a, Arbitrary a, HasDependencies a,
GenerateKey a, PersistEntityBackend a ~ SqlBackend,
PersistEntity a, Typeable a) =>
Dependencies a -> NodeOptions a -> m (Entity a)
node Dependencies a
dependencies NodeOptions {Kendo Maybe a
nodeOptionsEdit :: Kendo Maybe a
nodeOptionsEdit :: forall a. NodeOptions a -> Kendo Maybe a
..} =
let genKey :: m (KeySourceTypeInternalM (KeySource a) (Key a))
genKey = forall (m :: * -> *) a.
(MonadIO m, MonadGraphulaBackend m) =>
Gen a -> m a
generate forall a b. (a -> b) -> a -> b
$ forall (s :: KeySourceType) a.
(GenerateKeyInternal s a, KeyConstraint s a) =>
Gen (KeySourceTypeInternalM s (Key a))
generateKey @(KeySource a) @a
in forall a (m :: * -> *).
(MonadGraphula m, PersistEntityBackend a ~ SqlBackend,
PersistEntity a, GenerateKey a, Typeable a) =>
Int -> Int -> m (Maybe (KeyForInsert a, a)) -> m (Entity a)
attempt Int
100 Int
10 forall a b. (a -> b) -> a -> b
$ do
a
initial <- forall (m :: * -> *) a.
(MonadIO m, MonadGraphulaBackend m) =>
Gen a -> m a
generate forall a. Arbitrary a => Gen a
arbitrary
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall (m :: * -> *) a. Kendo m a -> a -> m a
appKendo Kendo Maybe a
nodeOptionsEdit a
initial) forall a b. (a -> b) -> a -> b
$ \a
edited -> do
let hydrated :: a
hydrated = a
edited forall a. HasDependencies a => a -> Dependencies a -> a
`dependsOn` Dependencies a
dependencies
forall (m :: * -> *) a.
(MonadGraphulaBackend m, Logging m a) =>
a -> m ()
logNode a
hydrated
KeySourceTypeInternalM (KeySource a) (Key a)
mKey <- m (KeySourceTypeInternalM (KeySource a) (Key a))
genKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeySourceTypeInternalM (KeySource a) (Key a)
mKey, a
hydrated)
attempt
:: forall a m
. ( MonadGraphula m
, PersistEntityBackend a ~ SqlBackend
, PersistEntity a
, GenerateKey a
, Typeable a
)
=> Int
-> Int
-> m (Maybe (KeyForInsert a, a))
-> m (Entity a)
attempt :: forall a (m :: * -> *).
(MonadGraphula m, PersistEntityBackend a ~ SqlBackend,
PersistEntity a, GenerateKey a, Typeable a) =>
Int -> Int -> m (Maybe (KeyForInsert a, a)) -> m (Entity a)
attempt Int
maxEdits Int
maxInserts m (Maybe (KeyForInsert a, a))
source = Int -> Int -> m (Entity a)
loop Int
0 Int
0
where
loop :: Int -> Int -> m (Entity a)
loop :: Int -> Int -> m (Entity a)
loop Int
numEdits Int
numInserts
| Int
numEdits forall a. Ord a => a -> a -> Bool
>= Int
maxEdits = forall a (m :: * -> *).
(MonadIO m, Typeable a) =>
(TypeRep -> GenerationFailure) -> m (Entity a)
die TypeRep -> GenerationFailure
GenerationFailureMaxAttemptsToConstrain
| Int
numInserts forall a. Ord a => a -> a -> Bool
>= Int
maxInserts = forall a (m :: * -> *).
(MonadIO m, Typeable a) =>
(TypeRep -> GenerationFailure) -> m (Entity a)
die TypeRep -> GenerationFailure
GenerationFailureMaxAttemptsToInsert
| Bool
otherwise =
m (Maybe (KeyForInsert a, a))
source forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (KeyForInsert a, a)
Nothing -> Int -> Int -> m (Entity a)
loop (forall a. Enum a => a -> a
succ Int
numEdits) Int
numInserts
Just (KeyForInsert a
mKey, a
value) ->
forall (requirement :: * -> *) record (m :: * -> *).
(InsertWithPossiblyRequiredKey requirement,
PersistEntityBackend record ~ SqlBackend, PersistEntity record,
Monad m, MonadGraphulaFrontend m,
InsertConstraint requirement record) =>
requirement (Key record) -> record -> m (Maybe (Entity record))
insertWithPossiblyRequiredKey KeyForInsert a
mKey a
value forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Entity a)
Nothing -> Int -> Int -> m (Entity a)
loop (forall a. Enum a => a -> a
succ Int
numEdits) (forall a. Enum a => a -> a
succ Int
numInserts)
Just Entity a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Entity a
a
nodeKeyed
:: forall a m
. ( MonadGraphula m
, Logging m a
, Arbitrary a
, HasDependencies a
, PersistEntityBackend a ~ SqlBackend
, PersistEntity a
, Typeable a
)
=> Key a
-> Dependencies a
-> NodeOptions a
-> m (Entity a)
nodeKeyed :: forall a (m :: * -> *).
(MonadGraphula m, Logging m a, Arbitrary a, HasDependencies a,
PersistEntityBackend a ~ SqlBackend, PersistEntity a,
Typeable a) =>
Key a -> Dependencies a -> NodeOptions a -> m (Entity a)
nodeKeyed Key a
key Dependencies a
dependencies NodeOptions {Kendo Maybe a
nodeOptionsEdit :: Kendo Maybe a
nodeOptionsEdit :: forall a. NodeOptions a -> Kendo Maybe a
..} =
forall a (m :: * -> *).
(MonadGraphula m, PersistEntityBackend a ~ SqlBackend,
PersistEntity a, Typeable a) =>
Int -> Int -> Key a -> m (Maybe a) -> m (Entity a)
attempt' Int
100 Int
10 Key a
key forall a b. (a -> b) -> a -> b
$ do
a
initial <- forall (m :: * -> *) a.
(MonadIO m, MonadGraphulaBackend m) =>
Gen a -> m a
generate forall a. Arbitrary a => Gen a
arbitrary
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall (m :: * -> *) a. Kendo m a -> a -> m a
appKendo Kendo Maybe a
nodeOptionsEdit a
initial) forall a b. (a -> b) -> a -> b
$ \a
edited -> do
let hydrated :: a
hydrated = a
edited forall a. HasDependencies a => a -> Dependencies a -> a
`dependsOn` Dependencies a
dependencies
forall (m :: * -> *) a.
(MonadGraphulaBackend m, Logging m a) =>
a -> m ()
logNode a
hydrated
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
hydrated
attempt'
:: forall a m
. ( MonadGraphula m
, PersistEntityBackend a ~ SqlBackend
, PersistEntity a
, Typeable a
)
=> Int
-> Int
-> Key a
-> m (Maybe a)
-> m (Entity a)
attempt' :: forall a (m :: * -> *).
(MonadGraphula m, PersistEntityBackend a ~ SqlBackend,
PersistEntity a, Typeable a) =>
Int -> Int -> Key a -> m (Maybe a) -> m (Entity a)
attempt' Int
maxEdits Int
maxInserts Key a
key m (Maybe a)
source = Int -> Int -> m (Entity a)
loop Int
0 Int
0
where
loop :: Int -> Int -> m (Entity a)
loop :: Int -> Int -> m (Entity a)
loop Int
numEdits Int
numInserts
| Int
numEdits forall a. Ord a => a -> a -> Bool
>= Int
maxEdits = forall a (m :: * -> *).
(MonadIO m, Typeable a) =>
(TypeRep -> GenerationFailure) -> m (Entity a)
die TypeRep -> GenerationFailure
GenerationFailureMaxAttemptsToConstrain
| Int
numInserts forall a. Ord a => a -> a -> Bool
>= Int
maxInserts = forall a (m :: * -> *).
(MonadIO m, Typeable a) =>
(TypeRep -> GenerationFailure) -> m (Entity a)
die TypeRep -> GenerationFailure
GenerationFailureMaxAttemptsToInsert
| Bool
otherwise =
m (Maybe a)
source forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe a
Nothing -> Int -> Int -> m (Entity a)
loop (forall a. Enum a => a -> a
succ Int
numEdits) Int
numInserts
Just a
value ->
forall (m :: * -> *) a.
(MonadGraphulaFrontend m, PersistEntityBackend a ~ SqlBackend,
PersistEntity a, Monad m) =>
Key a -> a -> m (Maybe (Entity a))
insertKeyed Key a
key a
value forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Entity a)
Nothing -> Int -> Int -> m (Entity a)
loop (forall a. Enum a => a -> a
succ Int
numEdits) (forall a. Enum a => a -> a
succ Int
numInserts)
Just Entity a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Entity a
a
die
:: forall a m
. (MonadIO m, Typeable a)
=> (TypeRep -> GenerationFailure)
-> m (Entity a)
die :: forall a (m :: * -> *).
(MonadIO m, Typeable a) =>
(TypeRep -> GenerationFailure) -> m (Entity a)
die TypeRep -> GenerationFailure
e = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ TypeRep -> GenerationFailure
e forall a b. (a -> b) -> a -> b
$ forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @a
data GenerationFailure
=
GenerationFailureMaxAttemptsToConstrain TypeRep
|
GenerationFailureMaxAttemptsToInsert TypeRep
deriving stock (Int -> GenerationFailure -> ShowS
[GenerationFailure] -> ShowS
GenerationFailure -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenerationFailure] -> ShowS
$cshowList :: [GenerationFailure] -> ShowS
show :: GenerationFailure -> String
$cshow :: GenerationFailure -> String
showsPrec :: Int -> GenerationFailure -> ShowS
$cshowsPrec :: Int -> GenerationFailure -> ShowS
Show, GenerationFailure -> GenerationFailure -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenerationFailure -> GenerationFailure -> Bool
$c/= :: GenerationFailure -> GenerationFailure -> Bool
== :: GenerationFailure -> GenerationFailure -> Bool
$c== :: GenerationFailure -> GenerationFailure -> Bool
Eq)
instance Exception GenerationFailure