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