diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright 2022 Rick Owens + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the "Software"), +to deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,90 @@ +# squeal-postgresql-qq + +This library provides a Template Haskell quasiquoter +parsing SQL as the quoted language and producing corresponding +[`squeal-postgresql`](https://hackage.haskell.org/package/squeal-postgresql) +expressing. The goal is to provide an easier way to use the +[`squeal-postgresql`](https://hackage.haskell.org/package/squeal-postgresql) +library, by eliminating (or at least reducing) the need for the user to +learn the squeal "DSL" and allowing her to write regular SQL instead. + +## Stability + +I would give this package a 5 out of 10 for stability where 0 is +completely unstable and experimental and 10 is maybe like the `aeson` +package. + +I think I've got a very large and usable segment of SQL supported but +of course there are unsupported features that are kind of important such +as common table expressions. + +I don't foresee backwards incompatable changes being a problem because, +after all, the "interface" is mostly the SQL language, which is +stable. Most work will be about supporting new corners of SQL. + +In terms of maintenance, I intend to be responsive to any bugs and to keep +up to date with the latest dependencies and GHC versions. In other words, +this is a maintained package, even if I experience a lull in adding new +supported SQL features. + +## Production usage + +I would feel relatively comfortable using this in production. The +risk regarding stability/maintenance is pretty low. + +If you have queries that are supported, great! They'll continue to be +supported. If you have a query that is not supported, you can always +fall back to crafting squeal expressions manually. (File an issue! I'll +prioritize real-world usage.) + +If you have a supported SQL statement that you find you have to +modify in a way that makes it unsupported, you can always tell GHC to +`-ddump-splices` and use the quasi-quoter generated squeal as a starting +point for your modifications. + +## How to use this library. + +See the haddocks. + +## Most important features not currently implemented + +* Prepared statement parameters + * See the haddock documentation for how to get haskell values into + your sql statements. +* `WITH` clauses (Common Table Expressions) +* `ON CONFLICT` clause + +## Other features is not currently implemented + +(Generated by an LLM. Maybe not complete.) + +* `TABLESAMPLE` clause +* `ONLY` keyword for table inheritance +* `WINDOW` clause and window functions (`OVER`) +* `INTO` clause (`SELECT ... INTO ...`) +* `LIKE` with `ESCAPE` +* `IN` with a subquery +* `OPERATOR()` syntax +* Parameter indirection (e.g., `$1[i]`) +* Indirection on parenthesized expressions (e.g., `(expr)[i]`) +* Aggregate `FILTER` clause +* `WITHIN GROUP` clause +* `DISTINCT` in function arguments +* `ORDER BY` in function arguments +* Function name indirection (e.g., `schema.func`) +* `SETOF` type modifier +* `BIT` and `BIT VARYING` types +* `INTERVAL` with qualifiers +* Types with precision/scale (`TIMESTAMP`, `TIME`, `FLOAT`, `NUMERIC`, etc.) +* Qualified type names (e.g., `schema.my_type`) +* `CURRENT_TIMESTAMP` with precision +* Multidimensional arrays with explicit bounds +* `ORDER BY USING` +* `FOR READ ONLY` locking clause +* Advanced `GROUP BY` features (`GROUPING SETS`, `CUBE`, `ROLLUP`) +* Multi-row `VALUES` clause +* `OVERRIDING` clause for identity columns +* Column indirection in `INSERT` target lists +* `WHERE CURRENT OF` for cursors +* Complex relation expressions in `UPDATE` or `DELETE` targets +* Column indirection in `UPDATE SET` clauses diff --git a/squeal-postgresql-qq.cabal b/squeal-postgresql-qq.cabal new file mode 100644 --- /dev/null +++ b/squeal-postgresql-qq.cabal @@ -0,0 +1,63 @@ +cabal-version: 3.0 +name: squeal-postgresql-qq +version: 0.1.0.0 +synopsis: QuasiQuoter transforming raw sql into Squeal expressions. +-- description: +homepage: https://github.com/owensmurray/squeal-postgresql-qq +license: MIT +license-file: LICENSE +author: Rick Owens +maintainer: rick@owensmurray.com +copyright: 2022 Rick Owens +-- category: +build-type: Simple +extra-source-files: + README.md + LICENSE + +common dependencies + build-depends: + , aeson >= 2.1.2.1 && < 2.3 + , 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 + , squeal-postgresql >= 0.9.1.3 && < 0.10 + , template-haskell >= 2.20.0.0 && < 2.24 + , text >= 1.2.5.0 && < 2.2 + , time >= 1.9.3 && < 1.15 + , uuid >= 1.3.15 && < 1.4 + +common warnings + ghc-options: + -Wmissing-deriving-strategies + -Wmissing-export-lists + -Wmissing-import-lists + -Wredundant-constraints + -Wall + +library + import: dependencies, warnings + exposed-modules: + Squeal.QuasiQuotes + other-modules: + Squeal.QuasiQuotes.Common + Squeal.QuasiQuotes.Delete + Squeal.QuasiQuotes.Insert + Squeal.QuasiQuotes.Query + Squeal.QuasiQuotes.RowType + Squeal.QuasiQuotes.Update + hs-source-dirs: src + default-language: Haskell2010 + +test-suite test + import: dependencies, warnings + main-is: test.hs + other-modules: + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-language: Haskell2010 + build-depends: + squeal-postgresql-qq + , hspec >= 2.11.7 && < 2.12 + diff --git a/src/Squeal/QuasiQuotes.hs b/src/Squeal/QuasiQuotes.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/QuasiQuotes.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +{- | + Description: quasiquoter understanding SQL and producing [squeal-postgresql](https://hackage.haskell.org/package/squeal-postgresql) expressions. +-} +module Squeal.QuasiQuotes ( + -- * The quasi-quoter + ssql, + Field (..), + + -- * Discussion about monomorphized 'Statements' + + -- + -- $discussion +) where + +import Language.Haskell.TH.Quote + ( QuasiQuoter(QuasiQuoter, quoteDec, quoteExp, quotePat, quoteType) + ) +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 + ) +import Squeal.QuasiQuotes.Delete (toSquealDelete) +import Squeal.QuasiQuotes.Insert (toSquealInsert) +import Squeal.QuasiQuotes.Query (toSquealQuery) +import Squeal.QuasiQuotes.RowType + ( Field(Field, unField), monoManipulation, monoQuery + ) +import Squeal.QuasiQuotes.Update (toSquealUpdate) +import qualified Data.Text as Text +import qualified PostgresqlSyntax.Ast as PGT_AST +import qualified PostgresqlSyntax.Parsing as PGT_Parse + + +{- | + Splice in a squeal expression with the following type: + + > Statement db () + + @\@ is going to be some concrete tuple of the + form: + + > (Field name1 type1, + > (Field name2 type2, + > (Field name3 type3, + > , + > ()))...) + + where the "name\" are phantom types of kind `Symbol`, which provide + the name of the corresponding column, and types "type\" are whatever + appropriate haskell type represents the postgres column type. + + See the [discussion](#discussion) section for why we monomorphize the + squeal 'Statement' in this way. + + = Haskell values + + The way you get Haskell values into your sql statements is with special bulit-in sql functions: + + * @inline(\)@: Corresponds to 'Squeal.PostgreSQL.Expression.Inline.inline' (value being inlined must not be null) + * @inline_param(\)@: Corresponds to 'Squeal.PostgreSQL.Expression.Inline.inlineParam' (value can be null) + + where @\@ is a haskell identifier in scope, whose type has an + 'Squeal.PostgreSQL.Inline' instance. + + = Example + + For the examples, let's assume you have a database like this: + + > type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ] + > type UsersColumns = + > '[ "id" ::: 'Def :=> 'NotNull 'PGtext + > , "name" ::: 'NoDef :=> 'NotNull 'PGtext + > , "employee_id" ::: 'NoDef :=> 'NotNull 'PGuuid + > , "bio" ::: 'NoDef :=> 'Null 'PGtext + > ] + > type EmailsConstraints = + > '[ "pk_emails" ::: 'PrimaryKey '["id"] + > , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] + > ] + > type EmailsColumns = + > '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + > , "user_id" ::: 'NoDef :=> 'NotNull 'PGtext + > , "email" ::: 'NoDef :=> 'Null 'PGtext + > ] + > type Schema = + > '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns) + > , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) + > ] + + + == Insert Example + + > mkStatement :: Int32 -> Text -> Maybe Text -> Statement DB () () + > mkStatement emailId uid email = + > [ssql| + > insert into + > emails (id, user_id, email) + > values (inline("emailId"), inline(uid), inline_param(email)) + > |] + + Notice the quotes around @"emailId"@. This is because postgres SQL + parsing mandates the unquoted idents be converted to lower case + (as a way of being "case insensitive"), which would result in the + quasiquoter injecting the lower case @emailid@ variable, which is not + in scope. The solution is to double quote the SQL ident so that its + casing is preserved. + + == Select Example + + > mkStatement + > :: Text + > -> Statement + > DB + > () + > ( Field "id" Text + > , ( Field "name" Text + > , ( Field "email" (Maybe Text) + > , () + > ) + > ) + > ) + > mkStatement targetEmail = + > [ssql| + > select users.id, users.name, emails.email + > from users + > left outer join emails + > on emails.user_id = users.id + > where emails.email = inline("targetEmail") + > |] + + These examples are more or less taken from the + test suite. I strongly recommend reading [the test + code](https://github.com/owensmurray/squeal-postgresql-qq/blob/master/test/test.hs) + to see what is currently supported. +-} +ssql :: QuasiQuoter +ssql = + QuasiQuoter + { quoteExp = + toSqueal . PGT_Parse.run PGT_Parse.preparableStmt . Text.strip . Text.pack + , quotePat = error "pattern quotes not supported" + , quoteType = error "type quotes not supported" + , quoteDec = error "declaration quotes not supported" + } + + +toSqueal :: Either String PGT_AST.PreparableStmt -> Q Exp +toSqueal = \case + Left err -> fail err + Right statement -> do + runIO (print statement) + toSquealStatement statement + + +toSquealStatement :: PGT_AST.PreparableStmt -> Q Exp +toSquealStatement = \case + PGT_AST.SelectPreparableStmt theQuery -> do + queryExp <- toSquealQuery theQuery + pure $ VarE 'monoQuery `AppE` queryExp + PGT_AST.InsertPreparableStmt stmt -> do + manipExp <- toSquealInsert stmt + pure $ VarE 'monoManipulation `AppE` manipExp + PGT_AST.UpdatePreparableStmt stmt -> do + manipExp <- toSquealUpdate stmt + pure $ VarE 'monoManipulation `AppE` manipExp + PGT_AST.DeletePreparableStmt stmt -> do + manipExp <- toSquealDelete stmt + pure $ VarE 'monoManipulation `AppE` manipExp + unsupported -> + error $ "Unsupported statement: " <> show unsupported + + +{- $discussion + + #discussion# + + The reason we monomorphize the SQL statement using the nested tuple + structure (see 'ssql') is that Squeal by default allows for generic + based polymorphic input row types and output row types. This is + problematic for a number of reasons. It severely hinders type inference, + and it produces very bad error messages when the types are misaligned. + + If you were to manually craft Squeal expressions, you would have the + opportunity to add helpful type annotations for convenient and critical + sub-expressions of the overall top-level Squeal expression. But because + this quasi-quoter generates the Squeal expression for you, you have + no opportunity to do something similar. The only place you can place + a type annotation is at the entire top level expression generated by + the quasi-quoter. + + Therefore, the trade-offs between going with the polymorphic approach + and a monomorphic approach don't have the same costs/benefits when + using the quasi-quoter as they do when manually crafting Squeal. + + To solve this problem (or rather to choose a different set of + trade-offs), the quasi-quoter forces all input and output rows to be + monomorphized into a "canonical" Haskell type which has this nested + tuple of fields structure. Under the hood we do this via an injective + type family, so that type inference can go both ways. + + If you have a quasi-quoted query in hand, you can use a type hole to + ask GHC what its inferred concrete type is. Conversely, if you know + what the expected row type is, but your quasi-quoted SQL statement is + failing to align with your expected types, you can put your expected + row type in a type signature and get a much better error message about + how and why the SQL statement is failing to type check. +-} + + diff --git a/src/Squeal/QuasiQuotes/Common.hs b/src/Squeal/QuasiQuotes/Common.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/QuasiQuotes/Common.hs @@ -0,0 +1,986 @@ +{-# 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 + + diff --git a/src/Squeal/QuasiQuotes/Delete.hs b/src/Squeal/QuasiQuotes/Delete.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/QuasiQuotes/Delete.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Description: Translate delete statements. +module Squeal.QuasiQuotes.Delete ( + toSquealDelete, +) where + +import Control.Monad (when) +import Data.Maybe (isJust) +import Language.Haskell.TH.Syntax (Exp(AppE, ConE, LabelE, VarE), Q) +import Prelude + ( Applicative(pure), Maybe(Just, Nothing), MonadFail(fail), ($), (<$>) + ) +import Squeal.QuasiQuotes.Common + ( getIdentText, renderPGTAExpr, renderPGTTableRef, renderPGTTargetList + ) +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 + + +toSquealDelete :: PGT_AST.DeleteStmt -> Q Exp +toSquealDelete + ( PGT_AST.DeleteStmt + maybeWithClause + relationExprOptAlias + maybeUsingClause + maybeWhereClause + maybeReturningClause + ) = do + when (isJust maybeWithClause) $ + fail "WITH clauses are not supported in DELETE statements yet." + -- whereOrCurrentClause with cursor is not supported yet + + targetTableExp <- renderPGTRelationExprOptAlias' relationExprOptAlias + + usingClauseExp <- + case maybeUsingClause of + Nothing -> pure $ ConE 'S.NoUsing + Just usingClause -> AppE (ConE 'S.Using) <$> renderPGTTableRef 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.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 + + pure + ( VarE 'S.deleteFrom + `AppE` targetTableExp + `AppE` usingClauseExp + `AppE` whereConditionExp + `AppE` returningClauseExp + ) + + +renderPGTRelationExprOptAlias' :: PGT_AST.RelationExprOptAlias -> Q Exp +renderPGTRelationExprOptAlias' (PGT_AST.RelationExprOptAlias relationExpr maybeAlias) = do + (tableName, schemaName) <- + case relationExpr of + PGT_AST.SimpleRelationExpr (PGT_AST.SimpleQualifiedName ident) _ -> + pure (getIdentText ident, Nothing) + PGT_AST.SimpleRelationExpr + ( PGT_AST.IndirectedQualifiedName + schemaIdent + (PGT_AST.AttrNameIndirectionEl tableIdent NE.:| []) + ) + _ -> + pure (getIdentText tableIdent, Just (getIdentText schemaIdent)) + _ -> fail "Unsupported relation expression in DELETE statement." + + let + aliasName = case maybeAlias of + Just (_, colId) -> getIdentText colId + Nothing -> tableName + + let + qualifiedAlias = case schemaName of + Nothing -> LabelE (Text.unpack tableName) + Just schema -> + VarE '(S.!) + `AppE` LabelE (Text.unpack schema) + `AppE` LabelE (Text.unpack tableName) + + pure $ VarE 'S.as `AppE` qualifiedAlias `AppE` LabelE (Text.unpack aliasName) + + diff --git a/src/Squeal/QuasiQuotes/Insert.hs b/src/Squeal/QuasiQuotes/Insert.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/QuasiQuotes/Insert.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Description: Translate insert statements. +module Squeal.QuasiQuotes.Insert ( + toSquealInsert, +) where + +import Control.Monad (MonadFail(fail), mapM, when, zipWithM) +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 + ) +import Squeal.QuasiQuotes.Common (getIdentText, renderPGTAExpr) +import Squeal.QuasiQuotes.Query (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 + + +toSquealInsert :: PGT_AST.InsertStmt -> Q Exp +toSquealInsert + ( PGT_AST.InsertStmt + maybeWithClause + insertTarget + insertRest + maybeOnConflict + maybeReturningClause + ) = do + when (isJust maybeWithClause) $ + fail "WITH clauses are not supported in INSERT statements yet." + when (isJust maybeOnConflict) $ + fail "ON CONFLICT clauses are not supported yet." + + insertBody <- + case insertRest of + PGT_AST.SelectInsertRest maybeInsertColumnList maybeOverrideKind selectStmt -> do + when (isJust maybeOverrideKind) $ + fail "OVERRIDING clause is not supported yet." + queryClauseExp <- + case selectStmt of + -- Case 1: INSERT ... VALUES ... + Left + (PGT_AST.SelectNoParens _ (Left (PGT_AST.ValuesSimpleSelect valuesClause)) _ _ _) -> + case maybeInsertColumnList of + Just colItems -> + renderPGTValueRows (NE.toList colItems) valuesClause + Nothing -> + fail + "INSERT INTO ... VALUES must specify column names for the Squeal-QQ translation." + -- Case 2: INSERT ... SELECT ... (a general SELECT statement) + _ -> + -- selectStmt is not a ValuesSimpleSelect (i.e., it's a general query) + case maybeInsertColumnList of + Just _ -> + 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 + pure (ConE 'S.Subquery `AppE` squealQueryExp) + let + table = renderPGTInsertTarget insertTarget + case maybeReturningClause of + Nothing -> + pure $ VarE 'S.insertInto_ `AppE` table `AppE` queryClauseExp + Just (NE.toList -> [PGT_AST.AsteriskTargetEl]) -> do + let + returning = ConE 'S.Returning `AppE` ConE 'S.Star + pure $ + VarE 'S.insertInto + `AppE` table + `AppE` queryClauseExp + `AppE` ConE 'S.OnConflictDoRaise + `AppE` returning + Just targetList -> do + returningProj <- renderTargetList (NE.toList targetList) + let + returning = ConE 'S.Returning `AppE` (ConE 'S.List `AppE` returningProj) + pure $ + VarE 'S.insertInto + `AppE` table + `AppE` queryClauseExp + `AppE` ConE 'S.OnConflictDoRaise + `AppE` returning + PGT_AST.DefaultValuesInsertRest -> + fail "INSERT INTO ... DEFAULT VALUES is not yet supported by Squeal-QQ." + + pure insertBody + + +renderTargetList :: [PGT_AST.TargetEl] -> Q Exp +renderTargetList targetEls = do + exps <- mapM renderTargetEl targetEls + pure $ + foldr + (\h t -> ConE '(S.:*) `AppE` h `AppE` t) + (ConE 'S.Nil) + exps + + +renderTargetEl :: PGT_AST.TargetEl -> Q Exp +renderTargetEl = \case + PGT_AST.ExprTargetEl expr -> do + exprExp <- renderPGTAExpr expr + case expr of + PGT_AST.CExprAExpr (PGT_AST.ColumnrefCExpr (PGT_AST.Columnref ident Nothing)) -> + let + colName = getIdentText ident + in + pure $ VarE 'S.as `AppE` exprExp `AppE` LabelE (Text.unpack colName) + _ -> + 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 + pure $ + VarE 'S.as `AppE` exprExp `AppE` LabelE (Text.unpack (getIdentText alias)) + PGT_AST.AsteriskTargetEl -> fail "should be handled by toSquealInsert" + PGT_AST.ImplicitlyAliasedExprTargetEl{} -> + fail "Implicitly aliased expressions in RETURNING are not supported" + + +getUnqualifiedNameFromAst :: PGT_AST.QualifiedName -> Text.Text +getUnqualifiedNameFromAst (PGT_AST.SimpleQualifiedName ident) = getIdentText ident +getUnqualifiedNameFromAst (PGT_AST.IndirectedQualifiedName _ (PGT_AST.AttrNameIndirectionEl ident NE.:| [])) = getIdentText ident +getUnqualifiedNameFromAst unsupported = + error $ + "Unsupported qualified name structure for extracting unqualified name: " + <> show unsupported + + +renderPGTInsertTarget :: PGT_AST.InsertTarget -> Exp +renderPGTInsertTarget (PGT_AST.InsertTarget qualifiedName maybeAsAlias) = + let + tableIdentifierExp = renderPGTQualifiedName qualifiedName + targetAliasText = case maybeAsAlias of + Nothing -> getUnqualifiedNameFromAst qualifiedName + Just asAliasColId -> getIdentText asAliasColId + targetAliasExp = LabelE (Text.unpack targetAliasText) + in + VarE 'S.as `AppE` tableIdentifierExp `AppE` targetAliasExp + + +renderPGTQualifiedName :: PGT_AST.QualifiedName -> Exp +renderPGTQualifiedName = \case + PGT_AST.SimpleQualifiedName ident -> LabelE (Text.unpack (getIdentText ident)) -- Defaults to public schema + PGT_AST.IndirectedQualifiedName + schemaIdent + (PGT_AST.AttrNameIndirectionEl colIdent NE.:| []) -> + -- Assuming simple schema.table form + VarE '(S.!) + `AppE` LabelE (Text.unpack (getIdentText schemaIdent)) + `AppE` LabelE (Text.unpack (getIdentText colIdent)) + unsupported -> error $ "Unsupported qualified name structure: " <> show unsupported + + +renderPGTValueRows + :: [PGT_AST.InsertColumnItem] -> PGT_AST.ValuesClause -> Q Exp +renderPGTValueRows 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 + 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 + + 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 + + diff --git a/src/Squeal/QuasiQuotes/Query.hs b/src/Squeal/QuasiQuotes/Query.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/QuasiQuotes/Query.hs @@ -0,0 +1,568 @@ +{-# 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 (no FROM, no other clauses) + -- Translate to S.values_ + renderedTargetingForValues <- + renderPGTTargetingForValues targeting + pure $ + VarE 'S.values_ `AppE` renderedTargetingForValues + (Nothing, _, _, _, _, _, _) -> + {- + Case: SELECT (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" + + diff --git a/src/Squeal/QuasiQuotes/RowType.hs b/src/Squeal/QuasiQuotes/RowType.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/QuasiQuotes/RowType.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | + Description: Monomorphic squeal row types. + + This module provides a type family that converts a squeal row type into + a specific, monomorphic tuple representation meant to be consumed by the + user. The purpose of this so that the squeal quasiquoter won't produce + polymorphic types, though it will produce a *different* monomorphic + type depending on the columns returned by the query. The reason we want + this is to help type inference as much as possible. Squeal already + has some problems with type inference, and the burden on the user of + navigating them is only likely to increase when a lot of the squeal + "code" itself is hidden behind a quasiquoter. +-} +module Squeal.QuasiQuotes.RowType ( + RowType, + monoQuery, + monoManipulation, + Field (..), +) where + +import Data.Aeson (Value) +import Data.Int (Int32, Int64) +import Data.Text (Text) +import Data.Time (Day, UTCTime) +import Data.UUID (UUID) +import GHC.TypeLits (Symbol) +import Generics.SOP (SListI) +import Prelude (Applicative(pure), (<$>), Bool, Maybe) +import Squeal.PostgreSQL + ( FromValue(fromValue), IsLabel(fromLabel), NullType(NotNull, Null) + , PGType(PGbool, PGdate, PGint4, PGint8, PGjson, PGjsonb, PGtext, PGtimestamptz, PGuuid) + , (:::), Json, Jsonb + ) +import qualified Squeal.PostgreSQL as Squeal + + + + +{- FOURMOLU_DISABLE -} +type family RowType a = b | b -> a where + {- + It would be more convenient to use a helper type family here that + would map PGtypes to Haskell types. But if we did that, we would + not be able to make this type family injective. + + This is Because GHC would not be able to tell that the right-hand + side of this type family did not overlap even if that the helper + type family were itself injective. Injectivity of the helper is not + enough. The specific helper definition must happen to not produce + instances that overlap with any Maybe type when used here. + + For instance, this example helper type family is injective, but when + used here it would produce overlapping values for the `NotNull PGint4` + and `Null PGbool` equations. + + type family Helper x = a | a -> x where + Helper Int32 = Maybe Bool + Helper Bool = Bool + -} + RowType (fld ::: 'NotNull PGbool ': more) = (Field fld Bool, RowType more) + RowType (fld ::: 'NotNull PGint4 ': more) = (Field fld Int32, RowType more) + RowType (fld ::: 'NotNull PGint8 ': more) = (Field fld Int64, RowType more) + RowType (fld ::: 'NotNull PGtext ': more) = (Field fld Text, RowType more) + RowType (fld ::: 'NotNull PGuuid ': more) = (Field fld UUID, RowType more) + RowType (fld ::: 'NotNull PGdate ': more) = (Field fld Day, RowType more) + RowType (fld ::: 'NotNull PGtimestamptz ': more) = (Field fld UTCTime, RowType more) + RowType (fld ::: 'NotNull PGjsonb ': more) = (Field fld (Jsonb Value), RowType more) + RowType (fld ::: 'NotNull PGjson ': more) = (Field fld (Json Value), RowType more) + + RowType (fld ::: 'Null PGbool ': more) = (Field fld (Maybe Bool), RowType more) + RowType (fld ::: 'Null PGint4 ': more) = (Field fld (Maybe Int32), RowType more) + RowType (fld ::: 'Null PGint8 ': more) = (Field fld (Maybe Int64), RowType more) + RowType (fld ::: 'Null PGtext ': more) = (Field fld (Maybe Text), RowType more) + RowType (fld ::: 'Null PGuuid ': more) = (Field fld (Maybe UUID), RowType more) + RowType (fld ::: 'Null PGdate ': more) = (Field fld (Maybe Day), RowType more) + RowType (fld ::: 'Null PGtimestamptz ': more) = (Field fld (Maybe UTCTime), RowType more) + RowType (fld ::: 'Null PGjsonb ': more) = (Field fld (Maybe (Jsonb Value)), RowType more) + RowType (fld ::: 'Null PGjson ': more) = (Field fld (Maybe (Json Value)), RowType more) + RowType '[] = () +{- FOURMOLU_ENABLE -} + + +newtype Field (name :: Symbol) a = Field + { unField :: a + } +instance + (Squeal.FromValue pg hask) + => + Squeal.FromValue pg (Field name hask) + where + fromValue mbs = Field @name <$> Squeal.fromValue @pg mbs + + +{- | + Like 'Squeal.query', but use the monomorphizing 'RowType' family to + fully specify the output rows. This is mainly a convenience to the + template haskell code so it can simply quote this function instead of + having to basically inline it directly in TH. +-} +monoQuery + :: forall db params input row ignored. + ( HasRowDecoder row (RowType row) + , SListI row + , Squeal.GenericParams db params input ignored + ) + => Squeal.Query '[] '[] db params row + -> Squeal.Statement db input (RowType row) +monoQuery = Squeal.Query Squeal.genericParams getRowDecoder + + +monoManipulation + :: forall db params input row ignored. + ( HasRowDecoder row (RowType row) + , SListI row + , Squeal.GenericParams db params input ignored + ) + => Squeal.Manipulation '[] db params row + -> Squeal.Statement db input (RowType row) +monoManipulation = Squeal.Manipulation Squeal.genericParams getRowDecoder + + +class HasRowDecoder row x where + getRowDecoder :: Squeal.DecodeRow row x +instance + ( HasRowDecoder moreRow moreFields + , Squeal.FromValue typ t + ) + => + HasRowDecoder ((fld ::: typ) ': moreRow) (Field fld t, moreFields) + where + getRowDecoder = + Squeal.consRow + (,) + (fromLabel @fld) + (getRowDecoder @moreRow @moreFields) +instance () => HasRowDecoder '[] () where + getRowDecoder = pure () + + diff --git a/src/Squeal/QuasiQuotes/Update.hs b/src/Squeal/QuasiQuotes/Update.hs new file mode 100644 --- /dev/null +++ b/src/Squeal/QuasiQuotes/Update.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Description: Translate update statements. +module Squeal.QuasiQuotes.Update ( + toSquealUpdate, +) where + +import Data.Text (Text) +import Control.Monad (when) +import Data.Maybe (isJust) +import Language.Haskell.TH.Syntax (Exp(AppE, ConE, LabelE, VarE), Q) +import Prelude + ( Applicative(pure), Foldable(foldr), Maybe(Just, Nothing), MonadFail(fail) + , Traversable(mapM), ($), (<$>) + ) +import Squeal.QuasiQuotes.Common + ( getIdentText, renderPGTAExpr, renderPGTTableRef, renderPGTTargetList + ) +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 + + +toSquealUpdate :: PGT_AST.UpdateStmt -> Q Exp +toSquealUpdate + ( PGT_AST.UpdateStmt + maybeWithClause + relationExprOptAlias + setClauseList + maybeFromClause + maybeWhereClause + maybeReturningClause + ) = do + when (isJust maybeWithClause) $ + fail "WITH clauses are not supported in UPDATE statements yet." + targetTableExp <- renderPGTRelationExprOptAlias' relationExprOptAlias + + setClauseExp <- renderPGTSetClauseList setClauseList + + usingClauseExp <- + case maybeFromClause of + Nothing -> pure $ ConE 'S.NoUsing + Just fromClause -> AppE (ConE 'S.Using) <$> renderPGTTableRef 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.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 + + pure $ + ( VarE 'S.update + `AppE` targetTableExp + `AppE` setClauseExp + `AppE` usingClauseExp + `AppE` whereConditionExp + `AppE` returningClauseExp + ) + + +renderPGTRelationExprOptAlias' :: PGT_AST.RelationExprOptAlias -> Q Exp +renderPGTRelationExprOptAlias' (PGT_AST.RelationExprOptAlias relationExpr maybeAlias) = do + (tableName, schemaName) <- + case relationExpr of + PGT_AST.SimpleRelationExpr (PGT_AST.SimpleQualifiedName ident) _ -> + pure (getIdentText ident, Nothing) + PGT_AST.SimpleRelationExpr + ( PGT_AST.IndirectedQualifiedName + schemaIdent + (PGT_AST.AttrNameIndirectionEl tableIdent NE.:| []) + ) + _ -> + pure (getIdentText tableIdent, Just (getIdentText schemaIdent)) + _ -> fail "Unsupported relation expression in UPDATE statement." + + let + aliasName :: Text + aliasName = + case maybeAlias of + Just (_, colId) -> getIdentText colId + Nothing -> tableName + + qualifiedAlias :: Exp + qualifiedAlias = + case schemaName of + Nothing -> LabelE (Text.unpack tableName) + Just schema -> + VarE '(S.!) + `AppE` LabelE (Text.unpack schema) + `AppE` LabelE (Text.unpack tableName) + + 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) + pure $ + foldr + (\item acc -> ConE '(S.:*) `AppE` item `AppE` acc) + (ConE 'S.Nil) + renderedItems + + +renderPGTSetClause :: PGT_AST.SetClause -> Q Exp +renderPGTSetClause = \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 + pure $ + VarE 'S.as + `AppE` (ConE 'S.Set `AppE` renderedExpr) + `AppE` LabelE colNameStr + PGT_AST.TargetListSetClause _ _ -> + fail + "UPDATE with multiple SET targets (e.g. (col1, col2) = (val1, val2)) is not yet supported." + + diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,1530 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- {-# OPTIONS_GHC -ddump-splices #-} + +module Main (main) where + +import Data.Aeson (Value) +import Data.Int (Int32, Int64) +import Data.Text (Text) +import Data.Time (Day, UTCTime) +import Data.UUID (UUID) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Prelude + ( Applicative(pure), Eq((==)), Maybe(Just, Nothing), MonadFail(fail) + , Semigroup((<>)), Show(show), ($), (.), Bool, IO, putStrLn + ) +import Squeal.PostgreSQL + ( NullType(NotNull, Null), Optionality(Def, NoDef) + , PGType(PGint4, PGjson, PGjsonb, PGtext, PGuuid), RenderSQL(renderSQL) + , SchemumType(Table), TableConstraint(ForeignKey, PrimaryKey), (:::), (:=>) + , Json, Jsonb, Only, Statement + ) +import Squeal.QuasiQuotes (Field, ssql) +import Test.Hspec (describe, hspec, it) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Generics.SOP as SOP + + + + +{- FOURMOLU_DISABLE -} +{- Copied mostly from the squeal documentation: -} +type UsersColumns = + '[ "id" ::: 'Def :=> 'NotNull 'PGtext + , "name" ::: 'NoDef :=> 'NotNull 'PGtext + , "employee_id" ::: 'NoDef :=> 'NotNull 'PGuuid + , "bio" ::: 'NoDef :=> 'Null 'PGtext + ] +type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ] +type EmailsColumns = + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "user_id" ::: 'NoDef :=> 'NotNull 'PGtext + , "email" ::: 'NoDef :=> 'Null 'PGtext + ] +type EmailsConstraints = + '[ "pk_emails" ::: 'PrimaryKey '["id"] + , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] + ] +type Schema = + '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns) + , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) + , "jsonb_test" ::: 'Table ('[] :=> '["data" ::: 'NoDef :=> 'NotNull 'PGjsonb]) + , "json_test" ::: 'Table ('[] :=> '["data" ::: 'NoDef :=> 'NotNull 'PGjson]) + , "users_copy" ::: 'Table (UsersCopyConstraints :=> UsersCopyColumns) + ] +type UsersCopyColumns = + '[ "id" ::: 'NoDef :=> 'NotNull 'PGtext + , "name" ::: 'NoDef :=> 'NotNull 'PGtext + , "bio" ::: 'NoDef :=> 'Null 'PGtext + ] +type UsersCopyConstraints = '[ "pk_users_copy" ::: 'PrimaryKey '["id"] ] +type DB = + '[ "public" ::: Schema + , "other" ::: Schema + ] +{- FOURMOLU_ENABLE -} + + +data User = User + { id :: Text + , name :: Text + } + deriving stock (Generic, Show) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + + +main :: IO () +main = + hspec $ do + describe "queries" $ do + it "select * from users" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + statement = [ssql| select * from users |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"users\" AS \"users\"" + checkStatement squealRendering statement + + it "select * from public.users" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + statement = [ssql| select * from public.users |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"users\" AS \"users\"" + checkStatement squealRendering statement + + it "SELECT * FROM \"users\" AS \"users\"" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + statement = [ssql| SELECT * FROM "users" AS "users" |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"users\" AS \"users\"" + checkStatement squealRendering statement + + it "select * from users where name = 'bob'" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + statement = [ssql| select * from users where name = 'bob' |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"users\" AS \"users\" WHERE (\"name\" = (E'bob' :: text))" + checkStatement squealRendering statement + + it "select user.name from users" $ do + let + statement :: Statement DB () (Field "name" Text, ()) + statement = [ssql| select users.name from users |] + squealRendering :: Text + squealRendering = "SELECT \"users\".\"name\" AS \"name\" FROM \"users\" AS \"users\"" + checkStatement squealRendering statement + + it "select name from users" $ do + let + statement :: Statement DB () (Field "name" Text, ()) + statement = [ssql| select name from users |] + squealRendering :: Text + squealRendering = "SELECT \"name\" AS \"name\" FROM \"users\" AS \"users\"" + checkStatement squealRendering statement + + it "select count(*) from users group by ()" $ do + let + statement :: Statement DB () (Field "_col1" Int64, ()) + statement = [ssql| select count(*) from users group by () |] + squealRendering :: Text + squealRendering = "SELECT count(*) AS \"_col1\" FROM \"users\" AS \"users\"" + checkStatement squealRendering statement + + it "select name, id from users" $ do + let + statement + :: Statement + DB + () + ( Field "name" Text + , ( Field "id" Text + , () + ) + ) + statement = [ssql| select name, id from users |] + squealRendering :: Text + squealRendering = "SELECT \"name\" AS \"name\", \"id\" AS \"id\" FROM \"users\" AS \"users\"" + checkStatement squealRendering statement + + it "select id, name from users" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , () + ) + ) + statement = [ssql| select id, name from users |] + squealRendering :: Text + squealRendering = "SELECT \"id\" AS \"id\", \"name\" AS \"name\" FROM \"users\" AS \"users\"" + checkStatement squealRendering statement + + it "select users.id, employee_id from users" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "employee_id" UUID + , () + ) + ) + statement = [ssql| select users.id, employee_id from users |] + squealRendering :: Text + squealRendering = + "SELECT \"users\".\"id\" AS \"id\", \"employee_id\" AS \"employee_id\" FROM \"users\" AS \"users\"" + checkStatement squealRendering statement + + it "select users.* from users" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + statement = [ssql| select users.* from users |] + squealRendering :: Text + squealRendering = "SELECT \"users\".* FROM \"users\" AS \"users\"" + checkStatement squealRendering statement + + it "select users.* from other.users" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + statement = [ssql| select users.* from other.users |] + squealRendering :: Text + squealRendering = "SELECT \"users\".* FROM \"other\".\"users\" AS \"users\"" + checkStatement squealRendering statement + + it "select * from users limit 3" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + statement = [ssql| select * from users limit 3 |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"users\" AS \"users\" LIMIT 3" + checkStatement squealRendering statement + + it "select * from users limit inline(lim)" $ do + let + mkStatement + :: Word64 + -> Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + mkStatement lim = + [ssql| select * from users limit inline(lim) |] + + squealRendering1 :: Text + squealRendering1 = "SELECT * FROM \"users\" AS \"users\" LIMIT 10" + + squealRendering2 :: Text + squealRendering2 = "SELECT * FROM \"users\" AS \"users\" LIMIT 20" + + checkStatement squealRendering1 (mkStatement 10) + checkStatement squealRendering2 (mkStatement 20) + + it "select * from users offset inline(off)" $ do + let + mkStatement + :: Word64 + -> Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + mkStatement off = + [ssql| select * from users offset inline(off) |] + + squealRendering1 :: Text + squealRendering1 = "SELECT * FROM \"users\" AS \"users\" OFFSET 5" + + squealRendering2 :: Text + squealRendering2 = "SELECT * FROM \"users\" AS \"users\" OFFSET 15" + + checkStatement squealRendering1 (mkStatement 5) + checkStatement squealRendering2 (mkStatement 15) + + it "select * from users offset 1" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + statement = [ssql| select * from users offset 1 |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"users\" AS \"users\" OFFSET 1" + checkStatement squealRendering statement + + it "select users.id, employee_id as emp_id from users" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "emp_id" UUID + , () + ) + ) + statement = [ssql| select users.id, employee_id as emp_id from users |] + squealRendering :: Text + squealRendering = + "SELECT \"users\".\"id\" AS \"id\", \"employee_id\" AS \"emp_id\" FROM \"users\" AS \"users\"" + checkStatement squealRendering statement + + it "select users.id as user_id, employee_id from users" $ do + let + statement + :: Statement + DB + () + ( Field "user_id" Text + , ( Field "employee_id" UUID + , () + ) + ) + statement = [ssql| select users.id as user_id, employee_id from users |] + squealRendering :: Text + squealRendering = + "SELECT \"users\".\"id\" AS \"user_id\", \"employee_id\" AS \"employee_id\" FROM \"users\" AS \"users\"" + checkStatement squealRendering statement + + it + "select users.id from users left outer join emails on users.id == emails.user_id" + $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , () + ) + statement = + [ssql| + select users.id + from users + left outer join emails + on emails.user_id = users.id + |] + squealRendering :: Text + squealRendering = + "SELECT \"users\".\"id\" AS \"id\" FROM \"users\" AS \"users\" LEFT OUTER JOIN \"emails\" AS \"emails\" ON (\"emails\".\"user_id\" = \"users\".\"id\")" + checkStatement squealRendering statement + + it + "select * from users left outer join emails on users.id == emails.user_id" + $ do + let + targetEmail :: Text + targetEmail = "foo@bar.com" + + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "email" (Maybe Text) + , () + ) + ) + ) + statement = + [ssql| + select users.id, users.name, emails.email + from users + left outer join emails + on emails.user_id = users.id + where emails.email = inline("targetEmail") + |] + + squealRendering :: Text + squealRendering = + "SELECT \"users\".\"id\" AS \"id\", \"users\".\"name\" AS \"name\", \"emails\".\"email\" AS \"email\" FROM \"users\" AS \"users\" LEFT OUTER JOIN \"emails\" AS \"emails\" ON (\"emails\".\"user_id\" = \"users\".\"id\") WHERE (\"emails\".\"email\" = (E'foo@bar.com' :: text))" + + checkStatement squealRendering statement + + it "select 'text_val'" $ do + let + statement + :: Statement + DB + () + ( Field "_col1" Text + , () + ) + statement = [ssql| select 'text_val' |] + squealRendering :: Text + squealRendering = "SELECT * FROM (VALUES ((E'text_val' :: text))) AS t (\"_col1\")" + checkStatement squealRendering statement + + it "select 1" $ do + let + statement + :: Statement + DB + () + ( Field "_col1" Int64 + , () + ) + statement = [ssql| select 1 |] + squealRendering :: Text + squealRendering = "SELECT * FROM (VALUES (1)) AS t (\"_col1\")" + checkStatement squealRendering statement + + it "select 1 AS num, 'text_val' AS txt" $ do + let + statement + :: Statement + DB + () + ( Field "num" Int64 + , ( Field "txt" Text + , () + ) + ) + statement = [ssql| select 1 AS num, 'text_val' AS txt |] + squealRendering :: Text + squealRendering = "SELECT * FROM (VALUES (1, (E'text_val' :: text))) AS t (\"num\", \"txt\")" + checkStatement squealRendering statement + + describe "group by" $ do + it "select name from users group by name" $ do + let + statement :: Statement DB () (Field "name" Text, ()) + statement = [ssql| select name from users group by name |] + squealRendering :: Text + squealRendering = "SELECT \"name\" AS \"name\" FROM \"users\" AS \"users\" GROUP BY \"name\"" + checkStatement squealRendering statement + + it "select employee_id, count(id) from users group by employee_id" $ do + let + statement + :: Statement + DB + () + ( Field "employee_id" UUID + , ( Field "_col2" Int64 -- Assuming count returns Int64 + , () + ) + ) + statement = [ssql| select employee_id, count(id) from users group by employee_id |] + squealRendering :: Text + squealRendering = + "SELECT \"employee_id\" AS \"employee_id\", count(ALL \"id\") AS \"_col2\" FROM \"users\" AS \"users\" GROUP BY \"employee_id\"" + checkStatement squealRendering statement + + it "select employee_id, name, count(id) from users group by employee_id, name" $ do + let + statement + :: Statement + DB + () + ( Field "employee_id" UUID + , ( Field "name" Text + , ( Field "_col3" Int64 + , () + ) + ) + ) + statement = + [ssql| select employee_id, name, count(id) from users group by employee_id, name |] + squealRendering :: Text + squealRendering = + "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 "inserts" $ do + it "insert into emails (id, user_id, email) values (1, 'user-1', 'foo@bar')" $ do + let + statement + :: Statement DB () () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (1, 'user-1', 'foo@bar') + |] + squealRendering :: Text + squealRendering = + "INSERT INTO \"emails\" AS \"emails\" (\"id\", \"user_id\", \"email\") VALUES (1, (E'user-1' :: text), (E'foo@bar' :: text))" + checkStatement squealRendering statement + + it "insert into emails (id, user_id, email) values (1, 'user-1', $1)" $ do + let + statement + :: Statement + DB + (Only (Maybe Text)) + () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (1, 'user-1', $1) + |] + squealRendering :: Text + squealRendering = + "INSERT INTO \"emails\" AS \"emails\" (\"id\", \"user_id\", \"email\") VALUES (1, (E'user-1' :: text), ($1 :: text))" + checkStatement squealRendering statement + + it "insert into emails (id, user_id, email) values (1, $2, $1)" $ do + let + statement + :: Statement + DB + (Maybe Text, Text) + () + statement = + {- + Note the parameters are backwards (i.e. $2 comes before $1), + to test that you can do this kind of thing out of order. + -} + [ssql| + insert into + emails (id, user_id, email) + values (1, $2, $1) + |] + squealRendering :: Text + squealRendering = + "INSERT INTO \"emails\" AS \"emails\" (\"id\", \"user_id\", \"email\") VALUES (1, ($2 :: text), ($1 :: text))" + checkStatement squealRendering statement + + it + "insert into emails (id, user_id, email) values (inline(i), inline(uid), inline(e))" + $ do + let + mkStatement :: Int32 -> Text -> Maybe Text -> Statement DB () () + mkStatement i uid e = + [ssql| + insert into + emails (id, user_id, email) + values (inline(i), inline(uid), inline_param(e)) + |] + + checkStatement + "INSERT INTO \"emails\" AS \"emails\" (\"id\", \"user_id\", \"email\") VALUES ((1 :: int4), (E'user-1' :: text), NULL)" + (mkStatement 1 "user-1" Nothing) + checkStatement + "INSERT INTO \"emails\" AS \"emails\" (\"id\", \"user_id\", \"email\") VALUES ((1 :: int4), (E'user-1' :: text), (E'foo@bar.com' :: text))" + (mkStatement 1 "user-1" (Just "foo@bar.com")) + + describe "default keyword" $ do + it "insert into emails (id, user_id, email) values (default, 'foo', 'bar')" $ do + let + statement + :: Statement + DB + (Maybe Text, Text) + () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (default, 'foo', 'bar') + |] + squealRendering :: Text + squealRendering = + "INSERT INTO \"emails\" AS \"emails\" (\"id\", \"user_id\", \"email\") VALUES (DEFAULT, (E'foo' :: text), (E'bar' :: text))" + checkStatement squealRendering statement + + it "insert into emails (id, user_id, email) values (deFault, 'foo', 'bar')" $ do + let + statement + :: Statement + DB + (Maybe Text, Text) + () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (deFault, 'foo', 'bar') + |] + squealRendering :: Text + squealRendering = + "INSERT INTO \"emails\" AS \"emails\" (\"id\", \"user_id\", \"email\") VALUES (DEFAULT, (E'foo' :: text), (E'bar' :: text))" + checkStatement squealRendering statement + + it "insert into emails (id, user_id, email) values (DEFAULT, 'foo', 'bar')" $ do + let + statement + :: Statement + DB + (Maybe Text, Text) + () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (DEFAULT, 'foo', 'bar') + |] + squealRendering :: Text + squealRendering = + "INSERT INTO \"emails\" AS \"emails\" (\"id\", \"user_id\", \"email\") VALUES (DEFAULT, (E'foo' :: text), (E'bar' :: text))" + checkStatement squealRendering statement + + describe "null keyword" $ do + it "insert into emails (id, user_id, email) values (DEFAULT, 'foo', null)" $ do + let + statement + :: Statement + DB + (Maybe Text, Text) + () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (DEFAULT, 'foo', null) + |] + squealRendering :: Text + squealRendering = + "INSERT INTO \"emails\" AS \"emails\" (\"id\", \"user_id\", \"email\") VALUES (DEFAULT, (E'foo' :: text), NULL)" + checkStatement squealRendering statement + + it "insert into emails (id, user_id, email) values (DEFAULT, 'foo', NULL)" $ do + let + statement + :: Statement + DB + (Maybe Text, Text) + () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (DEFAULT, 'foo', NULL) + |] + squealRendering :: Text + squealRendering = + "INSERT INTO \"emails\" AS \"emails\" (\"id\", \"user_id\", \"email\") VALUES (DEFAULT, (E'foo' :: text), NULL)" + checkStatement squealRendering statement + + it "insert into emails (id, user_id, email) values (DEFAULT, 'foo', NuLL)" $ do + let + statement + :: Statement + DB + (Maybe Text, Text) + () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (DEFAULT, 'foo', NuLL) + |] + squealRendering :: Text + squealRendering = + "INSERT INTO \"emails\" AS \"emails\" (\"id\", \"user_id\", \"email\") VALUES (DEFAULT, (E'foo' :: text), NULL)" + checkStatement squealRendering statement + + describe "insert ... select ..." $ do + it "insert into emails select id, user_id, email from emails where id = 1" $ do + let + statement :: Statement DB () () + statement = + [ssql| + insert into emails + select id, user_id, email from emails where id = 1 + |] + squealRendering :: Text + squealRendering = + "INSERT INTO \"emails\" AS \"emails\" SELECT \"id\" AS \"id\", \"user_id\" AS \"user_id\", \"email\" AS \"email\" FROM \"emails\" AS \"emails\" WHERE (\"id\" = 1)" + checkStatement squealRendering statement + + it "insert into emails select id, user_id, email from emails where id = $1" $ do + let + statement :: Statement DB (Only Int32) () + statement = + [ssql| + insert into emails + select id, user_id, email from emails where id = $1 + |] + squealRendering :: Text + squealRendering = + "INSERT INTO \"emails\" AS \"emails\" SELECT \"id\" AS \"id\", \"user_id\" AS \"user_id\", \"email\" AS \"email\" FROM \"emails\" AS \"emails\" WHERE (\"id\" = ($1 :: int4))" + checkStatement squealRendering statement + + it + "insert into users_copy select id, name, bio from users where users.id = 'uid1'" + $ do + let + statement :: Statement DB () () + statement = + [ssql| + insert into users_copy + select id, name, bio from users where users.id = 'uid1' + |] + squealRendering :: Text + squealRendering = + "INSERT INTO \"users_copy\" AS \"users_copy\" SELECT \"id\" AS \"id\", \"name\" AS \"name\", \"bio\" AS \"bio\" FROM \"users\" AS \"users\" WHERE (\"users\".\"id\" = (E'uid1' :: text))" + checkStatement squealRendering statement + + describe "returning clause" $ do + it + "insert into emails (id, user_id, email) values (1, 'user-1', 'foo@bar') returning id" + $ do + let + statement + :: Statement DB () (Field "id" Int32, ()) + statement = + [ssql| + insert into + emails (id, user_id, email) + values (1, 'user-1', 'foo@bar') + returning id + |] + squealRendering :: Text + squealRendering = + "INSERT INTO \"emails\" AS \"emails\" (\"id\", \"user_id\", \"email\") VALUES (1, (E'user-1' :: text), (E'foo@bar' :: text)) RETURNING \"id\" AS \"id\"" + checkStatement squealRendering statement + + it + "insert into emails (id, user_id, email) values (1, 'user-1', 'foo@bar') returning *" + $ do + let + statement + :: Statement + DB + () + ( Field "id" Int32 + , ( Field "user_id" Text + , ( Field "email" (Maybe Text) + , () + ) + ) + ) + statement = + [ssql| + insert into + emails (id, user_id, email) + values (1, 'user-1', 'foo@bar') + returning * + |] + squealRendering :: Text + squealRendering = + "INSERT INTO \"emails\" AS \"emails\" (\"id\", \"user_id\", \"email\") VALUES (1, (E'user-1' :: text), (E'foo@bar' :: text)) RETURNING *" + checkStatement squealRendering statement + + describe "deletes" $ do + it "delete from users where true" $ do + let + statement :: Statement DB () () + statement = [ssql| delete from users where true |] + squealRendering :: Text + squealRendering = "DELETE FROM \"users\" AS \"users\" WHERE TRUE" + + checkStatement squealRendering statement + + it "delete from emails where id = 1" $ do + let + statement :: Statement DB () () + statement = [ssql| delete from emails where id = 1 |] + squealRendering :: Text + squealRendering = + "DELETE FROM \"emails\" AS \"emails\" WHERE (\"id\" = 1)" + checkStatement squealRendering statement + + it "delete from emails where email = inline(e)" $ do + let + statement :: Statement DB () () + statement = [ssql| delete from emails where email = inline(e) |] + e :: Text + e = "foo" + squealRendering :: Text + squealRendering = + "DELETE FROM \"emails\" AS \"emails\" WHERE (\"email\" = (E'foo' :: text))" + checkStatement squealRendering statement + + it "delete from users where id = 'some-id' returning id" $ do + let + statement :: Statement DB () (Field "id" Text, ()) + statement = [ssql| delete from users where id = 'some-id' returning id |] + squealRendering :: Text + squealRendering = + "DELETE FROM \"users\" AS \"users\" WHERE (\"id\" = (E'some-id' :: text)) RETURNING \"id\" AS \"id\"" + checkStatement squealRendering statement + + describe "updates" $ do + it "update users set name = 'new name' where id = 'some-id'" $ do + let + statement :: Statement DB () () + statement = [ssql| update users set name = 'new name' where id = 'some-id' |] + squealRendering :: Text + squealRendering = + "UPDATE \"users\" AS \"users\" SET \"name\" = (E'new name' :: text) WHERE (\"id\" = (E'some-id' :: text))" + checkStatement squealRendering statement + + it "update users set name = 'new name', bio = 'new bio' where id = 'some-id'" $ do + let + statement :: Statement DB () () + statement = + [ssql| update users set name = 'new name', bio = 'new bio' where id = 'some-id' |] + squealRendering :: Text + squealRendering = + "UPDATE \"users\" AS \"users\" SET \"name\" = (E'new name' :: text), \"bio\" = (E'new bio' :: text) WHERE (\"id\" = (E'some-id' :: text))" + checkStatement squealRendering statement + + it "update users set name = inline(n) where id = 'some-id'" $ do + let + n :: Text + n = "new name" + statement :: Statement DB () () + statement = [ssql| update users set name = inline(n) where id = 'some-id' |] + squealRendering :: Text + squealRendering = + "UPDATE \"users\" AS \"users\" SET \"name\" = (E'new name' :: text) WHERE (\"id\" = (E'some-id' :: text))" + checkStatement squealRendering statement + + it "update users set name = 'new name' where id = 'some-id' returning id" $ do + let + statement :: Statement DB () (Field "id" Text, ()) + statement = + [ssql| update users set name = 'new name' where id = 'some-id' returning id |] + squealRendering :: Text + squealRendering = + "UPDATE \"users\" AS \"users\" SET \"name\" = (E'new name' :: text) WHERE (\"id\" = (E'some-id' :: text)) RETURNING \"id\" AS \"id\"" + checkStatement squealRendering statement + + describe "scalar expressions" $ do + -- Binary Operators + it "select 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 |] + squealRendering :: Text + squealRendering = + "SELECT (\"users\".\"id\" <> (E'no-such-user' :: text)) AS " + <> "\"neq\" FROM \"users\" AS \"users\"" + checkStatement squealRendering stmt + + it "select * from users where id <> 'no-such-user'" $ do + let + stmt + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + stmt = [ssql| select * from users where users.id <> 'no-such-user' |] + squealRendering :: Text + squealRendering = + "SELECT * FROM \"users\" AS \"users\" WHERE (\"users\".\"id\" <> (E'no-such-user' :: text))" + checkStatement squealRendering stmt + + it "select * from emails where id > 0" $ do + let + stmt + :: Statement + DB + () + (Field "id" Int32, (Field "user_id" Text, (Field "email" (Maybe Text), ()))) + stmt = [ssql| select * from emails where emails.id > 0 |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"emails\" AS \"emails\" WHERE (\"emails\".\"id\" > 0)" + checkStatement squealRendering stmt + + it "select * from emails where id >= 0" $ do + let + stmt + :: Statement + DB + () + (Field "id" Int32, (Field "user_id" Text, (Field "email" (Maybe Text), ()))) + stmt = [ssql| select * from emails where emails.id >= 0 |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"emails\" AS \"emails\" WHERE (\"emails\".\"id\" >= 0)" + checkStatement squealRendering stmt + + it "select * from emails where id < 10" $ do + let + stmt + :: Statement + DB + () + (Field "id" Int32, (Field "user_id" Text, (Field "email" (Maybe Text), ()))) + stmt = [ssql| select * from emails where emails.id < 10 |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"emails\" AS \"emails\" WHERE (\"emails\".\"id\" < 10)" + checkStatement squealRendering stmt + + it "select * from emails where id <= 10" $ do + let + stmt + :: Statement + DB + () + (Field "id" Int32, (Field "user_id" Text, (Field "email" (Maybe Text), ()))) + stmt = [ssql| select * from emails where emails.id <= 10 |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"emails\" AS \"emails\" WHERE (\"emails\".\"id\" <= 10)" + checkStatement squealRendering stmt + + it "select 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 |] + squealRendering :: Text + squealRendering = + "SELECT (\"emails\".\"id\" + 1) AS \"plus_one\" FROM \"emails\" AS \"emails\"" + checkStatement squealRendering stmt + + it "select 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 |] + squealRendering :: Text + squealRendering = + "SELECT (\"emails\".\"id\" - 1) AS \"minus_one\" FROM \"emails\" AS \"emails\"" + checkStatement squealRendering stmt + + it "select 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 |] + squealRendering :: Text + squealRendering = + "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 + let + stmt + :: Statement + DB + () + ( Field "id" Text + , (Field "name" Text, (Field "employee_id" UUID, (Field "bio" (Maybe Text), ()))) + ) + stmt = [ssql| select * from users where users.id = 'a' and users.name = 'b' |] + squealRendering :: Text + squealRendering = + "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 + let + stmt + :: Statement + DB + () + ( Field "id" Text + , (Field "name" Text, (Field "employee_id" UUID, (Field "bio" (Maybe Text), ()))) + ) + stmt = [ssql| select * from users where users.id = 'a' or users.name = 'b' |] + squealRendering :: Text + squealRendering = + "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 + let + stmt + :: Statement + DB + () + ( Field "id" Text + , (Field "name" Text, (Field "employee_id" UUID, (Field "bio" (Maybe Text), ()))) + ) + stmt = [ssql| select * from users where users.name like 'A%' |] + squealRendering :: Text + squealRendering = + "SELECT * FROM \"users\" AS \"users\" WHERE (\"users\".\"name\" LIKE (E'A%' :: text))" + checkStatement squealRendering stmt + + it "select * from users where name ilike 'a%'" $ do + let + stmt + :: Statement + DB + () + ( Field "id" Text + , (Field "name" Text, (Field "employee_id" UUID, (Field "bio" (Maybe Text), ()))) + ) + stmt = [ssql| select * from users where users.name ilike 'a%' |] + squealRendering :: Text + squealRendering = + "SELECT * FROM \"users\" AS \"users\" WHERE (\"users\".\"name\" ILIKE (E'a%' :: text))" + checkStatement squealRendering stmt + + -- Prefix Operators + it "select * from users where not (name = 'no-one')" $ do + let + stmt + :: Statement + DB + () + ( Field "id" Text + , (Field "name" Text, (Field "employee_id" UUID, (Field "bio" (Maybe Text), ()))) + ) + stmt = [ssql| select * from users where not (users.name = 'no-one') |] + squealRendering :: Text + squealRendering = + "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 + let + stmt :: Statement DB () (Field "neg_id" Int32, ()) + stmt = [ssql| select -emails.id as neg_id from emails |] + squealRendering :: Text + squealRendering = + "SELECT ((0 :: int4) - \"emails\".\"id\") AS \"neg_id\" FROM \"emails\" AS \"emails\"" + checkStatement squealRendering stmt + + -- Postfix Operators + it "select * from users where bio is null" $ do + let + stmt + :: Statement + DB + () + ( Field "id" Text + , (Field "name" Text, (Field "employee_id" UUID, (Field "bio" (Maybe Text), ()))) + ) + stmt = [ssql| select * from users where users.bio is null |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"users\" AS \"users\" WHERE \"users\".\"bio\" IS NULL" + checkStatement squealRendering stmt + + it "select * from users where bio is not null" $ do + let + stmt + :: Statement + DB + () + ( Field "id" Text + , (Field "name" Text, (Field "employee_id" UUID, (Field "bio" (Maybe Text), ()))) + ) + stmt = [ssql| select * from users where users.bio is not null |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"users\" AS \"users\" WHERE \"users\".\"bio\" IS NOT NULL" + checkStatement squealRendering stmt + + describe "function calls" $ do + -- Function Calls + it "select coalesce(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 |] + squealRendering :: Text + squealRendering = + "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 + let + stmt :: Statement DB () (Field "lower_name" Text, ()) + stmt = [ssql| select lower(users.name) as lower_name from users |] + squealRendering :: Text + squealRendering = + "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 + let + stmt :: Statement DB () (Field "name_len" Int32, ()) + stmt = [ssql| select char_length(users.name) as name_len from users |] + squealRendering :: Text + squealRendering = + "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 + let + stmt :: Statement DB () (Field "name_len_alias" Int32, ()) + stmt = [ssql| select character_length(users.name) as name_len_alias from users |] + squealRendering :: Text + squealRendering = + "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 + let + stmt :: Statement DB () (Field "upper_name" Text, ()) + stmt = [ssql| select "upper"(users.name) as upper_name from users |] + squealRendering :: Text + squealRendering = + "SELECT upper(\"users\".\"name\") AS \"upper_name\" FROM \"users\" AS \"users\"" + checkStatement squealRendering stmt + + it "select now() as current_time" $ do + let + stmt :: Statement DB () (Field "current_time" UTCTime, ()) + stmt = [ssql| select now() as current_time |] + squealRendering :: Text + squealRendering = "SELECT * FROM (VALUES (now())) AS t (\"current_time\")" + checkStatement squealRendering stmt + + it "select current_date as today" $ do + let + stmt :: Statement DB () (Field "today" Day, ()) + stmt = [ssql| select current_date as today |] + squealRendering :: Text + squealRendering = "SELECT * FROM (VALUES (CURRENT_DATE)) AS t (\"today\")" + checkStatement squealRendering stmt + + it "haskell variables in expressions" $ do + let + mkStatement + :: Text + -> Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + mkStatement someName = + [ssql| select * from users where name = inline("someName") |] + + squealRendering1 :: Text + squealRendering1 = "SELECT * FROM \"users\" AS \"users\" WHERE (\"name\" = (E'Alice' :: text))" + + squealRendering2 :: Text + squealRendering2 = "SELECT * FROM \"users\" AS \"users\" WHERE (\"name\" = (E'Bob' :: text))" + + checkStatement squealRendering1 (mkStatement "Alice") + checkStatement squealRendering2 (mkStatement "Bob") + + -- PARENS (implicitly tested by complex expressions) + it "select (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 |] + squealRendering :: Text + squealRendering = + "SELECT ((\"emails\".\"id\" + 1) * 2) AS \"calc\" FROM \"emails\" AS \"emails\"" + checkStatement squealRendering stmt + + -- IN / NOT IN + it "select * from users where name in ('Alice', 'Bob')" $ do + let + stmt + :: Statement + DB + () + ( Field "id" Text + , (Field "name" Text, (Field "employee_id" UUID, (Field "bio" (Maybe Text), ()))) + ) + stmt = [ssql| select * from users where users.name in ('Alice', 'Bob') |] + squealRendering :: Text + squealRendering = + "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 + let + stmt + :: Statement + DB + () + ( Field "id" Text + , (Field "name" Text, (Field "employee_id" UUID, (Field "bio" (Maybe Text), ()))) + ) + stmt = [ssql| select * from users where users.name not in ('Alice', 'Bob') |] + squealRendering :: Text + squealRendering = + "SELECT * FROM \"users\" AS \"users\" WHERE \"users\".\"name\" NOT IN ((E'Alice' :: text), (E'Bob' :: text))" + checkStatement squealRendering stmt + + -- BETWEEN / NOT BETWEEN + it "select * from emails where id between 0 and 10" $ do + let + stmt + :: Statement + DB + () + (Field "id" Int32, (Field "user_id" Text, (Field "email" (Maybe Text), ()))) + stmt = [ssql| select * from emails where emails.id between 0 and 10 |] + squealRendering :: Text + squealRendering = + "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 + let + stmt + :: Statement + DB + () + (Field "id" Int32, (Field "user_id" Text, (Field "email" (Maybe Text), ()))) + stmt = [ssql| select * from emails where emails.id not between 0 and 10 |] + squealRendering :: Text + squealRendering = + "SELECT * FROM \"emails\" AS \"emails\" WHERE \"emails\".\"id\" NOT BETWEEN 0 AND 10" + checkStatement squealRendering stmt + + -- CAST + it "select cast(e.id as 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 |] + squealRendering :: Text + squealRendering = "SELECT (\"e\".\"id\" :: text) AS \"casted_id\" FROM \"emails\" AS \"e\"" + checkStatement squealRendering stmt + + it "select * from users for update" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + statement = [ssql| select * from users for update |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"users\" AS \"users\" FOR UPDATE" + checkStatement squealRendering statement + + it "select * from jsonb_test" $ do + let + statement + :: Statement + DB + () + ( Field "data" (Jsonb Value) + , () + ) + statement = [ssql| select * from jsonb_test |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"jsonb_test\" AS \"jsonb_test\"" + checkStatement squealRendering statement + + it "select * from json_test" $ do + let + statement + :: Statement + DB + () + ( Field "data" (Json Value) + , () + ) + statement = [ssql| select * from json_test |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"json_test\" AS \"json_test\"" + checkStatement squealRendering statement + + it "select distinct name from users" $ do + let + statement :: Statement DB () (Field "name" Text, ()) + statement = [ssql| select distinct name from users |] + squealRendering :: Text + squealRendering = "SELECT DISTINCT \"name\" AS \"name\" FROM \"users\" AS \"users\"" + checkStatement squealRendering statement + + it "select distinct * from users" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + statement = [ssql| select distinct * from users |] + squealRendering :: Text + squealRendering = "SELECT DISTINCT * FROM \"users\" AS \"users\"" + checkStatement squealRendering statement + + it "select distinct on (employee_id) employee_id, name from users" $ do + let + statement + :: Statement + DB + () + ( Field "employee_id" UUID + , ( Field "name" Text + , () + ) + ) + statement = [ssql| select distinct on (employee_id) employee_id, name from users |] + squealRendering :: Text + squealRendering = + "SELECT DISTINCT ON (\"employee_id\") \"employee_id\" AS \"employee_id\", \"name\" AS \"name\" FROM \"users\" AS \"users\" ORDER BY \"employee_id\" ASC" + checkStatement squealRendering statement + + it "select distinct on (employee_id, name) employee_id, name, id from users" $ do + let + statement + :: Statement + DB + () + ( Field "employee_id" UUID + , ( Field "name" Text + , ( Field "id" Text + , () + ) + ) + ) + statement = + [ssql| select distinct on (employee_id, name) employee_id, name, id from users |] + squealRendering :: Text + squealRendering = + "SELECT DISTINCT ON (\"employee_id\", \"name\") \"employee_id\" AS \"employee_id\", \"name\" AS \"name\", \"id\" AS \"id\" FROM \"users\" AS \"users\" ORDER BY \"employee_id\" ASC, \"name\" ASC" + checkStatement squealRendering statement + + describe "order by" $ do + it "select * from users order by name" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + statement = [ssql| select * from users order by name |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"users\" AS \"users\" ORDER BY \"name\" ASC" + checkStatement squealRendering statement + + it "select * from users order by name asc" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + statement = [ssql| select * from users order by name asc |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"users\" AS \"users\" ORDER BY \"name\" ASC" + checkStatement squealRendering statement + + it "select * from users order by name desc" $ do + let + statement + :: Statement + DB + () + ( Field "id" Text + , ( Field "name" Text + , ( Field "employee_id" UUID + , ( Field "bio" (Maybe Text) + , () + ) + ) + ) + ) + statement = [ssql| select * from users order by name desc |] + squealRendering :: Text + squealRendering = "SELECT * FROM \"users\" AS \"users\" ORDER BY \"name\" DESC" + checkStatement squealRendering statement + + describe "having clause" $ do + it + "select employee_id, count(id) from users group by employee_id having count(id) > 1" + $ do + let + statement + :: Statement + DB + () + ( Field "employee_id" UUID + , ( Field "_col2" Int64 -- Assuming count returns Int64 + , () + ) + ) + statement = + [ssql| + select employee_id, count(id) + from users + group by employee_id + having count(id) > 1 + |] + squealRendering :: Text + squealRendering = + "SELECT \"employee_id\" AS \"employee_id\", count(ALL \"id\") AS \"_col2\" FROM \"users\" AS \"users\" GROUP BY \"employee_id\" HAVING (count(ALL \"id\") > 1)" + checkStatement squealRendering statement + + +_printQuery :: (RenderSQL a) => a -> IO () +_printQuery = putStrLn . T.unpack . TE.decodeUtf8 . renderSQL + + +checkStatement + :: (RenderSQL sql) + => Text + -> sql + -> IO () +checkStatement expect statement = + let + rendered :: Text + rendered = TE.decodeUtf8 (renderSQL statement) + in + if rendered == expect + then + pure () + else + fail $ + "SQL statements do not match.\nExpected:\n" + <> show expect + <> "\nActual:\n" + <> show rendered + <> "\n" + +