module Database.PostgreSQL.Query.TH
(
deriveFromRow
, deriveToRow
, deriveEntity
, deriveEverything
, EntityOptions(..)
, embedSql
, sqlFile
, sqlExp
, sqlExpEmbed
, sqlExpFile
) where
import Prelude
import Control.Applicative
import Data.Default
import Data.FileEmbed ( embedFile )
import Database.PostgreSQL.Query.Entity ( Entity(..) )
import Database.PostgreSQL.Query.TH.SqlExp
import Database.PostgreSQL.Simple.FromRow ( FromRow(..), field )
import Database.PostgreSQL.Simple.ToRow ( ToRow(..) )
import Database.PostgreSQL.Simple.Types ( Query(..) )
import Language.Haskell.TH
cName :: (Monad m) => Con -> m Name
cName (NormalC n _) = return n
cName (RecC n _) = return n
cName _ = error "Constructor must be simple"
cArgs :: (Monad m) => Con -> m Int
cArgs (NormalC _ n) = return $ length n
cArgs (RecC _ n) = return $ length n
cArgs _ = error "Constructor must be simple"
cFieldNames :: Con -> [Name]
cFieldNames (RecC _ vst) = map (\(a, _, _) -> a) vst
cFieldNames _ = error "Constructor must be a record (product type with field names)"
deriveFromRow :: Name -> Q [Dec]
deriveFromRow t = do
TyConI (DataD _ _ _ [con] _) <- reify t
cname <- cName con
cargs <- cArgs con
[d|instance FromRow $(return $ ConT t) where
fromRow = $(fieldsQ cname cargs)|]
where
fieldsQ cname cargs = do
fld <- [| field |]
fmp <- [| (<$>) |]
fap <- [| (<*>) |]
return $ UInfixE (ConE cname) fmp (fapChain cargs fld fap)
fapChain 0 _ _ = error "there must be at least 1 field in constructor"
fapChain 1 fld _ = fld
fapChain n fld fap = UInfixE fld fap (fapChain (n1) fld fap)
lookupVNameErr :: String -> Q Name
lookupVNameErr name =
lookupValueName name >>=
maybe (error $ "could not find identifier: " ++ name)
return
deriveToRow :: Name -> Q [Dec]
deriveToRow t = do
TyConI (DataD _ _ _ [con] _) <- reify t
cname <- cName con
cargs <- cArgs con
cvars <- sequence
$ replicate cargs
$ newName "a"
[d|instance ToRow $(return $ ConT t) where
toRow $(return $ ConP cname $ map VarP cvars) = $(toFields cvars)|]
where
toFields v = do
tof <- lookupVNameErr "toField"
return $ ListE
$ map
(\e -> AppE (VarE tof) (VarE e))
v
data EntityOptions = EntityOptions
{ eoTableName :: String -> String
, eoColumnNames :: String -> String
, eoDeriveClasses :: [Name]
, eoIdType :: Name
}
instance Default EntityOptions where
def = EntityOptions
{ eoTableName = id
, eoColumnNames = id
, eoDeriveClasses = [''Ord, ''Eq, ''Show]
, eoIdType = ''Integer
}
deriveEntity :: EntityOptions -> Name -> Q [Dec]
deriveEntity opts tname = do
TyConI (DataD _ _ _ [tcon] _) <- reify tname
econt <- [t|Entity $(conT tname)|]
ConT entityIdName <- [t|EntityId|]
let tnames = nameBase tname
idname = tnames ++ "Id"
unidname = "get" ++ idname
idtype = ConT (eoIdType opts)
idcon = RecC (mkName idname)
[(mkName unidname, NotStrict, idtype)]
iddec = NewtypeInstD [] entityIdName [ConT tname]
idcon (eoDeriveClasses opts)
tblName = eoTableName opts tnames
fldNames = map (eoColumnNames opts . nameBase) $ cFieldNames tcon
VarE ntableName <- [e|tableName|]
VarE nfieldNames <- [e|fieldNames|]
let tbldec = FunD ntableName [Clause [WildP] (NormalB $ LitE $ stringL tblName) []]
flddec = FunD nfieldNames [Clause [WildP] (NormalB $ ListE $ map (LitE . stringL) fldNames) []]
ret = InstanceD [] econt
[ iddec, tbldec, flddec ]
syndec = TySynD (mkName idname) [] (AppT (ConT entityIdName) (ConT tname))
return [ret, syndec]
deriveEverything :: EntityOptions -> Name -> Q [Dec]
deriveEverything opts tname = fmap concat $ sequence
[ deriveToRow tname
, deriveFromRow tname
, deriveEntity opts tname ]
embedSql :: String
-> Q Exp
embedSql path = do
[e| (Query ( $(embedFile path) )) |]
sqlFile :: String
-> Q Exp
sqlFile s = do
embedSql $ "sql/" ++ s ++ ".sql"