hpqtypes-extras 1.20.0.0 → 1.21.0.0

raw patch · 6 files changed

+74/−76 lines, 6 filesdep ~log-basedep ~tasty-hunitPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: log-base, tasty-hunit

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• hpqtypes-extras.cabal +4/−4
• src/Database/PostgreSQL/PQTypes/Checks.hs +22/−15
• src/Database/PostgreSQL/PQTypes/SQL/Builder.hs +34/−44
• src/Database/PostgreSQL/PQTypes/Utils/NubList.hs +1/−3
• test/Main.hs +4/−10

@@ -1,3 +1,12 @@+# hpqtypes-extras-1.21.0.0 (2026-09-18)+* `migrateDatabase` and `checkDatabase` now require PostgreSQL 15 or later. On an+  older server they stop with an error.+* Remove `checkAndRememberMaterializationSupport`. All supported servers+  understand the `MATERIALIZED` keyword, so delete the call from your code.+* `sqlWith` now emits a plain `WITH` clause and lets PostgreSQL decide whether+  to materialize it. It used to emit `WITH ... AS NOT MATERIALIZED`. To keep the+  old behavior, use the new `sqlWithNotMaterialized`.+ # hpqtypes-extras-1.20.0.0 (2026-06-10) * Drop `crypton` dependency in favor of `ppad-ripemd160`. * Add support for customizing trigger functions.

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                hpqtypes-extras-version:             1.20.0.0+version:             1.21.0.0 synopsis:            Extra utilities for hpqtypes library description:         The following extras for hpqtypes library:                      .@@ -89,8 +89,8 @@                , containers        >= 0.5                , exceptions        >= 0.10                , extra             >= 1.6.17-               , hpqtypes          >= 1.13.0.0-               , log-base          >= 0.11+               , hpqtypes          >= 1.13.0.0 && < 2+               , log-base          >= 0.12.0.1                , mtl               >= 2.2                , ppad-ripemd160    >= 0.1.4                , text              >= 1.2@@ -127,7 +127,7 @@                     , hpqtypes-extras                     , log-base                     , tasty-                    , tasty-hunit+                    , tasty-hunit >= 0.10                     , text                     , uuid-types 

@@ -88,6 +88,7 @@     , dbTables = tables     }   migrations = do+    checkPostgresVersion     setDBTimeZoneToUTC     mapM_ checkExtension extensions     tablesWithVersions <- getTableVersions (tableVersions : tables)@@ -131,6 +132,7 @@     , dbDomains = domains     , dbTables = tables     } = execWriterT $ do+    lift checkPostgresVersion     (_, report) <- W.listen $ do       tablesWithVersions <- getTableVersions (tableVersions : tables)       tell $ checkVersions options tablesWithVersions@@ -600,12 +602,11 @@         sqlOrderBy "a.attnum"       desc <- fetchMany fetchTableColumn -      isAbove15 <- checkVersionIsAtLeast15       -- get info about constraints from pg_catalog       pk <- sqlGetPrimaryKey tblName       runQuery_ $ sqlGetChecks tblName       checks <- fetchMany fetchTableCheck-      runQuery_ $ sqlGetIndexes isAbove15 tblName Nothing+      runQuery_ $ sqlGetIndexes tblName Nothing       indexes <- fetchMany fetchTableIndex       runQuery_ $ sqlGetForeignKeys tblName       fkeys <- fetchMany fetchForeignKey@@ -1131,8 +1132,7 @@           indexSet <- case mLocalIndexName of             Nothing -> pure False             Just localIndexName -> do-              isAbove15 <- checkVersionIsAtLeast15-              runQuery_ $ sqlGetIndexes isAbove15 mgrTableName (Just localIndexName)+              runQuery_ $ sqlGetIndexes mgrTableName (Just localIndexName)               fetchMaybe fetchTableIndex >>= \case                 Nothing -> do                   logInfo_ "Local index not found"@@ -1378,11 +1378,21 @@ -- | Type synonym for a list of tables along with their database versions. type TablesWithVersions = [(Table, Int32)] --- The server_version_num has been there since 8.2-checkVersionIsAtLeast15 :: (MonadDB m, MonadThrow m) => m Bool-checkVersionIsAtLeast15 = do-  runSQL01_ "select current_setting('server_version_num',true)::int >= 150000;"-  fetchOne runIdentity+-- | Fail if the PostgreSQL server is older than the oldest supported version.+checkPostgresVersion :: (MonadDB m, MonadLog m, MonadThrow m) => m ()+checkPostgresVersion = do+  runSQL_ "SELECT current_setting('server_version_num')::int4, current_setting('server_version')"+  (versionNum, version) <- fetchOne $ id @(Int32, Text)+  when (versionNum < minimumVersion) . resultCheck . validationError $+    T.concat+      [ "PostgreSQL "+      , version+      , " is not supported, the minimum supported version is "+      , showt $ minimumVersion `div` 10_000+      ]+  where+    minimumVersion :: Int32+    minimumVersion = 150_000  -- | Associate each table in the list with its version as it exists in -- the DB, or 0 if it's missing from the DB.@@ -1516,17 +1526,14 @@     }  -- *** INDEXES ***-sqlGetIndexes :: Bool -> RawSQL () -> Maybe (RawSQL ()) -> SQL-sqlGetIndexes nullsNotDistinctSupported tableName mname = toSQLCommand . sqlSelect "pg_catalog.pg_class c" $ do+sqlGetIndexes :: RawSQL () -> Maybe (RawSQL ()) -> SQL+sqlGetIndexes tableName mname = toSQLCommand . sqlSelect "pg_catalog.pg_class c" $ do   sqlResult "c.relname::text" -- index name   sqlResult $ "ARRAY(" <> selectCoordinates "0" "i.indnkeyatts" <> ")" -- array of key columns in the index   sqlResult $ "ARRAY(" <> selectCoordinates "i.indnkeyatts" "i.indnatts" <> ")" -- array of included columns in the index   sqlResult "am.amname::text" -- the method used (btree, gin etc)   sqlResult "i.indisunique" -- is it unique?-  -- does it have NULLS NOT DISTINCT ?-  if nullsNotDistinctSupported-    then sqlResult "i.indnullsnotdistinct"-    else sqlResult "false"+  sqlResult "i.indnullsnotdistinct" -- does it have NULLS NOT DISTINCT?   -- if partial, get constraint def   sqlResult "pg_catalog.pg_get_expr(i.indpred, i.indrelid, true)"   sqlJoinOn "pg_catalog.pg_index i" "c.oid = i.indexrelid"

