{-# 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
  ( -- * Generating
    node
  , nodeKeyed

    -- * 'NodeOptions'
  , NodeOptions
  , edit
  , ensure

    -- * Exceptions
  , 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)

-- | Options for generating an individual node
--
--
-- 'NodeOptions' can be created and combined with the Monoidal operations '(<>)'
-- and 'mempty'.
--
-- > a1 <- node @A () mempty
-- > a2 <- node @A () $ edit $ \a -> a { someField = True }
-- > a3 <- node @A () $ ensure $ (== True) . someField
--
-- The Semigroup orders the operations from right to left. For example,
-- @'edit' z <> 'ensure' y <> 'edit' x@ first performs @'edit' x@, then fails if
-- the value does not satisfy assertion @y@, then performs @'edit' z@.
newtype NodeOptions a = NodeOptions
  { forall a. 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
$cfrom :: forall a x. NodeOptions a -> Rep (NodeOptions a) x
from :: forall x. NodeOptions a -> Rep (NodeOptions a) x
$cto :: forall a x. Rep (NodeOptions a) x -> NodeOptions a
to :: forall x. Rep (NodeOptions a) x -> NodeOptions a
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 #-}

-- | Like @'Endo'@ but uses Kliesli composition
newtype Kendo m a = Kendo {forall (m :: * -> *) a. 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
$cfrom :: forall (m :: * -> *) a x. Kendo m a -> Rep (Kendo m a) x
from :: forall x. Kendo m a -> Rep (Kendo m a) x
$cto :: forall (m :: * -> *) a x. Rep (Kendo m a) x -> Kendo m a
to :: forall x. Rep (Kendo m a) x -> Kendo m a
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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE mempty #-}

-- | Modify the node after it's been generated
--
-- > a <- node @A () $ edit $ \a -> a { someField = True }
edit :: (a -> a) -> NodeOptions a
edit :: forall a. (a -> a) -> NodeOptions a
edit a -> a
f = NodeOptions Any
forall a. Monoid a => a
mempty {nodeOptionsEdit = Kendo $ Just . f}

-- | Require a node to satisfy the specified predicate
--
-- > a <- node @A () $ ensure $ (== True) . someField
--
-- N.B. ensuring a condition that is infrequently met can be innefficient.
ensure :: (a -> Bool) -> NodeOptions a
ensure :: forall a. (a -> Bool) -> NodeOptions a
ensure a -> Bool
f = NodeOptions Any
forall a. Monoid a => a
mempty {nodeOptionsEdit = Kendo $ \a
a -> a
a a -> Maybe () -> Maybe a
forall a b. a -> Maybe b -> 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)}

-- | Generate a node with a default (Arbitrary or database-provided) key
--
-- > a <- node @A () mempty
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 :: forall a. NodeOptions a -> Kendo Maybe a
nodeOptionsEdit :: Kendo Maybe a
..} =
  let genKey :: m (KeySourceTypeInternalM (KeySource a) (Key a))
genKey = Gen (KeySourceTypeInternalM (KeySource a) (Key a))
-> m (KeySourceTypeInternalM (KeySource a) (Key a))
forall (m :: * -> *) a.
(MonadIO m, MonadGraphulaBackend m) =>
Gen a -> m a
generate (Gen (KeySourceTypeInternalM (KeySource a) (Key a))
 -> m (KeySourceTypeInternalM (KeySource a) (Key a)))
-> Gen (KeySourceTypeInternalM (KeySource a) (Key a))
-> m (KeySourceTypeInternalM (KeySource a) (Key a))
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  Int
-> Int
-> m (Maybe (KeySourceTypeInternalM (KeySource a) (Key a), a))
-> m (Entity a)
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 (m (Maybe (KeySourceTypeInternalM (KeySource a) (Key a), a))
 -> m (Entity a))
-> m (Maybe (KeySourceTypeInternalM (KeySource a) (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 (KeySourceTypeInternalM (KeySource a) (Key a), a))
-> m (Maybe (KeySourceTypeInternalM (KeySource a) (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 (KeySourceTypeInternalM (KeySource a) (Key a), a))
 -> m (Maybe (KeySourceTypeInternalM (KeySource a) (Key a), a)))
-> (a -> m (KeySourceTypeInternalM (KeySource a) (Key a), a))
-> m (Maybe (KeySourceTypeInternalM (KeySource a) (Key a), a))
forall a b. (a -> b) -> a -> b
$ \a
edited -> do
          -- N.B. dependencies setting always overrules edits
          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 a. Logging m a => a -> m ()
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
          (KeySourceTypeInternalM (KeySource a) (Key a), a)
-> m (KeySourceTypeInternalM (KeySource a) (Key a), a)
forall a. a -> m a
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxEdits = (TypeRep -> GenerationFailure) -> m (Entity a)
forall a (m :: * -> *).
(MonadIO m, Typeable a) =>
(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)
forall a (m :: * -> *).
(MonadIO m, Typeable a) =>
(TypeRep -> GenerationFailure) -> m (Entity a)
die TypeRep -> GenerationFailure
GenerationFailureMaxAttemptsToInsert
    | Bool
otherwise =
        m (Maybe (KeyForInsert a, a))
source m (Maybe (KeyForInsert a, a))
-> (Maybe (KeyForInsert a, a) -> m (Entity a)) -> m (Entity a)
forall a b. m a -> (a -> m b) -> m b
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 (Int -> Int
forall a. Enum a => a -> a
succ Int
numEdits) Int
numInserts
          --               ^ failed to edit, only increments this
          Just (KeyForInsert a
mKey, a
value) ->
            KeyForInsert a -> a -> m (Maybe (Entity a))
forall record (m :: * -> *).
(PersistEntityBackend record ~ SqlBackend, PersistEntity record,
 Monad m, MonadGraphulaFrontend m,
 InsertConstraint (KeySourceTypeInternalM (KeySource a)) record) =>
KeySourceTypeInternalM (KeySource a) (Key record)
-> record -> m (Maybe (Entity record))
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 m (Maybe (Entity a))
-> (Maybe (Entity a) -> m (Entity a)) -> m (Entity a)
forall a b. m a -> (a -> m b) -> m b
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)
              --               ^ failed to insert, but also increments this. Are we
              --                 sure that's what we want?
              Just Entity a
a -> Entity a -> m (Entity a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Entity a
a

-- | Generate a node with an explictly-given key
--
-- > let someKey = UUID.fromString "..."
-- > a <- nodeKeyed @A someKey () mempty
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 :: forall a. NodeOptions a -> Kendo Maybe a
nodeOptionsEdit :: Kendo Maybe a
..} =
  Int -> Int -> Key a -> m (Maybe a) -> m (Entity 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 (m (Maybe a) -> m (Entity a)) -> m (Maybe 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 a) -> m (Maybe 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 a) -> m (Maybe a)) -> (a -> m a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \a
edited -> do
      -- N.B. dependencies setting always overrules edits
      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 a. Logging m a => a -> m ()
forall (m :: * -> *) a.
(MonadGraphulaBackend m, Logging m a) =>
a -> m ()
logNode a
hydrated
      a -> m a
forall a. a -> m a
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxEdits = (TypeRep -> GenerationFailure) -> m (Entity a)
forall a (m :: * -> *).
(MonadIO m, Typeable a) =>
(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)
forall a (m :: * -> *).
(MonadIO m, Typeable a) =>
(TypeRep -> GenerationFailure) -> m (Entity a)
die TypeRep -> GenerationFailure
GenerationFailureMaxAttemptsToInsert
    | Bool
otherwise =
        m (Maybe a)
source m (Maybe a) -> (Maybe a -> m (Entity a)) -> m (Entity a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe a
Nothing -> Int -> Int -> m (Entity a)
loop (Int -> Int
forall a. Enum a => a -> a
succ Int
numEdits) Int
numInserts
          --               ^ failed to edit, only increments this
          Just a
value ->
            Key a -> a -> m (Maybe (Entity a))
forall a.
(PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m) =>
Key a -> a -> m (Maybe (Entity a))
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 m (Maybe (Entity a))
-> (Maybe (Entity a) -> m (Entity a)) -> m (Entity a)
forall a b. m a -> (a -> m b) -> m b
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)
              --               ^ failed to insert, but also increments this. Are we
              --                 sure that's what we want?
              Just Entity a
a -> Entity a -> m (Entity a)
forall a. a -> m 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 = 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 -> TypeRep) -> Proxy a -> TypeRep
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a

data GenerationFailure
  = -- | Could not satisfy constraints defined using 'ensure'
    GenerationFailureMaxAttemptsToConstrain TypeRep
  | -- | Could not satisfy database constraints on 'insert'
    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
$cshowsPrec :: Int -> GenerationFailure -> ShowS
showsPrec :: Int -> GenerationFailure -> ShowS
$cshow :: GenerationFailure -> String
show :: GenerationFailure -> String
$cshowList :: [GenerationFailure] -> ShowS
showList :: [GenerationFailure] -> ShowS
Show, GenerationFailure -> GenerationFailure -> Bool
(GenerationFailure -> GenerationFailure -> Bool)
-> (GenerationFailure -> GenerationFailure -> Bool)
-> Eq GenerationFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GenerationFailure -> GenerationFailure -> Bool
== :: GenerationFailure -> GenerationFailure -> Bool
$c/= :: GenerationFailure -> GenerationFailure -> Bool
/= :: GenerationFailure -> GenerationFailure -> Bool
Eq)

instance Exception GenerationFailure