Something went wrong. Try again.
Compile-time SQL datatype generation from PostgreSQL for Haskell
Something went wrong. Try again.
67 kB · 1725 lines
Haskell
at main
1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726module Hasql.Generate.TH ( GenerateConfig , fromTable , fromType , fromView , generate , withDefaultedCols , withDerivations , withOverrides ) where
----------------------------------------------------------------------------------------------------
import Control.Applicative ( (<*>) )import Control.Monad ( mapM, 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 Contravariantimport Data.Int ( Int )import Data.List ( 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.Stringimport qualified Data.Textimport qualified Data.Tuple
import qualified Hasql.Decodersimport qualified Hasql.Encodersimport qualified Hasql.Generate.Classimport qualified Hasql.Generate.Codecimport qualified Hasql.Generate.Columnimport Hasql.Generate.Config ( Config (..) )import Hasql.Generate.Connection ( toConnString , withCompileTimeConnection )import Hasql.Generate.Internal.Introspect ( ColumnInfo (..) , introspectColumns , introspectEnumLabels , introspectPrimaryKey )import qualified Hasql.Sessionimport 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)] & withDefaultedCols [\"id\"] @-}data GenerateConfig = GenerateConfig { gcSchema :: String , gcTable :: String , gcKind :: RelationKind , gcDerivations :: [Name] , gcOverrides :: [(String, Name)] , gcDefaultedCols :: [String] }
{- | Create a 'GenerateConfig' for the given schema and table with no derivations and no type overrides. Generates full CRUD code.-}fromTable :: String -> String -> GenerateConfigfromTable schema table = GenerateConfig { gcSchema = schema , gcTable = table , gcKind = Table , gcDerivations = [] , gcOverrides = [] , gcDefaultedCols = [] }
{- | 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 -> GenerateConfigfromView schema view = GenerateConfig { gcSchema = schema , gcTable = view , gcKind = View , gcDerivations = [] , gcOverrides = [] , gcDefaultedCols = [] }
{- | 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 -> GenerateConfigfromType schema typeName = GenerateConfig { gcSchema = schema , gcTable = typeName , gcKind = Type , gcDerivations = [] , gcOverrides = [] , gcDefaultedCols = [] }
-- | Append derivation class 'Name's to the config.withDerivations :: [Name] -> GenerateConfig -> GenerateConfigwithDerivations names cfg = cfg {gcDerivations = gcDerivations 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 -> GenerateConfigwithOverrides ovs cfg = cfg {gcOverrides = gcOverrides cfg <> ovs}
{- | Exclude the named columns from INSERT statements. Each column must exist in the table and have a database default (@atthasdef = true@ in @pg_catalog@); a compile-time error is raised otherwise.
@ fromTable \"public\" \"users\" & withDefaultedCols [\"id\", \"created_at\"] @-}withDefaultedCols :: [String] -> GenerateConfig -> GenerateConfigwithDefaultedCols cols cfg = cfg {gcDefaultedCols = gcDefaultedCols cfg <> cols}
{- | 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 defaultedCols schema table typeName derivNames resolvedCols pkInfo View -> do (typeName, resolvedCols, _) <- getPgData generateViewDecs schema table typeName derivNames resolvedCols where connStr = toConnString (connection config) schema = gcSchema genConfig table = gcTable genConfig kind = gcKind genConfig derivNames = gcDerivations genConfig defaultedCols = gcDefaultedCols genConfig mergedOverrides = gcOverrides 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 ResolvedColumnresolveColumnWithOverrides 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] -> PkInfobuildPkInfo _ [] = NoPrimaryKeybuildPkInfo resolvedCols [pkName] = case filter (\rc -> rcColName rc == pkName) resolvedCols of [rc] -> SinglePk rc _ -> NoPrimaryKeybuildPkInfo 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 -> [String] -> String -> String -> String -> [Name] -> [ResolvedColumn] -> PkInfo -> Q [Dec]generateAllDecs config defaultedCols 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' insertCols <- computeInsertCols defaultedCols resolvedCols' 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 -> TypefieldType 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 -> BoolisStockDerivable 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 ExpgenDecoderBody 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 -> ExpcolumnDecodeExp 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 -> ExpapplyFmap f x = InfixE (Just f) (VarE '(<$>)) (Just x)
applyAp :: Q Exp -> Q Exp -> Q ExpapplyAp 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 -> ExpcolumnEncodeExp 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 -> ExpcolumnArrayEncodeExp 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 -> ExpsinglePkArrayEncoder 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 ExppkArrayEncoder (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 -> ExptupleFieldArrayEncoder 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. Each column name in the @defaultedNames@ list is validated to exist in the table and to have a database default (@atthasdef@); a compile-time error is raised otherwise. Validated columns are then excluded from the insert column list.-}computeInsertCols :: [String] -> [ResolvedColumn] -> Q [ResolvedColumn]computeInsertCols [] allCols = return allColscomputeInsertCols defaultedNames allCols = do mapM_ (validateDefaulted allCols) defaultedNames return (filter (\rc -> rcColName rc `notElem` defaultedNames) allCols)
validateDefaulted :: [ResolvedColumn] -> String -> Q ()validateDefaulted allCols name = case filter (\rc -> rcColName rc == name) allCols of [] -> fail ( "hasql-generate: withDefaultedCols: column '" <> name <> "' not found" ) (rc : _) -> if rcHasDefault rc then return () else fail ( "hasql-generate: withDefaultedCols: column '" <> name <> "' has no database default" )
{- 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] -> ExpinsertEncoder 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 -> ExpsessionLambda 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] -> ExpselectViewSql 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 -> ExpselectByPkSql 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] -> ExpinsertSql 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 -> ExpupdateSql 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 -> ExpdeleteSql 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 -> ExpselectManySql 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 -> ExpdeleteManySql 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] -> ExpinsertManySql 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 -> ExpupdateManySql 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 -> StringbatchPkWhereClause 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] -> StringtypedArrayParamList start cols = intercalate ", " (zipWith arrayParamRef (enumFromTo start (start + length cols - 1)) cols)
textLit :: String -> ExptextLit s = AppE (VarE 'Data.String.fromString) (LitE (StringL s))
sqlLit :: String -> ExpsqlLit = textLit
applyStatement :: Exp -> Exp -> Exp -> ExpapplyStatement sql enc dec = foldl AppE (ConE 'Hasql.Statement.Statement) [sql, enc, dec, ConE 'True]
columnList :: [ResolvedColumn] -> StringcolumnList 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 -> StringparamRef 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 -> StringarrayParamRef 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] -> StringtypedParamList start cols = intercalate ", " (zipWith paramRef (enumFromTo start (start + length cols - 1)) cols)
pkWhereClause :: PkInfo -> Int -> StringpkWhereClause NoPrimaryKey _ = "true"pkWhereClause (SinglePk rc) startIdx = quoteIdent (rcColName rc) <> " = " <> paramRef startIdx rcpkWhereClause (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 -> TypepkParamType (Just pkTypName) (CompositePk _) = ConT (mkName pkTypName)pkParamType _ NoPrimaryKey = TupleT 0pkParamType _ (SinglePk rc) = fieldType rcpkParamType _ (CompositePk rcs) = foldl AppT (TupleT (length rcs)) (map fieldType rcs)
pkEncoder :: Maybe String -> PkInfo -> Q ExppkEncoder (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 -> ExpsingleParamEncoder 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] -> ExpcompositeEncoder 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 -> ExptupleFieldEncoder 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 -> ExptupleAccessor 2 0 = VarE 'Data.Tuple.fsttupleAccessor 2 1 = VarE 'Data.Tuple.sndtupleAccessor 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 -> ResolvedColumnpkRecordFieldName 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 ExpgenToPk 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 ExpgenWrapPk _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 ExpgenUnwrapPk _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 ExpgenRawPk 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 :: ExpidentityLam = 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 -> StringquoteIdent 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 -> StringqualifiedName 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 -> ResolvedColumnprefixFieldName 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 -> StringsanitizeField 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 -> StringpascalCase = concatMap titleWord . splitSnake
{- Convert a snake_case or PascalCase identifier to camelCase.
@\"tenant_id\" → \"tenantId\"@ @\"UserEmails\" → \"userEmails\"@ @\"name\" → \"name\"@-}camelCase :: String -> StringcamelCase s = case splitSnake s of [] -> [] (w : ws) -> lowerFirst w <> concatMap titleWord ws
titleWord :: String -> StringtitleWord [] = []titleWord (c : cs) = toUpper c : cs
lowerFirst :: String -> StringlowerFirst [] = []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