@@ -125,9 +125,9 @@   , sqlWith   , sqlWithRecursive   , sqlWithMaterialized+  , sqlWithNotMaterialized   , sqlUnion   , sqlUnionAll-  , checkAndRememberMaterializationSupport   , sqlSelect   , sqlSelect2   , SqlSelect (..)@@ -165,18 +165,12 @@   ) where -import Control.Monad.Catch import Control.Monad.State-import Data.Either-import Data.IORef-import Data.Int import Data.List import Data.Maybe import Data.Monoid.Utils import Data.String-import Data.Typeable import Database.PostgreSQL.PQTypes-import System.IO.Unsafe  class Sqlable a where   toSQLCommand :: a -> SQL@@ -209,7 +203,7 @@   deriving (Eq, Show)  data Multiplicity a = Single a | Many [a]-  deriving (Eq, Ord, Show, Typeable)+  deriving (Eq, Ord, Show)  -- | 'SqlCondition' are clauses that are part of the WHERE block in -- SQL statements. Each statement has a list of conditions, all of@@ -220,7 +214,7 @@ data SqlCondition   = SqlPlainCondition SQL   | SqlExistsCondition SqlSelect-  deriving (Typeable, Show)+  deriving (Show)  instance Sqlable SqlCondition where   toSQLCommand (SqlPlainCondition a) = a@@ -238,7 +232,7 @@   , sqlSelectHaving :: [SQL]   , sqlSelectOffset :: Integer   , sqlSelectLimit :: Integer-  , sqlSelectWith :: [(SQL, SQL, Materialized)]+  , sqlSelectWith :: [(SQL, SQL, Materialization)]   , sqlSelectRecursiveWith :: Recursive   } @@ -248,7 +242,7 @@   , sqlUpdateWhere :: [SqlCondition]   , sqlUpdateSet :: [(SQL, SQL)]   , sqlUpdateResult :: [SQL]-  , sqlUpdateWith :: [(SQL, SQL, Materialized)]+  , sqlUpdateWith :: [(SQL, SQL, Materialization)]   , sqlUpdateRecursiveWith :: Recursive   } @@ -257,7 +251,7 @@   , sqlInsertOnConflict :: Maybe (SQL, Maybe SQL)   , sqlInsertSet :: [(SQL, Multiplicity SQL)]   , sqlInsertResult :: [SQL]-  , sqlInsertWith :: [(SQL, SQL, Materialized)]+  , sqlInsertWith :: [(SQL, SQL, Materialization)]   , sqlInsertRecursiveWith :: Recursive   } @@ -274,7 +268,7 @@   , sqlInsertSelectHaving :: [SQL]   , sqlInsertSelectOffset :: Integer   , sqlInsertSelectLimit :: Integer-  , sqlInsertSelectWith :: [(SQL, SQL, Materialized)]+  , sqlInsertSelectWith :: [(SQL, SQL, Materialization)]   , sqlInsertSelectRecursiveWith :: Recursive   } @@ -283,7 +277,7 @@   , sqlDeleteUsing :: SQL   , sqlDeleteWhere :: [SqlCondition]   , sqlDeleteResult :: [SQL]-  , sqlDeleteWith :: [(SQL, SQL, Materialized)]+  , sqlDeleteWith :: [(SQL, SQL, Materialization)]   , sqlDeleteRecursiveWith :: Recursive   } @@ -355,7 +349,7 @@   toSQLCommand cmd =     smconcat       [ emitClausesSepComma (recursiveClause $ sqlSelectRecursiveWith cmd) $-          map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlSelectWith cmd)+          map withClause (sqlSelectWith cmd)       , if hasUnion || hasUnionAll           then emitClausesSep "" unionKeyword (mainSelectClause : unionCmd)           else mainSelectClause@@ -412,7 +406,7 @@   toSQLCommand cmd =     emitClausesSepComma       (recursiveClause $ sqlInsertRecursiveWith cmd)-      (map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlInsertWith cmd))+      (map withClause (sqlInsertWith cmd))       <+> "INSERT INTO"       <+> sqlInsertWhat cmd       <+> parenthesize (sqlConcatComma (map fst (sqlInsertSet cmd)))@@ -433,7 +427,7 @@       -- WITH clause needs to be at the top level, so we emit it here and not       -- include it in the SqlSelect below.       [ emitClausesSepComma (recursiveClause $ sqlInsertSelectRecursiveWith cmd) $-          map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlInsertSelectWith cmd)+          map withClause (sqlInsertSelectWith cmd)       , "INSERT INTO" <+> sqlInsertSelectWhat cmd       , parenthesize . sqlConcatComma . map fst $ sqlInsertSelectSet cmd       , parenthesize . toSQLCommand $@@ -456,27 +450,15 @@       , emitClausesSepComma "RETURNING" $ sqlInsertSelectResult cmd       ] --- This function has to be called as one of first things in your program--- for the library to make sure that it is aware if the "WITH MATERIALIZED"--- clause is supported by your PostgreSQL version.-checkAndRememberMaterializationSupport :: (MonadDB m, MonadIO m, MonadMask m) => m ()-checkAndRememberMaterializationSupport = do-  res :: Either DBException Int64 <- try . withNewConnection $ do-    runSQL01_ "WITH t(n) AS MATERIALIZED (SELECT (1 :: bigint)) SELECT n FROM t LIMIT 1"-    fetchOne runIdentity-  liftIO $ writeIORef withMaterializedSupported (isRight res)--withMaterializedSupported :: IORef Bool-{-# NOINLINE withMaterializedSupported #-}-withMaterializedSupported = unsafePerformIO $ newIORef False--isWithMaterializedSupported :: Bool-{-# NOINLINE isWithMaterializedSupported #-}-isWithMaterializedSupported = unsafePerformIO $ readIORef withMaterializedSupported--materializedClause :: Materialized -> SQL-materializedClause Materialized = if isWithMaterializedSupported then "MATERIALIZED" else ""-materializedClause NonMaterialized = if isWithMaterializedSupported then "NOT MATERIALIZED" else ""+withClause :: (SQL, SQL, Materialization) -> SQL+withClause (name, command, materialization) =+  name <+> "AS" <+> materializationClause <+> parenthesize command+  where+    materializationClause :: SQL+    materializationClause = case materialization of+      DefaultMaterialization -> ""+      Materialized -> "MATERIALIZED"+      NotMaterialized -> "NOT MATERIALIZED"  recursiveClause :: Recursive -> SQL recursiveClause Recursive = "WITH RECURSIVE"@@ -486,7 +468,7 @@   toSQLCommand cmd =     emitClausesSepComma       (recursiveClause $ sqlUpdateRecursiveWith cmd)-      (map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlUpdateWith cmd))+      (map withClause (sqlUpdateWith cmd))       <+> "UPDATE"       <+> sqlUpdateWhat cmd       <+> "SET"@@ -499,7 +481,7 @@   toSQLCommand cmd =     emitClausesSepComma       (recursiveClause $ sqlDeleteRecursiveWith cmd)-      (map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlDeleteWith cmd))+      (map withClause (sqlDeleteWith cmd))       <+> "DELETE FROM"       <+> sqlDeleteFrom cmd       <+> emitClause "USING" (sqlDeleteUsing cmd)@@ -570,7 +552,7 @@         }     ) -data Materialized = Materialized | NonMaterialized+data Materialization = DefaultMaterialization | Materialized | NotMaterialized data Recursive = Recursive | NonRecursive  -- This instance guarantees that once a single CTE has@@ -582,7 +564,7 @@   _ <> _ = NonRecursive  class SqlWith a where-  sqlWith1 :: a -> SQL -> SQL -> Materialized -> Recursive -> a+  sqlWith1 :: a -> SQL -> SQL -> Materialization -> Recursive -> a  instance SqlWith SqlSelect where   sqlWith1 cmd name sql mat recurse = cmd {sqlSelectWith = sqlSelectWith cmd ++ [(name, sql, mat)], sqlSelectRecursiveWith = recurse <> sqlSelectRecursiveWith cmd}@@ -596,15 +578,23 @@ instance SqlWith SqlDelete where   sqlWith1 cmd name sql mat recurse = cmd {sqlDeleteWith = sqlDeleteWith cmd ++ [(name, sql, mat)], sqlDeleteRecursiveWith = recurse <> sqlDeleteRecursiveWith cmd} +-- | Add a @WITH@ clause and let PostgreSQL decide whether to materialize it. sqlWith :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m ()-sqlWith name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) NonMaterialized NonRecursive)+sqlWith name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) DefaultMaterialization NonRecursive) +-- | Add a @WITH ... AS MATERIALIZED@ clause. sqlWithMaterialized :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m () sqlWithMaterialized name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) Materialized NonRecursive) +-- | Add a @WITH ... AS NOT MATERIALIZED@ clause.+--+-- @since 1.21.0.0+sqlWithNotMaterialized :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m ()+sqlWithNotMaterialized name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) NotMaterialized NonRecursive)+ -- | Note: RECURSIVE only powers SELECTs (but the SELECT can feed an UPDATE outside of the recursive query). sqlWithRecursive :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m ()-sqlWithRecursive name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) NonMaterialized Recursive)+sqlWithRecursive name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) DefaultMaterialization Recursive)  -- | Note: WHERE clause of the main SELECT is treated specially, i.e. it only -- applies to the main SELECT, not the whole union.

@@ -5,8 +5,6 @@   , overNubList   ) where -import Data.Typeable- import Data.Semigroup qualified as SG import Data.Set qualified as Set import Text.Read qualified as R@@ -21,7 +19,7 @@ -- | NubList : A de-duplicated list that maintains the original order. newtype NubList a   = NubList {fromNubList :: [a]}-  deriving (Eq, Typeable)+  deriving (Eq)  -- NubList assumes that nub retains the list order while removing duplicate -- elements (keeping the first occurence). Documentation for "Data.List.nub"

