{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Database.HDBC.Query.TH (
makeRelationalRecord,
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 (ToSql, FromSql)
import Database.Record.TH (recordTemplate, reifyRecordType)
import Database.Relational.Query
(Config, nameConfig, recordConfig, verboseAsCompilerWarning, defaultConfig,
Relation, 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)
defineInstancesForSqlValue :: TypeQ
-> Q [Dec]
defineInstancesForSqlValue typeCon = do
[d| instance FromSql SqlValue $typeCon
instance ToSql SqlValue $typeCon
|]
makeRelationalRecord :: Name
-> Q [Dec]
makeRelationalRecord recTypeName = do
rr <- Relational.makeRelationalRecordDefault recTypeName
((typeCon, _), _) <- reifyRecordType recTypeName
ps <- defineInstancesForSqlValue typeCon
return $ rr ++ ps
{-# DEPRECATED makeRecordPersistableDefault "Use makeRelationalRecord instead of this." #-}
makeRecordPersistableDefault :: Name
-> Q [Dec]
makeRecordPersistableDefault = makeRelationalRecord
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 <- defineInstancesForSqlValue . fst $ recordTemplate (recordConfig $ nameConfig config) schema table
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 <- defineInstancesForSqlValue . fst $ recordTemplate (recordConfig $ nameConfig config) schema table
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)