{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Database.Relational.PostgreSQL.Pure.TH (
makeRelationalRecord,
makeRelationalRecord',
defineTableDefault',
defineTableDefault,
defineTableFromDB',
defineTableFromDB,
inlineVerifiedQuery
) where
import Control.Monad (void, when)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, listToMaybe)
import Data.String (fromString)
import Database.PostgreSQL.Pure (ColumnInfo, Connection, FromRecord, Length, Oid, ToRecord,
disconnect, parse, sync)
import Language.Haskell.TH (Dec, Name, Q, TyLit (NumTyLit), Type (AppT, ConT, LitT), TypeQ,
runIO)
import Language.Haskell.TH.Lib.Extra (reportError, reportWarning)
import Language.Haskell.TH.Name.CamelCase (varCamelcaseName)
import Language.Haskell.TH.Syntax (returnQ)
import Database.Record.TH (recordTemplate)
import Database.Relational (Config, Relation, defaultConfig, enableWarning, nameConfig,
recordConfig, relationalQuery_, untypeQuery,
verboseAsCompilerWarning)
import qualified Database.Relational.TH as Relational
import Language.SQL.Keyword (Keyword)
import Database.Schema.PostgreSQL.Pure.Driver (Driver, driverConfig, emptyLogChan, foldLog, getFields,
getPrimaryKey, takeLogs)
import Data.Tuple.Homotuple (IsHomolisttuple, IsHomotupleItem)
import GHC.TypeLits (KnownNat)
defineInstancesForRecord :: TypeQ
-> Q [Dec]
defineInstancesForRecord typeCon = do
[d| instance FromRecord $typeCon
instance ToRecord $typeCon
|]
defineInstancesForLength :: TypeQ -> Int -> Q [Dec]
defineInstancesForLength typeCon len = do
let len' = returnQ $ LitT $ NumTyLit $ toInteger len
[d| type instance Length $typeCon = $len' |]
makeRelationalRecord' :: Config
-> Name
-> Q [Dec]
makeRelationalRecord' config recTypeName =
Relational.makeRelationalRecordDefault' config recTypeName
makeRelationalRecord :: Name
-> Q [Dec]
makeRelationalRecord = makeRelationalRecord' defaultConfig
defineTableDefault' :: Config
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> Q [Dec]
defineTableDefault' config schema table columns derives =
Relational.defineTableTypesAndRecord config schema table columns derives
defineTableDefault :: Config
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> [Int]
-> Maybe Int
-> Q [Dec]
defineTableDefault config schema table columns derives primary notNull = do
modelD <- Relational.defineTable config schema table columns derives primary notNull
let typeCon = fst $ recordTemplate (recordConfig $ nameConfig config) schema table
recordD <- defineInstancesForRecord typeCon
lengthD <- defineInstancesForLength typeCon $ length columns
return $ modelD ++ recordD ++ lengthD
tableAlongWithSchema :: IO Connection
-> Driver
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> Q [Dec]
tableAlongWithSchema connect drv scm tbl cmap derives = do
let config = driverConfig drv
getDBinfo = do
logChan <- emptyLogChan
infoP <- do
conn <- connect
p <-
(,)
<$> getFields drv conn logChan scm tbl
<*> getPrimaryKey drv conn logChan scm tbl
disconnect conn
pure p
(,) infoP <$> takeLogs logChan
(((cols, notNullIdxs), primaryCols), logs) <- runIO getDBinfo
let reportWarning'
| enableWarning config = reportWarning
| otherwise = const $ pure ()
reportVerbose
| verboseAsCompilerWarning config = reportWarning
| otherwise = const $ pure ()
mapM_ (foldLog reportVerbose reportWarning' reportError) logs
when (null primaryCols) . reportWarning'
$ "getPrimaryKey: Primary key not found for table: " ++ scm ++ "." ++ tbl
let colIxMap = Map.fromList $ zip [c | (c, _) <- cols] [(0 :: Int) .. ]
ixLookups = [ (k, Map.lookup k colIxMap) | k <- primaryCols ]
warnLk k = maybe
(reportWarning $ "defineTableFromDB: fail to find index of pkey - " ++ k ++ ". Something wrong!!")
(const $ return ())
primaryIxs = fromMaybe [] . sequence $ map snd ixLookups
mapM_ (uncurry warnLk) ixLookups
let liftMaybe tyQ sty = do
ty <- tyQ
case ty of
(AppT (ConT n) _) | n == ''Maybe -> [t| Maybe $(sty) |]
_ -> sty
cols1 = [ (,) cn . maybe ty (liftMaybe ty) . Map.lookup cn $ Map.fromList cmap | (cn, ty) <- cols ]
defineTableDefault config scm tbl cols1 derives primaryIxs (listToMaybe notNullIdxs)
defineTableFromDB' :: IO Connection
-> Driver
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> Q [Dec]
defineTableFromDB' = tableAlongWithSchema
defineTableFromDB :: IO Connection
-> Driver
-> String
-> String
-> [Name]
-> Q [Dec]
defineTableFromDB connect driver scm tbl = tableAlongWithSchema connect driver scm tbl []
inlineVerifiedQuery :: forall p r.
( KnownNat (Length p)
, KnownNat (Length r)
, IsHomotupleItem (Length p) Oid
, IsHomotupleItem (Length r) Oid
, IsHomotupleItem (Length r) ColumnInfo
, IsHomolisttuple (Length p) Oid
, IsHomolisttuple (Length r) Oid
, IsHomolisttuple (Length r) ColumnInfo
)
=> IO Connection
-> Name
-> Relation p r
-> Config
-> [Keyword]
-> String
-> Q [Dec]
#if MIN_VERSION_relational_query(0,13,0)
inlineVerifiedQuery connect relVar rel config sufs declName =
Relational.inlineQuery_ check relVar rel config sufs declName
where
check sql = do
when (verboseAsCompilerWarning config) . reportWarning $ "Verify with prepare: " ++ sql
void . runIO $ do
conn <- connect
let psProc = parse @(Length p) @(Length r) "" (fromString sql) Nothing
void $ sync conn psProc
disconnect conn
#else
inlineVerifiedQuery connect relVar rel config sufs qns = do
(p, r) <- Relational.reifyRelation relVar
let sql = untypeQuery $ relationalQuery_ config rel sufs
when (verboseAsCompilerWarning config) . reportWarning $ "Verify with prepare: " ++ sql
void . runIO $ do
conn <- connect
let psProc = parse @(Length p) @(Length r) "" (fromString sql) Nothing
void $ sync conn psProc
disconnect conn
Relational.unsafeInlineQuery (return p) (return r) sql (varCamelcaseName qns)
#endif