squeal-postgresql-qq 0.1.0.0 → 0.1.1.0
raw patch · 9 files changed
+2123/−1680 lines, 9 filesdep ~postgresql-syntaxPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: postgresql-syntax
API changes (from Hackage documentation)
Files
- README.md +122/−0
- squeal-postgresql-qq.cabal +2/−3
- src/Squeal/QuasiQuotes.hs +3/−3
- src/Squeal/QuasiQuotes/Common.hs +0/−986
- src/Squeal/QuasiQuotes/Delete.hs +65/−14
- src/Squeal/QuasiQuotes/Insert.hs +97/−51
- src/Squeal/QuasiQuotes/Query.hs +1601/−566
- src/Squeal/QuasiQuotes/Update.hs +75/−24
- test/test.hs +158/−33
README.md view
@@ -88,3 +88,125 @@ * `WHERE CURRENT OF` for cursors * Complex relation expressions in `UPDATE` or `DELETE` targets * Column indirection in `UPDATE SET` clauses++## Supported features.++This is the output from the test suite, which gives a pretty good+indication of the supported SQL language features.++```+queries+ select * from users [✔]+ select * from public.users [✔]+ SELECT * FROM "users" AS "users" [✔]+ select * from users where name = 'bob' [✔]+ select users.name from users [✔]+ select name from users [✔]+ select count(*) from users group by () [✔]+ select name, id from users [✔]+ select id, name from users [✔]+ select users.id, employee_id from users [✔]+ select users.* from users [✔]+ select users.* from other.users [✔]+ select * from users limit 3 [✔]+ select * from users limit inline(lim) [✔]+ select * from users offset inline(off) [✔]+ select * from users offset 1 [✔]+ select users.id, employee_id as emp_id from users [✔]+ select users.id as user_id, employee_id from users [✔]+ select users.id from users left outer join emails on emails.user_id = users.id [✔]+ select users.id, users.name, emails.email from users left outer join emails on emails.user_id = users.id where emails.email = inline("targetEmail") [✔]+ select 'text_val' [✔]+ select 1 [✔]+ select 1 AS num, 'text_val' AS txt [✔]+ group by+ select name from users group by name [✔]+ select employee_id, count(id) from users group by employee_id [✔]+ select employee_id, name, count(id) from users group by employee_id, name [✔]+ common table expressions+ with users_cte as (select * from users) select * from users_cte [✔]+ with users_cte as (select * from users), emails_cte as (select * from emails) select users_cte.*, emails_cte.email from users_cte join emails_cte on users_cte.id = emails_cte.user_id [✔]+inserts+ insert into emails (id, user_id, email) values (1, 'user-1', 'foo@bar') [✔]+ insert into emails (id, user_id, email) values (1, 'user-1', $1) [✔]+ insert into emails (id, user_id, email) values (1, $2, $1) [✔]+ insert into emails (id, user_id, email) values (inline(i), inline(uid), inline_param(e)) [✔]+ default keyword+ insert into emails (id, user_id, email) values (default, 'foo', 'bar') [✔]+ insert into emails (id, user_id, email) values (deFault, 'foo', 'bar') [✔]+ insert into emails (id, user_id, email) values (DEFAULT, 'foo', 'bar') [✔]+ null keyword+ insert into emails (id, user_id, email) values (DEFAULT, 'foo', null) [✔]+ insert into emails (id, user_id, email) values (DEFAULT, 'foo', NULL) [✔]+ insert into emails (id, user_id, email) values (DEFAULT, 'foo', NuLL) [✔]+ insert ... select ...+ insert into emails select id, user_id, email from emails where id = 1 [✔]+ insert into emails select id, user_id, email from emails where id = $1 [✔]+ insert into users_copy select id, name, bio from users where users.id = 'uid1' [✔]+ returning clause+ insert into emails (id, user_id, email) values (1, 'user-1', 'foo@bar') returning id [✔]+ insert into emails (id, user_id, email) values (1, 'user-1', 'foo@bar') returning * [✔]+ with common table expressions+ with new_user (id, name, bio) as (values ('id_new', 'new_name', 'new_bio')) insert into users_copy select * from new_user [✔]+deletes+ delete from users where true [✔]+ delete from emails where id = 1 [✔]+ delete from emails where email = inline(e) [✔]+ delete from users where id = 'some-id' returning id [✔]+ with common table expressions+ with to_delete as (select id from users where name = 'Alice') delete from users where id in (select to_delete.id from to_delete) [✔]+ with to_delete as (select id from users where name = 'Alice') delete from users using to_delete where users.id = to_delete.id [✔]+updates+ update users set name = 'new name' where id = 'some-id' [✔]+ update users set name = 'new name', bio = 'new bio' where id = 'some-id' [✔]+ update users set name = inline(n) where id = 'some-id' [✔]+ update users set name = 'new name' where id = 'some-id' returning id [✔]+ with common table expressions+ with to_update as (select id from users where name = 'Alice') update users set name = 'Alicia' from to_update where users.id = to_update.id [✔]+scalar expressions+ select users.id != 'no-such-user' as neq from users [✔]+ select * from users where users.id <> 'no-such-user' [✔]+ select * from emails where emails.id > 0 [✔]+ select * from emails where emails.id >= 0 [✔]+ select * from emails where emails.id < 10 [✔]+ select * from emails where emails.id <= 10 [✔]+ select emails.id + 1 as plus_one from emails [✔]+ select emails.id - 1 as minus_one from emails [✔]+ select emails.id * 2 as times_two from emails [✔]+ select * from users where users.id = 'a' and users.name = 'b' [✔]+ select * from users where users.id = 'a' or users.name = 'b' [✔]+ select * from users where users.name like 'A%' [✔]+ select * from users where users.name ilike 'a%' [✔]+ select * from users where not (users.name = 'no-one') [✔]+ select -emails.id as neg_id from emails [✔]+ select * from users where users.bio is null [✔]+ select * from users where users.bio is not null [✔]+ function calls+ select coalesce(users.bio, 'no bio') as bio from users [✔]+ select lower(users.name) as lower_name from users [✔]+ select char_length(users.name) as name_len from users [✔]+ select character_length(users.name) as name_len_alias from users [✔]+ select "upper"(users.name) as upper_name from users [✔]+ select now() as current_time [✔]+ select current_date as today [✔]+ haskell variables in expressions [✔]+ select (emails.id + 1) * 2 as calc from emails [✔]+ select * from users where users.name in ('Alice', 'Bob') [✔]+ select * from users where users.name not in ('Alice', 'Bob') [✔]+ select * from emails where emails.id between 0 and 10 [✔]+ select * from emails where emails.id not between 0 and 10 [✔]+ select (e.id :: text) as casted_id from emails as e [✔]+ select * from users for update [✔]+ select * from jsonb_test [✔]+ select * from json_test [✔]+ select distinct name from users [✔]+ select distinct * from users [✔]+ select distinct on (employee_id) employee_id, name from users [✔]+ select distinct on (employee_id, name) employee_id, name, id from users [✔]+ order by+ select * from users order by name [✔]+ select * from users order by name asc [✔]+ select * from users order by name desc [✔]+ having clause+ select employee_id, count(id) from users group by employee_id having count(id) > 1 [✔]+```
squeal-postgresql-qq.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: squeal-postgresql-qq-version: 0.1.0.0+version: 0.1.1.0 synopsis: QuasiQuoter transforming raw sql into Squeal expressions. -- description: homepage: https://github.com/owensmurray/squeal-postgresql-qq@@ -21,7 +21,7 @@ , base >= 4.18.3.0 && < 4.22 , bytestring >= 0.11.3.0 && < 0.13 , generics-sop >= 0.5.1.3 && < 0.6- , postgresql-syntax >= 0.4 && < 0.5+ , postgresql-syntax >= 0.4.1 && < 0.5 , squeal-postgresql >= 0.9.1.3 && < 0.10 , template-haskell >= 2.20.0.0 && < 2.24 , text >= 1.2.5.0 && < 2.2@@ -41,7 +41,6 @@ exposed-modules: Squeal.QuasiQuotes other-modules:- Squeal.QuasiQuotes.Common Squeal.QuasiQuotes.Delete Squeal.QuasiQuotes.Insert Squeal.QuasiQuotes.Query
src/Squeal/QuasiQuotes.hs view
@@ -22,8 +22,8 @@ ) import Language.Haskell.TH.Syntax (Exp(AppE, VarE), Q, runIO) import Prelude- ( Applicative(pure), Either(Left, Right), MonadFail(fail), Semigroup((<>))- , Show(show), ($), (.), String, error, print+ ( Applicative(pure), Either(Left, Right), Maybe(Nothing), MonadFail(fail)+ , Semigroup((<>)), Show(show), ($), (.), String, error, print ) import Squeal.QuasiQuotes.Delete (toSquealDelete) import Squeal.QuasiQuotes.Insert (toSquealInsert)@@ -161,7 +161,7 @@ toSquealStatement :: PGT_AST.PreparableStmt -> Q Exp toSquealStatement = \case PGT_AST.SelectPreparableStmt theQuery -> do- queryExp <- toSquealQuery theQuery+ queryExp <- toSquealQuery [] Nothing theQuery pure $ VarE 'monoQuery `AppE` queryExp PGT_AST.InsertPreparableStmt stmt -> do manipExp <- toSquealInsert stmt
− src/Squeal/QuasiQuotes/Common.hs
@@ -1,986 +0,0 @@-{-# 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 = \case- PGT_AST.QuotedIdent t -> t- PGT_AST.UnquotedIdent t -> t---renderPGTTableRef :: NE.NonEmpty PGT_AST.TableRef -> Q Exp-renderPGTTableRef tableRefs = do- renderedTableRefs <- mapM renderSingleTableRef (NE.toList tableRefs)- case renderedTableRefs of- [] -> fail "Empty FROM clause" -- Should not happen with NonEmpty- (firstTbl : 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.- pure $ foldl' (\acc tbl -> VarE 'S.also `AppE` tbl `AppE` acc) firstTbl restTbls---renderSingleTableRef :: PGT_AST.TableRef -> Q Exp-renderSingleTableRef = \case- PGT_AST.RelationExprTableRef relationExpr maybeAliasClause sampleClause -> do- when (isJust sampleClause) $ fail "TABLESAMPLE clause is not supported yet."- renderPGTRelationExprTableRef relationExpr maybeAliasClause- PGT_AST.JoinTableRef joinedTable 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 maybeAliasClause of- Just _ ->- fail- "Aliasing a JOIN clause directly is not supported. Consider a subquery: (SELECT * FROM ...) AS alias"- Nothing -> renderPGTJoinedTable joinedTable- -- PGT_AST.InParensTableRefTableRef was an incorrect pattern, removing it.- -- Parenthesized joins are handled by PGT_AST.InParensJoinedTable within renderPGTJoinedTable.- unsupported ->- fail $ "Unsupported TableRef type in renderSingleTableRef: " <> show unsupported---renderPGTJoinedTable :: PGT_AST.JoinedTable -> Q Exp-renderPGTJoinedTable = \case- PGT_AST.InParensJoinedTable joinedTable -> renderPGTJoinedTable joinedTable- PGT_AST.MethJoinedTable joinMeth leftRef rightRef -> do- leftTableExp <- renderSingleTableRef leftRef- rightTableExp <- renderSingleTableRef rightRef- case joinMeth of- PGT_AST.QualJoinMeth maybeJoinType joinQual ->- case joinQual of- PGT_AST.OnJoinQual onConditionAExpr -> do- onConditionExp <- renderPGTAExpr onConditionAExpr- squealJoinFn <-- case maybeJoinType of- Just (PGT_AST.LeftJoinType _) -> pure $ VarE 'S.leftOuterJoin- Just (PGT_AST.RightJoinType _) -> pure $ VarE 'S.rightOuterJoin- Just (PGT_AST.FullJoinType _) -> pure $ VarE 'S.fullOuterJoin- Just PGT_AST.InnerJoinType -> pure $ VarE 'S.innerJoin- Nothing -> pure $ 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 _identsNE ->- fail "USING join qualification not yet supported"- PGT_AST.CrossJoinMeth ->- -- Change: Use S.& for crossJoin: leftTableExp & S.crossJoin rightTableExp- pure $- InfixE- (Just leftTableExp)- (VarE '(S.&))- (Just (VarE 'S.crossJoin `AppE` rightTableExp))- PGT_AST.NaturalJoinMeth _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.- fail "NATURAL JOIN is not supported by Squeal-QQ."---renderPGTRelationExprTableRef- :: PGT_AST.RelationExpr -> Maybe PGT_AST.AliasClause -> Q Exp-renderPGTRelationExprTableRef relationExpr maybeAliasClause = do- tableExpr <-- case relationExpr of- PGT_AST.SimpleRelationExpr qualifiedName isAsterisk -> do- when isAsterisk $ fail "Relation with '*' (e.g. 'table *') is not supported."- renderPGTQualifiedName qualifiedName- PGT_AST.OnlyRelationExpr _qualifiedName _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.- fail "ONLY keyword is not supported."-- aliasStr <-- case maybeAliasClause of- Just (PGT_AST.AliasClause _ aliasIdent _) -> pure $ Text.unpack (getIdentText aliasIdent)- Nothing -> case relationExpr of -- Infer default alias if none provided- PGT_AST.SimpleRelationExpr (PGT_AST.SimpleQualifiedName ident) _ -> pure $ Text.unpack (getIdentText ident)- PGT_AST.SimpleRelationExpr- ( PGT_AST.IndirectedQualifiedName- _- (NE.last -> PGT_AST.AttrNameIndirectionEl ident)- )- _ -> pure $ Text.unpack (getIdentText ident)- _ ->- fail $- "Cannot determine default alias for relation expression: " <> show relationExpr-- pure $ VarE 'S.table `AppE` (VarE 'S.as `AppE` tableExpr `AppE` LabelE aliasStr)---renderPGTQualifiedName :: PGT_AST.QualifiedName -> Q Exp-renderPGTQualifiedName = \case- PGT_AST.SimpleQualifiedName ident -> pure $ LabelE (Text.unpack (getIdentText ident))- PGT_AST.IndirectedQualifiedName- schemaIdent- (PGT_AST.AttrNameIndirectionEl colIdent NE.:| []) ->- -- Assuming schema.table.col- pure $- VarE '(S.!)- `AppE` LabelE (Text.unpack (getIdentText schemaIdent))- `AppE` LabelE (Text.unpack (getIdentText colIdent))- unsupported ->- fail $ "Unsupported qualified name for table reference: " <> show unsupported----- | Defines associativity of an operator.-data Associativity = LeftAssoc | RightAssoc | NonAssoc- deriving stock (Eq, Show)----- | Holds details for a binary operator relevant to precedence restructuring.-data OperatorDetails = OperatorDetails- { odConstructor :: PGT_AST.AExpr -> PGT_AST.AExpr -> PGT_AST.AExpr- , odPrecedence :: Int- , 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 = \case- PGT_AST.SymbolicBinOpAExpr l symOp r ->- let- details _op constr prec assoc = Just (l, OperatorDetails constr prec assoc, r)- mathDetails mathOp prec assoc =- details- (PGT_AST.MathSymbolicExprBinOp mathOp)- ( \l' r' -> PGT_AST.SymbolicBinOpAExpr l' (PGT_AST.MathSymbolicExprBinOp mathOp) r'- )- prec- assoc- in- case symOp of- PGT_AST.MathSymbolicExprBinOp PGT_AST.ArrowUpMathOp -> mathDetails PGT_AST.ArrowUpMathOp 8 LeftAssoc- -- \^ (exponentiation)- PGT_AST.MathSymbolicExprBinOp op- | op `elem` [PGT_AST.AsteriskMathOp, PGT_AST.SlashMathOp, PGT_AST.PercentMathOp] ->- mathDetails op 7 LeftAssoc- -- \* / %- PGT_AST.MathSymbolicExprBinOp op- | op `elem` [PGT_AST.PlusMathOp, PGT_AST.MinusMathOp] ->- mathDetails op 6 LeftAssoc -- binary + -- PGT_AST.MathSymbolicExprBinOp op -- Comparisons- | op- `elem` [ PGT_AST.ArrowLeftMathOp- , PGT_AST.ArrowRightMathOp- , PGT_AST.EqualsMathOp- , PGT_AST.LessEqualsMathOp- , PGT_AST.GreaterEqualsMathOp- , PGT_AST.ArrowLeftArrowRightMathOp- , PGT_AST.ExclamationEqualsMathOp- ] ->- mathDetails op 3 LeftAssoc -- < > = <= >= <> !=- PGT_AST.QualSymbolicExprBinOp qualOp ->- -- User-defined operators, bitwise, etc.- details- (PGT_AST.QualSymbolicExprBinOp qualOp)- ( \l' r' -> PGT_AST.SymbolicBinOpAExpr l' (PGT_AST.QualSymbolicExprBinOp qualOp) r'- )- 5- LeftAssoc- _ -> Nothing -- Should be exhaustive for PGT_AST.MathSymbolicExprBinOp if it's a binary op- PGT_AST.AndAExpr l r -> Just (l, OperatorDetails PGT_AST.AndAExpr 2 LeftAssoc, r) -- AND (precedence 2 in PG docs example)- PGT_AST.OrAExpr l r -> Just (l, OperatorDetails PGT_AST.OrAExpr 1 LeftAssoc, r) -- OR (precedence 1 in PG docs example)- PGT_AST.VerbalExprBinOpAExpr l notOp verbalOp r mEscape ->- -- LIKE, ILIKE, SIMILAR TO- Just- ( l- , OperatorDetails- (\l' r' -> PGT_AST.VerbalExprBinOpAExpr l' notOp verbalOp r' mEscape)- 3- LeftAssoc- , r -- Same as comparisons- )- PGT_AST.ReversableOpAExpr l notOp (PGT_AST.DistinctFromAExprReversableOp r) ->- -- IS DISTINCT FROM- Just- ( l- , OperatorDetails- ( \l' r' ->- PGT_AST.ReversableOpAExpr l' notOp (PGT_AST.DistinctFromAExprReversableOp r')- )- 3- LeftAssoc- , r -- Same as =- )- _ -> Nothing----- | Rearranges the AExpr syntax tree to account for operator precedence.-fixOperatorPrecedence :: PGT_AST.AExpr -> PGT_AST.AExpr-fixOperatorPrecedence = go- where- go expr =- case getOperatorDetails expr of- Just (l1, op1Details, r1) ->- let- l1Fixed = go l1- r1Fixed = go r1- currentOpConstructor = odConstructor op1Details- currentPrecedence = odPrecedence op1Details- currentAssociativity = odAssociativity op1Details- in- case getOperatorDetails r1Fixed of- Just (l2, op2Details, 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 = odConstructor op2Details- innerPrecedence = odPrecedence op2Details- in- -- innerAssociativity = odAssociativity op2Details -- Not used in this branch's logic directly-- if currentPrecedence < innerPrecedence- || (currentPrecedence == innerPrecedence && currentAssociativity == RightAssoc)- then- -- op2 binds tighter, or op1 is right-associative with same precedence.- -- Structure l1Fixed `op1` (l2 `op2` r2) is correct.- currentOpConstructor l1Fixed 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 = currentOpConstructor l1Fixed l2- in- go (innerOpConstructor newLeftChild r2) -- Recursively fix the new structure- Nothing ->- -- Right child r1Fixed is not a binary operator we're rebalancing.- -- The structure l1Fixed `op1` r1Fixed is locally correct.- currentOpConstructor l1Fixed r1Fixed- Nothing ->- -- Current expression `expr` is not a binary operator handled by getOperatorDetails,- -- or it's an atom. Recursively fix its children.- case expr of- PGT_AST.CExprAExpr c -> PGT_AST.CExprAExpr c -- CExprs are atoms or structured (FuncCExpr, CaseCExpr etc.)- PGT_AST.TypecastAExpr e t -> PGT_AST.TypecastAExpr (go e) t- PGT_AST.CollateAExpr e c -> PGT_AST.CollateAExpr (go e) c- PGT_AST.AtTimeZoneAExpr e1 e2 -> PGT_AST.AtTimeZoneAExpr (go e1) (go e2)- PGT_AST.PlusAExpr e -> PGT_AST.PlusAExpr (go 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 e -> PGT_AST.MinusAExpr (go e)- PGT_AST.PrefixQualOpAExpr op e -> PGT_AST.PrefixQualOpAExpr op (go e)- PGT_AST.SuffixQualOpAExpr e op -> PGT_AST.SuffixQualOpAExpr (go e) op- PGT_AST.NotAExpr e -> PGT_AST.NotAExpr (go e)- PGT_AST.ReversableOpAExpr e notFlag revOp ->- let- eFixed = go e- in- case revOp of- PGT_AST.DistinctFromAExprReversableOp{} -> expr -- Should have been caught by getOperatorDetails- PGT_AST.BetweenAExprReversableOp symm bExpr aExpr ->- PGT_AST.ReversableOpAExpr- eFixed- notFlag- (PGT_AST.BetweenAExprReversableOp symm (goBExpr bExpr) (go aExpr))- PGT_AST.InAExprReversableOp inExpr ->- PGT_AST.ReversableOpAExpr- eFixed- notFlag- (PGT_AST.InAExprReversableOp (goInExpr inExpr))- _ -> PGT_AST.ReversableOpAExpr eFixed notFlag revOp -- For IS NULL, IS TRUE etc.- PGT_AST.IsnullAExpr e -> PGT_AST.IsnullAExpr (go e)- PGT_AST.NotnullAExpr e -> PGT_AST.NotnullAExpr (go e)- PGT_AST.OverlapsAExpr row1 row2 -> PGT_AST.OverlapsAExpr (goRow row1) (goRow row2)- PGT_AST.SubqueryAExpr e op st sub ->- PGT_AST.SubqueryAExpr- (go e)- op- st- (either (Left . goSelectWithParens) (Right . go) sub)- PGT_AST.UniqueAExpr s -> PGT_AST.UniqueAExpr (goSelectWithParens s)- PGT_AST.DefaultAExpr -> PGT_AST.DefaultAExpr- _ -> expr -- Leaf node or unhandled construct- goBExpr :: PGT_AST.BExpr -> PGT_AST.BExpr- goBExpr = \case- PGT_AST.CExprBExpr c -> PGT_AST.CExprBExpr c- PGT_AST.TypecastBExpr be t -> PGT_AST.TypecastBExpr (goBExpr be) t- PGT_AST.PlusBExpr be -> PGT_AST.PlusBExpr (goBExpr be)- PGT_AST.MinusBExpr be -> PGT_AST.MinusBExpr (goBExpr 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 l op r -> PGT_AST.SymbolicBinOpBExpr (goBExpr l) op (goBExpr r)- PGT_AST.QualOpBExpr op be -> PGT_AST.QualOpBExpr op (goBExpr be)- PGT_AST.IsOpBExpr be notFlag isOp ->- let- beFixed = goBExpr be- in- case isOp of- PGT_AST.DistinctFromBExprIsOp b ->- PGT_AST.IsOpBExpr beFixed notFlag (PGT_AST.DistinctFromBExprIsOp (goBExpr b))- _ -> PGT_AST.IsOpBExpr beFixed notFlag isOp-- goRow :: PGT_AST.Row -> PGT_AST.Row- goRow = \case- PGT_AST.ExplicitRowRow mExprs -> PGT_AST.ExplicitRowRow (fmap (NE.map go) mExprs)- PGT_AST.ImplicitRowRow (PGT_AST.ImplicitRow exprs aexpr) -> PGT_AST.ImplicitRowRow (PGT_AST.ImplicitRow (NE.map go exprs) (go aexpr))-- goSelectWithParens :: PGT_AST.SelectWithParens -> PGT_AST.SelectWithParens- goSelectWithParens = id -- Placeholder: A full traversal would be needed.- goInExpr :: PGT_AST.InExpr -> PGT_AST.InExpr- goInExpr = \case- PGT_AST.SelectInExpr s -> PGT_AST.SelectInExpr (goSelectWithParens s)- PGT_AST.ExprListInExpr exprs -> PGT_AST.ExprListInExpr (NE.map go exprs)---renderPGTAExpr :: PGT_AST.AExpr -> Q Exp-renderPGTAExpr astExpr = case fixOperatorPrecedence astExpr of- PGT_AST.CExprAExpr cExpr -> renderPGTCExpr cExpr- PGT_AST.TypecastAExpr aExpr typename -> do- tnExp <- renderPGTTypename typename- aExp <- renderPGTAExpr aExpr- pure $ VarE 'S.cast `AppE` tnExp `AppE` aExp- PGT_AST.SymbolicBinOpAExpr left op right -> do- lExp <- renderPGTAExpr left- rExp <- renderPGTAExpr right- squealOpExp <-- case op of- PGT_AST.MathSymbolicExprBinOp mathOp -> pure $ renderPGTMathOp mathOp- PGT_AST.QualSymbolicExprBinOp qualOp -> pure $ renderPGTQualOp qualOp- pure (squealOpExp `AppE` lExp `AppE` rExp)- PGT_AST.PrefixQualOpAExpr op expr -> do- let- opExp' = renderPGTQualOp op- eExp' <- renderPGTAExpr expr- pure (opExp' `AppE` eExp')- PGT_AST.AndAExpr left right -> do- lExp' <- renderPGTAExpr left- rExp' <- renderPGTAExpr right- pure (VarE '(S..&&) `AppE` lExp' `AppE` rExp')- PGT_AST.OrAExpr left right -> do- lExp' <- renderPGTAExpr left- rExp' <- renderPGTAExpr right- pure (VarE '(S..||) `AppE` lExp' `AppE` rExp')- PGT_AST.NotAExpr expr -> do- eExp' <- renderPGTAExpr expr- pure (VarE 'S.not_ `AppE` eExp')- PGT_AST.VerbalExprBinOpAExpr left not op right mEscape -> do- when (isJust mEscape) $ fail "LIKE with ESCAPE is not supported yet."- lExp' <- renderPGTAExpr left- rExp' <- renderPGTAExpr right- baseOpExp <-- case op of- PGT_AST.LikeVerbalExprBinOp -> pure $ VarE 'S.like- PGT_AST.IlikeVerbalExprBinOp -> pure $ VarE 'S.ilike- _ -> fail $ "Unsupported verbal binary operator: " <> show op- let- finalOpExp = if not then VarE 'S.not_ `AppE` baseOpExp else baseOpExp- pure (finalOpExp `AppE` lExp' `AppE` rExp')- PGT_AST.ReversableOpAExpr expr not reversableOp -> do- renderedExpr' <- renderPGTAExpr expr- case reversableOp of- PGT_AST.NullAExprReversableOp ->- pure $ (if not then VarE 'S.isNotNull else VarE 'S.isNull) `AppE` renderedExpr'- PGT_AST.BetweenAExprReversableOp _asymmetric bExpr andAExpr -> do- bExp' <- renderPGTBExpr bExpr- aExp' <- renderPGTAExpr andAExpr- let- opVar' = if not then VarE 'S.notBetween else VarE 'S.between- pure $ opVar' `AppE` renderedExpr' `AppE` TupE [Just bExp', Just aExp']- PGT_AST.InAExprReversableOp inExpr ->- let- opVar' = if not then VarE 'S.notIn else VarE 'S.in_- in- case inExpr of- PGT_AST.ExprListInExpr exprList -> do- listExp' <- ListE <$> mapM renderPGTAExpr (NE.toList exprList)- pure $ opVar' `AppE` renderedExpr' `AppE` listExp'- _ -> fail "Unsupported IN subquery expression"- _ -> fail $ "Unsupported reversable operator: " <> show reversableOp- PGT_AST.DefaultAExpr -> pure $ ConE 'S.Default- PGT_AST.MinusAExpr expr -> do- -- Unary minus- eExp' <- renderPGTAExpr expr- let- zeroExp = AppE (VarE 'fromInteger) (LitE (IntegerL 0))- pure (InfixE (Just zeroExp) (VarE '(-)) (Just eExp'))- unsupported -> fail $ "Unsupported AExpr: " <> show unsupported---renderPGTBExpr :: PGT_AST.BExpr -> Q Exp-renderPGTBExpr = \case- PGT_AST.CExprBExpr cExpr -> renderPGTCExpr cExpr- PGT_AST.TypecastBExpr bExpr typename -> do- tnExp <- renderPGTTypename typename- bExp <- renderPGTBExpr bExpr- pure $ VarE 'S.cast `AppE` tnExp `AppE` bExp- PGT_AST.SymbolicBinOpBExpr left op right -> do- lExp <- renderPGTBExpr left- rExp <- renderPGTBExpr right- squealOpExp <-- case op of- PGT_AST.MathSymbolicExprBinOp mathOp -> pure $ renderPGTMathOp mathOp- PGT_AST.QualSymbolicExprBinOp qualOp -> pure $ renderPGTQualOp qualOp- pure (squealOpExp `AppE` lExp `AppE` rExp)- unsupported -> fail $ "Unsupported BExpr: " <> show unsupported---renderPGTCExpr :: PGT_AST.CExpr -> Q Exp-renderPGTCExpr = \case- PGT_AST.AexprConstCExpr aexprConst -> pure $ renderPGTAexprConst aexprConst- PGT_AST.ColumnrefCExpr columnref -> pure $ renderPGTColumnref columnref- PGT_AST.ParamCExpr n maybeIndirection -> do- when (isJust maybeIndirection) $- fail "Parameters with indirection (e.g. $1[i]) are not supported."- pure $ VarE 'S.param `AppTypeE` LitT (NumTyLit (fromIntegral n))- PGT_AST.InParensCExpr expr maybeIndirection -> do- when (isJust maybeIndirection) $- fail "Parenthesized expressions with indirection are not supported."- renderPGTAExpr expr -- Squeal's operator precedence should handle this- PGT_AST.FuncCExpr funcExpr -> renderPGTFuncExpr funcExpr- unsupported -> fail $ "Unsupported CExpr: " <> show unsupported---renderPGTFuncExpr :: PGT_AST.FuncExpr -> Q Exp-renderPGTFuncExpr = \case- PGT_AST.ApplicationFuncExpr funcApp maybeWithinGroup maybeFilter maybeOver -> do- when (isJust maybeWithinGroup) $ fail "WITHIN GROUP clause is not supported."- when (isJust maybeFilter) $ fail "FILTER clause is not supported."- when (isJust maybeOver) $ fail "OVER clause is not supported."- renderPGTFuncApplication funcApp- PGT_AST.SubexprFuncExpr funcCommonSubexpr -> renderPGTFuncExprCommonSubexpr funcCommonSubexpr---renderPGTFuncApplication :: PGT_AST.FuncApplication -> Q Exp-renderPGTFuncApplication (PGT_AST.FuncApplication funcName maybeParams) =- case funcName of- PGT_AST.IndirectedFuncName{} ->- fail "Functions with indirection (e.g. schema.func) are not supported."- PGT_AST.TypeFuncName fident ->- let- fnNameStr = Text.unpack (getIdentText fident)- in- case Text.toLower (Text.pack fnNameStr) of- "inline" ->- case maybeParams of- Just (PGT_AST.NormalFuncApplicationParams _ args _) ->- case NE.toList args of- [ PGT_AST.ExprFuncArgExpr- (PGT_AST.CExprAExpr (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref ident Nothing)))- ] -> do- let- varName :: Name- varName = mkName . Text.unpack . getIdentText $ ident- pure $ VarE 'S.inline `AppE` VarE varName- _ -> fail "inline() function expects a single variable argument"- _ -> fail "inline() function expects a single variable argument"- "inline_param" ->- case maybeParams of- Just (PGT_AST.NormalFuncApplicationParams _ args _) ->- case NE.toList args of- [ PGT_AST.ExprFuncArgExpr- (PGT_AST.CExprAExpr (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref ident Nothing)))- ] -> do- let- varName :: Name- varName = mkName . Text.unpack . getIdentText $ ident- pure $ VarE 'S.inlineParam `AppE` VarE varName- _ -> fail "inline_param() function expects a single variable argument"- _ -> fail "inline_param() function expects a single variable argument"- otherFnName ->- let- squealFn :: Q Exp- squealFn =- case otherFnName of- "coalesce" -> pure $ VarE 'S.coalesce- "lower" -> pure $ VarE 'S.lower- "char_length" -> pure $ VarE 'S.charLength- "character_length" -> pure $ VarE 'S.charLength- "upper" -> pure $ VarE 'S.upper- "count" -> pure $ VarE 'S.count -- Special handling for count(*) might be needed- "now" -> pure $ VarE 'S.now- _ -> fail $ "Unsupported function: " <> fnNameStr- in- case maybeParams of- Nothing -> squealFn -- No-argument function- Just params -> case params of- PGT_AST.NormalFuncApplicationParams maybeAllOrDistinct args maybeSortClause -> do- when (isJust maybeAllOrDistinct) $- fail "DISTINCT in function calls is not supported."- when (isJust maybeSortClause) $- fail "ORDER BY in function calls is not supported."- fn <- squealFn- argExps <- mapM renderPGTFuncArgExpr (NE.toList args)- pure $ foldl' AppE fn argExps- PGT_AST.StarFuncApplicationParams ->- -- Specific for count(*)- if fnNameStr == "count"- then pure $ VarE 'S.countStar- else fail "Star argument only supported for COUNT"- _ -> fail $ "Unsupported function parameters structure: " <> show params---renderPGTFuncArgExpr :: PGT_AST.FuncArgExpr -> Q Exp-renderPGTFuncArgExpr = \case- PGT_AST.ExprFuncArgExpr aExpr -> renderPGTAExpr aExpr- _ -> fail "Named or colon-syntax function arguments not supported"---renderPGTFuncExprCommonSubexpr :: PGT_AST.FuncExprCommonSubexpr -> Q Exp-renderPGTFuncExprCommonSubexpr = \case- PGT_AST.CurrentTimestampFuncExprCommonSubexpr (Just _) ->- fail "CURRENT_TIMESTAMP with precision is not supported."- PGT_AST.CurrentTimestampFuncExprCommonSubexpr Nothing -> pure $ VarE 'S.now -- Or S.currentTimestamp- PGT_AST.CurrentDateFuncExprCommonSubexpr -> pure $ VarE 'S.currentDate- PGT_AST.CoalesceFuncExprCommonSubexpr exprListNE -> do- renderedInitExprs <- mapM renderPGTAExpr (NE.init exprListNE)- renderedLastExpr <- renderPGTAExpr (NE.last exprListNE)- pure $ VarE 'S.coalesce `AppE` ListE renderedInitExprs `AppE` renderedLastExpr- e -> fail $ "Unsupported common function subexpression: " <> show e---renderPGTColumnref :: PGT_AST.Columnref -> Exp-renderPGTColumnref (PGT_AST.Columnref colId maybeIndirection) =- case maybeIndirection of- Nothing -> LabelE (Text.unpack (getIdentText colId))- Just indirection ->- let- base = LabelE (Text.unpack (getIdentText colId))- in- foldl' applyIndirection base (NE.toList indirection)- where- applyIndirection acc = \case- PGT_AST.AttrNameIndirectionEl attrName ->- VarE '(S.!) `AppE` acc `AppE` LabelE (Text.unpack (getIdentText attrName))- _ -> error "Unsupported column reference indirection"---renderPGTAexprConst :: PGT_AST.AexprConst -> Exp-renderPGTAexprConst = \case- PGT_AST.IAexprConst n ->- ConE 'S.UnsafeExpression- `AppE` ( VarE 'BS8.pack- `AppE` LitE (StringL (show n))- )- PGT_AST.FAexprConst f ->- ConE 'S.UnsafeExpression- `AppE` ( VarE 'BS8.pack- `AppE` LitE (StringL (show f))- )- PGT_AST.SAexprConst s ->- VarE 'fromString `AppE` LitE (StringL (Text.unpack s))- PGT_AST.BoolAexprConst True -> VarE 'S.true- PGT_AST.BoolAexprConst False -> VarE 'S.false- PGT_AST.NullAexprConst -> VarE 'S.null_- unsupported -> error $ "Unsupported AexprConst: " <> show unsupported---renderPGTMathOp :: PGT_AST.MathOp -> Exp-renderPGTMathOp = \case- PGT_AST.PlusMathOp -> VarE '(+)- PGT_AST.MinusMathOp -> VarE '(-)- PGT_AST.AsteriskMathOp -> VarE '(*)- PGT_AST.EqualsMathOp -> VarE '(S..==)- PGT_AST.ArrowLeftArrowRightMathOp -> VarE '(S../=) -- <>- PGT_AST.ExclamationEqualsMathOp -> VarE '(S../=) -- !=- PGT_AST.ArrowRightMathOp -> VarE '(S..>)- PGT_AST.GreaterEqualsMathOp -> VarE '(S..>=)- PGT_AST.ArrowLeftMathOp -> VarE '(S..<)- PGT_AST.LessEqualsMathOp -> VarE '(S..<=)- _ -> error "Unsupported math operator"---renderPGTQualOp :: PGT_AST.QualOp -> Exp-renderPGTQualOp = \case- PGT_AST.OpQualOp opText ->- case Text.toLower opText of- "+" -> VarE '(+)- "-" -> VarE '(-)- "*" -> VarE '(*)- "=" -> VarE '(S..==)- "<>" -> VarE '(S../=)- "!=" -> VarE '(S../=)- ">" -> VarE '(S..>)- ">=" -> VarE '(S..>=)- "<" -> VarE '(S..<)- "<=" -> VarE '(S..<=)- "and" -> VarE '(S..&&)- "or" -> VarE '(S..||)- "not" -> VarE 'S.not_- "like" -> VarE 'S.like- "ilike" -> VarE 'S.ilike- _ -> error $ "Unsupported QualOp operator text: " <> Text.unpack opText- PGT_AST.OperatorQualOp _anyOperator ->- error "OPERATOR(any_operator) syntax not supported"---renderPGTTypename :: PGT_AST.Typename -> Q Exp-renderPGTTypename (PGT_AST.Typename setof simpleTypename nullable arrayInfo) = do- when setof $ fail "SETOF type modifier is not supported."- when nullable $ fail "Nullable type modifier '?' is not supported."- baseTypeExp <- renderPGTSimpleTypename simpleTypename- case arrayInfo of- Nothing -> pure baseTypeExp- Just (dims, nullableArray) -> do- when nullableArray $ fail "Nullable array modifier '?' is not supported."- renderPGTArrayDimensions baseTypeExp dims---renderPGTArrayDimensions :: Exp -> PGT_AST.TypenameArrayDimensions -> Q Exp-renderPGTArrayDimensions baseTypeExp = \case- PGT_AST.BoundsTypenameArrayDimensions 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 NE.toList bounds of- [Just dim] ->- pure $- VarE 'S.fixarray- `AppTypeE` LitT (NumTyLit (fromIntegral dim))- `AppE` baseTypeExp- [_] -> pure $ VarE 'S.vararray `AppE` baseTypeExp -- e.g. int[]- _ ->- fail "Multidimensional arrays with explicit bounds not yet supported"- PGT_AST.ExplicitTypenameArrayDimensions Nothing -> pure $ VarE 'S.vararray `AppE` baseTypeExp -- e.g. sometype ARRAY- PGT_AST.ExplicitTypenameArrayDimensions (Just dim) ->- pure $- VarE 'S.fixarray- `AppTypeE` LitT (NumTyLit (fromIntegral dim))- `AppE` baseTypeExp -- e.g. sometype ARRAY[N]---renderPGTSimpleTypename :: PGT_AST.SimpleTypename -> Q Exp-renderPGTSimpleTypename = \case- PGT_AST.GenericTypeSimpleTypename- (PGT_AST.GenericType typeFnName attrs maybeModifiers) -> do- when (isJust attrs) $- fail "Qualified type names (e.g. schema.my_type) are not supported."- let- nameLower = Text.toLower (getIdentText typeFnName)- extractLength :: Maybe PGT_AST.TypeModifiers -> Q Integer- extractLength = \case- Just- ((PGT_AST.CExprAExpr (PGT_AST.AexprConstCExpr (PGT_AST.IAexprConst n))) NE.:| []) -> pure (fromIntegral n)- Just other ->- fail $- "Unsupported type modifier for " <> Text.unpack nameLower <> ": " <> show other- Nothing ->- fail $- "Type "- <> Text.unpack nameLower- <> " requires a length argument (e.g., "- <> Text.unpack nameLower- <> "(N))."-- extractLengthOrDefault :: Integer -> Maybe PGT_AST.TypeModifiers -> Q Integer- extractLengthOrDefault def = \case- Just- ((PGT_AST.CExprAExpr (PGT_AST.AexprConstCExpr (PGT_AST.IAexprConst n))) NE.:| []) -> pure (fromIntegral n)- Just other ->- fail $- "Unsupported type modifier for " <> Text.unpack nameLower <> ": " <> show other- Nothing -> pure def- case nameLower of- "char" -> do- len <- extractLengthOrDefault 1 maybeModifiers- pure $ VarE 'S.char `AppTypeE` LitT (NumTyLit len)- "character" -> do- len <- extractLengthOrDefault 1 maybeModifiers- pure $ VarE 'S.character `AppTypeE` LitT (NumTyLit len)- "varchar" -> case maybeModifiers of- Nothing -> pure $ VarE 'S.text -- varchar without length is text- Just _ -> do- len <- extractLength maybeModifiers- pure $ VarE 'S.varchar `AppTypeE` LitT (NumTyLit len)- "character varying" -> case maybeModifiers of- Nothing -> pure $ VarE 'S.text -- character varying without length is text- Just _ -> do- len <- extractLength maybeModifiers- pure $ VarE 'S.characterVarying `AppTypeE` LitT (NumTyLit len)- "bool" -> pure $ VarE 'S.bool- "int2" -> pure $ VarE 'S.int2- "smallint" -> pure $ VarE 'S.smallint- "int4" -> pure $ VarE 'S.int4- "int" -> pure $ VarE 'S.int- "integer" -> pure $ VarE 'S.integer- "int8" -> pure $ VarE 'S.int8- "bigint" -> pure $ VarE 'S.bigint- "numeric" -> pure $ VarE 'S.numeric -- Ignoring precision/scale for now- "float4" -> pure $ VarE 'S.float4 -- Ignoring precision for now- "real" -> pure $ VarE 'S.real- "float8" -> pure $ VarE 'S.float8- "double precision" -> pure $ VarE 'S.doublePrecision- "money" -> pure $ VarE 'S.money- "text" -> pure $ VarE 'S.text- "bytea" -> pure $ VarE 'S.bytea- "timestamp" -> pure $ VarE 'S.timestamp- "timestamptz" -> pure $ VarE 'S.timestamptz- "timestamp with time zone" -> pure $ VarE 'S.timestampWithTimeZone- "date" -> pure $ VarE 'S.date- "time" -> pure $ VarE 'S.time- "timetz" -> pure $ VarE 'S.timetz- "time with time zone" -> pure $ VarE 'S.timeWithTimeZone- "interval" -> pure $ VarE 'S.interval- "uuid" -> pure $ VarE 'S.uuid- "inet" -> pure $ VarE 'S.inet- "json" -> pure $ VarE 'S.json- "jsonb" -> pure $ VarE 'S.jsonb- "tsvector" -> pure $ VarE 'S.tsvector- "tsquery" -> pure $ VarE 'S.tsquery- "oid" -> pure $ VarE 'S.oid- "int4range" -> pure $ VarE 'S.int4range- "int8range" -> pure $ VarE 'S.int8range- "numrange" -> pure $ VarE 'S.numrange- "tsrange" -> pure $ VarE 'S.tsrange- "tstzrange" -> pure $ VarE 'S.tstzrange- "daterange" -> pure $ VarE 'S.daterange- "record" -> pure $ VarE 'S.record- other -> fail $ "Unsupported generic type name: " <> Text.unpack other- PGT_AST.NumericSimpleTypename numeric -> renderPGTNumeric numeric- PGT_AST.BitSimpleTypename (PGT_AST.Bit _varying _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.- fail- "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 charTypeAst ->- case charTypeAst of- PGT_AST.CharacterCharacter False -> pure $ VarE 'S.character `AppTypeE` LitT (NumTyLit 1) -- SQL CHARACTER -> Squeal character(1)- PGT_AST.CharacterCharacter True -> pure $ VarE 'S.text -- SQL CHARACTER VARYING -> Squeal text- PGT_AST.CharCharacter False -> pure $ VarE 'S.char `AppTypeE` LitT (NumTyLit 1) -- SQL CHAR -> Squeal char(1)- PGT_AST.CharCharacter True -> pure $ VarE 'S.text -- SQL CHAR VARYING -> Squeal text- PGT_AST.VarcharCharacter -> pure $ VarE 'S.text -- SQL VARCHAR (no length) -> Squeal text- -- National character types are often aliases for standard character types in PostgreSQL- PGT_AST.NationalCharacterCharacter False -> pure $ VarE 'S.character `AppTypeE` LitT (NumTyLit 1) -- NCHAR -> character(1)- PGT_AST.NationalCharacterCharacter True -> pure $ VarE 'S.text -- NCHAR VARYING -> text- PGT_AST.NationalCharCharacter False -> pure $ VarE 'S.char `AppTypeE` LitT (NumTyLit 1) -- NATIONAL CHAR -> char(1)- PGT_AST.NationalCharCharacter True -> pure $ VarE 'S.text -- NATIONAL CHAR VARYING -> text- PGT_AST.NcharCharacter False -> pure $ VarE 'S.char `AppTypeE` LitT (NumTyLit 1) -- NCHAR (synonym for NATIONAL CHAR) -> char(1)- PGT_AST.NcharCharacter True -> pure $ VarE 'S.text -- NCHAR VARYING -> text- PGT_AST.ConstDatetimeSimpleTypename dt -> case dt of- PGT_AST.TimestampConstDatetime precision maybeTimezone -> do- when (isJust precision) $ fail "TIMESTAMP with precision is not supported."- pure $ case maybeTimezone of- Just False -> VarE 'S.timestampWithTimeZone -- WITH TIME ZONE- _ -> VarE 'S.timestamp -- WITHOUT TIME ZONE or unspecified- PGT_AST.TimeConstDatetime precision maybeTimezone -> do- when (isJust precision) $ fail "TIME with precision is not supported."- pure $ case maybeTimezone of- Just False -> VarE 'S.timeWithTimeZone -- WITH TIME ZONE- _ -> VarE 'S.time -- WITHOUT TIME ZONE or unspecified- PGT_AST.ConstIntervalSimpleTypename (Left (Just _)) ->- fail "INTERVAL with qualifiers is not supported."- PGT_AST.ConstIntervalSimpleTypename (Left Nothing) ->- pure $ VarE 'S.interval- PGT_AST.ConstIntervalSimpleTypename (Right _) ->- fail "INTERVAL with integer literal is not supported in this context."---renderPGTNumeric :: PGT_AST.Numeric -> Q Exp-renderPGTNumeric = \case- PGT_AST.IntNumeric -> pure $ VarE 'S.int- PGT_AST.IntegerNumeric -> pure $ VarE 'S.integer- PGT_AST.SmallintNumeric -> pure $ VarE 'S.smallint- PGT_AST.BigintNumeric -> pure $ VarE 'S.bigint- PGT_AST.RealNumeric -> pure $ VarE 'S.real- PGT_AST.FloatNumeric (Just _) -> fail "FLOAT with precision is not supported."- PGT_AST.FloatNumeric Nothing -> pure $ VarE 'S.float4- PGT_AST.DoublePrecisionNumeric -> pure $ VarE 'S.doublePrecision- PGT_AST.DecimalNumeric (Just _) -> fail "DECIMAL with precision/scale is not supported."- PGT_AST.DecimalNumeric Nothing -> pure $ VarE 'S.numeric- PGT_AST.DecNumeric (Just _) -> fail "DEC with precision/scale is not supported."- PGT_AST.DecNumeric Nothing -> pure $ VarE 'S.numeric- PGT_AST.NumericNumeric (Just _) -> fail "NUMERIC with precision/scale is not supported."- PGT_AST.NumericNumeric Nothing -> pure $ VarE 'S.numeric- PGT_AST.BooleanNumeric -> pure $ 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 = \case- PGT_AST.NormalTargeting targetList -> do- selListExp <- renderPGTTargetList targetList- pure (selListExp, Nothing)- PGT_AST.AllTargeting maybeTargetList -> do- selListExp <-- case maybeTargetList of- Nothing -> pure $ ConE 'S.Star -- SELECT ALL (which is like SELECT *)- Just tl -> renderPGTTargetList tl- pure (selListExp, Nothing)- PGT_AST.DistinctTargeting maybeOnExprs targetList -> do- selListExp <- renderPGTTargetList targetList- pure (selListExp, fmap NE.toList maybeOnExprs)---renderPGTTargetEl :: PGT_AST.TargetEl -> Maybe PGT_AST.Ident -> Int -> Q Exp-renderPGTTargetEl targetEl mOuterAlias idx =- let- (exprAST, mInternalAlias) = case targetEl of- PGT_AST.AliasedExprTargetEl e an -> (e, Just an)- PGT_AST.ImplicitlyAliasedExprTargetEl e an -> (e, Just an)- PGT_AST.ExprTargetEl e -> (e, Nothing)- PGT_AST.AsteriskTargetEl ->- ( PGT_AST.CExprAExpr- ( PGT_AST.AexprConstCExpr- PGT_AST.NullAexprConst- )- , Nothing -- Placeholder for Star, should be S.Star- )- finalAliasName = mOuterAlias <|> mInternalAlias- in- case targetEl of- PGT_AST.AsteriskTargetEl -> pure $ ConE 'S.Star- _ -> do- renderedScalarExp <- renderPGTAExpr exprAST- case exprAST of- PGT_AST.CExprAExpr (PGT_AST.ColumnrefCExpr _)- | Nothing <- finalAliasName ->- pure renderedScalarExp- _ -> do- let- aliasLabelStr =- case finalAliasName of- Just ident -> Text.unpack $ getIdentText ident- Nothing -> "_col" <> show idx- pure $- VarE 'S.as- `AppE` renderedScalarExp- `AppE` LabelE aliasLabelStr---renderPGTTargetList :: PGT_AST.TargetList -> Q Exp-renderPGTTargetList (item NE.:| items) =- if null items && isAsterisk item- then- pure $ ConE 'S.Star- else- if null items && isDotStar item- then- renderPGTTargetElDotStar item- else- go (item : items) 1- where- isAsterisk :: PGT_AST.TargetEl -> Bool- isAsterisk PGT_AST.AsteriskTargetEl = True- isAsterisk _ = False-- isDotStar :: PGT_AST.TargetEl -> Bool- isDotStar- ( PGT_AST.ExprTargetEl- ( PGT_AST.CExprAExpr- (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref _ (Just indirection)))- )- ) =- any isAllIndirectionEl (NE.toList indirection)- isDotStar _ = False-- isAllIndirectionEl :: PGT_AST.IndirectionEl -> Bool- isAllIndirectionEl PGT_AST.AllIndirectionEl = True- isAllIndirectionEl _ = False-- renderPGTTargetElDotStar :: PGT_AST.TargetEl -> Q Exp- renderPGTTargetElDotStar- ( PGT_AST.ExprTargetEl- ( PGT_AST.CExprAExpr- ( PGT_AST.ColumnrefCExpr- ( PGT_AST.Columnref- qualName- indirectionOpt- )- )- )- ) =- case indirectionOpt of- Just indirection- | any isAllIndirectionEl (NE.toList indirection) ->- pure $- ConE 'S.DotStar- `AppE` (LabelE (Text.unpack (getIdentText qualName)))- _ ->- fail $- "renderPGTTargetElDotStar called with non-DotStar "- <> "TargetEl structure"- renderPGTTargetElDotStar _ =- fail "renderPGTTargetElDotStar called with unexpected TargetEl"-- go :: [PGT_AST.TargetEl] -> Int -> Q Exp- go [] _ =- {- Should not happen with NonEmpty input to renderPGTTargetList -}- fail "Empty selection list items in go."- go [el] currentIdx = renderPGTTargetEl el Nothing currentIdx- go (el : more) currentIdx = do- renderedEl <- renderPGTTargetEl el Nothing currentIdx- if null more- then pure renderedEl- else do- restRendered <- go more (currentIdx + 1)- pure $ ConE 'S.Also `AppE` restRendered `AppE` renderedEl--
src/Squeal/QuasiQuotes/Delete.hs view
@@ -9,13 +9,16 @@ ) where import Control.Monad (when)+import Data.Foldable (Foldable(foldr), foldlM) import Data.Maybe (isJust) import Language.Haskell.TH.Syntax (Exp(AppE, ConE, LabelE, VarE), Q) import Prelude- ( Applicative(pure), Maybe(Just, Nothing), MonadFail(fail), ($), (<$>)+ ( Applicative(pure), Maybe(Just, Nothing), MonadFail(fail), Semigroup((<>))+ , ($), (<$>) )-import Squeal.QuasiQuotes.Common+import Squeal.QuasiQuotes.Query ( getIdentText, renderPGTAExpr, renderPGTTableRef, renderPGTTargetList+ , toSquealQuery ) import qualified Data.List.NonEmpty as NE import qualified Data.Text as Text@@ -23,6 +26,44 @@ import qualified Squeal.PostgreSQL as S +renderPGTWithClause :: PGT_AST.WithClause -> Q ([Text.Text], Exp)+renderPGTWithClause (PGT_AST.WithClause recursive ctes) = do+ when recursive $ fail "Recursive WITH clauses are not supported yet."+ let+ cteList = NE.toList ctes+ (finalCteNames, renderedCtes) <-+ foldlM+ ( \(names, exps) cte -> do+ (name, exp) <- renderCte names cte+ pure (names <> [name], exps <> [exp])+ )+ ([], [])+ cteList++ let+ withExp =+ foldr+ (\cte acc -> ConE '(S.:>>) `AppE` cte `AppE` acc)+ (ConE 'S.Done)+ renderedCtes+ pure (finalCteNames, withExp)+ where+ renderCte :: [Text.Text] -> PGT_AST.CommonTableExpr -> Q (Text.Text, Exp)+ renderCte existingCteNames (PGT_AST.CommonTableExpr ident maybeColNames maybeMaterialized stmt) = do+ when (isJust maybeMaterialized) $+ fail "MATERIALIZED/NOT MATERIALIZED for CTEs is not supported yet."+ cteStmtExp <-+ case stmt of+ PGT_AST.SelectPreparableStmt selectStmt -> do+ queryExp <- toSquealQuery existingCteNames maybeColNames selectStmt+ pure $ VarE 'S.queryStatement `AppE` queryExp+ _ -> fail "Only SELECT statements are supported in CTEs for now."+ let+ cteName = getIdentText ident+ pure+ (cteName, VarE 'S.as `AppE` cteStmtExp `AppE` LabelE (Text.unpack cteName))++ toSquealDelete :: PGT_AST.DeleteStmt -> Q Exp toSquealDelete ( PGT_AST.DeleteStmt@@ -32,8 +73,12 @@ maybeWhereClause maybeReturningClause ) = do- when (isJust maybeWithClause) $- fail "WITH clauses are not supported in DELETE statements yet."+ (cteNames, renderedWithClause) <-+ case maybeWithClause of+ Nothing -> pure ([], Nothing)+ Just withClause -> do+ (names, exp) <- renderPGTWithClause withClause+ pure (names, Just exp) -- whereOrCurrentClause with cursor is not supported yet targetTableExp <- renderPGTRelationExprOptAlias' relationExprOptAlias@@ -41,28 +86,34 @@ usingClauseExp <- case maybeUsingClause of Nothing -> pure $ ConE 'S.NoUsing- Just usingClause -> AppE (ConE 'S.Using) <$> renderPGTTableRef usingClause+ Just usingClause -> AppE (ConE 'S.Using) <$> renderPGTTableRef cteNames usingClause whereConditionExp <- case maybeWhereClause of Nothing -> fail "DELETE statements must have a WHERE clause for safety. Use WHERE TRUE to delete all rows."- Just (PGT_AST.ExprWhereOrCurrentClause whereAExpr) -> renderPGTAExpr whereAExpr+ Just (PGT_AST.ExprWhereOrCurrentClause whereAExpr) -> renderPGTAExpr cteNames whereAExpr Just (PGT_AST.CursorWhereOrCurrentClause _) -> fail "WHERE CURRENT OF is not supported." returningClauseExp <- case maybeReturningClause of Nothing -> pure $ ConE 'S.Returning_ `AppE` ConE 'S.Nil- Just returningClause -> AppE (ConE 'S.Returning) <$> renderPGTTargetList returningClause+ Just returningClause -> AppE (ConE 'S.Returning) <$> renderPGTTargetList cteNames returningClause - pure- ( VarE 'S.deleteFrom- `AppE` targetTableExp- `AppE` usingClauseExp- `AppE` whereConditionExp- `AppE` returningClauseExp- )+ let+ deleteBody =+ ( VarE 'S.deleteFrom+ `AppE` targetTableExp+ `AppE` usingClauseExp+ `AppE` whereConditionExp+ `AppE` returningClauseExp+ )+ let+ finalExp = case renderedWithClause of+ Nothing -> deleteBody+ Just withExp -> VarE 'S.with `AppE` withExp `AppE` deleteBody+ pure finalExp renderPGTRelationExprOptAlias' :: PGT_AST.RelationExprOptAlias -> Q Exp
src/Squeal/QuasiQuotes/Insert.hs view
@@ -9,21 +9,58 @@ ) where import Control.Monad (MonadFail(fail), mapM, when, zipWithM)+import Data.Foldable (Foldable(foldr, length), foldlM) import Data.Maybe (isJust) import Language.Haskell.TH.Syntax (Exp(AppE, ConE, LabelE, ListE, VarE), Q) import Prelude- ( Applicative(pure), Either(Left), Eq((/=)), Foldable(foldr, length)- , Maybe(Just, Nothing), Semigroup((<>)), Show(show), ($), (.), error- , otherwise+ ( Applicative(pure), Either(Left), Eq((/=)), Maybe(Just, Nothing)+ , Semigroup((<>)), Show(show), ($), (.), error, otherwise )-import Squeal.QuasiQuotes.Common (getIdentText, renderPGTAExpr)-import Squeal.QuasiQuotes.Query (toSquealQuery)+import Squeal.QuasiQuotes.Query (getIdentText, renderPGTAExpr, toSquealQuery) import qualified Data.List.NonEmpty as NE import qualified Data.Text as Text import qualified PostgresqlSyntax.Ast as PGT_AST import qualified Squeal.PostgreSQL as S +renderPGTWithClause :: PGT_AST.WithClause -> Q ([Text.Text], Exp)+renderPGTWithClause (PGT_AST.WithClause recursive ctes) = do+ when recursive $ fail "Recursive WITH clauses are not supported yet."+ let+ cteList = NE.toList ctes+ (finalCteNames, renderedCtes) <-+ foldlM+ ( \(names, exps) cte -> do+ (name, exp) <- renderCte names cte+ pure (names <> [name], exps <> [exp])+ )+ ([], [])+ cteList++ let+ withExp =+ foldr+ (\cte acc -> ConE '(S.:>>) `AppE` cte `AppE` acc)+ (ConE 'S.Done)+ renderedCtes+ pure (finalCteNames, withExp)+ where+ renderCte :: [Text.Text] -> PGT_AST.CommonTableExpr -> Q (Text.Text, Exp)+ renderCte existingCteNames (PGT_AST.CommonTableExpr ident maybeColNames maybeMaterialized stmt) = do+ when (isJust maybeMaterialized) $+ fail "MATERIALIZED/NOT MATERIALIZED for CTEs is not supported yet."+ cteStmtExp <-+ case stmt of+ PGT_AST.SelectPreparableStmt selectStmt -> do+ queryExp <- toSquealQuery existingCteNames maybeColNames selectStmt+ pure $ VarE 'S.queryStatement `AppE` queryExp+ _ -> fail "Only SELECT statements are supported in CTEs for now."+ let+ cteName = getIdentText ident+ pure+ (cteName, VarE 'S.as `AppE` cteStmtExp `AppE` LabelE (Text.unpack cteName))++ toSquealInsert :: PGT_AST.InsertStmt -> Q Exp toSquealInsert ( PGT_AST.InsertStmt@@ -33,8 +70,13 @@ maybeOnConflict maybeReturningClause ) = do- when (isJust maybeWithClause) $- fail "WITH clauses are not supported in INSERT statements yet."+ (cteNames, renderedWithClause) <-+ case maybeWithClause of+ Nothing -> pure ([], Nothing)+ Just withClause -> do+ (names, exp) <- renderPGTWithClause withClause+ pure (names, Just exp)+ when (isJust maybeOnConflict) $ fail "ON CONFLICT clauses are not supported yet." @@ -50,7 +92,7 @@ (PGT_AST.SelectNoParens _ (Left (PGT_AST.ValuesSimpleSelect valuesClause)) _ _ _) -> case maybeInsertColumnList of Just colItems ->- renderPGTValueRows (NE.toList colItems) valuesClause+ renderPGTValueRows cteNames (NE.toList colItems) valuesClause Nothing -> fail "INSERT INTO ... VALUES must specify column names for the Squeal-QQ translation."@@ -62,7 +104,7 @@ fail "INSERT INTO table (columns) SELECT ... is not yet supported by Squeal-QQ. Please use INSERT INTO table SELECT ... and ensure your SELECT statement provides all columns for the table, matching the table's column order and types." Nothing -> do- squealQueryExp <- toSquealQuery selectStmt -- from Squeal.QuasiQuotes.Query+ squealQueryExp <- toSquealQuery cteNames Nothing selectStmt -- from Squeal.QuasiQuotes.Query pure (ConE 'S.Subquery `AppE` squealQueryExp) let table = renderPGTInsertTarget insertTarget@@ -79,7 +121,7 @@ `AppE` ConE 'S.OnConflictDoRaise `AppE` returning Just targetList -> do- returningProj <- renderTargetList (NE.toList targetList)+ returningProj <- renderTargetList cteNames (NE.toList targetList) let returning = ConE 'S.Returning `AppE` (ConE 'S.List `AppE` returningProj) pure $@@ -91,12 +133,16 @@ PGT_AST.DefaultValuesInsertRest -> fail "INSERT INTO ... DEFAULT VALUES is not yet supported by Squeal-QQ." - pure insertBody+ let+ finalExp = case renderedWithClause of+ Nothing -> insertBody+ Just withExp -> VarE 'S.with `AppE` withExp `AppE` insertBody+ pure finalExp -renderTargetList :: [PGT_AST.TargetEl] -> Q Exp-renderTargetList targetEls = do- exps <- mapM renderTargetEl targetEls+renderTargetList :: [Text.Text] -> [PGT_AST.TargetEl] -> Q Exp+renderTargetList cteNames targetEls = do+ exps <- mapM (renderTargetEl cteNames) targetEls pure $ foldr (\h t -> ConE '(S.:*) `AppE` h `AppE` t)@@ -104,10 +150,10 @@ exps -renderTargetEl :: PGT_AST.TargetEl -> Q Exp-renderTargetEl = \case+renderTargetEl :: [Text.Text] -> PGT_AST.TargetEl -> Q Exp+renderTargetEl cteNames = \case PGT_AST.ExprTargetEl expr -> do- exprExp <- renderPGTAExpr expr+ exprExp <- renderPGTAExpr cteNames expr case expr of PGT_AST.CExprAExpr (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref ident Nothing)) -> let@@ -118,7 +164,7 @@ fail "Returning expression without an alias is not supported for this expression type. Please add an alias." PGT_AST.AliasedExprTargetEl expr alias -> do- exprExp <- renderPGTAExpr expr+ exprExp <- renderPGTAExpr cteNames expr pure $ VarE 'S.as `AppE` exprExp `AppE` LabelE (Text.unpack (getIdentText alias)) PGT_AST.AsteriskTargetEl -> fail "should be handled by toSquealInsert"@@ -161,49 +207,49 @@ renderPGTValueRows- :: [PGT_AST.InsertColumnItem] -> PGT_AST.ValuesClause -> Q Exp-renderPGTValueRows colItems (valuesClauseRows) =+ :: [Text.Text] -> [PGT_AST.InsertColumnItem] -> PGT_AST.ValuesClause -> Q Exp+renderPGTValueRows cteNames colItems (valuesClauseRows) = -- valuesClauseRows is NonEmpty (NonEmpty AExpr) case NE.toList valuesClauseRows of [] -> fail "Insert statement has no value rows." row : moreRows -> do- firstRowExp <- renderPGTValueRow colItems (NE.toList row)- moreRowsExp <- mapM (renderPGTValueRow colItems . NE.toList) moreRows+ firstRowExp <- renderPGTValueRow cteNames colItems (NE.toList row)+ moreRowsExp <- mapM (renderPGTValueRow cteNames colItems . NE.toList) moreRows pure $ ConE 'S.Values `AppE` firstRowExp `AppE` ListE moreRowsExp -renderPGTValueRow :: [PGT_AST.InsertColumnItem] -> [PGT_AST.AExpr] -> Q Exp-renderPGTValueRow colItems exprs- | length colItems /= length exprs =- fail "Mismatched number of column names and values in INSERT statement."- | otherwise = do- processedItems <- zipWithM processItem colItems exprs- pure $ foldr nvpToCons (ConE 'S.Nil) processedItems- where- nvpToCons :: Exp -> Exp -> Exp- nvpToCons item acc = ConE '(S.:*) `AppE` item `AppE` acc+renderPGTValueRow :: [Text.Text] -> [PGT_AST.InsertColumnItem] -> [PGT_AST.AExpr] -> Q Exp+renderPGTValueRow cteNames colItems exprs+ | length colItems /= length exprs =+ fail "Mismatched number of column names and values in INSERT statement."+ | otherwise = do+ processedItems <- zipWithM processItem colItems exprs+ pure $ foldr nvpToCons (ConE 'S.Nil) processedItems+ where+ nvpToCons :: Exp -> Exp -> Exp+ nvpToCons item acc = ConE '(S.:*) `AppE` item `AppE` acc - processItem :: PGT_AST.InsertColumnItem -> PGT_AST.AExpr -> Q Exp- processItem (PGT_AST.InsertColumnItem colId maybeIndirection) expr = do- when (isJust maybeIndirection) $- fail "INSERT with indirection (e.g., array access) is not supported."- let- colNameStr = Text.unpack (getIdentText colId)- case expr of- PGT_AST.DefaultAExpr ->- -- Check for DEFAULT keyword- pure $- VarE 'S.as- `AppE` ConE 'S.Default- `AppE` LabelE colNameStr- _ -> do- renderedExpr <- renderPGTAExpr expr- pure $- VarE 'S.as- `AppE` (ConE 'S.Set `AppE` renderedExpr)- `AppE` LabelE colNameStr+ processItem :: PGT_AST.InsertColumnItem -> PGT_AST.AExpr -> Q Exp+ processItem (PGT_AST.InsertColumnItem colId maybeIndirection) expr = do+ when (isJust maybeIndirection) $+ fail "INSERT with indirection (e.g., array access) is not supported."+ let+ colNameStr = Text.unpack (getIdentText colId)+ case expr of+ PGT_AST.DefaultAExpr ->+ -- Check for DEFAULT keyword+ pure $+ VarE 'S.as+ `AppE` ConE 'S.Default+ `AppE` LabelE colNameStr+ _ -> do+ renderedExpr <- renderPGTAExpr cteNames expr+ pure $+ VarE 'S.as+ `AppE` (ConE 'S.Set `AppE` renderedExpr)+ `AppE` LabelE colNameStr
src/Squeal/QuasiQuotes/Query.hs view
@@ -1,568 +1,1603 @@-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# LANGUAGE ViewPatterns #-}---- | Description: Translate query expressions.-module Squeal.QuasiQuotes.Query (- toSquealQuery,-) where--import Control.Monad (unless, when)-import Data.Foldable (Foldable(foldl', foldr, null))-import Data.Maybe (fromMaybe, isJust, isNothing)-import Language.Haskell.TH.Syntax- ( Exp(AppE, ConE, InfixE, LabelE, ListE, LitE, VarE), Lit(IntegerL), Q, mkName- )-import Prelude- ( Applicative(pure), Bool(False, True), Either(Left, Right)- , Maybe(Just, Nothing), MonadFail(fail), Num((+)), Ord((>=)), Semigroup((<>))- , Show(show), Traversable(mapM), ($), (&&), (<$>), Int, fromIntegral, zip- )-import Squeal.QuasiQuotes.Common- ( getIdentText, renderPGTAExpr, renderPGTTableRef, renderPGTTargeting- )-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---toSquealQuery :: PGT_AST.SelectStmt -> Q Exp-toSquealQuery selectStmt = case selectStmt of- Left selectNoParens -> toSquealSelectNoParens selectNoParens- Right selectWithParens -> toSquealSelectWithParens selectWithParens---toSquealSelectWithParens :: PGT_AST.SelectWithParens -> Q Exp-toSquealSelectWithParens = \case- PGT_AST.NoParensSelectWithParens snp -> toSquealSelectNoParens snp- PGT_AST.WithParensSelectWithParens swp ->- {- The AST structure itself should handle precedence. Just recurse. -}- toSquealSelectWithParens swp---toSquealSelectNoParens :: PGT_AST.SelectNoParens -> Q Exp-toSquealSelectNoParens- ( PGT_AST.SelectNoParens- maybeWithClause- selectClause- maybeSortClause- maybeSelectLimit- maybeForLockingClause- ) = do- when (isJust maybeWithClause) $ fail "WITH clauses are not supported yet."- case selectClause of- Left simpleSelect ->- toSquealSimpleSelect- simpleSelect- maybeSortClause- maybeSelectLimit- maybeForLockingClause- Right selectWithParens' -> toSquealSelectWithParens selectWithParens'---toSquealSimpleSelect- :: PGT_AST.SimpleSelect- -> Maybe PGT_AST.SortClause- -> Maybe PGT_AST.SelectLimit- -> Maybe PGT_AST.ForLockingClause- -> Q Exp-toSquealSimpleSelect simpleSelect maybeSortClause maybeSelectLimit maybeForLockingClause =- case simpleSelect of- PGT_AST.ValuesSimpleSelect valuesClause -> do- unless- ( isNothing maybeSortClause- && isNothing maybeSelectLimit- && isNothing maybeForLockingClause- )- $ fail- $ "ORDER BY / OFFSET / LIMIT / FOR UPDATE etc. not supported with VALUES clause "- <> "in this translation yet."- renderedValues <- renderValuesClauseToNP valuesClause- pure $ VarE 'S.values_ `AppE` renderedValues- PGT_AST.NormalSimpleSelect- maybeTargeting- maybeIntoClause- maybeFromClause- maybeWhereClause- maybeGroupClause- maybeHavingClause- maybeWindowClause ->- do- targeting <-- case maybeTargeting of- Nothing ->- fail "SELECT without a selection list is not supported."- Just targeting -> pure targeting- case- ( maybeFromClause- , maybeGroupClause- , maybeHavingClause- , maybeIntoClause- , maybeSelectLimit- , maybeWhereClause- , maybeWindowClause- )- of- ( Nothing- , Nothing- , Nothing- , Nothing- , Nothing- , Nothing- , Nothing- ) ->- do- -- Case: SELECT <targeting_list> (no FROM, no other clauses)- -- Translate to S.values_- renderedTargetingForValues <-- renderPGTTargetingForValues targeting- pure $- VarE 'S.values_ `AppE` renderedTargetingForValues- (Nothing, _, _, _, _, _, _) ->- {-- Case: SELECT <targeting_list> (no FROM, but other- clauses are present)- -}- fail $- "SELECT with targeting but no FROM clause cannot have "- <> "other clauses like INTO, WHERE, GROUP BY, HAVING, "- <> "WINDOW, or LIMIT/OFFSET."- (Just fromClause, _, _, _, _, _, _) -> do- -- Case: SELECT ... FROM ... (original logic)-- when (isJust maybeIntoClause) $- fail "INTO clause is not yet supported in this translation."- when (isJust maybeWindowClause) $- fail $- "WINDOW clause is not yet supported in this translation "- <> "for NormalSimpleSelect with FROM."-- renderedFromClauseExp <- renderPGTTableRef fromClause- let- baseTableExpr = VarE 'S.from `AppE` renderedFromClauseExp-- tableExprWithWhere <-- case maybeWhereClause of- Nothing -> pure baseTableExpr- Just wc -> do- renderedWC <- renderPGTAExpr wc- pure $- InfixE- (Just baseTableExpr)- (VarE '(S.&))- (Just (AppE (VarE 'S.where_) renderedWC))-- tableExprWithGroupBy <-- applyPGTGroupBy tableExprWithWhere maybeGroupClause-- tableExprWithHaving <-- case maybeHavingClause of- Nothing -> pure tableExprWithGroupBy- Just hc -> do- when (isNothing maybeGroupClause) $- fail "HAVING clause requires a GROUP BY clause."- renderedHC <- renderPGTAExpr hc- pure $- InfixE- (Just tableExprWithGroupBy)- (VarE '(S.&))- (Just (AppE (VarE 'S.having) renderedHC))-- tableExprWithOrderBy <-- case maybeSortClause of- Nothing -> pure tableExprWithHaving- Just sortClause -> do- renderedSC <- renderPGTSortClause sortClause- pure $- InfixE- (Just tableExprWithHaving)- (VarE '(S.&))- (Just (AppE (VarE 'S.orderBy) renderedSC))-- (tableExprWithOffset, mTableExprWithLimit) <-- processSelectLimit tableExprWithOrderBy maybeSelectLimit-- let- baseFinalTableExpr =- fromMaybe tableExprWithOffset mTableExprWithLimit-- -- Apply FOR LOCKING clause if present- finalTableExprWithPotentialLocking <-- case maybeForLockingClause of- Nothing -> pure baseFinalTableExpr- Just flc -> do- lockingClauseExps <- renderPGTForLockingClauseItems flc- pure $- foldl'- ( \accTableExpr lockingClauseExp ->- InfixE- (Just accTableExpr)- (VarE '(S.&))- (Just (AppE (VarE 'S.lockRows) lockingClauseExp))- )- baseFinalTableExpr- lockingClauseExps-- (selectionTargetExp, maybeDistinctOnExprs) <-- renderPGTTargeting targeting-- squealSelectFn <-- case maybeDistinctOnExprs of- Nothing ->- case targeting of- PGT_AST.DistinctTargeting Nothing _ ->- pure $ VarE 'S.selectDistinct- _ -> pure $ VarE 'S.select -- Normal or ALL- Just distinctOnAstExprs -> do- distinctOnSquealSortExps <-- renderPGTOnExpressionsClause distinctOnAstExprs- pure $- VarE 'S.selectDistinctOn- `AppE` distinctOnSquealSortExps-- pure $- squealSelectFn- `AppE` selectionTargetExp- `AppE` finalTableExprWithPotentialLocking- unsupportedSimpleSelect ->- fail $- "Unsupported simple select statement: "- <> show unsupportedSimpleSelect----- Helper for VALUES clause: Assumes S.values_ for a single row of values.--- PGT_AST.ValuesClause is NonEmpty (NonEmpty PGT_AST.AExpr)-renderValuesClauseToNP :: PGT_AST.ValuesClause -> Q Exp-renderValuesClauseToNP (firstRowExps NE.:| restRowExps) = do- unless (null restRowExps) $- fail $- "Multi-row VALUES clause requires S.values, this translation "- <> "currently supports single row S.values_."- convertRowToNP firstRowExps- where- convertRowToNP :: NE.NonEmpty PGT_AST.AExpr -> Q Exp- convertRowToNP exprs =- go (NE.toList exprs) 1- where- go :: [PGT_AST.AExpr] -> Int -> Q Exp- go [] _ = pure $ ConE 'S.Nil- go (expr : fs) idx = do- renderedExpr <- renderPGTAExpr expr- let- aliasText = "_column" <> show idx -- Default alias for VALUES- aliasedExp = VarE 'S.as `AppE` renderedExpr `AppE` LabelE aliasText- restExp <- go fs (idx + 1) -- restExp is Exp here- -- Correct construction: aliasedExp :* restExp- pure $ ConE '(S.:*) `AppE` aliasedExp `AppE` restExp---renderPGTForLockingClauseItems :: PGT_AST.ForLockingClause -> Q [Exp]-renderPGTForLockingClauseItems = \case- PGT_AST.ReadOnlyForLockingClause ->- fail $- "FOR READ ONLY is not supported as a row-level locking "- <> "clause by Squeal-QQ."- PGT_AST.ItemsForLockingClause itemsNe ->- mapM renderPGTForLockingItem (NE.toList itemsNe)---renderPGTForLockingItem :: PGT_AST.ForLockingItem -> Q Exp-renderPGTForLockingItem- ( PGT_AST.ForLockingItem- strength- maybeTables- waitingOpt- ) = do- squealStrength <- renderPGTForLockingStrength strength- squealTables <-- case maybeTables of- Nothing ->- {- Empty list for "OF" tables means all tables in query -}- pure $ ConE 'S.Nil- Just tablesNe -> do- aliasExps <-- mapM- ( \qn -> case qn of- PGT_AST.SimpleQualifiedName ident ->- pure $ LabelE (Text.unpack $ getIdentText ident)- _ ->- fail $- "Qualified table names like schema.table in "- <> "FOR UPDATE/SHARE OF clauses are not yet "- <> "supported. Please use simple table aliases "- <> "that refer to tables in the FROM clause."- )- (NE.toList tablesNe)- pure $- foldr- (\itemExp acc -> ConE '(S.:*) `AppE` itemExp `AppE` acc)- (ConE 'S.Nil)- aliasExps-- squealWaiting <- renderPGTWaiting waitingOpt-- pure $- ConE 'S.For `AppE` squealStrength `AppE` squealTables `AppE` squealWaiting---renderPGTForLockingStrength :: PGT_AST.ForLockingStrength -> Q Exp-renderPGTForLockingStrength = \case- PGT_AST.UpdateForLockingStrength -> pure $ ConE 'S.Update- PGT_AST.NoKeyUpdateForLockingStrength -> pure $ ConE 'S.NoKeyUpdate- PGT_AST.ShareForLockingStrength -> pure $ ConE 'S.Share- PGT_AST.KeyForLockingStrength -> pure $ ConE 'S.KeyShare---renderPGTWaiting :: Maybe Bool -> Q Exp-renderPGTWaiting = \case- Nothing -> pure $ ConE 'S.Wait -- Default (no NOWAIT or SKIP LOCKED)- Just False -> pure $ ConE 'S.NoWait -- NOWAIT- Just True -> pure $ ConE 'S.SkipLocked -- SKIP LOCKED---applyPGTGroupBy :: Exp -> Maybe PGT_AST.GroupClause -> Q Exp-applyPGTGroupBy currentTableExpr = \case- Nothing -> pure currentTableExpr- Just groupClause -> do- renderedGB <- renderPGTGroupByClauseElements groupClause- pure $- InfixE- (Just currentTableExpr)- (VarE '(S.&))- (Just (AppE (VarE 'S.groupBy) renderedGB))- where- renderPGTGroupByClauseElements :: PGT_AST.GroupClause -> Q Exp- renderPGTGroupByClauseElements = \case- PGT_AST.EmptyGroupingSetGroupByItem NE.:| [] ->- pure $ ConE 'S.Nil- groupByItems -> do- renderedExprs <- mapM renderPGTGroupByItem (NE.toList groupByItems)- pure $- foldr- (\expr acc -> ConE '(S.:*) `AppE` expr `AppE` acc)- (ConE 'S.Nil)- renderedExprs---renderPGTGroupByItem :: PGT_AST.GroupByItem -> Q Exp-renderPGTGroupByItem = \case- PGT_AST.ExprGroupByItem scalarExpr -> renderPGTAExpr scalarExpr- PGT_AST.EmptyGroupingSetGroupByItem -> pure (ConE 'S.Nil)- unsupportedGroup ->- fail $- "Unsupported grouping expression: " <> show unsupportedGroup---processSelectLimit :: Exp -> Maybe PGT_AST.SelectLimit -> Q (Exp, Maybe Exp)-processSelectLimit tableExpr Nothing = pure (tableExpr, Nothing)-processSelectLimit tableExpr (Just selectLimit) = do- let- (maybeOffsetClause, maybeLimitClause) = case selectLimit of- PGT_AST.LimitOffsetSelectLimit lim off -> (Just off, Just lim)- PGT_AST.OffsetLimitSelectLimit off lim -> (Just off, Just lim)- PGT_AST.LimitSelectLimit lim -> (Nothing, Just lim)- PGT_AST.OffsetSelectLimit off -> (Just off, Nothing)-- tableExprWithOffset <-- case maybeOffsetClause of- Nothing -> pure tableExpr- Just offsetVal -> do- offsetExp <- renderPGTOffsetClause offsetVal- pure $- InfixE- (Just tableExpr)- (VarE '(S.&))- (Just (AppE (VarE 'S.offset) offsetExp))-- case maybeLimitClause of- Nothing -> pure (tableExprWithOffset, Nothing)- Just limitVal -> do- limitExp <- renderPGTLimitClause limitVal- pure- ( tableExprWithOffset- , Just- ( InfixE- (Just tableExprWithOffset)- (VarE '(S.&))- (Just (AppE (VarE 'S.limit) limitExp))- )- )---renderPGTLimitClause :: PGT_AST.LimitClause -> Q Exp-renderPGTLimitClause = \case- PGT_AST.LimitLimitClause slValue mOffsetVal -> do- when (isJust mOffsetVal) $- fail- "LIMIT with comma (e.g. LIMIT x, y) is not supported. Use separate LIMIT and OFFSET clauses."- case slValue of- PGT_AST.ExprSelectLimitValue- ( PGT_AST.CExprAExpr- ( PGT_AST.FuncCExpr- ( PGT_AST.ApplicationFuncExpr- ( PGT_AST.FuncApplication- (PGT_AST.TypeFuncName (PGT_AST.UnquotedIdent "inline"))- ( Just- ( PGT_AST.NormalFuncApplicationParams- Nothing- ( PGT_AST.ExprFuncArgExpr- ( PGT_AST.CExprAExpr- (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref ident Nothing))- )- NE.:| []- )- Nothing- )- )- )- Nothing- Nothing- Nothing- )- )- ) -> pure $ VarE (mkName (Text.unpack (getIdentText ident)))- PGT_AST.ExprSelectLimitValue- (PGT_AST.CExprAExpr (PGT_AST.AexprConstCExpr (PGT_AST.IAexprConst n))) ->- if n >= 0- then pure (LitE (IntegerL (fromIntegral n)))- else fail $ "LIMIT value must be non-negative: " <> show n- PGT_AST.AllSelectLimitValue ->- fail "LIMIT ALL not supported in this translation."- expr -> fail $ "Unsupported LIMIT expression: " <> show expr- PGT_AST.FetchOnlyLimitClause{} ->- fail "FETCH clause is not fully supported yet."---renderPGTOffsetClause :: PGT_AST.OffsetClause -> Q Exp-renderPGTOffsetClause = \case- PGT_AST.ExprOffsetClause- ( PGT_AST.CExprAExpr- ( PGT_AST.FuncCExpr- ( PGT_AST.ApplicationFuncExpr- ( PGT_AST.FuncApplication- (PGT_AST.TypeFuncName (PGT_AST.UnquotedIdent "inline"))- ( Just- ( PGT_AST.NormalFuncApplicationParams- Nothing- ( PGT_AST.ExprFuncArgExpr- ( PGT_AST.CExprAExpr- (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref ident Nothing))- )- NE.:| []- )- Nothing- )- )- )- Nothing- Nothing- Nothing- )- )- ) -> pure $ VarE (mkName (Text.unpack (getIdentText ident)))- PGT_AST.ExprOffsetClause- (PGT_AST.CExprAExpr (PGT_AST.AexprConstCExpr (PGT_AST.IAexprConst n))) ->- if n >= 0- then pure (LitE (IntegerL (fromIntegral n)))- else fail $ "OFFSET value must be non-negative: " <> show n- PGT_AST.ExprOffsetClause expr ->- fail $- "Unsupported OFFSET expression: " <> show expr- PGT_AST.FetchFirstOffsetClause{} ->- fail "OFFSET with FETCH FIRST clause is not supported yet."----- Helper to render a single TargetEl for S.values_--- Each expression must be aliased.-renderPGTTargetElForValues :: PGT_AST.TargetEl -> Int -> Q Exp-renderPGTTargetElForValues targetEl idx = do- (exprAST, mUserAlias) <-- case targetEl of- PGT_AST.AliasedExprTargetEl e an -> pure (e, Just an)- PGT_AST.ImplicitlyAliasedExprTargetEl e an -> pure (e, Just an)- PGT_AST.ExprTargetEl e -> pure (e, Nothing)- PGT_AST.AsteriskTargetEl ->- fail "SELECT * is not supported unless there is a from clause."- renderedScalarExp <- renderPGTAExpr exprAST- let- aliasLabelStr =- case mUserAlias of- Just ident -> Text.unpack $ getIdentText ident- Nothing -> "_col" <> show idx -- Default alias for VALUES items- pure $ VarE 'S.as `AppE` renderedScalarExp `AppE` LabelE aliasLabelStr----- Helper to render a TargetList into an NP list for S.values_-renderPGTTargetListForValues :: PGT_AST.TargetList -> Q Exp-renderPGTTargetListForValues (item NE.:| items) = do- renderedItems <-- mapM- (\(el, idx) -> renderPGTTargetElForValues el idx)- (zip (item : items) [1 ..])- -- Construct NP list: e1 :* e2 :* ... :* Nil- -- Each element in renderedItems is an Exp.- -- The result of the fold should be an Exp.- -- Then pure the final Exp.- pure $- foldr- (\hd acc -> ConE '(S.:*) `AppE` hd `AppE` acc)- (ConE 'S.Nil)- renderedItems----- New function to render Targeting specifically for S.values_-renderPGTTargetingForValues :: PGT_AST.Targeting -> Q Exp-renderPGTTargetingForValues = \case- PGT_AST.NormalTargeting targetList -> renderPGTTargetListForValues targetList- PGT_AST.AllTargeting (Just targetList) ->- renderPGTTargetListForValues targetList- PGT_AST.AllTargeting Nothing ->- fail $- "SELECT * (ALL targeting without a list) is not supported "- <> "with VALUES clause."- PGT_AST.DistinctTargeting{} ->- -- Handles both DISTINCT and DISTINCT ON- fail $- "DISTINCT and DISTINCT ON queries are not supported with VALUES clause in "- <> "this translation."---renderPGTOnExpressionsClause :: [PGT_AST.AExpr] -> Q Exp-renderPGTOnExpressionsClause exprs = do- renderedSortExps <- mapM renderToSortExpr exprs- pure $ ListE renderedSortExps- where- renderToSortExpr :: PGT_AST.AExpr -> Q Exp- renderToSortExpr astExpr = do- squealExpr <- renderPGTAExpr astExpr- -- For DISTINCT ON, the direction (ASC/DESC) and NULLS order- -- are typically specified in the ORDER BY clause.- -- Here, we default to ASC for the SortExpression constructor.- pure $ ConE 'S.Asc `AppE` squealExpr---renderPGTSortClause :: PGT_AST.SortClause -> Q Exp-renderPGTSortClause sortBys = ListE <$> mapM renderPGTSortBy (NE.toList sortBys)---renderPGTSortBy :: PGT_AST.SortBy -> Q Exp-renderPGTSortBy = \case- PGT_AST.AscDescSortBy aExpr maybeAscDesc maybeNullsOrder -> do- squealExpr <- renderPGTAExpr aExpr- let- (asc, desc) = case maybeNullsOrder of- Nothing -> ('S.Asc, 'S.Desc)- Just PGT_AST.FirstNullsOrder -> ('S.AscNullsFirst, 'S.DescNullsFirst)- Just PGT_AST.LastNullsOrder -> ('S.AscNullsLast, 'S.DescNullsLast)-- let- constructor = case maybeAscDesc of- Just PGT_AST.DescAscDesc -> desc- _ -> asc -- default to ASC- pure $ ConE constructor `AppE` squealExpr- PGT_AST.UsingSortBy{} -> fail "ORDER BY USING is not supported"+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE ViewPatterns #-}++-- | Description: Translate query expressions.+module Squeal.QuasiQuotes.Query (+ toSquealQuery,+ renderPGTTableRef,+ renderPGTTargeting,+ renderPGTTargetList,+ renderPGTAExpr,+ getIdentText,+) where++import Control.Applicative (Alternative((<|>)))+import Control.Monad (unless, when)+import Data.Foldable (Foldable(elem, foldl'), foldlM)+import Data.Maybe (fromMaybe, isJust, isNothing)+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((==))+ , Foldable(foldr, length, null), Functor(fmap), Maybe(Just, Nothing)+ , MonadFail(fail), Num((*), (+), (-), fromInteger), Ord((<), (>=))+ , Semigroup((<>)), Show(show), Traversable(mapM), ($), (&&), (.), (<$>), (||)+ , Int, Integer, any, either, error, fromIntegral, id, otherwise, zip+ )+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+++toSquealQuery+ :: [Text.Text]+ -> Maybe (NE.NonEmpty PGT_AST.Ident)+ -> PGT_AST.SelectStmt+ -> Q Exp+toSquealQuery cteNames maybeColAliases selectStmt = case selectStmt of+ Left selectNoParens -> toSquealSelectNoParens cteNames maybeColAliases selectNoParens+ Right selectWithParens -> toSquealSelectWithParens cteNames maybeColAliases selectWithParens+++toSquealSelectWithParens+ :: [Text.Text]+ -> Maybe (NE.NonEmpty PGT_AST.Ident)+ -> PGT_AST.SelectWithParens+ -> Q Exp+toSquealSelectWithParens cteNames maybeColAliases = \case+ PGT_AST.NoParensSelectWithParens snp -> toSquealSelectNoParens cteNames maybeColAliases snp+ PGT_AST.WithParensSelectWithParens swp ->+ {- The AST structure itself should handle precedence. Just recurse. -}+ toSquealSelectWithParens cteNames maybeColAliases swp+++toSquealSelectNoParens+ :: [Text.Text]+ -> Maybe (NE.NonEmpty PGT_AST.Ident)+ -> PGT_AST.SelectNoParens+ -> Q Exp+toSquealSelectNoParens+ initialCteNames+ maybeColAliases+ ( PGT_AST.SelectNoParens+ maybeWithClause+ selectClause+ maybeSortClause+ maybeSelectLimit+ maybeForLockingClause+ ) = do+ (cteNames, renderedWithClause) <-+ case maybeWithClause of+ Nothing -> pure (initialCteNames, Nothing)+ Just withClause -> do+ (names, exp) <- renderPGTWithClause initialCteNames withClause+ pure (names, Just exp)++ squealQueryBody <-+ case selectClause of+ Left simpleSelect ->+ toSquealSimpleSelect+ cteNames+ maybeColAliases+ simpleSelect+ maybeSortClause+ maybeSelectLimit+ maybeForLockingClause+ Right selectWithParens' -> toSquealSelectWithParens cteNames maybeColAliases selectWithParens'++ case renderedWithClause of+ Nothing -> pure squealQueryBody+ Just withExp -> pure $ VarE 'S.with `AppE` withExp `AppE` squealQueryBody+++renderPGTWithClause :: [Text.Text] -> PGT_AST.WithClause -> Q ([Text.Text], Exp)+renderPGTWithClause initialCteNames (PGT_AST.WithClause recursive ctes) = do+ when recursive $ fail "Recursive WITH clauses are not supported yet."+ let+ cteList = NE.toList ctes+ (finalCteNames, renderedCtes) <-+ foldlM+ ( \(names, exps) cte -> do+ (name, exp) <- renderCte names cte+ pure (names <> [name], exps <> [exp])+ )+ (initialCteNames, [])+ cteList++ let+ withExp =+ foldr+ (\cte acc -> ConE '(S.:>>) `AppE` cte `AppE` acc)+ (ConE 'S.Done)+ renderedCtes+ pure (finalCteNames, withExp)+ where+ renderCte :: [Text.Text] -> PGT_AST.CommonTableExpr -> Q (Text.Text, Exp)+ renderCte existingCteNames (PGT_AST.CommonTableExpr ident maybeColNames maybeMaterialized stmt) = do+ when (isJust maybeColNames) $+ fail "Column name lists in CTEs are not supported yet."+ when (isJust maybeMaterialized) $+ fail "MATERIALIZED/NOT MATERIALIZED for CTEs is not supported yet."+ cteQueryExp <-+ case stmt of+ PGT_AST.SelectPreparableStmt selectStmt -> toSquealQuery existingCteNames Nothing selectStmt+ _ -> fail "Only SELECT statements are supported in CTEs."+ let+ cteName = getIdentText ident+ pure+ (cteName, VarE 'S.as `AppE` cteQueryExp `AppE` LabelE (Text.unpack cteName))+++toSquealSimpleSelect+ :: [Text.Text]+ -> Maybe (NE.NonEmpty PGT_AST.Ident)+ -> PGT_AST.SimpleSelect+ -> Maybe PGT_AST.SortClause+ -> Maybe PGT_AST.SelectLimit+ -> Maybe PGT_AST.ForLockingClause+ -> Q Exp+toSquealSimpleSelect cteNames maybeColAliases simpleSelect maybeSortClause maybeSelectLimit maybeForLockingClause =+ case simpleSelect of+ PGT_AST.ValuesSimpleSelect valuesClause -> do+ unless+ ( isNothing maybeSortClause+ && isNothing maybeSelectLimit+ && isNothing maybeForLockingClause+ )+ $ fail+ $ "ORDER BY / OFFSET / LIMIT / FOR UPDATE etc. not supported with VALUES clause "+ <> "in this translation yet."+ renderedValues <- renderValuesClauseToNP cteNames maybeColAliases valuesClause+ pure $ VarE 'S.values_ `AppE` renderedValues+ PGT_AST.NormalSimpleSelect+ maybeTargeting+ maybeIntoClause+ maybeFromClause+ maybeWhereClause+ maybeGroupClause+ maybeHavingClause+ maybeWindowClause ->+ do+ targeting <-+ case maybeTargeting of+ Nothing ->+ fail "SELECT without a selection list is not supported."+ Just targeting -> pure targeting+ case+ ( maybeFromClause+ , maybeGroupClause+ , maybeHavingClause+ , maybeIntoClause+ , maybeSelectLimit+ , maybeWhereClause+ , maybeWindowClause+ )+ of+ ( Nothing+ , Nothing+ , Nothing+ , Nothing+ , Nothing+ , Nothing+ , Nothing+ ) ->+ do+ -- Case: SELECT <targeting_list> (no FROM, no other clauses)+ -- Translate to S.values_+ renderedTargetingForValues <-+ renderPGTTargetingForValues cteNames targeting+ pure $+ VarE 'S.values_ `AppE` renderedTargetingForValues+ (Nothing, _, _, _, _, _, _) ->+ {-+ Case: SELECT <targeting_list> (no FROM, but other+ clauses are present)+ -}+ fail $+ "SELECT with targeting but no FROM clause cannot have "+ <> "other clauses like INTO, WHERE, GROUP BY, HAVING, "+ <> "WINDOW, or LIMIT/OFFSET."+ (Just fromClause, _, _, _, _, _, _) -> do+ -- Case: SELECT ... FROM ... (original logic)++ when (isJust maybeIntoClause) $+ fail "INTO clause is not yet supported in this translation."+ when (isJust maybeWindowClause) $+ fail $+ "WINDOW clause is not yet supported in this translation "+ <> "for NormalSimpleSelect with FROM."++ renderedFromClauseExp <- renderPGTTableRef cteNames fromClause+ let+ baseTableExpr = VarE 'S.from `AppE` renderedFromClauseExp++ tableExprWithWhere <-+ case maybeWhereClause of+ Nothing -> pure baseTableExpr+ Just wc -> do+ renderedWC <- renderPGTAExpr cteNames wc+ pure $+ InfixE+ (Just baseTableExpr)+ (VarE '(S.&))+ (Just (AppE (VarE 'S.where_) renderedWC))++ tableExprWithGroupBy <-+ applyPGTGroupBy cteNames tableExprWithWhere maybeGroupClause++ tableExprWithHaving <-+ case maybeHavingClause of+ Nothing -> pure tableExprWithGroupBy+ Just hc -> do+ when (isNothing maybeGroupClause) $+ fail "HAVING clause requires a GROUP BY clause."+ renderedHC <- renderPGTAExpr cteNames hc+ pure $+ InfixE+ (Just tableExprWithGroupBy)+ (VarE '(S.&))+ (Just (AppE (VarE 'S.having) renderedHC))++ tableExprWithOrderBy <-+ case maybeSortClause of+ Nothing -> pure tableExprWithHaving+ Just sortClause -> do+ renderedSC <- renderPGTSortClause cteNames sortClause+ pure $+ InfixE+ (Just tableExprWithHaving)+ (VarE '(S.&))+ (Just (AppE (VarE 'S.orderBy) renderedSC))++ (tableExprWithOffset, mTableExprWithLimit) <-+ processSelectLimit cteNames tableExprWithOrderBy maybeSelectLimit++ let+ baseFinalTableExpr =+ fromMaybe tableExprWithOffset mTableExprWithLimit++ -- Apply FOR LOCKING clause if present+ finalTableExprWithPotentialLocking <-+ case maybeForLockingClause of+ Nothing -> pure baseFinalTableExpr+ Just flc -> do+ lockingClauseExps <- renderPGTForLockingClauseItems flc+ pure $+ foldl'+ ( \accTableExpr lockingClauseExp ->+ InfixE+ (Just accTableExpr)+ (VarE '(S.&))+ (Just (AppE (VarE 'S.lockRows) lockingClauseExp))+ )+ baseFinalTableExpr+ lockingClauseExps++ (selectionTargetExp, maybeDistinctOnExprs) <-+ renderPGTTargeting cteNames targeting++ squealSelectFn <-+ case maybeDistinctOnExprs of+ Nothing ->+ case targeting of+ PGT_AST.DistinctTargeting Nothing _ ->+ pure $ VarE 'S.selectDistinct+ _ -> pure $ VarE 'S.select -- Normal or ALL+ Just distinctOnAstExprs -> do+ distinctOnSquealSortExps <-+ renderPGTOnExpressionsClause cteNames distinctOnAstExprs+ pure $+ VarE 'S.selectDistinctOn+ `AppE` distinctOnSquealSortExps++ pure $+ squealSelectFn+ `AppE` selectionTargetExp+ `AppE` finalTableExprWithPotentialLocking+ unsupportedSimpleSelect ->+ fail $+ "Unsupported simple select statement: "+ <> show unsupportedSimpleSelect+++-- Helper for VALUES clause: Assumes S.values_ for a single row of values.+-- PGT_AST.ValuesClause is NonEmpty (NonEmpty PGT_AST.AExpr)+renderValuesClauseToNP+ :: [Text.Text]+ -> Maybe (NE.NonEmpty PGT_AST.Ident)+ -> PGT_AST.ValuesClause+ -> Q Exp+renderValuesClauseToNP cteNames maybeColAliases (firstRowExps NE.:| restRowExps) = do+ unless (null restRowExps) $+ fail $+ "Multi-row VALUES clause requires S.values, this translation "+ <> "currently supports single row S.values_."+ convertRowToNP firstRowExps+ where+ colAliasTexts = fmap (fmap getIdentText . NE.toList) maybeColAliases++ convertRowToNP :: NE.NonEmpty PGT_AST.AExpr -> Q Exp+ convertRowToNP exprs = do+ let+ exprList = NE.toList exprs+ aliasTexts <-+ case colAliasTexts of+ Just aliases ->+ if length aliases == length exprList+ then pure aliases+ else+ fail+ "Number of column aliases in CTE does not match number of columns in VALUES clause."+ Nothing -> pure $ fmap (Text.pack . ("_column" <>) . show) [1 :: Int ..]+ go (zip exprList aliasTexts)+ where+ go :: [(PGT_AST.AExpr, Text.Text)] -> Q Exp+ go [] = pure $ ConE 'S.Nil+ go ((expr, aliasText) : fs) = do+ renderedExpr <- renderPGTAExpr cteNames expr+ let+ aliasedExp = VarE 'S.as `AppE` renderedExpr `AppE` LabelE (Text.unpack aliasText)+ restExp <- go fs+ pure $ ConE '(S.:*) `AppE` aliasedExp `AppE` restExp+++renderPGTForLockingClauseItems :: PGT_AST.ForLockingClause -> Q [Exp]+renderPGTForLockingClauseItems = \case+ PGT_AST.ReadOnlyForLockingClause ->+ fail $+ "FOR READ ONLY is not supported as a row-level locking "+ <> "clause by Squeal-QQ."+ PGT_AST.ItemsForLockingClause itemsNe ->+ mapM renderPGTForLockingItem (NE.toList itemsNe)+++renderPGTForLockingItem :: PGT_AST.ForLockingItem -> Q Exp+renderPGTForLockingItem+ ( PGT_AST.ForLockingItem+ strength+ maybeTables+ waitingOpt+ ) = do+ squealStrength <- renderPGTForLockingStrength strength+ squealTables <-+ case maybeTables of+ Nothing ->+ {- Empty list for "OF" tables means all tables in query -}+ pure $ ConE 'S.Nil+ Just tablesNe -> do+ aliasExps <-+ mapM+ ( \qn -> case qn of+ PGT_AST.SimpleQualifiedName ident ->+ pure $ LabelE (Text.unpack $ getIdentText ident)+ _ ->+ fail $+ "Qualified table names like schema.table in "+ <> "FOR UPDATE/SHARE OF clauses are not yet "+ <> "supported. Please use simple table aliases "+ <> "that refer to tables in the FROM clause."+ )+ (NE.toList tablesNe)+ pure $+ foldr+ (\itemExp acc -> ConE '(S.:*) `AppE` itemExp `AppE` acc)+ (ConE 'S.Nil)+ aliasExps++ squealWaiting <- renderPGTWaiting waitingOpt++ pure $+ ConE 'S.For `AppE` squealStrength `AppE` squealTables `AppE` squealWaiting+++renderPGTForLockingStrength :: PGT_AST.ForLockingStrength -> Q Exp+renderPGTForLockingStrength = \case+ PGT_AST.UpdateForLockingStrength -> pure $ ConE 'S.Update+ PGT_AST.NoKeyUpdateForLockingStrength -> pure $ ConE 'S.NoKeyUpdate+ PGT_AST.ShareForLockingStrength -> pure $ ConE 'S.Share+ PGT_AST.KeyForLockingStrength -> pure $ ConE 'S.KeyShare+++renderPGTWaiting :: Maybe Bool -> Q Exp+renderPGTWaiting = \case+ Nothing -> pure $ ConE 'S.Wait -- Default (no NOWAIT or SKIP LOCKED)+ Just False -> pure $ ConE 'S.NoWait -- NOWAIT+ Just True -> pure $ ConE 'S.SkipLocked -- SKIP LOCKED+++applyPGTGroupBy :: [Text.Text] -> Exp -> Maybe PGT_AST.GroupClause -> Q Exp+applyPGTGroupBy cteNames currentTableExpr = \case+ Nothing -> pure currentTableExpr+ Just groupClause -> do+ renderedGB <- renderPGTGroupByClauseElements cteNames groupClause+ pure $+ InfixE+ (Just currentTableExpr)+ (VarE '(S.&))+ (Just (AppE (VarE 'S.groupBy) renderedGB))+++renderPGTGroupByClauseElements :: [Text.Text] -> PGT_AST.GroupClause -> Q Exp+renderPGTGroupByClauseElements cteNames = \case+ PGT_AST.EmptyGroupingSetGroupByItem NE.:| [] ->+ pure $ ConE 'S.Nil+ groupByItems -> do+ renderedExprs <- mapM (renderPGTGroupByItem cteNames) (NE.toList groupByItems)+ pure $+ foldr+ (\expr acc -> ConE '(S.:*) `AppE` expr `AppE` acc)+ (ConE 'S.Nil)+ renderedExprs++renderPGTGroupByItem :: [Text.Text] -> PGT_AST.GroupByItem -> Q Exp+renderPGTGroupByItem cteNames = \case+ PGT_AST.ExprGroupByItem scalarExpr -> renderPGTAExpr cteNames scalarExpr+ PGT_AST.EmptyGroupingSetGroupByItem -> pure (ConE 'S.Nil)+ unsupportedGroup ->+ fail $+ "Unsupported grouping expression: " <> show unsupportedGroup+++processSelectLimit :: [Text.Text] -> Exp -> Maybe PGT_AST.SelectLimit -> Q (Exp, Maybe Exp)+processSelectLimit _cteNames tableExpr Nothing = pure (tableExpr, Nothing)+processSelectLimit cteNames tableExpr (Just selectLimit) = do+ let+ (maybeOffsetClause, maybeLimitClause) = case selectLimit of+ PGT_AST.LimitOffsetSelectLimit lim off -> (Just off, Just lim)+ PGT_AST.OffsetLimitSelectLimit off lim -> (Just off, Just lim)+ PGT_AST.LimitSelectLimit lim -> (Nothing, Just lim)+ PGT_AST.OffsetSelectLimit off -> (Just off, Nothing)++ tableExprWithOffset <-+ case maybeOffsetClause of+ Nothing -> pure tableExpr+ Just offsetVal -> do+ offsetExp <- renderPGTOffsetClause cteNames offsetVal+ pure $+ InfixE+ (Just tableExpr)+ (VarE '(S.&))+ (Just (AppE (VarE 'S.offset) offsetExp))++ case maybeLimitClause of+ Nothing -> pure (tableExprWithOffset, Nothing)+ Just limitVal -> do+ limitExp <- renderPGTLimitClause cteNames limitVal+ pure+ ( tableExprWithOffset+ , Just+ ( InfixE+ (Just tableExprWithOffset)+ (VarE '(S.&))+ (Just (AppE (VarE 'S.limit) limitExp))+ )+ )+++renderPGTLimitClause :: [Text.Text] -> PGT_AST.LimitClause -> Q Exp+renderPGTLimitClause cteNames = \case+ PGT_AST.LimitLimitClause slValue mOffsetVal -> do+ when (isJust mOffsetVal) $+ fail+ "LIMIT with comma (e.g. LIMIT x, y) is not supported. Use separate LIMIT and OFFSET clauses."+ case slValue of+ PGT_AST.ExprSelectLimitValue+ ( PGT_AST.CExprAExpr+ ( PGT_AST.FuncCExpr+ ( PGT_AST.ApplicationFuncExpr+ ( PGT_AST.FuncApplication+ (PGT_AST.TypeFuncName (PGT_AST.UnquotedIdent "inline"))+ ( Just+ ( PGT_AST.NormalFuncApplicationParams+ Nothing+ ( PGT_AST.ExprFuncArgExpr+ ( PGT_AST.CExprAExpr+ (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref ident Nothing))+ )+ NE.:| []+ )+ Nothing+ )+ )+ )+ Nothing+ Nothing+ Nothing+ )+ )+ ) -> pure $ VarE (mkName (Text.unpack (getIdentText ident)))+ PGT_AST.ExprSelectLimitValue+ (PGT_AST.CExprAExpr (PGT_AST.AexprConstCExpr (PGT_AST.IAexprConst n))) ->+ if n >= 0+ then pure (LitE (IntegerL (fromIntegral n)))+ else fail $ "LIMIT value must be non-negative: " <> show n+ PGT_AST.AllSelectLimitValue ->+ fail "LIMIT ALL not supported in this translation."+ PGT_AST.ExprSelectLimitValue expr -> renderPGTAExpr cteNames expr+ PGT_AST.FetchOnlyLimitClause{} ->+ fail "FETCH clause is not fully supported yet."+++renderPGTOffsetClause :: [Text.Text] -> PGT_AST.OffsetClause -> Q Exp+renderPGTOffsetClause cteNames = \case+ PGT_AST.ExprOffsetClause+ ( PGT_AST.CExprAExpr+ ( PGT_AST.FuncCExpr+ ( PGT_AST.ApplicationFuncExpr+ ( PGT_AST.FuncApplication+ (PGT_AST.TypeFuncName (PGT_AST.UnquotedIdent "inline"))+ ( Just+ ( PGT_AST.NormalFuncApplicationParams+ Nothing+ ( PGT_AST.ExprFuncArgExpr+ ( PGT_AST.CExprAExpr+ (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref ident Nothing))+ )+ NE.:| []+ )+ Nothing+ )+ )+ )+ Nothing+ Nothing+ Nothing+ )+ )+ ) -> pure $ VarE (mkName (Text.unpack (getIdentText ident)))+ PGT_AST.ExprOffsetClause+ (PGT_AST.CExprAExpr (PGT_AST.AexprConstCExpr (PGT_AST.IAexprConst n))) ->+ if n >= 0+ then pure (LitE (IntegerL (fromIntegral n)))+ else fail $ "OFFSET value must be non-negative: " <> show n+ PGT_AST.ExprOffsetClause expr -> renderPGTAExpr cteNames expr+ PGT_AST.FetchFirstOffsetClause{} ->+ fail "OFFSET with FETCH FIRST clause is not supported yet."+++-- Helper to render a single TargetEl for S.values_+-- Each expression must be aliased.+renderPGTTargetElForValues :: [Text.Text] -> PGT_AST.TargetEl -> Int -> Q Exp+renderPGTTargetElForValues cteNames targetEl idx = do+ (exprAST, mUserAlias) <-+ case targetEl of+ PGT_AST.AliasedExprTargetEl e an -> pure (e, Just an)+ PGT_AST.ImplicitlyAliasedExprTargetEl e an -> pure (e, Just an)+ PGT_AST.ExprTargetEl e -> pure (e, Nothing)+ PGT_AST.AsteriskTargetEl ->+ fail "SELECT * is not supported unless there is a from clause."+ renderedScalarExp <- renderPGTAExpr cteNames exprAST+ let+ aliasLabelStr =+ case mUserAlias of+ Just ident -> Text.unpack $ getIdentText ident+ Nothing -> "_col" <> show idx -- Default alias for VALUES items+ pure $ VarE 'S.as `AppE` renderedScalarExp `AppE` LabelE aliasLabelStr+++-- Helper to render a TargetList into an NP list for S.values_+renderPGTTargetListForValues :: [Text.Text] -> PGT_AST.TargetList -> Q Exp+renderPGTTargetListForValues cteNames (item NE.:| items) = do+ renderedItems <-+ mapM+ (\(el, idx) -> renderPGTTargetElForValues cteNames el idx)+ (zip (item : items) [1 ..])+ -- Construct NP list: e1 :* e2 :* ... :* Nil+ -- Each element in renderedItems is an Exp.+ -- The result of the fold should be an Exp.+ -- Then pure the final Exp.+ pure $+ foldr+ (\hd acc -> ConE '(S.:*) `AppE` hd `AppE` acc)+ (ConE 'S.Nil)+ renderedItems+++-- New function to render Targeting specifically for S.values_+renderPGTTargetingForValues :: [Text.Text] -> PGT_AST.Targeting -> Q Exp+renderPGTTargetingForValues cteNames = \case+ PGT_AST.NormalTargeting targetList -> renderPGTTargetListForValues cteNames targetList+ PGT_AST.AllTargeting (Just targetList) ->+ renderPGTTargetListForValues cteNames targetList+ PGT_AST.AllTargeting Nothing ->+ fail $+ "SELECT * (ALL targeting without a list) is not supported "+ <> "with VALUES clause."+ PGT_AST.DistinctTargeting{} ->+ -- Handles both DISTINCT and DISTINCT ON+ fail $+ "DISTINCT and DISTINCT ON queries are not supported with VALUES clause in "+ <> "this translation."+++renderPGTOnExpressionsClause :: [Text.Text] -> [PGT_AST.AExpr] -> Q Exp+renderPGTOnExpressionsClause cteNames exprs = do+ renderedSortExps <- mapM renderToSortExpr exprs+ pure $ ListE renderedSortExps+ where+ renderToSortExpr :: PGT_AST.AExpr -> Q Exp+ renderToSortExpr astExpr = do+ squealExpr <- renderPGTAExpr cteNames astExpr+ -- For DISTINCT ON, the direction (ASC/DESC) and NULLS order+ -- are typically specified in the ORDER BY clause.+ -- Here, we default to ASC for the SortExpression constructor.+ pure $ ConE 'S.Asc `AppE` squealExpr+++renderPGTSortClause :: [Text.Text] -> PGT_AST.SortClause -> Q Exp+renderPGTSortClause cteNames sortBys = ListE <$> mapM (renderPGTSortBy cteNames) (NE.toList sortBys)+++renderPGTSortBy :: [Text.Text] -> PGT_AST.SortBy -> Q Exp+renderPGTSortBy cteNames = \case+ PGT_AST.AscDescSortBy aExpr maybeAscDesc maybeNullsOrder -> do+ squealExpr <- renderPGTAExpr cteNames aExpr+ let+ (asc, desc) = case maybeNullsOrder of+ Nothing -> ('S.Asc, 'S.Desc)+ Just PGT_AST.FirstNullsOrder -> ('S.AscNullsFirst, 'S.DescNullsFirst)+ Just PGT_AST.LastNullsOrder -> ('S.AscNullsLast, 'S.DescNullsLast)++ let+ constructor = case maybeAscDesc of+ Just PGT_AST.DescAscDesc -> desc+ _ -> asc -- default to ASC+ pure $ ConE constructor `AppE` squealExpr+ PGT_AST.UsingSortBy{} -> fail "ORDER BY USING is not supported"+++renderPGTTableRef :: [Text.Text] -> NE.NonEmpty PGT_AST.TableRef -> Q Exp+renderPGTTableRef cteNames tableRefs = do+ renderedTableRefs <- mapM (renderSingleTableRef cteNames) (NE.toList tableRefs)+ case renderedTableRefs of+ [] -> fail "Empty FROM clause" -- Should not happen with NonEmpty+ (firstTbl : 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.+ pure $ foldl' (\acc tbl -> VarE 'S.also `AppE` tbl `AppE` acc) firstTbl restTbls+++renderSingleTableRef :: [Text.Text] -> PGT_AST.TableRef -> Q Exp+renderSingleTableRef cteNames = \case+ PGT_AST.RelationExprTableRef relationExpr maybeAliasClause sampleClause -> do+ when (isJust sampleClause) $ fail "TABLESAMPLE clause is not supported yet."+ renderPGTRelationExprTableRef cteNames relationExpr maybeAliasClause+ PGT_AST.JoinTableRef joinedTable 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 maybeAliasClause of+ Just _ ->+ fail+ "Aliasing a JOIN clause directly is not supported. Consider a subquery: (SELECT * FROM ...) AS alias"+ Nothing -> renderPGTJoinedTable cteNames joinedTable+ -- PGT_AST.InParensTableRefTableRef was an incorrect pattern, removing it.+ -- Parenthesized joins are handled by PGT_AST.InParensJoinedTable within renderPGTJoinedTable.+ unsupported ->+ fail $ "Unsupported TableRef type in renderSingleTableRef: " <> show unsupported+++renderPGTJoinedTable :: [Text.Text] -> PGT_AST.JoinedTable -> Q Exp+renderPGTJoinedTable cteNames = \case+ PGT_AST.InParensJoinedTable joinedTable -> renderPGTJoinedTable cteNames joinedTable+ PGT_AST.MethJoinedTable joinMeth leftRef rightRef -> do+ leftTableExp <- renderSingleTableRef cteNames leftRef+ rightTableExp <- renderSingleTableRef cteNames rightRef+ case joinMeth of+ PGT_AST.QualJoinMeth maybeJoinType joinQual ->+ case joinQual of+ PGT_AST.OnJoinQual onConditionAExpr -> do+ onConditionExp <- renderPGTAExpr cteNames onConditionAExpr+ squealJoinFn <-+ case maybeJoinType of+ Just (PGT_AST.LeftJoinType _) -> pure $ VarE 'S.leftOuterJoin+ Just (PGT_AST.RightJoinType _) -> pure $ VarE 'S.rightOuterJoin+ Just (PGT_AST.FullJoinType _) -> pure $ VarE 'S.fullOuterJoin+ Just PGT_AST.InnerJoinType -> pure $ VarE 'S.innerJoin+ Nothing -> pure $ 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 _identsNE ->+ fail "USING join qualification not yet supported"+ PGT_AST.CrossJoinMeth ->+ -- Change: Use S.& for crossJoin: leftTableExp & S.crossJoin rightTableExp+ pure $+ InfixE+ (Just leftTableExp)+ (VarE '(S.&))+ (Just (VarE 'S.crossJoin `AppE` rightTableExp))+ PGT_AST.NaturalJoinMeth _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.+ fail "NATURAL JOIN is not supported by Squeal-QQ."+++renderPGTRelationExprTableRef+ :: [Text.Text] -> PGT_AST.RelationExpr -> Maybe PGT_AST.AliasClause -> Q Exp+renderPGTRelationExprTableRef cteNames relationExpr maybeAliasClause = do+ (tableName, schemaName) <-+ case relationExpr of+ PGT_AST.SimpleRelationExpr (PGT_AST.SimpleQualifiedName ident) _ ->+ pure (getIdentText ident, Nothing)+ PGT_AST.SimpleRelationExpr+ ( PGT_AST.IndirectedQualifiedName+ schemaIdent+ (NE.last -> PGT_AST.AttrNameIndirectionEl tableIdent)+ )+ _ ->+ pure (getIdentText tableIdent, Just (getIdentText schemaIdent))+ _ ->+ fail $+ "Unsupported relation expression: " <> show relationExpr++ aliasStr <-+ case maybeAliasClause of+ Just (PGT_AST.AliasClause _ aliasIdent _) -> pure $ Text.unpack (getIdentText aliasIdent)+ Nothing -> case relationExpr of -- Infer default alias if none provided+ PGT_AST.SimpleRelationExpr (PGT_AST.SimpleQualifiedName ident) _ -> pure $ Text.unpack (getIdentText ident)+ PGT_AST.SimpleRelationExpr+ ( PGT_AST.IndirectedQualifiedName+ _+ (NE.last -> PGT_AST.AttrNameIndirectionEl ident)+ )+ _ -> pure $ Text.unpack (getIdentText ident)+ _ ->+ fail $+ "Cannot determine default alias for relation expression: " <> show relationExpr++ let+ isCte = tableName `elem` cteNames+ squealFn = if isCte then VarE 'S.common else VarE 'S.table++ tableExpr <-+ case schemaName of+ Nothing -> pure $ LabelE (Text.unpack tableName)+ Just schema ->+ if isCte+ then+ fail "CTEs cannot be schema-qualified."+ else+ pure $+ VarE '(S.!)+ `AppE` LabelE (Text.unpack schema)+ `AppE` LabelE (Text.unpack tableName)++ pure $ squealFn `AppE` (VarE 'S.as `AppE` tableExpr `AppE` LabelE aliasStr)+++{- |+ 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+ :: [Text.Text]+ -> PGT_AST.Targeting+ -> Q (Exp, Maybe [PGT_AST.AExpr])+renderPGTTargeting cteNames = \case+ PGT_AST.NormalTargeting targetList -> do+ selListExp <- renderPGTTargetList cteNames targetList+ pure (selListExp, Nothing)+ PGT_AST.AllTargeting maybeTargetList -> do+ selListExp <-+ case maybeTargetList of+ Nothing -> pure $ ConE 'S.Star -- SELECT ALL (which is like SELECT *)+ Just tl -> renderPGTTargetList cteNames tl+ pure (selListExp, Nothing)+ PGT_AST.DistinctTargeting maybeOnExprs targetList -> do+ selListExp <- renderPGTTargetList cteNames targetList+ pure (selListExp, fmap NE.toList maybeOnExprs)+++renderPGTTargetEl :: [Text.Text] -> PGT_AST.TargetEl -> Maybe PGT_AST.Ident -> Int -> Q Exp+renderPGTTargetEl cteNames targetEl mOuterAlias idx =+ let+ (exprAST, mInternalAlias) = case targetEl of+ PGT_AST.AliasedExprTargetEl e an -> (e, Just an)+ PGT_AST.ImplicitlyAliasedExprTargetEl e an -> (e, Just an)+ PGT_AST.ExprTargetEl e -> (e, Nothing)+ PGT_AST.AsteriskTargetEl ->+ ( PGT_AST.CExprAExpr+ ( PGT_AST.AexprConstCExpr+ PGT_AST.NullAexprConst+ )+ , Nothing -- Placeholder for Star, should be S.Star+ )+ finalAliasName = mOuterAlias <|> mInternalAlias+ in+ case targetEl of+ PGT_AST.AsteriskTargetEl -> pure $ ConE 'S.Star+ _ -> do+ renderedScalarExp <- renderPGTAExpr cteNames exprAST+ case exprAST of+ PGT_AST.CExprAExpr (PGT_AST.ColumnrefCExpr _)+ | Nothing <- finalAliasName ->+ pure renderedScalarExp+ _ -> do+ let+ aliasLabelStr =+ case finalAliasName of+ Just ident -> Text.unpack $ getIdentText ident+ Nothing -> "_col" <> show idx+ pure $+ VarE 'S.as+ `AppE` renderedScalarExp+ `AppE` LabelE aliasLabelStr+++renderPGTTargetList :: [Text.Text] -> PGT_AST.TargetList -> Q Exp+renderPGTTargetList cteNames (item NE.:| items) = go (item : items) 1+ where+ isAsterisk :: PGT_AST.TargetEl -> Bool+ isAsterisk PGT_AST.AsteriskTargetEl = True+ isAsterisk _ = False++ isDotStar :: PGT_AST.TargetEl -> Bool+ isDotStar+ ( PGT_AST.ExprTargetEl+ ( PGT_AST.CExprAExpr+ (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref _ (Just indirection)))+ )+ ) =+ any isAllIndirectionEl (NE.toList indirection)+ isDotStar _ = False++ isAllIndirectionEl :: PGT_AST.IndirectionEl -> Bool+ isAllIndirectionEl PGT_AST.AllIndirectionEl = True+ isAllIndirectionEl _ = False++ renderPGTTargetElDotStar :: PGT_AST.TargetEl -> Q Exp+ renderPGTTargetElDotStar+ ( PGT_AST.ExprTargetEl+ ( PGT_AST.CExprAExpr+ ( PGT_AST.ColumnrefCExpr+ ( PGT_AST.Columnref+ qualName+ _ -- indirectionOpt+ )+ )+ )+ ) =+ pure $+ ConE 'S.DotStar+ `AppE` (LabelE (Text.unpack (getIdentText qualName)))+ renderPGTTargetElDotStar _ =+ fail "renderPGTTargetElDotStar called with unexpected TargetEl"++ go :: [PGT_AST.TargetEl] -> Int -> Q Exp+ go [] _ = fail "Empty selection list items in go."+ go [el] currentIdx = renderOne el currentIdx+ go (el : more) currentIdx = do+ renderedEl <- renderOne el currentIdx+ restRendered <- go more (currentIdx + 1)+ pure $ ConE 'S.Also `AppE` restRendered `AppE` renderedEl++ renderOne :: PGT_AST.TargetEl -> Int -> Q Exp+ renderOne el idx+ | isAsterisk el = pure $ ConE 'S.Star+ | isDotStar el = renderPGTTargetElDotStar el+ | otherwise = renderPGTTargetEl cteNames el Nothing idx+++-- | Defines associativity of an operator.+data Associativity = LeftAssoc | RightAssoc | NonAssoc+ deriving stock (Eq, Show)+++-- | Holds details for a binary operator relevant to precedence restructuring.+data OperatorDetails = OperatorDetails+ { odConstructor :: PGT_AST.AExpr -> PGT_AST.AExpr -> PGT_AST.AExpr+ , odPrecedence :: Int+ , 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 = \case+ PGT_AST.SymbolicBinOpAExpr l symOp r ->+ let+ details _op constr prec assoc = Just (l, OperatorDetails constr prec assoc, r)+ mathDetails mathOp prec assoc =+ details+ (PGT_AST.MathSymbolicExprBinOp mathOp)+ ( \l' r' -> PGT_AST.SymbolicBinOpAExpr l' (PGT_AST.MathSymbolicExprBinOp mathOp) r'+ )+ prec+ assoc+ in+ case symOp of+ PGT_AST.MathSymbolicExprBinOp PGT_AST.ArrowUpMathOp -> mathDetails PGT_AST.ArrowUpMathOp 8 LeftAssoc+ -- \^ (exponentiation)+ PGT_AST.MathSymbolicExprBinOp op+ | op `elem` [PGT_AST.AsteriskMathOp, PGT_AST.SlashMathOp, PGT_AST.PercentMathOp] ->+ mathDetails op 7 LeftAssoc+ -- \* / %+ PGT_AST.MathSymbolicExprBinOp op+ | op `elem` [PGT_AST.PlusMathOp, PGT_AST.MinusMathOp] ->+ mathDetails op 6 LeftAssoc -- binary + -+ PGT_AST.MathSymbolicExprBinOp op -- Comparisons+ | op+ `elem` [ PGT_AST.ArrowLeftMathOp+ , PGT_AST.ArrowRightMathOp+ , PGT_AST.EqualsMathOp+ , PGT_AST.LessEqualsMathOp+ , PGT_AST.GreaterEqualsMathOp+ , PGT_AST.ArrowLeftArrowRightMathOp+ , PGT_AST.ExclamationEqualsMathOp+ ] ->+ mathDetails op 3 LeftAssoc -- < > = <= >= <> !=+ PGT_AST.QualSymbolicExprBinOp qualOp ->+ -- User-defined operators, bitwise, etc.+ details+ (PGT_AST.QualSymbolicExprBinOp qualOp)+ ( \l' r' -> PGT_AST.SymbolicBinOpAExpr l' (PGT_AST.QualSymbolicExprBinOp qualOp) r'+ )+ 5+ LeftAssoc+ _ -> Nothing -- Should be exhaustive for PGT_AST.MathSymbolicExprBinOp if it's a binary op+ PGT_AST.AndAExpr l r -> Just (l, OperatorDetails PGT_AST.AndAExpr 2 LeftAssoc, r) -- AND (precedence 2 in PG docs example)+ PGT_AST.OrAExpr l r -> Just (l, OperatorDetails PGT_AST.OrAExpr 1 LeftAssoc, r) -- OR (precedence 1 in PG docs example)+ PGT_AST.VerbalExprBinOpAExpr l notOp verbalOp r mEscape ->+ -- LIKE, ILIKE, SIMILAR TO+ Just+ ( l+ , OperatorDetails+ (\l' r' -> PGT_AST.VerbalExprBinOpAExpr l' notOp verbalOp r' mEscape)+ 3+ LeftAssoc+ , r -- Same as comparisons+ )+ PGT_AST.ReversableOpAExpr l notOp (PGT_AST.DistinctFromAExprReversableOp r) ->+ -- IS DISTINCT FROM+ Just+ ( l+ , OperatorDetails+ ( \l' r' ->+ PGT_AST.ReversableOpAExpr l' notOp (PGT_AST.DistinctFromAExprReversableOp r')+ )+ 3+ LeftAssoc+ , r -- Same as =+ )+ _ -> Nothing+++-- | Rearranges the AExpr syntax tree to account for operator precedence.+fixOperatorPrecedence :: PGT_AST.AExpr -> PGT_AST.AExpr+fixOperatorPrecedence = go+ where+ go expr =+ case getOperatorDetails expr of+ Just (l1, op1Details, r1) ->+ let+ l1Fixed = go l1+ r1Fixed = go r1+ currentOpConstructor = odConstructor op1Details+ currentPrecedence = odPrecedence op1Details+ currentAssociativity = odAssociativity op1Details+ in+ case getOperatorDetails r1Fixed of+ Just (l2, op2Details, 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 = odConstructor op2Details+ innerPrecedence = odPrecedence op2Details+ in+ -- innerAssociativity = odAssociativity op2Details -- Not used in this branch's logic directly++ if currentPrecedence < innerPrecedence+ || (currentPrecedence == innerPrecedence && currentAssociativity == RightAssoc)+ then+ -- op2 binds tighter, or op1 is right-associative with same precedence.+ -- Structure l1Fixed `op1` (l2 `op2` r2) is correct.+ currentOpConstructor l1Fixed 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 = currentOpConstructor l1Fixed l2+ in+ go (innerOpConstructor newLeftChild r2) -- Recursively fix the new structure+ Nothing ->+ -- Right child r1Fixed is not a binary operator we're rebalancing.+ -- The structure l1Fixed `op1` r1Fixed is locally correct.+ currentOpConstructor l1Fixed r1Fixed+ Nothing ->+ -- Current expression `expr` is not a binary operator handled by getOperatorDetails,+ -- or it's an atom. Recursively fix its children.+ case expr of+ PGT_AST.CExprAExpr c -> PGT_AST.CExprAExpr c -- CExprs are atoms or structured (FuncCExpr, CaseCExpr etc.)+ PGT_AST.TypecastAExpr e t -> PGT_AST.TypecastAExpr (go e) t+ PGT_AST.CollateAExpr e c -> PGT_AST.CollateAExpr (go e) c+ PGT_AST.AtTimeZoneAExpr e1 e2 -> PGT_AST.AtTimeZoneAExpr (go e1) (go e2)+ PGT_AST.PlusAExpr e -> PGT_AST.PlusAExpr (go 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 e -> PGT_AST.MinusAExpr (go e)+ PGT_AST.PrefixQualOpAExpr op e -> PGT_AST.PrefixQualOpAExpr op (go e)+ PGT_AST.SuffixQualOpAExpr e op -> PGT_AST.SuffixQualOpAExpr (go e) op+ PGT_AST.NotAExpr e -> PGT_AST.NotAExpr (go e)+ PGT_AST.ReversableOpAExpr e notFlag revOp ->+ let+ eFixed = go e+ in+ case revOp of+ PGT_AST.DistinctFromAExprReversableOp{} -> expr -- Should have been caught by getOperatorDetails+ PGT_AST.BetweenAExprReversableOp symm bExpr aExpr ->+ PGT_AST.ReversableOpAExpr+ eFixed+ notFlag+ (PGT_AST.BetweenAExprReversableOp symm (goBExpr bExpr) (go aExpr))+ PGT_AST.InAExprReversableOp inExpr ->+ PGT_AST.ReversableOpAExpr+ eFixed+ notFlag+ (PGT_AST.InAExprReversableOp (goInExpr inExpr))+ _ -> PGT_AST.ReversableOpAExpr eFixed notFlag revOp -- For IS NULL, IS TRUE etc.+ PGT_AST.IsnullAExpr e -> PGT_AST.IsnullAExpr (go e)+ PGT_AST.NotnullAExpr e -> PGT_AST.NotnullAExpr (go e)+ PGT_AST.OverlapsAExpr row1 row2 -> PGT_AST.OverlapsAExpr (goRow row1) (goRow row2)+ PGT_AST.SubqueryAExpr e op st sub ->+ PGT_AST.SubqueryAExpr+ (go e)+ op+ st+ (either (Left . goSelectWithParens) (Right . go) sub)+ PGT_AST.UniqueAExpr s -> PGT_AST.UniqueAExpr (goSelectWithParens s)+ PGT_AST.DefaultAExpr -> PGT_AST.DefaultAExpr+ _ -> expr -- Leaf node or unhandled construct+ goBExpr :: PGT_AST.BExpr -> PGT_AST.BExpr+ goBExpr = \case+ PGT_AST.CExprBExpr c -> PGT_AST.CExprBExpr c+ PGT_AST.TypecastBExpr be t -> PGT_AST.TypecastBExpr (goBExpr be) t+ PGT_AST.PlusBExpr be -> PGT_AST.PlusBExpr (goBExpr be)+ PGT_AST.MinusBExpr be -> PGT_AST.MinusBExpr (goBExpr 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 l op r -> PGT_AST.SymbolicBinOpBExpr (goBExpr l) op (goBExpr r)+ PGT_AST.QualOpBExpr op be -> PGT_AST.QualOpBExpr op (goBExpr be)+ PGT_AST.IsOpBExpr be notFlag isOp ->+ let+ beFixed = goBExpr be+ in+ case isOp of+ PGT_AST.DistinctFromBExprIsOp b ->+ PGT_AST.IsOpBExpr beFixed notFlag (PGT_AST.DistinctFromBExprIsOp (goBExpr b))+ _ -> PGT_AST.IsOpBExpr beFixed notFlag isOp++ goRow :: PGT_AST.Row -> PGT_AST.Row+ goRow = \case+ PGT_AST.ExplicitRowRow mExprs -> PGT_AST.ExplicitRowRow (fmap (NE.map go) mExprs)+ PGT_AST.ImplicitRowRow (PGT_AST.ImplicitRow exprs aexpr) -> PGT_AST.ImplicitRowRow (PGT_AST.ImplicitRow (NE.map go exprs) (go aexpr))++ goSelectWithParens :: PGT_AST.SelectWithParens -> PGT_AST.SelectWithParens+ goSelectWithParens = id -- Placeholder: A full traversal would be needed.+ goInExpr :: PGT_AST.InExpr -> PGT_AST.InExpr+ goInExpr = \case+ PGT_AST.SelectInExpr s -> PGT_AST.SelectInExpr (goSelectWithParens s)+ PGT_AST.ExprListInExpr exprs -> PGT_AST.ExprListInExpr (NE.map go exprs)+++renderPGTAExpr :: [Text.Text] -> PGT_AST.AExpr -> Q Exp+renderPGTAExpr cteNames astExpr = case fixOperatorPrecedence astExpr of+ PGT_AST.CExprAExpr cExpr -> renderPGTCExpr cteNames cExpr+ PGT_AST.TypecastAExpr aExpr typename -> do+ tnExp <- renderPGTTypename typename+ aExp <- renderPGTAExpr cteNames aExpr+ pure $ VarE 'S.cast `AppE` tnExp `AppE` aExp+ PGT_AST.SymbolicBinOpAExpr left op right -> do+ lExp <- renderPGTAExpr cteNames left+ rExp <- renderPGTAExpr cteNames right+ squealOpExp <-+ case op of+ PGT_AST.MathSymbolicExprBinOp mathOp -> pure $ renderPGTMathOp mathOp+ PGT_AST.QualSymbolicExprBinOp qualOp -> pure $ renderPGTQualOp qualOp+ pure (squealOpExp `AppE` lExp `AppE` rExp)+ PGT_AST.PrefixQualOpAExpr op expr -> do+ let+ opExp' = renderPGTQualOp op+ eExp' <- renderPGTAExpr cteNames expr+ pure (opExp' `AppE` eExp')+ PGT_AST.AndAExpr left right -> do+ lExp' <- renderPGTAExpr cteNames left+ rExp' <- renderPGTAExpr cteNames right+ pure (VarE '(S..&&) `AppE` lExp' `AppE` rExp')+ PGT_AST.OrAExpr left right -> do+ lExp' <- renderPGTAExpr cteNames left+ rExp' <- renderPGTAExpr cteNames right+ pure (VarE '(S..||) `AppE` lExp' `AppE` rExp')+ PGT_AST.NotAExpr expr -> do+ eExp' <- renderPGTAExpr cteNames expr+ pure (VarE 'S.not_ `AppE` eExp')+ PGT_AST.VerbalExprBinOpAExpr left not op right mEscape -> do+ when (isJust mEscape) $ fail "LIKE with ESCAPE is not supported yet."+ lExp' <- renderPGTAExpr cteNames left+ rExp' <- renderPGTAExpr cteNames right+ baseOpExp <-+ case op of+ PGT_AST.LikeVerbalExprBinOp -> pure $ VarE 'S.like+ PGT_AST.IlikeVerbalExprBinOp -> pure $ VarE 'S.ilike+ _ -> fail $ "Unsupported verbal binary operator: " <> show op+ let+ finalOpExp = if not then VarE 'S.not_ `AppE` baseOpExp else baseOpExp+ pure (finalOpExp `AppE` lExp' `AppE` rExp')+ PGT_AST.ReversableOpAExpr expr not reversableOp -> do+ renderedExpr' <- renderPGTAExpr cteNames expr+ case reversableOp of+ PGT_AST.NullAExprReversableOp ->+ pure $ (if not then VarE 'S.isNotNull else VarE 'S.isNull) `AppE` renderedExpr'+ PGT_AST.BetweenAExprReversableOp _asymmetric bExpr andAExpr -> do+ bExp' <- renderPGTBExpr cteNames bExpr+ aExp' <- renderPGTAExpr cteNames andAExpr+ let+ opVar' = if not then VarE 'S.notBetween else VarE 'S.between+ pure $ opVar' `AppE` renderedExpr' `AppE` TupE [Just bExp', Just aExp']+ PGT_AST.InAExprReversableOp inExpr ->+ case inExpr of+ PGT_AST.ExprListInExpr exprList -> do+ let opVar' = if not then VarE 'S.notIn else VarE 'S.in_+ listExp' <- ListE <$> mapM (renderPGTAExpr cteNames) (NE.toList exprList)+ pure $ opVar' `AppE` renderedExpr' `AppE` listExp'+ PGT_AST.SelectInExpr selectWithParens -> do+ let+ (squealOp, squealFn) =+ if not+ then (VarE '(S../=), VarE 'S.subAll)+ else (VarE '(S..==), VarE 'S.subAny)+ subqueryExp <- toSquealSelectWithParens cteNames Nothing selectWithParens+ pure $ squealFn `AppE` renderedExpr' `AppE` squealOp `AppE` subqueryExp+ _ -> fail $ "Unsupported reversable operator: " <> show reversableOp+ PGT_AST.DefaultAExpr -> pure $ ConE 'S.Default+ PGT_AST.MinusAExpr expr -> do+ -- Unary minus+ eExp' <- renderPGTAExpr cteNames expr+ let+ zeroExp = AppE (VarE 'fromInteger) (LitE (IntegerL 0))+ pure (InfixE (Just zeroExp) (VarE '(-)) (Just eExp'))+ unsupported -> fail $ "Unsupported AExpr: " <> show unsupported+++renderPGTBExpr :: [Text.Text] -> PGT_AST.BExpr -> Q Exp+renderPGTBExpr cteNames = \case+ PGT_AST.CExprBExpr cExpr -> renderPGTCExpr cteNames cExpr+ PGT_AST.TypecastBExpr bExpr typename -> do+ tnExp <- renderPGTTypename typename+ bExp <- renderPGTBExpr cteNames bExpr+ pure $ VarE 'S.cast `AppE` tnExp `AppE` bExp+ PGT_AST.SymbolicBinOpBExpr left op right -> do+ lExp <- renderPGTBExpr cteNames left+ rExp <- renderPGTBExpr cteNames right+ squealOpExp <-+ case op of+ PGT_AST.MathSymbolicExprBinOp mathOp -> pure $ renderPGTMathOp mathOp+ PGT_AST.QualSymbolicExprBinOp qualOp -> pure $ renderPGTQualOp qualOp+ pure (squealOpExp `AppE` lExp `AppE` rExp)+ unsupported -> fail $ "Unsupported BExpr: " <> show unsupported+++renderPGTCExpr :: [Text.Text] -> PGT_AST.CExpr -> Q Exp+renderPGTCExpr cteNames = \case+ PGT_AST.AexprConstCExpr aexprConst -> pure $ renderPGTAexprConst aexprConst+ PGT_AST.ColumnrefCExpr columnref -> pure $ renderPGTColumnref columnref+ PGT_AST.ParamCExpr n maybeIndirection -> do+ when (isJust maybeIndirection) $+ fail "Parameters with indirection (e.g. $1[i]) are not supported."+ pure $ VarE 'S.param `AppTypeE` LitT (NumTyLit (fromIntegral n))+ PGT_AST.InParensCExpr expr maybeIndirection -> do+ when (isJust maybeIndirection) $+ fail "Parenthesized expressions with indirection are not supported."+ renderPGTAExpr cteNames expr -- Squeal's operator precedence should handle this+ PGT_AST.FuncCExpr funcExpr -> renderPGTFuncExpr cteNames funcExpr+ unsupported -> fail $ "Unsupported CExpr: " <> show unsupported+++renderPGTFuncExpr :: [Text.Text] -> PGT_AST.FuncExpr -> Q Exp+renderPGTFuncExpr cteNames = \case+ PGT_AST.ApplicationFuncExpr funcApp maybeWithinGroup maybeFilter maybeOver -> do+ when (isJust maybeWithinGroup) $ fail "WITHIN GROUP clause is not supported."+ when (isJust maybeFilter) $ fail "FILTER clause is not supported."+ when (isJust maybeOver) $ fail "OVER clause is not supported."+ renderPGTFuncApplication cteNames funcApp+ PGT_AST.SubexprFuncExpr funcCommonSubexpr -> renderPGTFuncExprCommonSubexpr cteNames funcCommonSubexpr+++renderPGTFuncApplication :: [Text.Text] -> PGT_AST.FuncApplication -> Q Exp+renderPGTFuncApplication cteNames (PGT_AST.FuncApplication funcName maybeParams) =+ case funcName of+ PGT_AST.IndirectedFuncName{} ->+ fail "Functions with indirection (e.g. schema.func) are not supported."+ PGT_AST.TypeFuncName fident ->+ let+ fnNameStr = Text.unpack (getIdentText fident)+ in+ case Text.toLower (Text.pack fnNameStr) of+ "inline" ->+ case maybeParams of+ Just (PGT_AST.NormalFuncApplicationParams _ args _) ->+ case NE.toList args of+ [ PGT_AST.ExprFuncArgExpr+ (PGT_AST.CExprAExpr (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref ident Nothing)))+ ] -> do+ let+ varName :: Name+ varName = mkName . Text.unpack . getIdentText $ ident+ pure $ VarE 'S.inline `AppE` VarE varName+ _ -> fail "inline() function expects a single variable argument"+ _ -> fail "inline() function expects a single variable argument"+ "inline_param" ->+ case maybeParams of+ Just (PGT_AST.NormalFuncApplicationParams _ args _) ->+ case NE.toList args of+ [ PGT_AST.ExprFuncArgExpr+ (PGT_AST.CExprAExpr (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref ident Nothing)))+ ] -> do+ let+ varName :: Name+ varName = mkName . Text.unpack . getIdentText $ ident+ pure $ VarE 'S.inlineParam `AppE` VarE varName+ _ -> fail "inline_param() function expects a single variable argument"+ _ -> fail "inline_param() function expects a single variable argument"+ otherFnName ->+ let+ squealFn :: Q Exp+ squealFn =+ case otherFnName of+ "coalesce" -> pure $ VarE 'S.coalesce+ "lower" -> pure $ VarE 'S.lower+ "char_length" -> pure $ VarE 'S.charLength+ "character_length" -> pure $ VarE 'S.charLength+ "upper" -> pure $ VarE 'S.upper+ "count" -> pure $ VarE 'S.count -- Special handling for count(*) might be needed+ "now" -> pure $ VarE 'S.now+ _ -> fail $ "Unsupported function: " <> fnNameStr+ in+ case maybeParams of+ Nothing -> squealFn -- No-argument function+ Just params -> case params of+ PGT_AST.NormalFuncApplicationParams maybeAllOrDistinct args maybeSortClause -> do+ when (isJust maybeAllOrDistinct) $+ fail "DISTINCT in function calls is not supported."+ when (isJust maybeSortClause) $+ fail "ORDER BY in function calls is not supported."+ fn <- squealFn+ argExps <- mapM (renderPGTFuncArgExpr cteNames) (NE.toList args)+ pure $ foldl' AppE fn argExps+ PGT_AST.StarFuncApplicationParams ->+ -- Specific for count(*)+ if fnNameStr == "count"+ then pure $ VarE 'S.countStar+ else fail "Star argument only supported for COUNT"+ _ -> fail $ "Unsupported function parameters structure: " <> show params+++renderPGTFuncArgExpr :: [Text.Text] -> PGT_AST.FuncArgExpr -> Q Exp+renderPGTFuncArgExpr cteNames = \case+ PGT_AST.ExprFuncArgExpr aExpr -> renderPGTAExpr cteNames aExpr+ _ -> fail "Named or colon-syntax function arguments not supported"+++renderPGTFuncExprCommonSubexpr :: [Text.Text] -> PGT_AST.FuncExprCommonSubexpr -> Q Exp+renderPGTFuncExprCommonSubexpr cteNames = \case+ PGT_AST.CurrentTimestampFuncExprCommonSubexpr (Just _) ->+ fail "CURRENT_TIMESTAMP with precision is not supported."+ PGT_AST.CurrentTimestampFuncExprCommonSubexpr Nothing -> pure $ VarE 'S.now -- Or S.currentTimestamp+ PGT_AST.CurrentDateFuncExprCommonSubexpr -> pure $ VarE 'S.currentDate+ PGT_AST.CoalesceFuncExprCommonSubexpr exprListNE -> do+ renderedInitExprs <- mapM (renderPGTAExpr cteNames) (NE.init exprListNE)+ renderedLastExpr <- renderPGTAExpr cteNames (NE.last exprListNE)+ pure $ VarE 'S.coalesce `AppE` ListE renderedInitExprs `AppE` renderedLastExpr+ e -> fail $ "Unsupported common function subexpression: " <> show e+++renderPGTColumnref :: PGT_AST.Columnref -> Exp+renderPGTColumnref (PGT_AST.Columnref colId maybeIndirection) =+ case maybeIndirection of+ Nothing -> LabelE (Text.unpack (getIdentText colId))+ Just indirection ->+ let+ base = LabelE (Text.unpack (getIdentText colId))+ in+ foldl' applyIndirection base (NE.toList indirection)+ where+ applyIndirection acc = \case+ PGT_AST.AttrNameIndirectionEl attrName ->+ VarE '(S.!) `AppE` acc `AppE` LabelE (Text.unpack (getIdentText attrName))+ _ -> error "Unsupported column reference indirection"+++renderPGTAexprConst :: PGT_AST.AexprConst -> Exp+renderPGTAexprConst = \case+ PGT_AST.IAexprConst n ->+ ConE 'S.UnsafeExpression+ `AppE` ( VarE 'BS8.pack+ `AppE` LitE (StringL (show n))+ )+ PGT_AST.FAexprConst f ->+ ConE 'S.UnsafeExpression+ `AppE` ( VarE 'BS8.pack+ `AppE` LitE (StringL (show f))+ )+ PGT_AST.SAexprConst s ->+ VarE 'fromString `AppE` LitE (StringL (Text.unpack s))+ PGT_AST.BoolAexprConst True -> VarE 'S.true+ PGT_AST.BoolAexprConst False -> VarE 'S.false+ PGT_AST.NullAexprConst -> VarE 'S.null_+ unsupported -> error $ "Unsupported AexprConst: " <> show unsupported+++renderPGTMathOp :: PGT_AST.MathOp -> Exp+renderPGTMathOp = \case+ PGT_AST.PlusMathOp -> VarE '(+)+ PGT_AST.MinusMathOp -> VarE '(-)+ PGT_AST.AsteriskMathOp -> VarE '(*)+ PGT_AST.EqualsMathOp -> VarE '(S..==)+ PGT_AST.ArrowLeftArrowRightMathOp -> VarE '(S../=) -- <>+ PGT_AST.ExclamationEqualsMathOp -> VarE '(S../=) -- !=+ PGT_AST.ArrowRightMathOp -> VarE '(S..>)+ PGT_AST.GreaterEqualsMathOp -> VarE '(S..>=)+ PGT_AST.ArrowLeftMathOp -> VarE '(S..<)+ PGT_AST.LessEqualsMathOp -> VarE '(S..<=)+ _ -> error "Unsupported math operator"+++renderPGTQualOp :: PGT_AST.QualOp -> Exp+renderPGTQualOp = \case+ PGT_AST.OpQualOp opText ->+ case Text.toLower opText of+ "+" -> VarE '(+)+ "-" -> VarE '(-)+ "*" -> VarE '(*)+ "=" -> VarE '(S..==)+ "<>" -> VarE '(S../=)+ "!=" -> VarE '(S../=)+ ">" -> VarE '(S..>)+ ">=" -> VarE '(S..>=)+ "<" -> VarE '(S..<)+ "<=" -> VarE '(S..<=)+ "and" -> VarE '(S..&&)+ "or" -> VarE '(S..||)+ "not" -> VarE 'S.not_+ "like" -> VarE 'S.like+ "ilike" -> VarE 'S.ilike+ _ -> error $ "Unsupported QualOp operator text: " <> Text.unpack opText+ PGT_AST.OperatorQualOp _anyOperator ->+ error "OPERATOR(any_operator) syntax not supported"+++renderPGTTypename :: PGT_AST.Typename -> Q Exp+renderPGTTypename (PGT_AST.Typename setof simpleTypename nullable arrayInfo) = do+ when setof $ fail "SETOF type modifier is not supported."+ when nullable $ fail "Nullable type modifier '?' is not supported."+ baseTypeExp <- renderPGTSimpleTypename simpleTypename+ case arrayInfo of+ Nothing -> pure baseTypeExp+ Just (dims, nullableArray) -> do+ when nullableArray $ fail "Nullable array modifier '?' is not supported."+ renderPGTArrayDimensions baseTypeExp dims+++renderPGTArrayDimensions :: Exp -> PGT_AST.TypenameArrayDimensions -> Q Exp+renderPGTArrayDimensions baseTypeExp = \case+ PGT_AST.BoundsTypenameArrayDimensions 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 NE.toList bounds of+ [Just dim] ->+ pure $+ VarE 'S.fixarray+ `AppTypeE` LitT (NumTyLit (fromIntegral dim))+ `AppE` baseTypeExp+ [_] -> pure $ VarE 'S.vararray `AppE` baseTypeExp -- e.g. int[]+ _ ->+ fail "Multidimensional arrays with explicit bounds not yet supported"+ PGT_AST.ExplicitTypenameArrayDimensions Nothing -> pure $ VarE 'S.vararray `AppE` baseTypeExp -- e.g. sometype ARRAY+ PGT_AST.ExplicitTypenameArrayDimensions (Just dim) ->+ pure $+ VarE 'S.fixarray+ `AppTypeE` LitT (NumTyLit (fromIntegral dim))+ `AppE` baseTypeExp -- e.g. sometype ARRAY[N]+++renderPGTSimpleTypename :: PGT_AST.SimpleTypename -> Q Exp+renderPGTSimpleTypename = \case+ PGT_AST.GenericTypeSimpleTypename+ (PGT_AST.GenericType typeFnName attrs maybeModifiers) -> do+ when (isJust attrs) $+ fail "Qualified type names (e.g. schema.my_type) are not supported."+ let+ nameLower = Text.toLower (getIdentText typeFnName)+ extractLength :: Maybe PGT_AST.TypeModifiers -> Q Integer+ extractLength = \case+ Just+ ((PGT_AST.CExprAExpr (PGT_AST.AexprConstCExpr (PGT_AST.IAexprConst n))) NE.:| []) -> pure (fromIntegral n)+ Just other ->+ fail $+ "Unsupported type modifier for " <> Text.unpack nameLower <> ": " <> show other+ Nothing ->+ fail $+ "Type "+ <> Text.unpack nameLower+ <> " requires a length argument (e.g., "+ <> Text.unpack nameLower+ <> "(N))."++ extractLengthOrDefault :: Integer -> Maybe PGT_AST.TypeModifiers -> Q Integer+ extractLengthOrDefault def = \case+ Just+ ((PGT_AST.CExprAExpr (PGT_AST.AexprConstCExpr (PGT_AST.IAexprConst n))) NE.:| []) -> pure (fromIntegral n)+ Just other ->+ fail $+ "Unsupported type modifier for " <> Text.unpack nameLower <> ": " <> show other+ Nothing -> pure def+ case nameLower of+ "char" -> do+ len <- extractLengthOrDefault 1 maybeModifiers+ pure $ VarE 'S.char `AppTypeE` LitT (NumTyLit len)+ "character" -> do+ len <- extractLengthOrDefault 1 maybeModifiers+ pure $ VarE 'S.character `AppTypeE` LitT (NumTyLit len)+ "varchar" -> case maybeModifiers of+ Nothing -> pure $ VarE 'S.text -- varchar without length is text+ Just _ -> do+ len <- extractLength maybeModifiers+ pure $ VarE 'S.varchar `AppTypeE` LitT (NumTyLit len)+ "character varying" -> case maybeModifiers of+ Nothing -> pure $ VarE 'S.text -- character varying without length is text+ Just _ -> do+ len <- extractLength maybeModifiers+ pure $ VarE 'S.characterVarying `AppTypeE` LitT (NumTyLit len)+ "bool" -> pure $ VarE 'S.bool+ "int2" -> pure $ VarE 'S.int2+ "smallint" -> pure $ VarE 'S.smallint+ "int4" -> pure $ VarE 'S.int4+ "int" -> pure $ VarE 'S.int+ "integer" -> pure $ VarE 'S.integer+ "int8" -> pure $ VarE 'S.int8+ "bigint" -> pure $ VarE 'S.bigint+ "numeric" -> pure $ VarE 'S.numeric -- Ignoring precision/scale for now+ "float4" -> pure $ VarE 'S.float4 -- Ignoring precision for now+ "real" -> pure $ VarE 'S.real+ "float8" -> pure $ VarE 'S.float8+ "double precision" -> pure $ VarE 'S.doublePrecision+ "money" -> pure $ VarE 'S.money+ "text" -> pure $ VarE 'S.text+ "bytea" -> pure $ VarE 'S.bytea+ "timestamp" -> pure $ VarE 'S.timestamp+ "timestamptz" -> pure $ VarE 'S.timestamptz+ "timestamp with time zone" -> pure $ VarE 'S.timestampWithTimeZone+ "date" -> pure $ VarE 'S.date+ "time" -> pure $ VarE 'S.time+ "timetz" -> pure $ VarE 'S.timetz+ "time with time zone" -> pure $ VarE 'S.timeWithTimeZone+ "interval" -> pure $ VarE 'S.interval+ "uuid" -> pure $ VarE 'S.uuid+ "inet" -> pure $ VarE 'S.inet+ "json" -> pure $ VarE 'S.json+ "jsonb" -> pure $ VarE 'S.jsonb+ "tsvector" -> pure $ VarE 'S.tsvector+ "tsquery" -> pure $ VarE 'S.tsquery+ "oid" -> pure $ VarE 'S.oid+ "int4range" -> pure $ VarE 'S.int4range+ "int8range" -> pure $ VarE 'S.int8range+ "numrange" -> pure $ VarE 'S.numrange+ "tsrange" -> pure $ VarE 'S.tsrange+ "tstzrange" -> pure $ VarE 'S.tstzrange+ "daterange" -> pure $ VarE 'S.daterange+ "record" -> pure $ VarE 'S.record+ other -> fail $ "Unsupported generic type name: " <> Text.unpack other+ PGT_AST.NumericSimpleTypename numeric -> renderPGTNumeric numeric+ PGT_AST.BitSimpleTypename (PGT_AST.Bit _varying _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.+ fail+ "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 charTypeAst ->+ case charTypeAst of+ PGT_AST.CharacterCharacter False -> pure $ VarE 'S.character `AppTypeE` LitT (NumTyLit 1) -- SQL CHARACTER -> Squeal character(1)+ PGT_AST.CharacterCharacter True -> pure $ VarE 'S.text -- SQL CHARACTER VARYING -> Squeal text+ PGT_AST.CharCharacter False -> pure $ VarE 'S.char `AppTypeE` LitT (NumTyLit 1) -- SQL CHAR -> Squeal char(1)+ PGT_AST.CharCharacter True -> pure $ VarE 'S.text -- SQL CHAR VARYING -> Squeal text+ PGT_AST.VarcharCharacter -> pure $ VarE 'S.text -- SQL VARCHAR (no length) -> Squeal text+ -- National character types are often aliases for standard character types in PostgreSQL+ PGT_AST.NationalCharacterCharacter False -> pure $ VarE 'S.character `AppTypeE` LitT (NumTyLit 1) -- NCHAR -> character(1)+ PGT_AST.NationalCharacterCharacter True -> pure $ VarE 'S.text -- NCHAR VARYING -> text+ PGT_AST.NationalCharCharacter False -> pure $ VarE 'S.char `AppTypeE` LitT (NumTyLit 1) -- NATIONAL CHAR -> char(1)+ PGT_AST.NationalCharCharacter True -> pure $ VarE 'S.text -- NATIONAL CHAR VARYING -> text+ PGT_AST.NcharCharacter False -> pure $ VarE 'S.char `AppTypeE` LitT (NumTyLit 1) -- NCHAR (synonym for NATIONAL CHAR) -> char(1)+ PGT_AST.NcharCharacter True -> pure $ VarE 'S.text -- NCHAR VARYING -> text+ PGT_AST.ConstDatetimeSimpleTypename dt -> case dt of+ PGT_AST.TimestampConstDatetime precision maybeTimezone -> do+ when (isJust precision) $ fail "TIMESTAMP with precision is not supported."+ pure $ case maybeTimezone of+ Just False -> VarE 'S.timestampWithTimeZone -- WITH TIME ZONE+ _ -> VarE 'S.timestamp -- WITHOUT TIME ZONE or unspecified+ PGT_AST.TimeConstDatetime precision maybeTimezone -> do+ when (isJust precision) $ fail "TIME with precision is not supported."+ pure $ case maybeTimezone of+ Just False -> VarE 'S.timeWithTimeZone -- WITH TIME ZONE+ _ -> VarE 'S.time -- WITHOUT TIME ZONE or unspecified+ PGT_AST.ConstIntervalSimpleTypename (Left (Just _)) ->+ fail "INTERVAL with qualifiers is not supported."+ PGT_AST.ConstIntervalSimpleTypename (Left Nothing) ->+ pure $ VarE 'S.interval+ PGT_AST.ConstIntervalSimpleTypename (Right _) ->+ fail "INTERVAL with integer literal is not supported in this context."+++renderPGTNumeric :: PGT_AST.Numeric -> Q Exp+renderPGTNumeric = \case+ PGT_AST.IntNumeric -> pure $ VarE 'S.int+ PGT_AST.IntegerNumeric -> pure $ VarE 'S.integer+ PGT_AST.SmallintNumeric -> pure $ VarE 'S.smallint+ PGT_AST.BigintNumeric -> pure $ VarE 'S.bigint+ PGT_AST.RealNumeric -> pure $ VarE 'S.real+ PGT_AST.FloatNumeric (Just _) -> fail "FLOAT with precision is not supported."+ PGT_AST.FloatNumeric Nothing -> pure $ VarE 'S.float4+ PGT_AST.DoublePrecisionNumeric -> pure $ VarE 'S.doublePrecision+ PGT_AST.DecimalNumeric (Just _) -> fail "DECIMAL with precision/scale is not supported."+ PGT_AST.DecimalNumeric Nothing -> pure $ VarE 'S.numeric+ PGT_AST.DecNumeric (Just _) -> fail "DEC with precision/scale is not supported."+ PGT_AST.DecNumeric Nothing -> pure $ VarE 'S.numeric+ PGT_AST.NumericNumeric (Just _) -> fail "NUMERIC with precision/scale is not supported."+ PGT_AST.NumericNumeric Nothing -> pure $ VarE 'S.numeric+ PGT_AST.BooleanNumeric -> pure $ VarE 'S.bool+++getIdentText :: PGT_AST.Ident -> Text.Text+getIdentText = \case+ PGT_AST.QuotedIdent t -> t+ PGT_AST.UnquotedIdent t -> t
src/Squeal/QuasiQuotes/Update.hs view
@@ -8,16 +8,18 @@ toSquealUpdate, ) where -import Data.Text (Text) import Control.Monad (when)+import Data.Foldable (Foldable(foldr), foldlM) import Data.Maybe (isJust)+import Data.Text (Text) import Language.Haskell.TH.Syntax (Exp(AppE, ConE, LabelE, VarE), Q) import Prelude- ( Applicative(pure), Foldable(foldr), Maybe(Just, Nothing), MonadFail(fail)+ ( Applicative(pure), Maybe(Just, Nothing), MonadFail(fail), Semigroup((<>)) , Traversable(mapM), ($), (<$>) )-import Squeal.QuasiQuotes.Common+import Squeal.QuasiQuotes.Query ( getIdentText, renderPGTAExpr, renderPGTTableRef, renderPGTTargetList+ , toSquealQuery ) import qualified Data.List.NonEmpty as NE import qualified Data.Text as Text@@ -25,6 +27,44 @@ import qualified Squeal.PostgreSQL as S +renderPGTWithClause :: PGT_AST.WithClause -> Q ([Text.Text], Exp)+renderPGTWithClause (PGT_AST.WithClause recursive ctes) = do+ when recursive $ fail "Recursive WITH clauses are not supported yet."+ let+ cteList = NE.toList ctes+ (finalCteNames, renderedCtes) <-+ foldlM+ ( \(names, exps) cte -> do+ (name, exp) <- renderCte names cte+ pure (names <> [name], exps <> [exp])+ )+ ([], [])+ cteList++ let+ withExp =+ foldr+ (\cte acc -> ConE '(S.:>>) `AppE` cte `AppE` acc)+ (ConE 'S.Done)+ renderedCtes+ pure (finalCteNames, withExp)+ where+ renderCte :: [Text.Text] -> PGT_AST.CommonTableExpr -> Q (Text.Text, Exp)+ renderCte existingCteNames (PGT_AST.CommonTableExpr ident maybeColNames maybeMaterialized stmt) = do+ when (isJust maybeMaterialized) $+ fail "MATERIALIZED/NOT MATERIALIZED for CTEs is not supported yet."+ cteStmtExp <-+ case stmt of+ PGT_AST.SelectPreparableStmt selectStmt -> do+ queryExp <- toSquealQuery existingCteNames maybeColNames selectStmt+ pure $ VarE 'S.queryStatement `AppE` queryExp+ _ -> fail "Only SELECT statements are supported in CTEs for now."+ let+ cteName = getIdentText ident+ pure+ (cteName, VarE 'S.as `AppE` cteStmtExp `AppE` LabelE (Text.unpack cteName))++ toSquealUpdate :: PGT_AST.UpdateStmt -> Q Exp toSquealUpdate ( PGT_AST.UpdateStmt@@ -35,38 +75,48 @@ maybeWhereClause maybeReturningClause ) = do- when (isJust maybeWithClause) $- fail "WITH clauses are not supported in UPDATE statements yet."+ (cteNames, renderedWithClause) <-+ case maybeWithClause of+ Nothing -> pure ([], Nothing)+ Just withClause -> do+ (names, exp) <- renderPGTWithClause withClause+ pure (names, Just exp) targetTableExp <- renderPGTRelationExprOptAlias' relationExprOptAlias - setClauseExp <- renderPGTSetClauseList setClauseList+ setClauseExp <- renderPGTSetClauseList cteNames setClauseList usingClauseExp <- case maybeFromClause of Nothing -> pure $ ConE 'S.NoUsing- Just fromClause -> AppE (ConE 'S.Using) <$> renderPGTTableRef fromClause+ Just fromClause -> AppE (ConE 'S.Using) <$> renderPGTTableRef cteNames fromClause whereConditionExp <- case maybeWhereClause of Nothing -> fail "UPDATE statements must have a WHERE clause for safety. Use WHERE TRUE to update all rows."- Just (PGT_AST.ExprWhereOrCurrentClause whereAExpr) -> renderPGTAExpr whereAExpr+ Just (PGT_AST.ExprWhereOrCurrentClause whereAExpr) -> renderPGTAExpr cteNames whereAExpr Just (PGT_AST.CursorWhereOrCurrentClause _) -> fail "WHERE CURRENT OF is not supported." returningClauseExp <- case maybeReturningClause of Nothing -> pure $ ConE 'S.Returning_ `AppE` ConE 'S.Nil- Just returningClause -> AppE (ConE 'S.Returning) <$> renderPGTTargetList returningClause+ Just returningClause -> AppE (ConE 'S.Returning) <$> renderPGTTargetList cteNames returningClause - pure $- ( VarE 'S.update- `AppE` targetTableExp- `AppE` setClauseExp- `AppE` usingClauseExp- `AppE` whereConditionExp- `AppE` returningClauseExp- )+ let+ updateBody =+ ( VarE 'S.update+ `AppE` targetTableExp+ `AppE` setClauseExp+ `AppE` usingClauseExp+ `AppE` whereConditionExp+ `AppE` returningClauseExp+ )+ let+ finalExp = case renderedWithClause of+ Nothing -> updateBody+ Just withExp -> VarE 'S.with `AppE` withExp `AppE` updateBody+ pure finalExp renderPGTRelationExprOptAlias' :: PGT_AST.RelationExprOptAlias -> Q Exp@@ -103,9 +153,9 @@ pure $ VarE 'S.as `AppE` qualifiedAlias `AppE` LabelE (Text.unpack aliasName) -renderPGTSetClauseList :: PGT_AST.SetClauseList -> Q Exp-renderPGTSetClauseList setClauses = do- renderedItems <- mapM renderPGTSetClause (NE.toList setClauses)+renderPGTSetClauseList :: [Text.Text] -> PGT_AST.SetClauseList -> Q Exp+renderPGTSetClauseList cteNames setClauses = do+ renderedItems <- mapM (renderPGTSetClause cteNames) (NE.toList setClauses) pure $ foldr (\item acc -> ConE '(S.:*) `AppE` item `AppE` acc)@@ -113,13 +163,14 @@ renderedItems -renderPGTSetClause :: PGT_AST.SetClause -> Q Exp-renderPGTSetClause = \case+renderPGTSetClause :: [Text.Text] -> PGT_AST.SetClause -> Q Exp+renderPGTSetClause cteNames = \case PGT_AST.TargetSetClause (PGT_AST.SetTarget colId maybeIndirection) aExpr -> do when (isJust maybeIndirection) $ fail "UPDATE SET with indirection (e.g., array access) is not supported."- let colNameStr = Text.unpack (getIdentText colId)- renderedExpr <- renderPGTAExpr aExpr+ let+ colNameStr = Text.unpack (getIdentText colId)+ renderedExpr <- renderPGTAExpr cteNames aExpr pure $ VarE 'S.as `AppE` (ConE 'S.Set `AppE` renderedExpr)
test/test.hs view
@@ -169,7 +169,7 @@ squealRendering = "SELECT * FROM \"users\" AS \"users\" WHERE (\"name\" = (E'bob' :: text))" checkStatement squealRendering statement - it "select user.name from users" $ do+ it "select users.name from users" $ do let statement :: Statement DB () (Field "name" Text, ()) statement = [ssql| select users.name from users |]@@ -413,7 +413,7 @@ checkStatement squealRendering statement it- "select users.id from users left outer join emails on users.id == emails.user_id"+ "select users.id from users left outer join emails on emails.user_id = users.id" $ do let statement@@ -436,7 +436,7 @@ checkStatement squealRendering statement it- "select * from users left outer join emails on users.id == emails.user_id"+ "select users.id, users.name, emails.email from users left outer join emails on emails.user_id = users.id where emails.email = inline(\"targetEmail\")" $ do let targetEmail :: Text@@ -558,6 +558,61 @@ "SELECT \"employee_id\" AS \"employee_id\", \"name\" AS \"name\", count(ALL \"id\") AS \"_col3\" FROM \"users\" AS \"users\" GROUP BY \"employee_id\", \"name\"" checkStatement squealRendering statement + describe "common table expressions" $ do+ it "with users_cte as (select * from users) select * from users_cte" $ do+ let+ statement+ :: Statement+ DB+ ()+ ( Field "id" Text+ , ( Field "name" Text+ , ( Field "employee_id" UUID+ , ( Field "bio" (Maybe Text)+ , ()+ )+ )+ )+ )+ statement = [ssql| with users_cte as (select * from users) select * from users_cte |]+ squealRendering :: Text+ squealRendering =+ "WITH \"users_cte\" AS (SELECT * FROM \"users\" AS \"users\") SELECT * FROM \"users_cte\" AS \"users_cte\""+ checkStatement squealRendering statement++ it+ "with users_cte as (select * from users), emails_cte as (select * from emails) select users_cte.*, emails_cte.email from users_cte join emails_cte on users_cte.id = emails_cte.user_id"+ $ do+ let+ statement+ :: Statement+ DB+ ()+ ( Field "id" Text+ , ( Field "name" Text+ , ( Field "employee_id" UUID+ , ( Field "bio" (Maybe Text)+ , ( Field "email" (Maybe Text)+ , ()+ )+ )+ )+ )+ )+ statement =+ [ssql|+ with+ users_cte as (select * from users),+ emails_cte as (select * from emails)+ select users_cte.*, emails_cte.email+ from users_cte+ join emails_cte on users_cte.id = emails_cte.user_id+ |]+ squealRendering :: Text+ squealRendering =+ "WITH \"users_cte\" AS (SELECT * FROM \"users\" AS \"users\"), \"emails_cte\" AS (SELECT * FROM \"emails\" AS \"emails\") SELECT \"users_cte\".*, \"emails_cte\".\"email\" AS \"email\" FROM \"users_cte\" AS \"users_cte\" INNER JOIN \"emails_cte\" AS \"emails_cte\" ON (\"users_cte\".\"id\" = \"emails_cte\".\"user_id\")"+ checkStatement squealRendering statement+ describe "inserts" $ do it "insert into emails (id, user_id, email) values (1, 'user-1', 'foo@bar')" $ do let@@ -615,7 +670,7 @@ checkStatement squealRendering statement it- "insert into emails (id, user_id, email) values (inline(i), inline(uid), inline(e))"+ "insert into emails (id, user_id, email) values (inline(i), inline(uid), inline_param(e))" $ do let mkStatement :: Int32 -> Text -> Maybe Text -> Statement DB () ()@@ -821,7 +876,7 @@ ) statement = [ssql|- insert into+ insert into emails (id, user_id, email) values (1, 'user-1', 'foo@bar') returning *@@ -831,6 +886,23 @@ "INSERT INTO \"emails\" AS \"emails\" (\"id\", \"user_id\", \"email\") VALUES (1, (E'user-1' :: text), (E'foo@bar' :: text)) RETURNING *" checkStatement squealRendering statement + describe "with common table expressions" $ do+ it+ "with new_user (id, name, bio) as (values ('id_new', 'new_name', 'new_bio')) insert into users_copy select * from new_user"+ $ do+ let+ statement :: Statement DB () ()+ statement =+ [ssql|+ with new_user (id, name, bio) as (values ('id_new', 'new_name', 'new_bio'))+ insert into users_copy+ select * from new_user+ |]+ squealRendering :: Text+ squealRendering =+ "WITH \"new_user\" AS (SELECT * FROM (VALUES ((E'id_new' :: text), (E'new_name' :: text), (E'new_bio' :: text))) AS t (\"id\", \"name\", \"bio\")) INSERT INTO \"users_copy\" AS \"users_copy\" SELECT * FROM \"new_user\" AS \"new_user\""+ checkStatement squealRendering statement+ describe "deletes" $ do it "delete from users where true" $ do let@@ -870,6 +942,40 @@ "DELETE FROM \"users\" AS \"users\" WHERE (\"id\" = (E'some-id' :: text)) RETURNING \"id\" AS \"id\"" checkStatement squealRendering statement + describe "with common table expressions" $ do+ it+ "with to_delete as (select id from users where name = 'Alice') delete from users where id in (select to_delete.id from to_delete)"+ $ do+ let+ statement :: Statement DB () ()+ statement =+ [ssql|+ with to_delete as (select id from users where name = 'Alice')+ delete from users+ where id in (select to_delete.id from to_delete)+ |]+ squealRendering :: Text+ squealRendering =+ "WITH \"to_delete\" AS (SELECT \"id\" AS \"id\" FROM \"users\" AS \"users\" WHERE (\"name\" = (E'Alice' :: text))) DELETE FROM \"users\" AS \"users\" WHERE (\"id\" = ANY (SELECT \"to_delete\".\"id\" AS \"id\" FROM \"to_delete\" AS \"to_delete\"))"+ checkStatement squealRendering statement++ it+ "with to_delete as (select id from users where name = 'Alice') delete from users using to_delete where users.id = to_delete.id"+ $ do+ let+ statement :: Statement DB () ()+ statement =+ [ssql|+ with to_delete as (select id from users where name = 'Alice')+ delete from users+ using to_delete+ where users.id = to_delete.id+ |]+ squealRendering :: Text+ squealRendering =+ "WITH \"to_delete\" AS (SELECT \"id\" AS \"id\" FROM \"users\" AS \"users\" WHERE (\"name\" = (E'Alice' :: text))) DELETE FROM \"users\" AS \"users\" USING \"to_delete\" AS \"to_delete\" WHERE (\"users\".\"id\" = \"to_delete\".\"id\")"+ checkStatement squealRendering statement+ describe "updates" $ do it "update users set name = 'new name' where id = 'some-id'" $ do let@@ -911,9 +1017,28 @@ "UPDATE \"users\" AS \"users\" SET \"name\" = (E'new name' :: text) WHERE (\"id\" = (E'some-id' :: text)) RETURNING \"id\" AS \"id\"" checkStatement squealRendering statement + describe "with common table expressions" $ do+ it+ "with to_update as (select id from users where name = 'Alice') update users set name = 'Alicia' from to_update where users.id = to_update.id"+ $ do+ let+ statement :: Statement DB () ()+ statement =+ [ssql|+ with to_update as (select id from users where name = 'Alice')+ update users+ set name = 'Alicia'+ from to_update+ where users.id = to_update.id+ |]+ squealRendering :: Text+ squealRendering =+ "WITH \"to_update\" AS (SELECT \"id\" AS \"id\" FROM \"users\" AS \"users\" WHERE (\"name\" = (E'Alice' :: text))) UPDATE \"users\" AS \"users\" SET \"name\" = (E'Alicia' :: text) FROM \"to_update\" AS \"to_update\" WHERE (\"users\".\"id\" = \"to_update\".\"id\")"+ checkStatement squealRendering statement+ describe "scalar expressions" $ do -- Binary Operators- it "select id != 'no-such-user' as neq from users" $ do+ it "select users.id != 'no-such-user' as neq from users" $ do let stmt :: Statement DB () (Field "neq" (Maybe Bool), ()) stmt = [ssql| select users.id != 'no-such-user' as neq from users |]@@ -923,7 +1048,7 @@ <> "\"neq\" FROM \"users\" AS \"users\"" checkStatement squealRendering stmt - it "select * from users where id <> 'no-such-user'" $ do+ it "select * from users where users.id <> 'no-such-user'" $ do let stmt :: Statement@@ -944,7 +1069,7 @@ "SELECT * FROM \"users\" AS \"users\" WHERE (\"users\".\"id\" <> (E'no-such-user' :: text))" checkStatement squealRendering stmt - it "select * from emails where id > 0" $ do+ it "select * from emails where emails.id > 0" $ do let stmt :: Statement@@ -956,7 +1081,7 @@ squealRendering = "SELECT * FROM \"emails\" AS \"emails\" WHERE (\"emails\".\"id\" > 0)" checkStatement squealRendering stmt - it "select * from emails where id >= 0" $ do+ it "select * from emails where emails.id >= 0" $ do let stmt :: Statement@@ -968,7 +1093,7 @@ squealRendering = "SELECT * FROM \"emails\" AS \"emails\" WHERE (\"emails\".\"id\" >= 0)" checkStatement squealRendering stmt - it "select * from emails where id < 10" $ do+ it "select * from emails where emails.id < 10" $ do let stmt :: Statement@@ -980,7 +1105,7 @@ squealRendering = "SELECT * FROM \"emails\" AS \"emails\" WHERE (\"emails\".\"id\" < 10)" checkStatement squealRendering stmt - it "select * from emails where id <= 10" $ do+ it "select * from emails where emails.id <= 10" $ do let stmt :: Statement@@ -992,7 +1117,7 @@ squealRendering = "SELECT * FROM \"emails\" AS \"emails\" WHERE (\"emails\".\"id\" <= 10)" checkStatement squealRendering stmt - it "select id + 1 as plus_one from emails" $ do+ it "select emails.id + 1 as plus_one from emails" $ do let stmt :: Statement DB () (Field "plus_one" Int32, ()) stmt = [ssql| select emails.id + 1 as plus_one from emails |]@@ -1001,7 +1126,7 @@ "SELECT (\"emails\".\"id\" + 1) AS \"plus_one\" FROM \"emails\" AS \"emails\"" checkStatement squealRendering stmt - it "select id - 1 as minus_one from emails" $ do+ it "select emails.id - 1 as minus_one from emails" $ do let stmt :: Statement DB () (Field "minus_one" Int32, ()) stmt = [ssql| select emails.id - 1 as minus_one from emails |]@@ -1010,7 +1135,7 @@ "SELECT (\"emails\".\"id\" - 1) AS \"minus_one\" FROM \"emails\" AS \"emails\"" checkStatement squealRendering stmt - it "select id * 2 as times_two from emails" $ do+ it "select emails.id * 2 as times_two from emails" $ do let stmt :: Statement DB () (Field "times_two" Int32, ()) stmt = [ssql| select emails.id * 2 as times_two from emails |]@@ -1019,7 +1144,7 @@ "SELECT (\"emails\".\"id\" * 2) AS \"times_two\" FROM \"emails\" AS \"emails\"" checkStatement squealRendering stmt - it "select * from users where id = 'a' and name = 'b'" $ do+ it "select * from users where users.id = 'a' and users.name = 'b'" $ do let stmt :: Statement@@ -1034,7 +1159,7 @@ "SELECT * FROM \"users\" AS \"users\" WHERE ((\"users\".\"id\" = (E'a' :: text)) AND (\"users\".\"name\" = (E'b' :: text)))" checkStatement squealRendering stmt - it "select * from users where id = 'a' or name = 'b'" $ do+ it "select * from users where users.id = 'a' or users.name = 'b'" $ do let stmt :: Statement@@ -1049,7 +1174,7 @@ "SELECT * FROM \"users\" AS \"users\" WHERE ((\"users\".\"id\" = (E'a' :: text)) OR (\"users\".\"name\" = (E'b' :: text)))" checkStatement squealRendering stmt - it "select * from users where name like 'A%'" $ do+ it "select * from users where users.name like 'A%'" $ do let stmt :: Statement@@ -1064,7 +1189,7 @@ "SELECT * FROM \"users\" AS \"users\" WHERE (\"users\".\"name\" LIKE (E'A%' :: text))" checkStatement squealRendering stmt - it "select * from users where name ilike 'a%'" $ do+ it "select * from users where users.name ilike 'a%'" $ do let stmt :: Statement@@ -1080,7 +1205,7 @@ checkStatement squealRendering stmt -- Prefix Operators- it "select * from users where not (name = 'no-one')" $ do+ it "select * from users where not (users.name = 'no-one')" $ do let stmt :: Statement@@ -1095,7 +1220,7 @@ "SELECT * FROM \"users\" AS \"users\" WHERE (NOT (\"users\".\"name\" = (E'no-one' :: text)))" checkStatement squealRendering stmt - it "select -id as neg_id from emails" $ do+ it "select -emails.id as neg_id from emails" $ do let stmt :: Statement DB () (Field "neg_id" Int32, ()) stmt = [ssql| select -emails.id as neg_id from emails |]@@ -1105,7 +1230,7 @@ checkStatement squealRendering stmt -- Postfix Operators- it "select * from users where bio is null" $ do+ it "select * from users where users.bio is null" $ do let stmt :: Statement@@ -1119,7 +1244,7 @@ squealRendering = "SELECT * FROM \"users\" AS \"users\" WHERE \"users\".\"bio\" IS NULL" checkStatement squealRendering stmt - it "select * from users where bio is not null" $ do+ it "select * from users where users.bio is not null" $ do let stmt :: Statement@@ -1135,7 +1260,7 @@ describe "function calls" $ do -- Function Calls- it "select coalesce(bio, 'no bio') as bio from users" $ do+ it "select coalesce(users.bio, 'no bio') as bio from users" $ do let stmt :: Statement DB () (Field "bio" Text, ()) stmt = [ssql| select coalesce(users.bio, 'no bio') as bio from users |]@@ -1144,7 +1269,7 @@ "SELECT COALESCE(\"users\".\"bio\", (E'no bio' :: text)) AS \"bio\" FROM \"users\" AS \"users\"" checkStatement squealRendering stmt - it "select lower(name) as lower_name from users" $ do+ it "select lower(users.name) as lower_name from users" $ do let stmt :: Statement DB () (Field "lower_name" Text, ()) stmt = [ssql| select lower(users.name) as lower_name from users |]@@ -1153,7 +1278,7 @@ "SELECT lower(\"users\".\"name\") AS \"lower_name\" FROM \"users\" AS \"users\"" checkStatement squealRendering stmt - it "select char_length(name) as name_len from users" $ do+ it "select char_length(users.name) as name_len from users" $ do let stmt :: Statement DB () (Field "name_len" Int32, ()) stmt = [ssql| select char_length(users.name) as name_len from users |]@@ -1162,7 +1287,7 @@ "SELECT char_length(\"users\".\"name\") AS \"name_len\" FROM \"users\" AS \"users\"" checkStatement squealRendering stmt - it "select character_length(name) as name_len_alias from users" $ do+ it "select character_length(users.name) as name_len_alias from users" $ do let stmt :: Statement DB () (Field "name_len_alias" Int32, ()) stmt = [ssql| select character_length(users.name) as name_len_alias from users |]@@ -1171,7 +1296,7 @@ "SELECT char_length(\"users\".\"name\") AS \"name_len_alias\" FROM \"users\" AS \"users\"" checkStatement squealRendering stmt - it "select upper(name) as upper_name from users" $ do+ it "select \"upper\"(users.name) as upper_name from users" $ do let stmt :: Statement DB () (Field "upper_name" Text, ()) stmt = [ssql| select "upper"(users.name) as upper_name from users |]@@ -1225,7 +1350,7 @@ checkStatement squealRendering2 (mkStatement "Bob") -- PARENS (implicitly tested by complex expressions)- it "select (id + 1) * 2 as calc from emails" $ do+ it "select (emails.id + 1) * 2 as calc from emails" $ do let stmt :: Statement DB () (Field "calc" Int32, ()) stmt = [ssql| select (emails.id + 1) * 2 as calc from emails |]@@ -1235,7 +1360,7 @@ checkStatement squealRendering stmt -- IN / NOT IN- it "select * from users where name in ('Alice', 'Bob')" $ do+ it "select * from users where users.name in ('Alice', 'Bob')" $ do let stmt :: Statement@@ -1250,7 +1375,7 @@ "SELECT * FROM \"users\" AS \"users\" WHERE \"users\".\"name\" IN ((E'Alice' :: text), (E'Bob' :: text))" checkStatement squealRendering stmt - it "select * from users where name not in ('Alice', 'Bob')" $ do+ it "select * from users where users.name not in ('Alice', 'Bob')" $ do let stmt :: Statement@@ -1266,7 +1391,7 @@ checkStatement squealRendering stmt -- BETWEEN / NOT BETWEEN- it "select * from emails where id between 0 and 10" $ do+ it "select * from emails where emails.id between 0 and 10" $ do let stmt :: Statement@@ -1279,7 +1404,7 @@ "SELECT * FROM \"emails\" AS \"emails\" WHERE \"emails\".\"id\" BETWEEN 0 AND 10" checkStatement squealRendering stmt - it "select * from emails where id not between 0 and 10" $ do+ it "select * from emails where emails.id not between 0 and 10" $ do let stmt :: Statement@@ -1293,7 +1418,7 @@ checkStatement squealRendering stmt -- CAST- it "select cast(e.id as text) as casted_id from emails as e" $ do+ it "select (e.id :: text) as casted_id from emails as e" $ do let stmt :: Statement DB () (Field "casted_id" Text, ()) stmt = [ssql| select (e.id :: text) as casted_id from emails as e |]