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

-- | Commonplace renderers shared by other modules.
module Squeal.QuasiQuotes.Common (
  renderPGTTableRef,
  renderPGTAExpr,
  getIdentText,
  renderPGTTargeting,
  renderPGTTargetList,
) where

import Control.Applicative (Alternative((<|>)))
import Control.Monad (when)
import Data.Foldable (Foldable(elem, foldl', null))
import Data.Maybe (isJust)
import Data.String (IsString(fromString))
import Language.Haskell.TH.Syntax
  ( Exp(AppE, AppTypeE, ConE, InfixE, LabelE, ListE, LitE, TupE, VarE)
  , Lit(IntegerL, StringL), TyLit(NumTyLit), Type(LitT), Name, Q, mkName
  )
import Prelude
  ( Applicative(pure), Bool(False, True), Either(Left, Right), Eq((==))
  , Functor(fmap), Maybe(Just, Nothing), MonadFail(fail)
  , Num((*), (+), (-), fromInteger), Ord((<)), Semigroup((<>)), Show(show)
  , Traversable(mapM), ($), (&&), (.), (<$>), (||), Int, Integer, any, either
  , error, fromIntegral, id
  )
import qualified Data.ByteString.Char8 as BS8
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


getIdentText :: PGT_AST.Ident -> Text.Text
getIdentText :: Ident -> Text
getIdentText = \case
  PGT_AST.QuotedIdent Text
t -> Text
t
  PGT_AST.UnquotedIdent Text
t -> Text
t


renderPGTTableRef :: NE.NonEmpty PGT_AST.TableRef -> Q Exp
renderPGTTableRef :: NonEmpty TableRef -> Q Exp
renderPGTTableRef NonEmpty TableRef
tableRefs = do
  renderedTableRefs <- (TableRef -> Q Exp) -> [TableRef] -> 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 TableRef -> Q Exp
renderSingleTableRef (NonEmpty TableRef -> [TableRef]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty TableRef
tableRefs)
  case renderedTableRefs of
    [] -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Empty FROM clause" -- Should not happen with NonEmpty
    (Exp
firstTbl : [Exp]
restTbls) ->
      -- For FROM t1, t2, t3 Squeal uses: (table #t1) & also (table #t2) & also (table #t3)
      -- S.also takes new item first, then accumulated.
      -- So foldl' (\acc item -> VarE 'S.also `AppE` item `AppE` acc) firstTbl restTbls
      -- However, Squeal's FromClause Additional instance is `also right left`, meaning `also new current`.
      -- So `foldl (\current new -> VarE 'S.also `AppE` new `AppE` current) firstTbl restTbls` is correct.
      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 -> 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
acc Exp
tbl -> Name -> Exp
VarE 'S.also Exp -> Exp -> Exp
`AppE` Exp
tbl Exp -> Exp -> Exp
`AppE` Exp
acc) Exp
firstTbl [Exp]
restTbls


renderSingleTableRef :: PGT_AST.TableRef -> Q Exp
renderSingleTableRef :: TableRef -> Q Exp
renderSingleTableRef = \case
  PGT_AST.RelationExprTableRef RelationExpr
relationExpr Maybe AliasClause
maybeAliasClause Maybe TablesampleClause
sampleClause -> do
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe TablesampleClause -> Bool
forall a. Maybe a -> Bool
isJust Maybe TablesampleClause
sampleClause) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"TABLESAMPLE clause is not supported yet."
    RelationExpr -> Maybe AliasClause -> Q Exp
renderPGTRelationExprTableRef RelationExpr
relationExpr Maybe AliasClause
maybeAliasClause
  PGT_AST.JoinTableRef JoinedTable
joinedTable Maybe AliasClause
maybeAliasClause ->
    -- If `maybeAliasClause` is Just, it means `(JOIN_TABLE) AS alias`.
    -- Squeal's direct join combinators don't alias the *result* of the join.
    -- This would require wrapping the join in a subquery.
    -- For now, we'll fail if an alias is applied to a complex join structure directly.
    -- Simple table references with aliases are handled by RelationExprTableRef.
    case Maybe AliasClause
maybeAliasClause of
      Just AliasClause
