squeal-postgresql-qq 0.1.3.0 → 0.1.4.0
raw patch · 6 files changed
+970/−236 lines, 6 filesdep +scientificPVP ok
version bump matches the API change (PVP)
Dependencies added: scientific
API changes (from Hackage documentation)
Files
- README.md +50/−8
- changelog.md +31/−0
- squeal-postgresql-qq.cabal +2/−1
- src/Squeal/QuasiQuotes/MonoRow.hs +7/−1
- src/Squeal/QuasiQuotes/Query.hs +468/−172
- test/test.hs +412/−54
README.md view
@@ -15,8 +15,7 @@ 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.+of course there are some unsupported features. I don't foresee backwards incompatable changes being a problem because, after all, the "interface" is mostly the SQL language, which is@@ -56,8 +55,8 @@ ### General Query Structure * `TABLESAMPLE` clause * `ONLY` keyword for table inheritance-* `WINDOW` clause and window functions (`OVER`) * `INTO` clause (`SELECT ... INTO ...`)+* `WINDOW` clause for defining named windows (e.g. `WINDOW w AS ...`) * `ORDER BY USING` * `FOR READ ONLY` locking clause * `FOR UPDATE/SHARE OF` with qualified table names.@@ -68,42 +67,51 @@ * `LIMIT` with comma offset (e.g. `LIMIT 10, 20`) * `LIMIT ALL` * `FETCH` clause+* `ORDER BY`, `LIMIT`, `OFFSET`, or locking clauses on the immediate operands of a set operation (`UNION`, `INTERSECT`, `EXCEPT`). * Advanced `GROUP BY` features (`GROUPING SETS`, `CUBE`, `ROLLUP`)-* Multi-row `VALUES` clause (e.g. `VALUES (1, 'a'), (2, 'b')`)+* Multi-row `VALUES` clause in `SELECT` statements (e.g. `SELECT * FROM (VALUES (1, 'a'), (2, 'b'))`). Multi-row `INSERT ... VALUES` is supported.+* `VALUES` clause with `ORDER BY`, `LIMIT`, `OFFSET`, or locking clauses.+* `SELECT` without a `FROM` clause cannot have other clauses like `WHERE`, `GROUP BY`, etc.+* Multiple `*` in a `SELECT` list. ### Common Table Expressions (WITH clauses)-* Recursive `WITH` clauses (`WITH RECURSIVE ...`) * `MATERIALIZED` / `NOT MATERIALIZED` hints+* Schema-qualified CTEs (e.g. `WITH public.my_cte AS ...`) * Column lists for CTEs are only partially supported (e.g., not for top-level `SELECT` statements) * Data-modifying statements (`INSERT`, `UPDATE`, `DELETE`) within a `WITH` clause ### Data Manipulation (INSERT/UPDATE/DELETE)-* `ON CONFLICT` with a column list conflict target (e.g. `ON CONFLICT (col1, col2) ...`)+* `ON CONFLICT` with a column list conflict target (e.g. `ON CONFLICT (col1, col2) ...`). Only `ON CONFLICT ON CONSTRAINT ...` is supported.+* `ON CONFLICT` without a conflict target (e.g. `ON CONFLICT DO NOTHING`). * `INSERT ... DEFAULT VALUES` * `INSERT INTO table (columns) SELECT ...` (must omit column list)+* `INSERT ... VALUES` without a column list. * `OVERRIDING` clause for identity columns in `INSERT` * Column indirection in `INSERT` target lists (e.g., `INSERT INTO tbl (col[1]) ...`) * Complex relation expressions in `UPDATE` or `DELETE` targets * Column indirection in `UPDATE SET` clauses (e.g., `UPDATE tbl SET col[1] = ...`) * `UPDATE` with multiple-column `SET` (e.g. `SET (a,b) = (1,2)`)+* `RETURNING` expressions must have an alias if they are not simple column references.+* Implicitly aliased expressions in `RETURNING` are not supported. ### Expressions and Functions * `LIKE` with `ESCAPE` * `OPERATOR()` syntax * Parameter indirection (e.g., `$1[i]`)+* Column array access (e.g. `col[1]`) * Indirection on parenthesized expressions (e.g., `(expr)[i]`) * Aggregate `FILTER` clause * `WITHIN GROUP` clause for aggregates-* `DISTINCT` in function arguments * `ORDER BY` in function arguments * Function name indirection (e.g., `schema.func`) * Named or colon-syntax function arguments (e.g. `my_func(arg_name => 'val')`) ### Types and Casting * `SETOF` type modifier+* Nullable type modifier `?` (e.g. `int?`) * `BIT` and `BIT VARYING` types * `INTERVAL` with qualifiers-* Types with precision/scale (`TIMESTAMP`, `TIME`, `FLOAT`, `NUMERIC`, etc.)+* Types with precision/scale (`TIMESTAMP`, `TIME`, `FLOAT`, etc.) * Qualified type names (e.g., `schema.my_type`) * `CURRENT_TIMESTAMP` with precision * Multidimensional arrays with explicit bounds@@ -145,7 +153,17 @@ select employee_id, name, count(id) from users group by employee_id, name [✔] common table expressions with users_cte as (select * from users) select * from users_cte [✔]+ with recursive t as ( select 1 as n union all select (n + 1) as n from t where n < 100) select n from t [✔]+ with recursive users_cte as ( select id, name from users union all select id, name from users_cte) select * from users_cte [✔] with users_cte as (select * from users), emails_cte as (select * from emails) select users_cte.*, emails_cte.email from users_cte join emails_cte on users_cte.id = emails_cte.user_id [✔]+ set operations+ select name from users union select name from users_copy [✔]+ select name from users union all select name from users_copy [✔]+ select name from users intersect select name from users_copy [✔]+ select name from users intersect all select name from users_copy [✔]+ select name from users except select name from users_copy [✔]+ select name from users except all select name from users_copy [✔]+ (select name from users) union (select name from users_copy) [✔] inserts insert into emails (id, user_id, email) values (1, 'user-1', 'foo@bar') [✔] insert into emails (id, user_id, email) values (1, 'user-1', $1) [✔]@@ -169,6 +187,12 @@ insert into emails (id, user_id, email) values (1, 'user-1', 'foo@bar') returning * [✔] with common table expressions with new_user (id, name, bio) as (values ('id_new', 'new_name', 'new_bio')) insert into users_copy select * from new_user [✔]+ on conflict+ insert into users_copy (id, name, bio) values ('id1', 'name1', null) on conflict on constraint pk_users_copy do nothing [✔]+ insert into users_copy (id, name, bio) values ('id1', 'name1', 'bio1') on conflict on constraint pk_users_copy do update set name = 'new_name' [✔]+ insert into users_copy (id, name, bio) values ('id1', 'name1', null) on conflict on constraint pk_users_copy do update set name = 'new_name' where users_copy.name = 'old_name' [✔]+ insert into users_copy (id, name, bio) values ('id1', 'name1', null) on conflict on constraint pk_users_copy do nothing returning id [✔]+ insert into users_copy (id, name, bio) values ('id1', 'name1', 'bio1') on conflict on constraint pk_users_copy do update set name = 'new_name' returning * [✔] deletes delete from users where true [✔] delete from emails where id = 1 [✔]@@ -212,6 +236,15 @@ select "upper"(users.name) as upper_name from users [✔] select now() as current_time [✔] select current_date as today [✔]+ aggregate functions+ select sum(id) as total_ids from emails [✔]+ select sum(all id) as total_ids from emails [✔]+ select sum(distinct id) as total_ids from emails [✔]+ select count(distinct id) as distinct_ids from emails [✔]+ select count(all id) as all_ids from emails [✔]+ select avg(id) as avg_id from emails [✔]+ select min(id) as min_id from emails [✔]+ select max(id) as max_id from emails [✔] haskell variables in expressions [✔] select (emails.id + 1) * 2 as calc from emails [✔] select * from users where users.name in ('Alice', 'Bob') [✔]@@ -233,4 +266,13 @@ select * from users order by name desc [✔] having clause select employee_id, count(id) from users group by employee_id having count(id) > 1 [✔]+ window functions+ select name, row_number() over () as rn from users [✔]+ select name, rank() over (partition by employee_id order by name) as r from users [✔]+ select email, sum(id) over (partition by user_id) as user_total from emails [✔]+ select email, avg(id) over (partition by user_id) as user_avg from emails [✔]+ select email, min(id) over (partition by user_id) as user_min from emails [✔]+ select email, max(id) over (partition by user_id) as user_max from emails [✔]+ select name, row_number() over (order by name), rank() over (order by name) from users [✔]+ select name, row_number() over (partition by employee_id order by name), rank() over (order by name) from users [✔] ```
changelog.md view
@@ -1,3 +1,34 @@+### 0.1.4.0++* New features+ * Support for SQL window functions (`OVER` clause).+ * `select name, row_number() over () as rn from users` [✔]+ * `select name, rank() over (partition by employee_id order by name) as r from users` [✔]+ * `select email, sum(id) over (partition by user_id) as user_total from emails` [✔]+ * `select email, avg(id) over (partition by user_id) as user_avg from emails` [✔]+ * `select email, min(id) over (partition by user_id) as user_min from emails` [✔]+ * `select email, max(id) over (partition by user_id) as user_max from emails` [✔]+ * Support for SQL set operations (`UNION`, `INTERSECT`, `EXCEPT`).+ * `select name from users union select name from users_copy` [✔]+ * `select name from users union all select name from users_copy` [✔]+ * `select name from users intersect select name from users_copy` [✔]+ * `select name from users intersect all select name from users_copy` [✔]+ * `select name from users except select name from users_copy` [✔]+ * `select name from users except all select name from users_copy` [✔]+ * Support for `WITH RECURSIVE` clauses.+ * `with recursive t as ( select 1 as n union all select (n + 1) as n from t where n < 100) select n from t` [✔]+ * `with recursive users_cte as ( select id, name from users union all select id, name from users_cte) select * from users_cte` [✔]+ * Support for aggregate functions (`sum`, `avg`, `min`, `max`).+ * `select sum(id) as total_ids from emails` [✔]+ * `select sum(all id) as total_ids from emails` [✔]+ * `select sum(distinct id) as total_ids from emails` [✔]+ * `select count(distinct id) as distinct_ids from emails` [✔]+ * `select count(all id) as all_ids from emails` [✔]+ * `select avg(id) as avg_id from emails` [✔]+ * `select min(id) as min_id from emails` [✔]+ * `select max(id) as max_id from emails` [✔]+ * Support for `PGnumeric` type, mapping to `Scientific`.+ ### 0.1.3.0 * New features
squeal-postgresql-qq.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: squeal-postgresql-qq-version: 0.1.3.0+version: 0.1.4.0 synopsis: QuasiQuoter transforming raw sql into Squeal expressions. -- description: homepage: https://github.com/owensmurray/squeal-postgresql-qq@@ -23,6 +23,7 @@ , bytestring >= 0.11.3.0 && < 0.13 , generics-sop >= 0.5.1.3 && < 0.6 , postgresql-syntax >= 0.4.1 && < 0.5+ , scientific >= 0.3.7.0 && < 0.4 , squeal-postgresql >= 0.9.1.3 && < 0.10 , template-haskell >= 2.20.0.0 && < 2.24 , text >= 1.2.5.0 && < 2.2
src/Squeal/QuasiQuotes/MonoRow.hs view
@@ -31,6 +31,7 @@ import Data.Aeson (Value) import Data.Int (Int32, Int64)+import Data.Scientific (Scientific) import Data.Text (Text) import Data.Time (Day, UTCTime) import Data.UUID (UUID)@@ -39,7 +40,10 @@ 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)+ , PGType+ ( PGbool, PGdate, PGint4, PGint8, PGjson, PGjsonb, PGnumeric, PGtext+ , PGtimestamptz, PGuuid+ ) , (:::), Json, Jsonb ) import qualified Squeal.PostgreSQL as Squeal@@ -77,6 +81,7 @@ MonoRow (fld ::: 'NotNull PGtimestamptz ': more) = (Field fld UTCTime, MonoRow more) MonoRow (fld ::: 'NotNull PGjsonb ': more) = (Field fld (Jsonb Value), MonoRow more) MonoRow (fld ::: 'NotNull PGjson ': more) = (Field fld (Json Value), MonoRow more)+ MonoRow (fld ::: 'NotNull PGnumeric ': more) = (Field fld Scientific, MonoRow more) MonoRow (fld ::: 'Null PGbool ': more) = (Field fld (Maybe Bool), MonoRow more) MonoRow (fld ::: 'Null PGint4 ': more) = (Field fld (Maybe Int32), MonoRow more)@@ -87,6 +92,7 @@ MonoRow (fld ::: 'Null PGtimestamptz ': more) = (Field fld (Maybe UTCTime), MonoRow more) MonoRow (fld ::: 'Null PGjsonb ': more) = (Field fld (Maybe (Jsonb Value)), MonoRow more) MonoRow (fld ::: 'Null PGjson ': more) = (Field fld (Maybe (Json Value)), MonoRow more)+ MonoRow (fld ::: 'Null PGnumeric ': more) = (Field fld (Maybe Scientific), MonoRow more) MonoRow '[] = () {- FOURMOLU_ENABLE -}
src/Squeal/QuasiQuotes/Query.hs view
@@ -16,10 +16,13 @@ getIdentText, ) where -import Control.Applicative (Alternative((<|>)))-import Control.Monad (unless, when)-import Data.Foldable (Foldable(elem, foldl'), foldlM)+import Control.Monad (unless, when, zipWithM)+import Data.Either (partitionEithers)+import Data.Foldable (Foldable(elem, foldl', foldr, length, null), any, foldlM)+import Data.Function (on)+import Data.List (groupBy, partition, sortBy) import Data.Maybe (fromMaybe, isJust, isNothing)+import Data.Ord (comparing) import Data.String (IsString(fromString)) import Language.Haskell.TH.Syntax ( Exp(AppE, AppTypeE, ConE, InfixE, LabelE, ListE, LitE, TupE, VarE)@@ -27,10 +30,10 @@ ) import Prelude ( Applicative(pure), Bool(False, True), Either(Left, Right), Eq((==))- , Foldable(foldr, length, null), Functor(fmap), Maybe(Just, Nothing)- , MonadFail(fail), Num((*), (+), (-), fromInteger), Ord((<), (>=))- , Semigroup((<>)), Show(show), Traversable(mapM), ($), (&&), (.), (<$>), (||)- , Int, Integer, any, either, error, fromIntegral, id, otherwise, zip+ , Functor(fmap), Maybe(Just, Nothing), MonadFail(fail)+ , Num((*), (+), (-), fromInteger), Ord((<), (>=), compare), Semigroup((<>))+ , Show(show), Traversable(mapM), ($), (&&), (++), (.), (<$>), (||), Int+ , Integer, either, error, fromIntegral, id, maybe, otherwise, uncurry, zip ) import qualified Data.ByteString.Char8 as BS8 import qualified Data.List.NonEmpty as NE@@ -39,6 +42,49 @@ import qualified Squeal.PostgreSQL as S +-- | Intermediate representation for a window function call in a SELECT list.+data WindowFuncInfo = WindowFuncInfo+ { wfiTargetEl :: PGT_AST.TargetEl+ , wfiFuncApp :: PGT_AST.FuncApplication+ , wfiOverClause :: PGT_AST.OverClause+ }+ deriving stock (Eq, Show)+++-- | A wrapper for `PGT_AST.OverClause` to provide an `Ord` instance for sorting and grouping.+newtype OrdOverClause = OrdOverClause PGT_AST.OverClause+ deriving stock (Eq, Show)+++-- Manual Ord instance based on the rendered string representation for simplicity.+instance Ord OrdOverClause where+ compare (OrdOverClause c1) (OrdOverClause c2) =+ compare (show c1) (show c2)+++-- | `WindowFuncInfo` using `OrdOverClause`.+data WindowFuncInfo_ = WindowFuncInfo_+ { wfiTargetEl_ :: PGT_AST.TargetEl+ , wfiOverClause_ :: OrdOverClause+ }+++-- | Classifies a `PGT_AST.TargetEl` as either a normal expression or a window function call.+isWindowTarget :: PGT_AST.TargetEl -> Either PGT_AST.TargetEl WindowFuncInfo_+isWindowTarget el = case el of+ PGT_AST.AliasedExprTargetEl expr _ -> go expr+ PGT_AST.ImplicitlyAliasedExprTargetEl expr _ -> go expr+ PGT_AST.ExprTargetEl expr -> go expr+ _ -> Left el+ where+ go+ ( PGT_AST.CExprAExpr+ (PGT_AST.FuncCExpr (PGT_AST.ApplicationFuncExpr _app _ _ (Just over)))+ ) =+ Right $ WindowFuncInfo_ el (OrdOverClause over)+ go _ = Left el++ toSquealQuery :: [Text.Text] -> Maybe (NE.NonEmpty PGT_AST.Ident)@@ -61,6 +107,23 @@ toSquealSelectWithParens cteNames maybeColAliases swp +toSquealSelectClause+ :: [Text.Text]+ -> Maybe (NE.NonEmpty PGT_AST.Ident)+ -> PGT_AST.SelectClause+ -> Q Exp+toSquealSelectClause cteNames maybeColAliases = \case+ Left simpleSelect ->+ toSquealSimpleSelect+ cteNames+ maybeColAliases+ simpleSelect+ Nothing+ Nothing+ Nothing+ Right selectWithParens -> toSquealSelectWithParens cteNames maybeColAliases selectWithParens++ toSquealSelectNoParens :: [Text.Text] -> Maybe (NE.NonEmpty PGT_AST.Ident)@@ -76,12 +139,10 @@ maybeSelectLimit maybeForLockingClause ) = do- (cteNames, renderedWithClause) <-+ (cteNames, withApp) <- case maybeWithClause of- Nothing -> pure (initialCteNames, Nothing)- Just withClause -> do- (names, exp) <- renderPGTWithClause initialCteNames withClause- pure (names, Just exp)+ Nothing -> pure (initialCteNames, id)+ Just withClause -> renderPGTWithClause initialCteNames withClause squealQueryBody <- case selectClause of@@ -95,32 +156,42 @@ maybeForLockingClause Right selectWithParens' -> toSquealSelectWithParens cteNames maybeColAliases selectWithParens' - case renderedWithClause of- Nothing -> pure squealQueryBody- Just withExp -> pure $ VarE 'S.with `AppE` withExp `AppE` squealQueryBody+ pure $ withApp squealQueryBody -renderPGTWithClause :: [Text.Text] -> PGT_AST.WithClause -> Q ([Text.Text], Exp)-renderPGTWithClause initialCteNames (PGT_AST.WithClause recursive ctes) = do- when recursive $ fail "Recursive WITH clauses are not supported yet."- let- cteList = NE.toList ctes- (finalCteNames, renderedCtes) <-- foldlM- ( \(names, exps) cte -> do- (name, exp) <- renderCte names cte- pure (names <> [name], exps <> [exp])- )- (initialCteNames, [])- cteList+renderPGTWithClause+ :: [Text.Text] -> PGT_AST.WithClause -> Q ([Text.Text], Exp -> Exp)+renderPGTWithClause initialCteNames (PGT_AST.WithClause recursive ctes) =+ if recursive+ then do+ case NE.toList ctes of+ [cte] -> do+ (cteName, aliasedCteQueryExp) <- renderRecursiveCte initialCteNames cte+ let+ withApp body = VarE 'S.withRecursive `AppE` aliasedCteQueryExp `AppE` body+ pure (initialCteNames <> [cteName], withApp)+ _ -> fail "Squeal-QQ currently only supports WITH RECURSIVE with a single CTE."+ else do+ let+ cteList = NE.toList ctes+ (finalCteNames, renderedCtes) <-+ foldlM+ ( \(names, exps) cte -> do+ (name, exp) <- renderCte names cte+ pure (names <> [name], exps <> [exp])+ )+ (initialCteNames, [])+ cteList - let- withExp =- foldr- (\cte acc -> ConE '(S.:>>) `AppE` cte `AppE` acc)- (ConE 'S.Done)- renderedCtes- pure (finalCteNames, withExp)+ let+ withExp =+ foldr+ (\cte acc -> ConE '(S.:>>) `AppE` cte `AppE` acc)+ (ConE 'S.Done)+ renderedCtes+ let+ withApp body = VarE 'S.with `AppE` withExp `AppE` body+ pure (finalCteNames, withApp) where renderCte :: [Text.Text] -> PGT_AST.CommonTableExpr -> Q (Text.Text, Exp) renderCte existingCteNames (PGT_AST.CommonTableExpr ident maybeColNames maybeMaterialized stmt) = do@@ -137,7 +208,27 @@ pure (cteName, VarE 'S.as `AppE` cteQueryExp `AppE` LabelE (Text.unpack cteName)) + renderRecursiveCte+ :: [Text.Text] -> PGT_AST.CommonTableExpr -> Q (Text.Text, Exp)+ renderRecursiveCte existingCteNames (PGT_AST.CommonTableExpr ident maybeColNames maybeMaterialized stmt) = do+ when (isJust maybeColNames) $+ fail "Column name lists in CTEs are not supported yet."+ when (isJust maybeMaterialized) $+ fail "MATERIALIZED/NOT MATERIALIZED for CTEs is not supported yet."+ let+ cteName = getIdentText ident+ -- For a recursive CTE, its own name must be in scope for the query inside it.+ let+ ctesInScope = existingCteNames <> [cteName]+ cteQueryExp <-+ case stmt of+ PGT_AST.SelectPreparableStmt selectStmt -> toSquealQuery ctesInScope Nothing selectStmt+ _ -> fail "Only SELECT statements are supported in CTEs."+ let+ aliasedQuery = VarE 'S.as `AppE` cteQueryExp `AppE` LabelE (Text.unpack cteName)+ pure (cteName, aliasedQuery) + toSquealSimpleSelect :: [Text.Text] -> Maybe (NE.NonEmpty PGT_AST.Ident)@@ -148,6 +239,28 @@ -> Q Exp toSquealSimpleSelect cteNames maybeColAliases simpleSelect maybeSortClause maybeSelectLimit maybeForLockingClause = case simpleSelect of+ PGT_AST.BinSimpleSelect op left allOrDistinct right -> do+ when+ ( isJust maybeSortClause+ || isJust maybeSelectLimit+ || isJust maybeForLockingClause+ )+ $ fail+ "ORDER BY, LIMIT, OFFSET, and FOR clauses are not supported on the immediate operands of a set operation. You can use parentheses to specify precedence."++ leftQuery <- toSquealSelectClause cteNames maybeColAliases left+ rightQuery <- toSquealSelectClause cteNames maybeColAliases right++ let+ squealOp = case (op, allOrDistinct) of+ (PGT_AST.UnionSelectBinOp, Just False) -> VarE 'S.unionAll+ (PGT_AST.UnionSelectBinOp, _) -> VarE 'S.union+ (PGT_AST.IntersectSelectBinOp, Just False) -> VarE 'S.intersectAll+ (PGT_AST.IntersectSelectBinOp, _) -> VarE 'S.intersect+ (PGT_AST.ExceptSelectBinOp, Just False) -> VarE 'S.exceptAll+ (PGT_AST.ExceptSelectBinOp, _) -> VarE 'S.except++ pure $ squealOp `AppE` leftQuery `AppE` rightQuery PGT_AST.ValuesSimpleSelect valuesClause -> do unless ( isNothing maybeSortClause@@ -213,9 +326,7 @@ 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."+ fail "WINDOW clause is not yet supported." renderedFromClauseExp <- renderPGTTableRef cteNames fromClause let@@ -318,37 +429,37 @@ -> PGT_AST.ValuesClause -> Q Exp renderValuesClauseToNP cteNames maybeColAliases (firstRowExps NE.:| restRowExps) = do- unless (null restRowExps) $- fail $- "Multi-row VALUES clause requires S.values, this translation "- <> "currently supports single row S.values_."- convertRowToNP firstRowExps- where- colAliasTexts = fmap (fmap getIdentText . NE.toList) maybeColAliases+ unless (null restRowExps) $+ fail $+ "Multi-row VALUES clause requires S.values, this translation "+ <> "currently supports single row S.values_."+ convertRowToNP firstRowExps+ where+ colAliasTexts = fmap (fmap getIdentText . NE.toList) maybeColAliases - convertRowToNP :: NE.NonEmpty PGT_AST.AExpr -> Q Exp- convertRowToNP exprs = do- let- exprList = NE.toList exprs- aliasTexts <-- case colAliasTexts of- Just aliases ->- if length aliases == length exprList- then pure aliases- else- fail- "Number of column aliases in CTE does not match number of columns in VALUES clause."- Nothing -> pure $ fmap (Text.pack . ("_column" <>) . show) [1 :: Int ..]- go (zip exprList aliasTexts)- where- go :: [(PGT_AST.AExpr, Text.Text)] -> Q Exp- go [] = pure $ ConE 'S.Nil- go ((expr, aliasText) : fs) = do- renderedExpr <- renderPGTAExpr cteNames expr- let- aliasedExp = VarE 'S.as `AppE` renderedExpr `AppE` LabelE (Text.unpack aliasText)- restExp <- go fs- pure $ ConE '(S.:*) `AppE` aliasedExp `AppE` restExp+ convertRowToNP :: NE.NonEmpty PGT_AST.AExpr -> Q Exp+ convertRowToNP exprs = do+ let+ exprList = NE.toList exprs+ aliasTexts <-+ case colAliasTexts of+ Just aliases ->+ if length aliases == length exprList+ then pure aliases+ else+ fail+ "Number of column aliases in CTE does not match number of columns in VALUES clause."+ Nothing -> pure $ fmap (Text.pack . ("_column" <>) . show) [1 :: Int ..]+ go (zip exprList aliasTexts)+ where+ go :: [(PGT_AST.AExpr, Text.Text)] -> Q Exp+ go [] = pure $ ConE 'S.Nil+ go ((expr, aliasText) : fs) = do+ renderedExpr <- renderPGTAExpr cteNames expr+ let+ aliasedExp = VarE 'S.as `AppE` renderedExpr `AppE` LabelE (Text.unpack aliasText)+ restExp <- go fs+ pure $ ConE '(S.:*) `AppE` aliasedExp `AppE` restExp renderPGTForLockingClauseItems :: PGT_AST.ForLockingClause -> Q [Exp]@@ -439,6 +550,7 @@ (ConE 'S.Nil) renderedExprs + renderPGTGroupByItem :: [Text.Text] -> PGT_AST.GroupByItem -> Q Exp renderPGTGroupByItem cteNames = \case PGT_AST.ExprGroupByItem scalarExpr -> renderPGTAExpr cteNames scalarExpr@@ -448,7 +560,8 @@ "Unsupported grouping expression: " <> show unsupportedGroup -processSelectLimit :: [Text.Text] -> Exp -> Maybe PGT_AST.SelectLimit -> Q (Exp, Maybe Exp)+processSelectLimit+ :: [Text.Text] -> Exp -> Maybe PGT_AST.SelectLimit -> Q (Exp, Maybe Exp) processSelectLimit _cteNames tableExpr Nothing = pure (tableExpr, Nothing) processSelectLimit cteNames tableExpr (Just selectLimit) = do let@@ -622,16 +735,16 @@ renderPGTOnExpressionsClause :: [Text.Text] -> [PGT_AST.AExpr] -> Q Exp renderPGTOnExpressionsClause cteNames exprs = do- renderedSortExps <- mapM renderToSortExpr exprs- pure $ ListE renderedSortExps- where- renderToSortExpr :: PGT_AST.AExpr -> Q Exp- renderToSortExpr astExpr = do- squealExpr <- renderPGTAExpr cteNames astExpr- -- For DISTINCT ON, the direction (ASC/DESC) and NULLS order- -- are typically specified in the ORDER BY clause.- -- Here, we default to ASC for the SortExpression constructor.- pure $ ConE 'S.Asc `AppE` squealExpr+ renderedSortExps <- mapM renderToSortExpr exprs+ pure $ ListE renderedSortExps+ where+ renderToSortExpr :: PGT_AST.AExpr -> Q Exp+ renderToSortExpr astExpr = do+ squealExpr <- renderPGTAExpr cteNames astExpr+ -- For DISTINCT ON, the direction (ASC/DESC) and NULLS order+ -- are typically specified in the ORDER BY clause.+ -- Here, we default to ASC for the SortExpression constructor.+ pure $ ConE 'S.Asc `AppE` squealExpr renderPGTSortClause :: [Text.Text] -> PGT_AST.SortClause -> Q Exp@@ -830,64 +943,122 @@ pure (selListExp, fmap NE.toList maybeOnExprs) -renderPGTTargetEl :: [Text.Text] -> PGT_AST.TargetEl -> Maybe PGT_AST.Ident -> Int -> Q Exp-renderPGTTargetEl cteNames targetEl mOuterAlias idx =+renderPGTTargetEl :: [Text.Text] -> PGT_AST.TargetEl -> Int -> Q Exp+renderPGTTargetEl cteNames targetEl 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+ _ -> error "renderPGTTargetEl called with non-expression TargetEl" in- case targetEl of- PGT_AST.AsteriskTargetEl -> pure $ ConE 'S.Star- _ -> do- renderedScalarExp <- renderPGTAExpr cteNames exprAST- case exprAST of- PGT_AST.CExprAExpr (PGT_AST.ColumnrefCExpr _)- | Nothing <- finalAliasName ->- pure renderedScalarExp- _ -> do- let- aliasLabelStr =- case finalAliasName of- Just ident -> Text.unpack $ getIdentText ident- Nothing -> "_col" <> show idx- pure $- VarE 'S.as- `AppE` renderedScalarExp- `AppE` LabelE aliasLabelStr+ do+ renderedScalarExp <- renderPGTAExpr cteNames exprAST+ case exprAST of+ PGT_AST.CExprAExpr (PGT_AST.ColumnrefCExpr _)+ | Nothing <- mInternalAlias ->+ pure renderedScalarExp+ _ -> do+ let+ aliasLabelStr =+ case mInternalAlias of+ Just ident -> Text.unpack $ getIdentText ident+ Nothing -> "_col" <> show idx+ pure $+ VarE 'S.as+ `AppE` renderedScalarExp+ `AppE` LabelE aliasLabelStr renderPGTTargetList :: [Text.Text] -> PGT_AST.TargetList -> Q Exp-renderPGTTargetList cteNames (item NE.:| items) = go (item : items) 1- where- isAsterisk :: PGT_AST.TargetEl -> Bool- isAsterisk PGT_AST.AsteriskTargetEl = True- isAsterisk _ = False+renderPGTTargetList cteNames (item NE.:| items) = do+ let+ allItems = item : items+ (normalTargets, windowTargets) = partitionEithers (isWindowTarget <$> allItems) - 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+ -- Group window functions by their OVER clause+ let+ sortedWindowTargets = sortBy (comparing wfiOverClause_) windowTargets+ groupedWindowTargets = groupBy ((==) `on` wfiOverClause_) sortedWindowTargets - isAllIndirectionEl :: PGT_AST.IndirectionEl -> Bool- isAllIndirectionEl PGT_AST.AllIndirectionEl = True- isAllIndirectionEl _ = False+ -- Render normal targets+ renderedNormalSelections <-+ if null normalTargets+ then pure []+ else (: []) <$> renderNormalTargetList cteNames normalTargets - renderPGTTargetElDotStar :: PGT_AST.TargetEl -> Q Exp+ -- Render window target groups+ (_, renderedWindowSelections) <-+ foldlM+ ( \(idx, acc) grp -> do+ (newIdx, renderedGrp) <- renderWindowGroup cteNames idx grp+ pure (newIdx, acc ++ [renderedGrp])+ )+ (1, [])+ groupedWindowTargets++ -- Combine all selections+ let+ allSelections = renderedNormalSelections ++ renderedWindowSelections+ case allSelections of+ [] -> fail "Empty selection list"+ [sel] -> pure sel+ (sel : sels) -> pure $ foldl' (\acc s -> ConE 'S.Also `AppE` s `AppE` acc) sel sels+++renderNormalTargetList :: [Text.Text] -> [PGT_AST.TargetEl] -> Q Exp+renderNormalTargetList cteNames targets = do+ let+ 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++ let+ (stars, notStars) = partition isAsterisk targets+ (dotStars, normalExprs) = partition isDotStar notStars++ renderedStar <-+ case stars of+ [] -> pure Nothing+ [_] -> pure $ Just (ConE 'S.Star)+ _ -> fail "Multiple `*` in SELECT list is not supported."++ renderedDotStars <- mapM renderPGTTargetElDotStar dotStars++ renderedNormalsExp <-+ if null normalExprs+ then pure Nothing+ else do+ renderedEls <- zipWithM (renderPGTTargetEl cteNames) normalExprs [1 ..]+ let+ npList = foldr (\h t -> ConE '(S.:*) `AppE` h `AppE` t) (ConE 'S.Nil) renderedEls+ pure $ Just (ConE 'S.List `AppE` npList)++ let+ allParts =+ maybe [] pure renderedStar+ ++ renderedDotStars+ ++ maybe [] pure renderedNormalsExp++ case allParts of+ [] -> fail "Empty normal selection list"+ [sel] -> pure sel+ (sel : sels) -> pure $ foldl' (\acc s -> ConE 'S.Also `AppE` s `AppE` acc) sel sels+ where renderPGTTargetElDotStar ( PGT_AST.ExprTargetEl ( PGT_AST.CExprAExpr@@ -905,21 +1076,133 @@ renderPGTTargetElDotStar _ = fail "renderPGTTargetElDotStar called with unexpected TargetEl" - go :: [PGT_AST.TargetEl] -> Int -> Q Exp- go [] _ = fail "Empty selection list items in go."- go [el] currentIdx = renderOne el currentIdx- go (el : more) currentIdx = do- renderedEl <- renderOne el currentIdx- restRendered <- go more (currentIdx + 1)- pure $ ConE 'S.Also `AppE` restRendered `AppE` renderedEl - renderOne :: PGT_AST.TargetEl -> Int -> Q Exp- renderOne el idx- | isAsterisk el = pure $ ConE 'S.Star- | isDotStar el = renderPGTTargetElDotStar el- | otherwise = renderPGTTargetEl cteNames el Nothing idx+renderWindowGroup :: [Text.Text] -> Int -> [WindowFuncInfo_] -> Q (Int, Exp)+renderWindowGroup cteNames startIdx = \case+ [] -> fail "renderWindowGroup: received an empty group, this should not happen."+ group@(head_info : _) -> do+ let+ OrdOverClause overClause = wfiOverClause_ head_info+ windowDefExp <-+ case overClause of+ PGT_AST.ColIdOverClause _ -> fail "WINDOW clause with named windows is not supported yet."+ PGT_AST.WindowOverClause spec -> renderPGTWindowSpecification cteNames spec + (newIdx, windowFuncsNP) <-+ renderWindowFuncsNP cteNames startIdx (wfiTargetEl_ <$> group) + pure $ (newIdx, ConE 'S.Over `AppE` windowFuncsNP `AppE` windowDefExp)+++renderPGTWindowSpecification+ :: [Text.Text] -> PGT_AST.WindowSpecification -> Q Exp+renderPGTWindowSpecification cteNames (PGT_AST.WindowSpecification mExisting mPartition mSort mFrame) = do+ when (isJust mExisting) $ fail "Existing window names are not supported yet."+ when (isJust mFrame) $+ fail "Frame clauses (ROWS/RANGE/GROUPS) are not supported yet."++ partitionByExp <-+ case mPartition of+ Nothing -> pure $ VarE 'S.partitionBy `AppE` ConE 'S.Nil+ Just partitionExps -> do+ renderedExps <- mapM (renderPGTAExpr cteNames) partitionExps+ let+ np = foldr (\h t -> ConE '(S.:*) `AppE` h `AppE` t) (ConE 'S.Nil) renderedExps+ pure $ VarE 'S.partitionBy `AppE` np++ case mSort of+ Nothing -> pure partitionByExp+ Just sortClause -> do+ renderedSC <- renderPGTSortClause cteNames sortClause+ pure $+ InfixE+ (Just partitionByExp)+ (VarE '(S.&))+ (Just (VarE 'S.orderBy `AppE` renderedSC))+++renderWindowFuncsNP :: [Text.Text] -> Int -> [PGT_AST.TargetEl] -> Q (Int, Exp)+renderWindowFuncsNP cteNames startIdx targets = do+ let+ indexedTargets = zip targets [startIdx ..]+ renderedFuncs <-+ mapM (uncurry (renderWindowFuncAsAliasedNP cteNames)) indexedTargets+ let+ newIdx = startIdx + length targets+ pure $+ ( newIdx+ , foldr (\h t -> ConE '(S.:*) `AppE` h `AppE` t) (ConE 'S.Nil) renderedFuncs+ )+++renderWindowFuncAsAliasedNP :: [Text.Text] -> PGT_AST.TargetEl -> Int -> Q Exp+renderWindowFuncAsAliasedNP cteNames el idx = do+ let+ (funcApp, mAlias) = case el of+ PGT_AST.AliasedExprTargetEl+ (PGT_AST.CExprAExpr (PGT_AST.FuncCExpr (PGT_AST.ApplicationFuncExpr app _ _ _)))+ an -> (app, Just an)+ PGT_AST.ImplicitlyAliasedExprTargetEl+ (PGT_AST.CExprAExpr (PGT_AST.FuncCExpr (PGT_AST.ApplicationFuncExpr app _ _ _)))+ an -> (app, Just an)+ PGT_AST.ExprTargetEl+ (PGT_AST.CExprAExpr (PGT_AST.FuncCExpr (PGT_AST.ApplicationFuncExpr app _ _ _))) -> (app, Nothing)+ _ -> error "renderWindowFuncAsAliasedNP: not a window function"++ let+ aliasStr = case mAlias of+ Just ident -> Text.unpack (getIdentText ident)+ Nothing -> "_window" <> show idx++ renderedFunc <- renderPGTFuncAppAsWindowFunc cteNames funcApp++ pure $ VarE 'S.as `AppE` renderedFunc `AppE` LabelE aliasStr+++renderPGTFuncAppAsWindowFunc :: [Text.Text] -> PGT_AST.FuncApplication -> Q Exp+renderPGTFuncAppAsWindowFunc cteNames (PGT_AST.FuncApplication funcName maybeParams) = do+ (squealFn, isCount) <-+ case funcName of+ PGT_AST.TypeFuncName fident -> do+ let+ fnNameStr = Text.toLower (getIdentText fident)+ case fnNameStr of+ "rank" -> pure (VarE 'S.rank, False)+ "row_number" -> pure (VarE 'S.rowNumber, False)+ "dense_rank" -> pure (VarE 'S.denseRank, False)+ "percent_rank" -> pure (VarE 'S.percentRank, False)+ "cume_dist" -> pure (VarE 'S.cumeDist, False)+ "ntile" -> pure (VarE 'S.ntile, False)+ "lag" -> pure (VarE 'S.lag, False)+ "lead" -> pure (VarE 'S.lead, False)+ "first_value" -> pure (VarE 'S.firstValue, False)+ "last_value" -> pure (VarE 'S.lastValue, False)+ "nth_value" -> pure (VarE 'S.nthValue, False)+ "count" -> pure (VarE 'S.count, True)+ "sum" -> pure (VarE 'S.sum_, False)+ "avg" -> pure (VarE 'S.avg, False)+ "min" -> pure (VarE 'S.min_, False)+ "max" -> pure (VarE 'S.max_, False)+ _ -> fail $ "Unsupported window function: " <> Text.unpack fnNameStr+ _ -> fail "Unsupported function name in window function"++ case maybeParams of+ Nothing -> pure squealFn+ Just PGT_AST.StarFuncApplicationParams+ | isCount -> pure $ VarE 'S.countStar+ | otherwise ->+ fail "Star argument is only supported for COUNT in window functions."+ Just (PGT_AST.NormalFuncApplicationParams (Just True) _ _) ->+ fail "DISTINCT is not supported for window functions."+ Just (PGT_AST.NormalFuncApplicationParams _ args _) -> do+ argExps <- mapM (renderPGTFuncArgExpr cteNames) (NE.toList args)+ let+ npArgs = foldr (\h t -> ConE '(S.:*) `AppE` h `AppE` t) (ConE 'S.Nil) argExps+ windowArg = ConE 'S.Windows `AppE` npArgs+ pure $ squealFn `AppE` windowArg+ _ -> fail "Unsupported parameters for window function"++ -- | Defines associativity of an operator. data Associativity = LeftAssoc | RightAssoc | NonAssoc deriving stock (Eq, Show)@@ -1184,7 +1467,8 @@ PGT_AST.InAExprReversableOp inExpr -> case inExpr of PGT_AST.ExprListInExpr exprList -> do- let opVar' = if not then VarE 'S.notIn else VarE 'S.in_+ let+ opVar' = if not then VarE 'S.notIn else VarE 'S.in_ listExp' <- ListE <$> mapM (renderPGTAExpr cteNames) (NE.toList exprList) pure $ opVar' `AppE` renderedExpr' `AppE` listExp' PGT_AST.SelectInExpr selectWithParens -> do@@ -1245,7 +1529,8 @@ 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."+ when (isJust maybeOver) $+ fail "OVER clause is only supported at the top level of a SELECT list item." renderPGTFuncApplication cteNames funcApp PGT_AST.SubexprFuncExpr funcCommonSubexpr -> renderPGTFuncExprCommonSubexpr cteNames funcCommonSubexpr @@ -1258,8 +1543,9 @@ PGT_AST.TypeFuncName fident -> let fnNameStr = Text.unpack (getIdentText fident)+ fnNameStrLower = Text.toLower (getIdentText fident) in- case Text.toLower (Text.pack fnNameStr) of+ case fnNameStrLower of "inline" -> case maybeParams of Just (PGT_AST.NormalFuncApplicationParams _ args _) ->@@ -1286,46 +1572,56 @@ pure $ VarE 'S.inlineParam `AppE` VarE varName _ -> fail "inline_param() function expects a single variable argument" _ -> fail "inline_param() function expects a single variable argument"- otherFnName ->- let- squealFn :: Q Exp- squealFn =- case otherFnName of- "coalesce" -> pure $ VarE 'S.coalesce- "lower" -> pure $ VarE 'S.lower- "char_length" -> pure $ VarE 'S.charLength- "character_length" -> pure $ VarE 'S.charLength- "upper" -> pure $ VarE 'S.upper- "count" -> pure $ VarE 'S.count -- Special handling for count(*) might be needed- "now" -> pure $ VarE 'S.now- _ -> fail $ "Unsupported function: " <> fnNameStr- in- case maybeParams of- Nothing -> squealFn -- No-argument function- Just params -> case params of- PGT_AST.NormalFuncApplicationParams maybeAllOrDistinct args maybeSortClause -> do- when (isJust maybeAllOrDistinct) $- fail "DISTINCT in function calls is not supported."- when (isJust maybeSortClause) $- fail "ORDER BY in function calls is not supported."- fn <- squealFn- argExps <- mapM (renderPGTFuncArgExpr cteNames) (NE.toList args)- pure $ foldl' AppE fn argExps- PGT_AST.StarFuncApplicationParams ->- -- Specific for count(*)- if fnNameStr == "count"- then pure $ VarE 'S.countStar- else fail "Star argument only supported for COUNT"- _ -> fail $ "Unsupported function parameters structure: " <> show params+ _ -> do+ (squealFn, isAggregate) <-+ case fnNameStrLower of+ "coalesce" -> pure (VarE 'S.coalesce, False)+ "lower" -> pure (VarE 'S.lower, False)+ "char_length" -> pure (VarE 'S.charLength, False)+ "character_length" -> pure (VarE 'S.charLength, False)+ "upper" -> pure (VarE 'S.upper, False)+ "now" -> pure (VarE 'S.now, False)+ "count" -> pure (VarE 'S.count, True)+ "sum" -> pure (VarE 'S.sum_, True)+ "avg" -> pure (VarE 'S.avg, True)+ "min" -> pure (VarE 'S.min_, True)+ "max" -> pure (VarE 'S.max_, True)+ _ -> fail $ "Unsupported function: " <> fnNameStr + case maybeParams of+ Nothing -> pure squealFn+ Just params -> case params of+ PGT_AST.NormalFuncApplicationParams maybeAllOrDistinct args maybeSortClause -> do+ when (isJust maybeSortClause) $+ fail "ORDER BY in function calls is not supported."+ argExps <- mapM (renderPGTFuncArgExpr cteNames) (NE.toList args)+ if isAggregate+ then do+ let+ aggArgConstructor = case maybeAllOrDistinct of+ Just True -> ConE 'S.Distincts+ _ -> ConE 'S.Alls+ npArgs = foldr (\h t -> ConE '(S.:*) `AppE` h `AppE` t) (ConE 'S.Nil) argExps+ pure $ squealFn `AppE` (aggArgConstructor `AppE` npArgs)+ else do+ when (isJust maybeAllOrDistinct) $+ fail "DISTINCT is not supported for non-aggregate functions."+ pure $ foldl' AppE squealFn argExps+ PGT_AST.StarFuncApplicationParams ->+ if fnNameStrLower == "count"+ then pure $ VarE 'S.countStar+ else fail "Star argument only supported for COUNT"+ _ -> fail $ "Unsupported function parameters structure: " <> show params + renderPGTFuncArgExpr :: [Text.Text] -> PGT_AST.FuncArgExpr -> Q Exp renderPGTFuncArgExpr cteNames = \case PGT_AST.ExprFuncArgExpr aExpr -> renderPGTAExpr cteNames aExpr _ -> fail "Named or colon-syntax function arguments not supported" -renderPGTFuncExprCommonSubexpr :: [Text.Text] -> PGT_AST.FuncExprCommonSubexpr -> Q Exp+renderPGTFuncExprCommonSubexpr+ :: [Text.Text] -> PGT_AST.FuncExprCommonSubexpr -> Q Exp renderPGTFuncExprCommonSubexpr cteNames = \case PGT_AST.CurrentTimestampFuncExprCommonSubexpr (Just _) -> fail "CURRENT_TIMESTAMP with precision is not supported."
test/test.hs view
@@ -15,6 +15,7 @@ import Data.Aeson (Value) import Data.Int (Int32, Int64)+import Data.Scientific (Scientific) import Data.Text (Text) import Data.Time (Day, UTCTime) import Data.UUID (UUID)@@ -594,13 +595,63 @@ ) ) )- statement = [ssql| with users_cte as (select * from users) select * from users_cte |]+ statement =+ [ssql|+ with users_cte as (select * from users)+ select * from users_cte+ |] squealRendering :: Text squealRendering = "WITH \"users_cte\" AS (SELECT * FROM \"users\" AS \"users\") SELECT * FROM \"users_cte\" AS \"users_cte\"" checkStatement squealRendering statement it+ "with recursive t as ( select 1 as n union all select (n + 1) as n from t where n < 100) select n from t"+ $ do+ let+ statement+ :: Statement+ DB+ ()+ (Field "n" Int64, ())+ statement =+ [ssql|+ with recursive t as (+ select 1 as n+ union all+ select (n + 1) as n from t where n < 100+ )+ select n from t+ |]+ squealRendering :: Text+ squealRendering =+ "WITH RECURSIVE \"t\" AS ((SELECT * FROM (VALUES (1)) AS t (\"n\")) UNION ALL (SELECT (\"n\" + 1) AS \"n\" FROM \"t\" AS \"t\" WHERE (\"n\" < 100))) SELECT \"n\" AS \"n\" FROM \"t\" AS \"t\""+ checkStatement squealRendering statement++ it+ "with recursive users_cte as ( select id, name from users union all select id, name from users_cte) select * from users_cte"+ $ do+ let+ statement+ :: Statement+ DB+ ()+ (Field "id" Text, (Field "name" Text, ()))+ statement =+ [ssql|+ with recursive users_cte as (+ select id, name from users+ union all+ select id, name from users_cte+ )+ select * from users_cte+ |]+ squealRendering :: Text+ squealRendering =+ "WITH RECURSIVE \"users_cte\" AS ((SELECT \"id\" AS \"id\", \"name\" AS \"name\" FROM \"users\" AS \"users\") UNION ALL (SELECT \"id\" AS \"id\", \"name\" AS \"name\" FROM \"users_cte\" AS \"users_cte\")) SELECT * FROM \"users_cte\" AS \"users_cte\""+ checkStatement squealRendering statement++ it "with users_cte as (select * from users), emails_cte as (select * from emails) select users_cte.*, emails_cte.email from users_cte join emails_cte on users_cte.id = emails_cte.user_id" $ do let@@ -633,6 +684,70 @@ "WITH \"users_cte\" AS (SELECT * FROM \"users\" AS \"users\"), \"emails_cte\" AS (SELECT * FROM \"emails\" AS \"emails\") SELECT \"users_cte\".*, \"emails_cte\".\"email\" AS \"email\" FROM \"users_cte\" AS \"users_cte\" INNER JOIN \"emails_cte\" AS \"emails_cte\" ON (\"users_cte\".\"id\" = \"emails_cte\".\"user_id\")" checkStatement squealRendering statement + describe "set operations" $ do+ it "select name from users union select name from users_copy" $ do+ let+ statement :: Statement DB () (Field "name" Text, ())+ statement = [ssql| select name from users union select name from users_copy |]+ squealRendering :: Text+ squealRendering =+ "(SELECT \"name\" AS \"name\" FROM \"users\" AS \"users\") UNION (SELECT \"name\" AS \"name\" FROM \"users_copy\" AS \"users_copy\")"+ checkStatement squealRendering statement++ it "select name from users union all select name from users_copy" $ do+ let+ statement :: Statement DB () (Field "name" Text, ())+ statement = [ssql| select name from users union all select name from users_copy |]+ squealRendering :: Text+ squealRendering =+ "(SELECT \"name\" AS \"name\" FROM \"users\" AS \"users\") UNION ALL (SELECT \"name\" AS \"name\" FROM \"users_copy\" AS \"users_copy\")"+ checkStatement squealRendering statement++ it "select name from users intersect select name from users_copy" $ do+ let+ statement :: Statement DB () (Field "name" Text, ())+ statement = [ssql| select name from users intersect select name from users_copy |]+ squealRendering :: Text+ squealRendering =+ "(SELECT \"name\" AS \"name\" FROM \"users\" AS \"users\") INTERSECT (SELECT \"name\" AS \"name\" FROM \"users_copy\" AS \"users_copy\")"+ checkStatement squealRendering statement++ it "select name from users intersect all select name from users_copy" $ do+ let+ statement :: Statement DB () (Field "name" Text, ())+ statement = [ssql| select name from users intersect all select name from users_copy |]+ squealRendering :: Text+ squealRendering =+ "(SELECT \"name\" AS \"name\" FROM \"users\" AS \"users\") INTERSECT ALL (SELECT \"name\" AS \"name\" FROM \"users_copy\" AS \"users_copy\")"+ checkStatement squealRendering statement++ it "select name from users except select name from users_copy" $ do+ let+ statement :: Statement DB () (Field "name" Text, ())+ statement = [ssql| select name from users except select name from users_copy |]+ squealRendering :: Text+ squealRendering =+ "(SELECT \"name\" AS \"name\" FROM \"users\" AS \"users\") EXCEPT (SELECT \"name\" AS \"name\" FROM \"users_copy\" AS \"users_copy\")"+ checkStatement squealRendering statement++ it "select name from users except all select name from users_copy" $ do+ let+ statement :: Statement DB () (Field "name" Text, ())+ statement = [ssql| select name from users except all select name from users_copy |]+ squealRendering :: Text+ squealRendering =+ "(SELECT \"name\" AS \"name\" FROM \"users\" AS \"users\") EXCEPT ALL (SELECT \"name\" AS \"name\" FROM \"users_copy\" AS \"users_copy\")"+ checkStatement squealRendering statement++ it "(select name from users) union (select name from users_copy)" $ do+ let+ statement :: Statement DB () (Field "name" Text, ())+ statement = [ssql| (select name from users) union (select name from users_copy) |]+ squealRendering :: Text+ squealRendering =+ "(SELECT \"name\" AS \"name\" FROM \"users\" AS \"users\") UNION (SELECT \"name\" AS \"name\" FROM \"users_copy\" AS \"users_copy\")"+ checkStatement squealRendering statement+ describe "inserts" $ do it "insert into emails (id, user_id, email) values (1, 'user-1', 'foo@bar')" $ do let@@ -942,91 +1057,101 @@ checkStatement squealRendering statement describe "on conflict" $ do- it "insert into users_copy (id, name, bio) values ('id1', 'name1', null) on conflict on constraint pk_users_copy do nothing" $ do- let- statement :: Statement DB () ()- statement =- [ssql|+ it+ "insert into users_copy (id, name, bio) values ('id1', 'name1', null) on conflict on constraint pk_users_copy do nothing"+ $ do+ let+ statement :: Statement DB () ()+ statement =+ [ssql| insert into users_copy (id, name, bio) values ('id1', 'name1', null) on conflict on constraint pk_users_copy do nothing |]- squealRendering :: Text- squealRendering =- "INSERT INTO \"users_copy\" AS \"users_copy\" (\"id\", \"name\", \"bio\") VALUES ((E'id1' :: text), (E'name1' :: text), NULL) ON CONFLICT ON CONSTRAINT \"pk_users_copy\" DO NOTHING"- checkStatement squealRendering statement+ squealRendering :: Text+ squealRendering =+ "INSERT INTO \"users_copy\" AS \"users_copy\" (\"id\", \"name\", \"bio\") VALUES ((E'id1' :: text), (E'name1' :: text), NULL) ON CONFLICT ON CONSTRAINT \"pk_users_copy\" DO NOTHING"+ checkStatement squealRendering statement - it "insert into users_copy (id, name, bio) values ('id1', 'name1', 'bio1') on conflict on constraint pk_users_copy do update set name = 'new_name'" $ do- let- statement :: Statement DB () ()- statement =- [ssql|+ it+ "insert into users_copy (id, name, bio) values ('id1', 'name1', 'bio1') on conflict on constraint pk_users_copy do update set name = 'new_name'"+ $ do+ let+ statement :: Statement DB () ()+ statement =+ [ssql| insert into users_copy (id, name, bio) values ('id1', 'name1', 'bio1') on conflict on constraint pk_users_copy do update set name = 'new_name' |]- squealRendering :: Text- squealRendering =- "INSERT INTO \"users_copy\" AS \"users_copy\" (\"id\", \"name\", \"bio\") VALUES ((E'id1' :: text), (E'name1' :: text), (E'bio1' :: text)) ON CONFLICT ON CONSTRAINT \"pk_users_copy\" DO UPDATE SET \"name\" = (E'new_name' :: text)"- checkStatement squealRendering statement+ squealRendering :: Text+ squealRendering =+ "INSERT INTO \"users_copy\" AS \"users_copy\" (\"id\", \"name\", \"bio\") VALUES ((E'id1' :: text), (E'name1' :: text), (E'bio1' :: text)) ON CONFLICT ON CONSTRAINT \"pk_users_copy\" DO UPDATE SET \"name\" = (E'new_name' :: text)"+ checkStatement squealRendering statement - it "insert into users_copy (id, name, bio) values ('id1', 'name1', null) on conflict on constraint pk_users_copy do update set name = 'new_name' where users_copy.name = 'old_name'" $ do- let- statement :: Statement DB () ()- statement =- [ssql|+ it+ "insert into users_copy (id, name, bio) values ('id1', 'name1', null) on conflict on constraint pk_users_copy do update set name = 'new_name' where users_copy.name = 'old_name'"+ $ do+ let+ statement :: Statement DB () ()+ statement =+ [ssql| insert into users_copy (id, name, bio) values ('id1', 'name1', null) on conflict on constraint pk_users_copy do update set name = 'new_name' where users_copy.name = 'old_name' |]- squealRendering :: Text- squealRendering =- "INSERT INTO \"users_copy\" AS \"users_copy\" (\"id\", \"name\", \"bio\") VALUES ((E'id1' :: text), (E'name1' :: text), NULL) ON CONFLICT ON CONSTRAINT \"pk_users_copy\" DO UPDATE SET \"name\" = (E'new_name' :: text) WHERE (\"users_copy\".\"name\" = (E'old_name' :: text))"- checkStatement squealRendering statement+ squealRendering :: Text+ squealRendering =+ "INSERT INTO \"users_copy\" AS \"users_copy\" (\"id\", \"name\", \"bio\") VALUES ((E'id1' :: text), (E'name1' :: text), NULL) ON CONFLICT ON CONSTRAINT \"pk_users_copy\" DO UPDATE SET \"name\" = (E'new_name' :: text) WHERE (\"users_copy\".\"name\" = (E'old_name' :: text))"+ checkStatement squealRendering statement - it "insert into users_copy (id, name, bio) values ('id1', 'name1', null) on conflict on constraint pk_users_copy do nothing returning id" $ do- let- statement :: Statement DB () (Field "id" Text, ())- statement =- [ssql|+ it+ "insert into users_copy (id, name, bio) values ('id1', 'name1', null) on conflict on constraint pk_users_copy do nothing returning id"+ $ do+ let+ statement :: Statement DB () (Field "id" Text, ())+ statement =+ [ssql| insert into users_copy (id, name, bio) values ('id1', 'name1', null) on conflict on constraint pk_users_copy do nothing returning id |]- squealRendering :: Text- squealRendering =- "INSERT INTO \"users_copy\" AS \"users_copy\" (\"id\", \"name\", \"bio\") VALUES ((E'id1' :: text), (E'name1' :: text), NULL) ON CONFLICT ON CONSTRAINT \"pk_users_copy\" DO NOTHING RETURNING \"id\" AS \"id\""- checkStatement squealRendering statement+ squealRendering :: Text+ squealRendering =+ "INSERT INTO \"users_copy\" AS \"users_copy\" (\"id\", \"name\", \"bio\") VALUES ((E'id1' :: text), (E'name1' :: text), NULL) ON CONFLICT ON CONSTRAINT \"pk_users_copy\" DO NOTHING RETURNING \"id\" AS \"id\""+ checkStatement squealRendering statement - it "insert into users_copy (id, name, bio) values ('id1', 'name1', 'bio1') on conflict on constraint pk_users_copy do update set name = 'new_name' returning *" $ do- let- statement- :: Statement- DB- ()- ( Field "id" Text- , ( Field "name" Text- , ( Field "bio" (Maybe Text)- , ()+ it+ "insert into users_copy (id, name, bio) values ('id1', 'name1', 'bio1') on conflict on constraint pk_users_copy do update set name = 'new_name' returning *"+ $ do+ let+ statement+ :: Statement+ DB+ ()+ ( Field "id" Text+ , ( Field "name" Text+ , ( Field "bio" (Maybe Text)+ , ()+ ) ) )- )- statement =- [ssql|+ statement =+ [ssql| insert into users_copy (id, name, bio) values ('id1', 'name1', 'bio1') on conflict on constraint pk_users_copy do update set name = 'new_name' returning * |]- squealRendering :: Text- squealRendering =- "INSERT INTO \"users_copy\" AS \"users_copy\" (\"id\", \"name\", \"bio\") VALUES ((E'id1' :: text), (E'name1' :: text), (E'bio1' :: text)) ON CONFLICT ON CONSTRAINT \"pk_users_copy\" DO UPDATE SET \"name\" = (E'new_name' :: text) RETURNING *"- checkStatement squealRendering statement+ squealRendering :: Text+ squealRendering =+ "INSERT INTO \"users_copy\" AS \"users_copy\" (\"id\", \"name\", \"bio\") VALUES ((E'id1' :: text), (E'name1' :: text), (E'bio1' :: text)) ON CONFLICT ON CONSTRAINT \"pk_users_copy\" DO UPDATE SET \"name\" = (E'new_name' :: text) RETURNING *"+ checkStatement squealRendering statement describe "deletes" $ do it "delete from users where true" $ do@@ -1463,6 +1588,85 @@ squealRendering = "SELECT * FROM (VALUES (CURRENT_DATE)) AS t (\"today\")" checkStatement squealRendering stmt + describe "aggregate functions" $ do+ it "select sum(id) as total_ids from emails" $ do+ let+ stmt :: Statement DB () (Field "total_ids" (Maybe Int64), ())+ stmt = [ssql| select sum(id) as total_ids from emails group by () |]+ squealRendering :: Text+ squealRendering =+ "SELECT sum(ALL \"id\") AS \"total_ids\" FROM \"emails\" AS \"emails\""+ checkStatement squealRendering stmt++ it "select sum(all id) as total_ids from emails" $ do+ let+ stmt :: Statement DB () (Field "total_ids" (Maybe Int64), ())+ stmt = [ssql| select sum(all id) as total_ids from emails group by () |]+ squealRendering :: Text+ squealRendering =+ "SELECT sum(ALL \"id\") AS \"total_ids\" FROM \"emails\" AS \"emails\""+ checkStatement squealRendering stmt++ it "select sum(distinct id) as total_ids from emails" $ do+ let+ stmt :: Statement DB () (Field "total_ids" (Maybe Int64), ())+ stmt = [ssql| select sum(distinct id) as total_ids from emails group by () |]+ squealRendering :: Text+ squealRendering =+ "SELECT sum(DISTINCT \"id\") AS \"total_ids\" FROM \"emails\" AS \"emails\""+ checkStatement squealRendering stmt++ it "select count(distinct id) as distinct_ids from emails" $ do+ let+ stmt :: Statement DB () (Field "distinct_ids" Int64, ())+ stmt = [ssql| select count(distinct id) as distinct_ids from emails group by () |]+ squealRendering :: Text+ squealRendering =+ "SELECT count(DISTINCT \"id\") AS \"distinct_ids\" FROM \"emails\" AS \"emails\""+ checkStatement squealRendering stmt++ it "select count(all id) as all_ids from emails" $ do+ let+ stmt :: Statement DB () (Field "all_ids" Int64, ())+ stmt = [ssql| select count(all id) as all_ids from emails group by () |]+ squealRendering :: Text+ squealRendering =+ "SELECT count(ALL \"id\") AS \"all_ids\" FROM \"emails\" AS \"emails\""+ checkStatement squealRendering stmt++ it "select avg(id) as avg_id from emails" $ do+ let+ stmt+ :: Statement+ DB+ ()+ ( Field "avg_id" (Maybe Scientific)+ , ()+ )+ stmt = [ssql| select avg(id) as avg_id from emails group by () |]+ squealRendering :: Text+ squealRendering =+ "SELECT avg(ALL \"id\") AS \"avg_id\" FROM \"emails\" AS \"emails\""+ checkStatement squealRendering stmt++ it "select min(id) as min_id from emails" $ do+ let+ stmt :: Statement DB () (Field "min_id" (Maybe Int32), ())+ stmt = [ssql| select min(id) as min_id from emails group by () |]+ squealRendering :: Text+ squealRendering =+ "SELECT min(ALL \"id\") AS \"min_id\" FROM \"emails\" AS \"emails\""+ checkStatement squealRendering stmt++ it "select max(id) as max_id from emails" $ do+ let+ stmt :: Statement DB () (Field "max_id" (Maybe Int32), ())+ stmt = [ssql| select max(id) as max_id from emails group by () |]+ squealRendering :: Text+ squealRendering =+ "SELECT max(ALL \"id\") AS \"max_id\" FROM \"emails\" AS \"emails\""+ checkStatement squealRendering stmt+ it "haskell variables in expressions" $ do let mkStatement@@ -1782,6 +1986,160 @@ 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++ describe "window functions" $ do+ it "select name, row_number() over () as rn from users" $ do+ let+ statement+ :: Statement+ DB+ ()+ ( Field "name" Text+ , ( Field "rn" Int64+ , ()+ )+ )+ statement = [ssql| select name, row_number() over () as rn from users |]+ squealRendering :: Text+ squealRendering =+ "SELECT \"name\" AS \"name\", row_number() OVER () AS \"rn\" FROM \"users\" AS \"users\""+ checkStatement squealRendering statement++ it+ "select name, rank() over (partition by employee_id order by name) as r from users"+ $ do+ let+ statement+ :: Statement+ DB+ ()+ ( Field "name" Text+ , ( Field "r" Int64+ , ()+ )+ )+ statement =+ [ssql| select name, rank() over (partition by employee_id order by name) as r from users |]+ squealRendering :: Text+ squealRendering =+ "SELECT \"name\" AS \"name\", rank() OVER (PARTITION BY \"employee_id\" ORDER BY \"name\" ASC) AS \"r\" FROM \"users\" AS \"users\""+ checkStatement squealRendering statement++ it "select email, sum(id) over (partition by user_id) as user_total from emails" $ do+ let+ statement+ :: Statement+ DB+ ()+ ( Field "email" (Maybe Text)+ , ( Field "user_total" (Maybe Int64)+ , ()+ )+ )+ statement =+ [ssql| select email, sum(id) over (partition by user_id) as user_total from emails |]+ squealRendering :: Text+ squealRendering =+ "SELECT \"email\" AS \"email\", sum(\"id\") OVER (PARTITION BY \"user_id\") AS \"user_total\" FROM \"emails\" AS \"emails\""+ checkStatement squealRendering statement++ it "select email, avg(id) over (partition by user_id) as user_avg from emails" $ do+ let+ statement+ :: Statement+ DB+ ()+ ( Field "email" (Maybe Text)+ , ( Field "user_avg" (Maybe Scientific)+ , ()+ )+ )+ statement =+ [ssql| select email, avg(id) over (partition by user_id) as user_avg from emails |]+ squealRendering :: Text+ squealRendering =+ "SELECT \"email\" AS \"email\", avg(\"id\") OVER (PARTITION BY \"user_id\") AS \"user_avg\" FROM \"emails\" AS \"emails\""+ checkStatement squealRendering statement++ it "select email, min(id) over (partition by user_id) as user_min from emails" $ do+ let+ statement+ :: Statement+ DB+ ()+ ( Field "email" (Maybe Text)+ , ( Field "user_min" (Maybe Int32)+ , ()+ )+ )+ statement =+ [ssql| select email, min(id) over (partition by user_id) as user_min from emails |]+ squealRendering :: Text+ squealRendering =+ "SELECT \"email\" AS \"email\", min(\"id\") OVER (PARTITION BY \"user_id\") AS \"user_min\" FROM \"emails\" AS \"emails\""+ checkStatement squealRendering statement++ it "select email, max(id) over (partition by user_id) as user_max from emails" $ do+ let+ statement+ :: Statement+ DB+ ()+ ( Field "email" (Maybe Text)+ , ( Field "user_max" (Maybe Int32)+ , ()+ )+ )+ statement =+ [ssql| select email, max(id) over (partition by user_id) as user_max from emails |]+ squealRendering :: Text+ squealRendering =+ "SELECT \"email\" AS \"email\", max(\"id\") OVER (PARTITION BY \"user_id\") AS \"user_max\" FROM \"emails\" AS \"emails\""+ checkStatement squealRendering statement++ it+ "select name, row_number() over (order by name), rank() over (order by name) from users"+ $ do+ let+ statement+ :: Statement+ DB+ ()+ ( Field "name" Text+ , ( Field "_window1" Int64+ , ( Field "_window2" Int64+ , ()+ )+ )+ )+ statement =+ [ssql| select name, row_number() over (order by name), rank() over (order by name) from users |]+ squealRendering :: Text+ squealRendering =+ "SELECT \"name\" AS \"name\", row_number() OVER ( ORDER BY \"name\" ASC) AS \"_window1\", rank() OVER ( ORDER BY \"name\" ASC) AS \"_window2\" FROM \"users\" AS \"users\""+ checkStatement squealRendering statement++ it+ "select name, row_number() over (partition by employee_id order by name), rank() over (order by name) from users"+ $ do+ let+ statement+ :: Statement+ DB+ ()+ ( Field "name" Text+ , ( Field "_window1" Int64+ , ( Field "_window2" Int64+ , ()+ )+ )+ )+ statement =+ [ssql| select name, row_number() over (partition by employee_id order by name), rank() over (order by name) from users |]+ squealRendering :: Text+ squealRendering =+ "SELECT \"name\" AS \"name\", row_number() OVER (PARTITION BY \"employee_id\" ORDER BY \"name\" ASC) AS \"_window1\", rank() OVER ( ORDER BY \"name\" ASC) AS \"_window2\" FROM \"users\" AS \"users\"" checkStatement squealRendering statement