bluefin-opaleye (empty) → 0.1.0.0
raw patch · 7 files changed
+774/−0 lines, 7 filesdep +basedep +bluefindep +bluefin-postgresql
Dependencies added: base, bluefin, bluefin-postgresql, containers, opaleye, postgresql-simple, pretty, product-profunctors, text
Files
- CHANGELOG.md +20/−0
- LICENSE +30/−0
- README.md +49/−0
- bluefin-opaleye.cabal +69/−0
- src/Bluefin/Opaleye.hs +156/−0
- src/Bluefin/Opaleye/Count.hs +356/−0
- src/Bluefin/Opaleye/Effect.hs +94/−0
+ CHANGELOG.md view
@@ -0,0 +1,20 @@+# Changelog++All notable changes to `bluefin-opaleye` will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),+and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org).++## [Unreleased]++## [0.1.0.0] - 27.02.2026++### Added++- First edition of the package, ready for feedback.+- 100% documentation coverage.+- 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+[0.1.0.0]: https://github.com/fpringle/bluefin-postgresql/releases/tag/bluefin-opaleye-0.1.0.0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2025, Frederick Pringle++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Frederick Pringle nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,49 @@+# bluefin-opaleye++This package provides a `bluefin` effect for [Opaleye](https://hackage.haskell.org/package/opaleye) operations.++It combines the very safe, high-level syntax of Opaleye, with the `WithConnection` abstraction of [bluefin-postgresql](https://github.com/fpringle/bluefin-postgresql/blob/main/bluefin-postgresql#readme).++## Effectful functions++In the `Opaleye` effect we can perform the 4 main operations permitted by Opaleye: query, insert, delete, and update.++```haskell+{-# LANGUAGE Arrows #-}+import Control.Arrow+import Bluefin.Opaleye as BO+import qualified Opaleye as O++insertAndList :: (e :> es) => Opaleye e -> Eff es [User]+insertAndList o = do+ BO.runInsert o $ O.Insert userTable [User {firstName = "Nuala"}] O.rCount Nothing++ BO.runDelete o $ O.Delete userTable isAdmin O.rCount++ BO.runUpdate o $ O.Update userTable (\user -> user {updatedAt = O.now}) isAdmin O.rCount++ BO.runSelect o $ proc () -> do+ user <- O.selectTable userTable -< ()+ O.restrict -< firstName user `O.in_` (O.toFields <$> ["Anna", "Boris", "Carla"])+ returnA -< user+```++## Interpreters++To run the `Opaleye` effect we can use the `WithConnection` effect from [bluefin-postgresql](https://github.com/fpringle/bluefin-postgresql/blob/main/bluefin-postgresql#readme):++```haskell+import Bluefin.Opaleye as BO++doOpaleyeStuff :: (e :> es) => WithConnection e -> IOE e -> Eff es [User]+doOpaleyeStuff wc ioe =+ BO.runOpaleyeWithConnection wc ioe $ \o -> insertAndList o+```++The `WithConnection` effect can then be dispatched using one of its [interpreters](https://github.com/fpringle/bluefin-postgresql/blob/main/bluefin-postgresql#interpreters).+Or, to skip that entirely, we can just use `runOpaleyeConnection`:++```haskell+doOpaleyeStuff :: (e :> es) => IOE e -> PSQL.Connection -> Eff es [User]+doOpaleyeStuff ioe conn = BO.runOpaleyeConnection ioe conn insertAndList+```
+ bluefin-opaleye.cabal view
@@ -0,0 +1,69 @@+cabal-version: 3.0+name: bluefin-opaleye+version: 0.1.0.0+synopsis:+ bluefin support for high-level PostgreSQL operations via Opaleye.+description:+ See the README for an overview, or the documentation in 'Bluefin.Opaleye'.+license: BSD-3-Clause+license-file: LICENSE+author: Frederick Pringle+maintainer: frederick.pringle@fpringle.com+copyright: Copyright(c) Frederick Pringle 2025+homepage: https://github.com/fpringle/bluefin-postgresql+build-type: Simple+category: Database+extra-doc-files: README.md+ CHANGELOG.md++tested-with:+ GHC == 8.10.7+ , 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+ , GHC == 9.8.2+ , GHC == 9.10.2++common warnings+ ghc-options: -Wall -Wno-unused-do-bind -Wunused-packages++common deps+ build-depends:+ , base >= 4 && < 5+ , bluefin >= 0.0.11 && < 0.0.18+ , opaleye >= 0.9 && < 0.11+ , product-profunctors >= 0.9 && < 0.12+ , bluefin-postgresql >= 0.1 && < 0.2+ , postgresql-simple >= 0.7 && < 0.8+ , text >= 2.0 && < 2.2+ , containers >= 0.6 && < 0.8+ , pretty >= 1.1.1.0 && < 1.2++common extensions+ default-extensions:+ DataKinds+ FlexibleContexts+ GADTs+ LambdaCase+ RankNTypes+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators++library+ import:+ warnings+ , deps+ , extensions+ exposed-modules:+ Bluefin.Opaleye+ Bluefin.Opaleye.Effect+ Bluefin.Opaleye.Count+ -- other-extensions:+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Bluefin/Opaleye.hs view
@@ -0,0 +1,156 @@+module Bluefin.Opaleye+ ( -- * Effect+ Opaleye++ -- * Effectful functions++ -- ** Select+ , runSelect+ , runSelectI+ , runSelectExplicit++ -- ** Select-fold+ , runSelectFold+ , runSelectFoldExplicit++ -- ** Insert+ , runInsert++ -- ** Delete+ , runDelete++ -- ** Update+ , runUpdate++ -- * Interpreters+ , runOpaleyeWithConnection+ , runOpaleyeWithConnectionCounting+ , runOpaleyeConnection+ , runOpaleyeConnectionCounting++ -- * Counting SQL operations+ , SQLOperationCounts (..)+ , withCounts+ , printCounts+ )+where++import Bluefin.Compound+import Bluefin.Eff+import Bluefin.IO+import Bluefin.Opaleye.Count+import Bluefin.Opaleye.Effect+import qualified Bluefin.PostgreSQL.Connection as Conn+import Bluefin.State+import Data.Profunctor.Product.Default+import qualified Database.PostgreSQL.Simple as PSQL+import GHC.Stack+import qualified Opaleye as O+import qualified Opaleye.Internal.Inferrable as O++-- | Lifted 'O.runSelect'.+runSelect ::+ (HasCallStack, e :> es, Default O.FromFields fields haskells) =>+ Opaleye e ->+ O.Select fields ->+ Eff es [haskells]+runSelect o = runSelectExplicit o def++-- | Lifted 'O.runSelectFold'.+runSelectFold ::+ (HasCallStack, e :> es, Default O.FromFields fields haskells) =>+ Opaleye e ->+ O.Select fields ->+ b ->+ (b -> haskells -> Eff es b) ->+ Eff es b+runSelectFold o = runSelectFoldExplicit o def++-- | Lifted 'O.runSelectI'.+runSelectI ::+ (HasCallStack, e :> es, Default (O.Inferrable O.FromFields) fields haskells) =>+ Opaleye e ->+ O.Select fields ->+ Eff es [haskells]+runSelectI o = runSelectExplicit o (O.runInferrable def)++{- | Interpret the 'Opaleye' effect using 'Conn.WithConnection' from+[bluefin-postgresql](https://hackage.haskell.org/package/bluefin-postgresql).++If you don't want to use 'Conn.WithConnection', see 'runOpaleyeConnection'.+-}+runOpaleyeWithConnection ::+ (HasCallStack, e1 :> es, e2 :> es) =>+ Conn.WithConnection e1 ->+ IOE e2 ->+ (forall e. Opaleye e -> Eff (e :& es) a) ->+ Eff es a+runOpaleyeWithConnection wc ioe k =+ useImplIn+ k+ MkOpaleye+ { runSelectExplicitImpl = \ff sel ->+ Conn.withConnection wc $ \conn -> effIO ioe $ O.runSelectExplicit ff conn sel+ , runSelectFoldExplicitImpl = \ff sel initial foldFn ->+ Conn.withConnection wc $ \conn ->+ withEffToIO_ ioe $ \unlift ->+ O.runSelectFoldExplicit ff conn sel initial $ \acc new ->+ unlift $ useImpl $ foldFn acc new+ , runInsertImpl = \sel ->+ Conn.withConnection wc $ \conn -> effIO ioe $ O.runInsert conn sel+ , runDeleteImpl = \sel ->+ Conn.withConnection wc $ \conn -> effIO ioe $ O.runDelete conn sel+ , runUpdateImpl = \sel ->+ Conn.withConnection wc $ \conn -> effIO ioe $ O.runUpdate conn sel+ }++-- | Interpret the 'Opaleye' effect by simply supplying a 'PSQL.Connection'+runOpaleyeConnection ::+ (HasCallStack, e1 :> es) =>+ IOE e1 ->+ PSQL.Connection ->+ (forall e. Opaleye e -> Eff (e :& es) a) ->+ Eff es a+runOpaleyeConnection ioe conn k =+ useImplIn+ k+ MkOpaleye+ { runSelectExplicitImpl = \ff sel -> effIO ioe $ O.runSelectExplicit ff conn sel+ , runSelectFoldExplicitImpl = \ff sel initial foldFn ->+ withEffToIO_ ioe $ \unlift ->+ O.runSelectFoldExplicit ff conn sel initial $+ \acc new -> unlift $ useImpl $ foldFn acc new+ , runInsertImpl = effIO ioe . O.runInsert conn+ , runDeleteImpl = effIO ioe . O.runDelete conn+ , runUpdateImpl = effIO ioe . O.runUpdate conn+ }++{- | Same as 'runOpaleyeWithConnection', but we track the number of SQL operations that+we perform.+-}+runOpaleyeWithConnectionCounting ::+ (HasCallStack, e1 :> es, e2 :> es, e3 :> es) =>+ Conn.WithConnection e1 ->+ IOE e2 ->+ State SQLOperationCounts e3 ->+ (forall e. Opaleye e -> Eff (e :& es) a) ->+ Eff es a+runOpaleyeWithConnectionCounting wc ioe st k =+ runOpaleyeWithConnection wc ioe $ \o1 ->+ opaleyeAddCounting st o1 $ \o2 ->+ useImplUnder (k o2)++{- | Same as 'runOpaleyeConnection', but we track the number of SQL operations that+we perform.+-}+runOpaleyeConnectionCounting ::+ (HasCallStack, e1 :> es, e2 :> es) =>+ IOE e1 ->+ PSQL.Connection ->+ State SQLOperationCounts e2 ->+ (forall e. Opaleye e -> Eff (e :& es) a) ->+ Eff es a+runOpaleyeConnectionCounting ioe conn st k =+ runOpaleyeConnection ioe conn $ \o1 ->+ opaleyeAddCounting st o1 $ \o2 ->+ useImplUnder (k o2)
+ src/Bluefin/Opaleye/Count.hs view
@@ -0,0 +1,356 @@+{-# 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+SQL operations (SELECTs, INSERTs etc) that have been performed. This is really useful for debugging.++The intended use-case is a sort of benchmark that runs several Opaleye operations for different+"sizes", counts the SQL operations, and prints the tallies to the console. This lets us detect if+some datbase operations are ineffecient.++For example, suppose our model has users with @UserId@s; those users an have multiple @Transaction@s, which+are composed of multiple @SubTransaction@s etc.+To insert a group of new users, we would need to insert the users, insert the transactions, and insert the subtransactions.+Ideally, the number of @INSERT@s should not depend on the number of @User@s or the number or size of their @Transactions@.+We would expect the number of SELECTs to remain basically constant (O(1)), while the execution time might grow linearly (O(u * t * s)).++A very naive implementation might be:++@+insertUsersNaive :: ('Opaleye' :> es) => [User] -> Eff es ()+insertUsersNaive users = for_ users $ \user -> do+ insertUserFlat user+ for (transactions user) $ \transaction -> do+ insertTransactionFlat transaction+ for (subTransactions transaction) $ \subTransaction -> do+ insertSubTransactionFlat subTransaction+@++However, if we ran a "benchmark" that looked something like this:++@+u1, u5, u10, u50 :: [User]+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++main :: IO ()+main = runEff . 'Conn.runWithConnectInfo' connInfo . evalState @SQLOperationCounts mempty . runOpaleyeWithConnectionCounting $ benchmark+ where+ connInfo = ...+@++We will probably see something like:++@+Counts at n=1: INSERT: 3+Counts at n=5: INSERT: 155+Counts at n=10: INSERT: 1110+Counts at n=50: INSERT: 127550+@++This is obviously going to have a severe performance impact. Rearranging our implementation of @insertUsers@:++@+insertUsersBetter :: ('Opaleye' :> es) => [User] -> Eff es ()+insertUsersBetter users = do+ let transactions_ = concatMap transactions users+ subTransactions_ = concatMap subTransactions transactions_+ insertUsersFlat users+ insertTransactionsFlat transactions_+ insertSubTransactionsFlat subTransactions_+@++As long as @insertTransactionsFlat@ etc are smart enough to only do one 'runInsert', then we should now get:++@+Counts at n=1: INSERT: 3+Counts at n=5: INSERT: 3+Counts at n=10: INSERT: 3+Counts at n=50: INSERT: 3+@++Note that we used 'renderCountsBrief' for simplicity. If we wanted to debug in more detail, we could have used+'renderCounts' instead:++@+Counts at n=1: INSERT: user: 1+ transaction: 1+ sub_transaction: 1+Counts at n=5: INSERT: user: 5+ transaction: 25+ sub_transaction: 125+Counts at n=10: INSERT: user: 10+ transaction: 100+ sub_transaction: 1000+Counts at n=50: INSERT: user: 50+ transaction: 2500+ sub_transaction: 125000+@+-}+module Bluefin.Opaleye.Count+ ( -- * Counting SQL operations+ SQLOperationCounts (..)+ , opaleyeAddCounting+ , withCounts++ -- * Pretty-printing+ , printCounts+ , printCountsBrief+ , renderCounts+ , renderCountsBrief+ , prettyCounts+ , prettyCountsBrief+ )+where++import Bluefin.Compound+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++------------------------------------------------------------+-- 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+through to the upstream handler (e.g. 'Bluefin.Opaleye.runOpaleyeWithConnection' or+'Bluefin.Opaleye.runOpaleyeConnection'). See 'Bluefin.Opaleye.runOpaleyeConnectionCounting'+and 'Bluefin.Opaleye.runOpaleyeWithConnectionCounting' for interpreters that do both.++Note: this function should only be used once, otherwise the operations will be tallied+more than once. Unless you're sure, it's probably better to use+'Bluefin.Opaleye.runOpaleyeConnectionCounting' or+'Bluefin.Opaleye.runOpaleyeWithConnectionCounting'.+-}+opaleyeAddCounting ::+ forall es e1 e2 a.+ (e1 :> es, e2 :> es) =>+ State SQLOperationCounts e1 ->+ Opaleye e2 ->+ (forall e. Opaleye e -> Eff (e :& es) a) ->+ Eff es a+opaleyeAddCounting st oldEffect k =+ useImplIn+ k+ MkOpaleye+ { runSelectExplicitImpl = \ff sel -> do+ incrementSelect+ runSelectExplicit oldEffect ff sel+ , runSelectFoldExplicitImpl = \ff sel b f -> do+ incrementSelect+ runSelectFoldExplicit oldEffect ff sel b (\b' -> useImpl . f b')+ , runInsertImpl = \ins -> do+ incrementInsert $ insertTableName ins+ runInsert oldEffect ins+ , runDeleteImpl = \del -> do+ incrementDelete $ deleteTableName del+ runDeleteImpl (mapHandle oldEffect) del+ , runUpdateImpl = \upd -> do+ incrementUpdate $ updateTableName upd+ runUpdate oldEffect upd+ }+ where+ incrementSelect :: Eff (e :& es) ()+ incrementSelect = modify st $ \counts ->+ counts {sqlSelects = succ $ sqlSelects counts}++ incrementInsert :: QualifiedIdentifier -> Eff (e :& es) ()+ incrementInsert name = modify st $ \counts ->+ counts {sqlInserts = incrementMap name $ sqlInserts counts}++ incrementUpdate :: QualifiedIdentifier -> Eff (e :& es) ()+ incrementUpdate name = modify st $ \counts ->+ counts {sqlUpdates = incrementMap name $ sqlUpdates counts}++ incrementDelete :: QualifiedIdentifier -> Eff (e :& es) ()+ incrementDelete name = modify st $ \counts ->+ counts {sqlDeletes = incrementMap name $ sqlDeletes counts}++ incrementMap :: QualifiedIdentifier -> Map QualifiedIdentifier Natural -> Map QualifiedIdentifier 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.+withCounts ::+ (e :> es) =>+ State SQLOperationCounts e ->+ Eff es a ->+ Eff es (SQLOperationCounts, a)+withCounts st eff = do+ countsBefore <- get st+ res <- eff+ 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)++insertTableName :: O.Insert haskells -> QualifiedIdentifier+insertTableName (O.Insert table _ _ _) =+ tableIdentifierToQualifiedIdentifier . O.tableIdentifier $ table++updateTableName :: O.Update haskells -> QualifiedIdentifier+updateTableName (O.Update table _ _ _) =+ tableIdentifierToQualifiedIdentifier . O.tableIdentifier $ table++deleteTableName :: O.Delete haskells -> QualifiedIdentifier+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
+ src/Bluefin/Opaleye/Effect.hs view
@@ -0,0 +1,94 @@+module Bluefin.Opaleye.Effect+ ( -- * Effect+ Opaleye (..)++ -- ** Effectful functions+ , runSelectExplicit+ , runSelectFoldExplicit+ , runInsert+ , runDelete+ , runUpdate+ )+where++import Bluefin.Compound+import Bluefin.Eff+import qualified Opaleye as O++-- | A dynamic effect to perform @opaleye@ operations.+data Opaleye (e :: Effects) = MkOpaleye+ { runSelectExplicitImpl ::+ forall e' fields haskells.+ O.FromFields fields haskells ->+ O.Select fields ->+ Eff (e' :& e) [haskells]+ -- ^ Lifted 'O.RunSelectExplicit'.+ , runSelectFoldExplicitImpl ::+ forall e' fields haskells b.+ O.FromFields fields haskells ->+ O.Select fields ->+ b ->+ (b -> haskells -> Eff e' b) ->+ Eff (e' :& e) b+ -- ^ Lifted 'O.RunSelectFoldExplicit'.+ , runInsertImpl :: forall e' haskells. O.Insert haskells -> Eff (e' :& e) haskells+ -- ^ Lifted 'O.RunInsert'.+ , runDeleteImpl :: forall e' haskells. O.Delete haskells -> Eff (e' :& e) haskells+ -- ^ Lifted 'O.RunDelete'.+ , runUpdateImpl :: forall e' haskells. O.Update haskells -> Eff (e' :& e) haskells+ -- ^ Lifted 'O.RunUpdate'.+ }++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+ }++-- | Lifted 'O.RunSelectExplicit'.+runSelectExplicit ::+ (e :> es) =>+ Opaleye e ->+ O.FromFields fields haskells ->+ O.Select fields ->+ Eff es [haskells]+runSelectExplicit o ff sel = makeOp (runSelectExplicitImpl (mapHandle o) ff sel)++-- | Lifted 'O.RunSelectFoldExplicit'.+runSelectFoldExplicit ::+ (e :> es) =>+ Opaleye e ->+ O.FromFields fields haskells ->+ O.Select fields ->+ b ->+ (b -> haskells -> Eff es b) ->+ Eff es b+runSelectFoldExplicit o ff sel b f = makeOp (runSelectFoldExplicitImpl (mapHandle o) ff sel b f)++-- | Lifted 'O.RunInsert'.+runInsert ::+ (e :> es) =>+ Opaleye e ->+ O.Insert haskells ->+ Eff es haskells+runInsert o ins = makeOp (runInsertImpl (mapHandle o) ins)++-- | Lifted 'O.RunDelete'.+runDelete ::+ (e :> es) =>+ Opaleye e ->+ O.Delete haskells ->+ Eff es haskells+runDelete o ins = makeOp (runDeleteImpl (mapHandle o) ins)++-- | Lifted 'O.RunUpdate'.+runUpdate ::+ (e :> es) =>+ Opaleye e ->+ O.Update haskells ->+ Eff es haskells+runUpdate o ins = makeOp (runUpdateImpl (mapHandle o) ins)