{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE ViewPatterns #-}

-- | Description: Translate insert statements.
module Squeal.QuasiQuotes.Insert (
  toSquealInsert,
) where

import Control.Monad (when, zipWithM)
import Data.Foldable (foldlM)
import Data.Maybe (isJust)
import Language.Haskell.TH.Syntax (Exp(AppE, ConE, LabelE, ListE, VarE), Q)
import Prelude
  ( Applicative(pure), Either(Left), Eq((/=)), Foldable(foldr, length)
  , Maybe(Just, Nothing), MonadFail(fail), Semigroup((<>)), Show(show)
  , Traversable(mapM), ($), (.), (<$>), error, otherwise
  )
import Squeal.QuasiQuotes.Query (getIdentText, renderPGTAExpr, toSquealQuery)
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as Text
import qualified PostgresqlSyntax.Ast as PGT_AST
import qualified Squeal.PostgreSQL as S


renderPGTWithClause :: PGT_AST.WithClause -> Q ([Text.Text], Exp)
renderPGTWithClause :: WithClause -> Q ([Text], Exp)
renderPGTWithClause (PGT_AST.WithClause Bool
recursive NonEmpty CommonTableExpr
ctes) = do
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
recursive (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Recursive WITH clauses are not supported yet."
    let
      cteList :: [CommonTableExpr]
cteList = NonEmpty CommonTableExpr -> [CommonTableExpr]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty CommonTableExpr
ctes
    (finalCteNames, renderedCtes) <-
      (([Text], [Exp]) -> CommonTableExpr -> Q ([Text], [Exp]))
-> ([Text], [Exp]) -> [CommonTableExpr] -> Q ([Text], [Exp])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
        ( \([Text]
names, [Exp]
exps) CommonTableExpr
cte -> do
            (name, exp) <- [Text] -> CommonTableExpr -> Q (Text, Exp)
renderCte [Text]
names CommonTableExpr
cte
            pure (names <> [name], exps <> [exp])
        )
        ([], [])
        [CommonTableExpr]
cteList

    let
      withExp =
        (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
          (\Exp
cte Exp
acc -> Name -> Exp
ConE '(S.:>>) Exp -> Exp -> Exp
`AppE` Exp
cte Exp -> Exp -> Exp
`AppE` Exp
acc)
          (Name -> Exp
ConE 'S.Done)
          [Exp]
renderedCtes
    pure (finalCteNames, withExp)
  where
    renderCte :: [Text.Text] -> PGT_AST.CommonTableExpr -> Q (Text.Text, Exp)
    renderCte :: [Text] -> CommonTableExpr -> Q (Text, Exp)
renderCte [Text]
existingCteNames (PGT_AST.CommonTableExpr Ident
ident Maybe (NonEmpty Ident)
maybeColNames Maybe Bool
maybeMaterialized PreparableStmt
stmt) = do
      Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Bool -> Bool
forall a. Maybe a -> Bool
isJust Maybe Bool
maybeMaterialized) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
        String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"MATERIALIZED/NOT MATERIALIZED for CTEs is not supported yet."
      cteStmtExp <-
        case PreparableStmt
stmt of
          PGT_AST.SelectPreparableStmt SelectStmt
selectStmt -> do
            queryExp <- [Text] -> Maybe (NonEmpty Ident) -> SelectStmt -> Q Exp
toSquealQuery [Text]
existingCteNames Maybe (NonEmpty Ident)
maybeColNames SelectStmt
selectStmt
            pure $ VarE 'S.queryStatement `AppE` queryExp
          PreparableStmt
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Only SELECT statements are supported in CTEs for now."
      let
        cteName = Ident -> Text
getIdentText Ident
ident
      pure
        (cteName, VarE 'S.as `AppE` cteStmtExp `AppE` LabelE (Text.unpack cteName))


toSquealInsert :: PGT_AST.InsertStmt -> Q Exp
toSquealInsert :: InsertStmt -> Q Exp
toSquealInsert
  ( PGT_AST.InsertStmt
      Maybe WithClause
maybeWithClause
      InsertTarget
insertTarget
      InsertRest
insertRest
      Maybe OnConflict
maybeOnConflict
      Maybe ReturningClause
maybeReturningClause
    ) = do
    (cteNames, renderedWithClause) <-
      case Maybe WithClause
maybeWithClause of
        Maybe WithClause
Nothing -> ([Text], Maybe Exp) -> Q ([Text], Maybe Exp)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Maybe Exp
forall a. Maybe a
Nothing)
        Just WithClause
withClause -> do
          (names, exp) <- WithClause -> Q ([Text], Exp)
renderPGTWithClause WithClause
withClause
          pure (names, Just exp)

    let
      table = InsertTarget -> Exp
renderPGTInsertTarget InsertTarget
insertTarget

    queryClauseExp <-
      case insertRest of
        PGT_AST.SelectInsertRest Maybe InsertColumnList
maybeInsertColumnList Maybe OverrideKind
maybeOverrideKind SelectStmt
selectStmt -> do
          Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe OverrideKind -> Bool
forall a. Maybe a -> Bool
isJust Maybe OverrideKind
maybeOverrideKind) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
            String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"OVERRIDING clause is not supported yet."
          case SelectStmt
selectStmt of
            -- Case 1: INSERT ... VALUES ...
            Left
              (PGT_AST.SelectNoParens Maybe WithClause
_ (Left (PGT_AST.ValuesSimpleSelect ValuesClause
valuesClause)) Maybe SortClause
_ Maybe SelectLimit
_ Maybe ForLockingClause
_) ->
                case Maybe InsertColumnList
maybeInsertColumnList of
                  Just InsertColumnList
colItems ->
                    [Text] -> [InsertColumnItem] -> ValuesClause -> Q Exp
renderPGTValueRows [Text]
cteNames (InsertColumnList -> [InsertColumnItem]
forall a. NonEmpty a -> [a]
NE.toList InsertColumnList
colItems) ValuesClause
valuesClause
                  Maybe InsertColumnList
Nothing ->
                    String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                      String
"INSERT INTO ... VALUES must specify column names for the Squeal-QQ translation."
            -- Case 2: INSERT ... SELECT ... (a general SELECT statement)
            SelectStmt
_ ->
              -- selectStmt is not a ValuesSimpleSelect (i.e., it's a general query)
              case Maybe InsertColumnList
maybeInsertColumnList of
                Just InsertColumnList
_ ->
                  String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                    String
"INSERT INTO table (columns) SELECT ... is not yet supported by Squeal-QQ. Please use INSERT INTO table SELECT ... and ensure your SELECT statement provides all columns for the table, matching the table's column order and types."
                Maybe InsertColumnList
Nothing -> do
                  squealQueryExp <- [Text] -> Maybe (NonEmpty Ident) -> SelectStmt -> Q Exp
toSquealQuery [Text]
cteNames Maybe (NonEmpty Ident)
forall a. Maybe a
Nothing SelectStmt
selectStmt -- from Squeal.QuasiQuotes.Query
                  pure (ConE 'S.Subquery `AppE` squealQueryExp)
        InsertRest
PGT_AST.DefaultValuesInsertRest ->
          String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"INSERT INTO ... DEFAULT VALUES is not yet supported by Squeal-QQ."

    let
      renderReturning Maybe ReturningClause
maybeReturning = case Maybe ReturningClause
maybeReturning of
        Maybe ReturningClause
Nothing -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'S.Returning_ Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'S.Nil
        Just (ReturningClause -> [TargetEl]
forall a. NonEmpty a -> [a]
NE.toList -> [TargetEl
PGT_AST.AsteriskTargetEl]) ->
          Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'S.Returning Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'S.Star
        Just ReturningClause
targetList -> do
          returningProj <- [Text] -> [TargetEl] -> Q Exp
renderTargetList [Text]
cteNames (ReturningClause -> [TargetEl]
forall a. NonEmpty a -> [a]
NE.toList ReturningClause
targetList)
          pure $ ConE 'S.Returning `AppE` (ConE 'S.List `AppE` returningProj)
    insertBody <-
      case (maybeOnConflict, maybeReturningClause) of
        (Maybe OnConflict
Nothing, Maybe ReturningClause
Nothing) ->
          Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'S.insertInto_ Exp -> Exp -> Exp
`AppE` Exp
table Exp -> Exp -> Exp
`AppE` Exp
queryClauseExp
        (Just OnConflict
onConflict, Maybe ReturningClause
returning) -> do
          onConflictExp <- [Text] -> OnConflict -> Q Exp
renderOnConflict [Text]
cteNames OnConflict
onConflict
          returningExp <- renderReturning returning
          pure $ VarE 'S.insertInto `AppE` table `AppE` queryClauseExp `AppE` onConflictExp `AppE` returningExp
        (Maybe OnConflict
Nothing, Maybe ReturningClause
returning) -> do
          let onConflictExp :: Exp
onConflictExp = Name -> Exp
ConE 'S.OnConflictDoRaise
          returningExp <- Maybe ReturningClause -> Q Exp
renderReturning Maybe ReturningClause
returning
          pure $ VarE 'S.insertInto `AppE` table `AppE` queryClauseExp `AppE` onConflictExp `AppE` returningExp

    let
      finalExp = case Maybe Exp
renderedWithClause of
        Maybe Exp
Nothing -> Exp
insertBody
        Just Exp
withExp -> Name -> Exp
VarE 'S.with Exp -> Exp -> Exp
`AppE` Exp
withExp Exp -> Exp -> Exp
`AppE` Exp
insertBody
    pure finalExp


renderTargetList :: [Text.Text] -> [PGT_AST.TargetEl] -> Q Exp
renderTargetList :: [Text] -> [TargetEl] -> Q Exp
renderTargetList [Text]
cteNames [TargetEl]
targetEls = do
  exps <- (TargetEl -> Q Exp) -> [TargetEl] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Text] -> TargetEl -> Q Exp
renderTargetEl [Text]
cteNames) [TargetEl]
targetEls
  pure $
    foldr
      (\Exp
h Exp
t -> Name -> Exp
ConE '(S.:*) Exp -> Exp -> Exp
`AppE` Exp
h Exp -> Exp -> Exp
`AppE` Exp
t)
      (ConE 'S.Nil)
      exps


renderTargetEl :: [Text.Text] -> PGT_AST.TargetEl -> Q Exp
renderTargetEl :: [Text] -> TargetEl -> Q Exp
renderTargetEl [Text]
cteNames = \case
  PGT_AST.ExprTargetEl AExpr
expr -> do
    exprExp <- [Text] -> AExpr -> Q Exp
renderPGTAExpr [Text]
cteNames AExpr
expr
    case expr of
      PGT_AST.CExprAExpr (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref Ident
ident Maybe Indirection
Nothing)) ->
        let
          colName :: Text
colName = Ident -> Text
getIdentText Ident
ident
        in
          Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'S.as Exp -> Exp -> Exp
`AppE` Exp
exprExp Exp -> Exp -> Exp
`AppE` String -> Exp
LabelE (Text -> String
Text.unpack Text
colName)
      AExpr
_ ->
        String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
          String
"Returning expression without an alias is not supported for this expression type. Please add an alias."
  PGT_AST.AliasedExprTargetEl AExpr
expr Ident
alias -> do
    exprExp <- [Text] -> AExpr -> Q Exp
renderPGTAExpr [Text]
cteNames AExpr
expr
    pure $
      VarE 'S.as `AppE` exprExp `AppE` LabelE (Text.unpack (getIdentText alias))
  TargetEl
PGT_AST.AsteriskTargetEl -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"should be handled by toSquealInsert"
  PGT_AST.ImplicitlyAliasedExprTargetEl{} ->
    String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Implicitly aliased expressions in RETURNING are not supported"


getUnqualifiedNameFromAst :: PGT_AST.QualifiedName -> Text.Text
getUnqualifiedNameFromAst :: QualifiedName -> Text
getUnqualifiedNameFromAst (PGT_AST.SimpleQualifiedName Ident
ident) = Ident -> Text
getIdentText Ident
ident
getUnqualifiedNameFromAst (PGT_AST.IndirectedQualifiedName Ident
_ (PGT_AST.AttrNameIndirectionEl Ident
ident NE.:| [])) = Ident -> Text
getIdentText Ident
ident
getUnqualifiedNameFromAst QualifiedName
unsupported =
  String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
    String
"Unsupported qualified name structure for extracting unqualified name: "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> QualifiedName -> String
forall a. Show a => a -> String
show QualifiedName
unsupported


renderPGTInsertTarget :: PGT_AST.InsertTarget -> Exp
renderPGTInsertTarget :: InsertTarget -> Exp
renderPGTInsertTarget (PGT_AST.InsertTarget QualifiedName
qualifiedName Maybe Ident
maybeAsAlias) =
  let
    tableIdentifierExp :: Exp
tableIdentifierExp = QualifiedName -> Exp
renderPGTQualifiedName QualifiedName
qualifiedName
    targetAliasText :: Text
targetAliasText = case Maybe Ident
maybeAsAlias of
      Maybe Ident
Nothing -> QualifiedName -> Text
getUnqualifiedNameFromAst QualifiedName
qualifiedName
      Just Ident
asAliasColId -> Ident -> Text
getIdentText Ident
asAliasColId
    targetAliasExp :: Exp
targetAliasExp = String -> Exp
LabelE (Text -> String
Text.unpack Text
targetAliasText)
  in
    Name -> Exp
VarE 'S.as Exp -> Exp -> Exp
`AppE` Exp
tableIdentifierExp Exp -> Exp -> Exp
`AppE` Exp
targetAliasExp


renderPGTQualifiedName :: PGT_AST.QualifiedName -> Exp
renderPGTQualifiedName :: QualifiedName -> Exp
renderPGTQualifiedName = \case
  PGT_AST.SimpleQualifiedName Ident
ident -> String -> Exp
LabelE (Text -> String
Text.unpack (Ident -> Text
getIdentText Ident
ident)) -- Defaults to public schema
  PGT_AST.IndirectedQualifiedName
    Ident
schemaIdent
    (PGT_AST.AttrNameIndirectionEl Ident
colIdent NE.:| []) ->
      -- Assuming simple schema.table form
      Name -> Exp
VarE '(S.!)
        Exp -> Exp -> Exp
`AppE` String -> Exp
LabelE (Text -> String
Text.unpack (Ident -> Text
getIdentText Ident
schemaIdent))
        Exp -> Exp -> Exp
`AppE` String -> Exp
LabelE (Text -> String
Text.unpack (Ident -> Text
getIdentText Ident
colIdent))
  QualifiedName
unsupported -> String -> Exp
forall a. HasCallStack => String -> a
error (String -> Exp) -> String -> Exp
forall a b. (a -> b) -> a -> b
$ String
"Unsupported qualified name structure: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> QualifiedName -> String
forall a. Show a => a -> String
show QualifiedName
unsupported


renderPGTValueRows
  :: [Text.Text] -> [PGT_AST.InsertColumnItem] -> PGT_AST.ValuesClause -> Q Exp
renderPGTValueRows :: [Text] -> [InsertColumnItem] -> ValuesClause -> Q Exp
renderPGTValueRows [Text]
cteNames [InsertColumnItem]
colItems (ValuesClause
valuesClauseRows) =
  -- valuesClauseRows is NonEmpty (NonEmpty AExpr)
  case ValuesClause -> [ExprList]
forall a. NonEmpty a -> [a]
NE.toList ValuesClause
valuesClauseRows of
    [] -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Insert statement has no value rows."
    ExprList
row : [ExprList]
moreRows -> do
      firstRowExp <- [Text] -> [InsertColumnItem] -> [AExpr] -> Q Exp
renderPGTValueRow [Text]
cteNames [InsertColumnItem]
colItems (ExprList -> [AExpr]
forall a. NonEmpty a -> [a]
NE.toList ExprList
row)
      moreRowsExp <- mapM (renderPGTValueRow cteNames colItems . NE.toList) moreRows
      pure $
        ConE 'S.Values
          `AppE` firstRowExp
          `AppE` ListE moreRowsExp


renderPGTValueRow :: [Text.Text] -> [PGT_AST.InsertColumnItem] -> [PGT_AST.AExpr] -> Q Exp
renderPGTValueRow :: [Text] -> [InsertColumnItem] -> [AExpr] -> Q Exp
renderPGTValueRow [Text]
cteNames [InsertColumnItem]
colItems [AExpr]
exprs
  | [InsertColumnItem] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InsertColumnItem]
