module Hasql.Generate.TH
    ( GenerateConfig
    , fromTable
    , fromType
    , fromView
    , generate
    , withDefaultedCols
    , withDerivations
    , withOverrides
    ) where

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

import           Control.Applicative                ( (<*>) )
import           Control.Monad                      ( mapM, mapM_, return )
import           Control.Monad.Fail                 ( MonadFail (fail) )

import           Data.Bool
    ( Bool (..)
    , not
    , otherwise
    )
import           Data.Char                          ( toLower, toUpper )
import           Data.Eq                            ( (==) )
import           Data.Foldable                      ( foldl )
import           Data.Function                      ( flip, ($), (.) )
import           Data.Functor                       ( (<$>) )
import qualified Data.Functor.Contravariant         as Contravariant
import           Data.Int                           ( Int )
import           Data.List
    ( break
    , concatMap
    , elem
    , filter
    , intercalate
    , length
    , lookup
    , map
    , notElem
    , null
    , partition
    , zip
    , zipWith
    , (!!)
    )
import           Data.Maybe                         ( Maybe (..) )
import           Data.Semigroup                     ( (<>) )
import           Data.String                        ( String )
import qualified Data.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)]
        & withDefaultedCols [\"id\"]
    @
-}
data GenerateConfig
    = GenerateConfig
      { GenerateConfig -> String
gcSchema        :: String
      , GenerateConfig -> String
gcTable         :: String
      , GenerateConfig -> RelationKind
gcKind          :: RelationKind
      , GenerateConfig -> [Name]
gcDerivations   :: [Name]
      , GenerateConfig -> [(String, Name)]
gcOverrides     :: [(String, Name)]
      , GenerateConfig -> [String]
gcDefaultedCols :: [String]
      }

{- | Create a 'GenerateConfig' for the given schema and table with no derivations
    and no type overrides. Generates full CRUD code.
-}
fromTable :: String -> String -> GenerateConfig
fromTable :: String -> String -> GenerateConfig
fromTable String
schema String
table =
  GenerateConfig
    { gcSchema :: String
gcSchema = String
schema
    , gcTable :: String
gcTable = String
table
    , gcKind :: RelationKind
gcKind = RelationKind
Table
    , gcDerivations :: [Name]
gcDerivations = []
    , gcOverrides :: [(String, Name)]
gcOverrides = []
    , gcDefaultedCols :: [String]
gcDefaultedCols = []
    }

{- | Create a 'GenerateConfig' for the given schema and view with no derivations
    and no type overrides. Generates read-only code: a record type, a decoder,
    a SELECT statement, and a 'HasView' instance.
-}
fromView :: String -> String -> GenerateConfig
fromView :: String -> String -> GenerateConfig
fromView String
schema String
view =
  GenerateConfig
    { gcSchema :: String
gcSchema = String
schema
    , gcTable :: String
gcTable = String
view
    , gcKind :: RelationKind
gcKind = RelationKind
View
    , gcDerivations :: [Name]
gcDerivations = []
    , gcOverrides :: [(String, Name)]
gcOverrides = []
    , gcDefaultedCols :: [String]
gcDefaultedCols = []
    }

