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
      { GenerateConfig -> String
tcSchema      :: String
      , GenerateConfig -> String
tcTable       :: String
      , GenerateConfig -> RelationKind
tcKind        :: RelationKind
      , GenerateConfig -> [Name]
tcDerivations :: [Name]
      , GenerateConfig -> [(String, Name)]
tcOverrides   :: [(String, Name)]
      , GenerateConfig -> Bool
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 :: String -> String -> GenerateConfig
fromTable String
schema String
table =
  GenerateConfig
    { tcSchema :: String
tcSchema = String
schema
    , tcTable :: String
tcTable = String
table
    , tcKind :: RelationKind
tcKind = RelationKind
Table
    , tcDerivations :: [Name]
tcDerivations = []
    , tcOverrides :: [(String, Name)]
tcOverrides = []
    , tcWithholdPk :: Bool
tcWithholdPk = Bool
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 :: String -> String -> GenerateConfig
fromView String
schema String
view =
  GenerateConfig
    { tcSchema :: String
tcSchema = String
schema
    , tcTable :: String
tcTable = String
view
    , tcKind :: RelationKind
tcKind = RelationKind
View
    , tcDerivations :: [Name]
tcDerivations = []
    , tcOverrides :: [(String, Name)]
tcOverrides = []
    , tcWithholdPk :: Bool
tcWithholdPk = Bool
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 :: String -> String -> GenerateConfig
fromType String
schema String
typeName =
  GenerateConfig
    { tcSchema :: String
tcSchema = String
schema
    , tcTable :: String
tcTable = String
typeName
    , tcKind :: RelationKind
tcKind = RelationKind
Type
    , tcDerivations :: [Name]
tcDerivations = []
    , tcOverrides :: [(String, Name)]
tcOverrides = []
    , tcWithholdPk :: Bool
tcWithholdPk = Bool
False
    }

-- | Append derivation class 'Name's to the config.
withDerivations :: [Name] -> GenerateConfig -> GenerateConfig
withDerivations :: [Name] -> GenerateConfig -> GenerateConfig
withDerivations [Name]
names GenerateConfig
cfg = GenerateConfig
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 :: [(String, Name)] -> GenerateConfig -> GenerateConfig
withOverrides [(String, Name)]
ovs GenerateConfig
cfg = GenerateConfig
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 :: GenerateConfig -> GenerateConfig
withholdPk GenerateConfig
cfg = GenerateConfig
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 -> GenerateConfig -> Q [Dec]
generate Config
config GenerateConfig
genConfig =
  case RelationKind
kind of
    RelationKind
Type -> do
      labels <- IO [String] -> Q [String]
forall a. IO a -> Q a
runIO (IO [String] -> Q [String]) -> IO [String] -> Q [String]
forall a b. (a -> b) -> a -> b
$ ByteString -> (Connection -> IO [String]) -> IO [String]
forall a. ByteString -> (Connection -> IO a) -> IO a
withCompileTimeConnection ByteString
connStr ((Connection -> IO [String]) -> IO [String])
-> (Connection -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
        Connection -> String -> String -> IO [String]
introspectEnumLabels Connection
conn String
schema String
table
      if null labels
        then fail ("hasql-generate: no enum labels found for " <> schema <> "." <> table)
        else generateTypeDecs schema table (pascalCase table) derivNames labels
    RelationKind
Table -> do
      (typeName, resolvedCols, pkCols) <- Q (String, [ResolvedColumn], [String])
getPgData
      let pkInfo = [ResolvedColumn] -> [String] -> PkInfo
buildPkInfo [ResolvedColumn]
resolvedCols [String]
pkCols
      generateAllDecs config withhold schema table typeName derivNames resolvedCols pkInfo
    RelationKind
View -> do
      (typeName, resolvedCols, _) <- Q (String, [ResolvedColumn], [String])
getPgData
      generateViewDecs schema table typeName derivNames resolvedCols
  where
    connStr :: ByteString
connStr = ConnectionInfo -> ByteString
toConnString (Config -> ConnectionInfo
connection Config
config)
    schema :: String
schema = GenerateConfig -> String
tcSchema GenerateConfig
genConfig
    table :: String
table = GenerateConfig -> String
tcTable GenerateConfig
genConfig
    kind :: RelationKind
kind = GenerateConfig -> RelationKind
tcKind GenerateConfig
genConfig
    derivNames :: [Name]
derivNames = GenerateConfig -> [Name]
tcDerivations GenerateConfig
genConfig
    withhold :: Bool
withhold = GenerateConfig -> Bool
tcWithholdPk GenerateConfig
genConfig
    mergedOverrides :: [(String, Name)]
mergedOverrides = GenerateConfig -> [(String, Name)]
tcOverrides GenerateConfig
genConfig [(String, Name)] -> [(String, Name)] -> [(String, Name)]
forall a. Semigroup a => a -> a -> a
<> Config -> [(String, Name)]
globalOverrides Config
config
    getPgData :: Q (String, [ResolvedColumn], [String])
getPgData = do
      (columns, pkCols') <- IO ([ColumnInfo], [String]) -> Q ([ColumnInfo], [String])
forall a. IO a -> Q a
runIO (IO ([ColumnInfo], [String]) -> Q ([ColumnInfo], [String]))
-> IO ([ColumnInfo], [String]) -> Q ([ColumnInfo], [String])
forall a b. (a -> b) -> a -> b
$ ByteString
-> (Connection -> IO ([ColumnInfo], [String]))
-> IO ([ColumnInfo], [String])
forall a. ByteString -> (Connection -> IO a) -> IO a
withCompileTimeConnection ByteString
connStr ((Connection -> IO ([ColumnInfo], [String]))
 -> IO ([ColumnInfo], [String]))
-> (Connection -> IO ([ColumnInfo], [String]))
-> IO ([ColumnInfo], [String])
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
        cols <- Connection -> String -> String -> IO [ColumnInfo]
introspectColumns Connection
conn String
schema String
table
        pks <- case kind of
          RelationKind
Table -> Connection -> String -> String -> IO [String]
introspectPrimaryKey Connection
conn String
schema String
table
          RelationKind
_     -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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 = String -> String
pascalCase String
table
              resolvedCols' =
                if Config -> Bool
allowDuplicateRecordFields Config
config
                  then [ResolvedColumn]
resolvedCols
                  else (ResolvedColumn -> ResolvedColumn)
-> [ResolvedColumn] -> [ResolvedColumn]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ResolvedColumn -> ResolvedColumn
prefixFieldName String
typName) [ResolvedColumn]
resolvedCols
          return (typName, resolvedCols', pkCols')

----------------------------------------------------------------------------------------------------

data ResolvedColumn
    = ResolvedColumn
      { ResolvedColumn -> String
rcColName    :: String
      , ResolvedColumn -> String
rcFieldName  :: String
      , ResolvedColumn -> Type
rcType       :: Type
      , ResolvedColumn -> Bool
rcNotNull    :: Bool
      , ResolvedColumn -> Bool
rcHasDefault :: Bool
      , ResolvedColumn -> Maybe String
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 :: [(String, Name)] -> ColumnInfo -> Q ResolvedColumn
resolveColumnWithOverrides [(String, Name)]
overrides ColumnInfo
col = do
  hsType <- case String -> [(String, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ColumnInfo -> String
colPgType ColumnInfo
col) [(String, Name)]
overrides of
    Just Name
overrideName -> Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT Name
overrideName)
    Maybe Name
Nothing -> do
      a <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
      insts <-
        reifyInstances
          ''Hasql.Generate.Column.PgColumn
          [ LitT (StrTyLit (colPgSchema col))
          , LitT (StrTyLit (colPgType col))
          , VarT a
          ]
      case insts of
        [InstanceD Maybe Overlap
_ [Type]
_ (AppT (AppT (AppT Type
_ Type
_) Type
_) Type
ty) [Dec]
_] -> Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
        [] ->
          String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
            ( String
"hasql-generate: no PgColumn instance for pg type '"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ColumnInfo -> String
colPgSchema ColumnInfo
col
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ColumnInfo -> String
colPgType ColumnInfo
col
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' (column '"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ColumnInfo -> String
colName ColumnInfo
col
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"')"
            )
        [Dec]
_ ->
          String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
            ( String
"hasql-generate: multiple PgColumn instances for pg type '"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ColumnInfo -> String
colPgSchema ColumnInfo
col
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ColumnInfo -> String
colPgType ColumnInfo
col
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' (column '"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ColumnInfo -> String
colName ColumnInfo
col
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"') — expected exactly one"
            )
  let pgCast =
        if ColumnInfo -> Bool
colIsEnum ColumnInfo
col
          then String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
quoteIdent (ColumnInfo -> String
colPgSchema ColumnInfo
col) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
quoteIdent (ColumnInfo -> String
colPgType ColumnInfo
col))
          else Maybe String
forall a. Maybe a
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 :: [ResolvedColumn] -> [String] -> PkInfo
buildPkInfo [ResolvedColumn]
_ [] = PkInfo
NoPrimaryKey
buildPkInfo [ResolvedColumn]
resolvedCols [String
pkName] =
  case (ResolvedColumn -> Bool) -> [ResolvedColumn] -> [ResolvedColumn]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ResolvedColumn
rc -> ResolvedColumn -> String
rcColName ResolvedColumn
rc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
pkName) [ResolvedColumn]
resolvedCols of
    [ResolvedColumn
rc] -> ResolvedColumn -> PkInfo
SinglePk ResolvedColumn
rc
    [ResolvedColumn]
_    -> PkInfo
NoPrimaryKey
buildPkInfo [ResolvedColumn]
resolvedCols [String]
pkNames =
  let lookupPk :: String -> [ResolvedColumn]
lookupPk String
pkn = (ResolvedColumn -> Bool) -> [ResolvedColumn] -> [ResolvedColumn]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ResolvedColumn
rc -> ResolvedColumn -> String
rcColName ResolvedColumn
rc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
pkn) [ResolvedColumn]
resolvedCols
      pkCols :: [ResolvedColumn]
pkCols = (String -> [ResolvedColumn]) -> [String] -> [ResolvedColumn]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [ResolvedColumn]
lookupPk [String]
pkNames
   in if [ResolvedColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedColumn]
pkCols Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
pkNames
        then [ResolvedColumn] -> PkInfo
CompositePk [ResolvedColumn]
pkCols
        else PkInfo
NoPrimaryKey

----------------------------------------------------------------------------------------------------

generateAllDecs
  :: Config -> Bool -> String -> String -> String -> [Name] -> [ResolvedColumn] -> PkInfo -> Q [Dec]
generateAllDecs :: Config
-> Bool
-> String
-> String
-> String
-> [Name]
-> [ResolvedColumn]
-> PkInfo
-> Q [Dec]
generateAllDecs Config
config Bool
withhold String
schema String
table String
typName [Name]
derivNames [ResolvedColumn]
resolvedCols PkInfo
pkInfo = do
  let useNtPk :: Bool
useNtPk = Config -> Bool
newtypePrimaryKeys Config
config
      pkTypName :: String
pkTypName = String
typName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Pk"
      allowDupFields :: Bool
allowDupFields = Config -> Bool
allowDuplicateRecordFields Config
config

  -- Generate PK wrapper type declarations (before main record so newtype is in scope)
  pkTypeDecs <-
    if Bool
useNtPk
      then case PkInfo
pkInfo of
        SinglePk ResolvedColumn
rc -> do
          ntDec <- String -> [Name] -> ResolvedColumn -> Q [Dec]
genPkNewtype String
pkTypName [Name]
derivNames ResolvedColumn
rc
          codecDec <- genPkNewtypeCodec pkTypName
          return (ntDec <> codecDec)
        CompositePk [ResolvedColumn]
rcs -> do
          let pkRcs :: [ResolvedColumn]
pkRcs = (ResolvedColumn -> ResolvedColumn)
-> [ResolvedColumn] -> [ResolvedColumn]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Bool -> ResolvedColumn -> ResolvedColumn
pkRecordFieldName String
pkTypName Bool
allowDupFields) [ResolvedColumn]
rcs
          recDec <- String -> [Name] -> [ResolvedColumn] -> Q [Dec]
genPkRecord String
pkTypName [Name]
derivNames [ResolvedColumn]
pkRcs
          encDec <- genPkRecordEncoder pkTypName pkRcs
          return (recDec <> encDec)
        PkInfo
NoPrimaryKey -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      else [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
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 ResolvedColumn
rc ->
              let rc' :: ResolvedColumn
rc' = ResolvedColumn
rc {rcType = ConT (mkName pkTypName)}
                  cols' :: [ResolvedColumn]
cols' = (ResolvedColumn -> ResolvedColumn)
-> [ResolvedColumn] -> [ResolvedColumn]
forall a b. (a -> b) -> [a] -> [b]
map (\ResolvedColumn
c -> if ResolvedColumn -> String
rcColName ResolvedColumn
c String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ResolvedColumn -> String
rcColName ResolvedColumn
rc then ResolvedColumn
rc' else ResolvedColumn
c) [ResolvedColumn]
resolvedCols
               in ([ResolvedColumn]
cols', ResolvedColumn -> PkInfo
SinglePk ResolvedColumn
rc')
            PkInfo
_ -> ([ResolvedColumn]
resolvedCols, PkInfo
pkInfo)
          else (resolvedCols, pkInfo)

  -- Compute pkTypOverride for composite PK with newtypes
  let pkTypOverride = case (Bool
useNtPk, PkInfo
pkInfo) of
        (Bool
True, CompositePk [ResolvedColumn]
_) -> String -> Maybe String
forall a. a -> Maybe a
Just String
pkTypName
        (Bool, PkInfo)
_                     -> Maybe String
forall a. Maybe a
Nothing

  -- Generate main record, decoder, encoder, insert (single + batch)
  dataDec <- genDataType typName derivNames resolvedCols'
  decoderDec <- genDecoder typName resolvedCols'
  encoderDec <- genEncoder typName resolvedCols'
  let insertCols = Bool -> [ResolvedColumn] -> PkInfo -> [ResolvedColumn]
computeInsertCols Bool
withhold [ResolvedColumn]
resolvedCols' PkInfo
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
    PkInfo
NoPrimaryKey -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    PkInfo
_ -> do
      sel <- String
-> String
-> String
-> [ResolvedColumn]
-> PkInfo
-> Maybe String
-> Q [Dec]
genSelectByPk String
schema String
table String
typName [ResolvedColumn]
resolvedCols' PkInfo
pkInfo' Maybe String
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
    PkInfo
NoPrimaryKey -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    PkInfo
_ -> String
-> PkInfo -> PkInfo -> Bool -> Maybe String -> Bool -> Q [Dec]
genHasPrimaryKeyInstance String
typName PkInfo
pkInfo PkInfo
pkInfo' Bool
useNtPk Maybe String
pkTypOverride Bool
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 :: String -> String -> String -> [Name] -> [ResolvedColumn] -> Q [Dec]
generateViewDecs String
schema String
table String
typName [Name]
derivNames [ResolvedColumn]
resolvedCols = do
  dataDec <- String -> [Name] -> [ResolvedColumn] -> Q [Dec]
genDataType String
typName [Name]
derivNames [ResolvedColumn]
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 :: String -> String -> String -> [Name] -> [String] -> Q [Dec]
generateTypeDecs String
schema String
pgTypeName String
hsTypeName [Name]
derivNames [String]
labels = do
  sumType <- String -> [Name] -> [String] -> Q [Dec]
genSumType String
hsTypeName [Name]
derivNames [String]
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 :: String -> [Name] -> [String] -> Q [Dec]
genSumType String
hsTypeName [Name]
derivNames [String]
labels = do
  let tName :: Name
tName = String -> Name
mkName String
hsTypeName
      cons :: [Con]
cons = (String -> Con) -> [String] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map (\String
lbl -> Name -> [BangType] -> Con
NormalC (String -> Name
mkName (String -> String
pascalCase String
lbl)) []) [String]
labels
      derivClauses :: [DerivClause]
derivClauses = [Name] -> [DerivClause]
mkDerivClauses [Name]
derivNames
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [[Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
tName [] Maybe Type
forall a. Maybe a
Nothing [Con]
cons [DerivClause]
derivClauses]

genPgCodecInstance :: String -> [String] -> Q [Dec]
genPgCodecInstance :: String -> [String] -> Q [Dec]
genPgCodecInstance String
hsTypeName [String]
labels = do
  let tName :: Name
tName = String -> Name
mkName String
hsTypeName
      -- pgDecode: Decoders.enum (\t -> case Data.Text.unpack t of "lbl" -> Just Con; ... _ -> Nothing)
      t :: Name
t = String -> Name
mkName String
"t"
      decoderMatches :: [Match]
decoderMatches =
        (String -> Match) -> [String] -> [Match]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \String
lbl ->
              Pat -> Body -> [Dec] -> Match
Match
                (Lit -> Pat
LitP (String -> Lit
StringL String
lbl))
                (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Just) (Name -> Exp
ConE (String -> Name
mkName (String -> String
pascalCase String
lbl)))))
                []
          )
          [String]
labels
          [Match] -> [Match] -> [Match]
forall a. Semigroup a => a -> a -> a
<> [Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB (Name -> Exp
ConE 'Nothing)) []]
      decoderLam :: Exp
decoderLam =
        [Pat] -> Exp -> Exp
LamE
          [Name -> Pat
VarP Name
t]
          (Exp -> [Match] -> Exp
CaseE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Data.Text.unpack) (Name -> Exp
VarE Name
t)) [Match]
decoderMatches)
      decoderBody :: Exp
decoderBody = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Decoders.enum) Exp
decoderLam
      decoderDec :: Dec
