1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
{-# 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 compatibleType = do
(b, s) <- compatibleType >>= \case
ForallT _ _ (AppT (AppT (ConT conTName) b) s) ->
if conTName == ''Compatible
then pure (b, s)
else fail $
"Cannot make `deriving via` instances if the argument is " <>
"not of the form `forall v1 ... vn. Compatible sub sup`"
AppT (AppT (ConT conTName) b) s ->
if conTName == ''Compatible
then pure (b, s)
else fail $
"Cannot make `deriving via` instances if the argument is " <>
"not of the form `Compatible sub sup`"
_ -> fail $
"Cannot make `deriving via` instances if the argument is " <>
"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 compatibleType = do
(b, s) <- compatibleType >>= \case
ForallT _ _ (AppT (AppT (ConT conTName) b) s) ->
if conTName == ''Compatible
then pure (b, s)
else fail $
"Cannot make `deriving via` instances if the argument is " <>
"not of the form `forall v1 ... vn. Compatible sub sup`"
AppT (AppT (ConT conTName) b) s ->
if conTName == ''Compatible
then pure (b, s)
else fail $
"Cannot make `deriving via` instances if the argument is " <>
"not of the form `Compatible sub sup`"
_ -> fail $
"Cannot make `deriving via` instances if the argument is " <>
"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))
|]
|
