{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoStarIsType #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Graphula.Internal
  ( MonadGraphulaBackend(..)
  , GHasDependencies(..)
  , KeySourceType(..)
  , GenerateKeyInternal(..)
  , NoConstraint
  )
where

import Data.IORef (IORef)
import Data.Kind (Constraint, Type)
import Database.Persist (Key)
import Generics.Eot (Proxy(..), Void)
import GHC.TypeLits (ErrorMessage(..), TypeError)
import Test.QuickCheck (Arbitrary(..), Gen)
import Test.QuickCheck.Random (QCGen)

class MonadGraphulaBackend m where
  type Logging m :: Type -> Constraint
  -- ^ A constraint provided to log details of the graph to some form of
  --   persistence. This is used by 'runGraphulaLogged' to store graph nodes as
  --   'Show'n 'Text' values
  askGen :: m (IORef QCGen)
  logNode :: Logging m a => a -> m ()

data Match t
  = NoMatch t
  | Match t

type family DependenciesTypeInstance nodeTy depsTy where
  DependenciesTypeInstance nodeTy depsTy =
    'Text "‘type Dependencies " ':<>: 'ShowType nodeTy ':<>:
    'Text " = " ':<>: 'ShowType depsTy ':<>: 'Text "’"

-- Walk through the fields of our node and match them up with fields from the dependencies.
type family FindMatches nodeTy depsTy as ds :: [Match Type] where
  -- Excess dependencies
  FindMatches nodeTy depsTy () (d, _ds) =
    TypeError
      ( 'Text "Excess dependency ‘" ':<>: 'ShowType d ':<>:
        'Text "’ in " ':$$: DependenciesTypeInstance nodeTy depsTy ':$$:
        'Text "Ordering of dependencies must match their occurrence in the target type ‘" ':<>:
        'ShowType nodeTy ':<>: 'Text "’"
      )

  -- No more fields or dependencies left
  FindMatches _nodeTy _depsTy () () = '[]

  -- Fields left, but no more dependencies
  FindMatches nodeTy depsTy (a, as) () = 'NoMatch a ': FindMatches nodeTy depsTy as ()

  -- Field matches dependency, keep going
  FindMatches nodeTy depsTy (a, as) (a, ds) = 'Match a ': FindMatches nodeTy depsTy as ds

  -- Field does not match dependency, keep going
  FindMatches nodeTy depsTy (a, as) (d, ds) = 'NoMatch a ': FindMatches nodeTy depsTy as (d, ds)

class GHasDependencies nodeTyProxy depsTyProxy node deps where
  genericDependsOn :: nodeTyProxy -> depsTyProxy -> node -> deps -> node

class GHasDependenciesRecursive fieldsProxy node deps where
  genericDependsOnRecursive :: fieldsProxy -> node -> deps -> node

-- This instance head only matches EoT representations of
-- datatypes with no constructors and no dependencies
instance {-# OVERLAPPING #-} GHasDependencies (Proxy nodeTy) (Proxy depsTy) Void (Either () Void) where
  genericDependsOn :: Proxy nodeTy -> Proxy depsTy -> Void -> Either () Void -> Void
genericDependsOn Proxy nodeTy
_ Proxy depsTy
_ Void
node Either () Void
_ = Void
node

-- This instance warns the user if they give dependencies
-- to a datatype with no constructors
instance
  {-# OVERLAPPABLE #-}
  ( TypeError
    ( 'Text "A datatype with no constructors can't use the dependencies in" ':$$:
      DependenciesTypeInstance nodeTy depsTy
    )
  ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) Void (Either deps rest) where
  genericDependsOn :: Proxy nodeTy -> Proxy depsTy -> Void -> Either deps rest -> Void
genericDependsOn Proxy nodeTy
_ Proxy depsTy
_ Void
_ Either deps rest
_ = [Char] -> Void
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible"

-- This instance head only matches EoT representations of
-- datatypes with a single constructor
instance
  ( FindMatches nodeTy depsTy node deps ~ fields
  , GHasDependenciesRecursive (Proxy fields) node deps
  ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either node Void) (Either deps Void) where
  genericDependsOn :: Proxy nodeTy
-> Proxy depsTy
-> Either node Void
-> Either deps Void
-> Either node Void
genericDependsOn Proxy nodeTy
_ Proxy depsTy
_ (Left node
node) (Left deps
deps) =
    node -> Either node Void
forall a b. a -> Either a b
Left (Proxy fields -> node -> deps -> node
forall fieldsProxy node deps.
GHasDependenciesRecursive fieldsProxy node deps =>
fieldsProxy -> node -> deps -> node
genericDependsOnRecursive (Proxy fields
forall k (t :: k). Proxy t
Proxy :: Proxy fields) node
node deps
deps)
  genericDependsOn Proxy nodeTy
_ Proxy depsTy
_ Either node Void
_ Either deps Void
_ = [Char] -> Either node Void
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible" -- EoT never generates an actual `Right (x :: Void)` here

-- This instance matches a sum type as both node and dependencies.
-- We use this to report an error to the user.
instance
  ( TypeError
    ( 'Text "Cannot automatically find dependencies for sum type in" ':$$:
      DependenciesTypeInstance nodeTy depsTy
    )
  ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either left (Either right rest)) (Either deps Void) where
  genericDependsOn :: Proxy nodeTy
-> Proxy depsTy
-> Either left (Either right rest)
-> Either deps Void
-> Either left (Either right rest)
genericDependsOn Proxy nodeTy
_ Proxy depsTy
_ Either left (Either right rest)
_ Either deps Void
_ = [Char] -> Either left (Either right rest)
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible"

-- This instance matches a sum type as the node.
-- This is also an error.
instance
  ( TypeError
    ( 'Text "Cannot automatically use a sum type as dependencies in" ':$$:
      DependenciesTypeInstance nodeTy depsTy
    )
  ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either node Void) (Either left (Either right rest)) where
  genericDependsOn :: Proxy nodeTy
-> Proxy depsTy
-> Either node Void
-> Either left (Either right rest)
-> Either node Void
genericDependsOn Proxy nodeTy
_ Proxy depsTy
_ Either node Void
_ Either left (Either right rest)
_ = [Char] -> Either node Void
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible"

-- This instance matches a sum type as the dependencies.
-- This is also an error.
instance
  ( TypeError
    ( 'Text "Cannot automatically find dependencies for sum type or use a sum type as a dependency in" ':$$:
      DependenciesTypeInstance nodeTy depsTy
    )
  ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either left1 (Either right1 rest1)) (Either left2 (Either right2 rest2)) where
  genericDependsOn :: Proxy nodeTy
-> Proxy depsTy
-> Either left1 (Either right1 rest1)
-> Either left2 (Either right2 rest2)
-> Either left1 (Either right1 rest1)
genericDependsOn Proxy nodeTy
_ Proxy depsTy
_ Either left1 (Either right1 rest1)
_ Either left2 (Either right2 rest2)
_ = [Char] -> Either left1 (Either right1 rest1)
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible"

-- Don't let the user specify `Void` as a dependency
instance
  ( TypeError
    ( 'Text "Use ‘()’ instead of ‘Void’ for datatypes with no dependencies in" ':$$:
      DependenciesTypeInstance nodeTy depsTy
    )
  ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) node Void where
  genericDependsOn :: Proxy nodeTy -> Proxy depsTy -> node -> Void -> node
genericDependsOn Proxy nodeTy
_ Proxy depsTy
_ node
_ Void
_ = [Char] -> node
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible"

instance
  ( a ~ dep
  , GHasDependenciesRecursive (Proxy fields) as deps
  ) => GHasDependenciesRecursive (Proxy ('Match a ': fields)) (a, as) (dep, deps) where
  genericDependsOnRecursive :: Proxy ('Match a : fields) -> (a, as) -> (dep, deps) -> (a, as)
genericDependsOnRecursive Proxy ('Match a : fields)
_ (a
_, as
as) (dep
dep, deps
deps) =
    (a
dep
dep, Proxy fields -> as -> deps -> as
forall fieldsProxy node deps.
GHasDependenciesRecursive fieldsProxy node deps =>
fieldsProxy -> node -> deps -> node
genericDependsOnRecursive (Proxy fields
forall k (t :: k). Proxy t
Proxy :: Proxy fields) as
as deps
deps)

instance
  ( GHasDependenciesRecursive (Proxy fields) as deps
  ) => GHasDependenciesRecursive (Proxy ('NoMatch a ': fields)) (a, as) deps where
  genericDependsOnRecursive :: Proxy ('NoMatch a : fields) -> (a, as) -> deps -> (a, as)
genericDependsOnRecursive Proxy ('NoMatch a : fields)
_ (a
a, as
as) deps
deps =
    (a
a, Proxy fields -> as -> deps -> as
forall fieldsProxy node deps.
GHasDependenciesRecursive fieldsProxy node deps =>
fieldsProxy -> node -> deps -> node
genericDependsOnRecursive (Proxy fields
forall k (t :: k). Proxy t
Proxy :: Proxy fields) as
as deps
deps)

-- Without the kind-signature for '[], ghc will fail to find this
-- instance for nullary constructors
instance GHasDependenciesRecursive (Proxy ('[] :: [Match Type])) () () where
  genericDependsOnRecursive :: Proxy '[] -> () -> () -> ()
genericDependsOnRecursive Proxy '[]
_ ()
_ ()
_ = ()

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

-- | Handle key generation for @'SourceDefault'@ and @'SourceArbitrary'@
--
-- Ths could be a single-parameter class, but carrying the @a@ around
-- lets us give a better error message when @'node'@ is called instead
-- of @'nodeKeyed'@.
--
class GenerateKeyInternal (s :: KeySourceType) a where
  type KeyConstraint s a :: Constraint
  generateKey :: KeyConstraint s a => Gen (Maybe (Key a))

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

instance GenerateKeyInternal 'SourceArbitrary a where
  type KeyConstraint 'SourceArbitrary a = Arbitrary (Key a)
  generateKey :: Gen (Maybe (Key a))
generateKey = Key a -> Maybe (Key a)
forall a. a -> Maybe a
Just (Key a -> Maybe (Key a)) -> Gen (Key a) -> Gen (Maybe (Key a))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Key a)
forall a. Arbitrary a => Gen a
arbitrary

-- | Explicit instance for @'SourceExternal'@ to give an actionable error message
--
-- 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 :: Gen (Maybe (Key a))
generateKey = [Char] -> Gen (Maybe (Key a))
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable"

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

-- | Graphula accepts constraints for various uses. Frontends do not always
-- utilize these constraints. 'NoConstraint' is a universal class that all
-- types inhabit. It has no behavior and no additional constraints.
class NoConstraint a
instance NoConstraint a