decoderDec = Name -> [Clause] -> Dec
FunD 'Hasql.Generate.Codec.pgDecode [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
decoderBody) []]
      -- pgEncode: Encoders.enum (\x -> case x of Con -> "lbl"; ...)
      x :: Name
x = String -> Name
mkName String
"x"
      encoderMatches :: [Match]
encoderMatches =
        (String -> Match) -> [String] -> [Match]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \String
lbl ->
              Pat -> Body -> [Dec] -> Match
Match
                (Name -> [Type] -> [Pat] -> Pat
ConP (String -> Name
mkName (String -> String
pascalCase String
lbl)) [] [])
                (Exp -> Body
NormalB (String -> Exp
textLit String
lbl))
                []
          )
          [String]
labels
      encoderLam :: Exp
encoderLam = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
x] (Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE Name
x) [Match]
encoderMatches)
      encoderBody :: Exp
encoderBody = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Encoders.enum) Exp
encoderLam
      encoderDec :: Dec
encoderDec = Name -> [Clause] -> Dec
FunD 'Hasql.Generate.Codec.pgEncode [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
encoderBody) []]
      instanceType :: Type
instanceType = Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Generate.Codec.PgCodec) (Name -> Type
ConT Name
tName)
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
instanceType [Dec
decoderDec, Dec
encoderDec]]

genPgColumnInstance :: String -> String -> String -> Q [Dec]
genPgColumnInstance :: String -> String -> String -> Q [Dec]
genPgColumnInstance String
schema String
pgTypeName String
hsTypeName = do
  let tName :: Name
tName = String -> Name
mkName String
hsTypeName
      instanceType :: Type
instanceType =
        Type -> Type -> Type
AppT
          ( Type -> Type -> Type
AppT
              (Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Generate.Column.PgColumn) (TyLit -> Type
LitT (String -> TyLit
StrTyLit String
schema)))
              (TyLit -> Type
LitT (String -> TyLit
StrTyLit String
pgTypeName))
          )
          (Name -> Type
ConT Name
tName)
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
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 :: String -> [String] -> Q [Dec]
genHasEnumInstance String
hsTypeName [String]
labels = do
  let tName :: Name
tName = String -> Name
mkName String
hsTypeName
      -- allValues = [Con1, Con2, ...]
      allValuesDec :: Dec
allValuesDec =
        Name -> [Clause] -> Dec
FunD
          'Hasql.Generate.Class.allValues
          [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB ([Exp] -> Exp
ListE ((String -> Exp) -> [String] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Exp
ConE (Name -> Exp) -> (String -> Name) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name) -> (String -> String) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
pascalCase) [String]
labels))) []]
      -- toText Con1 = "label1"; toText Con2 = "label2"; ...
      toTextClauses :: [Clause]
toTextClauses =
        (String -> Clause) -> [String] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \String
lbl ->
              [Pat] -> Body -> [Dec] -> Clause
Clause
                [Name -> [Type] -> [Pat] -> Pat
ConP (String -> Name
mkName (String -> String
pascalCase String
lbl)) [] []]
                (Exp -> Body
NormalB (String -> Exp
textLit String
lbl))
                []
          )
          [String]
labels
      toTextDec :: Dec
toTextDec = Name -> [Clause] -> Dec
FunD 'Hasql.Generate.Class.toText [Clause]
toTextClauses
      -- fromText t = case Data.Text.unpack t of "label1" -> Just Con1; ... _ -> Nothing
      t :: Name
t = String -> Name
mkName String
"t"
      fromTextMatches :: [Match]
fromTextMatches =
        (String -> Match) -> [String] -> [Match]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \String
lbl ->
              Pat -> Body -> [Dec] -> Match
Match
                (Lit -> Pat
LitP (String -> Lit
StringL String
lbl))
                (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Just) (Name -> Exp
ConE (String -> Name
mkName (String -> String
pascalCase String
lbl)))))
                []
          )
          [String]
labels
          [Match] -> [Match] -> [Match]
forall a. Semigroup a => a -> a -> a
<> [Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB (Name -> Exp
ConE 'Nothing)) []]
      fromTextBody :: Exp
fromTextBody =
        [Pat] -> Exp -> Exp
LamE
          [Name -> Pat
VarP Name
t]
          (Exp -> [Match] -> Exp
CaseE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Data.Text.unpack) (Name -> Exp
VarE Name
t)) [Match]
fromTextMatches)
      fromTextDec :: Dec
fromTextDec =
        Name -> [Clause] -> Dec
FunD
          'Hasql.Generate.Class.fromText
          [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
fromTextBody) []]
      instanceType :: Type
instanceType = Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Generate.Class.HasEnum) (Name -> Type
ConT Name
tName)
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
instanceType [Dec
allValuesDec, Dec
toTextDec, Dec
fromTextDec]]

----------------------------------------------------------------------------------------------------
-- Data type generation
----------------------------------------------------------------------------------------------------

genDataType :: String -> [Name] -> [ResolvedColumn] -> Q [Dec]
genDataType :: String -> [Name] -> [ResolvedColumn] -> Q [Dec]
genDataType String
typName [Name]
derivNames [ResolvedColumn]
cols = do
  let tName :: Name
tName = String -> Name
mkName String
typName
      fields :: [VarBangType]
fields = (ResolvedColumn -> VarBangType)
-> [ResolvedColumn] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
map ResolvedColumn -> VarBangType
mkField [ResolvedColumn]
cols
      con :: Con
con = Name -> [VarBangType] -> Con
RecC Name
tName [VarBangType]
fields
      derivClauses :: [DerivClause]
