{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- |
-- Module      : Database.HDBC.Query.TH
-- Copyright   : 2013-2018 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module contains templates to generate Haskell record types
-- and HDBC instances correspond to RDB table schema.
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   -- ^ Record type constructor.
                          -> Q [Dec] -- ^ Instance declarations.
defineInstancesForSqlValue :: TypeQ -> Q [Dec]
defineInstancesForSqlValue TypeQ
typeCon = do
  [d| instance FromSql SqlValue $typeCon
      instance ToSql SqlValue $typeCon
    |]

-- | Generate all persistable templates against defined record like type constructor.
makeRelationalRecord' :: Config
                      -> Name    -- ^ Type constructor name
                      -> Q [Dec] -- ^ Result declaration
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

-- | Generate all persistable templates against defined record like type constructor.
makeRelationalRecord :: Name    -- ^ Type constructor name
                     -> Q [Dec] -- ^ Result declaration
makeRelationalRecord :: Name -> Q [Dec]
makeRelationalRecord = Config -> Name -> Q [Dec]
makeRelationalRecord' Config
defaultConfig

-- | Generate all HDBC templates about table except for constraint keys.
defineTableDefault' :: Config            -- ^ Configuration to generate query with
                    -> String            -- ^ Schema name
                    -> String            -- ^ Table name
                    -> [(String, TypeQ)] -- ^ List of column name and type
                    -> [Name]            -- ^ Derivings
                    -> Q [Dec]           -- ^ Result declaration
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

-- | Generate all HDBC templates about table.
defineTableDefault :: Config            -- ^ Configuration to generate query with
                   -> String            -- ^ Schema name
                   -> String            -- ^ Table name
                   -> [(String, TypeQ)] -- ^ List of column name and type
                   -> [Name]            -- ^ Derivings
                   -> [Int]             -- ^ Indexes to represent primary key
                   -> Maybe Int         -- ^ Index of not-null key
                   -> Q [Dec]           -- ^ Result declaration
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           -- ^ Connect action to system catalog database
                     -> Driver conn       -- ^ Driver definition
                     -> String            -- ^ Schema name
                     -> String            -- ^ Table name
                     -> [(String, TypeQ)] -- ^ Additional column-name and column-type mapping to overwrite default
                     -> [Name]            -- ^ Derivings
                     -> Q [Dec]           -- ^ Result declaration
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)

-- | Generate all HDBC templates using system catalog information with specified config.
defineTableFromDB' :: IConnection conn
                   => IO conn           -- ^ Connect action to system catalog database
                   -> Driver conn       -- ^ Driver definition
                   -> String            -- ^ Schema name
                   -> String            -- ^ Table name
                   -> [(String, TypeQ)] -- ^ Additional column-name and column-type mapping to overwrite default
                   -> [Name]            -- ^ Derivings
                   -> Q [Dec]           -- ^ Result declaration
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

-- | Generate all HDBC templates using system catalog information.
defineTableFromDB :: IConnection conn
                  => IO conn     -- ^ Connect action to system catalog database
                  -> Driver conn -- ^ Driver definition
                  -> String      -- ^ Schema name
                  -> String      -- ^ Table name
                  -> [Name]      -- ^ Derivings
                  -> Q [Dec]     -- ^ Result declaration
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 []

-- | Verify composed 'Query' and inline it in compile type.
inlineVerifiedQuery :: IConnection conn
                    => IO conn      -- ^ Connect action to system catalog database
                    -> Name         -- ^ Top-level variable name which has 'Relation' type
                    -> Relation p r -- ^ Object which has 'Relation' type
                    -> Config       -- ^ Configuration to generate SQL
                    -> QuerySuffix  -- ^ suffix SQL words
                    -> String       -- ^ Variable name to define as inlined query
                    -> Q [Dec]      -- ^ Result declarations
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)