hpqtypes-extras 1.16.3.1 → 1.16.4.0
raw patch · 4 files changed
+85/−7 lines, 4 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Database.PostgreSQL.PQTypes.SQL.Builder: [sqlSelectUnionAll] :: SqlSelect -> [SQL]
+ Database.PostgreSQL.PQTypes.SQL.Builder: sqlUnionAll :: (MonadState SqlSelect m, Sqlable sql) => [sql] -> m ()
- Database.PostgreSQL.PQTypes.SQL.Builder: SqlSelect :: SQL -> [SQL] -> Bool -> [SQL] -> [SqlCondition] -> [SQL] -> [SQL] -> [SQL] -> Integer -> Integer -> [(SQL, SQL, Materialized)] -> SqlSelect
+ Database.PostgreSQL.PQTypes.SQL.Builder: SqlSelect :: SQL -> [SQL] -> [SQL] -> Bool -> [SQL] -> [SqlCondition] -> [SQL] -> [SQL] -> [SQL] -> Integer -> Integer -> [(SQL, SQL, Materialized)] -> SqlSelect
Files
- CHANGELOG.md +3/−0
- hpqtypes-extras.cabal +1/−1
- src/Database/PostgreSQL/PQTypes/SQL/Builder.hs +27/−5
- test/Main.hs +54/−1
CHANGELOG.md view
@@ -1,3 +1,6 @@+# hpqtypes-extras-1.16.4.0 (2023-04-20)+* Add support for the `UNION ALL` clause via `sqlUnionAll`.+ # hpqtypes-extras-1.16.3.1 (2023-04-13) * Add support for GHC 9.6. * Fix checkAndRememberMaterializationSupport's query.
hpqtypes-extras.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: hpqtypes-extras-version: 1.16.3.1+version: 1.16.4.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: .
src/Database/PostgreSQL/PQTypes/SQL/Builder.hs view
@@ -129,6 +129,7 @@ , sqlWith , sqlWithMaterialized , sqlUnion+ , sqlUnionAll , checkAndRememberMaterializationSupport , sqlSelect@@ -231,6 +232,7 @@ data SqlSelect = SqlSelect { sqlSelectFrom :: SQL , sqlSelectUnion :: [SQL]+ , sqlSelectUnionAll :: [SQL] , sqlSelectDistinct :: Bool , sqlSelectResult :: [SQL] , sqlSelectWhere :: [SqlCondition]@@ -340,8 +342,8 @@ toSQLCommand cmd = smconcat [ emitClausesSepComma "WITH" $ map (\(name,command,mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlSelectWith cmd)- , if hasUnion- then emitClausesSep "" "UNION" (mainSelectClause : sqlSelectUnion cmd)+ , if hasUnion || hasUnionAll+ then emitClausesSep "" unionKeyword (mainSelectClause : unionCmd) else mainSelectClause , emitClausesSepComma "GROUP BY" (sqlSelectGroupBy cmd) , emitClausesSep "HAVING" "AND" (sqlSelectHaving cmd)@@ -368,6 +370,19 @@ ] hasUnion = not . null $ sqlSelectUnion cmd+ hasUnionAll = not . null $ sqlSelectUnionAll cmd+ unionKeyword = case (hasUnion, hasUnionAll) of+ (False, True) -> "UNION ALL"+ (True, False) -> "UNION"+ -- False, False is caught by the (hasUnion || hasUnionAll) above.+ -- Hence, the catch-all is implicitly for (True, True).+ _ -> error "Having both `sqlSelectUnion` and `sqlSelectUnionAll` is not supported at the moment."+ unionCmd = case (hasUnion, hasUnionAll) of+ (False, True) -> sqlSelectUnionAll cmd+ (True, False) -> sqlSelectUnion cmd+ -- False, False is caught by the (hasUnion || hasUnionAll) above.+ -- Hence, the catch-all is implicitly for (True, True).+ _ -> error "Having both `sqlSelectUnion` and `sqlSelectUnionAll` is not supported at the moment." orderByClause = emitClausesSepComma "ORDER BY" $ sqlSelectOrderBy cmd limitClause = unsafeSQL $ "LIMIT" <+> show (sqlSelectLimit cmd) @@ -403,6 +418,7 @@ , parenthesize . sqlConcatComma . map fst $ sqlInsertSelectSet cmd , parenthesize . toSQLCommand $ SqlSelect { sqlSelectFrom = sqlInsertSelectFrom cmd , sqlSelectUnion = []+ , sqlSelectUnionAll = [] , sqlSelectDistinct = sqlInsertSelectDistinct cmd , sqlSelectResult = fmap snd $ sqlInsertSelectSet cmd , sqlSelectWhere = sqlInsertSelectWhere cmd@@ -460,14 +476,13 @@ toSQLCommand cmd = "(" <+> smintercalate "AND" (map (parenthesize . toSQLCommand) (sqlAllWhere cmd)) <+> ")" - sqlSelect :: SQL -> State SqlSelect () -> SqlSelect sqlSelect table refine =- execState refine (SqlSelect table [] False [] [] [] [] [] 0 (-1) [])+ execState refine (SqlSelect table [] [] False [] [] [] [] [] 0 (-1) []) sqlSelect2 :: SQL -> State SqlSelect () -> SqlSelect sqlSelect2 from refine =- execState refine (SqlSelect from [] False [] [] [] [] [] 0 (-1) [])+ execState refine (SqlSelect from [] [] False [] [] [] [] [] 0 (-1) []) sqlInsert :: SQL -> State SqlInsert () -> SqlInsert sqlInsert table refine =@@ -533,6 +548,13 @@ -- applies to the main SELECT, not the whole union. sqlUnion :: (MonadState SqlSelect m, Sqlable sql) => [sql] -> m () sqlUnion sqls = modify (\cmd -> cmd { sqlSelectUnion = map toSQLCommand sqls })++-- | Note: WHERE clause of the main SELECT is treated specially, i.e. it only+-- applies to the main SELECT, not the whole union.+--+-- @since 1.16.4.0+sqlUnionAll :: (MonadState SqlSelect m, Sqlable sql) => [sql] -> m ()+sqlUnionAll sqls = modify (\cmd -> cmd { sqlSelectUnionAll = map toSQLCommand sqls }) class SqlWhere a where sqlWhere1 :: a -> SqlCondition -> a
test/Main.hs view
@@ -1205,7 +1205,7 @@ testPass runSQL_ "DELETE FROM bank" step "Checking for WITH MATERIALIZED support"- checkAndRememberMaterializationSupport + checkAndRememberMaterializationSupport step "Running sql WITH tests again with WITH MATERIALIZED support flag set" testPass where@@ -1257,6 +1257,45 @@ (results :: [T.Text]) <- fetchMany runIdentity liftIO $ assertEqual "Wrong number of banks left" 2 (length results) +testUnion :: HasCallStack => (String -> TestM ()) -> TestM ()+testUnion step = do+ step "Running SQL UNION tests"+ testPass+ where+ testPass = do+ runQuery_ . sqlSelect "" $ do+ sqlResult "true"+ sqlUnion+ [ sqlSelect "" $ do+ sqlResult "false"+ , sqlSelect "" $ do+ sqlResult "true"+ ]+ result <- fetchMany runIdentity+ liftIO $ assertEqual "UNION of booleans"+ [False, True]+ result+++testUnionAll :: HasCallStack => (String -> TestM ()) -> TestM ()+testUnionAll step = do+ step "Running SQL UNION ALL tests"+ testPass+ where+ testPass = do+ runQuery_ . sqlSelect "" $ do+ sqlResult "true"+ sqlUnionAll+ [ sqlSelect "" $ do+ sqlResult "false"+ , sqlSelect "" $ do+ sqlResult "true"+ ]+ result <- fetchMany runIdentity+ liftIO $ assertEqual "UNION ALL of booleans"+ [True, False, True]+ result+ migrationTest1 :: ConnectionSourceM (LogT IO) -> TestTree migrationTest1 connSource = testCaseSteps' "Migration test 1" connSource $ \step -> do@@ -1398,6 +1437,18 @@ freshTestDB step testSqlWith step +unionTests :: ConnectionSourceM (LogT IO) -> TestTree+unionTests connSource =+ testCaseSteps' "SQL UNION Tests" connSource $ \step -> do+ freshTestDB step+ testUnion step++unionAllTests :: ConnectionSourceM (LogT IO) -> TestTree+unionAllTests connSource =+ testCaseSteps' "SQL UNION ALL Tests" connSource $ \step -> do+ freshTestDB step+ testUnionAll step+ eitherExc :: MonadCatch m => (SomeException -> m ()) -> (a -> m ()) -> m a -> m () eitherExc left right c = try c >>= either left right @@ -1581,6 +1632,8 @@ , migrationTest5 connSource , triggerTests connSource , sqlWithTests connSource+ , unionTests connSource+ , unionAllTests connSource ] where ings =