_ ->
        [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail
          [Char]
"Aliasing a JOIN clause directly is not supported. Consider a subquery: (SELECT * FROM ...) AS alias"
      Maybe AliasClause
Nothing -> JoinedTable -> Q Exp
renderPGTJoinedTable JoinedTable
joinedTable
  -- PGT_AST.InParensTableRefTableRef was an incorrect pattern, removing it.
  -- Parenthesized joins are handled by PGT_AST.InParensJoinedTable within renderPGTJoinedTable.
  TableRef
unsupported ->
    [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported TableRef type in renderSingleTableRef: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> TableRef -> [Char]
forall a. Show a => a -> [Char]
show TableRef
unsupported


renderPGTJoinedTable :: PGT_AST.JoinedTable -> Q Exp
renderPGTJoinedTable :: JoinedTable -> Q Exp
renderPGTJoinedTable = \case
  PGT_AST.InParensJoinedTable JoinedTable
joinedTable -> JoinedTable -> Q Exp
renderPGTJoinedTable JoinedTable
joinedTable
  PGT_AST.MethJoinedTable JoinMeth
joinMeth TableRef
leftRef TableRef
rightRef -> do
    leftTableExp <- TableRef -> Q Exp
renderSingleTableRef TableRef
leftRef
    rightTableExp <- renderSingleTableRef rightRef
    case joinMeth of
      PGT_AST.QualJoinMeth Maybe JoinType
maybeJoinType JoinQual
joinQual ->
        case JoinQual
joinQual of
          PGT_AST.OnJoinQual AExpr
onConditionAExpr -> do
            onConditionExp <- AExpr -> Q Exp
renderPGTAExpr AExpr
onConditionAExpr
            squealJoinFn <-
              case maybeJoinType of
                Just (PGT_AST.LeftJoinType Bool
_) -> 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.leftOuterJoin
                Just (PGT_AST.RightJoinType Bool
_) -> 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.rightOuterJoin
                Just (PGT_AST.FullJoinType Bool
_) -> 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.fullOuterJoin
                Just JoinType
PGT_AST.InnerJoinType -> 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.innerJoin
                Maybe JoinType
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.innerJoin -- SQL JOIN (no type) is INNER JOIN
                -- Change: Use S.& for join: leftTableExp & squealJoinFn rightTableExp onConditionExp
            pure $
              InfixE
                (Just leftTableExp)
                (VarE '(S.&))
                (Just (squealJoinFn `AppE` rightTableExp `AppE` onConditionExp))
          PGT_AST.UsingJoinQual NonEmpty Ident
_identsNE ->
            [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"USING join qualification not yet supported"
      JoinMeth
PGT_AST.CrossJoinMeth ->
        -- Change: Use S.& for crossJoin: leftTableExp & S.crossJoin rightTableExp
        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
$
          Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
            (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
leftTableExp)
            (Name -> Exp
VarE '(S.&))
            (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE 'S.crossJoin Exp -> Exp -> Exp
`AppE` Exp
rightTableExp))
      PGT_AST.NaturalJoinMeth Maybe JoinType
_naturalJoinType ->
        -- Squeal does not have direct high-level support for NATURAL JOIN.
        -- These would typically be rewritten as INNER JOINs with USING clauses
        -- or explicit ON conditions based on common column names.
        -- This is complex to implement correctly in the QQ and might be error-prone.
        [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"NATURAL JOIN is not supported by Squeal-QQ."


renderPGTRelationExprTableRef
  :: PGT_AST.RelationExpr -> Maybe PGT_AST.AliasClause -> Q Exp
renderPGTRelationExprTableRef :: RelationExpr -> Maybe AliasClause -> Q Exp
renderPGTRelationExprTableRef RelationExpr
relationExpr Maybe AliasClause
maybeAliasClause = do
  tableExpr <-
    case RelationExpr
relationExpr of
      PGT_AST.SimpleRelationExpr QualifiedName
qualifiedName Bool
isAsterisk -> do
        Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isAsterisk (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Relation with '*' (e.g. 'table *') is not supported."
        QualifiedName -> Q Exp
renderPGTQualifiedName QualifiedName
qualifiedName
      PGT_AST.OnlyRelationExpr QualifiedName
_qualifiedName Bool
_areParensPresent -> do
        -- Squeal doesn't have a direct equivalent for ONLY, so we treat it as a normal table for now.
        -- This might need adjustment if ONLY semantics are critical.
        [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"ONLY keyword is not supported."

  aliasStr <-
    case maybeAliasClause of
      Just (PGT_AST.AliasClause Bool
_ Ident
aliasIdent Maybe (NonEmpty Ident)
_) -> [Char] -> Q [Char]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Q [Char]) -> [Char] -> Q [Char]
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Text.unpack (Ident -> Text
getIdentText Ident
aliasIdent)
      Maybe AliasClause
Nothing -> case RelationExpr
relationExpr of -- Infer default alias if none provided
        PGT_AST.SimpleRelationExpr (PGT_AST.SimpleQualifiedName Ident
ident) Bool
_ -> [Char] -> Q [Char]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Q [Char]) -> [Char] -> Q [Char]
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Text.unpack (Ident -> Text
getIdentText Ident
ident)
        PGT_AST.SimpleRelationExpr
          ( PGT_AST.IndirectedQualifiedName
              Ident
_
              (Indirection -> IndirectionEl
forall a. NonEmpty a -> a
NE.last -> PGT_AST.AttrNameIndirectionEl Ident
ident)
            )
          Bool
_ -> [Char] -> Q [Char]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Q [Char]) -> [Char] -> Q [Char]
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Text.unpack (Ident -> Text
getIdentText Ident
ident)
        RelationExpr
_ ->
          [Char] -> Q [Char]
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q [Char]) -> [Char] -> Q [Char]
forall a b. (a -> b) -> a -> b
$
            [Char]
"Cannot determine default alias for relation expression: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> RelationExpr -> [Char]
forall a. Show a => a -> [Char]
show RelationExpr
relationExpr

  pure $ VarE 'S.table `AppE` (VarE 'S.as `AppE` tableExpr `AppE` LabelE aliasStr)


renderPGTQualifiedName :: PGT_AST.QualifiedName -> Q Exp
renderPGTQualifiedName :: QualifiedName -> Q Exp
renderPGTQualifiedName = \case
  PGT_AST.SimpleQualifiedName Ident
ident -> 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
$ [Char] -> Exp
LabelE (Text -> [Char]
Text.unpack (Ident -> Text
getIdentText Ident
ident))
  PGT_AST.IndirectedQualifiedName
    Ident
schemaIdent
    (PGT_AST.AttrNameIndirectionEl Ident
colIdent NE.:| []) ->
      -- Assuming schema.table.col
      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.!)
          Exp -> Exp -> Exp
`AppE` [Char] -> Exp
LabelE (Text -> [Char]
Text.unpack (Ident -> Text
getIdentText Ident
schemaIdent))
          Exp -> Exp -> Exp
`AppE` [Char] -> Exp
LabelE (Text -> [Char]
Text.unpack (Ident -> Text
getIdentText Ident
colIdent))
  QualifiedName
unsupported ->
    [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported qualified name for table reference: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> QualifiedName -> [Char]
forall a. Show a => a -> [Char]
show QualifiedName
unsupported


-- | Defines associativity of an operator.
data Associativity = LeftAssoc | RightAssoc | NonAssoc
  deriving stock (Associativity -> Associativity -> Bool
(Associativity -> Associativity -> Bool)
-> (Associativity -> Associativity -> Bool) -> Eq Associativity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Associativity -> Associativity -> Bool
== :: Associativity -> Associativity -> Bool
$c/= :: Associativity -> Associativity -> Bool
/= :: Associativity -> Associativity -> Bool
Eq, Int -> Associativity -> [Char] -> [Char]
[Associativity] -> [Char] -> [Char]
Associativity -> [Char]
(Int -> Associativity -> [Char] -> [Char])
-> (Associativity -> [Char])
-> ([Associativity] -> [Char] -> [Char])
-> Show Associativity
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Associativity -> [Char] -> [Char]
showsPrec :: Int -> Associativity -> [Char] -> [Char]
$cshow :: Associativity -> [Char]
show :: Associativity -> [Char]
$cshowList :: [Associativity] -> [Char] -> [Char]
showList :: [Associativity] -> [Char] -> [Char]
Show)


-- | Holds details for a binary operator relevant to precedence restructuring.
data OperatorDetails = OperatorDetails
  { OperatorDetails -> AExpr -> AExpr -> AExpr
odConstructor :: PGT_AST.AExpr -> PGT_AST.AExpr -> PGT_AST.AExpr
  , OperatorDetails -> Int
odPrecedence :: Int
  , OperatorDetails -> Associativity
odAssociativity :: Associativity
  }


{- | Extracts components if the expression is a recognized binary operator.
Higher precedence number means binds tighter.
Based on PostgreSQL operator precedence.
-}
getOperatorDetails
  :: PGT_AST.AExpr -> Maybe (PGT_AST.AExpr, OperatorDetails, PGT_AST.AExpr)
getOperatorDetails :: AExpr -> Maybe (AExpr, OperatorDetails, AExpr)
getOperatorDetails = \case
  PGT_AST.SymbolicBinOpAExpr AExpr
l SymbolicExprBinOp
symOp AExpr
r ->
    let
      details :: p
-> (AExpr -> AExpr -> AExpr)
-> Int
-> Associativity
-> Maybe (AExpr, OperatorDetails, AExpr)
details p
_op AExpr -> AExpr -> AExpr
constr Int
prec Associativity
assoc = (AExpr, OperatorDetails, AExpr)
-> Maybe (AExpr, OperatorDetails, AExpr)
forall a. a -> Maybe a
Just (AExpr
l, (AExpr -> AExpr -> AExpr)
-> Int -> Associativity -> OperatorDetails
OperatorDetails AExpr -> AExpr -> AExpr
constr Int
prec Associativity
assoc, AExpr
r)
      mathDetails :: MathOp
-> Int -> Associativity -> Maybe (AExpr, OperatorDetails, AExpr)
mathDetails MathOp
mathOp Int
prec Associativity
assoc =
        SymbolicExprBinOp
-> (AExpr -> AExpr -> AExpr)
-> Int
-> Associativity
-> Maybe (AExpr, OperatorDetails, AExpr)
forall {p}.
p
-> (AExpr -> AExpr -> AExpr)
-> Int
-> Associativity
-> Maybe (AExpr, OperatorDetails, AExpr)
details
          (MathOp -> SymbolicExprBinOp
PGT_AST.MathSymbolicExprBinOp MathOp
mathOp)
          ( \AExpr
l' AExpr
r' -> AExpr -> SymbolicExprBinOp -> AExpr -> AExpr
PGT_AST.SymbolicBinOpAExpr AExpr
l' (MathOp -> SymbolicExprBinOp
PGT_AST.MathSymbolicExprBinOp MathOp
mathOp) AExpr
r'
          )
          Int
prec
          Associativity
assoc
    in
      case SymbolicExprBinOp
symOp of
        PGT_AST.MathSymbolicExprBinOp MathOp
PGT_AST.ArrowUpMathOp -> MathOp
-> Int -> Associativity -> Maybe (AExpr, OperatorDetails, AExpr)
mathDetails MathOp
PGT_AST.ArrowUpMathOp Int
8 Associativity
LeftAssoc
        -- \^ (exponentiation)
        PGT_AST.MathSymbolicExprBinOp MathOp
op
          | MathOp
op MathOp -> [MathOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [MathOp
PGT_AST.AsteriskMathOp, MathOp
PGT_AST.SlashMathOp, MathOp
PGT_AST.PercentMathOp] ->
              MathOp
-> Int -> Associativity -> Maybe (AExpr, OperatorDetails, AExpr)
mathDetails MathOp
op Int
7 Associativity
LeftAssoc
        -- \* / %
        PGT_AST.MathSymbolicExprBinOp MathOp
op
          | MathOp
op MathOp -> [MathOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [MathOp
PGT_AST.PlusMathOp, MathOp
PGT_AST.MinusMathOp] ->
              MathOp
-> Int -> Associativity -> Maybe (AExpr, OperatorDetails, AExpr)
mathDetails MathOp
op Int
6 Associativity
LeftAssoc -- binary + -
        PGT_AST.MathSymbolicExprBinOp MathOp
op -- Comparisons
          | MathOp
op
              MathOp -> [MathOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ MathOp
PGT_AST.ArrowLeftMathOp
                     , MathOp
PGT_AST.ArrowRightMathOp
                     , MathOp
PGT_AST.EqualsMathOp
                     , MathOp
PGT_AST.LessEqualsMathOp
                     , MathOp
PGT_AST.GreaterEqualsMathOp
                     , MathOp
PGT_AST.ArrowLeftArrowRightMathOp
                     , MathOp
PGT_AST.ExclamationEqualsMathOp
                     ] ->
              MathOp
-> Int -> Associativity -> Maybe (AExpr, OperatorDetails, AExpr)
mathDetails MathOp
op Int
3 Associativity
LeftAssoc -- < > = <= >= <> !=
        PGT_AST.QualSymbolicExprBinOp QualOp
qualOp ->
          -- User-defined operators, bitwise, etc.
          SymbolicExprBinOp
-> (AExpr -> AExpr -> AExpr)
-> Int
-> Associativity
-> Maybe (AExpr, OperatorDetails, AExpr)
forall {p}.
p
-> (AExpr -> AExpr -> AExpr)
-> Int
-> Associativity
-> Maybe (AExpr, OperatorDetails, AExpr)
details
            (QualOp -> SymbolicExprBinOp
PGT_AST.QualSymbolicExprBinOp QualOp
qualOp)
            ( \AExpr
l' AExpr
r' -> AExpr -> SymbolicExprBinOp -> AExpr -> AExpr
PGT_AST.SymbolicBinOpAExpr AExpr
l' (QualOp -> SymbolicExprBinOp
PGT_AST.QualSymbolicExprBinOp QualOp
qualOp) AExpr
r'
            )
            Int
5
            Associativity
LeftAssoc
        SymbolicExprBinOp
_ -> Maybe (AExpr, OperatorDetails, AExpr)
forall a. Maybe a
Nothing -- Should be exhaustive for PGT_AST.MathSymbolicExprBinOp if it's a binary op
  PGT_AST.AndAExpr AExpr
l AExpr
r -> (AExpr, OperatorDetails, AExpr)
-> Maybe (AExpr, OperatorDetails, AExpr)
forall a. a -> Maybe a
Just (AExpr
l, (AExpr -> AExpr -> AExpr)
-> Int -> Associativity -> OperatorDetails
OperatorDetails AExpr -> AExpr -> AExpr
PGT_AST.AndAExpr Int
2 Associativity
LeftAssoc, AExpr
r) -- AND (precedence 2 in PG docs example)
  PGT_AST.OrAExpr AExpr
l AExpr
r -> (AExpr, OperatorDetails, AExpr)
-> Maybe (AExpr, OperatorDetails, AExpr)
forall a. a -> Maybe a
Just (AExpr
l, (AExpr -> AExpr -> AExpr)
-> Int -> Associativity -> OperatorDetails
OperatorDetails AExpr -> AExpr -> AExpr
PGT_AST.OrAExpr Int
1 Associativity
LeftAssoc, AExpr
r) -- OR (precedence 1 in PG docs example)
  PGT_AST.VerbalExprBinOpAExpr AExpr
l Bool
notOp VerbalExprBinOp
verbalOp AExpr
r Maybe AExpr
mEscape ->
    -- LIKE, ILIKE, SIMILAR TO
    (AExpr, OperatorDetails, AExpr)
-> Maybe (AExpr, OperatorDetails, AExpr)
forall a. a -> Maybe a
Just
      ( AExpr
l
      , (AExpr -> AExpr -> AExpr)
-> Int -> Associativity -> OperatorDetails
OperatorDetails
          (\AExpr
l' AExpr
r' -> AExpr -> Bool -> VerbalExprBinOp -> AExpr -> Maybe AExpr -> AExpr
PGT_AST.VerbalExprBinOpAExpr AExpr
l' Bool
notOp VerbalExprBinOp
verbalOp AExpr
r' Maybe AExpr
mEscape)
          Int
3
          Associativity
LeftAssoc
      , AExpr
r -- Same as comparisons
      )
  PGT_AST.ReversableOpAExpr AExpr
l Bool
notOp (PGT_AST.DistinctFromAExprReversableOp AExpr
r) ->
    -- IS DISTINCT FROM
    (AExpr, OperatorDetails, AExpr)
-> Maybe (AExpr, OperatorDetails, AExpr)
forall a. a -> Maybe a
Just
      ( AExpr
l
      , (AExpr -> AExpr -> AExpr)
-> Int -> Associativity -> OperatorDetails
OperatorDetails
          ( \AExpr
l' AExpr
r' ->
              AExpr -> Bool -> AExprReversableOp -> AExpr
PGT_AST.ReversableOpAExpr AExpr
l' Bool
notOp (AExpr -> AExprReversableOp
PGT_AST.DistinctFromAExprReversableOp AExpr
r')
          )
          Int
3
          Associativity
LeftAssoc
      , AExpr
r -- Same as =
      )
  AExpr
_ -> Maybe (AExpr, OperatorDetails, AExpr)
forall a. Maybe a
Nothing


-- | Rearranges the AExpr syntax tree to account for operator precedence.
fixOperatorPrecedence :: PGT_AST.AExpr -> PGT_AST.AExpr
fixOperatorPrecedence :: AExpr -> AExpr
fixOperatorPrecedence = AExpr -> AExpr
go
  where
    go :: AExpr -> AExpr
go AExpr
expr =
      case AExpr -> Maybe (AExpr, OperatorDetails, AExpr)
getOperatorDetails AExpr
expr of
        Just (AExpr
l1, OperatorDetails
op1Details, AExpr
r1) ->
          let
            l1Fixed :: AExpr
l1Fixed = AExpr -> AExpr
go AExpr
l1
            r1Fixed :: AExpr
r1Fixed = AExpr -> AExpr
go AExpr
r1
            currentOpConstructor :: AExpr -> AExpr -> AExpr
currentOpConstructor = OperatorDetails -> AExpr -> AExpr -> AExpr
odConstructor OperatorDetails
op1Details
            currentPrecedence :: Int
currentPrecedence = OperatorDetails -> Int
odPrecedence OperatorDetails
op1Details
            currentAssociativity :: Associativity
currentAssociativity = OperatorDetails -> Associativity
odAssociativity OperatorDetails
op1Details
          in
            case AExpr -> Maybe (AExpr, OperatorDetails, AExpr)
getOperatorDetails AExpr
r1Fixed of
              Just (AExpr
l2, OperatorDetails
op2Details, AExpr
r2) ->
                let
                  -- We have effectively: l1Fixed `op1` (l2 `op2` r2)
                  -- l2 is the left child of the (potentially restructured) r1Fixed
                  -- r2 is the right child of the (potentially restructured) r1Fixed
                  innerOpConstructor :: AExpr -> AExpr -> AExpr
innerOpConstructor = OperatorDetails -> AExpr -> AExpr -> AExpr
odConstructor OperatorDetails
op2Details
                  innerPrecedence :: Int
innerPrecedence = OperatorDetails -> Int
odPrecedence OperatorDetails
op2Details
                in
                  -- innerAssociativity = odAssociativity op2Details -- Not used in this branch's logic directly

                  if Int
currentPrecedence Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
innerPrecedence
                    Bool -> Bool -> Bool
|| (Int
currentPrecedence Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
innerPrecedence Bool -> Bool -> Bool
&& Associativity
currentAssociativity Associativity -> Associativity -> Bool
forall a. Eq a => a -> a -> Bool
== Associativity
RightAssoc)
                    then
                      -- op2 binds tighter, or op1 is right-associative with same precedence.
                      -- Structure l1Fixed `op1` (l2 `op2` r2) is correct.
                      AExpr -> AExpr -> AExpr
currentOpConstructor AExpr
l1Fixed AExpr
r1Fixed
                    else
                      -- op1 binds tighter, or op1 is left-associative with same precedence.
                      -- We need to rotate to form: (l1Fixed `op1` l2) `op2` r2
                      let
                        newLeftChild :: AExpr
newLeftChild = AExpr -> AExpr -> AExpr
currentOpConstructor AExpr
l1Fixed AExpr
l2
                      in
                        AExpr -> AExpr
go (AExpr -> AExpr -> AExpr
innerOpConstructor AExpr
newLeftChild AExpr
r2) -- Recursively fix the new structure
              Maybe (AExpr, OperatorDetails, AExpr)
Nothing ->
                -- Right child r1Fixed is not a binary operator we're rebalancing.
                -- The structure l1Fixed `op1` r1Fixed is locally correct.
                AExpr -> AExpr -> AExpr
currentOpConstructor AExpr
l1Fixed AExpr
r1Fixed
        Maybe (AExpr, OperatorDetails, AExpr)
Nothing ->
          -- Current expression `expr` is not a binary operator handled by getOperatorDetails,
          -- or it's an atom. Recursively fix its children.
          case AExpr
expr of
            PGT_AST.CExprAExpr CExpr
c -> CExpr -> AExpr
PGT_AST.CExprAExpr CExpr
c -- CExprs are atoms or structured (FuncCExpr, CaseCExpr etc.)
            PGT_AST.TypecastAExpr AExpr
e Typename
t -> AExpr -> Typename -> AExpr
PGT_AST.TypecastAExpr (AExpr -> AExpr
go AExpr
e) Typename
t
            PGT_AST.CollateAExpr AExpr
e AnyName
c -> AExpr -> AnyName -> AExpr
PGT_AST.CollateAExpr (AExpr -> AExpr
go AExpr
e) AnyName
c
            PGT_AST.AtTimeZoneAExpr AExpr
e1 AExpr
e2 -> AExpr -> AExpr -> AExpr
PGT_AST.AtTimeZoneAExpr (AExpr -> AExpr
go AExpr
e1) (AExpr -> AExpr
go AExpr
e2)
            PGT_AST.PlusAExpr AExpr
e -> AExpr -> AExpr
PGT_AST.PlusAExpr (AExpr -> AExpr
go AExpr
e) -- Unary plus
            -- MinusAExpr is handled by fixOperatorPrecedence if it's part of a binary op,
            -- otherwise it's a unary negate.
            PGT_AST.MinusAExpr AExpr
e -> AExpr -> AExpr
PGT_AST.MinusAExpr (AExpr -> AExpr
go AExpr
e)
            PGT_AST.PrefixQualOpAExpr QualOp
op AExpr
e -> QualOp -> AExpr -> AExpr
PGT_AST.PrefixQualOpAExpr QualOp
op (AExpr -> AExpr
go AExpr
e)
            PGT_AST.SuffixQualOpAExpr AExpr
e QualOp
op -> AExpr -> QualOp -> AExpr
PGT_AST.SuffixQualOpAExpr (AExpr -> AExpr
go AExpr
e) QualOp
op
            PGT_AST.NotAExpr AExpr
e -> AExpr -> AExpr
PGT_AST.NotAExpr (AExpr -> AExpr
go AExpr
e)
            PGT_AST.ReversableOpAExpr AExpr
e Bool
notFlag AExprReversableOp
revOp ->
              let
                eFixed :: AExpr
eFixed = AExpr -> AExpr
go AExpr
e
              in
                case AExprReversableOp
revOp of
                  PGT_AST.DistinctFromAExprReversableOp{} -> AExpr
expr -- Should have been caught by getOperatorDetails
                  PGT_AST.BetweenAExprReversableOp Bool
symm BExpr
bExpr AExpr
aExpr ->
                    AExpr -> Bool -> AExprReversableOp -> AExpr
PGT_AST.ReversableOpAExpr
                      AExpr
eFixed
                      Bool
notFlag
                      (Bool -> BExpr -> AExpr -> AExprReversableOp
PGT_AST.BetweenAExprReversableOp Bool
symm (BExpr -> BExpr
goBExpr BExpr
bExpr) (AExpr -> AExpr
go AExpr
aExpr))
                  PGT_AST.InAExprReversableOp InExpr
inExpr ->
                    AExpr -> Bool -> AExprReversableOp -> AExpr
PGT_AST.ReversableOpAExpr
                      AExpr
eFixed
                      Bool
notFlag
                      (InExpr -> AExprReversableOp
PGT_AST.InAExprReversableOp (InExpr -> InExpr
goInExpr InExpr
inExpr))
                  AExprReversableOp
_ -> AExpr -> Bool -> AExprReversableOp -> AExpr
PGT_AST.ReversableOpAExpr AExpr
eFixed Bool
notFlag AExprReversableOp
revOp -- For IS NULL, IS TRUE etc.
            PGT_AST.IsnullAExpr AExpr
e -> AExpr -> AExpr
PGT_AST.IsnullAExpr (AExpr -> AExpr
go AExpr
e)
            PGT_AST.NotnullAExpr AExpr
e -> AExpr -> AExpr
PGT_AST.NotnullAExpr (AExpr -> AExpr
go AExpr
e)
            PGT_AST.OverlapsAExpr Row
row1 Row
row2 -> Row -> Row -> AExpr
PGT_AST.OverlapsAExpr (Row -> Row
goRow Row
row1) (Row -> Row
goRow Row
row2)
            PGT_AST.SubqueryAExpr AExpr
e SubqueryOp
op SubType
st Either SelectWithParens AExpr
sub ->
              AExpr
-> SubqueryOp -> SubType -> Either SelectWithParens AExpr -> AExpr
PGT_AST.SubqueryAExpr
                (AExpr -> AExpr
go AExpr
e)
                SubqueryOp
op
                SubType
st
                ((SelectWithParens -> Either SelectWithParens AExpr)
-> (AExpr -> Either SelectWithParens AExpr)
-> Either SelectWithParens AExpr
-> Either SelectWithParens AExpr
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (SelectWithParens -> Either SelectWithParens AExpr
forall a b. a -> Either a b
Left (SelectWithParens -> Either SelectWithParens AExpr)
-> (SelectWithParens -> SelectWithParens)
-> SelectWithParens
-> Either SelectWithParens AExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SelectWithParens -> SelectWithParens
goSelectWithParens) (AExpr -> Either SelectWithParens AExpr
forall a b. b -> Either a b
Right (AExpr -> Either SelectWithParens AExpr)
-> (AExpr -> AExpr) -> AExpr -> Either SelectWithParens AExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AExpr -> AExpr
go) Either SelectWithParens AExpr
sub)
            PGT_AST.UniqueAExpr SelectWithParens
s -> SelectWithParens -> AExpr
PGT_AST.UniqueAExpr (SelectWithParens -> SelectWithParens
goSelectWithParens SelectWithParens
s)
            AExpr
PGT_AST.DefaultAExpr -> AExpr
PGT_AST.DefaultAExpr
            AExpr
_ -> AExpr
expr -- Leaf node or unhandled construct
    goBExpr :: PGT_AST.BExpr -> PGT_AST.BExpr
    goBExpr :: BExpr -> BExpr
goBExpr = \case
      PGT_AST.CExprBExpr CExpr
c -> CExpr -> BExpr
PGT_AST.CExprBExpr CExpr
c
      PGT_AST.TypecastBExpr BExpr
be Typename
t -> BExpr -> Typename -> BExpr
PGT_AST.TypecastBExpr (BExpr -> BExpr
goBExpr BExpr
be) Typename
t
      PGT_AST.PlusBExpr BExpr
be -> BExpr -> BExpr
PGT_AST.PlusBExpr (BExpr -> BExpr
goBExpr BExpr
be)
      PGT_AST.MinusBExpr BExpr
be -> BExpr -> BExpr
PGT_AST.MinusBExpr (BExpr -> BExpr
goBExpr BExpr
be)
      -- BExpr's own binary ops are typically higher precedence than AExpr's,
      -- but for completeness, one could define getOperatorDetails for BExpr too.
      -- For now, just recurse.
      PGT_AST.SymbolicBinOpBExpr BExpr
l SymbolicExprBinOp
op BExpr
r -> BExpr -> SymbolicExprBinOp -> BExpr -> BExpr
PGT_AST.SymbolicBinOpBExpr (BExpr -> BExpr
goBExpr BExpr
l) SymbolicExprBinOp
op (BExpr -> BExpr
goBExpr BExpr
r)
      PGT_AST.QualOpBExpr QualOp
op BExpr
be -> QualOp -> BExpr -> BExpr
PGT_AST.QualOpBExpr QualOp
op (BExpr -> BExpr
goBExpr BExpr
be)
      PGT_AST.IsOpBExpr BExpr
be Bool
notFlag BExprIsOp
isOp ->
        let
          beFixed :: BExpr
beFixed = BExpr -> BExpr
goBExpr BExpr
be
        in
          case BExprIsOp
isOp of
            PGT_AST.DistinctFromBExprIsOp BExpr
b ->
              BExpr -> Bool -> BExprIsOp -> BExpr
PGT_AST.IsOpBExpr BExpr
beFixed Bool
notFlag (BExpr -> BExprIsOp
PGT_AST.DistinctFromBExprIsOp (BExpr -> BExpr
goBExpr BExpr
b))
            BExprIsOp
_ -> BExpr -> Bool -> BExprIsOp -> BExpr
PGT_AST.IsOpBExpr BExpr
beFixed Bool
notFlag BExprIsOp
isOp

    goRow :: PGT_AST.Row -> PGT_AST.Row
    goRow :: Row -> Row
goRow = \case
      PGT_AST.ExplicitRowRow ExplicitRow
mExprs -> ExplicitRow -> Row
PGT_AST.ExplicitRowRow ((TypeModifiers -> TypeModifiers) -> ExplicitRow -> ExplicitRow
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AExpr -> AExpr) -> TypeModifiers -> TypeModifiers
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map AExpr -> AExpr
go) ExplicitRow
mExprs)
      PGT_AST.ImplicitRowRow (PGT_AST.ImplicitRow TypeModifiers
exprs AExpr
aexpr) -> ImplicitRow -> Row
PGT_AST.ImplicitRowRow (TypeModifiers -> AExpr -> ImplicitRow
PGT_AST.ImplicitRow ((AExpr -> AExpr) -> TypeModifiers -> TypeModifiers
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map AExpr -> AExpr
go TypeModifiers
exprs) (AExpr -> AExpr
go AExpr
aexpr))

    goSelectWithParens :: PGT_AST.SelectWithParens -> PGT_AST.SelectWithParens
    goSelectWithParens :: SelectWithParens -> SelectWithParens
goSelectWithParens = SelectWithParens -> SelectWithParens
forall a. a -> a
id -- Placeholder: A full traversal would be needed.
    goInExpr :: PGT_AST.InExpr -> PGT_AST.InExpr
    goInExpr :: InExpr -> InExpr
goInExpr = \case
      PGT_AST.SelectInExpr SelectWithParens
s -> SelectWithParens -> InExpr
PGT_AST.SelectInExpr (SelectWithParens -> SelectWithParens
goSelectWithParens SelectWithParens
s)
      PGT_AST.ExprListInExpr TypeModifiers
exprs -> TypeModifiers -> InExpr
PGT_AST.ExprListInExpr ((AExpr -> AExpr) -> TypeModifiers -> TypeModifiers
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map AExpr -> AExpr
go TypeModifiers
exprs)


renderPGTAExpr :: PGT_AST.AExpr -> Q Exp
renderPGTAExpr :: AExpr -> Q Exp
renderPGTAExpr AExpr
astExpr = case AExpr -> AExpr
fixOperatorPrecedence AExpr
astExpr of
  PGT_AST.CExprAExpr CExpr
cExpr -> CExpr -> Q Exp
renderPGTCExpr CExpr
cExpr
  PGT_AST.TypecastAExpr AExpr
aExpr Typename
typename -> do
    tnExp <- Typename -> Q Exp
renderPGTTypename Typename
typename
    aExp <- renderPGTAExpr aExpr
    pure $ VarE 'S.cast `AppE` tnExp `AppE` aExp
  PGT_AST.SymbolicBinOpAExpr AExpr
left SymbolicExprBinOp
op AExpr
right -> do
    lExp <- AExpr -> Q Exp
renderPGTAExpr AExpr
left
    rExp <- renderPGTAExpr right
    squealOpExp <-
      case op of
        PGT_AST.MathSymbolicExprBinOp MathOp
mathOp -> 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
$ MathOp -> Exp
renderPGTMathOp MathOp
mathOp
        PGT_AST.QualSymbolicExprBinOp QualOp
qualOp -> 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
$ QualOp -> Exp
renderPGTQualOp QualOp
qualOp
    pure (squealOpExp `AppE` lExp `AppE` rExp)
  PGT_AST.PrefixQualOpAExpr QualOp
op AExpr
expr -> do
    let
      opExp' :: Exp
opExp' = QualOp -> Exp
renderPGTQualOp QualOp
op
    eExp' <- AExpr -> Q Exp
renderPGTAExpr AExpr
expr
    pure (opExp' `AppE` eExp')
  PGT_AST.AndAExpr AExpr
left AExpr
right -> do
    lExp' <- AExpr -> Q Exp
renderPGTAExpr AExpr
left
    rExp' <- renderPGTAExpr right
    pure (VarE '(S..&&) `AppE` lExp' `AppE` rExp')
  PGT_AST.OrAExpr AExpr
left AExpr
right -> do
    lExp' <- AExpr -> Q Exp
renderPGTAExpr AExpr
left
    rExp' <- renderPGTAExpr right
    pure (VarE '(S..||) `AppE` lExp' `AppE` rExp')
  PGT_AST.NotAExpr AExpr
expr -> do
    eExp' <- AExpr -> Q Exp
renderPGTAExpr AExpr
expr
    pure (VarE 'S.not_ `AppE` eExp')
  PGT_AST.VerbalExprBinOpAExpr AExpr
left Bool
not VerbalExprBinOp
op AExpr
right Maybe AExpr
mEscape -> do
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe AExpr -> Bool
forall a. Maybe a -> Bool
isJust Maybe AExpr
mEscape) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"LIKE with ESCAPE is not supported yet."
    lExp' <- AExpr -> Q Exp
renderPGTAExpr AExpr
left
    rExp' <- renderPGTAExpr right
    baseOpExp <-
      case op of
        VerbalExprBinOp
PGT_AST.LikeVerbalExprBinOp -> 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.like
        VerbalExprBinOp
PGT_AST.IlikeVerbalExprBinOp -> 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.ilike
        VerbalExprBinOp
_ -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported verbal binary operator: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VerbalExprBinOp -> [Char]
forall a. Show a => a -> [Char]
show VerbalExprBinOp
op
    let
      finalOpExp = if Bool
not then Name -> Exp
VarE 'S.not_ Exp -> Exp -> Exp
`AppE` Exp
baseOpExp else Exp
baseOpExp
    pure (finalOpExp `AppE` lExp' `AppE` rExp')
  PGT_AST.ReversableOpAExpr AExpr
expr Bool
not AExprReversableOp
reversableOp -> do
    renderedExpr' <- AExpr -> Q Exp
renderPGTAExpr AExpr
expr
    case reversableOp of
      AExprReversableOp
PGT_AST.NullAExprReversableOp ->
        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
$ (if Bool
not then Name -> Exp
VarE 'S.isNotNull else Name -> Exp
VarE 'S.isNull) Exp -> Exp -> Exp
`AppE` Exp
renderedExpr'
      PGT_AST.BetweenAExprReversableOp Bool
_asymmetric BExpr
bExpr AExpr
andAExpr -> do
        bExp' <- BExpr -> Q Exp
renderPGTBExpr BExpr
bExpr
        aExp' <- renderPGTAExpr andAExpr
        let
          opVar' = if Bool
not then Name -> Exp
VarE 'S.notBetween else Name -> Exp
VarE 'S.between
        pure $ opVar' `AppE` renderedExpr' `AppE` TupE [Just bExp', Just aExp']
      PGT_AST.InAExprReversableOp InExpr
inExpr ->
        let
          opVar' :: Exp
opVar' = if Bool
not then Name -> Exp
VarE 'S.notIn else Name -> Exp
VarE 'S.in_
        in
          case InExpr
inExpr of
            PGT_AST.ExprListInExpr TypeModifiers
exprList -> do
              listExp' <- [Exp] -> Exp
ListE ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AExpr -> Q Exp) -> [AExpr] -> 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 AExpr -> Q Exp
renderPGTAExpr (TypeModifiers -> [AExpr]
forall a. NonEmpty a -> [a]
NE.toList TypeModifiers
exprList)
              pure $ opVar' `AppE` renderedExpr' `AppE` listExp'
            InExpr
_ -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Unsupported IN subquery expression"
      AExprReversableOp
_ -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported reversable operator: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> AExprReversableOp -> [Char]
forall a. Show a => a -> [Char]
show AExprReversableOp
reversableOp
  AExpr
PGT_AST.DefaultAExpr -> 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.Default
  PGT_AST.MinusAExpr AExpr
expr -> do
    -- Unary minus
    eExp' <- AExpr -> Q Exp
renderPGTAExpr AExpr
expr
    let
      zeroExp = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'fromInteger) (Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
0))
    pure (InfixE (Just zeroExp) (VarE '(-)) (Just eExp'))
  AExpr
