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
|
module Database.PostgreSQL.Query.TH.Entity
( EntityOptions(..)
, deriveEntity
) where
import Data.Default
import Database.PostgreSQL.Query.Entity.Class
import Database.PostgreSQL.Query.Import
import Database.PostgreSQL.Query.TH.Common
import Database.PostgreSQL.Query.Types ( FN(..), textFN )
import Database.PostgreSQL.Simple.FromField
import Database.PostgreSQL.Simple.ToField
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Text.Inflections
import qualified Data.Text as T
-- | Options for deriving `Entity`
data EntityOptions = EntityOptions
{ eoTableName :: Text -> FN -- ^ Type name to table name converter
, eoColumnNames :: Text -> FN -- ^ Record field to column name converter
, eoDeriveClasses :: [Name] -- ^ Typeclasses to derive for Id
, eoIdType :: Name -- ^ Base type for Id
} deriving (Generic)
#if !MIN_VERSION_inflections(0,3,0)
toUnderscore' :: Text -> Text
toUnderscore' = T.pack . toUnderscore . T.unpack
#else
toUnderscore' :: Text -> Text
toUnderscore' = either error' id . toUnderscore
where
error' er = error $ "toUnderscore: " ++ show er
#endif
instance Default EntityOptions where
def = EntityOptions
{ eoTableName = textFN . toUnderscore'
, eoColumnNames = textFN . toUnderscore'
, eoDeriveClasses = [ ''Ord, ''Eq, ''Show
, ''FromField, ''ToField ]
, eoIdType = ''Integer
}
{- | Derives instance for 'Entity' using type name and field names. Also
generates type synonim for ID. E.g. code like this:
@
data Agent = Agent
{ aName :: !Text
, aAttributes :: !HStoreMap
, aLongWeirdName :: !Int
} deriving (Ord, Eq, Show)
$(deriveEntity
def { eoIdType = ''Id
, eoTableName = textFN . toUnderscore'
, eoColumnNames = textFN . toUnderscore' . drop 1
, eoDeriveClasses =
[''Show, ''Read, ''Ord, ''Eq
, ''FromField, ''ToField, ''PathPiece]
}
''Agent )
@
Will generate code like this:
@
instance Database.PostgreSQL.Query.Entity Agent where
newtype EntityId Agent
= AgentId {getAgentId :: Id}
deriving (Show, Read, Ord, Eq, FromField, ToField, PathPiece)
tableName _ = "agent"
fieldNames _ = ["name", "attributes", "long_weird_name"]
type AgentId = EntityId Agent
@
So, you dont need to write it by hands any more.
NOTE: 'toUnderscore' is from package 'inflections' here
-}
deriveEntity :: EntityOptions -> Name -> Q [Dec]
deriveEntity opts tname = do
tcon <- dataConstructors <$> reify tname >>= \case
[a] -> return a
x -> fail $ "expected exactly 1 data constructor, but " ++ show (length x) ++ " got"
econt <- [t|Entity $(conT tname)|]
ConT entityIdName <- [t|EntityId|]
let tnames = nameBase tname
idname = tnames ++ "Id"
unidname = "get" ++ idname
idtype = ConT (eoIdType opts)
#if MIN_VERSION_template_haskell(2,12,0)
idcon = RecC (mkName idname)
[(mkName unidname, Bang NoSourceUnpackedness NoSourceStrictness, idtype)]
iddec = NewtypeInstD [] entityIdName [ConT tname] Nothing
idcon [DerivClause Nothing (map ConT $ eoDeriveClasses opts)]
#elif MIN_VERSION_template_haskell(2,11,0)
idcon = RecC (mkName idname)
[(mkName unidname, Bang NoSourceUnpackedness NoSourceStrictness, idtype)]
iddec = NewtypeInstD [] entityIdName [ConT tname] Nothing
idcon (map ConT $ eoDeriveClasses opts)
#else
idcon = RecC (mkName idname)
[(mkName unidname, NotStrict, idtype)]
iddec = NewtypeInstD [] entityIdName [ConT tname]
idcon (eoDeriveClasses opts)
#endif
tblName = eoTableName opts $ T.pack tnames
fldNames = map (eoColumnNames opts . T.pack . nameBase)
$ cFieldNames tcon
VarE ntableName <- [e|tableName|]
VarE nfieldNames <- [e|fieldNames|]
tblExp <- lift (tblName :: FN)
fldExp <- mapM lift (fldNames :: [FN])
let tbldec = FunD ntableName [Clause [WildP] (NormalB tblExp) []]
flddec = FunD nfieldNames [Clause [WildP] (NormalB $ ListE fldExp) []]
#if MIN_VERSION_template_haskell(2,11,0)
ret = InstanceD Nothing [] econt [ iddec, tbldec, flddec ]
#else
ret = InstanceD [] econt [ iddec, tbldec, flddec ]
#endif
syndec = TySynD (mkName idname) [] (AppT (ConT entityIdName) (ConT tname))
return [ret, syndec]
|
