summaryrefslogtreecommitdiff
path: root/src/Database/PostgreSQL/Query/TH/Entity.hs
blob: 83519e88a6045c377e88998fa992c9a7dfb7a6cb (plain)
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
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)|]
    eidcont <- [t|EntityId $(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,15,0)
        idcon = RecC (mkName idname)
                [(mkName unidname, Bang NoSourceUnpackedness NoSourceStrictness, idtype)]
        iddec = NewtypeInstD [] Nothing eidcont Nothing
                idcon [DerivClause Nothing (map ConT $ eoDeriveClasses opts)]
#elif 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]