{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

module Database.Persist.Compatible.TH
    ( makeCompatibleInstances
    , makeCompatibleKeyInstances
    ) where

import Data.Aeson
import Database.Persist.Class
import Database.Persist.Sql.Class
import Language.Haskell.TH

import Database.Persist.Compatible.Types

-- | Gives a bunch of useful instance declarations for a backend based on its
-- compatibility with another backend, using 'Compatible'.
--
-- The argument should be a type of the form @ forall v1 ... vn. Compatible b s @
-- (Quantification is optional, but supported because TH won't let you have
-- unbound type variables in a type splice). The instance is produced for @s@
-- based on the instance defined for @b@, which is constrained in the instance
-- head to exist.
--
-- @v1 ... vn@ are implicitly quantified in the instance, which is derived via
-- @'Compatible' b s@.
--
-- @since 2.12
makeCompatibleInstances :: Q Type -> Q [Dec]
makeCompatibleInstances :: Q Type -> Q [Dec]
makeCompatibleInstances Q Type
compatibleType = do
    (Type
b, Type
s) <-
        Q Type
compatibleType Q Type -> (Type -> Q (Type, Type)) -> Q (Type, Type)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            ForallT [TyVarBndr Specificity]
_ Cxt
_ (AppT (AppT (ConT Name
conTName) Type
b) Type
s) ->
                if Name
conTName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Compatible
                    then (Type, Type) -> Q (Type, Type)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
b, Type
s)
                    else
                        String -> Q (Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, Type)) -> String -> Q (Type, Type)
forall a b. (a -> b) -> a -> b
$
                            String
"Cannot make `deriving via` instances if the argument is "
                                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"not of the form `forall v1 ... vn. Compatible sub sup`"
            AppT (AppT (ConT Name
conTName) Type
b) Type
s ->
                if Name
conTName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Compatible
                    then (Type, Type) -> Q (Type, Type)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
b, Type
s)
                    else
                        String -> Q (Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, Type)) -> String -> Q (Type, Type)
forall a b. (a -> b) -> a -> b
$
                            String
"Cannot make `deriving via` instances if the argument is "
                                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"not of the form `Compatible sub sup`"
            Type
_ ->
                String -> Q (Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, Type)) -> String -> Q (Type, Type)
forall a b. (a -> b) -> a -> b
$
                    String
"Cannot make `deriving via` instances if the argument is "
                        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"not of the form `Compatible sub sup`"

    [d|
        deriving via
            (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))
            instance
                (HasPersistBackend $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b)) => HasPersistBackend $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)

        deriving via
            (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))
            instance
                (HasPersistBackend $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b), PersistStoreRead $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                => PersistStoreRead $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)

        deriving via
            (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))
            instance
                (HasPersistBackend $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b), PersistQueryRead $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                => PersistQueryRead $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)

        deriving via
            (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))
            instance
                (HasPersistBackend $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b), PersistUniqueRead $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                => PersistUniqueRead $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)

        deriving via
            (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))
            instance
                (HasPersistBackend $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b), PersistStoreWrite $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                => PersistStoreWrite $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)

        deriving via
            (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))
            instance
                (HasPersistBackend $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b), PersistQueryWrite $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                => PersistQueryWrite $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)

        deriving via
            (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))
            instance
                (HasPersistBackend $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b), PersistUniqueWrite $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                => PersistUniqueWrite $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)
        |]

-- | Gives a bunch of useful instance declarations for a backend key based on
-- its compatibility with another backend & key, using 'Compatible'.
--
-- The argument should be a type of the form @ forall v1 ... vn. Compatible b s @
-- (Quantification is optional, but supported because TH won't let you have
-- unbound type variables in a type splice). The instance is produced for
-- @'BackendKey' s@ based on the instance defined for @'BackendKey' b@, which
-- is constrained in the instance head to exist.
--
-- @v1 ... vn@ are implicitly quantified in the instance, which is derived via
-- @'BackendKey' ('Compatible' b s)@.
--
-- @since 2.12
makeCompatibleKeyInstances :: Q Type -> Q [Dec]
makeCompatibleKeyInstances :: Q Type -> Q [Dec]
makeCompatibleKeyInstances Q Type
compatibleType = do
    (Type
b, Type
s) <-
        Q Type
compatibleType Q Type -> (Type -> Q (Type, Type)) -> Q (Type, Type)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            ForallT [TyVarBndr Specificity]
_ Cxt
_ (AppT (AppT (ConT Name
conTName) Type
b) Type
s) ->
                if Name
conTName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Compatible
                    then (Type, Type) -> Q (Type, Type)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
b, Type
s)
                    else
                        String -> Q (Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, Type)) -> String -> Q (Type, Type)
forall a b. (a -> b) -> a -> b
$
                            String
"Cannot make `deriving via` instances if the argument is "
                                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"not of the form `forall v1 ... vn. Compatible sub sup`"
            AppT (AppT (ConT Name
conTName) Type
b) Type
s ->
                if Name
conTName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Compatible
                    then (Type, Type) -> Q (Type, Type)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
b, Type
s)
                    else
                        String -> Q (Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, Type)) -> String -> Q (Type, Type)
forall a b. (a -> b) -> a -> b
$
                            String
"Cannot make `deriving via` instances if the argument is "
                                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"not of the form `Compatible sub sup`"
            Type
_ ->
                String -> Q (Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, Type)) -> String -> Q (Type, Type)
forall a b. (a -> b) -> a -> b
$
                    String
"Cannot make `deriving via` instances if the argument is "
                        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"not of the form `Compatible sub sup`"

    [d|
        deriving via
            (BackendKey (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)))
            instance
                ( PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b)
                , PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)
                , Show (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                )
                => Show (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))

        deriving via
            (BackendKey (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)))
            instance
                ( PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b)
                , PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)
                , Read (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                )
                => Read (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))

        deriving via
            (BackendKey (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)))
            instance
                (PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b), PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s), Eq (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b)))
                => Eq (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))

        deriving via
            (BackendKey (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)))
            instance
                (PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b), PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s), Ord (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b)))
                => Ord (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))

        deriving via
            (BackendKey (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)))
            instance
                (PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b), PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s), Num (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b)))
                => Num (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))

        deriving via
            (BackendKey (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)))
            instance
                ( PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b)
                , PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)
                , Integral (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                )
                => Integral (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))

        deriving via
            (BackendKey (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)))
            instance
                ( PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b)
                , PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)
                , PersistField (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                )
                => PersistField (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))

        deriving via
            (BackendKey (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)))
            instance
                ( PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b)
                , PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)
                , PersistFieldSql (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                )
                => PersistFieldSql (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))

        deriving via
            (BackendKey (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)))
            instance
                ( PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b)
                , PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)
                , Real (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                )
                => Real (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))

        deriving via
            (BackendKey (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)))
            instance
                ( PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b)
                , PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)
                , Enum (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                )
                => Enum (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))

        deriving via
            (BackendKey (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)))
            instance
                ( PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b)
                , PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)
                , Bounded (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                )
                => Bounded (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))

        deriving via
            (BackendKey (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)))
            instance
                ( PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b)
                , PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)
                , ToJSON (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                )
                => ToJSON (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))

        deriving via
            (BackendKey (Compatible $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)))
            instance
                ( PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b)
                , PersistCore $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s)
                , FromJSON (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b))
                )
                => FromJSON (BackendKey $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
s))
        |]