derivClauses = [Name] -> [DerivClause]
mkDerivClauses [Name]
derivNames
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [[Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
tName [] Maybe Type
forall a. Maybe a
Nothing [Con
con] [DerivClause]
derivClauses]
  where
    mkField :: ResolvedColumn -> VarBangType
    mkField :: ResolvedColumn -> VarBangType
mkField ResolvedColumn
resCol =
      let fName :: Name
fName = String -> Name
mkName (ResolvedColumn -> String
rcFieldName ResolvedColumn
resCol)
          fieldBang :: Bang
fieldBang = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict
          typ :: Type
typ = ResolvedColumn -> Type
fieldType ResolvedColumn
resCol
       in (Name
fName, Bang
fieldBang, Type
typ)

fieldType :: ResolvedColumn -> Type
fieldType :: ResolvedColumn -> Type
fieldType ResolvedColumn
resCol
  | ResolvedColumn -> Bool
rcNotNull ResolvedColumn
resCol = ResolvedColumn -> Type
rcType ResolvedColumn
resCol
  | Bool
otherwise = Type -> Type -> Type
AppT (Name -> Type
ConT ''Maybe) (ResolvedColumn -> Type
rcType ResolvedColumn
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 :: [Name] -> [DerivClause]
mkDerivClauses [Name]
names =
  let ([Name]
stock, [Name]
anyclass) = (Name -> Bool) -> [Name] -> ([Name], [Name])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Name -> Bool
isStockDerivable [Name]
names
   in DerivStrategy -> [Name] -> [DerivClause]
clauseFor DerivStrategy
StockStrategy [Name]
stock [DerivClause] -> [DerivClause] -> [DerivClause]
forall a. Semigroup a => a -> a -> a
<> DerivStrategy -> [Name] -> [DerivClause]
clauseFor DerivStrategy
AnyclassStrategy [Name]
anyclass
  where
    clauseFor :: DerivStrategy -> [Name] -> [DerivClause]
clauseFor DerivStrategy
_ []      = []
    clauseFor DerivStrategy
strat [Name]
nms = [Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
strat) ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
ConT [Name]
nms)]

isStockDerivable :: Name -> Bool
isStockDerivable :: Name -> Bool
isStockDerivable Name
nm =
  Name -> String
nameBase Name
nm
    String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ String
"Show"
           , String
"Read"
           , String
"Eq"
           , String
"Ord"
           , String
"Bounded"
           , String
"Enum"
           , String
"Ix"
           , String
"Generic"
           , String
"Generic1"
           , String
"Data"
           , String
"Typeable"
           , String
"Lift"
           , String
"Functor"
           , String
"Foldable"
           , String
"Traversable"
           ]

----------------------------------------------------------------------------------------------------
-- Decoder generation
----------------------------------------------------------------------------------------------------

genDecoder :: String -> [ResolvedColumn] -> Q [Dec]
genDecoder :: String -> [ResolvedColumn] -> Q [Dec]
genDecoder String
typName [ResolvedColumn]
cols = do
  let decName :: Name
decName = String -> Name
mkName (String -> String
camelCase String
typName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Decoder")
      tName :: Name
tName = String -> Name
mkName String
typName
      sigTy :: Type
sigTy = Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Decoders.Row) (Name -> Type
ConT Name
tName)
  sig <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
decName (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
sigTy)
  body <- genDecoderBody tName cols
  let dec = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
decName) (Exp -> Body
NormalB Exp
body) []
  return [sig, dec]

genDecoderBody :: Name -> [ResolvedColumn] -> Q Exp
genDecoderBody :: Name -> [ResolvedColumn] -> Q Exp
genDecoderBody Name
tName [ResolvedColumn]
cols =
  case [ResolvedColumn]
cols of
    [] -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"hasql-generate: cannot generate decoder for table with no columns"
    (ResolvedColumn
x : [ResolvedColumn]
xs) -> do
      let first :: Exp
first = Exp -> Exp -> Exp
applyFmap (Name -> Exp
ConE Name
tName) (ResolvedColumn -> Exp
columnDecodeExp ResolvedColumn
x)
      (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
applyAp (Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
first) ((ResolvedColumn -> Q Exp) -> [ResolvedColumn] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp)
-> (ResolvedColumn -> Exp) -> ResolvedColumn -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedColumn -> Exp
columnDecodeExp) [ResolvedColumn]
xs)

columnDecodeExp :: ResolvedColumn -> Exp
columnDecodeExp :: ResolvedColumn -> Exp
columnDecodeExp ResolvedColumn
resCol =
  let nullability :: Exp
nullability =
        if ResolvedColumn -> Bool
rcNotNull ResolvedColumn
resCol
          then Name -> Exp
VarE 'Hasql.Decoders.nonNullable
          else Name -> Exp
VarE 'Hasql.Decoders.nullable
      codec :: Exp
codec = Name -> Exp
VarE 'Hasql.Generate.Codec.pgDecode
   in Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Decoders.column) (Exp -> Exp -> Exp
AppE Exp
nullability Exp
codec)

applyFmap :: Exp -> Exp -> Exp
applyFmap :: Exp -> Exp -> Exp
applyFmap Exp
f Exp
x = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
f) (Name -> Exp
VarE '(<$>)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
x)

applyAp :: Q Exp -> Q Exp -> Q Exp
applyAp :: Q Exp -> Q Exp -> Q Exp
applyAp Q Exp
qf Q Exp
qx = do
  f <- Q Exp
qf
  InfixE (Just f) (VarE '(<*>)) . Just <$> qx

----------------------------------------------------------------------------------------------------
-- Encoder generation
----------------------------------------------------------------------------------------------------

genEncoder :: String -> [ResolvedColumn] -> Q [Dec]
genEncoder :: String -> [ResolvedColumn] -> Q [Dec]
genEncoder String
typName [ResolvedColumn]
cols = do
  let encName :: Name
encName = String -> Name
mkName (String -> String
camelCase String
typName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Encoder")
      tName :: Name
tName = String -> Name
mkName String
typName
      sigTy :: Type
sigTy = Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Encoders.Params) (Name -> Type
ConT Name
tName)
  sig <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
encName (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
sigTy)
  let body = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'mconcat) ([Exp] -> Exp
ListE ((ResolvedColumn -> Exp) -> [ResolvedColumn] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> ResolvedColumn -> Exp
columnEncodeExp Name
tName) [ResolvedColumn]
cols))
      dec = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
encName) (Exp -> Body
NormalB Exp
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 :: Name -> ResolvedColumn -> Exp
columnEncodeExp Name
tName ResolvedColumn
rc =
  let nullability :: Exp
nullability =
        if ResolvedColumn -> Bool
rcNotNull ResolvedColumn
rc
          then Name -> Exp
VarE 'Hasql.Encoders.nonNullable
          else Name -> Exp
VarE 'Hasql.Encoders.nullable
      codec :: Exp
codec = Name -> Exp
VarE 'Hasql.Generate.Codec.pgEncode
      paramEnc :: Exp
paramEnc = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Encoders.param) (Exp -> Exp -> Exp
AppE Exp
nullability Exp
codec)
      x :: Name
x = String -> Name
mkName String
"x"
      selector :: Exp
selector =
        [Pat] -> Exp -> Exp
LamE
          [Name -> [FieldPat] -> Pat
RecP Name
tName [(String -> Name
mkName (ResolvedColumn -> String
rcFieldName ResolvedColumn
rc), Name -> Pat
VarP Name
x)]]
          (Name -> Exp
VarE Name
x)
   in Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Contravariant.contramap) Exp
selector) Exp
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 :: Name -> ResolvedColumn -> Exp
columnArrayEncodeExp Name
tName ResolvedColumn
rc =
  let elementNullability :: Exp
elementNullability =
        if ResolvedColumn -> Bool
rcNotNull ResolvedColumn
rc
          then Name -> Exp
VarE 'Hasql.Encoders.nonNullable
          else Name -> Exp
VarE 'Hasql.Encoders.nullable
      codec :: Exp
codec = Name -> Exp
VarE 'Hasql.Generate.Codec.pgEncode
      arrayEnc :: Exp
arrayEnc =
        Exp -> Exp -> Exp
AppE
          (Name -> Exp
VarE 'Hasql.Encoders.foldableArray)
          (Exp -> Exp -> Exp
AppE Exp
elementNullability Exp
codec)
      paramEnc :: Exp
paramEnc =
        Exp -> Exp -> Exp
AppE
          (Name -> Exp
VarE 'Hasql.Encoders.param)
          (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Encoders.nonNullable) Exp
arrayEnc)
      x :: Name
x = String -> Name
mkName String
"x"
      fieldExtractor :: Exp
fieldExtractor =
        [Pat] -> Exp -> Exp
LamE
          [Name -> [FieldPat] -> Pat
RecP Name
tName [(String -> Name
mkName (ResolvedColumn -> String
rcFieldName ResolvedColumn
rc), Name -> Pat
VarP Name
x)]]
          (Name -> Exp
VarE Name
x)
      mapSelector :: Exp
mapSelector = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'map) Exp
fieldExtractor
   in Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Contravariant.contramap) Exp
mapSelector) Exp
paramEnc

{-  Generate an array encoder for a single PK value list:

    @Encoders.param (Encoders.nonNullable
      (Encoders.foldableArray (nonNullable\/nullable pgEncode)))@
-}
singlePkArrayEncoder :: ResolvedColumn -> Exp
singlePkArrayEncoder :: ResolvedColumn -> Exp
singlePkArrayEncoder ResolvedColumn
resCol =
  let elementNullability :: Exp
elementNullability =
        if ResolvedColumn -> Bool
rcNotNull ResolvedColumn
resCol
          then Name -> Exp
VarE 'Hasql.Encoders.nonNullable
          else Name -> Exp
VarE 'Hasql.Encoders.nullable
      codec :: Exp
codec = Name -> Exp
VarE 'Hasql.Generate.Codec.pgEncode
      arrayEnc :: Exp
arrayEnc =
        Exp -> Exp -> Exp
AppE
          (Name -> Exp
VarE 'Hasql.Encoders.foldableArray)
          (Exp -> Exp -> Exp
AppE Exp
elementNullability Exp
codec)
   in Exp -> Exp -> Exp
AppE
        (Name -> Exp
VarE 'Hasql.Encoders.param)
        (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Encoders.nonNullable) Exp
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 :: Maybe String -> PkInfo -> Q Exp
pkArrayEncoder (Just String
pkTypName) (CompositePk [ResolvedColumn]
rcs) = do
  let tName :: Name
tName = String -> Name
mkName String
pkTypName
  Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'mconcat) ([Exp] -> Exp
ListE ((ResolvedColumn -> Exp) -> [ResolvedColumn] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> ResolvedColumn -> Exp
columnArrayEncodeExp Name
tName) [ResolvedColumn]
rcs)))
pkArrayEncoder Maybe String
_ PkInfo
NoPrimaryKey = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE 'Hasql.Encoders.noParams)
pkArrayEncoder Maybe String
_ (SinglePk ResolvedColumn
rc) = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedColumn -> Exp
singlePkArrayEncoder ResolvedColumn
rc)
pkArrayEncoder Maybe String
_ (CompositePk [ResolvedColumn]
rcs) = do
  let n :: Int
n = [ResolvedColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedColumn]
rcs
      encoders :: [Exp]
encoders =
        (ResolvedColumn -> Int -> Exp)
-> [ResolvedColumn] -> [Int] -> [Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
          ((Int -> ResolvedColumn -> Exp) -> ResolvedColumn -> Int -> Exp
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> Int -> ResolvedColumn -> Exp
tupleFieldArrayEncoder Int
n))
          [ResolvedColumn]
