{-# 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, untypeQuery, relationalQuery_, 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 :: TypeQ -> Q [Dec]
defineInstancesForSqlValue TypeQ
typeCon = do
[d| instance FromSql SqlValue $typeCon
instance ToSql SqlValue $typeCon
|]
makeRelationalRecord' :: Config
-> Name
-> Q [Dec]
makeRelationalRecord' :: Config -> Name -> Q [Dec]
makeRelationalRecord' Config
config Name
recTypeName = do
[Dec]
rr <- Config -> Name -> Q [Dec]
Relational.makeRelationalRecordDefault' Config
config Name
recTypeName
(((TypeQ
typeCon, [Name]
avs), ExpQ
_), (Maybe [Name], [TypeQ])
_) <- Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType Name
recTypeName
[Dec]
ps <- TypeQ -> TypeQ -> [Name] -> Q [Dec]
defineSqlPersistableInstances [t| SqlValue |] TypeQ
typeCon [Name]
avs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
rr forall a. [a] -> [a] -> [a]
++ [Dec]
ps
makeRelationalRecord :: Name
-> Q [Dec]
makeRelationalRecord :: Name -> Q [Dec]
makeRelationalRecord = Config -> Name -> Q [Dec]
makeRelationalRecord' Config
defaultConfig
defineTableDefault' :: Config
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> Q [Dec]
defineTableDefault' :: Config
-> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
defineTableDefault' Config
config String
schema String
table [(String, TypeQ)]
columns [Name]
derives = do
[Dec]
modelD <- Config
-> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
Relational.defineTableTypesAndRecord Config
config String
schema String
table [(String, TypeQ)]
columns [Name]
derives
[Dec]
sqlvD <- TypeQ -> TypeQ -> [Name] -> Q [Dec]
defineSqlPersistableInstances [t| SqlValue |]
(forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate (NameConfig -> NameConfig
recordConfig forall a b. (a -> b) -> a -> b
$ Config -> NameConfig
nameConfig Config
config) String
schema String
table)
[]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
modelD forall a. [a] -> [a] -> [a]
++ [Dec]
sqlvD
defineTableDefault :: Config
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> [Int]
-> Maybe Int
-> Q [Dec]
defineTableDefault :: Config
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> [Int]
-> Maybe Int
-> Q [Dec]
defineTableDefault Config
config String
schema String
table [(String, TypeQ)]
columns [Name]
derives [Int]
primary Maybe Int
notNull = do
[Dec]
modelD <- Config
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> [Int]
-> Maybe Int
-> Q [Dec]
Relational.defineTable Config
config String
schema String
table [(String, TypeQ)]
columns [Name]
derives [Int]
primary Maybe Int
notNull
[Dec]
sqlvD <- TypeQ -> Q [Dec]
defineInstancesForSqlValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate (NameConfig -> NameConfig
recordConfig forall a b. (a -> b) -> a -> b
$ Config -> NameConfig
nameConfig Config
config) String
schema String
table
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
modelD forall a. [a] -> [a] -> [a]
++ [Dec]
sqlvD
tableAlongWithSchema :: IConnection conn
=> IO conn
-> Driver conn
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> Q [Dec]
tableAlongWithSchema :: forall conn.
IConnection conn =>
IO conn
-> Driver conn
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> Q [Dec]
tableAlongWithSchema IO conn
connect Driver conn
drv String
scm String
tbl [(String, TypeQ)]
cmap [Name]
derives = do
let config :: Config
config = forall conn. Driver conn -> Config
driverConfig Driver conn
drv
getDBinfo :: IO ((([(String, TypeQ)], [Int]), [String]), [Log])
getDBinfo = do
LogChan
logChan <- IO LogChan
emptyLogChan
(([(String, TypeQ)], [Int]), [String])
infoP <- forall conn a.
IConnection conn =>
IO conn -> (conn -> IO a) -> IO a
withConnectionIO IO conn
connect
(\conn
conn ->
(,)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall conn.
IConnection conn =>
Driver conn
-> conn
-> LogChan
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
getFields Driver conn
drv conn
conn LogChan
logChan String
scm String
tbl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall conn.
Driver conn -> conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey Driver conn
drv conn
conn LogChan
logChan String
scm String
tbl)
(,) (([(String, TypeQ)], [Int]), [String])
infoP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LogChan -> IO [Log]
takeLogs LogChan
logChan
((([(String, TypeQ)]
cols, [Int]
notNullIdxs), [String]
primaryCols), [Log]
logs) <- forall a. IO a -> Q a
runIO IO ((([(String, TypeQ)], [Int]), [String]), [Log])
getDBinfo
let reportWarning' :: String -> Q ()
reportWarning'
| Config -> Bool
enableWarning Config
config = String -> Q ()
reportWarning
| Bool
otherwise = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
reportVerbose :: String -> Q ()
reportVerbose
| Config -> Bool
verboseAsCompilerWarning Config
config = String -> Q ()
reportWarning
| Bool
otherwise = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall t.
(String -> t) -> (String -> t) -> (String -> t) -> Log -> t
foldLog String -> Q ()
reportVerbose String -> Q ()
reportWarning' String -> Q ()
reportError) [Log]
logs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
primaryCols) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q ()
reportWarning'
forall a b. (a -> b) -> a -> b
$ String
"getPrimaryKey: Primary key not found for table: " forall a. [a] -> [a] -> [a]
++ String
scm forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
tbl
let colIxMap :: Map String Int
colIxMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [String
c | (String
c, TypeQ
_) <- [(String, TypeQ)]
cols] [(Int
0 :: Int) .. ]
ixLookups :: [(String, Maybe Int)]
ixLookups = [ (String
k, forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
k Map String Int
colIxMap) | String
k <- [String]
primaryCols ]
warnLk :: String -> Maybe a -> Q ()
warnLk String
k = forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(String -> Q ()
reportWarning forall a b. (a -> b) -> a -> b
$ String
"defineTableFromDB: fail to find index of pkey - " forall a. [a] -> [a] -> [a]
++ String
k forall a. [a] -> [a] -> [a]
++ String
". Something wrong!!")
(forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ())
primaryIxs :: [Int]
primaryIxs = forall a. a -> Maybe a -> a
fromMaybe [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(String, Maybe Int)]
ixLookups
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {a}. String -> Maybe a -> Q ()
warnLk) [(String, Maybe Int)]
ixLookups
let liftMaybe :: m Type -> m Type -> m Type
liftMaybe m Type
tyQ m Type
sty = do
Type
ty <- m Type
tyQ
case Type
ty of
(AppT (ConT Name
n) Type
_) | Name
n forall a. Eq a => a -> a -> Bool
== ''Maybe -> [t| Maybe $(sty) |]
Type
_ -> m Type
sty
cols1 :: [(String, TypeQ)]
cols1 = [ (,) String
cn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeQ
ty (forall {m :: * -> *}. Quote m => m Type -> m Type -> m Type
liftMaybe TypeQ
ty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
cn forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, TypeQ)]
cmap | (String
cn, TypeQ
ty) <- [(String, TypeQ)]
cols ]
Config
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> [Int]
-> Maybe Int
-> Q [Dec]
defineTableDefault Config
config String
scm String
tbl [(String, TypeQ)]
cols1 [Name]
derives [Int]
primaryIxs (forall a. [a] -> Maybe a
listToMaybe [Int]
notNullIdxs)
defineTableFromDB' :: IConnection conn
=> IO conn
-> Driver conn
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> Q [Dec]
defineTableFromDB' :: forall conn.
IConnection conn =>
IO conn
-> Driver conn
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> Q [Dec]
defineTableFromDB' = forall conn.
IConnection conn =>
IO conn
-> Driver conn
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> Q [Dec]
tableAlongWithSchema
defineTableFromDB :: IConnection conn
=> IO conn
-> Driver conn
-> String
-> String
-> [Name]
-> Q [Dec]
defineTableFromDB :: forall conn.
IConnection conn =>
IO conn -> Driver conn -> String -> String -> [Name] -> Q [Dec]
defineTableFromDB IO conn
connect Driver conn
driver String
tbl String
scm = forall conn.
IConnection conn =>
IO conn
-> Driver conn
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> Q [Dec]
tableAlongWithSchema IO conn
connect Driver conn
driver String
tbl String
scm []
inlineVerifiedQuery :: IConnection conn
=> IO conn
-> Name
-> Relation p r
-> Config
-> QuerySuffix
-> String
-> Q [Dec]
inlineVerifiedQuery :: forall conn p r.
IConnection conn =>
IO conn
-> Name
-> Relation p r
-> Config
-> QuerySuffix
-> String
-> Q [Dec]
inlineVerifiedQuery IO conn
connect Name
relVar Relation p r
rel Config
config QuerySuffix
sufs String
qns = do
(Type
p, Type
r) <- Name -> Q (Type, Type)
Relational.reifyRelation Name
relVar
let sql :: String
sql = forall p a. Query p a -> String
untypeQuery forall a b. (a -> b) -> a -> b
$ forall p r. Config -> Relation p r -> QuerySuffix -> Query p r
relationalQuery_ Config
config Relation p r
rel QuerySuffix
sufs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
verboseAsCompilerWarning Config
config) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q ()
reportWarning forall a b. (a -> b) -> a -> b
$ String
"Verify with prepare: " forall a. [a] -> [a] -> [a]
++ String
sql
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ forall conn a.
IConnection conn =>
IO conn -> (conn -> IO a) -> IO a
withConnectionIO IO conn
connect (\conn
conn -> forall conn. IConnection conn => conn -> String -> IO Statement
prepare conn
conn String
sql)
TypeQ -> TypeQ -> String -> VarName -> Q [Dec]
Relational.unsafeInlineQuery (forall (m :: * -> *) a. Monad m => a -> m a
return Type
p) (forall (m :: * -> *) a. Monad m => a -> m a
return Type
r) String
sql (String -> VarName
varCamelcaseName String
qns)