{-# 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
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 "’"
type family FindMatches nodeTy depsTy as ds :: [Match Type] where
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 "’"
)
FindMatches _nodeTy _depsTy () () = '[]
FindMatches nodeTy depsTy (a, as) () = 'NoMatch a ': FindMatches nodeTy depsTy as ()
FindMatches nodeTy depsTy (a, as) (a, ds) = 'Match a ': FindMatches nodeTy depsTy as ds
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
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
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"
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"
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"
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"
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"
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)
instance GHasDependenciesRecursive (Proxy ('[] :: [Match Type])) () () where
genericDependsOnRecursive :: Proxy '[] -> () -> () -> ()
genericDependsOnRecursive Proxy '[]
_ ()
_ ()
_ = ()
data KeySourceType
= SourceDefault
| SourceArbitrary
| SourceExternal
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
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 "’"
class NoConstraint a
instance NoConstraint a