{-# 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 typeCon :: 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
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

-- | 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
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

-- | 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
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           -- ^ 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 :: 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)

-- | Generate all HDBC templates using system catalog informations 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' :: 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

-- | Generate all HDBC templates using system catalog informations.
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 :: 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 []

-- | 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 :: 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)