{-# 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, Type (AppT, ConT), 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
-> Driver conn
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> Q [Dec]
tableAlongWithSchema connect drv scm tbl cmap derives = do
let config = driverConfig drv
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
let liftMaybe tyQ sty = do
ty <- tyQ
case ty of
(AppT (ConT n) _) | n == ''Maybe -> [t| Maybe $(sty) |]
_ -> sty
cols1 = [ (,) cn . maybe ty (liftMaybe ty) . Map.lookup cn $ Map.fromList cmap | (cn, ty) <- cols ]
defineTableDefault config scm tbl cols1 derives primaryIxs (listToMaybe notNullIdxs)
defineTableFromDB' :: IConnection conn
=> IO conn
-> Driver conn
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> Q [Dec]
defineTableFromDB' = tableAlongWithSchema
defineTableFromDB :: IConnection conn
=> IO conn
-> Driver conn
-> String
-> String
-> [Name]
-> Q [Dec]
defineTableFromDB connect driver tbl scm = tableAlongWithSchema connect driver tbl scm []
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)