unsupported -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported AExpr: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> AExpr -> [Char]
forall a. Show a => a -> [Char]
show AExpr
unsupported


renderPGTBExpr :: PGT_AST.BExpr -> Q Exp
renderPGTBExpr :: BExpr -> Q Exp
renderPGTBExpr = \case
  PGT_AST.CExprBExpr CExpr
cExpr -> CExpr -> Q Exp
renderPGTCExpr CExpr
cExpr
  PGT_AST.TypecastBExpr BExpr
bExpr Typename
typename -> do
    tnExp <- Typename -> Q Exp
renderPGTTypename Typename
typename
    bExp <- renderPGTBExpr bExpr
    pure $ VarE 'S.cast `AppE` tnExp `AppE` bExp
  PGT_AST.SymbolicBinOpBExpr BExpr
left SymbolicExprBinOp
op BExpr
right -> do
    lExp <- BExpr -> Q Exp
renderPGTBExpr BExpr
left
    rExp <- renderPGTBExpr right
    squealOpExp <-
      case op of
        PGT_AST.MathSymbolicExprBinOp MathOp
mathOp -> 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
$ MathOp -> Exp
renderPGTMathOp MathOp
mathOp
        PGT_AST.QualSymbolicExprBinOp QualOp
qualOp -> 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
$ QualOp -> Exp
renderPGTQualOp QualOp
qualOp
    pure (squealOpExp `AppE` lExp `AppE` rExp)
  BExpr