rcs
          (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
  Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'mconcat) ([Exp] -> Exp
ListE [Exp]
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 :: Int -> Int -> ResolvedColumn -> Exp
tupleFieldArrayEncoder Int
tupleSize Int
idx ResolvedColumn
resCol =
  let elementNullability :: Exp
elementNullability =
        if ResolvedColumn -> Bool
rcNotNull ResolvedColumn
resCol
          then Name -> Exp
VarE 'Hasql.Encoders.nonNullable
          else Name -> Exp
VarE 'Hasql.Encoders.nullable
      codec :: Exp
codec = Name -> Exp
VarE 'Hasql.Generate.Codec.pgEncode
      arrayEnc :: Exp
arrayEnc =
        Exp -> Exp -> Exp
AppE
          (Name -> Exp
VarE 'Hasql.Encoders.foldableArray)
          (Exp -> Exp -> Exp
AppE Exp
elementNullability Exp
codec)
      paramEnc :: Exp
paramEnc =
        Exp -> Exp -> Exp
AppE
          (Name -> Exp
VarE 'Hasql.Encoders.param)
          (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Encoders.nonNullable) Exp
arrayEnc)
      accessor :: Exp
accessor = Int -> Int -> Exp
tupleAccessor Int
tupleSize Int
idx
      mapSelector :: Exp
mapSelector = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'map) Exp
accessor
   in Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Contravariant.contramap) Exp
mapSelector) Exp
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 :: Name -> Type -> Exp -> Exp -> Exp -> Q [Dec]
genStatement Name
stmtName Type
sigTy Exp
sql Exp
enc Exp
dec = do
  sig <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
stmtName (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
sigTy)
  let body = Exp -> Exp -> Exp -> Exp
applyStatement Exp
sql Exp
enc Exp
dec
      valDec = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
stmtName) (Exp -> Body
NormalB Exp
body) []
  return [sig, valDec]

genSelectByPk
  :: String -> String -> String -> [ResolvedColumn] -> PkInfo -> Maybe String -> Q [Dec]
genSelectByPk :: String
-> String
-> String
-> [ResolvedColumn]
-> PkInfo
-> Maybe String
-> Q [Dec]
genSelectByPk String
schema String
table String
typName [ResolvedColumn]
cols PkInfo
pkInfo Maybe String
pkTypOverride = do
  let stmtName :: Name
stmtName = String -> Name
mkName (String
"select" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typName)
      decName :: Name
decName = String -> Name
mkName (String -> String
camelCase String
typName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Decoder")
      pkType :: Type
pkType = Maybe String -> PkInfo -> Type
pkParamType Maybe String
pkTypOverride PkInfo
pkInfo
      sql :: Exp
sql = String -> String -> [ResolvedColumn] -> PkInfo -> Exp
selectByPkSql String
schema String
table [ResolvedColumn]
cols PkInfo
pkInfo
      sigTy :: Type
sigTy =
        Type -> Type -> Type
AppT
          (Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Statement.Statement) Type
pkType)
          (Type -> Type -> Type
AppT (Name -> Type
ConT ''Maybe) (Name -> Type
ConT (String -> Name
mkName String
typName)))
  pkEnc <- Maybe String -> PkInfo -> Q Exp
pkEncoder Maybe String
pkTypOverride PkInfo
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 :: Bool -> [ResolvedColumn] -> PkInfo -> [ResolvedColumn]
computeInsertCols Bool
withhold [ResolvedColumn]
allCols PkInfo
pkInfo =
  let pkNames :: [String]
pkNames = PkInfo -> [String]
pkColumnNames PkInfo
pkInfo
      pkCols :: [ResolvedColumn]
pkCols = (ResolvedColumn -> Bool) -> [ResolvedColumn] -> [ResolvedColumn]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ResolvedColumn
rc -> ResolvedColumn -> String
rcColName ResolvedColumn
rc String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
pkNames) [ResolvedColumn]
allCols
      allPkDefaulted :: Bool
allPkDefaulted = Bool -> Bool
not ([ResolvedColumn] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ResolvedColumn]
pkCols) Bool -> Bool -> Bool
&& (ResolvedColumn -> Bool) -> [ResolvedColumn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ResolvedColumn -> Bool
rcHasDefault [ResolvedColumn]
pkCols
   in if Bool
withhold Bool -> Bool -> Bool
&& Bool
allPkDefaulted
        then (ResolvedColumn -> Bool) -> [ResolvedColumn] -> [ResolvedColumn]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ResolvedColumn
rc -> ResolvedColumn -> String
rcColName ResolvedColumn
rc String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
pkNames) [ResolvedColumn]
allCols
        else [ResolvedColumn]
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 :: String
-> String
-> String
-> [ResolvedColumn]
-> [ResolvedColumn]
-> Q [Dec]
genInsert String
schema String
table String
typName [ResolvedColumn]
allCols [ResolvedColumn]
insertCols =
  let stmtName :: Name
stmtName = String -> Name
mkName (String
"insert" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typName)
      tName :: Name
tName = String -> Name
mkName String
typName
      decName :: Name
decName = String -> Name
mkName (String -> String
camelCase String
typName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Decoder")
      sql :: Exp
sql = String -> String -> [ResolvedColumn] -> [ResolvedColumn] -> Exp
insertSql String
schema String
table [ResolvedColumn]
allCols [ResolvedColumn]
insertCols
      sigTy :: Type
sigTy = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Statement.Statement) (Name -> Type
ConT Name
tName)) (Name -> Type
ConT Name
tName)
      enc :: Exp
enc = Name -> [ResolvedColumn] -> Exp
insertEncoder Name
tName [ResolvedColumn]
insertCols
   in Name -> Type -> Exp -> Exp -> Exp -> Q [Dec]
genStatement Name
stmtName Type
sigTy Exp
sql Exp
enc (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Decoders.singleRow) (Name -> Exp
VarE Name
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 :: Name -> [ResolvedColumn] -> Exp
insertEncoder Name
tName [ResolvedColumn]
cols =
  Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'mconcat) ([Exp] -> Exp
ListE ((ResolvedColumn -> Exp) -> [ResolvedColumn] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> ResolvedColumn -> Exp
columnEncodeExp Name
tName) [ResolvedColumn]
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 :: String -> String -> String -> [ResolvedColumn] -> PkInfo -> Q [Dec]
genUpdate String
schema String
table String
typName [ResolvedColumn]
cols PkInfo
pkInfo =
  let stmtName :: Name
stmtName = String -> Name
mkName (String
"update" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typName)
      tName :: Name
tName = String -> Name
mkName String
typName
      encName :: Name
encName = String -> Name
mkName (String -> String
camelCase String
typName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Encoder")
      decName :: Name
decName = String -> Name
mkName (String -> String
camelCase String
typName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Decoder")
      sql :: Exp
sql = String -> String -> [ResolvedColumn] -> PkInfo -> Exp
updateSql String
schema String
table [ResolvedColumn]
cols PkInfo
pkInfo
      sigTy :: Type
sigTy =
        Type -> Type -> Type
AppT
          (Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Statement.Statement) (Name -> Type
ConT Name
tName))
          (Type -> Type -> Type
AppT (Name -> Type
ConT ''Maybe) (Name -> Type
ConT Name
tName))
   in Name -> Type -> Exp -> Exp -> Exp -> Q [Dec]
genStatement Name
stmtName Type
sigTy Exp
sql (Name -> Exp
VarE Name
encName) (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Decoders.rowMaybe) (Name -> Exp
VarE Name
decName))

genDeleteByPk :: String -> String -> String -> PkInfo -> Maybe String -> Q [Dec]
genDeleteByPk :: String -> String -> String -> PkInfo -> Maybe String -> Q [Dec]
genDeleteByPk String
schema String
table String
_typName PkInfo
pkInfo Maybe String
pkTypOverride = do
  let stmtName :: Name
stmtName = String -> Name
mkName (String
"delete" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
pascalCase String
table)
      pkType :: Type
pkType = Maybe String -> PkInfo -> Type
pkParamType Maybe String
pkTypOverride PkInfo
pkInfo
      sql :: Exp
sql = String -> String -> PkInfo -> Exp
deleteSql String
schema String
table PkInfo
pkInfo
      sigTy :: Type
sigTy = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Statement.Statement) Type
pkType) (Int -> Type
TupleT Int
0)
  pkEnc <- Maybe String -> PkInfo -> Q Exp
pkEncoder Maybe String
pkTypOverride PkInfo
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 :: String
-> String
-> String
-> [ResolvedColumn]
-> PkInfo
-> Maybe String
-> Q [Dec]
genSelectMany String
schema String
table String
typName [ResolvedColumn]
cols PkInfo
pkInfo Maybe String
pkTypOverride = do
  let stmtName :: Name
stmtName = String -> Name
mkName (String
"selectMany" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typName)
      tName :: Name
tName = String -> Name
mkName String
typName
      decName :: Name
decName = String -> Name
mkName (String -> String
camelCase String
typName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Decoder")
      pkType :: Type
pkType = Maybe String -> PkInfo -> Type
pkParamType Maybe String
pkTypOverride PkInfo
pkInfo
      sql :: Exp
sql = String -> String -> [ResolvedColumn] -> PkInfo -> Exp
selectManySql String
schema String
table [ResolvedColumn]
cols PkInfo
pkInfo
      sigTy :: Type
sigTy =
        Type -> Type -> Type
AppT
          (Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Statement.Statement) (Type -> Type -> Type
AppT Type
ListT Type
pkType))
          (Type -> Type -> Type
AppT Type
ListT (Name -> Type
ConT Name
tName))
  pkEnc <- Maybe String -> PkInfo -> Q Exp
pkArrayEncoder Maybe String
pkTypOverride PkInfo
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 :: String -> String -> String -> PkInfo -> Maybe String -> Q [Dec]
genDeleteMany String
schema String
table String
_typName PkInfo
pkInfo Maybe String
pkTypOverride = do
  let stmtName :: Name
stmtName = String -> Name
mkName (String
"deleteMany" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
pascalCase String
table)
      pkType :: Type
pkType = Maybe String -> PkInfo -> Type
pkParamType Maybe String
pkTypOverride PkInfo
pkInfo
      sql :: Exp
sql = String -> String -> PkInfo -> Exp
deleteManySql String
schema String
table PkInfo
pkInfo
      sigTy :: Type
sigTy = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Statement.Statement) (Type -> Type -> Type
AppT Type
ListT Type
pkType)) (Int -> Type
TupleT Int
0)
  pkEnc <- Maybe String -> PkInfo -> Q Exp
pkArrayEncoder Maybe String
pkTypOverride PkInfo
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 :: String
-> String
-> String
-> [ResolvedColumn]
-> [ResolvedColumn]
-> Q [Dec]
genInsertMany String
schema String
table String
typName [ResolvedColumn]
allCols [ResolvedColumn]
insertCols =
  let stmtName :: Name
stmtName = String -> Name
mkName (String
"insertMany" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typName)
      tName :: Name
tName = String -> Name
mkName String
typName
      decName :: Name
decName = String -> Name
mkName (String -> String
camelCase String
typName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Decoder")
      sql :: Exp
sql = String -> String -> [ResolvedColumn] -> [ResolvedColumn] -> Exp
insertManySql String
schema String
table [ResolvedColumn]
allCols [ResolvedColumn]
insertCols
      sigTy :: Type
sigTy =
        Type -> Type -> Type
AppT
          (Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Statement.Statement) (Type -> Type -> Type
AppT Type
ListT (Name -> Type
ConT Name
tName)))
          (Type -> Type -> Type
AppT Type
ListT (Name -> Type
ConT Name
tName))
      enc :: Exp
enc = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'mconcat) ([Exp] -> Exp
ListE ((ResolvedColumn -> Exp) -> [ResolvedColumn] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> ResolvedColumn -> Exp
columnArrayEncodeExp Name
tName) [ResolvedColumn]
insertCols))
   in Name -> Type -> Exp -> Exp -> Exp -> Q [Dec]