colItems Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [AExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AExpr]
exprs =
      String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Mismatched number of column names and values in INSERT statement."
  | Bool
otherwise = do
      processedItems <- (InsertColumnItem -> AExpr -> Q Exp)
-> [InsertColumnItem] -> [AExpr] -> Q [Exp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM InsertColumnItem -> AExpr -> Q Exp
processItem [InsertColumnItem]
colItems [AExpr]
exprs
      pure $ foldr nvpToCons (ConE 'S.Nil) processedItems
 where
  nvpToCons :: Exp -> Exp -> Exp
  nvpToCons :: Exp -> Exp -> Exp
nvpToCons Exp
item Exp
acc = Name -> Exp
ConE '(S.:*) Exp -> Exp -> Exp
`AppE` Exp
item Exp -> Exp -> Exp
`AppE` Exp
acc

  processItem :: PGT_AST.InsertColumnItem -> PGT_AST.AExpr -> Q Exp
  processItem :: InsertColumnItem -> AExpr -> Q Exp
processItem (PGT_AST.InsertColumnItem Ident
colId Maybe Indirection
maybeIndirection) AExpr
expr = do
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Indirection -> Bool
forall a. Maybe a -> Bool
isJust Maybe Indirection
maybeIndirection) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"INSERT with indirection (e.g., array access) is not supported."
    let
      colNameStr :: String
colNameStr = Text -> String
Text.unpack (Ident -> Text
getIdentText Ident
colId)
    case AExpr
expr of
      AExpr
PGT_AST.DefaultAExpr ->
        -- Check for DEFAULT keyword
        Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
          Name -> Exp
VarE 'S.as
            Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'S.Default
            Exp -> Exp -> Exp
`AppE` String -> Exp
LabelE String
colNameStr
      AExpr
_ -> do
        renderedExpr <- [Text] -> AExpr -> Q Exp
renderPGTAExpr [Text]
cteNames AExpr
expr
        pure $
          VarE 'S.as
            `AppE` (ConE 'S.Set `AppE` renderedExpr)
            `AppE` LabelE colNameStr


--
-- ON CONFLICT support note
-- -------------------------
-- As of the pinned upstream `squeal-postgresql` (0.9.2.0), the
-- `ConflictTarget` GADT only exposes `OnConstraint` and there is no
-- clause form for a targetless `ON CONFLICT DO NOTHING`.
--
-- Consequently, this quasiquoter intentionally fails fast when the parsed
-- `PostgresqlSyntax` AST requests either:
--   * a targetless ON CONFLICT (i.e. DO NOTHING without a target), or
--   * a column-list conflict target (i.e. ON CONFLICT (col[, ...]) ...).
--
-- When upstream adds the necessary constructors (e.g. an `OnColumns`
-- conflict target and a clause for targetless `DO NOTHING`), this is the
-- place to wire them through. See `plan.md` for the backlog item.
renderOnConflict :: [Text.Text] -> PGT_AST.OnConflict -> Q Exp
renderOnConflict :: [Text] -> OnConflict -> Q Exp
renderOnConflict [Text]
cteNames (PGT_AST.OnConflict Maybe ConfExpr
maybeConfExpr OnConflictDo
onConflictDo) = do
  conflictActionExp <- [Text] -> OnConflictDo -> Q Exp
renderOnConflictDo [Text]
cteNames OnConflictDo
onConflictDo
  case maybeConfExpr of
    Maybe ConfExpr
Nothing ->
      String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
        (  String
"ON CONFLICT without a conflict target (i.e. targetless DO NOTHING) "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"cannot be represented with squeal-postgresql 0.9.2.0. "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Only ON CONFLICT ON CONSTRAINT ... is currently available. "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"See plan.md for the proposed upstream changes and status."
        )
    Just ConfExpr
confExpr -> do
      conflictTargetExp <- ConfExpr -> Q Exp
renderConfExpr ConfExpr
confExpr
      pure $ ConE 'S.OnConflict `AppE` conflictTargetExp `AppE` conflictActionExp

-- See the ON CONFLICT support note above.
renderConfExpr :: PGT_AST.ConfExpr -> Q Exp
renderConfExpr :: ConfExpr -> Q Exp
renderConfExpr = \case
  PGT_AST.ConstraintConfExpr Ident
name ->
    Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'S.OnConstraint Exp -> Exp -> Exp
`AppE` String -> Exp
LabelE (Text -> String
Text.unpack (Ident -> Text
getIdentText Ident
name))
  PGT_AST.WhereConfExpr IndexParams
_ Maybe AExpr
_ ->
    String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
      (  String
"ON CONFLICT (columns ...) is not supported by squeal-postgresql 0.9.2.0. "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Only ON CONFLICT ON CONSTRAINT ... is currently available. "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"See plan.md for the proposed upstream changes and status."
      )

renderOnConflictDo :: [Text.Text] -> PGT_AST.OnConflictDo -> Q Exp
renderOnConflictDo :: [Text] -> OnConflictDo -> Q Exp
renderOnConflictDo [Text]
cteNames = \case
  OnConflictDo
PGT_AST.NothingOnConflictDo -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'S.DoNothing
  PGT_AST.UpdateOnConflictDo SetClauseList
setClauseList Maybe AExpr
maybeWhereClause -> do
    setClauseListExp <- [Text] -> SetClauseList -> Q Exp
renderPGTSetClauseList' [Text]
cteNames SetClauseList
setClauseList
    whereClauseExp <- case maybeWhereClause of
      Maybe AExpr
Nothing -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE []
      Just AExpr
whereClause -> [Exp] -> Exp
ListE ([Exp] -> Exp) -> (Exp -> [Exp]) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
:[]) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> AExpr -> Q Exp
renderPGTAExpr [Text]
cteNames AExpr
whereClause
    pure $ ConE 'S.DoUpdate `AppE` setClauseListExp `AppE` whereClauseExp

renderPGTSetClauseList' :: [Text.Text] -> PGT_AST.SetClauseList -> Q Exp
renderPGTSetClauseList' :: [Text] -> SetClauseList -> Q Exp
renderPGTSetClauseList' [Text]
cteNames SetClauseList
setClauses = do
  renderedItems <- (SetClause -> Q Exp) -> [SetClause] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Text] -> SetClause -> Q Exp