unsupported -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported BExpr: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> BExpr -> [Char]
forall a. Show a => a -> [Char]
show BExpr
unsupported


renderPGTCExpr :: PGT_AST.CExpr -> Q Exp
renderPGTCExpr :: CExpr -> Q Exp
renderPGTCExpr = \case
  PGT_AST.AexprConstCExpr AexprConst
aexprConst -> 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
$ AexprConst -> Exp
renderPGTAexprConst AexprConst
aexprConst
  PGT_AST.ColumnrefCExpr Columnref
columnref -> 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
$ Columnref -> Exp
renderPGTColumnref Columnref
columnref
  PGT_AST.ParamCExpr Int
n Maybe Indirection
maybeIndirection -> 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
$
      [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Parameters with indirection (e.g. $1[i]) are not supported."
    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.param Exp -> Type -> Exp
`AppTypeE` TyLit -> Type
LitT (Integer -> TyLit
NumTyLit (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n))
  PGT_AST.InParensCExpr AExpr
expr Maybe Indirection
maybeIndirection -> 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
$
      [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Parenthesized expressions with indirection are not supported."
    AExpr -> Q Exp
renderPGTAExpr AExpr
expr -- Squeal's operator precedence should handle this
  PGT_AST.FuncCExpr FuncExpr
funcExpr -> FuncExpr -> Q Exp
renderPGTFuncExpr FuncExpr
funcExpr
  CExpr
unsupported -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported CExpr: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> CExpr -> [Char]
forall a. Show a => a -> [Char]
show CExpr
unsupported


renderPGTFuncExpr :: PGT_AST.FuncExpr -> Q Exp
renderPGTFuncExpr :: FuncExpr -> Q Exp
renderPGTFuncExpr = \case
  PGT_AST.ApplicationFuncExpr FuncApplication
funcApp Maybe WithinGroupClause
maybeWithinGroup Maybe AExpr
maybeFilter Maybe OverClause
maybeOver -> do
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe WithinGroupClause -> Bool
forall a. Maybe a -> Bool
isJust Maybe WithinGroupClause
maybeWithinGroup) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"WITHIN GROUP clause is not supported."
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe AExpr -> Bool
forall a. Maybe a -> Bool
isJust Maybe AExpr
maybeFilter) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"FILTER clause is not supported."
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe OverClause -> Bool
forall a. Maybe a -> Bool
isJust Maybe OverClause
maybeOver) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"OVER clause is not supported."
    FuncApplication -> Q Exp