genStatement Name
stmtName Type
sigTy Exp
sql Exp
enc (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Decoders.rowList) (Name -> Exp
VarE Name
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 :: String -> String -> String -> [ResolvedColumn] -> PkInfo -> Q [Dec]
genUpdateMany String
schema String
table String
typName [ResolvedColumn]
cols PkInfo
pkInfo =
  let stmtName :: Name
stmtName = String -> Name
mkName (String
"updateMany" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typName)
      tName :: Name
tName = String -> Name
mkName String
typName
      decName :: Name
decName = String -> Name
mkName (String -> String
camelCase String
typName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Decoder")
      sql :: Exp
sql = String -> String -> [ResolvedColumn] -> PkInfo -> Exp
updateManySql String
schema String
table [ResolvedColumn]
cols PkInfo
pkInfo
      sigTy :: Type
sigTy =
        Type -> Type -> Type
AppT
          (Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Statement.Statement) (Type -> Type -> Type
AppT Type
ListT (Name -> Type
ConT Name
tName)))
          (Type -> Type -> Type
AppT Type
ListT (Name -> Type
ConT Name
tName))
      enc :: Exp
enc = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'mconcat) ([Exp] -> Exp
ListE ((ResolvedColumn -> Exp) -> [ResolvedColumn] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> ResolvedColumn -> Exp
columnArrayEncodeExp Name
tName) [ResolvedColumn]
cols))
   in Name -> Type -> Exp -> Exp -> Exp -> Q [Dec]
genStatement Name
stmtName Type
sigTy Exp
sql Exp
enc (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Decoders.rowList) (Name -> Exp
VarE Name
decName))

----------------------------------------------------------------------------------------------------
-- Typeclass instance generation
----------------------------------------------------------------------------------------------------

-- | Build @\\param -> Hasql.Session.statement param stmtName@.
sessionLambda :: String -> Name -> Exp
sessionLambda :: String -> Name -> Exp
sessionLambda String
paramName Name
stmtName =
  [Pat] -> Exp -> Exp
LamE
    [Name -> Pat
VarP (String -> Name
mkName String
paramName)]
    ( Exp -> Exp -> Exp
AppE
        (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Session.statement) (Name -> Exp
VarE (String -> Name
mkName String
paramName)))
        (Name -> Exp
VarE Name
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 :: Name -> Name -> Name -> String -> String -> Q [Dec]
genSimpleCrudInstance Name
className Name
singleMethod Name
batchMethod String
prefix String
typName = do
  let tName :: Name
tName = String -> Name
mkName String
typName
      singleDec :: Dec
singleDec = Name -> [Clause] -> Dec
FunD Name
singleMethod [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB (String -> Name -> Exp
sessionLambda String
"x" (String -> Name
mkName (String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typName)))) []]
      batchDec :: Dec
batchDec = Name -> [Clause] -> Dec
FunD Name
batchMethod [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB (String -> Name -> Exp
sessionLambda String
"xs" (String -> Name
mkName (String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Many" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typName)))) []]
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] (Type -> Type -> Type
AppT (Name -> Type
ConT Name
className) (Name -> Type
ConT Name
tName)) [Dec
singleDec, Dec
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 :: Name
-> Name
-> Name
-> Name
-> String
-> String
-> PkInfo
-> Maybe String
-> Q [Dec]
genKeyCrudInstance Name
className Name
singleMethod Name
batchMethod Name
assocType String
prefix String
typName PkInfo
pkInfo Maybe String
pkTypOverride = do
  let tName :: Name
tName = String -> Name
mkName String
typName
      keyType :: Type
keyType = Maybe String -> PkInfo -> Type
pkParamType Maybe String
pkTypOverride PkInfo
pkInfo
      singleDec :: Dec
singleDec = Name -> [Clause] -> Dec
FunD Name
singleMethod [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB (String -> Name -> Exp
sessionLambda String
"k" (String -> Name
mkName (String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typName)))) []]
      batchDec :: Dec
batchDec = Name -> [Clause] -> Dec
FunD Name
batchMethod [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB (String -> Name -> Exp
sessionLambda String
"ks" (String -> Name
mkName (String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Many" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typName)))) []]
      keyTySynInst :: Dec
keyTySynInst = TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT Name
assocType) (Name -> Type
ConT Name
tName)) Type
keyType)
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] (Type -> Type -> Type
AppT (Name -> Type
ConT Name
className) (Name -> Type
ConT Name
tName)) [Dec
keyTySynInst, Dec
singleDec, Dec
batchDec]]

genHasInsertInstance :: String -> Q [Dec]
genHasInsertInstance :: String -> Q [Dec]
genHasInsertInstance =
  Name -> Name -> Name -> String -> String -> Q [Dec]
genSimpleCrudInstance ''Hasql.Generate.Class.HasInsert 'Hasql.Generate.Class.insert 'Hasql.Generate.Class.insertMany String
"insert"

genHasSelectInstance :: String -> PkInfo -> Maybe String -> Q [Dec]
genHasSelectInstance :: String -> PkInfo -> Maybe String -> Q [Dec]
genHasSelectInstance =
  Name
-> Name
-> Name
-> Name
-> String
-> String
-> PkInfo
-> Maybe String
-> Q [Dec]
genKeyCrudInstance ''Hasql.Generate.Class.HasSelect 'Hasql.Generate.Class.select 'Hasql.Generate.Class.selectMany ''Hasql.Generate.Class.SelectKey String
"select"

genHasUpdateInstance :: String -> Q [Dec]
genHasUpdateInstance :: String -> Q [Dec]
genHasUpdateInstance =
  Name -> Name -> Name -> String -> String -> Q [Dec]
genSimpleCrudInstance ''Hasql.Generate.Class.HasUpdate 'Hasql.Generate.Class.update 'Hasql.Generate.Class.updateMany String
"update"

genHasDeleteInstance :: String -> PkInfo -> Maybe String -> Q [Dec]
genHasDeleteInstance :: String -> PkInfo -> Maybe String -> Q [Dec]
genHasDeleteInstance =
  Name
-> Name
-> Name
-> Name
-> String
-> String
-> PkInfo
-> Maybe String
-> Q [Dec]
genKeyCrudInstance ''Hasql.Generate.Class.HasDelete 'Hasql.Generate.Class.delete 'Hasql.Generate.Class.deleteMany ''Hasql.Generate.Class.DeleteKey String
"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 :: String -> String -> String -> [ResolvedColumn] -> Q [Dec]
genSelectView String
schema String
table String
typName [ResolvedColumn]
cols =
  let stmtName :: Name
stmtName = String -> Name
mkName (String
"select" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typName)
      tName :: Name
tName = String -> Name
mkName String
typName
      decName :: Name
decName = String -> Name
mkName (String -> String
camelCase String
typName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Decoder")
      sql :: Exp
sql = String -> String -> [ResolvedColumn] -> Exp
selectViewSql String
schema String
table [ResolvedColumn]
cols
      sigTy :: Type
sigTy =
        Type -> Type -> Type
AppT
          (Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Statement.Statement) (Int -> Type
TupleT Int
0))
          (Type -> Type -> Type
AppT Type
ListT (Name -> Type
ConT Name
tName))
   in Name -> Type -> Exp -> Exp -> Exp -> Q [Dec]
genStatement Name
stmtName Type
sigTy Exp
sql (Name -> Exp
VarE 'Hasql.Encoders.noParams) (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Decoders.rowList) (Name -> Exp
VarE Name
decName))

selectViewSql :: String -> String -> [ResolvedColumn] -> Exp
selectViewSql :: String -> String -> [ResolvedColumn] -> Exp
selectViewSql String
schema String
table [ResolvedColumn]
cols =
  String -> Exp
sqlLit
    ( String
"SELECT "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [ResolvedColumn] -> String
columnList [ResolvedColumn]
cols
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" FROM "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
qualifiedName String
schema String
table
    )

-- | Generate a @HasView@ instance for a view.
genHasViewInstance :: String -> Q [Dec]
genHasViewInstance :: String -> Q [Dec]
genHasViewInstance String
typName = do
  let tName :: Name
tName = String -> Name
mkName String
typName
      stmtName :: Name
stmtName = String -> Name
mkName (String
"select" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typName)
      body :: Exp
body =
        Exp -> Exp -> Exp
AppE
          (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Session.statement) ([Maybe Exp] -> Exp
TupE []))
          (Name -> Exp
VarE Name
stmtName)
      selectViewMethod :: Dec
selectViewMethod = Name -> [Clause] -> Dec
FunD 'Hasql.Generate.Class.selectView [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) []]
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] (Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Generate.Class.HasView) (Name -> Type
ConT Name
tName)) [Dec
selectViewMethod]]

----------------------------------------------------------------------------------------------------
-- SQL generation helpers
----------------------------------------------------------------------------------------------------

selectByPkSql :: String -> String -> [ResolvedColumn] -> PkInfo -> Exp
selectByPkSql :: String -> String -> [ResolvedColumn] -> PkInfo -> Exp
selectByPkSql String
schema String
table [ResolvedColumn]
cols PkInfo
pkInfo =
  let pkWhere :: String
pkWhere = PkInfo -> Int -> String
pkWhereClause PkInfo
pkInfo Int
1
   in String -> Exp
sqlLit
        ( String
"SELECT "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [ResolvedColumn] -> String
columnList [ResolvedColumn]
cols
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" FROM "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
qualifiedName String
schema String
table
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" WHERE "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pkWhere
        )

insertSql :: String -> String -> [ResolvedColumn] -> [ResolvedColumn] -> Exp
insertSql :: String -> String -> [ResolvedColumn] -> [ResolvedColumn] -> Exp
insertSql String
schema String
table [ResolvedColumn]
allCols [ResolvedColumn]
insertCols =
  let insertColNames :: String
insertColNames = [ResolvedColumn] -> String
columnList [ResolvedColumn]
insertCols
      returnColNames :: String
returnColNames = [ResolvedColumn] -> String
columnList [ResolvedColumn]
allCols
      params :: String
params = Int -> [ResolvedColumn] -> String
typedParamList Int
1 [ResolvedColumn]
insertCols
   in String -> Exp
