{-# 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 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.Exception (Exception, throwIO)
newtype NodeOptions a = NodeOptions
{ NodeOptions a -> Kendo Maybe a
nodeOptionsEdit :: Kendo Maybe a
}
deriving stock (forall x. NodeOptions a -> Rep (NodeOptions a) x)
-> (forall x. Rep (NodeOptions a) x -> NodeOptions a)
-> Generic (NodeOptions a)
forall x. Rep (NodeOptions a) x -> NodeOptions a
forall x. NodeOptions a -> Rep (NodeOptions a) x
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
(<>) = 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 = NodeOptions a
forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
{-# INLINE mempty #-}
newtype Kendo m a = Kendo { Kendo m a -> a -> m a
appKendo :: a -> m a }
deriving stock (forall x. Kendo m a -> Rep (Kendo m a) x)
-> (forall x. Rep (Kendo m a) x -> Kendo m a)
-> Generic (Kendo m a)
forall x. Rep (Kendo m a) x -> Kendo m a
forall x. Kendo m a -> Rep (Kendo m a) x
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 = (a -> m a) -> Kendo m a
forall (m :: * -> *) a. (a -> m a) -> Kendo m a
Kendo ((a -> m a) -> Kendo m a) -> (a -> m a) -> Kendo m a
forall a b. (a -> b) -> a -> b
$ a -> m a
f (a -> m a) -> (a -> m a) -> a -> m a
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 = (a -> m a) -> Kendo m a
forall (m :: * -> *) a. (a -> m a) -> Kendo m a
Kendo a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE mempty #-}
edit :: (a -> a) -> NodeOptions a
edit :: (a -> a) -> NodeOptions a
edit a -> a
f = NodeOptions Any
forall a. Monoid a => a
mempty { nodeOptionsEdit :: Kendo Maybe a
nodeOptionsEdit = (a -> Maybe a) -> Kendo Maybe a
forall (m :: * -> *) a. (a -> m a) -> Kendo m a
Kendo ((a -> Maybe a) -> Kendo Maybe a)
-> (a -> Maybe a) -> Kendo Maybe a
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (a -> a) -> a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f }
ensure :: (a -> Bool) -> NodeOptions a
ensure :: (a -> Bool) -> NodeOptions a
ensure a -> Bool
f = NodeOptions Any
forall a. Monoid a => a
mempty { nodeOptionsEdit :: Kendo Maybe a
nodeOptionsEdit = (a -> Maybe a) -> Kendo Maybe a
forall (m :: * -> *) a. (a -> m a) -> Kendo m a
Kendo ((a -> Maybe a) -> Kendo Maybe a)
-> (a -> Maybe a) -> Kendo Maybe a
forall a b. (a -> b) -> a -> b
$ \a
a -> a
a a -> Maybe () -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
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
, GraphulaSafeToInsert a
)
=> Dependencies a
-> NodeOptions a
-> m (Entity a)
node :: Dependencies a -> NodeOptions a -> m (Entity a)
node = m (Maybe (Key a))
-> Dependencies a -> NodeOptions a -> m (Entity a)
forall a (m :: * -> *).
(MonadGraphula m, Logging m a, Arbitrary a, HasDependencies a,
PersistEntityBackend a ~ SqlBackend, PersistEntity a, Typeable a,
GraphulaSafeToInsert a) =>
m (Maybe (Key a))
-> Dependencies a -> NodeOptions a -> m (Entity a)
nodeImpl (m (Maybe (Key a))
-> Dependencies a -> NodeOptions a -> m (Entity a))
-> m (Maybe (Key a))
-> Dependencies a
-> NodeOptions a
-> m (Entity a)
forall a b. (a -> b) -> a -> b
$ Gen (Maybe (Key a)) -> m (Maybe (Key a))
forall (m :: * -> *) a.
(MonadIO m, MonadGraphulaBackend m) =>
Gen a -> m a
generate (Gen (Maybe (Key a)) -> m (Maybe (Key a)))
-> Gen (Maybe (Key a)) -> m (Maybe (Key a))
forall a b. (a -> b) -> a -> b
$ (GenerateKeyInternal (KeySource a) a,
KeyConstraint (KeySource a) a) =>
Gen (Maybe (Key a))
forall (s :: KeySourceType) a.
(GenerateKeyInternal s a, KeyConstraint s a) =>
Gen (Maybe (Key a))
generateKey @(KeySource a) @a
nodeKeyed
:: forall a m
. ( MonadGraphula m
, Logging m a
, Arbitrary a
, HasDependencies a
, PersistEntityBackend a ~ SqlBackend
, PersistEntity a
, Typeable a
, GraphulaSafeToInsert a
)
=> Key a
-> Dependencies a
-> NodeOptions a
-> m (Entity a)
nodeKeyed :: Key a -> Dependencies a -> NodeOptions a -> m (Entity a)
nodeKeyed Key a
key = m (Maybe (Key a))
-> Dependencies a -> NodeOptions a -> m (Entity a)
forall a (m :: * -> *).
(MonadGraphula m, Logging m a, Arbitrary a, HasDependencies a,
PersistEntityBackend a ~ SqlBackend, PersistEntity a, Typeable a,
GraphulaSafeToInsert a) =>
m (Maybe (Key a))
-> Dependencies a -> NodeOptions a -> m (Entity a)
nodeImpl (m (Maybe (Key a))
-> Dependencies a -> NodeOptions a -> m (Entity a))
-> m (Maybe (Key a))
-> Dependencies a
-> NodeOptions a
-> m (Entity a)
forall a b. (a -> b) -> a -> b
$ Maybe (Key a) -> m (Maybe (Key a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Key a) -> m (Maybe (Key a)))
-> Maybe (Key a) -> m (Maybe (Key a))
forall a b. (a -> b) -> a -> b
$ Key a -> Maybe (Key a)
forall a. a -> Maybe a
Just Key a
key
nodeImpl
:: forall a m
. ( MonadGraphula m
, Logging m a
, Arbitrary a
, HasDependencies a
, PersistEntityBackend a ~ SqlBackend
, PersistEntity a
, Typeable a
, GraphulaSafeToInsert a
)
=> m (Maybe (Key a))
-> Dependencies a
-> NodeOptions a
-> m (Entity a)
nodeImpl :: m (Maybe (Key a))
-> Dependencies a -> NodeOptions a -> m (Entity a)
nodeImpl m (Maybe (Key a))
genKey Dependencies a
dependencies NodeOptions {Kendo Maybe a
nodeOptionsEdit :: Kendo Maybe a
nodeOptionsEdit :: forall a. NodeOptions a -> Kendo Maybe a
..} = Int -> Int -> m (Maybe (Maybe (Key a), a)) -> m (Entity a)
forall a (m :: * -> *).
(MonadGraphula m, PersistEntityBackend a ~ SqlBackend,
PersistEntity a, Typeable a, GraphulaSafeToInsert a) =>
Int -> Int -> m (Maybe (Maybe (Key a), a)) -> m (Entity a)
attempt Int
100 Int
10 (m (Maybe (Maybe (Key a), a)) -> m (Entity a))
-> m (Maybe (Maybe (Key a), a)) -> m (Entity a)
forall a b. (a -> b) -> a -> b
$ do
a
initial <- Gen a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadGraphulaBackend m) =>
Gen a -> m a
generate Gen a
forall a. Arbitrary a => Gen a
arbitrary
Maybe a
-> (a -> m (Maybe (Key a), a)) -> m (Maybe (Maybe (Key a), a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Kendo Maybe a -> a -> Maybe a
forall (m :: * -> *) a. Kendo m a -> a -> m a
appKendo Kendo Maybe a
nodeOptionsEdit a
initial) ((a -> m (Maybe (Key a), a)) -> m (Maybe (Maybe (Key a), a)))
-> (a -> m (Maybe (Key a), a)) -> m (Maybe (Maybe (Key a), a))
forall a b. (a -> b) -> a -> b
$ \a
edited -> do
let hydrated :: a
hydrated = a
edited a -> Dependencies a -> a
forall a. HasDependencies a => a -> Dependencies a -> a
`dependsOn` Dependencies a
dependencies
a -> m ()
forall (m :: * -> *) a.
(MonadGraphulaBackend m, Logging m a) =>
a -> m ()
logNode a
hydrated
Maybe (Key a)
mKey <- m (Maybe (Key a))
genKey
(Maybe (Key a), a) -> m (Maybe (Key a), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Key a)
mKey, a
hydrated)
data GenerationFailure
= GenerationFailureMaxAttemptsToConstrain TypeRep
| GenerationFailureMaxAttemptsToInsert TypeRep
deriving stock (Int -> GenerationFailure -> ShowS
[GenerationFailure] -> ShowS
GenerationFailure -> String
(Int -> GenerationFailure -> ShowS)
-> (GenerationFailure -> String)
-> ([GenerationFailure] -> ShowS)
-> Show GenerationFailure
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
(GenerationFailure -> GenerationFailure -> Bool)
-> (GenerationFailure -> GenerationFailure -> Bool)
-> Eq GenerationFailure
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
attempt
:: forall a m
. ( MonadGraphula m
, PersistEntityBackend a ~ SqlBackend
, PersistEntity a
, Typeable a
, GraphulaSafeToInsert a
)
=> Int
-> Int
-> m (Maybe (Maybe (Key a), a))
-> m (Entity a)
attempt :: Int -> Int -> m (Maybe (Maybe (Key a), a)) -> m (Entity a)
attempt Int
maxEdits Int
maxInserts m (Maybe (Maybe (Key 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxEdits = (TypeRep -> GenerationFailure) -> m (Entity a)
die TypeRep -> GenerationFailure
GenerationFailureMaxAttemptsToConstrain
| Int
numInserts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxInserts = (TypeRep -> GenerationFailure) -> m (Entity a)
die TypeRep -> GenerationFailure
GenerationFailureMaxAttemptsToInsert
| Bool
otherwise = m (Maybe (Maybe (Key a), a))
source m (Maybe (Maybe (Key a), a))
-> (Maybe (Maybe (Key a), a) -> m (Entity a)) -> m (Entity a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Maybe (Key a), a)
Nothing -> Int -> Int -> m (Entity a)
loop (Int -> Int
forall a. Enum a => a -> a
succ Int
numEdits) Int
numInserts
Just (Maybe (Key a)
mKey, a
value) -> Maybe (Key a) -> a -> m (Maybe (Entity a))
forall (m :: * -> *) a.
(MonadGraphulaFrontend m, PersistEntityBackend a ~ SqlBackend,
PersistEntity a, Monad m, GraphulaSafeToInsert a) =>
Maybe (Key a) -> a -> m (Maybe (Entity a))
insert Maybe (Key a)
mKey a
value m (Maybe (Entity a))
-> (Maybe (Entity a) -> m (Entity a)) -> m (Entity a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Entity a)
Nothing -> Int -> Int -> m (Entity a)
loop (Int -> Int
forall a. Enum a => a -> a
succ Int
numEdits) (Int -> Int
forall a. Enum a => a -> a
succ Int
numInserts)
Just Entity a
a -> Entity a -> m (Entity a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Entity a
a
die :: (TypeRep -> GenerationFailure) -> m (Entity a)
die :: (TypeRep -> GenerationFailure) -> m (Entity a)
die TypeRep -> GenerationFailure
e = GenerationFailure -> m (Entity a)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (GenerationFailure -> m (Entity a))
-> GenerationFailure -> m (Entity a)
forall a b. (a -> b) -> a -> b
$ TypeRep -> GenerationFailure
e (TypeRep -> GenerationFailure) -> TypeRep -> GenerationFailure
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)