renderPGTFuncApplication FuncApplication
funcApp
  PGT_AST.SubexprFuncExpr FuncExprCommonSubexpr
funcCommonSubexpr -> FuncExprCommonSubexpr -> Q Exp
renderPGTFuncExprCommonSubexpr FuncExprCommonSubexpr
funcCommonSubexpr


renderPGTFuncApplication :: PGT_AST.FuncApplication -> Q Exp
renderPGTFuncApplication :: FuncApplication -> Q Exp
renderPGTFuncApplication (PGT_AST.FuncApplication FuncName
funcName Maybe FuncApplicationParams
maybeParams) =
  case FuncName
funcName of
    PGT_AST.IndirectedFuncName{} ->
      [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Functions with indirection (e.g. schema.func) are not supported."
    PGT_AST.TypeFuncName Ident
fident ->
      let
        fnNameStr :: [Char]
fnNameStr = Text -> [Char]
Text.unpack (Ident -> Text
getIdentText Ident
fident)
      in
        case Text -> Text
Text.toLower ([Char] -> Text
Text.pack [Char]
fnNameStr) of
          Text
"inline" ->
            case Maybe FuncApplicationParams
maybeParams of
              Just (PGT_AST.NormalFuncApplicationParams Maybe Bool
_ NonEmpty FuncArgExpr
args Maybe WithinGroupClause
_) ->
                case NonEmpty FuncArgExpr -> [FuncArgExpr]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty FuncArgExpr
args of
                  [ PGT_AST.ExprFuncArgExpr
                      (PGT_AST.CExprAExpr (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref Ident
ident Maybe Indirection
Nothing)))
                    ] -> do
                      let
                        varName :: Name
                        varName :: Name
varName = [Char] -> Name
mkName ([Char] -> Name) -> (Ident -> [Char]) -> Ident -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Text.unpack (Text -> [Char]) -> (Ident -> Text) -> Ident -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
getIdentText (Ident -> Name) -> Ident -> Name
forall a b. (a -> b) -> a -> b
$ Ident
ident
                      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.inline Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
varName
                  [FuncArgExpr]
_ -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline() function expects a single variable argument"
              Maybe FuncApplicationParams
_ -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline() function expects a single variable argument"
          Text
"inline_param" ->
            case Maybe FuncApplicationParams
maybeParams of
              Just (PGT_AST.NormalFuncApplicationParams Maybe Bool
_ NonEmpty FuncArgExpr
args Maybe WithinGroupClause
_) ->
                case NonEmpty FuncArgExpr -> [FuncArgExpr]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty FuncArgExpr
args of
                  [ PGT_AST.ExprFuncArgExpr
                      (PGT_AST.CExprAExpr (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref Ident
ident Maybe Indirection
Nothing)))
                    ] -> do
                      let
                        varName :: Name
                        varName :: Name
varName = [Char] -> Name
mkName ([Char] -> Name) -> (Ident -> [Char]) -> Ident -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Text.unpack (Text -> [Char]) -> (Ident -> Text) -> Ident -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
getIdentText (Ident -> Name) -> Ident -> Name
forall a b. (a -> b) -> a -> b
$ Ident
ident
                      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.inlineParam Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
varName
                  [FuncArgExpr]
_ -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline_param() function expects a single variable argument"
              Maybe FuncApplicationParams
_ -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline_param() function expects a single variable argument"
          Text
otherFnName ->
            let
              squealFn :: Q Exp
              squealFn :: Q Exp
squealFn =
                case Text
otherFnName of
                  Text
"coalesce" -> 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.coalesce
                  Text
"lower" -> 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.lower
                  Text
"char_length" -> 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.charLength
                  Text
"character_length" -> 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.charLength
                  Text
"upper" -> 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.upper
                  Text
"count" -> 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.count -- Special handling for count(*) might be needed
                  Text
"now" -> 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.now
                  Text
_ -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported function: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
fnNameStr
            in
              case Maybe FuncApplicationParams
maybeParams of
                Maybe FuncApplicationParams
Nothing -> Q Exp
squealFn -- No-argument function
                Just FuncApplicationParams
params -> case FuncApplicationParams
params of
                  PGT_AST.NormalFuncApplicationParams Maybe Bool
maybeAllOrDistinct NonEmpty FuncArgExpr
args Maybe WithinGroupClause
maybeSortClause -> do
                    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Bool -> Bool