sqlLit
        ( String
"INSERT INTO "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
qualifiedName String
schema String
table
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ("
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
insertColNames
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" VALUES ("
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
params
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" RETURNING "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
returnColNames
        )

updateSql :: String -> String -> [ResolvedColumn] -> PkInfo -> Exp
updateSql :: String -> String -> [ResolvedColumn] -> PkInfo -> Exp
updateSql String
schema String
table [ResolvedColumn]
cols PkInfo
pkInfo =
  let pkNames :: [String]
pkNames = PkInfo -> [String]
pkColumnNames PkInfo
pkInfo
      indexed :: [(ResolvedColumn, Int)]
indexed = [ResolvedColumn] -> [Int] -> [(ResolvedColumn, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ResolvedColumn]
cols (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
1 ([ResolvedColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedColumn]
cols))
      nonPkSet :: [(ResolvedColumn, Int)]
nonPkSet = ((ResolvedColumn, Int) -> Bool)
-> [(ResolvedColumn, Int)] -> [(ResolvedColumn, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ResolvedColumn
rc, Int
_) -> ResolvedColumn -> String
rcColName ResolvedColumn
rc String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
pkNames) [(ResolvedColumn, Int)]
indexed
      pkWhere :: [(ResolvedColumn, Int)]
pkWhere = ((ResolvedColumn, Int) -> Bool)
-> [(ResolvedColumn, Int)] -> [(ResolvedColumn, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ResolvedColumn
rc, Int
_) -> ResolvedColumn -> String
rcColName ResolvedColumn
rc String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
pkNames) [(ResolvedColumn, Int)]
indexed
      setClauses :: String
setClauses =
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
          String
", "
          (((ResolvedColumn, Int) -> String)
-> [(ResolvedColumn, Int)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(ResolvedColumn
rc, Int
i) -> String -> String
quoteIdent (ResolvedColumn -> String
rcColName ResolvedColumn
rc) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> ResolvedColumn -> String
paramRef Int
i ResolvedColumn
rc) [(ResolvedColumn, Int)]
nonPkSet)
      whereClauses :: String
whereClauses =
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
          String
" AND "
          (((ResolvedColumn, Int) -> String)
-> [(ResolvedColumn, Int)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(ResolvedColumn
rc, Int
i) -> String -> String
quoteIdent (ResolvedColumn -> String
rcColName ResolvedColumn
rc) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> ResolvedColumn -> String
paramRef Int
i ResolvedColumn
rc) [(ResolvedColumn, Int)]
pkWhere)
   in String -> Exp
sqlLit
        ( String
"UPDATE "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
qualifiedName String
schema String
table
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" SET "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
setClauses
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" WHERE "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
whereClauses
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" RETURNING "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [ResolvedColumn] -> String
columnList [ResolvedColumn]
cols
        )

deleteSql :: String -> String -> PkInfo -> Exp
deleteSql :: String -> String -> PkInfo -> Exp
deleteSql String
schema String
table PkInfo
pkInfo =
  let pkWhere :: String
pkWhere = PkInfo -> Int -> String
pkWhereClause PkInfo
pkInfo Int
1
   in String -> Exp
sqlLit
        ( String
"DELETE FROM "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
qualifiedName String
schema String
table
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" WHERE "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
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 :: String -> String -> [ResolvedColumn] -> PkInfo -> Exp
selectManySql String
schema String
table [ResolvedColumn]
cols PkInfo
pkInfo =
  String -> Exp
sqlLit
    ( String
"SELECT "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [ResolvedColumn] -> String
columnList [ResolvedColumn]
cols
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" FROM "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
qualifiedName String
schema String
table
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" WHERE "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PkInfo -> String
batchPkWhereClause PkInfo
pkInfo
    )

{-  Generate SQL for batch delete: same WHERE clause logic as 'selectManySql'.
-}
deleteManySql :: String -> String -> PkInfo -> Exp
deleteManySql :: String -> String -> PkInfo -> Exp
deleteManySql String
schema String
table PkInfo
pkInfo =
  String -> Exp
sqlLit
    ( String
"DELETE FROM "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
qualifiedName String
schema String
table
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" WHERE "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PkInfo -> String
batchPkWhereClause PkInfo
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 :: String -> String -> [ResolvedColumn] -> [ResolvedColumn] -> Exp
insertManySql String
schema String
table [ResolvedColumn]
allCols [ResolvedColumn]
insertCols =
  let insertColNames :: String
insertColNames = [ResolvedColumn] -> String
columnList [ResolvedColumn]
insertCols
      returnColNames :: String
returnColNames = [ResolvedColumn] -> String
columnList [ResolvedColumn]
allCols
      params :: String
params = Int -> [ResolvedColumn] -> String
typedArrayParamList Int
1 [ResolvedColumn]
insertCols
   in String -> Exp
sqlLit
        ( String
"INSERT INTO "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
qualifiedName String
schema String
table
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ("
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
insertColNames
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") SELECT * FROM unnest("
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
params
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") RETURNING "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
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 :: String -> String -> [ResolvedColumn] -> PkInfo -> Exp
updateManySql String
schema String
table [ResolvedColumn]
cols PkInfo
pkInfo =
  let pkNames :: [String]
pkNames = PkInfo -> [String]
pkColumnNames PkInfo
pkInfo
      nonPkCols :: [ResolvedColumn]
nonPkCols = (ResolvedColumn -> Bool) -> [ResolvedColumn] -> [ResolvedColumn]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ResolvedColumn
rc -> ResolvedColumn -> String
rcColName ResolvedColumn
rc String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
pkNames) [ResolvedColumn]
cols
      setClauses :: String
setClauses =
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
          String
", "
          ((ResolvedColumn -> String) -> [ResolvedColumn] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ResolvedColumn
rc -> String -> String
quoteIdent (ResolvedColumn -> String
rcColName ResolvedColumn
rc) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = d." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
quoteIdent (ResolvedColumn -> String
rcColName ResolvedColumn
rc)) [ResolvedColumn]
nonPkCols)
      -- All columns in the unnest subquery
      unnestParams :: String
unnestParams =
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
          String
", "
          ( (ResolvedColumn -> Int -> String)
-> [ResolvedColumn] -> [Int] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
              (\ResolvedColumn
rc Int
i -> String
"unnest(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> ResolvedColumn -> String
arrayParamRef Int
i ResolvedColumn
rc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") AS " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
quoteIdent (ResolvedColumn -> String
rcColName ResolvedColumn
rc))
              [ResolvedColumn]
cols
              (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
1 ([ResolvedColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedColumn]
cols))
          )
      -- WHERE join on PK columns
      pkJoin :: String
pkJoin =
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
          String
" AND "
          ( (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
              (\String
pkn -> String -> String -> String
qualifiedName String
schema String
table String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
quoteIdent String
pkn String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = d." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
quoteIdent String
pkn)
              [String]
pkNames
          )
   in String -> Exp
sqlLit
        ( String
"UPDATE "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
qualifiedName String
schema String
table
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" SET "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
setClauses
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" FROM (SELECT "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
unnestParams
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") d WHERE "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pkJoin
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" RETURNING "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
qualifiedName String
schema String
table
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".*"
        )

{-  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 :: PkInfo -> String
batchPkWhereClause PkInfo
NoPrimaryKey = String
"true"
batchPkWhereClause (SinglePk ResolvedColumn
rc) =
  String -> String
quoteIdent (ResolvedColumn -> String
rcColName ResolvedColumn
rc) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = ANY(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> ResolvedColumn -> String
arrayParamRef Int
1 ResolvedColumn
rc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
batchPkWhereClause (CompositePk [ResolvedColumn]
rcs) =
  let pkTuple :: String
pkTuple = String
"(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((ResolvedColumn -> String) -> [ResolvedColumn] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
quoteIdent (String -> String)
-> (ResolvedColumn -> String) -> ResolvedColumn -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedColumn -> String
rcColName) [ResolvedColumn]
rcs) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
      unnests :: String
unnests =
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
          String
", "
          ( (ResolvedColumn -> Int -> String)
-> [ResolvedColumn] -> [Int] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
              (\ResolvedColumn
rc Int
i -> String
"unnest(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> ResolvedColumn -> String
arrayParamRef Int
i ResolvedColumn
rc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")")
              [ResolvedColumn]
rcs
              (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
1 ([ResolvedColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedColumn]
rcs))
          )
   in String
pkTuple String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" IN (SELECT " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
unnests String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"

{-  Generate a comma-separated array parameter list with per-column type casts,
    using 'arrayParamRef' so enum types get @[]@ appended.
-}
typedArrayParamList :: Int -> [ResolvedColumn] -> String
typedArrayParamList :: Int -> [ResolvedColumn] -> String
typedArrayParamList Int
start [ResolvedColumn]
cols =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Int -> ResolvedColumn -> String)
-> [Int] -> [ResolvedColumn] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ResolvedColumn -> String
arrayParamRef (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
start (Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [ResolvedColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedColumn]
cols Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [ResolvedColumn]
cols)

textLit :: String -> Exp
textLit :: String -> Exp
textLit String
s = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Data.String.fromString) (Lit -> Exp
LitE (String -> Lit
StringL String
s))

sqlLit :: String -> Exp
sqlLit :: String -> Exp
sqlLit = String -> Exp
textLit

applyStatement :: Exp -> Exp -> Exp -> Exp
applyStatement :: Exp -> Exp -> Exp -> Exp
applyStatement Exp
sql Exp
enc Exp
dec =
  (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Hasql.Statement.Statement) [Exp
sql, Exp
enc, Exp
dec, Name -> Exp
ConE 'True]

columnList :: [ResolvedColumn] -> String
columnList :: [ResolvedColumn] -> String
columnList [ResolvedColumn]
cols = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((ResolvedColumn -> String) -> [ResolvedColumn] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
quoteIdent (String -> String)
-> (ResolvedColumn -> String) -> ResolvedColumn -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedColumn -> String
rcColName) [ResolvedColumn]
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 :: Int -> ResolvedColumn -> String
paramRef Int
i ResolvedColumn
rc = case ResolvedColumn -> Maybe String
rcPgCast ResolvedColumn
rc of
  Maybe String
Nothing   -> String
"$" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i
  Just String
cast -> String
"$" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"::" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
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 :: Int -> ResolvedColumn -> String
arrayParamRef Int
i ResolvedColumn
rc = case ResolvedColumn -> Maybe String
rcPgCast ResolvedColumn
rc of
  Maybe String
Nothing   -> String
"$" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i
  Just String
cast -> String
"$" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"::" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cast String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"[]"

{-  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 :: Int -> [ResolvedColumn] -> String
typedParamList Int
start [ResolvedColumn]
cols =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Int -> ResolvedColumn -> String)
-> [Int] -> [ResolvedColumn] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ResolvedColumn -> String
paramRef (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
start (Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [ResolvedColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedColumn]
cols Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [ResolvedColumn]
cols)

pkWhereClause :: PkInfo -> Int -> String
pkWhereClause :: PkInfo -> Int -> String
pkWhereClause PkInfo
NoPrimaryKey Int
_ = String
"true"
pkWhereClause (SinglePk ResolvedColumn
rc) Int
startIdx =
  String -> String
quoteIdent (ResolvedColumn -> String
rcColName ResolvedColumn
rc) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> ResolvedColumn -> String
paramRef Int
startIdx ResolvedColumn
rc
pkWhereClause (CompositePk [ResolvedColumn]
rcs) Int
startIdx =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
    String
" AND "
    ( (ResolvedColumn -> Int -> String)
-> [ResolvedColumn] -> [Int] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
        (\ResolvedColumn
rc Int
i -> String -> String
quoteIdent (ResolvedColumn -> String
rcColName ResolvedColumn
rc) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> ResolvedColumn -> String
paramRef Int
i ResolvedColumn
rc)
        [ResolvedColumn]
rcs
        (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
startIdx (Int
startIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [ResolvedColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedColumn]
rcs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
    )

pkColumnNames :: PkInfo -> [String]
pkColumnNames :: PkInfo -> [String]
pkColumnNames PkInfo
NoPrimaryKey      = []
pkColumnNames (SinglePk ResolvedColumn
rc)     = [ResolvedColumn -> String
rcColName ResolvedColumn
rc]
pkColumnNames (CompositePk [ResolvedColumn]
rcs) = (ResolvedColumn -> String) -> [ResolvedColumn] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ResolvedColumn -> String
rcColName [ResolvedColumn]
rcs

----------------------------------------------------------------------------------------------------
-- PK type and encoder helpers
----------------------------------------------------------------------------------------------------

pkParamType :: Maybe String -> PkInfo -> Type
pkParamType :: Maybe String -> PkInfo -> Type
pkParamType (Just String
pkTypName) (CompositePk [ResolvedColumn]
_) = Name -> Type
ConT (String -> Name
mkName String
pkTypName)
pkParamType Maybe String
_ PkInfo
NoPrimaryKey = Int -> Type
TupleT Int
0
pkParamType Maybe String
_ (SinglePk ResolvedColumn
rc) = ResolvedColumn -> Type
fieldType ResolvedColumn
rc
pkParamType Maybe String
_ (CompositePk [ResolvedColumn]
rcs) =
  (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT ([ResolvedColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedColumn]
rcs)) ((ResolvedColumn -> Type) -> [ResolvedColumn] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ResolvedColumn -> Type
fieldType [ResolvedColumn]
rcs)

pkEncoder :: Maybe String -> PkInfo -> Q Exp
pkEncoder :: Maybe String -> PkInfo -> Q Exp
pkEncoder (Just String
pkTypName) (CompositePk [ResolvedColumn]
_) =
  Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE (String -> Name
mkName (String -> String
camelCase String
pkTypName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Encoder")))
pkEncoder Maybe String
_ PkInfo
NoPrimaryKey = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE 'Hasql.Encoders.noParams)
pkEncoder Maybe String
_ (SinglePk ResolvedColumn
rc) = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedColumn -> Exp
singleParamEncoder ResolvedColumn
rc)
pkEncoder Maybe String
_ (CompositePk [ResolvedColumn]
rcs) = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ResolvedColumn] -> Exp
compositeEncoder [ResolvedColumn]
rcs)

singleParamEncoder :: ResolvedColumn -> Exp
singleParamEncoder :: ResolvedColumn -> Exp
singleParamEncoder ResolvedColumn
rc =
  let nullability :: Exp
nullability =
        if ResolvedColumn -> Bool
rcNotNull ResolvedColumn
rc
          then Name -> Exp
VarE 'Hasql.Encoders.nonNullable
          else Name -> Exp
VarE 'Hasql.Encoders.nullable
      codec :: Exp
codec = Name -> Exp
VarE 'Hasql.Generate.Codec.pgEncode
   in Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Encoders.param) (Exp -> Exp -> Exp
AppE Exp
nullability Exp
codec)

compositeEncoder :: [ResolvedColumn] -> Exp
compositeEncoder :: [ResolvedColumn] -> Exp
compositeEncoder [ResolvedColumn]
rcs =
  let n :: Int
n = [ResolvedColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedColumn]
rcs
      encoders :: [Exp]
encoders =
        (ResolvedColumn -> Int -> Exp)
-> [ResolvedColumn] -> [Int] -> [Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
          ((Int -> ResolvedColumn -> Exp) -> ResolvedColumn -> Int -> Exp
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> Int -> ResolvedColumn -> Exp
tupleFieldEncoder Int
n))
          [ResolvedColumn]
rcs
          (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
   in Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'mconcat) ([Exp] -> Exp
ListE [Exp]
encoders)

tupleFieldEncoder :: Int -> Int -> ResolvedColumn -> Exp
tupleFieldEncoder :: Int -> Int -> ResolvedColumn -> Exp
tupleFieldEncoder Int
tupleSize Int
idx ResolvedColumn
rc =
  let nullability :: Exp
nullability =
        if ResolvedColumn -> Bool
rcNotNull ResolvedColumn
rc
          then Name -> Exp
VarE 'Hasql.Encoders.nonNullable
          else Name -> Exp
VarE 'Hasql.Encoders.nullable
      codec :: Exp
codec = Name -> Exp
VarE 'Hasql.Generate.Codec.pgEncode
      paramEnc :: Exp
paramEnc = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Hasql.Encoders.param) (Exp -> Exp -> Exp
AppE Exp
nullability Exp
codec)
      accessor :: Exp
accessor = Int -> Int -> Exp
tupleAccessor Int
tupleSize Int
idx
   in Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Contravariant.contramap) Exp
accessor) Exp
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 :: Int -> Int -> Exp
tupleAccessor Int
2 Int
0 = Name -> Exp
VarE 'Data.Tuple.fst
tupleAccessor Int
2 Int
1 = Name -> Exp
VarE 'Data.Tuple.snd
tupleAccessor Int
size Int
idx =
  let names :: [Name]
names = (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> String -> Name
mkName (String
"t" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i)) (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
      pats :: [Pat]
pats = (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
names
      target :: Name
target = [Name]
names [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
idx
   in [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP [Pat]
pats] (Name -> Exp
VarE Name
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 :: String -> [Name] -> ResolvedColumn -> Q [Dec]
genPkNewtype String
pkTypName [Name]
derivNames ResolvedColumn
rc = do
  let tName :: Name
tName = String -> Name
mkName String
pkTypName
      unwrapperName :: Name
unwrapperName = String -> Name
mkName (String
"get" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pkTypName)
      fieldBang :: Bang
fieldBang = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
      field :: VarBangType
field = (Name
unwrapperName, Bang
fieldBang, ResolvedColumn -> Type
rcType ResolvedColumn
rc)
      con :: Con
con = Name -> [VarBangType] -> Con
RecC Name
tName [VarBangType
field]
      derivClauses :: [DerivClause]
derivClauses = [Name] -> [DerivClause]
mkDerivClauses [Name]
derivNames
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [[Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeD [] Name
tName [] Maybe Type
forall a. Maybe a
Nothing Con
con [DerivClause]
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 :: String -> Q [Dec]
genPkNewtypeCodec String
pkTypName = do
  let tName :: Name
tName = String -> Name
mkName String
pkTypName
      conName :: Name
conName = String -> Name
mkName String
pkTypName
      unwrapperName :: Name
unwrapperName = String -> Name
mkName (String
"get" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pkTypName)
      -- pgDecode = Con <$> pgDecode
      decoderBody :: Exp
decoderBody =
        Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
          (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
ConE Name
conName))
          (Name -> Exp
VarE '(<$>))
          (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE 'Hasql.Generate.Codec.pgDecode))
      decoderDec :: Dec
decoderDec = Name -> [Clause] -> Dec
FunD 'Hasql.Generate.Codec.pgDecode [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
decoderBody) []]
      -- pgEncode = contramap unwrapper pgEncode
      encoderBody :: Exp
encoderBody =
        Exp -> Exp -> Exp
AppE
          (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Contravariant.contramap) (Name -> Exp
VarE Name
unwrapperName))
          (Name -> Exp
VarE 'Hasql.Generate.Codec.pgEncode)
      encoderDec :: Dec
encoderDec = Name -> [Clause] -> Dec
FunD 'Hasql.Generate.Codec.pgEncode [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
encoderBody) []]
      instanceType :: Type
instanceType = Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Generate.Codec.PgCodec) (Name -> Type
ConT Name
tName)
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
instanceType [Dec
decoderDec, Dec
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 :: String -> [Name] -> [ResolvedColumn] -> Q [Dec]
genPkRecord String
pkTypName [Name]
derivNames [ResolvedColumn]
pkRcs = do
  let tName :: Name
tName = String -> Name
mkName String
pkTypName
      fields :: [VarBangType]
fields = (ResolvedColumn -> VarBangType)
-> [ResolvedColumn] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
map ResolvedColumn -> VarBangType
mkPkField [ResolvedColumn]
pkRcs
      con :: Con
con = Name -> [VarBangType] -> Con
RecC Name
tName [VarBangType]
fields
      derivClauses :: [DerivClause]
derivClauses = [Name] -> [DerivClause]
mkDerivClauses [Name]
derivNames
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [[Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
tName [] Maybe Type
forall a. Maybe a
Nothing [Con
con] [DerivClause]
derivClauses]
  where
    mkPkField :: ResolvedColumn -> VarBangType
    mkPkField :: ResolvedColumn -> VarBangType
mkPkField ResolvedColumn
rc =
      let fName :: Name
fName = String -> Name
mkName (ResolvedColumn -> String
rcFieldName ResolvedColumn
rc)
          fieldBang :: Bang
fieldBang = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict
       in (Name
fName, Bang
fieldBang, ResolvedColumn -> Type
fieldType ResolvedColumn
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 :: String -> [ResolvedColumn] -> Q [Dec]
genPkRecordEncoder String
pkTypName [ResolvedColumn]
pkRcs = do
  let encName :: Name
encName = String -> Name
mkName (String -> String
camelCase String
pkTypName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Encoder")
      tName :: Name
tName = String -> Name
mkName String
pkTypName
      sigTy :: Type
sigTy = Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Encoders.Params) (Name -> Type
ConT Name
tName)
  sig <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
encName (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
sigTy)
  let body = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'mconcat) ([Exp] -> Exp
ListE ((ResolvedColumn -> Exp) -> [ResolvedColumn] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> ResolvedColumn -> Exp
columnEncodeExp Name
tName) [ResolvedColumn]
pkRcs))
      dec = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
encName) (Exp -> Body
NormalB Exp
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 :: String -> Bool -> ResolvedColumn -> ResolvedColumn
pkRecordFieldName String
pkTypName Bool
allowDupFields ResolvedColumn
rc =
  if Bool
allowDupFields
    then ResolvedColumn
rc {rcFieldName = sanitizeField (camelCase (rcColName rc))}
    else ResolvedColumn
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 :: String
-> PkInfo -> PkInfo -> Bool -> Maybe String -> Bool -> Q [Dec]
genHasPrimaryKeyInstance String
typName PkInfo
origPkInfo PkInfo
pkInfo' Bool
useNtPk Maybe String
pkTypOverride Bool
allowDupFields = do
  let tName :: Name
tName = String -> Name
mkName String
typName
      pkOfType :: Type
pkOfType = Maybe String -> PkInfo -> Type
pkParamType Maybe String
pkTypOverride PkInfo
pkInfo'
      rawPkOfType :: Type
rawPkOfType = Maybe String -> PkInfo -> Type
pkParamType Maybe String
forall a. Maybe a
Nothing PkInfo
origPkInfo
      pkOfTySynInst :: Dec
pkOfTySynInst =
        TySynEqn -> Dec
TySynInstD
          (Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Generate.Class.PkOf) (Name -> Type
ConT Name
tName)) Type
pkOfType)
      rawPkOfTySynInst :: Dec
rawPkOfTySynInst =
        TySynEqn -> Dec
TySynInstD
          (Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Generate.Class.RawPkOf) (Name -> Type
ConT Name
tName)) Type
rawPkOfType)
  toPkBody <- String -> PkInfo -> Maybe String -> Bool -> Q Exp
genToPk String
typName PkInfo
pkInfo' Maybe String
pkTypOverride Bool
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 = Name -> [Clause] -> Dec
FunD 'Hasql.Generate.Class.toPk [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
toPkBody) []]
      wrapPkDec = Name -> [Clause] -> Dec