renderPGTSetClause' [Text]
cteNames) (SetClauseList -> [SetClause]
forall a. NonEmpty a -> [a]
NE.toList SetClauseList
setClauses)
  pure $
    foldr
      (\Exp
item Exp
acc -> Name -> Exp
ConE '(S.:*) Exp -> Exp -> Exp
`AppE` Exp
item Exp -> Exp -> Exp
`AppE` Exp
acc)
      (ConE 'S.Nil)
      renderedItems

renderPGTSetClause' :: [Text.Text] -> PGT_AST.SetClause -> Q Exp
renderPGTSetClause' :: [Text] -> SetClause -> Q Exp
renderPGTSetClause' [Text]
cteNames = \case
  PGT_AST.TargetSetClause (PGT_AST.SetTarget Ident
colId Maybe Indirection
maybeIndirection) AExpr
aExpr -> do
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Indirection -> Bool
forall a. Maybe a -> Bool
isJust Maybe Indirection
maybeIndirection) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"UPDATE SET with indirection (e.g., array access) is not supported."
    let
      colNameStr :: String
colNameStr = Text -> String
Text.unpack (Ident -> Text
getIdentText Ident
colId)
    renderedExpr <- [Text] -> AExpr -> Q Exp
renderPGTAExpr [Text]
cteNames AExpr
aExpr
    pure $
      VarE 'S.as
        `AppE` (ConE 'S.Set `AppE` renderedExpr)
        `AppE` LabelE colNameStr
  PGT_AST.TargetListSetClause SetTargetList
_ AExpr
_ ->
    String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
      String
"UPDATE with multiple SET targets (e.g. (col1, col2) = (val1, val2)) is not yet supported."