{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Database.HDBC.Query.TH (
makeRelationalRecord,
makeRelationalRecord',
defineTableDefault',
defineTableDefault,
defineTableFromDB',
defineTableFromDB,
inlineVerifiedQuery
) where
import Control.Applicative ((<$>), pure, (<*>))
import Control.Monad (when, void)
import Data.Maybe (listToMaybe, fromMaybe)
import qualified Data.Map as Map
import Data.Functor.ProductIsomorphic.TH (reifyRecordType)
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, defineSqlPersistableInstances)
import Database.Relational
(Config, nameConfig, recordConfig, enableWarning, verboseAsCompilerWarning,
defaultConfig, Relation, relationalQuerySQL, QuerySuffix)
import qualified Database.Relational.TH as Relational
import Database.HDBC.Session (withConnectionIO)
import Database.HDBC.Record.Persistable ()
import Database.HDBC.Schema.Driver
(foldLog, emptyLogChan, takeLogs, Driver, driverConfig, getFields, getPrimaryKey)
defineInstancesForSqlValue :: TypeQ
-> Q [Dec]
defineInstancesForSqlValue typeCon = do
[d| instance FromSql SqlValue $typeCon
instance ToSql SqlValue $typeCon
|]
makeRelationalRecord' :: Config
-> Name
-> Q [Dec]
makeRelationalRecord' config recTypeName = do
rr <- Relational.makeRelationalRecordDefault' config recTypeName
(((typeCon, avs), _), _) <- reifyRecordType recTypeName
ps <- defineSqlPersistableInstances [t| SqlValue |] typeCon avs
return $ rr ++ ps
makeRelationalRecord :: Name
-> Q [Dec]
makeRelationalRecord = makeRelationalRecord' defaultConfig
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 <- defineSqlPersistableInstances [t| SqlValue |]
(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
tableAlongWithSchema :: IConnection conn
=> IO conn
-> Config
-> Driver conn
-> String
-> String
-> [Name]
-> Q [Dec]
tableAlongWithSchema connect config drv scm tbl derives = do
let getDBinfo = do
logChan <- emptyLogChan
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
let reportWarning'
| enableWarning config = reportWarning
| otherwise = const $ pure ()
reportVerbose
| verboseAsCompilerWarning config = reportWarning
| otherwise = const $ pure ()
mapM_ (foldLog reportVerbose 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)
{-# DEPRECATED defineTableFromDB' "Use defineTableFromDB with updated driverConfig field of Driver argument." #-}
defineTableFromDB' :: IConnection conn
=> IO conn
-> Config
-> Driver conn
-> String
-> String
-> [Name]
-> Q [Dec]
defineTableFromDB' = tableAlongWithSchema
defineTableFromDB :: IConnection conn
=> IO conn
-> Driver conn
-> String
-> String
-> [Name]
-> Q [Dec]
defineTableFromDB connect driver = tableAlongWithSchema connect (driverConfig driver) driver
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)