module Database.PostgreSQL.Query.TH.Entity
( EntityOptions(..)
, deriveEntity
) where
import Prelude
import Data.Default
import Data.String
import Data.Text (pack, unpack)
import Database.PostgreSQL.Query.Entity.Class
import Database.PostgreSQL.Query.TH.Common
import Database.PostgreSQL.Query.Types ( FN(..) )
import Database.PostgreSQL.Simple.FromField
import Database.PostgreSQL.Simple.ToField
import GHC.Generics (Generic)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Text.Inflections
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
data EntityOptions = EntityOptions
{ eoTableName :: String -> String
, eoColumnNames :: String -> String
, eoDeriveClasses :: [Name]
, eoIdType :: Name
} deriving (Generic)
#if !MIN_VERSION_inflections(0,3,0)
instance Default EntityOptions where
def = EntityOptions
{ eoTableName = toUnderscore
, eoColumnNames = toUnderscore
, eoDeriveClasses = [ ''Ord, ''Eq, ''Show
, ''FromField, ''ToField ]
, eoIdType = ''Integer
}
#else
instance Default EntityOptions where
def = EntityOptions
{ eoTableName = toUnderscore'
, eoColumnNames = toUnderscore'
, eoDeriveClasses = [ ''Ord, ''Eq, ''Show
, ''FromField, ''ToField ]
, eoIdType = ''Integer
}
toUnderscore' :: String -> String
toUnderscore' s = case toUnderscore $ pack s of
Left er -> error $ "toUnderscore: " ++ show er
Right a -> unpack a
#endif
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,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 = fromString $ eoTableName opts tnames
fldNames = map (fromString . eoColumnNames opts . 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]