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
data EntityOptions = EntityOptions
{ EntityOptions -> Text -> FN
eoTableName :: Text -> FN
, EntityOptions -> Text -> FN
eoColumnNames :: Text -> FN
, EntityOptions -> [Name]
eoDeriveClasses :: [Name]
, EntityOptions -> Name
eoIdType :: Name
} deriving ((forall x. EntityOptions -> Rep EntityOptions x)
-> (forall x. Rep EntityOptions x -> EntityOptions)
-> Generic EntityOptions
forall x. Rep EntityOptions x -> EntityOptions
forall x. EntityOptions -> Rep EntityOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EntityOptions x -> EntityOptions
$cfrom :: forall x. EntityOptions -> Rep EntityOptions x
Generic)
#if !MIN_VERSION_inflections(0,3,0)
toUnderscore' :: Text -> Text
toUnderscore' = T.pack . toUnderscore . T.unpack
#else
toUnderscore' :: Text -> Text
toUnderscore' :: Text -> Text
toUnderscore' = (ParseErrorBundle Text Void -> Text)
-> (Text -> Text)
-> Either (ParseErrorBundle Text Void) Text
-> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseErrorBundle Text Void -> Text
forall a a. Show a => a -> a
error' Text -> Text
forall a. a -> a
id (Either (ParseErrorBundle Text Void) Text -> Text)
-> (Text -> Either (ParseErrorBundle Text Void) Text)
-> Text
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either (ParseErrorBundle Text Void) Text
toUnderscore
where
error' :: a -> a
error' a
er = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"toUnderscore: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
er
#endif
instance Default EntityOptions where
def :: EntityOptions
def = EntityOptions :: (Text -> FN) -> (Text -> FN) -> [Name] -> Name -> EntityOptions
EntityOptions
{ eoTableName :: Text -> FN
eoTableName = Text -> FN
textFN (Text -> FN) -> (Text -> Text) -> Text -> FN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toUnderscore'
, eoColumnNames :: Text -> FN
eoColumnNames = Text -> FN
textFN (Text -> FN) -> (Text -> Text) -> Text -> FN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toUnderscore'
, eoDeriveClasses :: [Name]
eoDeriveClasses = [ ''Ord, ''Eq, ''Show
, ''FromField, ''ToField ]
, eoIdType :: Name
eoIdType = ''Integer
}
deriveEntity :: EntityOptions -> Name -> Q [Dec]
deriveEntity :: EntityOptions -> Name -> Q [Dec]
deriveEntity EntityOptions
opts Name
tname = do
Con
tcon <- Info -> [Con]
dataConstructors (Info -> [Con]) -> Q Info -> Q [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
tname Q [Con] -> ([Con] -> Q Con) -> Q Con
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[Con
a] -> Con -> Q Con
forall (m :: * -> *) a. Monad m => a -> m a
return Con
a
[Con]
x -> [Char] -> Q Con
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Con) -> [Char] -> Q Con
forall a b. (a -> b) -> a -> b
$ [Char]
"expected exactly 1 data constructor, but " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
x) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" got"
Type
econt <- [t|Entity $(conT tname)|]
Type
eidcont <- [t|EntityId $(conT tname)|]
ConT Name
entityIdName <- [t|EntityId|]
let tnames :: [Char]
tnames = Name -> [Char]
nameBase Name
tname
idname :: [Char]
idname = [Char]
tnames [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Id"
unidname :: [Char]
unidname = [Char]
"get" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
idname
idtype :: Type
idtype = Name -> Type
ConT (EntityOptions -> Name
eoIdType EntityOptions
opts)
#if MIN_VERSION_template_haskell(2,15,0)
idcon :: Con
idcon = Name -> [VarBangType] -> Con
RecC ([Char] -> Name
mkName [Char]
idname)
[([Char] -> Name
mkName [Char]
unidname, SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
idtype)]
iddec :: Dec
iddec = Cxt
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD [] Maybe [TyVarBndr]
forall a. Maybe a
Nothing Type
eidcont Maybe Type
forall a. Maybe a
Nothing
Con
idcon [Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
ConT ([Name] -> Cxt) -> [Name] -> Cxt
forall a b. (a -> b) -> a -> b
$ EntityOptions -> [Name]
eoDeriveClasses EntityOptions
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 :: FN
tblName = EntityOptions -> Text -> FN
eoTableName EntityOptions
opts (Text -> FN) -> Text -> FN
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
tnames
fldNames :: [FN]
fldNames = (Name -> FN) -> [Name] -> [FN]
forall a b. (a -> b) -> [a] -> [b]
map (EntityOptions -> Text -> FN
eoColumnNames EntityOptions
opts (Text -> FN) -> (Name -> Text) -> Name -> FN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Text) -> (Name -> [Char]) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase)
([Name] -> [FN]) -> [Name] -> [FN]
forall a b. (a -> b) -> a -> b
$ Con -> [Name]
cFieldNames Con
tcon
VarE Name
ntableName <- [e|tableName|]
VarE Name
nfieldNames <- [e|fieldNames|]
Exp
tblExp <- FN -> Q Exp
forall t. Lift t => t -> Q Exp
lift (FN
tblName :: FN)
[Exp]
fldExp <- (FN -> Q Exp) -> [FN] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FN -> Q Exp
forall t. Lift t => t -> Q Exp
lift ([FN]
fldNames :: [FN])
let tbldec :: Dec
tbldec = Name -> [Clause] -> Dec
FunD Name
ntableName [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB Exp
tblExp) []]
flddec :: Dec
flddec = Name -> [Clause] -> Dec
FunD Name
nfieldNames [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE [Exp]
fldExp) []]
#if MIN_VERSION_template_haskell(2,11,0)
ret :: Dec
ret = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
econt [ Dec
iddec, Dec
tbldec, Dec
flddec ]
#else
ret = InstanceD [] econt [ iddec, tbldec, flddec ]
#endif
syndec :: Dec
syndec = Name -> [TyVarBndr] -> Type -> Dec
TySynD ([Char] -> Name
mkName [Char]
idname) [] (Type -> Type -> Type
AppT (Name -> Type
ConT Name
entityIdName) (Name -> Type
ConT Name
tname))
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
ret, Dec
syndec]