hasql-generate-1.0.0: src/Hasql/Generate/TH.hs
module Hasql.Generate.TH
( GenerateConfig
, fromTable
, fromType
, fromView
, generate
, withDerivations
, withOverrides
, withholdPk
) where
----------------------------------------------------------------------------------------------------
import Control.Applicative ( (<*>) )
import Control.Monad ( mapM, return )
import Control.Monad.Fail ( MonadFail (fail) )
import Data.Bool
( Bool (..)
, not
, otherwise
, (&&)
)
import Data.Char ( toLower, toUpper )
import Data.Eq ( (==) )
import Data.Foldable ( foldl )
import Data.Function ( flip, ($), (.) )
import Data.Functor ( (<$>) )
import qualified Data.Functor.Contravariant as Contravariant
import Data.Int ( Int )
import Data.List
( all
, break
, concatMap
, elem
, filter
, intercalate
, length
, lookup
, map
, notElem
, null
, partition
, zip
, zipWith
, (!!)
)
import Data.Maybe ( Maybe (..) )
import Data.Semigroup ( (<>) )
import Data.String ( String )
import qualified Data.String
import qualified Data.Text
import qualified Data.Tuple
import qualified Hasql.Decoders
import qualified Hasql.Encoders
import qualified Hasql.Generate.Class
import qualified Hasql.Generate.Codec
import qualified Hasql.Generate.Column
import Hasql.Generate.Config ( Config (..) )
import Hasql.Generate.Connection
( toConnString
, withCompileTimeConnection
)
import Hasql.Generate.Internal.Introspect
( ColumnInfo (..)
, introspectColumns
, introspectEnumLabels
, introspectPrimaryKey
)
import qualified Hasql.Session
import qualified Hasql.Statement
import Language.Haskell.TH
import Prelude
( enumFromTo
, mconcat
, show
, (+)
, (-)
)
----------------------------------------------------------------------------------------------------
-- | Whether the target relation is a table (full CRUD), a view (read-only), or a type (enum).
data RelationKind = Table | View | Type
{- Configuration for a table, view, or type code-generation request.
Use 'fromTable', 'fromView', or 'fromType' to create a default config,
then chain modifier functions with @(&)@ to customise it:
@
fromTable \"public\" \"users\"
& withDerivations [''Show, ''Eq, ''Generic]
& withOverrides [(\"timestamptz\", ''UTCTime)]
& withholdPk
@
-}
data GenerateConfig
= GenerateConfig
{ tcSchema :: String
, tcTable :: String
, tcKind :: RelationKind
, tcDerivations :: [Name]
, tcOverrides :: [(String, Name)]
, tcWithholdPk :: Bool
}
{- Create a 'GenerateConfig' for the given schema and table with no derivations
and no type overrides. Generates full CRUD code.
-}
fromTable :: String -> String -> GenerateConfig
fromTable schema table =
GenerateConfig
{ tcSchema = schema
, tcTable = table
, tcKind = Table
, tcDerivations = []
, tcOverrides = []
, tcWithholdPk = False
}
{- Create a 'GenerateConfig' for the given schema and view with no derivations
and no type overrides. Generates read-only code: a record type, a decoder,
a SELECT statement, and a 'HasView' instance.
-}
fromView :: String -> String -> GenerateConfig
fromView schema view =
GenerateConfig
{ tcSchema = schema
, tcTable = view
, tcKind = View
, tcDerivations = []
, tcOverrides = []
, tcWithholdPk = False
}
{- Create a 'GenerateConfig' for the given schema and enum type with no
derivations. Generates a Haskell sum type, a 'PgCodec' instance,
and a 'PgColumn' instance. Overrides are ignored for types.
The splice must appear before any @fromTable@ whose table has a column of
this enum type, since TH processes splices top to bottom.
__Orphan instance warning:__ The generated @PgColumn@ instance will trigger
GHC's @-Worphans@ warning because the functional dependency's determining
types are @Symbol@ literals, which GHC never considers local to any user
module. This is expected and harmless. Add the following pragma to any
module that uses @fromType@:
@
\{\-\# OPTIONS_GHC -Wno-orphans \#\-\}
@
-}
fromType :: String -> String -> GenerateConfig
fromType schema typeName =
GenerateConfig
{ tcSchema = schema
, tcTable = typeName
, tcKind = Type
, tcDerivations = []
, tcOverrides = []
, tcWithholdPk = False
}
-- | Append derivation class 'Name's to the config.
withDerivations :: [Name] -> GenerateConfig -> GenerateConfig
withDerivations names cfg = cfg {tcDerivations = tcDerivations cfg <> names}
{- Append per-table PG type overrides. Each pair maps a PostgreSQL type name
(e.g. @\"timestamptz\"@) to a Haskell type 'Name' (e.g. @''UTCTime@).
The override type must still have a 'PgCodec' instance.
-}
withOverrides :: [(String, Name)] -> GenerateConfig -> GenerateConfig
withOverrides ovs cfg = cfg {tcOverrides = tcOverrides cfg <> ovs}
{- Opt in to excluding PK columns from INSERT when all PK columns have
database defaults. Without this, INSERT always includes all columns.
@
fromTable \"public\" \"users\" & withholdPk
@
-}
withholdPk :: GenerateConfig -> GenerateConfig
withholdPk cfg = cfg {tcWithholdPk = True}
{- Terminal step that introspects a PostgreSQL database at compile time and
generates the provided data construct:
Usage:
@
\$(generate def (fromTable \"public\" \"users\" & withDerivations [''Show, ''Eq]))
@
-}
generate :: Config -> GenerateConfig -> Q [Dec]
generate config genConfig =
case kind of
Type -> do
labels <- runIO $ withCompileTimeConnection connStr $ \conn ->
introspectEnumLabels conn schema table
if null labels
then fail ("hasql-generate: no enum labels found for " <> schema <> "." <> table)
else generateTypeDecs schema table (pascalCase table) derivNames labels
Table -> do
(typeName, resolvedCols, pkCols) <- getPgData
let pkInfo = buildPkInfo resolvedCols pkCols
generateAllDecs config withhold schema table typeName derivNames resolvedCols pkInfo
View -> do
(typeName, resolvedCols, _) <- getPgData
generateViewDecs schema table typeName derivNames resolvedCols
where
connStr = toConnString (connection config)
schema = tcSchema genConfig
table = tcTable genConfig
kind = tcKind genConfig
derivNames = tcDerivations genConfig
withhold = tcWithholdPk genConfig
mergedOverrides = tcOverrides genConfig <> globalOverrides config
getPgData = do
(columns, pkCols') <- runIO $ withCompileTimeConnection connStr $ \conn -> do
cols <- introspectColumns conn schema table
pks <- case kind of
Table -> introspectPrimaryKey conn schema table
_ -> return []
return (cols, pks)
if null columns
then fail ("hasql-generate: no columns found for " <> schema <> "." <> table)
else do
resolvedCols <- mapM (resolveColumnWithOverrides mergedOverrides) columns
let typName = pascalCase table
resolvedCols' =
if allowDuplicateRecordFields config
then resolvedCols
else map (prefixFieldName typName) resolvedCols
return (typName, resolvedCols', pkCols')
----------------------------------------------------------------------------------------------------
data ResolvedColumn
= ResolvedColumn
{ rcColName :: String
, rcFieldName :: String
, rcType :: Type
, rcNotNull :: Bool
, rcHasDefault :: Bool
, rcPgCast :: Maybe String
}
data PkInfo
= NoPrimaryKey
| SinglePk ResolvedColumn
| CompositePk [ResolvedColumn]
----------------------------------------------------------------------------------------------------
{- Resolve a column's Haskell type. If the column's PG type name appears in
the overrides list, use the override 'Name' directly (as @ConT@). Otherwise
fall back to 'PgColumn' instance resolution via 'reifyInstances'.
-}
resolveColumnWithOverrides :: [(String, Name)] -> ColumnInfo -> Q ResolvedColumn
resolveColumnWithOverrides overrides col = do
hsType <- case lookup (colPgType col) overrides of
Just overrideName -> return (ConT overrideName)
Nothing -> do
a <- newName "a"
insts <-
reifyInstances
''Hasql.Generate.Column.PgColumn
[ LitT (StrTyLit (colPgSchema col))
, LitT (StrTyLit (colPgType col))
, VarT a
]
case insts of
[InstanceD _ _ (AppT (AppT (AppT _ _) _) ty) _] -> return ty
[] ->
fail
( "hasql-generate: no PgColumn instance for pg type '"
<> colPgSchema col
<> "."
<> colPgType col
<> "' (column '"
<> colName col
<> "')"
)
_ ->
fail
( "hasql-generate: multiple PgColumn instances for pg type '"
<> colPgSchema col
<> "."
<> colPgType col
<> "' (column '"
<> colName col
<> "') — expected exactly one"
)
let pgCast =
if colIsEnum col
then Just (quoteIdent (colPgSchema col) <> "." <> quoteIdent (colPgType col))
else Nothing
return
ResolvedColumn
{ rcColName = colName col
, rcFieldName = sanitizeField (camelCase (colName col))
, rcType = hsType
, rcNotNull = colNotNull col
, rcHasDefault = colHasDefault col
, rcPgCast = pgCast
}
----------------------------------------------------------------------------------------------------
buildPkInfo :: [ResolvedColumn] -> [String] -> PkInfo
buildPkInfo _ [] = NoPrimaryKey
buildPkInfo resolvedCols [pkName] =
case filter (\rc -> rcColName rc == pkName) resolvedCols of
[rc] -> SinglePk rc
_ -> NoPrimaryKey
buildPkInfo resolvedCols pkNames =
let lookupPk pkn = filter (\rc -> rcColName rc == pkn) resolvedCols
pkCols = concatMap lookupPk pkNames
in if length pkCols == length pkNames
then CompositePk pkCols
else NoPrimaryKey
----------------------------------------------------------------------------------------------------
generateAllDecs
:: Config -> Bool -> String -> String -> String -> [Name] -> [ResolvedColumn] -> PkInfo -> Q [Dec]
generateAllDecs config withhold schema table typName derivNames resolvedCols pkInfo = do
let useNtPk = newtypePrimaryKeys config
pkTypName = typName <> "Pk"
allowDupFields = allowDuplicateRecordFields config
-- Generate PK wrapper type declarations (before main record so newtype is in scope)
pkTypeDecs <-
if useNtPk
then case pkInfo of
SinglePk rc -> do
ntDec <- genPkNewtype pkTypName derivNames rc
codecDec <- genPkNewtypeCodec pkTypName
return (ntDec <> codecDec)
CompositePk rcs -> do
let pkRcs = map (pkRecordFieldName pkTypName allowDupFields) rcs
recDec <- genPkRecord pkTypName derivNames pkRcs
encDec <- genPkRecordEncoder pkTypName pkRcs
return (recDec <> encDec)
NoPrimaryKey -> return []
else return []
-- For single PK with newtypes, rewrite the PK column's type to the newtype
let (resolvedCols', pkInfo') =
if useNtPk
then case pkInfo of
SinglePk rc ->
let rc' = rc {rcType = ConT (mkName pkTypName)}
cols' = map (\c -> if rcColName c == rcColName rc then rc' else c) resolvedCols
in (cols', SinglePk rc')
_ -> (resolvedCols, pkInfo)
else (resolvedCols, pkInfo)
-- Compute pkTypOverride for composite PK with newtypes
let pkTypOverride = case (useNtPk, pkInfo) of
(True, CompositePk _) -> Just pkTypName
_ -> Nothing
-- Generate main record, decoder, encoder, insert (single + batch)
dataDec <- genDataType typName derivNames resolvedCols'
decoderDec <- genDecoder typName resolvedCols'
encoderDec <- genEncoder typName resolvedCols'
let insertCols = computeInsertCols withhold resolvedCols' pkInfo'
insDec <- genInsert schema table typName resolvedCols' insertCols
insMany <- genInsertMany schema table typName resolvedCols' insertCols
hasInsInst <- genHasInsertInstance typName
-- Generate PK-dependent statements and instances (single + batch)
pkDecs <- case pkInfo' of
NoPrimaryKey -> return []
_ -> do
sel <- genSelectByPk schema table typName resolvedCols' pkInfo' pkTypOverride
selMany <- genSelectMany schema table typName resolvedCols' pkInfo' pkTypOverride
upd <- genUpdate schema table typName resolvedCols' pkInfo'
updMany <- genUpdateMany schema table typName resolvedCols' pkInfo'
del <- genDeleteByPk schema table typName pkInfo' pkTypOverride
delMany <- genDeleteMany schema table typName pkInfo' pkTypOverride
hasSelInst <- genHasSelectInstance typName pkInfo' pkTypOverride
hasUpdInst <- genHasUpdateInstance typName
hasDelInst <- genHasDeleteInstance typName pkInfo' pkTypOverride
return (sel <> selMany <> upd <> updMany <> del <> delMany <> hasSelInst <> hasUpdInst <> hasDelInst)
-- Generate HasPrimaryKey instance (for ALL tables with PKs)
hasPkInst <- case pkInfo of
NoPrimaryKey -> return []
_ -> genHasPrimaryKeyInstance typName pkInfo pkInfo' useNtPk pkTypOverride allowDupFields
return (pkTypeDecs <> dataDec <> decoderDec <> encoderDec <> insDec <> insMany <> hasInsInst <> pkDecs <> hasPkInst)
{- Generate read-only declarations for a view: data type, decoder, SELECT
statement, and 'HasView' instance.
-}
generateViewDecs
:: String -> String -> String -> [Name] -> [ResolvedColumn] -> Q [Dec]
generateViewDecs schema table typName derivNames resolvedCols = do
dataDec <- genDataType typName derivNames resolvedCols
decoderDec <- genDecoder typName resolvedCols
selectDec <- genSelectView schema table typName resolvedCols
hasViewInst <- genHasViewInstance typName
return (dataDec <> decoderDec <> selectDec <> hasViewInst)
{- Generate declarations for a PostgreSQL enum type: a Haskell sum type,
a 'PgCodec' instance (using @Decoders.enum@ / @Encoders.enum@), and
a 'PgColumn' instance mapping the schema-qualified PG type name to the
generated Haskell type.
-}
generateTypeDecs
:: String -> String -> String -> [Name] -> [String] -> Q [Dec]
generateTypeDecs schema pgTypeName hsTypeName derivNames labels = do
sumType <- genSumType hsTypeName derivNames labels
codecInst <- genPgCodecInstance hsTypeName labels
columnInst <- genPgColumnInstance schema pgTypeName hsTypeName
enumInst <- genHasEnumInstance hsTypeName labels
return (sumType <> codecInst <> columnInst <> enumInst)
genSumType :: String -> [Name] -> [String] -> Q [Dec]
genSumType hsTypeName derivNames labels = do
let tName = mkName hsTypeName
cons = map (\lbl -> NormalC (mkName (pascalCase lbl)) []) labels
derivClauses = mkDerivClauses derivNames
return [DataD [] tName [] Nothing cons derivClauses]
genPgCodecInstance :: String -> [String] -> Q [Dec]
genPgCodecInstance hsTypeName labels = do
let tName = mkName hsTypeName
-- pgDecode: Decoders.enum (\t -> case Data.Text.unpack t of "lbl" -> Just Con; ... _ -> Nothing)
t = mkName "t"
decoderMatches =
map
( \lbl ->
Match
(LitP (StringL lbl))
(NormalB (AppE (ConE 'Just) (ConE (mkName (pascalCase lbl)))))
[]
)
labels
<> [Match WildP (NormalB (ConE 'Nothing)) []]
decoderLam =
LamE
[VarP t]
(CaseE (AppE (VarE 'Data.Text.unpack) (VarE t)) decoderMatches)
decoderBody = AppE (VarE 'Hasql.Decoders.enum) decoderLam
decoderDec = FunD 'Hasql.Generate.Codec.pgDecode [Clause [] (NormalB decoderBody) []]
-- pgEncode: Encoders.enum (\x -> case x of Con -> "lbl"; ...)
x = mkName "x"
encoderMatches =
map
( \lbl ->
Match
(ConP (mkName (pascalCase lbl)) [] [])
(NormalB (textLit lbl))
[]
)
labels
encoderLam = LamE [VarP x] (CaseE (VarE x) encoderMatches)
encoderBody = AppE (VarE 'Hasql.Encoders.enum) encoderLam
encoderDec = FunD 'Hasql.Generate.Codec.pgEncode [Clause [] (NormalB encoderBody) []]
instanceType = AppT (ConT ''Hasql.Generate.Codec.PgCodec) (ConT tName)
return [InstanceD Nothing [] instanceType [decoderDec, encoderDec]]
genPgColumnInstance :: String -> String -> String -> Q [Dec]
genPgColumnInstance schema pgTypeName hsTypeName = do
let tName = mkName hsTypeName
instanceType =
AppT
( AppT
(AppT (ConT ''Hasql.Generate.Column.PgColumn) (LitT (StrTyLit schema)))
(LitT (StrTyLit pgTypeName))
)
(ConT tName)
return [InstanceD Nothing [] instanceType []]
{- Generate a @HasEnum@ instance for the given sum type.
@allValues@ is a list of all constructors. @toText@ is a multi-clause
function mapping each constructor to its PostgreSQL label. @fromText@
unpacks the 'Text' to a 'String' and matches on string literals.
-}
genHasEnumInstance :: String -> [String] -> Q [Dec]
genHasEnumInstance hsTypeName labels = do
let tName = mkName hsTypeName
-- allValues = [Con1, Con2, ...]
allValuesDec =
FunD
'Hasql.Generate.Class.allValues
[Clause [] (NormalB (ListE (map (ConE . mkName . pascalCase) labels))) []]
-- toText Con1 = "label1"; toText Con2 = "label2"; ...
toTextClauses =
map
( \lbl ->
Clause
[ConP (mkName (pascalCase lbl)) [] []]
(NormalB (textLit lbl))
[]
)
labels
toTextDec = FunD 'Hasql.Generate.Class.toText toTextClauses
-- fromText t = case Data.Text.unpack t of "label1" -> Just Con1; ... _ -> Nothing
t = mkName "t"
fromTextMatches =
map
( \lbl ->
Match
(LitP (StringL lbl))
(NormalB (AppE (ConE 'Just) (ConE (mkName (pascalCase lbl)))))
[]
)
labels
<> [Match WildP (NormalB (ConE 'Nothing)) []]
fromTextBody =
LamE
[VarP t]
(CaseE (AppE (VarE 'Data.Text.unpack) (VarE t)) fromTextMatches)
fromTextDec =
FunD
'Hasql.Generate.Class.fromText
[Clause [] (NormalB fromTextBody) []]
instanceType = AppT (ConT ''Hasql.Generate.Class.HasEnum) (ConT tName)
return [InstanceD Nothing [] instanceType [allValuesDec, toTextDec, fromTextDec]]
----------------------------------------------------------------------------------------------------
-- Data type generation
----------------------------------------------------------------------------------------------------
genDataType :: String -> [Name] -> [ResolvedColumn] -> Q [Dec]
genDataType typName derivNames cols = do
let tName = mkName typName
fields = map mkField cols
con = RecC tName fields
derivClauses = mkDerivClauses derivNames
return [DataD [] tName [] Nothing [con] derivClauses]
where
mkField :: ResolvedColumn -> VarBangType
mkField resCol =
let fName = mkName (rcFieldName resCol)
fieldBang = Bang NoSourceUnpackedness SourceStrict
typ = fieldType resCol
in (fName, fieldBang, typ)
fieldType :: ResolvedColumn -> Type
fieldType resCol
| rcNotNull resCol = rcType resCol
| otherwise = AppT (ConT ''Maybe) (rcType resCol)
{- Partition deriving class 'Name's into stock and anyclass 'DerivClause's.
Known stock-derivable classes get @deriving stock@; everything else gets
@deriving anyclass@. Empty groups are omitted.
-}
mkDerivClauses :: [Name] -> [DerivClause]
mkDerivClauses names =
let (stock, anyclass) = partition isStockDerivable names
in clauseFor StockStrategy stock <> clauseFor AnyclassStrategy anyclass
where
clauseFor _ [] = []
clauseFor strat nms = [DerivClause (Just strat) (map ConT nms)]
isStockDerivable :: Name -> Bool
isStockDerivable nm =
nameBase nm
`elem` [ "Show"
, "Read"
, "Eq"
, "Ord"
, "Bounded"
, "Enum"
, "Ix"
, "Generic"
, "Generic1"
, "Data"
, "Typeable"
, "Lift"
, "Functor"
, "Foldable"
, "Traversable"
]
----------------------------------------------------------------------------------------------------
-- Decoder generation
----------------------------------------------------------------------------------------------------
genDecoder :: String -> [ResolvedColumn] -> Q [Dec]
genDecoder typName cols = do
let decName = mkName (camelCase typName <> "Decoder")
tName = mkName typName
sigTy = AppT (ConT ''Hasql.Decoders.Row) (ConT tName)
sig <- sigD decName (return sigTy)
body <- genDecoderBody tName cols
let dec = ValD (VarP decName) (NormalB body) []
return [sig, dec]
genDecoderBody :: Name -> [ResolvedColumn] -> Q Exp
genDecoderBody tName cols =
case cols of
[] -> fail "hasql-generate: cannot generate decoder for table with no columns"
(x : xs) -> do
let first = applyFmap (ConE tName) (columnDecodeExp x)
foldl applyAp (return first) (map (return . columnDecodeExp) xs)
columnDecodeExp :: ResolvedColumn -> Exp
columnDecodeExp resCol =
let nullability =
if rcNotNull resCol
then VarE 'Hasql.Decoders.nonNullable
else VarE 'Hasql.Decoders.nullable
codec = VarE 'Hasql.Generate.Codec.pgDecode
in AppE (VarE 'Hasql.Decoders.column) (AppE nullability codec)
applyFmap :: Exp -> Exp -> Exp
applyFmap f x = InfixE (Just f) (VarE '(<$>)) (Just x)
applyAp :: Q Exp -> Q Exp -> Q Exp
applyAp qf qx = do
f <- qf
InfixE (Just f) (VarE '(<*>)) . Just <$> qx
----------------------------------------------------------------------------------------------------
-- Encoder generation
----------------------------------------------------------------------------------------------------
genEncoder :: String -> [ResolvedColumn] -> Q [Dec]
genEncoder typName cols = do
let encName = mkName (camelCase typName <> "Encoder")
tName = mkName typName
sigTy = AppT (ConT ''Hasql.Encoders.Params) (ConT tName)
sig <- sigD encName (return sigTy)
let body = AppE (VarE 'mconcat) (ListE (map (columnEncodeExp tName) cols))
dec = ValD (VarP encName) (NormalB body) []
return [sig, dec]
{- Generate a single encoder term:
@contramap fieldSelector (Hasql.Encoders.param (Hasql.Encoders.nonNullable pgEncode))@
Uses a record pattern match lambda to extract the field, which works
regardless of @DuplicateRecordFields@ or @NoFieldSelectors@ settings.
-}
columnEncodeExp :: Name -> ResolvedColumn -> Exp
columnEncodeExp tName rc =
let nullability =
if rcNotNull rc
then VarE 'Hasql.Encoders.nonNullable
else VarE 'Hasql.Encoders.nullable
codec = VarE 'Hasql.Generate.Codec.pgEncode
paramEnc = AppE (VarE 'Hasql.Encoders.param) (AppE nullability codec)
x = mkName "x"
selector =
LamE
[RecP tName [(mkName (rcFieldName rc), VarP x)]]
(VarE x)
in AppE (AppE (VarE 'Contravariant.contramap) selector) paramEnc
{- Generate a single array encoder term for batch operations:
@contramap (map (\\TypeName{field = x} -> x))
(Encoders.param (Encoders.nonNullable
(Encoders.foldableArray (nonNullable\/nullable pgEncode))))@
The outer @param@ is always @nonNullable@ (the array itself is always present).
The inner @foldableArray@ element nullability follows 'rcNotNull'.
The selector uses @map@ over a @RecP@ lambda pattern.
-}
columnArrayEncodeExp :: Name -> ResolvedColumn -> Exp
columnArrayEncodeExp tName rc =
let elementNullability =
if rcNotNull rc
then VarE 'Hasql.Encoders.nonNullable
else VarE 'Hasql.Encoders.nullable
codec = VarE 'Hasql.Generate.Codec.pgEncode
arrayEnc =
AppE
(VarE 'Hasql.Encoders.foldableArray)
(AppE elementNullability codec)
paramEnc =
AppE
(VarE 'Hasql.Encoders.param)
(AppE (VarE 'Hasql.Encoders.nonNullable) arrayEnc)
x = mkName "x"
fieldExtractor =
LamE
[RecP tName [(mkName (rcFieldName rc), VarP x)]]
(VarE x)
mapSelector = AppE (VarE 'map) fieldExtractor
in AppE (AppE (VarE 'Contravariant.contramap) mapSelector) paramEnc
{- Generate an array encoder for a single PK value list:
@Encoders.param (Encoders.nonNullable
(Encoders.foldableArray (nonNullable\/nullable pgEncode)))@
-}
singlePkArrayEncoder :: ResolvedColumn -> Exp
singlePkArrayEncoder resCol =
let elementNullability =
if rcNotNull resCol
then VarE 'Hasql.Encoders.nonNullable
else VarE 'Hasql.Encoders.nullable
codec = VarE 'Hasql.Generate.Codec.pgEncode
arrayEnc =
AppE
(VarE 'Hasql.Encoders.foldableArray)
(AppE elementNullability codec)
in AppE
(VarE 'Hasql.Encoders.param)
(AppE (VarE 'Hasql.Encoders.nonNullable) arrayEnc)
{- Generate an array encoder for batch PK operations over @[PkType]@ input.
* @NoPrimaryKey@: @noParams@
* @SinglePk@: 'singlePkArrayEncoder'
* @CompositePk@ without newtypes: @mconcat@ of tuple-field array encoders
* @CompositePk@ with newtypes: @mconcat@ of RecP-based array encoders
over the PK record type
-}
pkArrayEncoder :: Maybe String -> PkInfo -> Q Exp
pkArrayEncoder (Just pkTypName) (CompositePk rcs) = do
let tName = mkName pkTypName
return (AppE (VarE 'mconcat) (ListE (map (columnArrayEncodeExp tName) rcs)))
pkArrayEncoder _ NoPrimaryKey = return (VarE 'Hasql.Encoders.noParams)
pkArrayEncoder _ (SinglePk rc) = return (singlePkArrayEncoder rc)
pkArrayEncoder _ (CompositePk rcs) = do
let n = length rcs
encoders =
zipWith
(flip (tupleFieldArrayEncoder n))
rcs
(enumFromTo 0 (n - 1))
return (AppE (VarE 'mconcat) (ListE encoders))
{- Generate an array encoder for one field of a tuple PK:
@contramap (map (\\(_, x, _) -> x))
(Encoders.param (Encoders.nonNullable (Encoders.foldableArray ...)))@
-}
tupleFieldArrayEncoder :: Int -> Int -> ResolvedColumn -> Exp
tupleFieldArrayEncoder tupleSize idx resCol =
let elementNullability =
if rcNotNull resCol
then VarE 'Hasql.Encoders.nonNullable
else VarE 'Hasql.Encoders.nullable
codec = VarE 'Hasql.Generate.Codec.pgEncode
arrayEnc =
AppE
(VarE 'Hasql.Encoders.foldableArray)
(AppE elementNullability codec)
paramEnc =
AppE
(VarE 'Hasql.Encoders.param)
(AppE (VarE 'Hasql.Encoders.nonNullable) arrayEnc)
accessor = tupleAccessor tupleSize idx
mapSelector = AppE (VarE 'map) accessor
in AppE (AppE (VarE 'Contravariant.contramap) mapSelector) paramEnc
----------------------------------------------------------------------------------------------------
-- CRUD statement generation
----------------------------------------------------------------------------------------------------
{- Assemble a typed top-level @Statement@ binding from its parts: name, type
signature, SQL literal, encoder expression, and decoder expression.
Every statement generator delegates to this for the final assembly.
-}
genStatement :: Name -> Type -> Exp -> Exp -> Exp -> Q [Dec]
genStatement stmtName sigTy sql enc dec = do
sig <- sigD stmtName (return sigTy)
let body = applyStatement sql enc dec
valDec = ValD (VarP stmtName) (NormalB body) []
return [sig, valDec]
genSelectByPk
:: String -> String -> String -> [ResolvedColumn] -> PkInfo -> Maybe String -> Q [Dec]
genSelectByPk schema table typName cols pkInfo pkTypOverride = do
let stmtName = mkName ("select" <> typName)
decName = mkName (camelCase typName <> "Decoder")
pkType = pkParamType pkTypOverride pkInfo
sql = selectByPkSql schema table cols pkInfo
sigTy =
AppT
(AppT (ConT ''Hasql.Statement.Statement) pkType)
(AppT (ConT ''Maybe) (ConT (mkName typName)))
pkEnc <- pkEncoder pkTypOverride pkInfo
genStatement stmtName sigTy sql pkEnc (AppE (VarE 'Hasql.Decoders.rowMaybe) (VarE decName))
{- Compute the columns to include in INSERT. When 'withholdPk' is active
and all PK columns have database defaults, the PK columns are excluded
from the insert column list (the DB generates them). Without 'withholdPk',
all columns are always included.
-}
computeInsertCols :: Bool -> [ResolvedColumn] -> PkInfo -> [ResolvedColumn]
computeInsertCols withhold allCols pkInfo =
let pkNames = pkColumnNames pkInfo
pkCols = filter (\rc -> rcColName rc `elem` pkNames) allCols
allPkDefaulted = not (null pkCols) && all rcHasDefault pkCols
in if withhold && allPkDefaulted
then filter (\rc -> rcColName rc `notElem` pkNames) allCols
else allCols
{- Generate the INSERT statement. @allCols@ is the full record column list
(used for RETURNING and the decoder), @insertCols@ is the subset actually
included in the INSERT column list and VALUES params. When PK columns have
defaults, @insertCols@ excludes them.
-}
genInsert
:: String -> String -> String -> [ResolvedColumn] -> [ResolvedColumn] -> Q [Dec]
genInsert schema table typName allCols insertCols =
let stmtName = mkName ("insert" <> typName)
tName = mkName typName
decName = mkName (camelCase typName <> "Decoder")
sql = insertSql schema table allCols insertCols
sigTy = AppT (AppT (ConT ''Hasql.Statement.Statement) (ConT tName)) (ConT tName)
enc = insertEncoder tName insertCols
in genStatement stmtName sigTy sql enc (AppE (VarE 'Hasql.Decoders.singleRow) (VarE decName))
{- Generate an inline encoder for the INSERT that only encodes the insert
columns (which may be a subset of all columns when PK columns are excluded).
-}
insertEncoder :: Name -> [ResolvedColumn] -> Exp
insertEncoder tName cols =
AppE (VarE 'mconcat) (ListE (map (columnEncodeExp tName) cols))
{- The UPDATE uses the full record encoder, so SQL parameter positions match
the record field order. SET covers non-PK columns and WHERE covers PK
columns, each referencing the correct @$N@ from the encoder.
-}
genUpdate
:: String -> String -> String -> [ResolvedColumn] -> PkInfo -> Q [Dec]
genUpdate schema table typName cols pkInfo =
let stmtName = mkName ("update" <> typName)
tName = mkName typName
encName = mkName (camelCase typName <> "Encoder")
decName = mkName (camelCase typName <> "Decoder")
sql = updateSql schema table cols pkInfo
sigTy =
AppT
(AppT (ConT ''Hasql.Statement.Statement) (ConT tName))
(AppT (ConT ''Maybe) (ConT tName))
in genStatement stmtName sigTy sql (VarE encName) (AppE (VarE 'Hasql.Decoders.rowMaybe) (VarE decName))
genDeleteByPk :: String -> String -> String -> PkInfo -> Maybe String -> Q [Dec]
genDeleteByPk schema table _typName pkInfo pkTypOverride = do
let stmtName = mkName ("delete" <> pascalCase table)
pkType = pkParamType pkTypOverride pkInfo
sql = deleteSql schema table pkInfo
sigTy = AppT (AppT (ConT ''Hasql.Statement.Statement) pkType) (TupleT 0)
pkEnc <- pkEncoder pkTypOverride pkInfo
genStatement stmtName sigTy sql pkEnc (VarE 'Hasql.Decoders.noResult)
{- Generate @selectMany\<TypeName\> :: Statement [PkType] [TypeName]@.
Uses 'selectManySql' and 'pkArrayEncoder' for the input encoding.
-}
genSelectMany
:: String -> String -> String -> [ResolvedColumn] -> PkInfo -> Maybe String -> Q [Dec]
genSelectMany schema table typName cols pkInfo pkTypOverride = do
let stmtName = mkName ("selectMany" <> typName)
tName = mkName typName
decName = mkName (camelCase typName <> "Decoder")
pkType = pkParamType pkTypOverride pkInfo
sql = selectManySql schema table cols pkInfo
sigTy =
AppT
(AppT (ConT ''Hasql.Statement.Statement) (AppT ListT pkType))
(AppT ListT (ConT tName))
pkEnc <- pkArrayEncoder pkTypOverride pkInfo
genStatement stmtName sigTy sql pkEnc (AppE (VarE 'Hasql.Decoders.rowList) (VarE decName))
{- Generate @deleteMany\<TypeName\> :: Statement [PkType] ()@.
Uses 'deleteManySql' and 'pkArrayEncoder'.
-}
genDeleteMany
:: String -> String -> String -> PkInfo -> Maybe String -> Q [Dec]
genDeleteMany schema table _typName pkInfo pkTypOverride = do
let stmtName = mkName ("deleteMany" <> pascalCase table)
pkType = pkParamType pkTypOverride pkInfo
sql = deleteManySql schema table pkInfo
sigTy = AppT (AppT (ConT ''Hasql.Statement.Statement) (AppT ListT pkType)) (TupleT 0)
pkEnc <- pkArrayEncoder pkTypOverride pkInfo
genStatement stmtName sigTy sql pkEnc (VarE 'Hasql.Decoders.noResult)
{- Generate @insertMany\<TypeName\> :: Statement [TypeName] [TypeName]@.
Uses 'insertManySql' and @mconcat@ of 'columnArrayEncodeExp' for
each insert column. Respects 'computeInsertCols' (excludes defaulted
PK columns).
-}
genInsertMany
:: String -> String -> String -> [ResolvedColumn] -> [ResolvedColumn] -> Q [Dec]
genInsertMany schema table typName allCols insertCols =
let stmtName = mkName ("insertMany" <> typName)
tName = mkName typName
decName = mkName (camelCase typName <> "Decoder")
sql = insertManySql schema table allCols insertCols
sigTy =
AppT
(AppT (ConT ''Hasql.Statement.Statement) (AppT ListT (ConT tName)))
(AppT ListT (ConT tName))
enc = AppE (VarE 'mconcat) (ListE (map (columnArrayEncodeExp tName) insertCols))
in genStatement stmtName sigTy sql enc (AppE (VarE 'Hasql.Decoders.rowList) (VarE decName))
{- Generate @updateMany\<TypeName\> :: Statement [TypeName] [TypeName]@.
Uses 'updateManySql' and @mconcat@ of 'columnArrayEncodeExp' for ALL
columns (both PK and non-PK appear in the unnest subquery). Only generated
when the table has a primary key.
-}
genUpdateMany
:: String -> String -> String -> [ResolvedColumn] -> PkInfo -> Q [Dec]
genUpdateMany schema table typName cols pkInfo =
let stmtName = mkName ("updateMany" <> typName)
tName = mkName typName
decName = mkName (camelCase typName <> "Decoder")
sql = updateManySql schema table cols pkInfo
sigTy =
AppT
(AppT (ConT ''Hasql.Statement.Statement) (AppT ListT (ConT tName)))
(AppT ListT (ConT tName))
enc = AppE (VarE 'mconcat) (ListE (map (columnArrayEncodeExp tName) cols))
in genStatement stmtName sigTy sql enc (AppE (VarE 'Hasql.Decoders.rowList) (VarE decName))
----------------------------------------------------------------------------------------------------
-- Typeclass instance generation
----------------------------------------------------------------------------------------------------
-- | Build @\\param -> Hasql.Session.statement param stmtName@.
sessionLambda :: String -> Name -> Exp
sessionLambda paramName stmtName =
LamE
[VarP (mkName paramName)]
( AppE
(AppE (VarE 'Hasql.Session.statement) (VarE (mkName paramName)))
(VarE stmtName)
)
{- Generate an instance with two session-wrapper methods (single + batch) and
no associated types. Used for 'HasInsert' and 'HasUpdate'.
-}
genSimpleCrudInstance :: Name -> Name -> Name -> String -> String -> Q [Dec]
genSimpleCrudInstance className singleMethod batchMethod prefix typName = do
let tName = mkName typName
singleDec = FunD singleMethod [Clause [] (NormalB (sessionLambda "x" (mkName (prefix <> typName)))) []]
batchDec = FunD batchMethod [Clause [] (NormalB (sessionLambda "xs" (mkName (prefix <> "Many" <> typName)))) []]
return [InstanceD Nothing [] (AppT (ConT className) (ConT tName)) [singleDec, batchDec]]
{- Generate an instance with two session-wrapper methods (single + batch) and
one associated type for the key. Used for 'HasSelect' and 'HasDelete'.
-}
genKeyCrudInstance :: Name -> Name -> Name -> Name -> String -> String -> PkInfo -> Maybe String -> Q [Dec]
genKeyCrudInstance className singleMethod batchMethod assocType prefix typName pkInfo pkTypOverride = do
let tName = mkName typName
keyType = pkParamType pkTypOverride pkInfo
singleDec = FunD singleMethod [Clause [] (NormalB (sessionLambda "k" (mkName (prefix <> typName)))) []]
batchDec = FunD batchMethod [Clause [] (NormalB (sessionLambda "ks" (mkName (prefix <> "Many" <> typName)))) []]
keyTySynInst = TySynInstD (TySynEqn Nothing (AppT (ConT assocType) (ConT tName)) keyType)
return [InstanceD Nothing [] (AppT (ConT className) (ConT tName)) [keyTySynInst, singleDec, batchDec]]
genHasInsertInstance :: String -> Q [Dec]
genHasInsertInstance =
genSimpleCrudInstance ''Hasql.Generate.Class.HasInsert 'Hasql.Generate.Class.insert 'Hasql.Generate.Class.insertMany "insert"
genHasSelectInstance :: String -> PkInfo -> Maybe String -> Q [Dec]
genHasSelectInstance =
genKeyCrudInstance ''Hasql.Generate.Class.HasSelect 'Hasql.Generate.Class.select 'Hasql.Generate.Class.selectMany ''Hasql.Generate.Class.SelectKey "select"
genHasUpdateInstance :: String -> Q [Dec]
genHasUpdateInstance =
genSimpleCrudInstance ''Hasql.Generate.Class.HasUpdate 'Hasql.Generate.Class.update 'Hasql.Generate.Class.updateMany "update"
genHasDeleteInstance :: String -> PkInfo -> Maybe String -> Q [Dec]
genHasDeleteInstance =
genKeyCrudInstance ''Hasql.Generate.Class.HasDelete 'Hasql.Generate.Class.delete 'Hasql.Generate.Class.deleteMany ''Hasql.Generate.Class.DeleteKey "delete"
----------------------------------------------------------------------------------------------------
-- View-specific generators
----------------------------------------------------------------------------------------------------
{- Generate a @select<TypeName> :: Statement () [TypeName]@ that selects
all rows from the view with no parameters.
-}
genSelectView
:: String -> String -> String -> [ResolvedColumn] -> Q [Dec]
genSelectView schema table typName cols =
let stmtName = mkName ("select" <> typName)
tName = mkName typName
decName = mkName (camelCase typName <> "Decoder")
sql = selectViewSql schema table cols
sigTy =
AppT
(AppT (ConT ''Hasql.Statement.Statement) (TupleT 0))
(AppT ListT (ConT tName))
in genStatement stmtName sigTy sql (VarE 'Hasql.Encoders.noParams) (AppE (VarE 'Hasql.Decoders.rowList) (VarE decName))
selectViewSql :: String -> String -> [ResolvedColumn] -> Exp
selectViewSql schema table cols =
sqlLit
( "SELECT "
<> columnList cols
<> " FROM "
<> qualifiedName schema table
)
-- | Generate a @HasView@ instance for a view.
genHasViewInstance :: String -> Q [Dec]
genHasViewInstance typName = do
let tName = mkName typName
stmtName = mkName ("select" <> typName)
body =
AppE
(AppE (VarE 'Hasql.Session.statement) (TupE []))
(VarE stmtName)
selectViewMethod = FunD 'Hasql.Generate.Class.selectView [Clause [] (NormalB body) []]
return [InstanceD Nothing [] (AppT (ConT ''Hasql.Generate.Class.HasView) (ConT tName)) [selectViewMethod]]
----------------------------------------------------------------------------------------------------
-- SQL generation helpers
----------------------------------------------------------------------------------------------------
selectByPkSql :: String -> String -> [ResolvedColumn] -> PkInfo -> Exp
selectByPkSql schema table cols pkInfo =
let pkWhere = pkWhereClause pkInfo 1
in sqlLit
( "SELECT "
<> columnList cols
<> " FROM "
<> qualifiedName schema table
<> " WHERE "
<> pkWhere
)
insertSql :: String -> String -> [ResolvedColumn] -> [ResolvedColumn] -> Exp
insertSql schema table allCols insertCols =
let insertColNames = columnList insertCols
returnColNames = columnList allCols
params = typedParamList 1 insertCols
in sqlLit
( "INSERT INTO "
<> qualifiedName schema table
<> " ("
<> insertColNames
<> ")"
<> " VALUES ("
<> params
<> ")"
<> " RETURNING "
<> returnColNames
)
updateSql :: String -> String -> [ResolvedColumn] -> PkInfo -> Exp
updateSql schema table cols pkInfo =
let pkNames = pkColumnNames pkInfo
indexed = zip cols (enumFromTo 1 (length cols))
nonPkSet = filter (\(rc, _) -> rcColName rc `notElem` pkNames) indexed
pkWhere = filter (\(rc, _) -> rcColName rc `elem` pkNames) indexed
setClauses =
intercalate
", "
(map (\(rc, i) -> quoteIdent (rcColName rc) <> " = " <> paramRef i rc) nonPkSet)
whereClauses =
intercalate
" AND "
(map (\(rc, i) -> quoteIdent (rcColName rc) <> " = " <> paramRef i rc) pkWhere)
in sqlLit
( "UPDATE "
<> qualifiedName schema table
<> " SET "
<> setClauses
<> " WHERE "
<> whereClauses
<> " RETURNING "
<> columnList cols
)
deleteSql :: String -> String -> PkInfo -> Exp
deleteSql schema table pkInfo =
let pkWhere = pkWhereClause pkInfo 1
in sqlLit
( "DELETE FROM "
<> qualifiedName schema table
<> " WHERE "
<> pkWhere
)
----------------------------------------------------------------------------------------------------
-- Batch SQL generation helpers
----------------------------------------------------------------------------------------------------
{- Generate SQL for batch select: @SELECT cols FROM s.t WHERE pk = ANY($1)@
for single PK, or @WHERE (c1, c2) IN (SELECT unnest($1), unnest($2))@
for composite PK.
-}
selectManySql :: String -> String -> [ResolvedColumn] -> PkInfo -> Exp
selectManySql schema table cols pkInfo =
sqlLit
( "SELECT "
<> columnList cols
<> " FROM "
<> qualifiedName schema table
<> " WHERE "
<> batchPkWhereClause pkInfo
)
{- Generate SQL for batch delete: same WHERE clause logic as 'selectManySql'.
-}
deleteManySql :: String -> String -> PkInfo -> Exp
deleteManySql schema table pkInfo =
sqlLit
( "DELETE FROM "
<> qualifiedName schema table
<> " WHERE "
<> batchPkWhereClause pkInfo
)
{- Generate SQL for batch insert using @unnest@-based array parameters:
@INSERT INTO s.t (cols) SELECT * FROM unnest($1, $2, ...) RETURNING allCols@
-}
insertManySql :: String -> String -> [ResolvedColumn] -> [ResolvedColumn] -> Exp
insertManySql schema table allCols insertCols =
let insertColNames = columnList insertCols
returnColNames = columnList allCols
params = typedArrayParamList 1 insertCols
in sqlLit
( "INSERT INTO "
<> qualifiedName schema table
<> " ("
<> insertColNames
<> ") SELECT * FROM unnest("
<> params
<> ") RETURNING "
<> returnColNames
)
{- Generate SQL for batch update using an @unnest@ subquery join:
@UPDATE s.t SET c1 = d.c1, c2 = d.c2
FROM (SELECT unnest($1) AS pk, unnest($2) AS c1, unnest($3) AS c2) d
WHERE s.t.pk = d.pk
RETURNING s.t.*@
All columns (PK and non-PK) appear in the unnest subquery. SET covers
non-PK columns. WHERE joins on PK columns.
-}
updateManySql :: String -> String -> [ResolvedColumn] -> PkInfo -> Exp
updateManySql schema table cols pkInfo =
let pkNames = pkColumnNames pkInfo
nonPkCols = filter (\rc -> rcColName rc `notElem` pkNames) cols
setClauses =
intercalate
", "
(map (\rc -> quoteIdent (rcColName rc) <> " = d." <> quoteIdent (rcColName rc)) nonPkCols)
-- All columns in the unnest subquery
unnestParams =
intercalate
", "
( zipWith
(\rc i -> "unnest(" <> arrayParamRef i rc <> ") AS " <> quoteIdent (rcColName rc))
cols
(enumFromTo 1 (length cols))
)
-- WHERE join on PK columns
pkJoin =
intercalate
" AND "
( map
(\pkn -> qualifiedName schema table <> "." <> quoteIdent pkn <> " = d." <> quoteIdent pkn)
pkNames
)
in sqlLit
( "UPDATE "
<> qualifiedName schema table
<> " SET "
<> setClauses
<> " FROM (SELECT "
<> unnestParams
<> ") d WHERE "
<> pkJoin
<> " RETURNING "
<> qualifiedName schema table
<> ".*"
)
{- Generate the WHERE clause for batch PK operations.
Single PK: @pk = ANY($1)@ — uses @arrayParamRef@ for enum cast support.
Composite PK: @(c1, c2) IN (SELECT unnest($1), unnest($2))@.
-}
batchPkWhereClause :: PkInfo -> String
batchPkWhereClause NoPrimaryKey = "true"
batchPkWhereClause (SinglePk rc) =
quoteIdent (rcColName rc) <> " = ANY(" <> arrayParamRef 1 rc <> ")"
batchPkWhereClause (CompositePk rcs) =
let pkTuple = "(" <> intercalate ", " (map (quoteIdent . rcColName) rcs) <> ")"
unnests =
intercalate
", "
( zipWith
(\rc i -> "unnest(" <> arrayParamRef i rc <> ")")
rcs
(enumFromTo 1 (length rcs))
)
in pkTuple <> " IN (SELECT " <> unnests <> ")"
{- Generate a comma-separated array parameter list with per-column type casts,
using 'arrayParamRef' so enum types get @[]@ appended.
-}
typedArrayParamList :: Int -> [ResolvedColumn] -> String
typedArrayParamList start cols =
intercalate ", " (zipWith arrayParamRef (enumFromTo start (start + length cols - 1)) cols)
textLit :: String -> Exp
textLit s = AppE (VarE 'Data.String.fromString) (LitE (StringL s))
sqlLit :: String -> Exp
sqlLit = textLit
applyStatement :: Exp -> Exp -> Exp -> Exp
applyStatement sql enc dec =
foldl AppE (ConE 'Hasql.Statement.Statement) [sql, enc, dec, ConE 'True]
columnList :: [ResolvedColumn] -> String
columnList cols = intercalate ", " (map (quoteIdent . rcColName) cols)
{- Format a single parameter reference, appending a @::type@ cast when the
column has 'rcPgCast' set (e.g. for enum types).
@paramRef 3 rc@ → @\"$3\"@ or @\"$3::hg_test.user_role\"@
-}
paramRef :: Int -> ResolvedColumn -> String
paramRef i rc = case rcPgCast rc of
Nothing -> "$" <> show i
Just cast -> "$" <> show i <> "::" <> cast
{- Format an array parameter reference for batch operations. Appends @[]@ to
the cast suffix for enum types so that PostgreSQL receives the correct
array type annotation.
@arrayParamRef 1 rcEnum@ produces @\"$1::hg_test.user_role[]\"@
@arrayParamRef 2 rcPlain@ produces @\"$2\"@
-}
arrayParamRef :: Int -> ResolvedColumn -> String
arrayParamRef i rc = case rcPgCast rc of
Nothing -> "$" <> show i
Just cast -> "$" <> show i <> "::" <> cast <> "[]"
{- Generate a comma-separated parameter list with per-column type casts.
@typedParamList 1 [rcPlain, rcEnum]@ → @\"$1, $2::hg_test.user_role\"@
-}
typedParamList :: Int -> [ResolvedColumn] -> String
typedParamList start cols =
intercalate ", " (zipWith paramRef (enumFromTo start (start + length cols - 1)) cols)
pkWhereClause :: PkInfo -> Int -> String
pkWhereClause NoPrimaryKey _ = "true"
pkWhereClause (SinglePk rc) startIdx =
quoteIdent (rcColName rc) <> " = " <> paramRef startIdx rc
pkWhereClause (CompositePk rcs) startIdx =
intercalate
" AND "
( zipWith
(\rc i -> quoteIdent (rcColName rc) <> " = " <> paramRef i rc)
rcs
(enumFromTo startIdx (startIdx + length rcs - 1))
)
pkColumnNames :: PkInfo -> [String]
pkColumnNames NoPrimaryKey = []
pkColumnNames (SinglePk rc) = [rcColName rc]
pkColumnNames (CompositePk rcs) = map rcColName rcs
----------------------------------------------------------------------------------------------------
-- PK type and encoder helpers
----------------------------------------------------------------------------------------------------
pkParamType :: Maybe String -> PkInfo -> Type
pkParamType (Just pkTypName) (CompositePk _) = ConT (mkName pkTypName)
pkParamType _ NoPrimaryKey = TupleT 0
pkParamType _ (SinglePk rc) = fieldType rc
pkParamType _ (CompositePk rcs) =
foldl AppT (TupleT (length rcs)) (map fieldType rcs)
pkEncoder :: Maybe String -> PkInfo -> Q Exp
pkEncoder (Just pkTypName) (CompositePk _) =
return (VarE (mkName (camelCase pkTypName <> "Encoder")))
pkEncoder _ NoPrimaryKey = return (VarE 'Hasql.Encoders.noParams)
pkEncoder _ (SinglePk rc) = return (singleParamEncoder rc)
pkEncoder _ (CompositePk rcs) = return (compositeEncoder rcs)
singleParamEncoder :: ResolvedColumn -> Exp
singleParamEncoder rc =
let nullability =
if rcNotNull rc
then VarE 'Hasql.Encoders.nonNullable
else VarE 'Hasql.Encoders.nullable
codec = VarE 'Hasql.Generate.Codec.pgEncode
in AppE (VarE 'Hasql.Encoders.param) (AppE nullability codec)
compositeEncoder :: [ResolvedColumn] -> Exp
compositeEncoder rcs =
let n = length rcs
encoders =
zipWith
(flip (tupleFieldEncoder n))
rcs
(enumFromTo 0 (n - 1))
in AppE (VarE 'mconcat) (ListE encoders)
tupleFieldEncoder :: Int -> Int -> ResolvedColumn -> Exp
tupleFieldEncoder tupleSize idx rc =
let nullability =
if rcNotNull rc
then VarE 'Hasql.Encoders.nonNullable
else VarE 'Hasql.Encoders.nullable
codec = VarE 'Hasql.Generate.Codec.pgEncode
paramEnc = AppE (VarE 'Hasql.Encoders.param) (AppE nullability codec)
accessor = tupleAccessor tupleSize idx
in AppE (AppE (VarE 'Contravariant.contramap) accessor) paramEnc
{- Build a lambda extracting the Nth element from a tuple of known size.
For pairs, uses @fst@ and @snd@. For larger tuples, generates a pattern match:
@\\(_, _, x, _) -> x@
-}
tupleAccessor :: Int -> Int -> Exp
tupleAccessor 2 0 = VarE 'Data.Tuple.fst
tupleAccessor 2 1 = VarE 'Data.Tuple.snd
tupleAccessor size idx =
let names = map (\i -> mkName ("t" <> show i)) (enumFromTo 0 (size - 1))
pats = map VarP names
target = names !! idx
in LamE [TupP pats] (VarE target)
----------------------------------------------------------------------------------------------------
-- Newtype PK generation
----------------------------------------------------------------------------------------------------
{- Generate a newtype wrapper for a single-column primary key.
@genPkNewtype \"UsersPk\" [''Show, ''Eq] rc@ where @rc@ has type @UUID@
produces:
@newtype UsersPk = UsersPk { getUsersPk :: !UUID } deriving stock (Show, Eq)@
-}
genPkNewtype :: String -> [Name] -> ResolvedColumn -> Q [Dec]
genPkNewtype pkTypName derivNames rc = do
let tName = mkName pkTypName
unwrapperName = mkName ("get" <> pkTypName)
fieldBang = Bang NoSourceUnpackedness NoSourceStrictness
field = (unwrapperName, fieldBang, rcType rc)
con = RecC tName [field]
derivClauses = mkDerivClauses derivNames
return [NewtypeD [] tName [] Nothing con derivClauses]
{- Generate a @PgCodec@ instance for a single-column PK newtype.
@genPkNewtypeCodec \"UsersPk\"@ produces:
@
instance PgCodec UsersPk where
pgDecode = UsersPk \<$\> pgDecode
pgEncode = contramap getUsersPk pgEncode
@
-}
genPkNewtypeCodec :: String -> Q [Dec]
genPkNewtypeCodec pkTypName = do
let tName = mkName pkTypName
conName = mkName pkTypName
unwrapperName = mkName ("get" <> pkTypName)
-- pgDecode = Con <$> pgDecode
decoderBody =
InfixE
(Just (ConE conName))
(VarE '(<$>))
(Just (VarE 'Hasql.Generate.Codec.pgDecode))
decoderDec = FunD 'Hasql.Generate.Codec.pgDecode [Clause [] (NormalB decoderBody) []]
-- pgEncode = contramap unwrapper pgEncode
encoderBody =
AppE
(AppE (VarE 'Contravariant.contramap) (VarE unwrapperName))
(VarE 'Hasql.Generate.Codec.pgEncode)
encoderDec = FunD 'Hasql.Generate.Codec.pgEncode [Clause [] (NormalB encoderBody) []]
instanceType = AppT (ConT ''Hasql.Generate.Codec.PgCodec) (ConT tName)
return [InstanceD Nothing [] instanceType [decoderDec, encoderDec]]
{- Generate a data record for a composite primary key.
@genPkRecord \"CompositePkPk\" [''Show, ''Eq] pkRcs@ produces a record with
fields matching the PK columns.
-}
genPkRecord :: String -> [Name] -> [ResolvedColumn] -> Q [Dec]
genPkRecord pkTypName derivNames pkRcs = do
let tName = mkName pkTypName
fields = map mkPkField pkRcs
con = RecC tName fields
derivClauses = mkDerivClauses derivNames
return [DataD [] tName [] Nothing [con] derivClauses]
where
mkPkField :: ResolvedColumn -> VarBangType
mkPkField rc =
let fName = mkName (rcFieldName rc)
fieldBang = Bang NoSourceUnpackedness SourceStrict
in (fName, fieldBang, fieldType rc)
{- Generate an encoder for a composite PK record type.
@genPkRecordEncoder \"CompositePkPk\" pkRcs@ produces:
@
compositePkPkEncoder :: Encoders.Params CompositePkPk
compositePkPkEncoder = mconcat [...]
@
-}
genPkRecordEncoder :: String -> [ResolvedColumn] -> Q [Dec]
genPkRecordEncoder pkTypName pkRcs = do
let encName = mkName (camelCase pkTypName <> "Encoder")
tName = mkName pkTypName
sigTy = AppT (ConT ''Hasql.Encoders.Params) (ConT tName)
sig <- sigD encName (return sigTy)
let body = AppE (VarE 'mconcat) (ListE (map (columnEncodeExp tName) pkRcs))
dec = ValD (VarP encName) (NormalB body) []
return [sig, dec]
{- Compute the field name for a PK record column. Uses @rcColName@ (the raw PG
column name) rather than the main record's potentially-prefixed @rcFieldName@.
-}
pkRecordFieldName :: String -> Bool -> ResolvedColumn -> ResolvedColumn
pkRecordFieldName pkTypName allowDupFields rc =
if allowDupFields
then rc {rcFieldName = sanitizeField (camelCase (rcColName rc))}
else rc {rcFieldName = sanitizeField (camelCase pkTypName <> pascalCase (rcColName rc))}
----------------------------------------------------------------------------------------------------
-- HasPrimaryKey instance generation
----------------------------------------------------------------------------------------------------
{- Generate a @HasPrimaryKey@ instance for a table.
Handles all four cases: single/composite × newtypes/no-newtypes.
@rawPk@ is generated explicitly since the type families are non-injective
and GHC cannot resolve a default @unwrapPk . toPk@ composition.
-}
genHasPrimaryKeyInstance
:: String -> PkInfo -> PkInfo -> Bool -> Maybe String -> Bool -> Q [Dec]
genHasPrimaryKeyInstance typName origPkInfo pkInfo' useNtPk pkTypOverride allowDupFields = do
let tName = mkName typName
pkOfType = pkParamType pkTypOverride pkInfo'
rawPkOfType = pkParamType Nothing origPkInfo
pkOfTySynInst =
TySynInstD
(TySynEqn Nothing (AppT (ConT ''Hasql.Generate.Class.PkOf) (ConT tName)) pkOfType)
rawPkOfTySynInst =
TySynInstD
(TySynEqn Nothing (AppT (ConT ''Hasql.Generate.Class.RawPkOf) (ConT tName)) rawPkOfType)
toPkBody <- genToPk typName pkInfo' pkTypOverride allowDupFields
wrapPkBody <- genWrapPk origPkInfo pkInfo' useNtPk pkTypOverride allowDupFields
unwrapPkBody <- genUnwrapPk origPkInfo pkInfo' useNtPk pkTypOverride allowDupFields
rawPkBody <- genRawPk typName origPkInfo pkInfo' useNtPk pkTypOverride allowDupFields
let toPkDec = FunD 'Hasql.Generate.Class.toPk [Clause [] (NormalB toPkBody) []]
wrapPkDec = FunD 'Hasql.Generate.Class.wrapPk [Clause [] (NormalB wrapPkBody) []]
unwrapPkDec = FunD 'Hasql.Generate.Class.unwrapPk [Clause [] (NormalB unwrapPkBody) []]
rawPkDec = FunD 'Hasql.Generate.Class.rawPk [Clause [] (NormalB rawPkBody) []]
instanceType = AppT (ConT ''Hasql.Generate.Class.HasPrimaryKey) (ConT tName)
return
[ InstanceD
Nothing
[]
instanceType
[pkOfTySynInst, rawPkOfTySynInst, toPkDec, wrapPkDec, unwrapPkDec, rawPkDec]
]
{- Generate the @toPk@ method body: extracts PK field(s) from the main record.
Single PK: @\\Rec{field = x} -> x@
Composite, no newtypes: @\\Rec{f1 = x0, f2 = x1} -> (x0, x1)@
Composite, with newtypes: @\\Rec{f1 = x0, f2 = x1} -> PkRec{pf1 = x0, pf2 = x1}@
-}
genToPk :: String -> PkInfo -> Maybe String -> Bool -> Q Exp
genToPk typName pkInfo' pkTypOverride allowDupFields = do
let tName = mkName typName
case pkInfo' of
NoPrimaryKey -> fail "hasql-generate: genToPk called with NoPrimaryKey"
SinglePk rc -> do
let x = mkName "x"
return (LamE [RecP tName [(mkName (rcFieldName rc), VarP x)]] (VarE x))
CompositePk rcs -> do
let xs = map (\i -> mkName ("x" <> show i)) (enumFromTo 0 (length rcs - 1))
pat = RecP tName (zipWith (\rc x -> (mkName (rcFieldName rc), VarP x)) rcs xs)
case pkTypOverride of
Just pkTypName -> do
let pkCon = mkName pkTypName
pkRcs = map (pkRecordFieldName pkTypName allowDupFields) rcs
body = RecConE pkCon (zipWith (\prc x -> (mkName (rcFieldName prc), VarE x)) pkRcs xs)
return (LamE [pat] body)
Nothing -> do
let body = TupE (map (Just . VarE) xs)
return (LamE [pat] body)
{- Generate the @wrapPk@ method body: converts raw PK value(s) to the PK type.
No newtypes: @\\x -> x@ (identity)
Single + newtypes: @ConE pkTypName@ (newtype constructor)
Composite + newtypes: @\\(x0, x1) -> PkRec{pf1 = x0, pf2 = x1}@
-}
genWrapPk :: PkInfo -> PkInfo -> Bool -> Maybe String -> Bool -> Q Exp
genWrapPk _origPkInfo _pkInfo' useNtPk pkTypOverride allowDupFields
| not useNtPk = return identityLam
| otherwise = case (_origPkInfo, pkTypOverride) of
(SinglePk _, _) -> do
let pkTypName = case _pkInfo' of
SinglePk rc -> case rcType rc of
ConT n -> nameBase n
_ -> ""
_ -> ""
return (ConE (mkName pkTypName))
(CompositePk rcs, Just pkTypName) -> do
let n = length rcs
xs = map (\i -> mkName ("x" <> show i)) (enumFromTo 0 (n - 1))
pat = TupP (map VarP xs)
pkRcs = map (pkRecordFieldName pkTypName allowDupFields) rcs
body = RecConE (mkName pkTypName) (zipWith (\prc x -> (mkName (rcFieldName prc), VarE x)) pkRcs xs)
return (LamE [pat] body)
_ -> return identityLam
{- Generate the @unwrapPk@ method body: converts PK type to raw value(s).
No newtypes: @\\x -> x@ (identity)
Single + newtypes: @VarE getterName@ (newtype field accessor)
Composite + newtypes: @\\PkRec{pf1 = x0, pf2 = x1} -> (x0, x1)@
-}
genUnwrapPk :: PkInfo -> PkInfo -> Bool -> Maybe String -> Bool -> Q Exp
genUnwrapPk _origPkInfo _pkInfo' useNtPk pkTypOverride allowDupFields
| not useNtPk = return identityLam
| otherwise = case (_origPkInfo, pkTypOverride) of
(SinglePk _, _) -> do
let pkTypName = case _pkInfo' of
SinglePk rc -> case rcType rc of
ConT n -> nameBase n
_ -> ""
_ -> ""
return (VarE (mkName ("get" <> pkTypName)))
(CompositePk rcs, Just pkTypName) -> do
let n = length rcs
xs = map (\i -> mkName ("x" <> show i)) (enumFromTo 0 (n - 1))
pkRcs = map (pkRecordFieldName pkTypName allowDupFields) rcs
pat = RecP (mkName pkTypName) (zipWith (\prc x -> (mkName (rcFieldName prc), VarP x)) pkRcs xs)
body = TupE (map (Just . VarE) xs)
return (LamE [pat] body)
_ -> return identityLam
{- Generate the @rawPk@ method body: extracts raw PK value(s) directly from the
main record.
Without newtypes: same as @toPk@ — the PK type is already the raw type.
With newtypes, single PK: pattern matches through the newtype to extract
the raw value (e.g. @\\Rec{id = NtSinglePk x} -> x@).
With newtypes, composite PK: extracts raw fields into a tuple (the record
fields are already raw types, only the PK wrapper is a record).
-}
genRawPk :: String -> PkInfo -> PkInfo -> Bool -> Maybe String -> Bool -> Q Exp
genRawPk typName origPkInfo pkInfo' useNtPk _pkTypOverride allowDupFields
| not useNtPk = genToPk typName origPkInfo Nothing allowDupFields
| otherwise = do
let tName = mkName typName
case origPkInfo of
NoPrimaryKey -> fail "hasql-generate: genRawPk called with NoPrimaryKey"
SinglePk _rc -> do
-- The record field is the newtype; pattern match through it
case pkInfo' of
SinglePk rc' -> do
let pkTypName = case rcType rc' of
ConT n -> nameBase n
_ -> ""
x = mkName "x"
innerPat = ConP (mkName pkTypName) [] [VarP x]
pat = RecP tName [(mkName (rcFieldName rc'), innerPat)]
return (LamE [pat] (VarE x))
_ -> fail "hasql-generate: genRawPk single PK mismatch"
CompositePk rcs -> do
-- Composite PK fields in the main record are raw types (not rewritten)
let xs = map (\i -> mkName ("x" <> show i)) (enumFromTo 0 (length rcs - 1))
-- Use pkInfo' field names since those are what the main record uses
rcs' = case pkInfo' of
CompositePk cs -> cs
_ -> rcs
pat = RecP tName (zipWith (\rc x -> (mkName (rcFieldName rc), VarP x)) rcs' xs)
body = TupE (map (Just . VarE) xs)
return (LamE [pat] body)
identityLam :: Exp
identityLam =
let x = mkName "x"
in LamE [VarP x] (VarE x)
----------------------------------------------------------------------------------------------------
-- Utility functions
----------------------------------------------------------------------------------------------------
{- Wrap a single PostgreSQL identifier in double-quotes, escaping any
internal double-quote characters per the SQL standard (@\"\"@ → @\"\"\"\"@).
-}
quoteIdent :: String -> String
quoteIdent s = "\"" <> concatMap escDQ s <> "\""
where
escDQ '"' = "\"\""
escDQ c = [c]
{- Build a schema-qualified, double-quoted identifier pair.
@qualifiedName \"public\" \"users\"@ → @\"\\\"public\\\".\\\"users\\\"\"@
-}
qualifiedName :: String -> String -> String
qualifiedName schema name = quoteIdent schema <> "." <> quoteIdent name
{- Prefix a resolved column's field name with the type name in camelCase.
@prefixFieldName \"Users\" rc{rcColName=\"tenant_id\"}@ gives
@rc{rcFieldName=\"usersTenantId\"}@
-}
prefixFieldName :: String -> ResolvedColumn -> ResolvedColumn
prefixFieldName typName rc =
rc {rcFieldName = sanitizeField (camelCase typName <> pascalCase (rcColName rc))}
{- Append an apostrophe to a camelCase identifier if it collides with a
Haskell reserved keyword. This is idiomatic Haskell (e.g. @type'@, @class'@).
-}
sanitizeField :: String -> String
sanitizeField s
| s `elem` haskellKeywords = s <> "'"
| otherwise = s
-- | Haskell reserved keywords that may collide with generated camelCase identifiers.
haskellKeywords :: [String]
haskellKeywords =
[ "case"
, "class"
, "data"
, "default"
, "deriving"
, "do"
, "else"
, "forall"
, "foreign"
, "hiding"
, "if"
, "import"
, "in"
, "infix"
, "infixl"
, "infixr"
, "instance"
, "let"
, "module"
, "newtype"
, "of"
, "qualified"
, "then"
, "type"
, "where"
, "mdo"
, "rec"
, "proc"
, "pattern"
, "role"
, "family"
, "stock"
, "anyclass"
, "via"
]
{- Convert a snake_case or plain identifier to PascalCase.
@\"user_emails\" → \"UserEmails\"@
@\"users\" → \"Users\"@
-}
pascalCase :: String -> String
pascalCase = concatMap titleWord . splitSnake
{- Convert a snake_case or PascalCase identifier to camelCase.
@\"tenant_id\" → \"tenantId\"@
@\"UserEmails\" → \"userEmails\"@
@\"name\" → \"name\"@
-}
camelCase :: String -> String
camelCase s = case splitSnake s of
[] -> []
(w : ws) -> lowerFirst w <> concatMap titleWord ws
titleWord :: String -> String
titleWord [] = []
titleWord (c : cs) = toUpper c : cs
lowerFirst :: String -> String
lowerFirst [] = []
lowerFirst (c : cs) = toLower c : cs
{- Split a string on underscores.
@\"tenant_id\" → [\"tenant\", \"id\"]@
@\"name\" → [\"name\"]@
-}
splitSnake :: String -> [String]
splitSnake [] = []
splitSnake s = case break (== '_') s of
(word, []) -> [word]
(word, _ : rest) -> word : splitSnake rest