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.Applicative ((<$>), (<*>))
import Control.Monad (when, void)
import Database.HDBC (IConnection, SqlValue, prepare)
import Language.Haskell.TH (Q, runIO, Name, TypeQ, Dec)
import Language.Haskell.TH.Name.CamelCase (varCamelcaseName)
import Language.Haskell.TH.Lib.Extra (reportWarning, reportError)
import Database.Record.TH (makeRecordPersistableWithSqlTypeDefault)
import qualified Database.Record.TH as Record
import Database.Relational.Query
(Relation, Config, verboseAsCompilerWarning, defaultConfig,
relationalQuerySQL, QuerySuffix)
import qualified Database.Relational.Query.TH as Relational
import Database.HDBC.Session (withConnectionIO)
import Database.HDBC.Record.Persistable ()
import Database.HDBC.Schema.Driver
(runLog, newLogChan, takeLogs, 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)]
-> [Name]
-> Q [Dec]
defineTableDefault' config schema table columns derives = do
modelD <- Relational.defineTableTypesAndRecord config schema table columns derives
sqlvD <- makeRecordPersistableWithSqlTypeDefault [t| SqlValue |] schema table $ length columns
return $ modelD ++ sqlvD
defineTableDefault :: Config
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> [Int]
-> Maybe Int
-> Q [Dec]
defineTableDefault config schema table columns derives primary notNull = do
modelD <- Relational.defineTable config schema table columns derives primary notNull
sqlvD <- makeRecordPersistableWithSqlTypeDefault [t| SqlValue |] schema table $ length columns
return $ modelD ++ sqlvD
defineTableFromDB' :: IConnection conn
=> IO conn
-> Config
-> Driver conn
-> String
-> String
-> [Name]
-> Q [Dec]
defineTableFromDB' connect config drv scm tbl derives = do
let getDBinfo = do
logChan <- newLogChan $ verboseAsCompilerWarning config
infoP <- withConnectionIO connect
(\conn ->
(,)
<$> getFields drv conn logChan scm tbl
<*> getPrimaryKey drv conn logChan scm tbl)
(,) infoP <$> takeLogs logChan
(((cols, notNullIdxs), primaryCols), logs) <- runIO getDBinfo
mapM_ (runLog reportWarning reportError) logs
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
-> [Name]
-> 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
when (verboseAsCompilerWarning config) . reportWarning $ "Verify with prepare: " ++ sql
void . runIO $ withConnectionIO connect (\conn -> prepare conn sql)
Relational.unsafeInlineQuery (return p) (return r) sql (varCamelcaseName qns)