{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Graphula.Dependencies
  ( HasDependencies (..)
  , Only (..)
  , only

    -- * Non-serial keys
  , KeySourceType (..)
  , KeySourceTypeM
  , KeyForInsert
  , KeyRequirementForInsert
  , InsertWithPossiblyRequiredKey (..)
  , Required (..)
  , Optional (..)
  , GenerateKey
  , generateKey
  ) where

import Prelude

import Data.Kind (Constraint, Type)
import Data.Proxy (Proxy (..))
import Database.Persist (Entity (..), Key, PersistEntity, PersistEntityBackend)
import Database.Persist.Sql (SqlBackend)
import GHC.Generics (Generic)
import GHC.TypeLits (ErrorMessage (..), TypeError)
import Generics.Eot (Eot, HasEot, fromEot, toEot)
import Graphula.Class (GraphulaSafeToInsert, MonadGraphulaFrontend)
import qualified Graphula.Class as MonadGraphulaFrontend
  ( MonadGraphulaFrontend (..)
  )
import Graphula.Dependencies.Generic
import Graphula.NoConstraint
import Test.QuickCheck.Arbitrary (Arbitrary (..))
import Test.QuickCheck.Gen (Gen)

class HasDependencies a where
  -- | A data type declaring the model's dependencies
  --
  -- Models with no dependencies can declare an empty instance,
  --
  -- @
  -- instance 'HasDependencies' School
  -- @
  --
  -- Models with one dependency must use the 'Only' 1-tuple constructor,
  --
  -- @
  -- instance 'HasDependencies' Teacher where
  --   type Dependencies Teacher = Only SchoolId
  -- @
  --
  -- Models with multiple dependencies use tuple syntax,
  --
  -- @
  -- instance 'HasDependencies' Course where
  --   type Dependencies Course = (SchoolId, TeacherId)
  -- @
  type Dependencies a

  type Dependencies _a = ()

  -- | Specify the method for resolving a node's key
  --
  -- This can be
  --
  -- @
  -- 'SourceDefault   -- automatically generate keys from the database
  -- 'SourceArbitrary -- automatically generate keys using @'Arbitrary'@
  -- 'SourceExternal  -- explicitly pass a key using @'nodeKeyed'@
  -- @
  --
  -- Most types will use 'SourceDefault' or 'SourceArbitrary'. Only use
  -- 'SourceExternal' if the key for a value is always defined externally.
  type KeySource a :: KeySourceType

  type KeySource _a = 'SourceDefault

  -- | Assign values from the 'Dependencies' collection to a value
  --
  -- This must be an idempotent operation. Law:
  --
  -- prop> (\x d -> x `dependsOn` d `dependsOn` d) = dependsOn
  --
  -- The default, 'Generic'-based implementation will assign values by the order
  -- of the fields in the model's type.
  dependsOn :: a -> Dependencies a -> a
  default dependsOn
    :: ( HasEot a
       , HasEot (Dependencies a)
       , GHasDependencies
          (Proxy a)
          (Proxy (Dependencies a))
          (Eot a)
          (Eot (Dependencies a))
       )
    => a
    -> Dependencies a
    -> a
  dependsOn a
a Dependencies a
dependencies =
    forall a. HasEot a => Eot a -> a
fromEot forall a b. (a -> b) -> a -> b
$
      forall nodeTyProxy depsTyProxy node deps.
GHasDependencies nodeTyProxy depsTyProxy node deps =>
nodeTyProxy -> depsTyProxy -> node -> deps -> node
genericDependsOn
        (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
        (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Dependencies a))
        (forall a. HasEot a => a -> Eot a
toEot a
a)
        (forall a. HasEot a => a -> Eot a
toEot Dependencies a
dependencies)

-- | For entities that only have singular 'Dependencies'
newtype Only a = Only {forall a. Only a -> a
fromOnly :: a}
  deriving stock (Only a -> Only a -> Bool
forall a. Eq a => Only a -> Only a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Only a -> Only a -> Bool
$c/= :: forall a. Eq a => Only a -> Only a -> Bool
== :: Only a -> Only a -> Bool
$c== :: forall a. Eq a => Only a -> Only a -> Bool
Eq, Int -> Only a -> ShowS
forall a. Show a => Int -> Only a -> ShowS
forall a. Show a => [Only a] -> ShowS
forall a. Show a => Only a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Only a] -> ShowS
$cshowList :: forall a. Show a => [Only a] -> ShowS
show :: Only a -> String
$cshow :: forall a. Show a => Only a -> String
showsPrec :: Int -> Only a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Only a -> ShowS
Show, Only a -> Only a -> Bool
Only a -> Only a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Only a)
forall a. Ord a => Only a -> Only a -> Bool
forall a. Ord a => Only a -> Only a -> Ordering
forall a. Ord a => Only a -> Only a -> Only a
min :: Only a -> Only a -> Only a
$cmin :: forall a. Ord a => Only a -> Only a -> Only a
max :: Only a -> Only a -> Only a
$cmax :: forall a. Ord a => Only a -> Only a -> Only a
>= :: Only a -> Only a -> Bool
$c>= :: forall a. Ord a => Only a -> Only a -> Bool
> :: Only a -> Only a -> Bool
$c> :: forall a. Ord a => Only a -> Only a -> Bool
<= :: Only a -> Only a -> Bool
$c<= :: forall a. Ord a => Only a -> Only a -> Bool
< :: Only a -> Only a -> Bool
$c< :: forall a. Ord a => Only a -> Only a -> Bool
compare :: Only a -> Only a -> Ordering
$ccompare :: forall a. Ord a => Only a -> Only a -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Only a) x -> Only a
forall a x. Only a -> Rep (Only a) x
$cto :: forall a x. Rep (Only a) x -> Only a
$cfrom :: forall a x. Only a -> Rep (Only a) x
Generic, forall a b. a -> Only b -> Only a
forall a b. (a -> b) -> Only a -> Only b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Only b -> Only a
$c<$ :: forall a b. a -> Only b -> Only a
fmap :: forall a b. (a -> b) -> Only a -> Only b
$cfmap :: forall a b. (a -> b) -> Only a -> Only b
Functor, forall a. Eq a => a -> Only a -> Bool
forall a. Num a => Only a -> a
forall a. Ord a => Only a -> a
forall m. Monoid m => Only m -> m
forall a. Only a -> Bool
forall a. Only a -> Int
forall a. Only a -> [a]
forall a. (a -> a -> a) -> Only a -> a
forall m a. Monoid m => (a -> m) -> Only a -> m
forall b a. (b -> a -> b) -> b -> Only a -> b
forall a b. (a -> b -> b) -> b -> Only a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Only a -> a
$cproduct :: forall a. Num a => Only a -> a
sum :: forall a. Num a => Only a -> a
$csum :: forall a. Num a => Only a -> a
minimum :: forall a. Ord a => Only a -> a
$cminimum :: forall a. Ord a => Only a -> a
maximum :: forall a. Ord a => Only a -> a
$cmaximum :: forall a. Ord a => Only a -> a
elem :: forall a. Eq a => a -> Only a -> Bool
$celem :: forall a. Eq a => a -> Only a -> Bool
length :: forall a. Only a -> Int
$clength :: forall a. Only a -> Int
null :: forall a. Only a -> Bool
$cnull :: forall a. Only a -> Bool
toList :: forall a. Only a -> [a]
$ctoList :: forall a. Only a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Only a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Only a -> a
foldr1 :: forall a. (a -> a -> a) -> Only a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Only a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Only a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Only a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Only a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Only a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Only a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Only a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Only a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Only a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Only a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Only a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Only a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Only a -> m
fold :: forall m. Monoid m => Only m -> m
$cfold :: forall m. Monoid m => Only m -> m
Foldable, Functor Only
Foldable Only
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Only (m a) -> m (Only a)
forall (f :: * -> *) a. Applicative f => Only (f a) -> f (Only a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Only a -> m (Only b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Only a -> f (Only b)
sequence :: forall (m :: * -> *) a. Monad m => Only (m a) -> m (Only a)
$csequence :: forall (m :: * -> *) a. Monad m => Only (m a) -> m (Only a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Only a -> m (Only b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Only a -> m (Only b)
sequenceA :: forall (f :: * -> *) a. Applicative f => Only (f a) -> f (Only a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Only (f a) -> f (Only a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Only a -> f (Only b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Only a -> f (Only b)
Traversable)

only :: a -> Only a
only :: forall a. a -> Only a
only = forall a. a -> Only a
Only

data KeySourceType
  = -- | Generate keys using the database's @DEFAULT@ strategy
    SourceDefault
  | -- | Generate keys using the 'Arbitrary' instance for the 'Key'
    SourceArbitrary
  | -- | Always explicitly pass an external key
    --
    -- See 'nodeKeyed'.
    SourceExternal

newtype Required a = Required a

newtype Optional a = Optional (Maybe a)

-- | When a user of Graphula inserts, this wraps the key they provide.
--   For 'SourceExternal' a key is required; for others it's optional.
type family KeySourceTypeM (t :: KeySourceType) :: Type -> Type where
  KeySourceTypeM 'SourceExternal = Required
  KeySourceTypeM _ = Optional

type KeyRequirementForInsert record = KeySourceTypeM (KeySource record)

-- | When Graphula inserts into Persistent, this wraps the key is provides.
--   For 'SourceDefault', a key is optional; for others it has always been
--   generated.
type family KeySourceTypeInternalM (t :: KeySourceType) :: Type -> Type where
  KeySourceTypeInternalM 'SourceDefault = Optional
  KeySourceTypeInternalM _ = Required

type KeyRequirementForInsertInternal record =
  KeySourceTypeInternalM (KeySource record)

-- | When Graphula inserts into Persistent, this is the record's key.
type KeyForInsert record = KeyRequirementForInsertInternal record (Key record)

class InsertWithPossiblyRequiredKey (requirement :: Type -> Type) where
  type InsertConstraint requirement :: Type -> Constraint
  insertWithPossiblyRequiredKey
    :: ( PersistEntityBackend record ~ SqlBackend
       , PersistEntity record
       , Monad m
       , MonadGraphulaFrontend m
       , InsertConstraint requirement record
       )
    => requirement (Key record)
    -> record
    -> m (Maybe (Entity record))
  justKey :: key -> requirement key

instance InsertWithPossiblyRequiredKey Optional where
  type InsertConstraint Optional = GraphulaSafeToInsert
  insertWithPossiblyRequiredKey :: forall record (m :: * -> *).
(PersistEntityBackend record ~ SqlBackend, PersistEntity record,
 Monad m, MonadGraphulaFrontend m,
 InsertConstraint Optional record) =>
Optional (Key record) -> record -> m (Maybe (Entity record))
insertWithPossiblyRequiredKey (Optional Maybe (Key record)
key) = forall (m :: * -> *) a.
(MonadGraphulaFrontend m, PersistEntityBackend a ~ SqlBackend,
 PersistEntity a, Monad m, GraphulaSafeToInsert a) =>
Maybe (Key a) -> a -> m (Maybe (Entity a))
MonadGraphulaFrontend.insert Maybe (Key record)
key
  justKey :: forall key. key -> Optional key
justKey = forall a. Maybe a -> Optional a
Optional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just

instance InsertWithPossiblyRequiredKey Required where
  type InsertConstraint Required = NoConstraint
  insertWithPossiblyRequiredKey :: forall record (m :: * -> *).
(PersistEntityBackend record ~ SqlBackend, PersistEntity record,
 Monad m, MonadGraphulaFrontend m,
 InsertConstraint Required record) =>
Required (Key record) -> record -> m (Maybe (Entity record))
insertWithPossiblyRequiredKey (Required Key record
key) = forall (m :: * -> *) a.
(MonadGraphulaFrontend m, PersistEntityBackend a ~ SqlBackend,
 PersistEntity a, Monad m) =>
Key a -> a -> m (Maybe (Entity a))
MonadGraphulaFrontend.insertKeyed Key record
key
  justKey :: forall key. key -> Required key
justKey = forall key. key -> Required key
Required

-- | Abstract constraint that some @a@ can generate a key
--
-- This is part of ensuring better error messages.
class
  ( GenerateKeyInternal (KeySource a) a
  , KeyConstraint (KeySource a) a
  , InsertWithPossiblyRequiredKey (KeySourceTypeInternalM (KeySource a))
  , InsertConstraint (KeySourceTypeInternalM (KeySource a)) a
  ) =>
  GenerateKey a

instance
  ( GenerateKeyInternal (KeySource a) a
  , KeyConstraint (KeySource a) a
  , InsertWithPossiblyRequiredKey (KeySourceTypeInternalM (KeySource a))
  , InsertConstraint (KeySourceTypeInternalM (KeySource a)) a
  )
  => GenerateKey a

class GenerateKeyInternal (s :: KeySourceType) a where
  type KeyConstraint s a :: Constraint
  generateKey :: KeyConstraint s a => Gen (KeySourceTypeInternalM s (Key a))

instance GenerateKeyInternal 'SourceDefault a where
  type KeyConstraint 'SourceDefault a = GraphulaSafeToInsert a
  generateKey :: KeyConstraint 'SourceDefault a =>
Gen (KeySourceTypeInternalM 'SourceDefault (Key a))
generateKey = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a -> Optional a
Optional forall a. Maybe a
Nothing)

instance GenerateKeyInternal 'SourceArbitrary a where
  type KeyConstraint 'SourceArbitrary a = Arbitrary (Key a)
  generateKey :: KeyConstraint 'SourceArbitrary a =>
Gen (KeySourceTypeInternalM 'SourceArbitrary (Key a))
generateKey = forall key. key -> Required key
Required forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary

-- Rendered:
--
-- @
-- Cannot generate a value of type ‘X’ using ‘node’ since
--
--   instance HasDependencies X where
--     type KeySource X = 'SourceExternal
--
-- Possible fixes include:
-- • Use ‘nodeKeyed’ instead of ‘node’
-- • Change ‘KeySource X’ to 'SourceDefault or 'SourceArbitrary
-- @
--
instance
  TypeError
    ( 'Text "Cannot generate a value of type "
        ':<>: Quote ('ShowType a)
        ':<>: 'Text " using "
        ':<>: Quote ('Text "node")
        ':<>: 'Text " since"
        ':$$: 'Text ""
        ':$$: 'Text "  instance HasDependencies "
        ':<>: 'ShowType a
        ':<>: 'Text " where"
        ':$$: 'Text "    "
        ':<>: 'Text "type KeySource "
        ':<>: 'ShowType a
        ':<>: 'Text " = "
        ':<>: 'ShowType 'SourceExternal
        ':$$: 'Text ""
        ':$$: 'Text "Possible fixes include:"
        ':$$: 'Text "• Use "
        ':<>: Quote ('Text "nodeKeyed")
        ':<>: 'Text " instead of "
        ':<>: Quote ('Text "node")
        ':$$: 'Text "• Change "
        ':<>: Quote ('Text "KeySource " ':<>: 'ShowType a)
        ':<>: 'Text " to "
        ':<>: 'Text "'SourceDefault"
        ':<>: 'Text " or "
        ':<>: 'Text "'SourceArbitrary"
    )
  => GenerateKeyInternal 'SourceExternal a
  where
  type KeyConstraint 'SourceExternal a = NoConstraint a
  generateKey :: KeyConstraint 'SourceExternal a =>
Gen (KeySourceTypeInternalM 'SourceExternal (Key a))
generateKey = forall a. HasCallStack => String -> a
error String
"unreachable"

type family Quote t where
  Quote t = 'Text "‘" ':<>: t ':<>: 'Text "’"