diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +``` diff --git a/bluefin-opaleye.cabal b/bluefin-opaleye.cabal new file mode 100644 --- /dev/null +++ b/bluefin-opaleye.cabal @@ -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 diff --git a/src/Bluefin/Opaleye.hs b/src/Bluefin/Opaleye.hs new file mode 100644 --- /dev/null +++ b/src/Bluefin/Opaleye.hs @@ -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) diff --git a/src/Bluefin/Opaleye/Count.hs b/src/Bluefin/Opaleye/Count.hs new file mode 100644 --- /dev/null +++ b/src/Bluefin/Opaleye/Count.hs @@ -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 diff --git a/src/Bluefin/Opaleye/Effect.hs b/src/Bluefin/Opaleye/Effect.hs new file mode 100644 --- /dev/null +++ b/src/Bluefin/Opaleye/Effect.hs @@ -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)