{- | Create a 'GenerateConfig' for the given schema and enum type with no
    derivations. Generates a Haskell sum type, a 'PgCodec' instance,
    and a 'PgColumn' instance. Overrides are ignored for types.

    The splice must appear before any @fromTable@ whose table has a column of
    this enum type, since TH processes splices top to bottom.

    __Orphan instance warning:__ The generated @PgColumn@ instance will trigger
    GHC's @-Worphans@ warning because the functional dependency's determining
    types are @Symbol@ literals, which GHC never considers local to any user
    module. This is expected and harmless. Add the following pragma to any
    module that uses @fromType@:

    @
    \{\-\# OPTIONS_GHC -Wno-orphans \#\-\}
    @
-}
fromType :: String -> String -> GenerateConfig
fromType :: String -> String -> GenerateConfig
fromType String
schema String
typeName =
  GenerateConfig
    { gcSchema :: String
gcSchema = String
schema
    , gcTable :: String
gcTable = String
typeName
    , gcKind :: RelationKind
gcKind = RelationKind
Type
    , gcDerivations :: [Name]
gcDerivations = []
    , gcOverrides :: [(String, Name)]
gcOverrides = []
    , gcDefaultedCols :: [String]
gcDefaultedCols = []
    }

-- | Append derivation class 'Name's to the config.
withDerivations :: [Name] -> GenerateConfig -> GenerateConfig
withDerivations :: [Name] -> GenerateConfig -> GenerateConfig
withDerivations [Name]
names GenerateConfig
cfg = GenerateConfig
cfg {gcDerivations = gcDerivations cfg <> names}

{- | Append per-table PG type overrides. Each pair maps a PostgreSQL type name
    (e.g. @\"timestamptz\"@) to a Haskell type 'Name' (e.g. @''UTCTime@).
    The override type must still have a 'PgCodec' instance.
-}
withOverrides :: [(String, Name)] -> GenerateConfig -> GenerateConfig
withOverrides :: [(String, Name)] -> GenerateConfig -> GenerateConfig
withOverrides [(String, Name)]
ovs GenerateConfig
cfg = GenerateConfig
cfg {gcOverrides = gcOverrides cfg <> ovs}

{- | Exclude the named columns from INSERT statements. Each column must exist
    in the table and have a database default (@atthasdef = true@ in
    @pg_catalog@); a compile-time error is raised otherwise.

    @
    fromTable \"public\" \"users\" & withDefaultedCols [\"id\", \"created_at\"]
    @
-}
withDefaultedCols :: [String] -> GenerateConfig -> GenerateConfig
withDefaultedCols :: [String] -> GenerateConfig -> GenerateConfig
withDefaultedCols [String]
cols GenerateConfig
cfg = GenerateConfig
cfg {gcDefaultedCols = gcDefaultedCols cfg <> cols}

{- | Terminal step that introspects a PostgreSQL database at compile time and
    generates the provided data construct:

    Usage:
    @
    \$(generate def (fromTable \"public\" \"users\" & withDerivations [''Show, ''Eq]))
    @
-}
generate :: Config -> GenerateConfig -> Q [Dec]
generate :: Config -> 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 defaultedCols 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
gcSchema GenerateConfig
genConfig
    table :: String
table = GenerateConfig -> String
gcTable GenerateConfig
genConfig
    kind :: RelationKind
kind = GenerateConfig -> RelationKind
gcKind GenerateConfig
genConfig
    derivNames :: [Name]
derivNames = GenerateConfig -> [Name]
gcDerivations GenerateConfig
genConfig
    defaultedCols :: [String]
defaultedCols = GenerateConfig -> [String]
gcDefaultedCols GenerateConfig
genConfig
    mergedOverrides :: [(String, Name)]
mergedOverrides = GenerateConfig -> [(String, Name)]
gcOverrides 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 -> [String] -> String -> String -> String -> [Name] -> [ResolvedColumn] -> PkInfo -> Q [Dec]
generateAllDecs :: Config
-> [String]
-> String
-> String
-> String
-> [Name]
-> [ResolvedColumn]
-> PkInfo
-> Q [Dec]
generateAllDecs Config
config [String]
defaultedCols 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'
  insertCols <- computeInsertCols defaultedCols resolvedCols'
  insDec <- genInsert schema table typName resolvedCols' insertCols
  insMany <- genInsertMany schema table typName resolvedCols' insertCols
  hasInsInst <- genHasInsertInstance typName

  -- Generate PK-dependent statements and instances (single + batch)
  pkDecs <- case pkInfo' of
    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. Each column name in the
    @defaultedNames@ list is validated to exist in the table and to have a
    database default (@atthasdef@); a compile-time error is raised otherwise.
    Validated columns are then excluded from the insert column list.
-}
computeInsertCols :: [String] -> [ResolvedColumn] -> Q [ResolvedColumn]
computeInsertCols :: [String] -> [ResolvedColumn] -> Q [ResolvedColumn]
computeInsertCols [] [ResolvedColumn]
allCols = [ResolvedColumn] -> Q [ResolvedColumn]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [ResolvedColumn]
allCols
computeInsertCols [String]
defaultedNames [ResolvedColumn]
allCols = do
  (String -> Q ()) -> [String] -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([ResolvedColumn] -> String -> Q ()
validateDefaulted [ResolvedColumn]
allCols) [String]
defaultedNames
  [ResolvedColumn] -> Q [ResolvedColumn]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((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]
defaultedNames) [ResolvedColumn]
allCols)

validateDefaulted :: [ResolvedColumn] -> String -> Q ()
validateDefaulted :: [ResolvedColumn] -> String -> Q ()
validateDefaulted [ResolvedColumn]
allCols String
name =
  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
name) [ResolvedColumn]
allCols of
    [] ->
      String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
        ( String
"hasql-generate: withDefaultedCols: column '"
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' not found"
        )
    (ResolvedColumn
rc : [ResolvedColumn]
_) ->
      if ResolvedColumn -> Bool
rcHasDefault ResolvedColumn
rc
        then () -> Q ()
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else
          String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
            ( String
"hasql-generate: withDefaultedCols: column '"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' has no database default"
            )

{-  Generate the INSERT statement. @allCols@ is the full record column list
    (used for RETURNING and the decoder), @insertCols@ is the subset actually
    included in the INSERT column list and VALUES params. When PK columns have
    defaults, @insertCols@ excludes them.
-}
genInsert
  :: String -> String -> String -> [ResolvedColumn] -> [ResolvedColumn] -> Q [Dec]
genInsert :: 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