diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,14 @@ ## [Unreleased] +## [0.2.0.0] - 22.09.2026 + +### Changed +- Support `bluefin` versions `0.2.7 && < 0.6` in [#4](https://github.com/fpringle/bluefin-postgresql/pull/4). +- Extract common operation counting code to [postgresql-operation-counting](https://github.com/fpringle/postgresql-operation-counting) in [#6](https://github.com/fpringle/bluefin-postgresql/pull/6). Breaking change. +- Support `bluefin < 0.11` in [#8](https://github.com/fpringle/bluefin-postgresql/pull/8). +- Fix `Bluefin.Opaleye.Count` module docs in [#9](https://github.com/fpringle/bluefin-postgresql/pull/9). + ## [0.1.0.0] - 27.02.2026 ### Added @@ -16,5 +24,6 @@ - Reasonably detailed READMEs. - CI that builds and tests the packages for each version of GHC in the `tested-with` field. -[unreleased]: https://github.com/fpringle/bluefin-postgresql/compare/bluefin-opaleye-0.1.0.0...HEAD +[unreleased]: https://github.com/fpringle/bluefin-postgresql/compare/bluefin-opaleye-0.2.0.0...HEAD +[0.2.0.0]: https://github.com/fpringle/bluefin-postgresql/compare/bluefin-opaleye-0.1.0.0...bluefin-opaleye-0.2.0.0 [0.1.0.0]: https://github.com/fpringle/bluefin-postgresql/releases/tag/bluefin-opaleye-0.1.0.0 diff --git a/bluefin-opaleye.cabal b/bluefin-opaleye.cabal --- a/bluefin-opaleye.cabal +++ b/bluefin-opaleye.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: bluefin-opaleye -version: 0.1.0.0 +version: 0.2.0.0 synopsis: bluefin support for high-level PostgreSQL operations via Opaleye. description: @@ -17,11 +17,9 @@ CHANGELOG.md tested-with: - GHC == 8.10.7 - , GHC == 9.0.2 + GHC == 9.0.2 , GHC == 9.2.4 , GHC == 9.2.8 - , GHC == 9.4.2 , GHC == 9.4.5 , GHC == 9.6.1 , GHC == 9.6.7 @@ -34,14 +32,14 @@ common deps build-depends: , base >= 4 && < 5 - , bluefin >= 0.0.11 && < 0.0.18 + , bluefin >= 0.2.7 && < 0.11 , opaleye >= 0.9 && < 0.11 , product-profunctors >= 0.9 && < 0.12 - , bluefin-postgresql >= 0.1 && < 0.2 + , bluefin-postgresql >= 0.1 && < 0.3 , postgresql-simple >= 0.7 && < 0.8 , text >= 2.0 && < 2.2 , containers >= 0.6 && < 0.8 - , pretty >= 1.1.1.0 && < 1.2 + , postgresql-operation-counting >= 0.1 && < 0.2 common extensions default-extensions: diff --git a/src/Bluefin/Opaleye/Count.hs b/src/Bluefin/Opaleye/Count.hs --- a/src/Bluefin/Opaleye/Count.hs +++ b/src/Bluefin/Opaleye/Count.hs @@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} {- | Thanks to our dynamic 'Opaleye' effect, we can write an alternative interpreter which, as well as performing SQL operations as before, will also keep a tally of the number of @@ -19,13 +17,13 @@ A very naive implementation might be: @ -insertUsersNaive :: ('Opaleye' :> es) => [User] -> Eff es () -insertUsersNaive users = for_ users $ \user -> do - insertUserFlat user +insertUsersNaive :: (e :> es) => 'Opaleye' e -> [User] -> Eff es () +insertUsersNaive o users = for_ users $ \user -> do + insertUserFlat o user for (transactions user) $ \transaction -> do - insertTransactionFlat transaction + insertTransactionFlat o transaction for (subTransactions transaction) $ \subTransaction -> do - insertSubTransactionFlat subTransaction + insertSubTransactionFlat o subTransaction @ However, if we ran a "benchmark" that looked something like this: @@ -35,13 +33,23 @@ u1 = [User {transactions = [Transaction [SubTransaction]]}] -- one user, one transaction, one sub-transaction u5 = ... -- five users, each with five transactions, each with 5 sub-transactions -benchmark :: ('Opaleye' :> es, State SQLOperationCounts :> es, IOE :> es) => Eff es () -benchmark = for_ [(1, u1), (5, u5), (10, u10), (50, u50)] $ \(n, users) -> do - (counts, ()) <- withCounts $ insertUsersNaive users - liftIO . putStrLn $ "Counts at n=" <> show n <> ": " <> 'renderCountsBrief' counts +benchmark :: + (e :> es, e1 :> es, e2 :> es) => + 'Opaleye' e -> + State SQLOperationCounts e1 -> + IOE e2 -> + Eff es () +benchmark o st ioe = for_ [(1, u1), (5, u5), (10, u10), (50, u50)] $ \(n, users) -> do + (counts, ()) <- withCounts st $ insertUsersNaive o users + effIO ioe . putStrLn $ "Counts at n=" <> show n <> ": " <> 'renderCountsBrief' counts main :: IO () -main = runEff . 'Conn.runWithConnectInfo' connInfo . evalState @SQLOperationCounts mempty . runOpaleyeWithConnectionCounting $ benchmark +main = + runEff $ \ioe -> + 'Conn.runWithConnectInfo' ioe connInfo $ \withConn -> + evalState @SQLOperationCounts mempty $ \st -> + runOpaleyeWithConnectionCounting withConn ioe st $ \o -> + benchmark o st ioe where connInfo = ... @ @@ -58,13 +66,13 @@ This is obviously going to have a severe performance impact. Rearranging our implementation of @insertUsers@: @ -insertUsersBetter :: ('Opaleye' :> es) => [User] -> Eff es () -insertUsersBetter users = do +insertUsersBetter :: (e :> es) => 'Opaleye' e -> [User] -> Eff es () +insertUsersBetter o users = do let transactions_ = concatMap transactions users subTransactions_ = concatMap subTransactions transactions_ - insertUsersFlat users - insertTransactionsFlat transactions_ - insertSubTransactionsFlat subTransactions_ + insertUsersFlat o users + insertTransactionsFlat o transactions_ + insertSubTransactionsFlat o subTransactions_ @ As long as @insertTransactionsFlat@ etc are smart enough to only do one 'runInsert', then we should now get: @@ -96,17 +104,9 @@ -} module Bluefin.Opaleye.Count ( -- * Counting SQL operations - SQLOperationCounts (..) - , opaleyeAddCounting + opaleyeAddCounting , withCounts - - -- * Pretty-printing - , printCounts - , printCountsBrief - , renderCounts - , renderCountsBrief - , prettyCounts - , prettyCountsBrief + , module PostgreSQL.Count ) where @@ -114,56 +114,18 @@ import Bluefin.Eff import Bluefin.Opaleye.Effect import Bluefin.State -import Control.Monad.IO.Class -import qualified Data.List.NonEmpty as NE import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (catMaybes, mapMaybe) import qualified Data.Text as T -import Database.PostgreSQL.Simple.Types (QualifiedIdentifier (..)) -import GHC.Generics import Numeric.Natural import qualified Opaleye as O import qualified Opaleye.Internal.PrimQuery as O (TableIdentifier (..)) import qualified Opaleye.Internal.Table as O -import qualified Text.PrettyPrint as P -import qualified Text.PrettyPrint.HughesPJClass as P +import PostgreSQL.Count ------------------------------------------------------------ -- Tallying SQL operations -{- | This tracks the number of SQL operations that have been performed in the -'Opaleye' effect, along with which table it was performed on (where possible). - -@INSERT@, @DELETE@ and @UPDATE@ operations act on one table only, so we can tally the number -of each that are performed on each table (indexed by a t'QualifiedIdentifier'). -@SELECT@ operations can act on multiple tables, so we just track the total number of selects. - -If required, t'SQLOperationCounts' can be constructed using 'Monoid' and combined using 'Semigroup'. - -We use non-negative 'Natural's as a tally since a negative number of operations makes no sense. --} -data SQLOperationCounts = SQLOperationCounts - { sqlSelects :: Natural - , sqlInserts :: Map QualifiedIdentifier Natural - , sqlDeletes :: Map QualifiedIdentifier Natural - , sqlUpdates :: Map QualifiedIdentifier Natural - } - deriving (Show, Eq, Generic) - -instance Semigroup SQLOperationCounts where - SQLOperationCounts s1 i1 d1 u1 <> SQLOperationCounts s2 i2 d2 u2 = - SQLOperationCounts - (s1 + s2) - (i1 `addNatMaps` i2) - (d1 `addNatMaps` d2) - (u1 `addNatMaps` u2) - where - addNatMaps = Map.unionWith (+) - -instance Monoid SQLOperationCounts where - mempty = SQLOperationCounts 0 mempty mempty mempty - {- | Add counting of SQL operations to the interpreter of an 'Opaleye' effect. Note that the effect itself is not actually interpreted. After updating our t'SQLOperationCounts' state based on the 'Opaleye' constructor, we then pass them @@ -208,19 +170,19 @@ incrementSelect = modify st $ \counts -> counts {sqlSelects = succ $ sqlSelects counts} - incrementInsert :: QualifiedIdentifier -> Eff (e :& es) () + incrementInsert :: TableName -> Eff (e :& es) () incrementInsert name = modify st $ \counts -> counts {sqlInserts = incrementMap name $ sqlInserts counts} - incrementUpdate :: QualifiedIdentifier -> Eff (e :& es) () + incrementUpdate :: TableName -> Eff (e :& es) () incrementUpdate name = modify st $ \counts -> counts {sqlUpdates = incrementMap name $ sqlUpdates counts} - incrementDelete :: QualifiedIdentifier -> Eff (e :& es) () + incrementDelete :: TableName -> Eff (e :& es) () incrementDelete name = modify st $ \counts -> counts {sqlDeletes = incrementMap name $ sqlDeletes counts} - incrementMap :: QualifiedIdentifier -> Map QualifiedIdentifier Natural -> Map QualifiedIdentifier Natural + incrementMap :: TableName -> Map TableName Natural -> Map TableName Natural incrementMap = Map.alter (Just . maybe 1 succ) -- | This allows us to count the number of SQL operations over the course of a sub-operation. @@ -235,122 +197,21 @@ countsAfter <- get st pure (countsAfter `subtractCounts` countsBefore, res) -subtractNat :: Natural -> Natural -> Natural -a `subtractNat` b = if a > b then a - b else 0 - -subtractNatMaps :: (Ord k) => Map k Natural -> Map k Natural -> Map k Natural -subtractNatMaps c1 c2 = - let f op count = Map.adjust (`subtractNat` count) op - in Map.foldrWithKey f c1 c2 - -subtractCounts :: SQLOperationCounts -> SQLOperationCounts -> SQLOperationCounts -subtractCounts (SQLOperationCounts s1 i1 d1 u1) (SQLOperationCounts s2 i2 d2 u2) = - SQLOperationCounts - (s1 `subtractNat` s2) - (i1 `subtractNatMaps` i2) - (d1 `subtractNatMaps` d2) - (u1 `subtractNatMaps` u2) - ------------------------------------------------------------ -- Getting table identifiers from opaleye operations -tableIdentifierToQualifiedIdentifier :: O.TableIdentifier -> QualifiedIdentifier -tableIdentifierToQualifiedIdentifier (O.TableIdentifier mSchema table) = - QualifiedIdentifier (T.pack <$> mSchema) (T.pack table) +tableIdentifierToTableName :: O.TableIdentifier -> TableName +tableIdentifierToTableName (O.TableIdentifier mSchema table) = + TableName (T.pack <$> mSchema) (T.pack table) -insertTableName :: O.Insert haskells -> QualifiedIdentifier +insertTableName :: O.Insert haskells -> TableName insertTableName (O.Insert table _ _ _) = - tableIdentifierToQualifiedIdentifier . O.tableIdentifier $ table + tableIdentifierToTableName . O.tableIdentifier $ table -updateTableName :: O.Update haskells -> QualifiedIdentifier +updateTableName :: O.Update haskells -> TableName updateTableName (O.Update table _ _ _) = - tableIdentifierToQualifiedIdentifier . O.tableIdentifier $ table + tableIdentifierToTableName . O.tableIdentifier $ table -deleteTableName :: O.Delete haskells -> QualifiedIdentifier +deleteTableName :: O.Delete haskells -> TableName deleteTableName (O.Delete table _ _) = - tableIdentifierToQualifiedIdentifier . O.tableIdentifier $ table - ------------------------------------------------------------- --- Pretty rendering and printing counts - -instance P.Pretty SQLOperationCounts where - pPrint = prettyCounts - -{- | Print an t'SQLOperationCounts' to stdout using 'prettyCounts'. -For less verbose output, see 'printCountsBrief'. --} -printCounts :: (MonadIO m) => SQLOperationCounts -> m () -printCounts = liftIO . putStrLn . renderCounts - -{- | Print an t'SQLOperationCounts' to stdout using 'prettyCountsBrief'. -For more verbose output, see 'printCounts'. --} -printCountsBrief :: (MonadIO m) => SQLOperationCounts -> m () -printCountsBrief = liftIO . putStrLn . renderCountsBrief - -{- | Render an t'SQLOperationCounts' using 'prettyCounts'. -For less verbose output, see 'renderCountsBrief'. - -For more control over how the 'P.Doc' gets rendered, use 'P.renderStyle' with a custom 'P.style'. --} -renderCounts :: SQLOperationCounts -> String -renderCounts = P.render . prettyCounts - -{- | Render an t'SQLOperationCounts' using 'prettyCountsBrief'. -For more verbose output, see 'renderCounts'. - -For more control over how the 'P.Doc' gets rendered, use 'P.renderStyle' with a custom 'P.style'. --} -renderCountsBrief :: SQLOperationCounts -> String -renderCountsBrief = P.render . prettyCountsBrief - -{- | Pretty-print an t'SQLOperationCounts' using "Text.PrettyPrint". -For each 'Map', we'll print one line for each table. For less verbose output, -see 'prettyCountsBrief'. - -This is also the implementation of 'P.pPrint' for t'SQLOperationCounts'. --} -prettyCounts :: SQLOperationCounts -> P.Doc -prettyCounts = prettyCountsWith $ \mp -> - let counts = Map.toList mp - renderPair (name, count) = prefix (renderTableName name) <$> renderNat count - in fmap (P.vcat . NE.toList) . NE.nonEmpty $ mapMaybe renderPair counts - -{- | Pretty-print an t'SQLOperationCounts' using "Text.PrettyPrint". -For each 'Map', we'll print just the sum of the counts. For more verbose output, -see 'prettyCounts'. --} -prettyCountsBrief :: SQLOperationCounts -> P.Doc -prettyCountsBrief = prettyCountsWith $ \mp -> - let total = sum $ Map.elems mp - in renderNat total - -prettyCountsWith :: (Map QualifiedIdentifier Natural -> Maybe P.Doc) -> SQLOperationCounts -> P.Doc -prettyCountsWith renderMap (SQLOperationCounts selects inserts deletes updates) = - let parts = - catMaybes - [ prefix "SELECT" <$> renderNat selects - , prefix "INSERT" <$> renderMap inserts - , prefix "UPDATE" <$> renderMap updates - , prefix "DELETE" <$> renderMap deletes - ] - in case parts of - [] -> "None" - _ -> P.vcat parts - -prefix :: P.Doc -> P.Doc -> P.Doc -prefix t n = t P.<> ":" P.<+> n - -renderNat :: Natural -> Maybe P.Doc -renderNat = \case - 0 -> Nothing - n -> Just $ P.pPrint @Integer $ toInteger n - -renderTableName :: QualifiedIdentifier -> P.Doc -renderTableName (QualifiedIdentifier mSchema table) = - case mSchema of - Nothing -> renderText table - Just schema -> renderText schema <> "." <> renderText table - -renderText :: T.Text -> P.Doc -renderText = P.text . T.unpack + tableIdentifierToTableName . O.tableIdentifier $ table diff --git a/src/Bluefin/Opaleye/Effect.hs b/src/Bluefin/Opaleye/Effect.hs --- a/src/Bluefin/Opaleye/Effect.hs +++ b/src/Bluefin/Opaleye/Effect.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE MultiParamTypeClasses #-} + module Bluefin.Opaleye.Effect ( -- * Effect Opaleye (..) @@ -38,16 +41,20 @@ , runUpdateImpl :: forall e' haskells. O.Update haskells -> Eff (e' :& e) haskells -- ^ Lifted 'O.RunUpdate'. } + deriving (Handle) via OneWayCoercibleHandle Opaleye -instance Handle Opaleye where - mapHandle h = - MkOpaleye - { runSelectExplicitImpl = \ff sel -> useImplUnder (runSelectExplicitImpl h ff sel) - , runSelectFoldExplicitImpl = \ff sel b f -> useImplUnder (runSelectFoldExplicitImpl h ff sel b f) - , runInsertImpl = useImplUnder . runInsertImpl h - , runDeleteImpl = useImplUnder . runDeleteImpl h - , runUpdateImpl = useImplUnder . runUpdateImpl h - } +mapHandleOpaleye :: (e :> es) => Opaleye e -> Opaleye es +mapHandleOpaleye h = + MkOpaleye + { runSelectExplicitImpl = \ff sel -> useImplUnder (runSelectExplicitImpl h ff sel) + , runSelectFoldExplicitImpl = \ff sel b f -> useImplUnder (runSelectFoldExplicitImpl h ff sel b f) + , runInsertImpl = useImplUnder . runInsertImpl h + , runDeleteImpl = useImplUnder . runDeleteImpl h + , runUpdateImpl = useImplUnder . runUpdateImpl h + } + +instance (e :> es) => OneWayCoercible (Opaleye e) (Opaleye es) where + oneWayCoercibleImpl = oneWayCoercibleTrustMe mapHandleOpaleye -- | Lifted 'O.RunSelectExplicit'. runSelectExplicit ::