@@ -28,7 +28,6 @@ import Test.Tasty.Options  newtype ConnectionString = ConnectionString String-  deriving (Typeable)  instance IsOption ConnectionString where   defaultValue =@@ -1617,11 +1616,6 @@ testSqlWith step = do   step "Running sql WITH tests"   testPass-  runSQL_ "DELETE FROM bank"-  step "Checking for WITH MATERIALIZED support"-  checkAndRememberMaterializationSupport-  step "Running sql WITH tests again with WITH MATERIALIZED support flag set"-  testPass   where     migrate tables migrations = do       let definitions = tableDefsWithPgCrypto tables@@ -1644,9 +1638,9 @@         sqlFrom "bank_name"         sqlSetCmd "name" "bank_name"         sqlSet "location" ("Other side" :: T.Text)-      step "testing WITH .. UPDATE"+      step "testing WITH MATERIALIZED .. UPDATE"       runQuery_ . sqlUpdate "bank" $ do-        sqlWith "other_bank" $ do+        sqlWithMaterialized "other_bank" $ do           sqlSelect "bank" $ do             sqlWhereEq "name" ("other" :: T.Text)             sqlResult "id"@@ -1654,9 +1648,9 @@         sqlSet "location" ("abcd" :: T.Text)         sqlWhereInSql "bank.id" $ mkSQL "other_bank.id"         sqlResult "bank.id"-      step "testing WITH .. DELETE"+      step "testing WITH NOT MATERIALIZED .. DELETE"       runQuery_ . sqlDelete "bank" $ do-        sqlWith "other_bank" $ do+        sqlWithNotMaterialized "other_bank" $ do           sqlSelect "bank" $ do             sqlWhereEq "name" ("other" :: T.Text)             sqlResult "id"