{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE CPP #-}

-- |
-- Module      : Database.Relational.TH
-- Copyright   : 2013-2019 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines templates for Haskell record type and type class instances
-- to define column projection on SQL query like Haskell records.
-- Templates are generated by also using functions of "Database.Record.TH" module,
-- so mapping between list of untyped SQL type and Haskell record type will be done too.
module Database.Relational.TH (
  -- * All templates about table
  defineTable,

  -- * Inlining typed 'Query'
  unsafeInlineQuery,
  inlineQuery,

  -- * Column projections and basic 'Relation' for Haskell record
  defineTableTypesAndRecord,

  -- * Constraint key templates
  defineHasPrimaryKeyInstance,
  defineHasPrimaryKeyInstanceWithConfig,
  defineHasNotNullKeyInstance,
  defineHasNotNullKeyInstanceWithConfig,
  defineScalarDegree,

  -- * Column projections
  defineColumnsDefault, defineOverloadedColumnsDefault,
  defineColumns, defineOverloadedColumns,

  defineTuplePi,

  -- * Table metadata type and basic 'Relation'
  defineTableTypes, defineTableTypesWithConfig,

  -- * Basic SQL templates generate rules
  definePrimaryQuery,
  definePrimaryUpdate,

  -- * Var expression templates
  derivationExpDefault,
  tableVarExpDefault,
  relationVarExp,

  -- * Derived SQL templates from table definitions
  defineSqlsWithPrimaryKey,
  defineSqlsWithPrimaryKeyDefault,

  -- * Reify
  makeRelationalRecordDefault,
  makeRelationalRecordDefault',
  reifyRelation,
  ) where

import Data.Char (toUpper, toLower)
import Data.List (foldl1')
import Data.Array.IArray ((!))
import Data.Functor.ProductIsomorphic.TH
  (reifyRecordType, defineProductConstructor)
import Data.Functor.ProductIsomorphic.Unsafe (ProductConstructor (..))

import Language.Haskell.TH
  (Name, nameBase, Q, reify, Dec, instanceD, ExpQ, stringE, listE,
   TypeQ, Type (AppT, ConT), varT, tupleT, appT, arrowT)
import Language.Haskell.TH.Compat.Reify (unVarI)
import Language.Haskell.TH.Compat.Constraint (classP)
import Language.Haskell.TH.Name.CamelCase
  (VarName, varName, ConName (ConName), conName,
   varCamelcaseName, toVarExp, toTypeCon)
import Language.Haskell.TH.Lib.Extra (simpleValD, maybeD, integralE)

import Database.Record.TH
  (columnOffsetsVarNameDefault, recordTypeName, recordTemplate,
   defineRecordTypeWithConfig, defineHasColumnConstraintInstance)
import qualified Database.Record.TH as Record

import Database.Relational
  (Table, Pi, id', Relation, LiteralSQL,
   NameConfig (..), SchemaNameMode (..), IdentifierQuotation (..), defaultConfig,
   Config (normalizedTableName, disableOverloadedProjection, disableSpecializedProjection,
           schemaNameMode, nameConfig, identifierQuotation),
   Query, untypeQuery, relationalQuery_, relationalQuery, KeyUpdate,
   Insert, insert, InsertQuery, insertQuery,
   HasConstraintKey(constraintKey), Primary, NotNull, primarySelect, primaryUpdate)

import Database.Relational.InternalTH.Base (defineTuplePi, defineRecordProjections)
import Database.Relational.Scalar (defineScalarDegree)
import Database.Relational.Constraint (unsafeDefineConstraintKey)
import Database.Relational.Table (TableDerivable (..))
import qualified Database.Relational.Table as Table
import Database.Relational.Relation (derivedRelation)
import Database.Relational.SimpleSql (QuerySuffix)
import Database.Relational.Type (unsafeTypedQuery)
import qualified Database.Relational.Pi.Unsafe as UnsafePi

import qualified Database.Relational.InternalTH.Overloaded as Overloaded

-- | Rule template to infer constraint key.
defineHasConstraintKeyInstance :: TypeQ   -- ^ Constraint type
                               -> TypeQ   -- ^ Record type
                               -> TypeQ   -- ^ Key type
                               -> [Int]   -- ^ Indexes specifies key
                               -> Q [Dec] -- ^ Result 'HasConstraintKey' declaration
defineHasConstraintKeyInstance :: TypeQ -> TypeQ -> TypeQ -> [Int] -> Q [Dec]
defineHasConstraintKeyInstance TypeQ
constraint TypeQ
recType TypeQ
colType [Int]
indexes =
  [d| instance HasConstraintKey $constraint $recType $colType  where
        constraintKey = unsafeDefineConstraintKey $(listE [integralE ix | ix <- indexes])
    |]

-- | Rule template to infer primary key.
defineHasPrimaryKeyInstance :: TypeQ   -- ^ Record type
                            -> TypeQ   -- ^ Key type
                            -> [Int]   -- ^ Indexes specifies key
                            -> Q [Dec] -- ^ Result constraint key declarations
defineHasPrimaryKeyInstance :: TypeQ -> TypeQ -> [Int] -> Q [Dec]
defineHasPrimaryKeyInstance TypeQ
recType TypeQ
colType [Int]
indexes = do
  [Dec]
kc <- TypeQ -> [Int] -> Q [Dec]
Record.defineHasPrimaryKeyInstance TypeQ
recType [Int]
indexes
  [Dec]
ck <- TypeQ -> TypeQ -> TypeQ -> [Int] -> Q [Dec]
defineHasConstraintKeyInstance [t| Primary |] TypeQ
recType TypeQ
colType [Int]
indexes
  [Dec]
pp <- TypeQ -> TypeQ -> [Int] -> Q [Dec]
Overloaded.definePrimaryHasProjection TypeQ
recType TypeQ
colType [Int]
indexes
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
kc forall a. [a] -> [a] -> [a]
++ [Dec]
ck forall a. [a] -> [a] -> [a]
++ [Dec]
pp

-- | Rule template to infer primary key.
defineHasPrimaryKeyInstanceWithConfig :: Config  -- ^ configuration parameters
                                      -> String  -- ^ Schema name
                                      -> String  -- ^ Table name
                                      -> TypeQ   -- ^ Column type
                                      -> [Int]   -- ^ Primary key index
                                      -> Q [Dec] -- ^ Declarations of primary constraint key
defineHasPrimaryKeyInstanceWithConfig :: Config -> String -> String -> TypeQ -> [Int] -> Q [Dec]
defineHasPrimaryKeyInstanceWithConfig Config
config String
scm =
  TypeQ -> TypeQ -> [Int] -> Q [Dec]
defineHasPrimaryKeyInstance forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate (NameConfig -> NameConfig
recordConfig forall a b. (a -> b) -> a -> b
$ Config -> NameConfig
nameConfig Config
config) String
scm

-- | Rule template to infer not-null key.
defineHasNotNullKeyInstance :: TypeQ   -- ^ Record type
                            -> Int     -- ^ Column index
                            -> Q [Dec] -- ^ Result 'ColumnConstraint' declaration
defineHasNotNullKeyInstance :: TypeQ -> Int -> Q [Dec]
defineHasNotNullKeyInstance =
  TypeQ -> TypeQ -> Int -> Q [Dec]
defineHasColumnConstraintInstance [t| NotNull |]

-- | Rule template to infer not-null key.
defineHasNotNullKeyInstanceWithConfig :: Config  -- ^ configuration parameters
                                      -> String  -- ^ Schema name
                                      -> String  -- ^ Table name
                                      -> Int     -- ^ NotNull key index
                                      -> Q [Dec] -- ^ Declaration of not-null constraint key
defineHasNotNullKeyInstanceWithConfig :: Config -> String -> String -> Int -> Q [Dec]
defineHasNotNullKeyInstanceWithConfig Config
config String
scm =
  TypeQ -> Int -> Q [Dec]
defineHasNotNullKeyInstance forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate (NameConfig -> NameConfig
recordConfig forall a b. (a -> b) -> a -> b
$ Config -> NameConfig
nameConfig Config
config) String
scm


projectionTemplate :: ConName   -- ^ Record type name
                   -> VarName   -- ^ Column declaration variable name
                   -> Int       -- ^ Column leftest index
                   -> TypeQ     -- ^ Column type
                   -> Q [Dec]   -- ^ Column projection path declaration
projectionTemplate :: ConName -> VarName -> Int -> TypeQ -> Q [Dec]
projectionTemplate ConName
recName VarName
var Int
ix TypeQ
colType = do
  let offsetsExp :: ExpQ
offsetsExp = VarName -> ExpQ
toVarExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> VarName
columnOffsetsVarNameDefault forall a b. (a -> b) -> a -> b
$ ConName -> Name
conName ConName
recName
  Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD (VarName -> Name
varName VarName
var)
    [t| Pi $(toTypeCon recName) $colType |]
    [| UnsafePi.definePi $ $offsetsExp ! $(integralE ix) |]

-- | Projection path 'Pi' templates.
defineColumns :: ConName           -- ^ Record type name
              -> [(VarName, TypeQ)] -- ^ Column info list
              -> Q [Dec]           -- ^ Column projection path declarations
defineColumns :: ConName -> [(VarName, TypeQ)] -> Q [Dec]
defineColumns ConName
recTypeName [(VarName, TypeQ)]
cols = do
  let defC :: (VarName, TypeQ) -> Int -> Q [Dec]
defC (VarName
name, TypeQ
typ) Int
ix = ConName -> VarName -> Int -> TypeQ -> Q [Dec]
projectionTemplate ConName
recTypeName VarName
name Int
ix TypeQ
typ
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 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 c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (VarName, TypeQ) -> Int -> Q [Dec]
defC [(VarName, TypeQ)]
cols [Int
0 :: Int ..]

-- | Overloaded projection path 'Pi' templates.
defineOverloadedColumns :: ConName           -- ^ Record type name
                        -> [(String, TypeQ)] -- ^ Column info list
                        -> Q [Dec]           -- ^ Column projection path declarations
defineOverloadedColumns :: ConName -> [(String, TypeQ)] -> Q [Dec]
defineOverloadedColumns ConName
recTypeName [(String, TypeQ)]
cols = do
  let defC :: (String, TypeQ) -> Int -> Q [Dec]
defC (String
name, TypeQ
typ) Int
ix =
        ConName -> String -> Int -> TypeQ -> Q [Dec]
Overloaded.monomorphicProjection ConName
recTypeName String
name Int
ix TypeQ
typ
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 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 c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (String, TypeQ) -> Int -> Q [Dec]
defC [(String, TypeQ)]
cols [Int
0 :: Int ..]

-- | Make projection path templates using default naming rule.
defineColumnsDefault :: ConName           -- ^ Record type name
                     -> [(String, TypeQ)] -- ^ Column info list
                     -> Q [Dec]           -- ^ Column projection path declarations
defineColumnsDefault :: ConName -> [(String, TypeQ)] -> Q [Dec]
defineColumnsDefault ConName
recTypeName [(String, TypeQ)]
cols =
  ConName -> [(VarName, TypeQ)] -> Q [Dec]
defineColumns     ConName
recTypeName [ (String -> VarName
varCamelcaseName forall a b. (a -> b) -> a -> b
$ String
name forall a. [a] -> [a] -> [a]
++ String
"'",             TypeQ
typ) | (String
name, TypeQ
typ) <- [(String, TypeQ)]
cols ]

-- | Make overloaded projection path templates using default naming rule.
defineOverloadedColumnsDefault :: ConName           -- ^ Record type name
                               -> [(String, TypeQ)] -- ^ Column info list
                               -> Q [Dec]           -- ^ Column projection path declarations
defineOverloadedColumnsDefault :: ConName -> [(String, TypeQ)] -> Q [Dec]
defineOverloadedColumnsDefault ConName
recTypeName [(String, TypeQ)]
cols =
  ConName -> [(String, TypeQ)] -> Q [Dec]
defineOverloadedColumns ConName
recTypeName [ (Name -> String
nameBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName -> Name
varName forall a b. (a -> b) -> a -> b
$ String -> VarName
varCamelcaseName String
name, TypeQ
typ) | (String
name, TypeQ
typ) <- [(String, TypeQ)]
cols ]

-- | Rule template to infer table derivations.
defineTableDerivableInstance :: TypeQ -> String -> [String] -> Q [Dec]
defineTableDerivableInstance :: TypeQ -> String -> [String] -> Q [Dec]
defineTableDerivableInstance TypeQ
recordType' String
table [String]
columns =
  [d| instance TableDerivable $recordType' where
        derivedTable = Table.table $(stringE table) $(listE $ map stringE columns)
    |]

-- | Template to define inferred entries from table type.
defineTableDerivations :: VarName -- ^ Table declaration variable name
                       -> VarName -- ^ Relation declaration variable name
                       -> VarName -- ^ Insert statement declaration variable name
                       -> VarName -- ^ InsertQuery statement declaration variable name
                       -> TypeQ   -- ^ Record type
                       -> Q [Dec] -- ^ Table and Relation declaration
defineTableDerivations :: VarName -> VarName -> VarName -> VarName -> TypeQ -> Q [Dec]
defineTableDerivations VarName
tableVar' VarName
relVar' VarName
insVar' VarName
insQVar' TypeQ
recordType' = do
  let tableVar :: Name
tableVar = VarName -> Name
varName VarName
tableVar'
  [Dec]
tableDs <- Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD Name
tableVar [t| Table $recordType' |]
             [| derivedTable |]
  let relVar :: Name
relVar   = VarName -> Name
varName VarName
relVar'
  [Dec]
relDs   <- Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD Name
relVar   [t| Relation () $recordType' |]
             [| derivedRelation |]
  let insVar :: Name
insVar   = VarName -> Name
varName VarName
insVar'
  [Dec]
insDs   <- Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD Name
insVar   [t| Insert $recordType' |]
             [| insert id' |]
  let insQVar :: Name
insQVar  = VarName -> Name
varName VarName
insQVar'
  [Dec]
insQDs  <- Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD Name
insQVar  [t| forall p . Relation p $recordType' -> InsertQuery p |]
             [| insertQuery id' |]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]
tableDs, [Dec]
relDs, [Dec]
insDs, [Dec]
insQDs]

-- | 'Table' and 'Relation' templates.
defineTableTypes :: VarName  -- ^ Table declaration variable name
                 -> VarName  -- ^ Relation declaration variable name
                 -> VarName  -- ^ Insert statement declaration variable name
                 -> VarName  -- ^ InsertQuery statement declaration variable name
                 -> TypeQ    -- ^ Record type
                 -> String   -- ^ Table name in SQL ex. FOO_SCHEMA.table0
                 -> [String] -- ^ Column names
                 -> Q [Dec]  -- ^ Table and Relation declaration
defineTableTypes :: VarName
-> VarName
-> VarName
-> VarName
-> TypeQ
-> String
-> [String]
-> Q [Dec]
defineTableTypes VarName
tableVar' VarName
relVar' VarName
insVar' VarName
insQVar' TypeQ
recordType' String
table [String]
columns = do
  [Dec]
iDs <- TypeQ -> String -> [String] -> Q [Dec]
defineTableDerivableInstance TypeQ
recordType' String
table [String]
columns
  [Dec]
dDs <- VarName -> VarName -> VarName -> VarName -> TypeQ -> Q [Dec]
defineTableDerivations VarName
tableVar' VarName
relVar' VarName
insVar' VarName
insQVar' TypeQ
recordType'
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
iDs forall a. [a] -> [a] -> [a]
++ [Dec]
dDs

tableSQL :: Bool -> SchemaNameMode -> IdentifierQuotation -> String -> String -> String
tableSQL :: Bool
-> SchemaNameMode
-> IdentifierQuotation
-> String
-> String
-> String
tableSQL Bool
normalize SchemaNameMode
snm IdentifierQuotation
iq String
schema String
table = case SchemaNameMode
snm of
  SchemaNameMode
SchemaQualified     ->  (String -> String
qt String
normalizeS) forall a. [a] -> [a] -> [a]
++ Char
'.' forall a. a -> [a] -> [a]
: (String -> String
qt String
normalizeT)
  SchemaNameMode
SchemaNotQualified  ->  (String -> String
qt String
normalizeT)
  where
    normalizeS :: String
normalizeS
      | Bool
normalize = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
schema
      | Bool
otherwise = String
schema
    normalizeT :: String
normalizeT
      | Bool
normalize = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
table
      | Bool
otherwise = String
table
    qt :: String -> String
qt = IdentifierQuotation -> String -> String
quote IdentifierQuotation
iq

quote :: IdentifierQuotation -> String -> String
quote :: IdentifierQuotation -> String -> String
quote IdentifierQuotation
NoQuotation   String
s = String
s
quote (Quotation Char
q) String
s = Char
q forall a. a -> [a] -> [a]
: (String -> String
escape String
s) forall a. [a] -> [a] -> [a]
++ Char
q forall a. a -> [a] -> [a]
: []
  where escape :: String -> String
escape = (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Char
c -> if Char
c forall a. Eq a => a -> a -> Bool
== Char
q then [Char
q, Char
q] else [Char
c]))

varNameWithPrefix :: String -> String -> VarName
varNameWithPrefix :: String -> String -> VarName
varNameWithPrefix String
n String
p = String -> VarName
varCamelcaseName forall a b. (a -> b) -> a -> b
$ String
p forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ String
n

derivationVarNameDefault :: String -> VarName
derivationVarNameDefault :: String -> VarName
derivationVarNameDefault =  (String -> String -> VarName
`varNameWithPrefix` String
"derivationFrom")

-- | Make 'TableDerivation' variable expression template from table name using default naming rule.
derivationExpDefault :: String -- ^ Table name string
                     -> ExpQ   -- ^ Result var Exp
derivationExpDefault :: String -> ExpQ
derivationExpDefault =  VarName -> ExpQ
toVarExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> VarName
derivationVarNameDefault

tableVarNameDefault :: String -> VarName
tableVarNameDefault :: String -> VarName
tableVarNameDefault =  (String -> String -> VarName
`varNameWithPrefix` String
"tableOf")

-- | Make 'Table' variable expression template from table name using default naming rule.
tableVarExpDefault :: String -- ^ Table name string
                   -> ExpQ   -- ^ Result var Exp
tableVarExpDefault :: String -> ExpQ
tableVarExpDefault =  VarName -> ExpQ
toVarExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> VarName
tableVarNameDefault

-- | Make 'Relation' variable expression template from table name using specified naming rule.
relationVarExp :: Config -- ^ Configuration which has  naming rules of templates
                         -> String -- ^ Schema name string
                         -> String -- ^ Table name string
                         -> ExpQ   -- ^ Result var Exp
relationVarExp :: Config -> String -> String -> ExpQ
relationVarExp Config
config String
scm = VarName -> ExpQ
toVarExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConfig -> String -> String -> VarName
relationVarName (Config -> NameConfig
nameConfig Config
config) String
scm

-- | Make template for record 'ProductConstructor' instance using specified naming rule.
defineProductConstructorInstanceWithConfig :: Config -> String -> String -> [Q Type] -> Q [Dec]
defineProductConstructorInstanceWithConfig :: Config -> String -> String -> [TypeQ] -> Q [Dec]
defineProductConstructorInstanceWithConfig Config
config String
schema String
table [TypeQ]
colTypes = do
  let (TypeQ
recType, ExpQ
recData) = 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
  [d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recType colTypes) where
        productConstructor = $(recData)
    |]

-- | Make templates about table and column metadatas using specified naming rule.
defineTableTypesWithConfig :: Config            -- ^ Configuration to generate query with
                           -> String            -- ^ Schema name
                           -> String            -- ^ Table name
                           -> [(String, TypeQ)] -- ^ Column names and types and constraint type
                           -> Q [Dec]           -- ^ Result declarations
defineTableTypesWithConfig :: Config -> String -> String -> [(String, TypeQ)] -> Q [Dec]
defineTableTypesWithConfig Config
config String
schema String
table [(String, TypeQ)]
columns = do
  let nmconfig :: NameConfig
nmconfig = Config -> NameConfig
nameConfig Config
config
      recConfig :: NameConfig
recConfig = NameConfig -> NameConfig
recordConfig NameConfig
nmconfig
  [Dec]
tableDs <- VarName
-> VarName
-> VarName
-> VarName
-> TypeQ
-> String
-> [String]
-> Q [Dec]
defineTableTypes
             (String -> VarName
tableVarNameDefault String
table)
             (NameConfig -> String -> String -> VarName
relationVarName NameConfig
nmconfig String
schema String
table)
             (String
table String -> String -> VarName
`varNameWithPrefix` String
"insert")
             (String
table String -> String -> VarName
`varNameWithPrefix` String
"insertQuery")
             (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate NameConfig
recConfig String
schema String
table)
             (Bool
-> SchemaNameMode
-> IdentifierQuotation
-> String
-> String
-> String
tableSQL (Config -> Bool
normalizedTableName Config
config) (Config -> SchemaNameMode
schemaNameMode Config
config) (Config -> IdentifierQuotation
identifierQuotation Config
config) String
schema String
table)
             (forall a b. (a -> b) -> [a] -> [b]
map ((IdentifierQuotation -> String -> String
quote (Config -> IdentifierQuotation
identifierQuotation Config
config)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(String, TypeQ)]
columns)
  let typeName :: ConName
typeName = NameConfig -> String -> String -> ConName
recordTypeName NameConfig
recConfig String
schema String
table
  [Dec]
colsDs  <- if Config -> Bool
disableSpecializedProjection Config
config
             then [d| |]
             else ConName -> [(String, TypeQ)] -> Q [Dec]
defineColumnsDefault     ConName
typeName [(String, TypeQ)]
columns
  [Dec]
pcolsDs <- if Config -> Bool
disableOverloadedProjection Config
config
             then [d| |]
             else ConName -> [(String, TypeQ)] -> Q [Dec]
defineOverloadedColumnsDefault ConName
typeName [(String, TypeQ)]
columns
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
tableDs forall a. [a] -> [a] -> [a]
++ [Dec]
colsDs forall a. [a] -> [a] -> [a]
++ [Dec]
pcolsDs

-- | Make templates about table, column and haskell record using specified naming rule.
defineTableTypesAndRecord :: Config            -- ^ Configuration to generate query with
                          -> String            -- ^ Schema name
                          -> String            -- ^ Table name
                          -> [(String, TypeQ)] -- ^ Column names and types
                          -> [Name]            -- ^ Record derivings
                          -> Q [Dec]           -- ^ Result declarations
defineTableTypesAndRecord :: Config
-> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
defineTableTypesAndRecord Config
config String
schema String
table [(String, TypeQ)]
columns [Name]
derives = do
  let recConfig :: NameConfig
recConfig = NameConfig -> NameConfig
recordConfig forall a b. (a -> b) -> a -> b
$ Config -> NameConfig
nameConfig Config
config
  [Dec]
recD    <- NameConfig
-> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
defineRecordTypeWithConfig NameConfig
recConfig String
schema String
table [(String, TypeQ)]
columns [Name]
derives
  [Dec]
rconD   <- Config -> String -> String -> [TypeQ] -> Q [Dec]
defineProductConstructorInstanceWithConfig Config
config String
schema String
table [TypeQ
t | (String
_, TypeQ
t) <- [(String, TypeQ)]
columns]
  [Dec]
ctD     <- [d| instance LiteralSQL $(fst $ recordTemplate recConfig schema table) |]
  [Dec]
tableDs <- Config -> String -> String -> [(String, TypeQ)] -> Q [Dec]
defineTableTypesWithConfig Config
config String
schema String
table [(String, TypeQ)]
columns
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
recD forall a. [a] -> [a] -> [a]
++ [Dec]
rconD forall a. [a] -> [a] -> [a]
++ [Dec]
ctD forall a. [a] -> [a] -> [a]
++ [Dec]
tableDs

-- | Template of derived primary 'Query'.
definePrimaryQuery :: VarName -- ^ Variable name of result declaration
                   -> TypeQ   -- ^ Parameter type of 'Query'
                   -> TypeQ   -- ^ Record type of 'Query'
                   -> ExpQ    -- ^ 'Relation' expression
                   -> Q [Dec] -- ^ Result 'Query' declaration
definePrimaryQuery :: VarName -> TypeQ -> TypeQ -> ExpQ -> Q [Dec]
definePrimaryQuery VarName
toDef' TypeQ
paramType TypeQ
recType ExpQ
relE = do
  let toDef :: Name
toDef = VarName -> Name
varName VarName
toDef'
  Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD Name
toDef
    [t| Query $paramType $recType |]
    [|  relationalQuery (primarySelect $relE) |]

-- | Template of derived primary 'Update'.
definePrimaryUpdate :: VarName -- ^ Variable name of result declaration
                    -> TypeQ   -- ^ Parameter type of 'Update'
                    -> TypeQ   -- ^ Record type of 'Update'
                    -> ExpQ    -- ^ 'Table' expression
                    -> Q [Dec] -- ^ Result 'Update' declaration
definePrimaryUpdate :: VarName -> TypeQ -> TypeQ -> ExpQ -> Q [Dec]
definePrimaryUpdate VarName
toDef' TypeQ
paramType TypeQ
recType ExpQ
tableE = do
  let toDef :: Name
toDef = VarName -> Name
varName VarName
toDef'
  Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD Name
toDef
    [t| KeyUpdate $paramType $recType |]
    [|  primaryUpdate $tableE |]


-- | SQL templates derived from primary key.
defineSqlsWithPrimaryKey :: VarName -- ^ Variable name of select query definition from primary key
                         -> VarName -- ^ Variable name of update statement definition from primary key
                         -> TypeQ   -- ^ Primary key type
                         -> TypeQ   -- ^ Record type
                         -> ExpQ    -- ^ Relation expression
                         -> ExpQ    -- ^ Table expression
                         -> Q [Dec] -- ^ Result declarations
defineSqlsWithPrimaryKey :: VarName -> VarName -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> Q [Dec]
defineSqlsWithPrimaryKey VarName
sel VarName
upd TypeQ
paramType TypeQ
recType ExpQ
relE ExpQ
tableE = do
  [Dec]
selD <- VarName -> TypeQ -> TypeQ -> ExpQ -> Q [Dec]
definePrimaryQuery  VarName
sel TypeQ
paramType TypeQ
recType ExpQ
relE
  [Dec]
updD <- VarName -> TypeQ -> TypeQ -> ExpQ -> Q [Dec]
definePrimaryUpdate VarName
upd TypeQ
paramType TypeQ
recType ExpQ
tableE
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
selD forall a. [a] -> [a] -> [a]
++ [Dec]
updD

-- | SQL templates derived from primary key using default naming rule.
defineSqlsWithPrimaryKeyDefault :: String  -- ^ Table name of Database
                                -> TypeQ   -- ^ Primary key type
                                -> TypeQ   -- ^ Record type
                                -> ExpQ    -- ^ Relation expression
                                -> ExpQ    -- ^ Table expression
                                -> Q [Dec] -- ^ Result declarations
defineSqlsWithPrimaryKeyDefault :: String -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> Q [Dec]
defineSqlsWithPrimaryKeyDefault String
table  =
  VarName -> VarName -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> Q [Dec]
defineSqlsWithPrimaryKey VarName
sel VarName
upd
  where
    sel :: VarName
sel = String
table String -> String -> VarName
`varNameWithPrefix` String
"select"
    upd :: VarName
upd = String
table String -> String -> VarName
`varNameWithPrefix` String
"update"

-- | All templates about primary key.
defineWithPrimaryKey :: Config
                     -> String  -- ^ Schema name
                     -> String  -- ^ Table name string
                     -> TypeQ   -- ^ Type of primary key
                     -> [Int]   -- ^ Indexes specifies primary key
                     -> Q [Dec] -- ^ Result declarations
defineWithPrimaryKey :: Config -> String -> String -> TypeQ -> [Int] -> Q [Dec]
defineWithPrimaryKey Config
config String
schema String
table TypeQ
keyType [Int]
ixs = do
  [Dec]
instD <- Config -> String -> String -> TypeQ -> [Int] -> Q [Dec]
defineHasPrimaryKeyInstanceWithConfig Config
config String
schema String
table TypeQ
keyType [Int]
ixs
  let recType :: TypeQ
recType  = 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
      tableE :: ExpQ
tableE   = String -> ExpQ
tableVarExpDefault String
table
      relE :: ExpQ
relE     = Config -> String -> String -> ExpQ
relationVarExp Config
config String
schema String
table
  [Dec]
sqlsD <- String -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> Q [Dec]
defineSqlsWithPrimaryKeyDefault String
table TypeQ
keyType TypeQ
recType ExpQ
relE ExpQ
tableE
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
instD forall a. [a] -> [a] -> [a]
++ [Dec]
sqlsD

-- | All templates about not-null key.
defineWithNotNullKeyWithConfig :: Config -> String -> String -> Int -> Q [Dec]
defineWithNotNullKeyWithConfig :: Config -> String -> String -> Int -> Q [Dec]
defineWithNotNullKeyWithConfig = Config -> String -> String -> Int -> Q [Dec]
defineHasNotNullKeyInstanceWithConfig

-- | Generate all templtes about table using specified naming rule.
defineTable :: Config            -- ^ Configuration to generate query with
            -> String            -- ^ Schema name string of Database
            -> String            -- ^ Table name string of Database
            -> [(String, TypeQ)] -- ^ Column names and types
            -> [Name]            -- ^ derivings for Record type
            -> [Int]             -- ^ Primary key index
            -> Maybe Int         -- ^ Not null key index
            -> Q [Dec]           -- ^ Result declarations
defineTable :: Config
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> [Int]
-> Maybe Int
-> Q [Dec]
defineTable Config
config String
schema String
table [(String, TypeQ)]
columns [Name]
derives [Int]
primaryIxs Maybe Int
mayNotNullIdx = do
  [Dec]
tblD  <- Config
-> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
defineTableTypesAndRecord Config
config String
schema String
table [(String, TypeQ)]
columns [Name]
derives
  let pairT :: m Type -> m Type -> m Type
pairT m Type
x m Type
y = forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Int -> m Type
tupleT Int
2) m Type
x) m Type
y
      keyType :: TypeQ
keyType   = forall a. (a -> a -> a) -> [a] -> a
foldl1' forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
pairT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(String, TypeQ)]
columns forall a. [a] -> Int -> a
!!)) forall a b. (a -> b) -> a -> b
$ [Int]
primaryIxs
  [Dec]
primD <- case [Int]
primaryIxs of
    []  -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    [Int]
ixs -> Config -> String -> String -> TypeQ -> [Int] -> Q [Dec]
defineWithPrimaryKey Config
config String
schema String
table TypeQ
keyType [Int]
ixs
  [Dec]
nnD   <- forall a. (a -> Q [Dec]) -> Maybe a -> Q [Dec]
maybeD (\Int
i -> Config -> String -> String -> Int -> Q [Dec]
defineWithNotNullKeyWithConfig Config
config String
schema String
table Int
i) Maybe Int
mayNotNullIdx
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
tblD forall a. [a] -> [a] -> [a]
++ [Dec]
primD forall a. [a] -> [a] -> [a]
++ [Dec]
nnD


-- | Unsafely inlining SQL string 'Query' in compile type.
unsafeInlineQuery :: TypeQ   -- ^ Query parameter type
                  -> TypeQ   -- ^ Query result type
                  -> String  -- ^ SQL string query to inline
                  -> VarName -- ^ Variable name for inlined query
                  -> Q [Dec] -- ^ Result declarations
unsafeInlineQuery :: TypeQ -> TypeQ -> String -> VarName -> Q [Dec]
unsafeInlineQuery TypeQ
p TypeQ
r String
sql VarName
qVar' =
  Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD (VarName -> Name
varName VarName
qVar')
    [t| Query $p $r |]
    [|  unsafeTypedQuery $(stringE sql) |]

-- | Extract param type and result type from defined Relation
reifyRelation :: Name           -- ^ Variable name which has Relation type
              -> Q (Type, Type) -- ^ Extracted param type and result type from Relation type
reifyRelation :: Name -> Q (Type, Type)
reifyRelation Name
relVar = do
  Info
relInfo <- Name -> Q Info
reify Name
relVar
  case Info -> Maybe (Name, Type, Maybe Dec)
unVarI Info
relInfo of
    Just (Name
_, (AppT (AppT (ConT Name
prn) Type
p) Type
r), Maybe Dec
_)
      | Name
prn forall a. Eq a => a -> a -> Bool
== ''Relation    ->  forall (m :: * -> *) a. Monad m => a -> m a
return (Type
p, Type
r)
    Maybe (Name, Type, Maybe Dec)
_                        ->
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"expandRelation: Variable must have Relation type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
relVar

-- | Inlining composed 'Query' in compile type.
inlineQuery :: 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
inlineQuery :: forall p r.
Name -> Relation p r -> Config -> QuerySuffix -> String -> Q [Dec]
inlineQuery Name
relVar Relation p r
rel Config
config QuerySuffix
sufs String
qns = do
  (Type
p, Type
r) <- Name -> Q (Type, Type)
reifyRelation Name
relVar
  TypeQ -> TypeQ -> String -> VarName -> Q [Dec]
unsafeInlineQuery (forall (m :: * -> *) a. Monad m => a -> m a
return Type
p) (forall (m :: * -> *) a. Monad m => a -> m a
return Type
r)
    (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)
    (String -> VarName
varCamelcaseName String
qns)

-- | Generate all templates against defined record like type constructor
--   other than depending on sql-value type.
makeRelationalRecordDefault' :: Config
                             -> Name    -- ^ Type constructor name
                             -> Q [Dec] -- ^ Result declaration
makeRelationalRecordDefault' :: Config -> Name -> Q [Dec]
makeRelationalRecordDefault' Config
config Name
recTypeName = do
  let recTypeConName :: ConName
recTypeConName = Name -> ConName
ConName Name
recTypeName
  (((TypeQ
tyCon, [Name]
vars), ExpQ
_dataCon), (Maybe [Name]
mayNs, [TypeQ]
cts)) <- Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType Name
recTypeName
  [Dec]
pw <- TypeQ -> [Name] -> Q [Dec]
Record.definePersistableWidthInstance TypeQ
tyCon [Name]
vars
  [Dec]
cols <- case Maybe [Name]
mayNs of
    Maybe [Name]
Nothing   ->  forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just [Name]
ns   ->  case [Name]
vars of
      []      ->  do {- monomorphic case -}
        [Dec]
off <- ConName -> Q [Dec]
Record.defineColumnOffsets ConName
recTypeConName
        let cnames :: [(String, TypeQ)]
cnames =  [ (Name -> String
nameBase Name
n, TypeQ
ct) | Name
n  <- [Name]
ns  | TypeQ
ct <- [TypeQ]
cts ]
        [Dec]
cs  <- if Config -> Bool
disableSpecializedProjection Config
config
               then [d| |]
               else ConName -> [(String, TypeQ)] -> Q [Dec]
defineColumnsDefault     ConName
recTypeConName [(String, TypeQ)]
cnames
        [Dec]
pcs <- if Config -> Bool
disableOverloadedProjection Config
config
               then [d| |]
               else ConName -> [(String, TypeQ)] -> Q [Dec]
defineOverloadedColumnsDefault ConName
recTypeConName [(String, TypeQ)]
cnames
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
off forall a. [a] -> [a] -> [a]
++ [Dec]
cs forall a. [a] -> [a] -> [a]
++ [Dec]
pcs
      Name
_:[Name]
_     ->  do {- polymorphic case -}
        [Dec]
cols <- if Config -> Bool
disableSpecializedProjection Config
config
                then [d| |]
                else TypeQ -> [Name] -> [Name] -> [TypeQ] -> Q [Dec]
defineRecordProjections TypeQ
tyCon [Name]
vars
                     [VarName -> Name
varName forall a b. (a -> b) -> a -> b
$ String -> VarName
varCamelcaseName (Name -> String
nameBase Name
n forall a. [a] -> [a] -> [a]
++ String
"'") | Name
n <- [Name]
ns]
                     [TypeQ]
cts
        [Dec]
ovls <- if Config -> Bool
disableOverloadedProjection Config
config
                then [d| |]
                else TypeQ -> [Name] -> [String] -> [TypeQ] -> Q [Dec]
Overloaded.polymorphicProjections TypeQ
tyCon [Name]
vars
                     [Name -> String
nameBase Name
n | Name
n <- [Name]
ns]
                     [TypeQ]
cts
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
cols forall a. [a] -> [a] -> [a]
++ [Dec]
ovls

  [Dec]
pc <- Name -> Q [Dec]
defineProductConstructor Name
recTypeName
  let scPred :: Name -> TypeQ
scPred Name
v = Name -> [TypeQ] -> TypeQ
classP ''LiteralSQL [forall (m :: * -> *). Quote m => Name -> m Type
varT Name
v]
  Dec
ct <- forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> TypeQ
scPred [Name]
vars) (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [t| LiteralSQL |] TypeQ
tyCon) []
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]
pw, [Dec]
cols, [Dec]
pc, [Dec
ct]]

-- | Generate all templates against defined record like type constructor
--   other than depending on sql-value type.
makeRelationalRecordDefault ::  Name   -- ^ Type constructor name
                            -> Q [Dec] -- ^ Result declaration
makeRelationalRecordDefault :: Name -> Q [Dec]
makeRelationalRecordDefault = Config -> Name -> Q [Dec]
makeRelationalRecordDefault' Config
defaultConfig