forall a. Maybe a -> Bool
isJust Maybe Bool
maybeAllOrDistinct) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
                      [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"DISTINCT in function calls is not supported."
                    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe WithinGroupClause -> Bool
forall a. Maybe a -> Bool
isJust Maybe WithinGroupClause
maybeSortClause) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
                      [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"ORDER BY in function calls is not supported."
                    fn <- Q Exp
squealFn
                    argExps <- mapM renderPGTFuncArgExpr (NE.toList args)
                    pure $ foldl' AppE fn argExps
                  FuncApplicationParams
PGT_AST.StarFuncApplicationParams ->
                    -- Specific for count(*)
                    if [Char]
fnNameStr [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"count"
                      then 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.countStar
                      else [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Star argument only supported for COUNT"
                  FuncApplicationParams
_ -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported function parameters structure: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> FuncApplicationParams -> [Char]
forall a. Show a => a -> [Char]
show FuncApplicationParams
params


renderPGTFuncArgExpr :: PGT_AST.FuncArgExpr -> Q Exp
renderPGTFuncArgExpr :: FuncArgExpr -> Q Exp
renderPGTFuncArgExpr = \case
  PGT_AST.ExprFuncArgExpr AExpr
aExpr -> AExpr -> Q Exp
renderPGTAExpr AExpr
aExpr
  FuncArgExpr
_ -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Named or colon-syntax function arguments not supported"


renderPGTFuncExprCommonSubexpr :: PGT_AST.FuncExprCommonSubexpr -> Q Exp
renderPGTFuncExprCommonSubexpr :: FuncExprCommonSubexpr -> Q Exp
renderPGTFuncExprCommonSubexpr = \case
  PGT_AST.CurrentTimestampFuncExprCommonSubexpr (Just Iconst
_) ->
    [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"CURRENT_TIMESTAMP with precision is not supported."
  PGT_AST.CurrentTimestampFuncExprCommonSubexpr Maybe Iconst
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.now -- Or S.currentTimestamp
  FuncExprCommonSubexpr
PGT_AST.CurrentDateFuncExprCommonSubexpr -> 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.currentDate
  PGT_AST.CoalesceFuncExprCommonSubexpr TypeModifiers
exprListNE -> do
    renderedInitExprs <- (AExpr -> Q Exp) -> [AExpr] -> 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 AExpr -> Q Exp
renderPGTAExpr (TypeModifiers -> [AExpr]
forall a. NonEmpty a -> [a]
NE.init TypeModifiers
exprListNE)
    renderedLastExpr <- renderPGTAExpr (NE.last exprListNE)
    pure $ VarE 'S.coalesce `AppE` ListE renderedInitExprs `AppE` renderedLastExpr
  FuncExprCommonSubexpr
e -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported common function subexpression: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> FuncExprCommonSubexpr -> [Char]
forall a. Show a => a -> [Char]
show FuncExprCommonSubexpr
e


renderPGTColumnref :: PGT_AST.Columnref -> Exp
renderPGTColumnref :: Columnref -> Exp
renderPGTColumnref (PGT_AST.Columnref Ident
colId Maybe Indirection
maybeIndirection) =
    case Maybe Indirection
maybeIndirection of
      Maybe Indirection
Nothing -> [Char] -> Exp
LabelE (Text -> [Char]
Text.unpack (Ident -> Text
getIdentText Ident
colId))
      Just Indirection
indirection ->
        let
          base :: Exp
base = [Char] -> Exp
LabelE (Text -> [Char]
Text.unpack (Ident -> Text
getIdentText Ident
colId))
        in
          (Exp -> IndirectionEl -> Exp) -> Exp -> [IndirectionEl] -> 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 -> IndirectionEl -> Exp
applyIndirection Exp
base (Indirection -> [IndirectionEl]
forall a. NonEmpty a -> [a]
NE.toList Indirection
indirection)
  where
    applyIndirection :: Exp -> IndirectionEl -> Exp
applyIndirection Exp
acc = \case
      PGT_AST.AttrNameIndirectionEl Ident
attrName ->
        Name -> Exp
VarE '(S.!) Exp -> Exp -> Exp
`AppE` Exp
acc Exp -> Exp -> Exp
`AppE` [Char] -> Exp
LabelE (Text -> [Char]
Text.unpack (Ident -> Text
getIdentText Ident
attrName))
      IndirectionEl
_ -> [Char] -> Exp
forall a. HasCallStack => [Char] -> a
error [Char]
"Unsupported column reference indirection"


renderPGTAexprConst :: PGT_AST.AexprConst -> Exp
renderPGTAexprConst :: AexprConst -> Exp
renderPGTAexprConst = \case
  PGT_AST.IAexprConst Iconst
n ->
    Name -> Exp
ConE 'S.UnsafeExpression
      Exp -> Exp -> Exp
`AppE` ( Name -> Exp
VarE 'BS8.pack
                 Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE ([Char] -> Lit
StringL (Iconst -> [Char]
forall a. Show a => a -> [Char]
show Iconst
n))
             )
  PGT_AST.FAexprConst Fconst
f ->
    Name -> Exp
ConE 'S.UnsafeExpression
      Exp -> Exp -> Exp
`AppE` ( Name -> Exp
VarE 'BS8.pack
                 Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE ([Char] -> Lit
StringL (Fconst -> [Char]
forall a. Show a => a -> [Char]
show Fconst
f))
             )
  PGT_AST.SAexprConst Text
s ->
    Name -> Exp
VarE 'fromString Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE ([Char] -> Lit
StringL (Text -> [Char]
Text.unpack Text
s))
  PGT_AST.BoolAexprConst Bool
True -> Name -> Exp
VarE 'S.true
  PGT_AST.BoolAexprConst Bool
False -> Name -> Exp
VarE 'S.false
  AexprConst
PGT_AST.NullAexprConst -> Name -> Exp
VarE 'S.null_
  AexprConst
unsupported -> [Char] -> Exp
forall a. HasCallStack => [Char] -> a
error ([Char] -> Exp) -> [Char] -> Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported AexprConst: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> AexprConst -> [Char]
forall a. Show a => a -> [Char]
show AexprConst
unsupported


renderPGTMathOp :: PGT_AST.MathOp -> Exp
renderPGTMathOp :: MathOp -> Exp
renderPGTMathOp = \case
  MathOp
PGT_AST.PlusMathOp -> Name -> Exp
VarE '(+)
  MathOp
PGT_AST.MinusMathOp -> Name -> Exp
VarE '(-)
  MathOp
PGT_AST.AsteriskMathOp -> Name -> Exp
VarE '(*)
  MathOp
PGT_AST.EqualsMathOp -> Name -> Exp
VarE '(S..==)
  MathOp
PGT_AST.ArrowLeftArrowRightMathOp -> Name -> Exp
VarE '(S../=) -- <>
  MathOp
PGT_AST.ExclamationEqualsMathOp -> Name -> Exp
VarE '(S../=) -- !=
  MathOp
PGT_AST.ArrowRightMathOp -> Name -> Exp
VarE '(S..>)
  MathOp
PGT_AST.GreaterEqualsMathOp -> Name -> Exp
VarE '(S..>=)
  MathOp
PGT_AST.ArrowLeftMathOp -> Name -> Exp
VarE '(S..<)
  MathOp
PGT_AST.LessEqualsMathOp -> Name -> Exp
VarE '(S..<=)
  MathOp
_ -> [Char] -> Exp
forall a. HasCallStack => [Char] -> a
error [Char]
"Unsupported math operator"


renderPGTQualOp :: PGT_AST.QualOp -> Exp
renderPGTQualOp :: QualOp -> Exp
renderPGTQualOp = \case
  PGT_AST.OpQualOp Text
opText ->
    case Text -> Text
Text.toLower Text
opText of
      Text
"+" -> Name -> Exp
VarE '(+)
      Text
"-" -> Name -> Exp
VarE '(-)
      Text
"*" -> Name -> Exp
VarE '(*)
      Text
"=" -> Name -> Exp
VarE '(S..==)
      Text
"<>" -> Name -> Exp
VarE '(S../=)
      Text
"!=" -> Name -> Exp
VarE '(S../=)
      Text
">" -> Name -> Exp
VarE '(S..>)
      Text
">=" -> Name -> Exp
VarE '(S..>=)
      Text
"<" -> Name -> Exp
VarE '(S..<)
      Text
"<=" -> Name -> Exp
VarE '(S..<=)
      Text
"and" -> Name -> Exp
VarE '(S..&&)
      Text
"or" -> Name -> Exp
VarE '(S..||)
      Text
"not" -> Name -> Exp
VarE 'S.not_
      Text
"like" -> Name -> Exp
VarE 'S.like
      Text
"ilike" -> Name -> Exp
VarE 'S.ilike
      Text
_ -> [Char] -> Exp
forall a. HasCallStack => [Char] -> a
error ([Char] -> Exp) -> [Char] -> Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported QualOp operator text: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
opText
  PGT_AST.OperatorQualOp AnyOperator
_anyOperator ->
    [Char] -> Exp
forall a. HasCallStack => [Char] -> a
error [Char]
"OPERATOR(any_operator) syntax not supported"


renderPGTTypename :: PGT_AST.Typename -> Q Exp
renderPGTTypename :: Typename -> Q Exp
renderPGTTypename (PGT_AST.Typename Bool
setof SimpleTypename
simpleTypename Bool
nullable Maybe (TypenameArrayDimensions, Bool)
arrayInfo) = do
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
setof (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"SETOF type modifier is not supported."
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nullable (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Nullable type modifier '?' is not supported."
  baseTypeExp <- SimpleTypename -> Q Exp
renderPGTSimpleTypename SimpleTypename
simpleTypename
  case arrayInfo of
    Maybe (TypenameArrayDimensions, Bool)
Nothing -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
baseTypeExp
    Just (TypenameArrayDimensions
dims, Bool
nullableArray) -> do
      Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nullableArray (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Nullable array modifier '?' is not supported."
      Exp -> TypenameArrayDimensions -> Q Exp
renderPGTArrayDimensions Exp
baseTypeExp TypenameArrayDimensions
dims


renderPGTArrayDimensions :: Exp -> PGT_AST.TypenameArrayDimensions -> Q Exp
renderPGTArrayDimensions :: Exp -> TypenameArrayDimensions -> Q Exp
renderPGTArrayDimensions Exp
baseTypeExp = \case
  PGT_AST.BoundsTypenameArrayDimensions ArrayBounds
bounds ->
    -- Squeal's fixarray takes a type-level list of Nats for dimensions.
    -- This is hard to represent directly from parsed integer bounds.
    -- For now, we'll only support 1D arrays if bounds are provided.
    case ArrayBounds -> [Maybe Iconst]
forall a. NonEmpty a -> [a]
NE.toList ArrayBounds
bounds of
      [Just Iconst
dim] ->
        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.fixarray
            Exp -> Type -> Exp
`AppTypeE` TyLit -> Type
LitT (Integer -> TyLit
NumTyLit (Iconst -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Iconst
dim))
            Exp -> Exp -> Exp
`AppE` Exp
baseTypeExp
      [Maybe Iconst
_] -> 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.vararray Exp -> Exp -> Exp
`AppE` Exp
baseTypeExp -- e.g. int[]
      [Maybe Iconst]
_ ->
        [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Multidimensional arrays with explicit bounds not yet supported"
  PGT_AST.ExplicitTypenameArrayDimensions Maybe Iconst
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.vararray Exp -> Exp -> Exp
`AppE` Exp
baseTypeExp -- e.g. sometype ARRAY
  PGT_AST.ExplicitTypenameArrayDimensions (Just Iconst
dim) ->
    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.fixarray
        Exp -> Type -> Exp
`AppTypeE` TyLit -> Type
LitT (Integer -> TyLit
NumTyLit (Iconst -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Iconst
dim))
        Exp -> Exp -> Exp
`AppE` Exp
baseTypeExp -- e.g. sometype ARRAY[N]


renderPGTSimpleTypename :: PGT_AST.SimpleTypename -> Q Exp
renderPGTSimpleTypename :: SimpleTypename -> Q Exp
renderPGTSimpleTypename = \case
  PGT_AST.GenericTypeSimpleTypename
    (PGT_AST.GenericType Ident
typeFnName Maybe (NonEmpty Ident)
attrs ExplicitRow
maybeModifiers) -> do
      Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (NonEmpty Ident) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (NonEmpty Ident)
attrs) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Qualified type names (e.g. schema.my_type) are not supported."
      let
        nameLower :: Text
nameLower = Text -> Text
Text.toLower (Ident -> Text
getIdentText Ident
typeFnName)
        extractLength :: Maybe PGT_AST.TypeModifiers -> Q Integer
        extractLength :: ExplicitRow -> Q Integer
extractLength = \case
          Just
            ((PGT_AST.CExprAExpr (PGT_AST.AexprConstCExpr (PGT_AST.IAexprConst Iconst
n))) NE.:| []) -> Integer -> Q Integer
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Iconst -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Iconst
n)
          Just TypeModifiers
other ->
            [Char] -> Q Integer
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Integer) -> [Char] -> Q Integer
forall a b. (a -> b) -> a -> b
$
              [Char]
"Unsupported type modifier for " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
nameLower [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> TypeModifiers -> [Char]
forall a. Show a => a -> [Char]
show TypeModifiers
other
          ExplicitRow
Nothing ->
            [Char] -> Q Integer
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Integer) -> [Char] -> Q Integer
forall a b. (a -> b) -> a -> b
$
              [Char]
"Type "
                [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
nameLower
                [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" requires a length argument (e.g., "
                [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
nameLower
                [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"(N))."

        extractLengthOrDefault :: Integer -> Maybe PGT_AST.TypeModifiers -> Q Integer
        extractLengthOrDefault :: Integer -> ExplicitRow -> Q Integer
extractLengthOrDefault Integer
def = \case
          Just
            ((PGT_AST.CExprAExpr (PGT_AST.AexprConstCExpr (PGT_AST.IAexprConst Iconst
n))) NE.:| []) -> Integer -> Q Integer
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Iconst -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Iconst
n)
          Just TypeModifiers
other ->
            [Char] -> Q Integer
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Integer) -> [Char] -> Q Integer
forall a b. (a -> b) -> a -> b
$
              [Char]
"Unsupported type modifier for " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
nameLower [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> TypeModifiers -> [Char]
forall a. Show a => a -> [Char]
show TypeModifiers
other
          ExplicitRow
Nothing -> Integer -> Q Integer
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
def
      case Text
nameLower of
        Text
"char" -> do
          len <- Integer -> ExplicitRow -> Q Integer
extractLengthOrDefault Integer
1 ExplicitRow
maybeModifiers
          pure $ VarE 'S.char `AppTypeE` LitT (NumTyLit len)
        Text
"character" -> do
          len <- Integer -> ExplicitRow -> Q Integer
extractLengthOrDefault Integer
1 ExplicitRow
maybeModifiers
          pure $ VarE 'S.character `AppTypeE` LitT (NumTyLit len)
        Text
"varchar" -> case ExplicitRow
maybeModifiers of
          ExplicitRow
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.text -- varchar without length is text
          Just TypeModifiers
_ -> do
            len <- ExplicitRow -> Q Integer
extractLength ExplicitRow
maybeModifiers
            pure $ VarE 'S.varchar `AppTypeE` LitT (NumTyLit len)
        Text
"character varying" -> case ExplicitRow
maybeModifiers of
          ExplicitRow
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.text -- character varying without length is text
          Just TypeModifiers
_ -> do
            len <- ExplicitRow -> Q Integer
extractLength ExplicitRow
maybeModifiers
            pure $ VarE 'S.characterVarying `AppTypeE` LitT (NumTyLit len)
        Text
"bool" -> 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.bool
        Text
"int2" -> 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.int2
        Text
"smallint" -> 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.smallint
        Text
"int4" -> 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.int4
        Text
"int" -> 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.int
        Text
"integer" -> 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.integer
        Text
"int8" -> 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.int8
        Text
"bigint" -> 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.bigint
        Text
"numeric" -> 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.numeric -- Ignoring precision/scale for now
        Text
"float4" -> 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.float4 -- Ignoring precision for now
        Text
"real" -> 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.real
        Text
"float8" -> 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.float8
        Text
"double precision" -> 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.doublePrecision
        Text
"money" -> 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.money
        Text
"text" -> 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.text
        Text
"bytea" -> 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.bytea
        Text
"timestamp" -> 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.timestamp
        Text
"timestamptz" -> 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.timestamptz
        Text
"timestamp with time zone" -> 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.timestampWithTimeZone
        Text
"date" -> 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.date
        Text
"time" -> 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.time
        Text
"timetz" -> 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.timetz
        Text
"time with time zone" -> 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.timeWithTimeZone
        Text
"interval" -> 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.interval
        Text
"uuid" -> 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.uuid
        Text
"inet" -> 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.inet
        Text
"json" -> 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.json
        Text
"jsonb" -> 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.jsonb
        Text
"tsvector" -> 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.tsvector
        Text
"tsquery" -> 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.tsquery
        Text
"oid" -> 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.oid
        Text
"int4range" -> 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.int4range
        Text
"int8range" -> 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.int8range
        Text
"numrange" -> 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.numrange
        Text
"tsrange" -> 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.tsrange
        Text
"tstzrange" -> 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.tstzrange
        Text
"daterange" -> 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.daterange
        Text
"record" -> 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.record
        Text
other -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported generic type name: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
other
  PGT_AST.NumericSimpleTypename Numeric
numeric -> Numeric -> Q Exp
renderPGTNumeric Numeric
numeric
  PGT_AST.BitSimpleTypename (PGT_AST.Bit Bool
_varying ExplicitRow
_maybeLength) ->
    -- PostgreSQL's BIT type without length is BIT(1). BIT VARYING without length is unlimited.
    -- Squeal's `char` and `varchar` are for text, not bit strings.
    -- Squeal does not have a direct equivalent for PG bit string types yet.
    -- Potentially map to bytea or text, or add new Squeal types. For now, error.
    [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail
      [Char]
"BIT and BIT VARYING types are not directly supported by Squeal's `char`/`varchar` like types. Consider using bytea or text, or a custom Squeal type."
  PGT_AST.CharacterSimpleTypename Character
charTypeAst ->
    case Character
charTypeAst of
      PGT_AST.CharacterCharacter Bool
False -> 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.character Exp -> Type -> Exp
`AppTypeE` TyLit -> Type
LitT (Integer -> TyLit
NumTyLit Integer
1) -- SQL CHARACTER -> Squeal character(1)
      PGT_AST.CharacterCharacter Bool
True -> 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.text -- SQL CHARACTER VARYING -> Squeal text
      PGT_AST.CharCharacter Bool
False -> 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.char Exp -> Type -> Exp
`AppTypeE` TyLit -> Type
LitT (Integer -> TyLit
NumTyLit Integer
1) -- SQL CHAR -> Squeal char(1)
      PGT_AST.CharCharacter Bool
True -> 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.text -- SQL CHAR VARYING -> Squeal text
      Character
PGT_AST.VarcharCharacter -> 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.text -- SQL VARCHAR (no length) -> Squeal text
      -- National character types are often aliases for standard character types in PostgreSQL
      PGT_AST.NationalCharacterCharacter Bool
False -> 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.character Exp -> Type -> Exp
`AppTypeE` TyLit -> Type
LitT (Integer -> TyLit
NumTyLit Integer
1) -- NCHAR -> character(1)
      PGT_AST.NationalCharacterCharacter Bool
True -> 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.text -- NCHAR VARYING -> text
      PGT_AST.NationalCharCharacter Bool
False -> 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.char Exp -> Type -> Exp
`AppTypeE` TyLit -> Type
LitT (Integer -> TyLit
NumTyLit Integer
1) -- NATIONAL CHAR -> char(1)
      PGT_AST.NationalCharCharacter Bool
True -> 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.text -- NATIONAL CHAR VARYING -> text
      PGT_AST.NcharCharacter Bool
False -> 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.char Exp -> Type -> Exp
`AppTypeE` TyLit -> Type
LitT (Integer -> TyLit
NumTyLit Integer
1) -- NCHAR (synonym for NATIONAL CHAR) -> char(1)
      PGT_AST.NcharCharacter Bool
True -> 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.text -- NCHAR VARYING -> text
  PGT_AST.ConstDatetimeSimpleTypename ConstDatetime
dt -> case ConstDatetime
dt of
    PGT_AST.TimestampConstDatetime Maybe Iconst
precision Maybe Bool
maybeTimezone -> do
      Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Iconst -> Bool
forall a. Maybe a -> Bool
isJust Maybe Iconst
precision) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"TIMESTAMP with precision is not supported."
      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
$ case Maybe Bool
maybeTimezone of
        Just Bool
False -> Name -> Exp
VarE 'S.timestampWithTimeZone -- WITH TIME ZONE
        Maybe Bool
_ -> Name -> Exp
VarE 'S.timestamp -- WITHOUT TIME ZONE or unspecified
    PGT_AST.TimeConstDatetime Maybe Iconst
precision Maybe Bool
maybeTimezone -> do
      Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Iconst -> Bool
forall a. Maybe a -> Bool
isJust Maybe Iconst
precision) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"TIME with precision is not supported."
      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
$ case Maybe Bool
maybeTimezone of
        Just Bool
False -> Name -> Exp
VarE 'S.timeWithTimeZone -- WITH TIME ZONE
        Maybe Bool
_ -> Name -> Exp
VarE 'S.time -- WITHOUT TIME ZONE or unspecified
  PGT_AST.ConstIntervalSimpleTypename (Left (Just Interval
_)) ->
    [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"INTERVAL with qualifiers is not supported."
  PGT_AST.ConstIntervalSimpleTypename (Left Maybe Interval
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.interval
  PGT_AST.ConstIntervalSimpleTypename (Right Iconst
_) ->
    [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"INTERVAL with integer literal is not supported in this context."


renderPGTNumeric :: PGT_AST.Numeric -> Q Exp
renderPGTNumeric :: Numeric -> Q Exp
renderPGTNumeric = \case
  Numeric
PGT_AST.IntNumeric -> 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.int
  Numeric
PGT_AST.IntegerNumeric -> 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.integer
  Numeric
PGT_AST.SmallintNumeric -> 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.smallint
  Numeric
PGT_AST.BigintNumeric -> 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.bigint
  Numeric
PGT_AST.RealNumeric -> 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.real
  PGT_AST.FloatNumeric (Just Iconst
_) -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"FLOAT with precision is not supported."
  PGT_AST.FloatNumeric Maybe Iconst
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.float4
  Numeric
PGT_AST.DoublePrecisionNumeric -> 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.doublePrecision
  PGT_AST.DecimalNumeric (Just TypeModifiers
_) -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"DECIMAL with precision/scale is not supported."
  PGT_AST.DecimalNumeric ExplicitRow
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.numeric
  PGT_AST.DecNumeric (Just TypeModifiers
_) -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"DEC with precision/scale is not supported."
  PGT_AST.DecNumeric ExplicitRow
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.numeric
  PGT_AST.NumericNumeric (Just TypeModifiers
_) -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"NUMERIC with precision/scale is not supported."
  PGT_AST.NumericNumeric ExplicitRow
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.numeric
  Numeric
PGT_AST.BooleanNumeric -> 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.bool


{- |
  Translates the `Targeting` clause of a SQL SELECT statement from the
  `postgresql-syntax` AST (`PGT_AST.Targeting`) into a Squeal representation.
  The `Targeting` clause defines the list of expressions or columns to be
  returned by the query (e.g., `*`, `col1`, `col2 AS alias`, `DISTINCT col3`).

  The function returns a Template Haskell `Q` computation that, when run,
  produces a pair:
  1. `Exp`: A Template Haskell expression representing the Squeal selection list.
     This could be `S.Star` for `SELECT *`, or a constructed Squeal expression
     for a list of target elements (e.g., `expression1 :* expression2 :* S.Nil`).
  2. `Maybe [PGT_AST.AExpr]`: This field is used to pass along the expressions
     from a `DISTINCT ON (expr1, expr2, ...)` clause. If the query uses
     `DISTINCT ON`, this will be `Just` containing the list of `PGT_AST.AExpr`
     nodes representing `expr1, expr2, ...`. For all other types of targeting
     (e.g., `SELECT DISTINCT col`, `SELECT col1, col2`, `SELECT *`), this
     will be `Nothing`.

  The function handles different kinds of targeting:
  - `PGT_AST.NormalTargeting`: Standard `SELECT col1, col2, ...`
  - `PGT_AST.AllTargeting`: `SELECT ALL ...` (often equivalent to normal select or `SELECT *`)
  - `PGT_AST.DistinctTargeting`: `SELECT DISTINCT ...` or `SELECT DISTINCT ON (...) ...`

  Returns (SquealSelectionListExp, Maybe DistinctOnAstExpressions)
-}
renderPGTTargeting
  :: PGT_AST.Targeting
  -> Q (Exp, Maybe [PGT_AST.AExpr])
renderPGTTargeting :: Targeting -> Q (Exp, Maybe [AExpr])
renderPGTTargeting = \case
  PGT_AST.NormalTargeting TargetList
targetList -> do
    selListExp <- TargetList -> Q Exp
renderPGTTargetList TargetList
targetList
    pure (selListExp, Nothing)
  PGT_AST.AllTargeting Maybe TargetList
maybeTargetList -> do
    selListExp <-
      case Maybe TargetList
maybeTargetList of
        Maybe TargetList
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.Star -- SELECT ALL (which is like SELECT *)
        Just TargetList
tl -> TargetList -> Q Exp
renderPGTTargetList TargetList
tl
    pure (selListExp, Nothing)
  PGT_AST.DistinctTargeting ExplicitRow
maybeOnExprs TargetList
targetList -> do
    selListExp <- TargetList -> Q Exp
renderPGTTargetList TargetList
targetList
    pure (selListExp, fmap NE.toList maybeOnExprs)


renderPGTTargetEl :: PGT_AST.TargetEl -> Maybe PGT_AST.Ident -> Int -> Q Exp
renderPGTTargetEl :: TargetEl -> Maybe Ident -> Int -> Q Exp
renderPGTTargetEl TargetEl
targetEl Maybe Ident
mOuterAlias Int
idx =
  let
    (AExpr
exprAST, Maybe Ident
mInternalAlias) = case TargetEl
targetEl of
      PGT_AST.AliasedExprTargetEl AExpr
e Ident
an -> (AExpr
e, Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
an)
      PGT_AST.ImplicitlyAliasedExprTargetEl AExpr
e Ident
an -> (AExpr
e, Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
an)
      PGT_AST.ExprTargetEl AExpr
e -> (AExpr
e, Maybe Ident
forall a. Maybe a
Nothing)
      TargetEl
PGT_AST.AsteriskTargetEl ->
        ( CExpr -> AExpr
PGT_AST.CExprAExpr
            ( AexprConst -> CExpr
PGT_AST.AexprConstCExpr
                AexprConst
PGT_AST.NullAexprConst
            )
        , Maybe Ident
forall a. Maybe a
Nothing -- Placeholder for Star, should be S.Star
        )
    finalAliasName :: Maybe Ident
finalAliasName = Maybe Ident
mOuterAlias Maybe Ident -> Maybe Ident -> Maybe Ident
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Ident
mInternalAlias
  in
    case TargetEl
targetEl of
      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.Star
      TargetEl
_ -> do
        renderedScalarExp <- AExpr -> Q Exp
renderPGTAExpr AExpr
exprAST
        case exprAST of
          PGT_AST.CExprAExpr (PGT_AST.ColumnrefCExpr Columnref
_)
            | Maybe Ident
Nothing <- Maybe Ident
finalAliasName ->
                Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
renderedScalarExp
          AExpr
_ -> do
            let
              aliasLabelStr :: [Char]
aliasLabelStr =
                case Maybe Ident
finalAliasName of
                  Just Ident
ident -> Text -> [Char]
Text.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Ident -> Text
getIdentText Ident
ident
                  Maybe Ident
Nothing -> [Char]
"_col" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
idx
            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
renderedScalarExp
                Exp -> Exp -> Exp
`AppE` [Char] -> Exp
LabelE [Char]
aliasLabelStr


renderPGTTargetList :: PGT_AST.TargetList -> Q Exp
renderPGTTargetList :: TargetList -> Q Exp
renderPGTTargetList (TargetEl
item NE.:| [TargetEl]
items) =
    if [TargetEl] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TargetEl]
items Bool -> Bool -> Bool
&& TargetEl -> Bool
isAsterisk TargetEl
item
      then
        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.Star
      else
        if [TargetEl] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TargetEl]
items Bool -> Bool -> Bool
&& TargetEl -> Bool
isDotStar TargetEl
item
          then
            TargetEl -> Q Exp
renderPGTTargetElDotStar TargetEl
item
          else
            [TargetEl] -> Int -> Q Exp
go (TargetEl
item TargetEl -> [TargetEl] -> [TargetEl]
forall a. a -> [a] -> [a]
: [TargetEl]
items) Int
1
  where
    isAsterisk :: PGT_AST.TargetEl -> Bool
    isAsterisk :: TargetEl -> Bool
isAsterisk TargetEl
PGT_AST.AsteriskTargetEl = Bool
True
    isAsterisk TargetEl
_ = Bool
False

    isDotStar :: PGT_AST.TargetEl -> Bool
    isDotStar :: TargetEl -> Bool
isDotStar
      ( PGT_AST.ExprTargetEl
          ( PGT_AST.CExprAExpr
              (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref Ident
_ (Just Indirection
indirection)))
            )
        ) =
        (IndirectionEl -> Bool) -> [IndirectionEl] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any IndirectionEl -> Bool
isAllIndirectionEl (Indirection -> [IndirectionEl]
forall a. NonEmpty a -> [a]
NE.toList Indirection
indirection)
    isDotStar TargetEl
_ = Bool
False

    isAllIndirectionEl :: PGT_AST.IndirectionEl -> Bool
    isAllIndirectionEl :: IndirectionEl -> Bool
isAllIndirectionEl IndirectionEl
PGT_AST.AllIndirectionEl = Bool
True
    isAllIndirectionEl IndirectionEl
_ = Bool
False

    renderPGTTargetElDotStar :: PGT_AST.TargetEl -> Q Exp
    renderPGTTargetElDotStar :: TargetEl -> Q Exp
renderPGTTargetElDotStar
      ( PGT_AST.ExprTargetEl
          ( PGT_AST.CExprAExpr
              ( PGT_AST.ColumnrefCExpr
                  ( PGT_AST.Columnref
                      Ident
qualName
                      Maybe Indirection
indirectionOpt
                    )
                )
            )
        ) =
        case Maybe Indirection
indirectionOpt of
          Just Indirection
indirection
            | (IndirectionEl -> Bool) -> [IndirectionEl] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any IndirectionEl -> Bool
isAllIndirectionEl (Indirection -> [IndirectionEl]
forall a. NonEmpty a -> [a]
NE.toList Indirection
indirection) ->
                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.DotStar
                    Exp -> Exp -> Exp
`AppE` ([Char] -> Exp
LabelE (Text -> [Char]
Text.unpack (Ident -> Text
getIdentText Ident
qualName)))
          Maybe Indirection
_ ->
            [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$
              [Char]
"renderPGTTargetElDotStar called with non-DotStar "
                [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"TargetEl structure"
    renderPGTTargetElDotStar TargetEl
_ =
      [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"renderPGTTargetElDotStar called with unexpected TargetEl"

    go :: [PGT_AST.TargetEl] -> Int -> Q Exp
    go :: [TargetEl] -> Int -> Q Exp
go [] Int
_ =
      {- Should not happen with NonEmpty input to renderPGTTargetList -}
      [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Empty selection list items in go."
    go [TargetEl
el] Int
currentIdx = TargetEl -> Maybe Ident -> Int -> Q Exp
renderPGTTargetEl TargetEl
el Maybe Ident
forall a. Maybe a
Nothing Int
currentIdx
    go (TargetEl
el : [TargetEl]
more) Int
currentIdx = do
      renderedEl <- TargetEl -> Maybe Ident -> Int -> Q Exp
renderPGTTargetEl TargetEl
el Maybe Ident
forall a. Maybe a
Nothing Int
currentIdx
      if null more
        then pure renderedEl
        else do
          restRendered <- go more (currentIdx + 1)
          pure $ ConE 'S.Also `AppE` restRendered `AppE` renderedEl