{-# 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
  (
  -- * 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.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
--
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 #-}

-- | 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 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 #-}

-- | 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 = 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 }

-- | 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 = 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) }

-- | Generate a node with a default (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
     , GraphulaSafeToInsert 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, GraphulaSafeToInsert a) =>
Dependencies a -> NodeOptions a -> m (Entity a)
node = 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 forall a b. (a -> b) -> a -> b
$ 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 (Maybe (Key a))
generateKey @(KeySource 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
     , GraphulaSafeToInsert 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,
 GraphulaSafeToInsert a) =>
Key a -> Dependencies a -> NodeOptions a -> m (Entity a)
nodeKeyed Key a
key = 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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 :: 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))
genKey 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, GraphulaSafeToInsert a) =>
Int -> Int -> m (Maybe (Maybe (Key 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
    -- N.B. dependencies setting always overrules edits
    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
    Maybe (Key a)
mKey <- m (Maybe (Key a))
genKey
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Key a)
mKey, a
hydrated)

data GenerationFailure
  = GenerationFailureMaxAttemptsToConstrain TypeRep
  -- ^ Could not satisfy constraints defined using 'ensure'
  | GenerationFailureMaxAttemptsToInsert TypeRep
  -- ^ Could not satisfy database constraints on 'insert'
  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

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 :: 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
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 forall a. Ord a => a -> a -> Bool
>= Int
maxEdits = (TypeRep -> GenerationFailure) -> m (Entity a)
die TypeRep -> GenerationFailure
GenerationFailureMaxAttemptsToConstrain
    | Int
numInserts 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 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 (forall a. Enum a => a -> a
succ Int
numEdits) Int
numInserts
      --               ^ failed to edit, only increments this
      Just (Maybe (Key a)
mKey, a
value) -> 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 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)
        --               ^ failed to insert, but also increments this. Are we
        --                 sure that's what we want?
        Just Entity a
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 = 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 {k} (t :: k). Proxy t
Proxy :: Proxy a)