    {-# 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
            (b, 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 $(return b) $(return s)) instance (HasPersistBackend $(return b)) => HasPersistBackend $(return s)
                    deriving via (Compatible $(return b) $(return s)) instance (HasPersistBackend $(return b), PersistStoreRead $(return b)) => PersistStoreRead $(return s)
                    deriving via (Compatible $(return b) $(return s)) instance (HasPersistBackend $(return b), PersistQueryRead $(return b)) => PersistQueryRead $(return s)
                    deriving via (Compatible $(return b) $(return s)) instance (HasPersistBackend $(return b), PersistUniqueRead $(return b)) => PersistUniqueRead $(return s)
                    deriving via (Compatible $(return b) $(return s)) instance (HasPersistBackend $(return b), PersistStoreWrite $(return b)) => PersistStoreWrite $(return s)
                    deriving via (Compatible $(return b) $(return s)) instance (HasPersistBackend $(return b), PersistQueryWrite $(return b)) => PersistQueryWrite $(return s)
                    deriving via (Compatible $(return b) $(return s)) instance (HasPersistBackend $(return b), PersistUniqueWrite $(return b)) => PersistUniqueWrite $(return 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
        (b, 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 $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Show (BackendKey $(return b))) => Show (BackendKey $(return s))
                deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Read (BackendKey $(return b))) => Read (BackendKey $(return s))
                deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Eq (BackendKey $(return b))) => Eq (BackendKey $(return s))
                deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Ord (BackendKey $(return b))) => Ord (BackendKey $(return s))
                deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Num (BackendKey $(return b))) => Num (BackendKey $(return s))
                deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Integral (BackendKey $(return b))) => Integral (BackendKey $(return s))
                deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), PersistField (BackendKey $(return b))) => PersistField (BackendKey $(return s))
                deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), PersistFieldSql (BackendKey $(return b))) => PersistFieldSql (BackendKey $(return s))
                deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Real (BackendKey $(return b))) => Real (BackendKey $(return s))
                deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Enum (BackendKey $(return b))) => Enum (BackendKey $(return s))
                deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Bounded (BackendKey $(return b))) => Bounded (BackendKey $(return s))
                deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), ToJSON (BackendKey $(return b))) => ToJSON (BackendKey $(return s))
                deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), FromJSON (BackendKey $(return b))) => FromJSON (BackendKey $(return s))
            |]