FunD 'Hasql.Generate.Class.wrapPk [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
wrapPkBody) []]
      unwrapPkDec = Name -> [Clause] -> Dec
FunD 'Hasql.Generate.Class.unwrapPk [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
unwrapPkBody) []]
      rawPkDec = Name -> [Clause] -> Dec
FunD 'Hasql.Generate.Class.rawPk [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
rawPkBody) []]
      instanceType = Type -> Type -> Type
AppT (Name -> Type
ConT ''Hasql.Generate.Class.HasPrimaryKey) (Name -> Type
ConT Name
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 :: String -> PkInfo -> Maybe String -> Bool -> Q Exp
genToPk String
typName PkInfo
pkInfo' Maybe String
pkTypOverride Bool
allowDupFields = do
  let tName :: Name
tName = String -> Name
mkName String
typName
  case PkInfo
pkInfo' of
    PkInfo
NoPrimaryKey -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"hasql-generate: genToPk called with NoPrimaryKey"
    SinglePk ResolvedColumn
rc -> do
      let x :: Name
x = String -> Name
mkName String
"x"
      Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Exp -> Exp
LamE [Name -> [FieldPat] -> Pat
RecP Name
tName [(String -> Name
mkName (ResolvedColumn -> String
rcFieldName ResolvedColumn
rc), Name -> Pat
VarP Name
x)]] (Name -> Exp
VarE Name
x))
    CompositePk [ResolvedColumn]
rcs -> do
      let xs :: [Name]
xs = (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> String -> Name
mkName (String
"x" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i)) (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 ([ResolvedColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedColumn]
rcs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
          pat :: Pat
pat = Name -> [FieldPat] -> Pat
RecP Name
tName ((ResolvedColumn -> Name -> FieldPat)
-> [ResolvedColumn] -> [Name] -> [FieldPat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ResolvedColumn
rc Name
x -> (String -> Name
mkName (ResolvedColumn -> String
rcFieldName ResolvedColumn
rc), Name -> Pat
VarP Name
x)) [ResolvedColumn]
rcs [Name]
xs)
      case Maybe String
pkTypOverride of
        Just String
pkTypName -> do
          let pkCon :: Name
pkCon = String -> Name
mkName String
pkTypName
              pkRcs :: [ResolvedColumn]
pkRcs = (ResolvedColumn -> ResolvedColumn)
-> [ResolvedColumn] -> [ResolvedColumn]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Bool -> ResolvedColumn -> ResolvedColumn
pkRecordFieldName String
pkTypName Bool
allowDupFields) [ResolvedColumn]
rcs
              body :: Exp
body = Name -> [FieldExp] -> Exp
RecConE Name
pkCon ((ResolvedColumn -> Name -> FieldExp)
-> [ResolvedColumn] -> [Name] -> [FieldExp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ResolvedColumn
prc Name
x -> (String -> Name
mkName (ResolvedColumn -> String
rcFieldName ResolvedColumn
prc), Name -> Exp
VarE Name
x)) [ResolvedColumn]
pkRcs [Name]
xs)
          Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
body)
        Maybe String
