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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
{- You can't export a data family constructor, so there's an "unused" warning -}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Persist.Compatible.Types
( Compatible(..)
) where
import Control.Monad.Trans.Reader (withReaderT)
import Data.Aeson
import Database.Persist.Class
import Database.Persist.Sql.Class
-- | A newtype wrapper for compatible backends, mainly useful for @DerivingVia@.
--
-- When writing a new backend that is 'BackendCompatible' with an existing backend,
-- instances for the new backend can be naturally defined in terms of the
-- instances for the existing backend.
--
-- For example, if you decide to augment the 'SqlBackend' with some additional
-- features:
--
-- @
-- data BetterSqlBackend = BetterSqlBackend { sqlBackend :: SqlBackend, ... }
--
-- instance BackendCompatible SqlBackend BetterSqlBackend where
-- projectBackend = sqlBackend
-- @
--
-- Then you can use @DerivingVia@ to automatically get instances like:
--
-- @
-- deriving via (Compatible SqlBackend BetterSqlBackend) instance PersistStoreRead BetterSqlBackend
-- deriving via (Compatible SqlBackend BetterSqlBackend) instance PersistStoreWrite BetterSqlBackend
-- ...
-- @
--
-- These instances will go through the compatible backend (in this case, 'SqlBackend')
-- for all their queries.
--
-- These instances require that both backends have the same 'BaseBackend', but
-- deriving 'HasPersistBackend' will enforce that for you.
--
-- @
-- deriving via (Compatible SqlBackend BetterSqlBackend) instance HasPersistBackend BetterSqlBackend
-- @
--
-- @since 2.12
newtype Compatible b s = Compatible { unCompatible :: s }
instance (BackendCompatible b s, HasPersistBackend b) => HasPersistBackend (Compatible b s) where
type BaseBackend (Compatible b s) = BaseBackend b
persistBackend = persistBackend . projectBackend @b @s . unCompatible
instance (BackendCompatible b s, PersistCore b) => PersistCore (Compatible b s) where
-- | A newtype wrapper around @'BackendKey' b@, mainly useful for @DerivingVia@.
--
-- Similarly to @'Compatible' b s@, this data family instance is handy for deriving
-- instances for @'BackendKey' s@ by defining them in terms of @'BackendKey' b@.
--
--
-- For example, if you decide to augment the 'SqlBackend' with some additional
-- features:
--
-- @
-- data BetterSqlBackend = BetterSqlBackend { sqlBackend :: SqlBackend, ... }
--
-- instance PersistCore BetterSqlBackend where
-- newtype BackendKey BetterSqlBackend = BSQLKey { unBSQLKey :: BackendKey (Compatible SqlBackend BetterSqlBackend) }
-- @
--
-- Then you can use @DerivingVia@ to automatically get instances like:
--
-- @
-- deriving via BackendKey (Compatible SqlBackend BetterSqlBackend) instance Show (BackendKey BetterSqlBackend)
-- ...
-- @
--
-- These instances will go through the compatible backend's key (in this case,
-- @'BackendKey' 'SqlBackend'@) for all their logic.
newtype BackendKey (Compatible b s) = CompatibleKey { unCompatibleKey :: BackendKey b }
instance (HasPersistBackend b, BackendCompatible b s, PersistStoreRead b) => PersistStoreRead (Compatible b s) where
get = withReaderT (projectBackend @b @s . unCompatible) . get
getMany = withReaderT (projectBackend @b @s . unCompatible) . getMany
instance (HasPersistBackend b, BackendCompatible b s, PersistQueryRead b) => PersistQueryRead (Compatible b s) where
selectSourceRes filts opts = withReaderT (projectBackend @b @s . unCompatible) $ selectSourceRes filts opts
selectFirst filts opts = withReaderT (projectBackend @b @s . unCompatible) $ selectFirst filts opts
selectKeysRes filts opts = withReaderT (projectBackend @b @s . unCompatible) $ selectKeysRes filts opts
count = withReaderT (projectBackend @b @s . unCompatible) . count
exists = withReaderT (projectBackend @b @s . unCompatible) . exists
instance (HasPersistBackend b, BackendCompatible b s, PersistQueryWrite b) => PersistQueryWrite (Compatible b s) where
updateWhere filts updates = withReaderT (projectBackend @b @s . unCompatible) $ updateWhere filts updates
deleteWhere = withReaderT (projectBackend @b @s . unCompatible) . deleteWhere
instance (HasPersistBackend b, BackendCompatible b s, PersistUniqueRead b) => PersistUniqueRead (Compatible b s) where
getBy = withReaderT (projectBackend @b @s . unCompatible) . getBy
existsBy = withReaderT (projectBackend @b @s . unCompatible) . existsBy
instance (HasPersistBackend b, BackendCompatible b s, PersistStoreWrite b) => PersistStoreWrite (Compatible b s) where
insert = withReaderT (projectBackend @b @s . unCompatible) . insert
insert_ = withReaderT (projectBackend @b @s . unCompatible) . insert_
insertMany = withReaderT (projectBackend @b @s . unCompatible) . insertMany
insertMany_ = withReaderT (projectBackend @b @s . unCompatible) . insertMany_
insertEntityMany = withReaderT (projectBackend @b @s . unCompatible) . insertEntityMany
insertKey k = withReaderT (projectBackend @b @s . unCompatible) . insertKey k
repsert k = withReaderT (projectBackend @b @s . unCompatible) . repsert k
repsertMany = withReaderT (projectBackend @b @s . unCompatible) . repsertMany
replace k = withReaderT (projectBackend @b @s . unCompatible) . replace k
delete = withReaderT (projectBackend @b @s . unCompatible) . delete
update k = withReaderT (projectBackend @b @s . unCompatible) . update k
updateGet k = withReaderT (projectBackend @b @s . unCompatible) . updateGet k
instance (HasPersistBackend b, BackendCompatible b s, PersistUniqueWrite b) => PersistUniqueWrite (Compatible b s) where
deleteBy = withReaderT (projectBackend @b @s . unCompatible) . deleteBy
insertUnique = withReaderT (projectBackend @b @s . unCompatible) . insertUnique
upsert rec = withReaderT (projectBackend @b @s . unCompatible) . upsert rec
upsertBy uniq rec = withReaderT (projectBackend @b @s . unCompatible) . upsertBy uniq rec
putMany = withReaderT (projectBackend @b @s . unCompatible) . putMany
deriving via (BackendKey b) instance (BackendCompatible b s, Show (BackendKey b)) => Show (BackendKey (Compatible b s))
deriving via (BackendKey b) instance (BackendCompatible b s, Read (BackendKey b)) => Read (BackendKey (Compatible b s))
deriving via (BackendKey b) instance (BackendCompatible b s, Eq (BackendKey b)) => Eq (BackendKey (Compatible b s))
deriving via (BackendKey b) instance (BackendCompatible b s, Ord (BackendKey b)) => Ord (BackendKey (Compatible b s))
deriving via (BackendKey b) instance (BackendCompatible b s, Num (BackendKey b)) => Num (BackendKey (Compatible b s))
deriving via (BackendKey b) instance (BackendCompatible b s, Integral (BackendKey b)) => Integral (BackendKey (Compatible b s))
deriving via (BackendKey b) instance (BackendCompatible b s, PersistField (BackendKey b)) => PersistField (BackendKey (Compatible b s))
deriving via (BackendKey b) instance (BackendCompatible b s, PersistFieldSql (BackendKey b)) => PersistFieldSql (BackendKey (Compatible b s))
deriving via (BackendKey b) instance (BackendCompatible b s, Real (BackendKey b)) => Real (BackendKey (Compatible b s))
deriving via (BackendKey b) instance (BackendCompatible b s, Enum (BackendKey b)) => Enum (BackendKey (Compatible b s))
deriving via (BackendKey b) instance (BackendCompatible b s, Bounded (BackendKey b)) => Bounded (BackendKey (Compatible b s))
deriving via (BackendKey b) instance (BackendCompatible b s, ToJSON (BackendKey b)) => ToJSON (BackendKey (Compatible b s))
deriving via (BackendKey b) instance (BackendCompatible b s, FromJSON (BackendKey b)) => FromJSON (BackendKey (Compatible b s))
|
