module Database.HDBC.Query.TH (
makeRecordPersistableDefault,
defineTableDefault',
defineTableDefault,
defineTableFromDB',
defineTableFromDB,
inlineVerifiedQuery
) where
import Data.Maybe (listToMaybe, fromMaybe)
import qualified Data.Map as Map
import Control.Monad (when)
import Database.HDBC (IConnection, SqlValue, prepare)
import Language.Haskell.TH (Q, runIO, Name, TypeQ, Dec)
import Language.Haskell.TH.Name.CamelCase (ConName, varCamelcaseName)
import Language.Haskell.TH.Lib.Extra (reportWarning, reportMessage)
import Database.Record.TH (makeRecordPersistableWithSqlTypeDefault)
import qualified Database.Record.TH as Record
import Database.Relational.Query (Relation, Config, defaultConfig, relationalQuerySQL)
import Database.Relational.Query.SQL (QuerySuffix)
import qualified Database.Relational.Query.TH as Relational
import Database.HDBC.Session (withConnectionIO)
import Database.HDBC.Record.Persistable ()
import Database.HDBC.Schema.Driver (Driver, getFields, getPrimaryKey)
makeRecordPersistableDefault :: Name
-> Q [Dec]
makeRecordPersistableDefault recTypeName = do
rr <- Relational.makeRelationalRecordDefault recTypeName
(pair, (_mayNs, cts)) <- Record.reifyRecordType recTypeName
let width = length cts
ps <- Record.makeRecordPersistableWithSqlType [t| SqlValue |]
(Record.persistableFunctionNamesDefault recTypeName) pair width
return $ rr ++ ps
defineTableDefault' :: Config
-> String
-> String
-> [(String, TypeQ)]
-> [ConName]
-> Q [Dec]
defineTableDefault' config schema table columns derives = do
modelD <- Relational.defineTableTypesAndRecordDefault config schema table columns derives
sqlvD <- makeRecordPersistableWithSqlTypeDefault [t| SqlValue |] table $ length columns
return $ modelD ++ sqlvD
defineTableDefault :: Config
-> String
-> String
-> [(String, TypeQ)]
-> [ConName]
-> [Int]
-> Maybe Int
-> Q [Dec]
defineTableDefault config schema table columns derives primary notNull = do
modelD <- Relational.defineTableDefault config schema table columns derives primary notNull
sqlvD <- makeRecordPersistableWithSqlTypeDefault [t| SqlValue |] table $ length columns
return $ modelD ++ sqlvD
defineTableFromDB' :: IConnection conn
=> IO conn
-> Config
-> Driver conn
-> String
-> String
-> [ConName]
-> Q [Dec]
defineTableFromDB' connect config drv scm tbl derives = do
let getDBinfo =
withConnectionIO connect
(\conn -> do
(cols, notNullIdxs) <- getFields drv conn scm tbl
primCols <- getPrimaryKey drv conn scm tbl
return (cols, notNullIdxs, primCols) )
(cols, notNullIdxs, primaryCols) <- runIO getDBinfo
when (null primaryCols) . reportWarning
$ "getPrimaryKey: Primary key not found for table: " ++ scm ++ "." ++ tbl
let colIxMap = Map.fromList $ zip [c | (c, _) <- cols] [(0 :: Int) .. ]
ixLookups = [ (k, Map.lookup k colIxMap) | k <- primaryCols ]
warnLk k = maybe
(reportWarning $ "defineTableFromDB: fail to find index of pkey - " ++ k ++ ". Something wrong!!")
(const $ return ())
primaryIxs = fromMaybe [] . sequence $ map snd ixLookups
mapM_ (uncurry warnLk) ixLookups
defineTableDefault config scm tbl cols derives primaryIxs (listToMaybe notNullIdxs)
defineTableFromDB :: IConnection conn
=> IO conn
-> Driver conn
-> String
-> String
-> [ConName]
-> Q [Dec]
defineTableFromDB connect = defineTableFromDB' connect defaultConfig
inlineVerifiedQuery :: IConnection conn
=> IO conn
-> Name
-> Relation p r
-> Config
-> QuerySuffix
-> String
-> Q [Dec]
inlineVerifiedQuery connect relVar rel config sufs qns = do
(p, r) <- Relational.reifyRelation relVar
let sql = relationalQuerySQL config rel sufs
_ <- runIO $ withConnectionIO connect
(\conn -> do
reportMessage $ "Verify with prepare: " ++ sql
prepare conn sql)
Relational.unsafeInlineQuery (return p) (return r) sql (varCamelcaseName qns)