Nothing -> do
          let body :: Exp
body = [Maybe Exp] -> Exp
TupE ((Name -> Maybe Exp) -> [Name] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (Name -> Exp) -> Name -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [Name]
xs)
          Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
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 :: PkInfo -> PkInfo -> Bool -> Maybe String -> Bool -> Q Exp
genWrapPk PkInfo
_origPkInfo PkInfo
_pkInfo' Bool
useNtPk Maybe String
pkTypOverride Bool
allowDupFields
  | Bool -> Bool
not Bool
useNtPk = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
identityLam
  | Bool
otherwise = case (PkInfo
_origPkInfo, Maybe String
pkTypOverride) of
      (SinglePk ResolvedColumn
_, Maybe String
_) -> do
        let pkTypName :: String
pkTypName = case PkInfo
_pkInfo' of
              SinglePk ResolvedColumn
rc -> case ResolvedColumn -> Type
rcType ResolvedColumn
rc of
                ConT Name
n -> Name -> String
nameBase Name
n
                Type
_      -> String
""
              PkInfo
_ -> String
""
        Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
ConE (String -> Name
mkName String
pkTypName))
      (CompositePk [ResolvedColumn]
rcs, Just String
pkTypName) -> do
        let n :: Int
n = [ResolvedColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedColumn]
rcs
            xs :: [Name]
xs = (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> String -> Name
mkName (String
"x" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i)) (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
            pat :: Pat
pat = [Pat] -> Pat
TupP ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
xs)
            pkRcs :: [ResolvedColumn]
pkRcs = (ResolvedColumn -> ResolvedColumn)
-> [ResolvedColumn] -> [ResolvedColumn]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Bool -> ResolvedColumn -> ResolvedColumn
pkRecordFieldName String
pkTypName Bool
allowDupFields) [ResolvedColumn]
rcs
            body :: Exp
body = Name -> [FieldExp] -> Exp
RecConE (String -> Name
mkName String
pkTypName) ((ResolvedColumn -> Name -> FieldExp)
-> [ResolvedColumn] -> [Name] -> [FieldExp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ResolvedColumn
prc Name
x -> (String -> Name
mkName (ResolvedColumn -> String
rcFieldName ResolvedColumn
prc), Name -> Exp
VarE Name
x)) [ResolvedColumn]
pkRcs [Name]
xs)
        Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
body)
      (PkInfo, Maybe String)
_ -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
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 :: PkInfo -> PkInfo -> Bool -> Maybe String -> Bool -> Q Exp
genUnwrapPk PkInfo
_origPkInfo PkInfo
_pkInfo' Bool
useNtPk Maybe String
pkTypOverride Bool
allowDupFields
  | Bool -> Bool
not Bool
useNtPk = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
identityLam
  | Bool
otherwise = case (PkInfo
_origPkInfo, Maybe String
pkTypOverride) of
      (SinglePk ResolvedColumn
_, Maybe String
_) -> do
        let pkTypName :: String
pkTypName = case PkInfo
_pkInfo' of
              SinglePk ResolvedColumn
rc -> case ResolvedColumn -> Type
rcType ResolvedColumn
rc of
                ConT Name
n -> Name -> String
nameBase Name
n
                Type
_      -> String
""
              PkInfo
_ -> String
""
        Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE (String -> Name
mkName (String
"get" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pkTypName)))
      (CompositePk [ResolvedColumn]
rcs, Just String
pkTypName) -> do
        let n :: Int
n = [ResolvedColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedColumn]
rcs
            xs :: [Name]
xs = (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> String -> Name
mkName (String
"x" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i)) (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
            pkRcs :: [ResolvedColumn]
pkRcs = (ResolvedColumn -> ResolvedColumn)
-> [ResolvedColumn] -> [ResolvedColumn]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Bool -> ResolvedColumn -> ResolvedColumn
pkRecordFieldName String
pkTypName Bool
allowDupFields) [ResolvedColumn]
rcs
            pat :: Pat
pat = Name -> [FieldPat] -> Pat
RecP (String -> Name
mkName String
pkTypName) ((ResolvedColumn -> Name -> FieldPat)
-> [ResolvedColumn] -> [Name] -> [FieldPat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ResolvedColumn
prc Name
x -> (String -> Name
mkName (ResolvedColumn -> String
rcFieldName ResolvedColumn
prc), Name -> Pat
VarP Name
x)) [ResolvedColumn]
pkRcs [Name]
xs)
            body :: Exp
body = [Maybe Exp] -> Exp
TupE ((Name -> Maybe Exp) -> [Name] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (Name -> Exp) -> Name -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [Name]
xs)
        Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
body)
      (PkInfo, Maybe String)
_ -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
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 :: String -> PkInfo -> PkInfo -> Bool -> Maybe String -> Bool -> Q Exp
genRawPk String
typName PkInfo
origPkInfo PkInfo
pkInfo' Bool
useNtPk Maybe String
_pkTypOverride Bool
allowDupFields
  | Bool -> Bool
not Bool
useNtPk = String -> PkInfo -> Maybe String -> Bool -> Q Exp
genToPk String
typName PkInfo
origPkInfo Maybe String
forall a. Maybe a
Nothing Bool
allowDupFields
  | Bool
otherwise = do
      let tName :: Name
tName = String -> Name
mkName String
typName
      case PkInfo
origPkInfo of
        PkInfo
NoPrimaryKey -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"hasql-generate: genRawPk called with NoPrimaryKey"
        SinglePk ResolvedColumn
_rc -> do
          -- The record field is the newtype; pattern match through it
          case PkInfo
pkInfo' of
            SinglePk ResolvedColumn
rc' -> do
              let pkTypName :: String
pkTypName = case ResolvedColumn -> Type
rcType ResolvedColumn
rc' of
                    ConT Name
n -> Name -> String
nameBase Name
n
                    Type
_      -> String
""
                  x :: Name
x = String -> Name
mkName String
"x"
                  innerPat :: Pat
innerPat = Name -> [Type] -> [Pat] -> Pat
ConP (String -> Name
mkName String
pkTypName) [] [Name -> Pat
VarP Name
x]
                  pat :: Pat
pat = Name -> [FieldPat] -> Pat
RecP Name
tName [(String -> Name
mkName (ResolvedColumn -> String
rcFieldName ResolvedColumn
rc'), Pat
innerPat)]
              Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Exp -> Exp
LamE [Pat
pat] (Name -> Exp
VarE Name
x))
            PkInfo
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"hasql-generate: genRawPk single PK mismatch"
        CompositePk [ResolvedColumn]
rcs -> do
          -- Composite PK fields in the main record are raw types (not rewritten)
          let xs :: [Name]
xs = (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> String -> Name
mkName (String
"x" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i)) (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 ([ResolvedColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedColumn]
rcs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
              -- Use pkInfo' field names since those are what the main record uses
              rcs' :: [ResolvedColumn]
rcs' = case PkInfo
pkInfo' of
                CompositePk [ResolvedColumn]
cs -> [ResolvedColumn]
cs
                PkInfo
_              -> [ResolvedColumn]
rcs
              pat :: Pat
pat = Name -> [FieldPat] -> Pat
RecP Name
tName ((ResolvedColumn -> Name -> FieldPat)
-> [ResolvedColumn] -> [Name] -> [FieldPat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ResolvedColumn
rc Name
x -> (String -> Name
mkName (ResolvedColumn -> String
rcFieldName ResolvedColumn
rc), Name -> Pat
VarP Name
x)) [ResolvedColumn]
rcs' [Name]
xs)
              body :: Exp
body = [Maybe Exp] -> Exp
TupE ((Name -> Maybe Exp) -> [Name] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (Name -> Exp) -> Name -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [Name]
xs)
          Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
body)

identityLam :: Exp
identityLam :: Exp
identityLam =
  let x :: Name
x = String -> Name
mkName String
"x"
   in [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
x] (Name -> Exp
VarE Name
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 :: String -> String
quoteIdent String
s = String
"\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escDQ String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\""
  where
    escDQ :: Char -> String
escDQ Char
'"' = String
"\"\""
    escDQ Char
c   = [Char
c]

{-  Build a schema-qualified, double-quoted identifier pair.

    @qualifiedName \"public\" \"users\"@  →  @\"\\\"public\\\".\\\"users\\\"\"@
-}
qualifiedName :: String -> String -> String
qualifiedName :: String -> String -> String
qualifiedName String
schema String
name = String -> String
quoteIdent String
schema String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
quoteIdent String
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 :: String -> ResolvedColumn -> ResolvedColumn
prefixFieldName String
typName ResolvedColumn
rc =
  ResolvedColumn
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 :: String -> String
sanitizeField String
s
  | String
s String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
haskellKeywords = String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'"
  | Bool
otherwise = String
s

-- | Haskell reserved keywords that may collide with generated camelCase identifiers.
haskellKeywords :: [String]
haskellKeywords :: [String]
haskellKeywords =
  [ String
"case"
  , String
"class"
  , String
"data"
  , String
"default"
  , String
"deriving"
  , String
"do"
  , String
"else"
  , String
"forall"
  , String
"foreign"
  , String
"hiding"
  , String
"if"
  , String
"import"
  , String
"in"
  , String
"infix"
  , String
"infixl"
  , String
"infixr"
  , String
"instance"
  , String
"let"
  , String
"module"
  , String
"newtype"
  , String
"of"
  , String
"qualified"
  , String
"then"
  , String
"type"
  , String
"where"
  , String
"mdo"
  , String
"rec"
  , String
"proc"
  , String
"pattern"
  , String
"role"
  , String
"family"
  , String
"stock"
  , String
"anyclass"
  , String
"via"
  ]

{-  Convert a snake_case or plain identifier to PascalCase.

    @\"user_emails\"  →  \"UserEmails\"@
    @\"users\"        →  \"Users\"@
-}
pascalCase :: String -> String
pascalCase :: String -> String
pascalCase = (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
titleWord ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitSnake

{-  Convert a snake_case or PascalCase identifier to camelCase.

    @\"tenant_id\"    →  \"tenantId\"@
    @\"UserEmails\"   →  \"userEmails\"@
    @\"name\"         →  \"name\"@
-}
camelCase :: String -> String
camelCase :: String -> String
camelCase String
s = case String -> [String]
splitSnake String
s of
  []       -> []
  (String
w : [String]
ws) -> String -> String
lowerFirst String
w String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
titleWord [String]
ws

titleWord :: String -> String
titleWord :: String -> String
titleWord []       = []
titleWord (Char
c : String
cs) = Char -> Char
toUpper Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs

lowerFirst :: String -> String
lowerFirst :: String -> String
lowerFirst []       = []
lowerFirst (Char
c : String
cs) = Char -> Char
toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs

{-  Split a string on underscores.

    @\"tenant_id\"  →  [\"tenant\", \"id\"]@
    @\"name\"       →  [\"name\"]@
-}
splitSnake :: String -> [String]
splitSnake :: String -> [String]
splitSnake [] = []
splitSnake String
s = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') String
s of
  (String
word, [])       -> [String
word]
  (String
word, Char
_ : String
rest) -> String
word String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
splitSnake String
rest