From 3a1ce54f0adb231195599142d1c0beaad97d8b8a Mon Sep 17 00:00:00 2001
From: Andrzej Rybczak <arybczak@users.noreply.github.com>
Date: Mon, 18 Dec 2023 14:16:58 +0100
Subject: [PATCH] Attach CallStack to DBException (#68)

* Attach CallStack to DBException

* Major version bump

* lazy callstack
---
 CHANGELOG.md                                  |  3 +
 hpqtypes.cabal                                |  2 +-
 src/Database/PostgreSQL/PQTypes/Class.hs      | 13 ++--
 src/Database/PostgreSQL/PQTypes/Cursor.hs     |  7 +-
 src/Database/PostgreSQL/PQTypes/Fold.hs       | 60 ++++++++++------
 .../PostgreSQL/PQTypes/Internal/Connection.hs | 16 +++--
 .../PostgreSQL/PQTypes/Internal/Exception.hs  |  5 +-
 .../PostgreSQL/PQTypes/Internal/Monad.hs      |  9 +--
 .../PQTypes/Internal/QueryResult.hs           | 71 +++++++++++++------
 .../PostgreSQL/PQTypes/Notification.hs        |  9 +--
 .../PostgreSQL/PQTypes/Transaction.hs         | 19 ++---
 src/Database/PostgreSQL/PQTypes/Utils.hs      | 68 ++++++++++--------
 12 files changed, 179 insertions(+), 103 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 5778823..c537008 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,6 @@
+# hpqtypes-1.12.0.0 (????-??-??)
+* Attach `CallStack` to `DBException`.
+
 # hpqtypes-1.11.1.2 (2023-11-08)
 * Support multihost setups and the `connect_timeout` parameter in the connection
   string.
diff --git a/hpqtypes.cabal b/hpqtypes.cabal
index 2d765b7..5cef3e6 100644
--- a/hpqtypes.cabal
+++ b/hpqtypes.cabal
@@ -1,5 +1,5 @@
 name:                hpqtypes
-version:             1.11.1.2
+version:             1.12.0.0
 synopsis:            Haskell bindings to libpqtypes
 
 description:         Efficient and easy-to-use bindings to (slightly modified)
diff --git a/src/Database/PostgreSQL/PQTypes/Class.hs b/src/Database/PostgreSQL/PQTypes/Class.hs
index d5ce153..fe74e26 100644
--- a/src/Database/PostgreSQL/PQTypes/Class.hs
+++ b/src/Database/PostgreSQL/PQTypes/Class.hs
@@ -5,6 +5,7 @@ module Database.PostgreSQL.PQTypes.Class
 
 import Control.Monad.Trans
 import Control.Monad.Trans.Control
+import GHC.Stack
 
 import Database.PostgreSQL.PQTypes.FromRow
 import Database.PostgreSQL.PQTypes.Internal.Connection
@@ -18,10 +19,10 @@ class (Applicative m, Monad m) => MonadDB m where
   -- for a given connection, only one thread may be executing 'runQuery' at
   -- a given time. If simultaneous call is made from another thread, it
   -- will block until currently running 'runQuery' finishes.
-  runQuery :: IsSQL sql => sql -> m Int
+  runQuery :: (HasCallStack, IsSQL sql) => sql -> m Int
   -- | Similar to 'runQuery', but it prepares and executes a statement under a
   -- given name.
-  runPreparedQuery :: IsSQL sql => QueryName -> sql -> m Int
+  runPreparedQuery :: (HasCallStack, IsSQL sql) => QueryName -> sql -> m Int
   -- | Get last SQL query that was executed.
   getLastQuery :: m SomeSQL
   -- | Subsequent queries in the callback do not alter the result of
@@ -29,7 +30,7 @@ class (Applicative m, Monad m) => MonadDB m where
   withFrozenLastQuery :: m a -> m a
 
   -- | Get current connection statistics.
-  getConnectionStats :: m ConnectionStats
+  getConnectionStats :: HasCallStack => m ConnectionStats
 
   -- | Get current query result.
   getQueryResult :: FromRow row => m (Maybe (QueryResult row))
@@ -76,11 +77,11 @@ instance {-# OVERLAPPABLE #-}
   , MonadTransControl t
   , MonadDB m
   ) => MonadDB (t m) where
-    runQuery = lift . runQuery
-    runPreparedQuery name = lift . runPreparedQuery name
+    runQuery = withFrozenCallStack $ lift . runQuery
+    runPreparedQuery name = withFrozenCallStack $ lift . runPreparedQuery name
     getLastQuery = lift getLastQuery
     withFrozenLastQuery m = controlT $ \run -> withFrozenLastQuery (run m)
-    getConnectionStats = lift getConnectionStats
+    getConnectionStats = withFrozenCallStack $ lift getConnectionStats
     getQueryResult = lift getQueryResult
     clearQueryResult = lift clearQueryResult
     getTransactionSettings = lift getTransactionSettings
diff --git a/src/Database/PostgreSQL/PQTypes/Cursor.hs b/src/Database/PostgreSQL/PQTypes/Cursor.hs
index 0300337..636fda0 100644
--- a/src/Database/PostgreSQL/PQTypes/Cursor.hs
+++ b/src/Database/PostgreSQL/PQTypes/Cursor.hs
@@ -17,6 +17,7 @@ module Database.PostgreSQL.PQTypes.Cursor
 import Control.Monad
 import Control.Monad.Catch
 import Data.String
+import GHC.Stack
 
 import Data.Monoid.Utils
 import Database.PostgreSQL.PQTypes.Class
@@ -98,7 +99,7 @@ cursorQuery (Cursor _ query) = query
 
 -- | Create a cursor from the SQL query and use it within the given context.
 withCursor
-  :: (IsString sql, IsSQL sql, Monoid sql, MonadDB m, MonadMask m)
+  :: (HasCallStack, IsString sql, IsSQL sql, Monoid sql, MonadDB m, MonadMask m)
   => CursorName sql
   -> Scroll
   -> Hold
@@ -149,7 +150,7 @@ withCursorSQL = withCursor
 -- | Retrieve rows from a query using a cursor. See
 -- https://www.postgresql.org/docs/current/sql-fetch.html for more information.
 cursorFetch
-  :: (IsSQL sql, IsString sql, Monoid sql, MonadDB m)
+  :: (HasCallStack, IsSQL sql, IsString sql, Monoid sql, MonadDB m)
   => Cursor sql
   -> CursorDirection
   -> m Int
@@ -172,7 +173,7 @@ cursorFetch_ cursor = void . cursorFetch cursor
 -- except it only positions the cursor and does not return rows. See
 -- https://www.postgresql.org/docs/current/sql-move.html for more information.
 cursorMove
-  :: (IsSQL sql, IsString sql, Monoid sql, MonadDB m)
+  :: (HasCallStack, IsSQL sql, IsString sql, Monoid sql, MonadDB m)
   => Cursor sql
   -> CursorDirection
   -> m Int
diff --git a/src/Database/PostgreSQL/PQTypes/Fold.hs b/src/Database/PostgreSQL/PQTypes/Fold.hs
index d259e8f..068b63a 100644
--- a/src/Database/PostgreSQL/PQTypes/Fold.hs
+++ b/src/Database/PostgreSQL/PQTypes/Fold.hs
@@ -9,7 +9,7 @@ module Database.PostgreSQL.PQTypes.Fold (
   ) where
 
 import Control.Monad.Catch
-import qualified Data.Foldable as F
+import GHC.Stack
 
 import Database.PostgreSQL.PQTypes.Class
 import Database.PostgreSQL.PQTypes.FromRow
@@ -18,36 +18,56 @@ import Database.PostgreSQL.PQTypes.Internal.QueryResult
 import Database.PostgreSQL.PQTypes.Utils
 
 -- | Get current 'QueryResult' or throw an exception if there isn't one.
-queryResult :: (MonadDB m, MonadThrow m, FromRow row) => m (QueryResult row)
-queryResult = getQueryResult
+queryResult
+  :: (HasCallStack, MonadDB m, MonadThrow m, FromRow row)
+  => m (QueryResult row)
+queryResult = withFrozenCallStack $ getQueryResult
   >>= maybe (throwDB . HPQTypesError $ "queryResult: no query result") return
 
 ----------------------------------------
 
--- | Specialization of 'F.foldrM' for convenient query results fetching.
-foldrDB :: (MonadDB m, FromRow row) => (row -> acc -> m acc) -> acc -> m acc
-foldrDB f acc = maybe (return acc) (F.foldrM f acc) =<< getQueryResult
+-- | Fetcher of rows returned by a query as a monadic right fold.
+foldrDB
+  :: (HasCallStack, MonadDB m, FromRow row)
+  => (row -> acc -> m acc)
+  -> acc
+  -> m acc
+foldrDB f acc = withFrozenCallStack $ getQueryResult
+  >>= maybe (return acc) (foldrImpl False f acc)
 
--- | Specialization of 'F.foldlM' for convenient query results fetching.
-foldlDB :: (MonadDB m, FromRow row) => (acc -> row -> m acc) -> acc -> m acc
-foldlDB f acc = maybe (return acc) (F.foldlM f acc) =<< getQueryResult
+-- | Fetcher of rows returned by a query as a monadic left fold.
+foldlDB
+  :: (HasCallStack, MonadDB m, FromRow row)
+  => (acc -> row -> m acc)
+  -> acc
+  -> m acc
+foldlDB f acc = withFrozenCallStack $ getQueryResult
+  >>= maybe (return acc) (foldlImpl False f acc)
 
--- | Specialization of 'F.mapM_' for convenient mapping over query results.
-mapDB_ :: (MonadDB m, FromRow row) => (row -> m t) -> m ()
-mapDB_ f = maybe (return ()) (F.mapM_ f) =<< getQueryResult
+-- | Fetcher of rows returned by a query as a monadic map.
+mapDB_
+  :: (HasCallStack, MonadDB m, FromRow row)
+  => (row -> m r)
+  -> m ()
+mapDB_ f = withFrozenCallStack $ getQueryResult
+  >>= maybe (return ()) (foldlImpl False (\() row -> () <$ f row) ())
 
 ----------------------------------------
 
 -- | Specialization of 'foldrDB' that fetches a list of rows.
-fetchMany :: (MonadDB m, FromRow row) => (row -> t) -> m [t]
-fetchMany f = foldrDB (\row acc -> return $ f row : acc) []
+fetchMany :: (HasCallStack, MonadDB m, FromRow row) => (row -> t) -> m [t]
+fetchMany f = withFrozenCallStack $ foldrDB (\row acc -> return $ f row : acc) []
 
 -- | Specialization of 'foldlDB' that fetches one or zero rows. If
 -- more rows are delivered, 'AffectedRowsMismatch' exception is thrown.
-fetchMaybe :: (MonadDB m, MonadThrow m, FromRow row) => (row -> t) -> m (Maybe t)
-fetchMaybe f = getQueryResult >>= \mqr -> case mqr of
-  Nothing -> return Nothing
-  Just qr -> fst <$> foldlDB go (Nothing, f <$> qr)
+fetchMaybe
+  :: (HasCallStack, MonadDB m, MonadThrow m, FromRow row)
+  => (row -> t)
+  -> m (Maybe t)
+fetchMaybe f = withFrozenCallStack $ do
+  getQueryResult >>= \mqr -> case mqr of
+    Nothing -> return Nothing
+    Just qr -> fst <$> foldlDB go (Nothing, f <$> qr)
   where
     go (Nothing, qr) row = return (Just $ f row, qr)
     go (Just _, qr) _ = throwDB AffectedRowsMismatch {
@@ -57,8 +77,8 @@ fetchMaybe f = getQueryResult >>= \mqr -> case mqr of
 
 -- | Specialization of 'fetchMaybe' that fetches exactly one row. If
 -- no row is delivered, 'AffectedRowsMismatch' exception is thrown.
-fetchOne :: (MonadDB m, MonadThrow m, FromRow row) => (row -> t) -> m t
-fetchOne f = do
+fetchOne :: (HasCallStack, MonadDB m, MonadThrow m, FromRow row) => (row -> t) -> m t
+fetchOne f = withFrozenCallStack $ do
   mt <- fetchMaybe f
   case mt of
     Just t  -> return t
diff --git a/src/Database/PostgreSQL/PQTypes/Internal/Connection.hs b/src/Database/PostgreSQL/PQTypes/Internal/Connection.hs
index ce4ff22..06caa28 100644
--- a/src/Database/PostgreSQL/PQTypes/Internal/Connection.hs
+++ b/src/Database/PostgreSQL/PQTypes/Internal/Connection.hs
@@ -33,6 +33,7 @@ import Foreign.C.String
 import Foreign.ForeignPtr
 import Foreign.Ptr
 import GHC.Conc (closeFdWith)
+import GHC.Stack
 import qualified Control.Exception as E
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.Foldable as F
@@ -274,7 +275,7 @@ disconnect (Connection mvconn) = modifyMVar_ mvconn $ \mconn -> do
 
 -- | Low-level function for running an SQL query.
 runQueryIO
-  :: IsSQL sql
+  :: (HasCallStack, IsSQL sql)
   => Connection
   -> sql
   -> IO (Int, ForeignPtr PGresult)
@@ -291,7 +292,7 @@ newtype QueryName = QueryName T.Text
 
 -- | Low-level function for running a prepared SQL query.
 runPreparedQueryIO
-  :: IsSQL sql
+  :: (HasCallStack, IsSQL sql)
   => Connection
   -> QueryName
   -> sql
@@ -302,6 +303,7 @@ runPreparedQueryIO conn (QueryName queryName) sql = do
       E.throwIO DBException
         { dbeQueryContext = sql
         , dbeError = HPQTypesError "runPreparedQueryIO: unnamed prepared query is not supported"
+        , dbeCallStack = callStack
         }
     let allocParam = ParamAllocator $ withPGparam cdPtr
     withSQL sql allocParam $ \param query -> do
@@ -319,7 +321,7 @@ runPreparedQueryIO conn (QueryName queryName) sql = do
 
 -- | Shared implementation of 'runQueryIO' and 'runPreparedQueryIO'.
 runQueryImpl
-  :: IsSQL sql
+  :: (HasCallStack, IsSQL sql)
   => String
   -> Connection
   -> sql
@@ -374,7 +376,12 @@ runQueryImpl fname conn sql execSql = do
   where
     withConnDo = withConnectionData conn fname
 
-verifyResult :: IsSQL sql => sql -> Ptr PGconn -> Ptr PGresult -> IO (Either Int Int)
+verifyResult
+  :: (HasCallStack, IsSQL sql)
+  => sql
+  -> Ptr PGconn
+  -> Ptr PGresult
+  -> IO (Either Int Int)
 verifyResult sql conn res = do
   -- works even if res is NULL
   rst <- c_PQresultStatus res
@@ -416,4 +423,5 @@ verifyResult sql conn res = do
       throwParseError sn = E.throwIO DBException {
         dbeQueryContext = sql
       , dbeError = HPQTypesError ("verifyResult: string returned by PQcmdTuples is not a valid number: " ++ show sn)
+      , dbeCallStack = callStack
       }
diff --git a/src/Database/PostgreSQL/PQTypes/Internal/Exception.hs b/src/Database/PostgreSQL/PQTypes/Internal/Exception.hs
index 2a7dc7a..ae5c7fe 100644
--- a/src/Database/PostgreSQL/PQTypes/Internal/Exception.hs
+++ b/src/Database/PostgreSQL/PQTypes/Internal/Exception.hs
@@ -4,6 +4,7 @@ module Database.PostgreSQL.PQTypes.Internal.Exception (
   , rethrowWithContext
   ) where
 
+import GHC.Stack
 import qualified Control.Exception as E
 
 import Database.PostgreSQL.PQTypes.SQL.Class
@@ -15,6 +16,7 @@ data DBException = forall e sql. (E.Exception e, Show sql) => DBException
     dbeQueryContext :: !sql
     -- | Specific error.
   , dbeError        :: !e
+  , dbeCallStack    :: CallStack
   }
 
 deriving instance Show DBException
@@ -22,8 +24,9 @@ deriving instance Show DBException
 instance E.Exception DBException
 
 -- | Rethrow supplied exception enriched with given SQL.
-rethrowWithContext :: IsSQL sql => sql -> E.SomeException -> IO a
+rethrowWithContext :: (HasCallStack, IsSQL sql) => sql -> E.SomeException -> IO a
 rethrowWithContext sql (E.SomeException e) = E.throwIO DBException {
     dbeQueryContext = sql
   , dbeError = e
+  , dbeCallStack = callStack
   }
diff --git a/src/Database/PostgreSQL/PQTypes/Internal/Monad.hs b/src/Database/PostgreSQL/PQTypes/Internal/Monad.hs
index 2116c0e..3320c09 100644
--- a/src/Database/PostgreSQL/PQTypes/Internal/Monad.hs
+++ b/src/Database/PostgreSQL/PQTypes/Internal/Monad.hs
@@ -16,6 +16,7 @@ import Control.Monad.State.Strict
 import Control.Monad.Trans.Control
 import Control.Monad.Writer.Class
 import Data.Bifunctor
+import GHC.Stack
 import qualified Control.Monad.Trans.State.Strict as S
 import qualified Control.Monad.Fail as MF
 
@@ -42,7 +43,7 @@ type DBT m = DBT_ m m
 -- | Evaluate monadic action with supplied
 -- connection source and transaction settings.
 runDBT
-  :: (MonadBase IO m, MonadMask m)
+  :: (HasCallStack, MonadBase IO m, MonadMask m)
   => ConnectionSourceM m
   -> TransactionSettings
   -> DBT m a
@@ -72,9 +73,9 @@ mapDBT f g m = DBT . StateT $ g . runStateT (unDBT m) . f
 ----------------------------------------
 
 instance (m ~ n, MonadBase IO m, MonadMask m) => MonadDB (DBT_ m n) where
-  runQuery sql = DBT . StateT $ \st -> liftBase $ do
+  runQuery sql = withFrozenCallStack $ DBT . StateT $ \st -> liftBase $ do
     second (updateStateWith st sql) <$> runQueryIO (dbConnection st) sql
-  runPreparedQuery name sql = DBT . StateT $ \st -> liftBase $ do
+  runPreparedQuery name sql = withFrozenCallStack $ DBT . StateT $ \st -> liftBase $ do
     second (updateStateWith st sql) <$> runPreparedQueryIO (dbConnection st) name sql
 
   getLastQuery = DBT . gets $ dbLastQuery
@@ -84,7 +85,7 @@ instance (m ~ n, MonadBase IO m, MonadMask m) => MonadDB (DBT_ m n) where
     (x, st'') <- runStateT (unDBT callback) st'
     pure (x, st'' { dbRecordLastQuery = dbRecordLastQuery st })
 
-  getConnectionStats = do
+  getConnectionStats = withFrozenCallStack $ do
     mconn <- DBT $ liftBase . readMVar =<< gets (unConnection . dbConnection)
     case mconn of
       Nothing -> throwDB $ HPQTypesError "getConnectionStats: no connection"
diff --git a/src/Database/PostgreSQL/PQTypes/Internal/QueryResult.hs b/src/Database/PostgreSQL/PQTypes/Internal/QueryResult.hs
index ba893d2..ae8cd19 100644
--- a/src/Database/PostgreSQL/PQTypes/Internal/QueryResult.hs
+++ b/src/Database/PostgreSQL/PQTypes/Internal/QueryResult.hs
@@ -3,14 +3,21 @@ module Database.PostgreSQL.PQTypes.Internal.QueryResult (
     QueryResult(..)
   , ntuples
   , nfields
+
+    -- * Implementation
+  , foldrImpl
+  , foldlImpl
   ) where
 
 import Control.Monad
+import Data.Coerce
 import Data.Foldable
+import Data.Functor.Identity
 import Foreign.C.Types
 import Foreign.ForeignPtr
 import Foreign.Marshal.Alloc
 import Foreign.Ptr
+import GHC.Stack
 import System.IO.Unsafe
 import qualified Control.Exception as E
 
@@ -35,21 +42,41 @@ instance Functor QueryResult where
   f `fmap` QueryResult ctx fres g = QueryResult ctx fres (f . g)
 
 instance Foldable QueryResult where
-  foldr  = foldImpl False (fmap pred . c_PQntuples) (const . return $ -1) pred
-  foldr' = foldImpl True  (fmap pred . c_PQntuples) (const . return $ -1) pred
+  foldr  f acc = runIdentity . foldrImpl False (coerce f) acc
+  foldr' f acc = runIdentity . foldrImpl True  (coerce f) acc
+
+  foldl  f acc = runIdentity . foldlImpl False (coerce f) acc
+  foldl' f acc = runIdentity . foldlImpl True  (coerce f) acc
 
-  foldl  = foldImpl False (const $ return 0) c_PQntuples succ . flip
-  foldl' = foldImpl True  (const $ return 0) c_PQntuples succ . flip
+foldrImpl
+  :: (HasCallStack, Monad m)
+  => Bool
+  -> (t -> acc -> m acc)
+  -> acc
+  -> QueryResult t
+  -> m acc
+foldrImpl = foldImpl (fmap pred . c_PQntuples) (const . return $ -1) pred
 
-foldImpl :: Bool
-         -> (Ptr PGresult -> IO CInt)
-         -> (Ptr PGresult -> IO CInt)
-         -> (CInt -> CInt)
-         -> (t -> acc -> acc)
-         -> acc
-         -> QueryResult t
-         -> acc
-foldImpl strict initCtr termCtr advCtr f iacc (QueryResult (SomeSQL ctx) fres g) =
+foldlImpl
+  :: (HasCallStack, Monad m)
+  => Bool
+  -> (acc -> t -> m acc)
+  -> acc
+  -> QueryResult t
+  -> m acc
+foldlImpl strict = foldImpl (const $ return 0) c_PQntuples succ strict . flip
+
+foldImpl
+  :: (HasCallStack, Monad m)
+  => (Ptr PGresult -> IO CInt)
+  -> (Ptr PGresult -> IO CInt)
+  -> (CInt -> CInt)
+  -> Bool
+  -> (t -> acc -> m acc)
+  -> acc
+  -> QueryResult t
+  -> m acc
+foldImpl initCtr termCtr advCtr strict f iacc (QueryResult (SomeSQL ctx) fres g) =
   unsafePerformIO $ withForeignPtr fres $ \res -> do
     -- This bit is referentially transparent iff appropriate
     -- FrowRow and FromSQL instances are (the ones provided
@@ -61,11 +88,18 @@ foldImpl strict initCtr termCtr advCtr f iacc (QueryResult (SomeSQL ctx) fres g)
         lengthExpected  = pqVariablesP rowp
       , lengthDelivered = rowlen
       }
+    , dbeCallStack = callStack
     }
     alloca $ \err -> do
-      i <- initCtr res
       n <- termCtr res
-      worker res err i n iacc
+      let worker acc i =
+            if i == n
+            then return acc
+            else do
+              -- mask asynchronous exceptions so they won't be wrapped in DBException
+              obj <- E.mask_ (g <$> fromRow res err 0 i `E.catch` rethrowWithContext ctx)
+              worker `apply` (f obj =<< acc) $ advCtr i
+      worker (pure iacc) =<< initCtr res
   where
     -- ⊥ of existential type hidden in QueryResult
     row      = let _ = g row in row
@@ -73,13 +107,6 @@ foldImpl strict initCtr termCtr advCtr f iacc (QueryResult (SomeSQL ctx) fres g)
 
     apply = if strict then ($!) else ($)
 
-    worker res err !i n acc
-      | i == n    = return acc
-      | otherwise = do
-        -- mask asynchronous exceptions so they won't be wrapped in DBException
-        obj <- E.mask_ (g <$> fromRow res err 0 i `E.catch` rethrowWithContext ctx)
-        worker res err (advCtr i) n `apply` f obj acc
-
 -- Note: c_PQntuples/c_PQnfields are pure on a C level and QueryResult
 -- constructor is not exported to the end user (so it's not possible
 -- to enforce premature finalization via finalizeForeignPtr), which
diff --git a/src/Database/PostgreSQL/PQTypes/Notification.hs b/src/Database/PostgreSQL/PQTypes/Notification.hs
index b1c5119..703e825 100644
--- a/src/Database/PostgreSQL/PQTypes/Notification.hs
+++ b/src/Database/PostgreSQL/PQTypes/Notification.hs
@@ -8,6 +8,7 @@ module Database.PostgreSQL.PQTypes.Notification (
   ) where
 
 import Data.Text (Text)
+import GHC.Stack
 
 import Data.Monoid.Utils
 import Database.PostgreSQL.PQTypes.Class
@@ -16,18 +17,18 @@ import Database.PostgreSQL.PQTypes.SQL.Raw
 import Database.PostgreSQL.PQTypes.Utils
 
 -- | Start listening for notifications on a given channel.
-listen :: MonadDB m => Channel -> m ()
+listen :: (HasCallStack, MonadDB m) => Channel -> m ()
 listen (Channel chan) = runQuery_ $ "LISTEN" <+> chan
 
 -- | Stop listening for notifications on a given channel.
-unlisten :: MonadDB m => Channel -> m ()
+unlisten :: (HasCallStack, MonadDB m) => Channel -> m ()
 unlisten (Channel chan) = runQuery_ $ "UNLISTEN" <+> chan
 
 -- | Cancel all listener registrations for the current session.
-unlistenAll :: MonadDB m => m ()
+unlistenAll :: (HasCallStack, MonadDB m) => m ()
 unlistenAll = runSQL_ "UNLISTEN *"
 
 -- | Generate a notification on a given channel.
-notify :: MonadDB m => Channel -> Text -> m ()
+notify :: (HasCallStack, MonadDB m) => Channel -> Text -> m ()
 notify (Channel chan) payload = runQuery_
   $ rawSQL "SELECT pg_notify($1, $2)" (unRawSQL chan, payload)
diff --git a/src/Database/PostgreSQL/PQTypes/Transaction.hs b/src/Database/PostgreSQL/PQTypes/Transaction.hs
index 9d30cb4..559ea5a 100644
--- a/src/Database/PostgreSQL/PQTypes/Transaction.hs
+++ b/src/Database/PostgreSQL/PQTypes/Transaction.hs
@@ -16,6 +16,7 @@ import Control.Monad.Catch
 import Data.Function
 import Data.String
 import Data.Typeable
+import GHC.Stack
 
 import Data.Monoid.Utils
 import Database.PostgreSQL.PQTypes.Class
@@ -35,7 +36,7 @@ instance IsString Savepoint where
 -- provides something like \"nested transaction\".
 --
 -- See <http://www.postgresql.org/docs/current/static/sql-savepoint.html>
-withSavepoint :: (MonadDB m, MonadMask m) => Savepoint -> m a -> m a
+withSavepoint :: (HasCallStack, MonadDB m, MonadMask m) => Savepoint -> m a -> m a
 withSavepoint (Savepoint savepoint) m = fst <$> generalBracket
   (runQuery_ $ "SAVEPOINT" <+> savepoint)
   (\() -> \case
@@ -57,19 +58,19 @@ withSavepoint (Savepoint savepoint) m = fst <$> generalBracket
 -- monadic action won't have any effect  on the final 'commit'
 -- / 'rollback' as settings that were in effect during the call
 -- to 'withTransaction' will be used.
-withTransaction :: (MonadDB m, MonadMask m) => m a -> m a
+withTransaction :: (HasCallStack, MonadDB m, MonadMask m) => m a -> m a
 withTransaction m = getTransactionSettings >>= flip withTransaction' m
 
 -- | Begin transaction using current transaction settings.
-begin :: MonadDB m => m ()
+begin :: (HasCallStack, MonadDB m) => m ()
 begin = getTransactionSettings >>= begin'
 
 -- | Commit active transaction using current transaction settings.
-commit :: MonadDB m => m ()
+commit :: (HasCallStack, MonadDB m) => m ()
 commit = getTransactionSettings >>= commit'
 
 -- | Rollback active transaction using current transaction settings.
-rollback :: MonadDB m => m ()
+rollback :: (HasCallStack, MonadDB m) => m ()
 rollback = getTransactionSettings >>= rollback'
 
 ----------------------------------------
@@ -77,7 +78,7 @@ rollback = getTransactionSettings >>= rollback'
 -- | Execute monadic action within a transaction using given transaction
 -- settings. Note that it won't work as expected if a transaction is already
 -- active (in such case 'withSavepoint' should be used instead).
-withTransaction' :: (MonadDB m, MonadMask m)
+withTransaction' :: (HasCallStack, MonadDB m, MonadMask m)
                  => TransactionSettings -> m a -> m a
 withTransaction' ts m = (`fix` 1) $ \loop n -> do
   -- Optimization for squashing possible space leaks.
@@ -109,7 +110,7 @@ withTransaction' ts m = (`fix` 1) $ \loop n -> do
       guard $ f err n
 
 -- | Begin transaction using given transaction settings.
-begin' :: MonadDB m => TransactionSettings -> m ()
+begin' :: (HasCallStack, MonadDB m) => TransactionSettings -> m ()
 begin' ts = runSQL_ . mintercalate " " $ ["BEGIN", isolationLevel, permissions]
   where
     isolationLevel = case tsIsolationLevel ts of
@@ -123,14 +124,14 @@ begin' ts = runSQL_ . mintercalate " " $ ["BEGIN", isolationLevel, permissions]
       ReadWrite          -> "READ WRITE"
 
 -- | Commit active transaction using given transaction settings.
-commit' :: MonadDB m => TransactionSettings -> m ()
+commit' :: (HasCallStack, MonadDB m) => TransactionSettings -> m ()
 commit' ts = do
   runSQL_ "COMMIT"
   when (tsAutoTransaction ts) $
     begin' ts
 
 -- | Rollback active transaction using given transaction settings.
-rollback' :: MonadDB m => TransactionSettings -> m ()
+rollback' :: (HasCallStack, MonadDB m) => TransactionSettings -> m ()
 rollback' ts = do
   runSQL_ "ROLLBACK"
   when (tsAutoTransaction ts) $
diff --git a/src/Database/PostgreSQL/PQTypes/Utils.hs b/src/Database/PostgreSQL/PQTypes/Utils.hs
index 7c14dd6..af26a3e 100644
--- a/src/Database/PostgreSQL/PQTypes/Utils.hs
+++ b/src/Database/PostgreSQL/PQTypes/Utils.hs
@@ -21,6 +21,7 @@ module Database.PostgreSQL.PQTypes.Utils (
 
 import Control.Monad
 import Control.Monad.Catch
+import GHC.Stack
 
 import Database.PostgreSQL.PQTypes.Class
 import Database.PostgreSQL.PQTypes.Internal.Error
@@ -32,7 +33,7 @@ import Database.PostgreSQL.PQTypes.SQL.Raw
 
 -- | When given 'DBException', throw it immediately. Otherwise
 -- wrap it in 'DBException' with the current query context first.
-throwDB :: (Exception e, MonadDB m, MonadThrow m) => e -> m a
+throwDB :: (HasCallStack, Exception e, MonadDB m, MonadThrow m) => e -> m a
 throwDB e = case fromException $ toException e of
   Just (dbe::DBException) -> throwM dbe
   Nothing -> do
@@ -40,6 +41,7 @@ throwDB e = case fromException $ toException e of
     throwM DBException {
       dbeQueryContext = sql
     , dbeError = e
+    , dbeCallStack = callStack
     }
 
 ----------------------------------------
@@ -51,14 +53,14 @@ raw = mkSQL . unRawSQL
 ----------------------------------------
 
 -- | Specialization of 'runQuery' that discards the result.
-runQuery_ :: (IsSQL sql, MonadDB m) => sql -> m ()
-runQuery_ = void . runQuery
+runQuery_ :: (HasCallStack, IsSQL sql, MonadDB m) => sql -> m ()
+runQuery_ = withFrozenCallStack $ void . runQuery
 
 -- | Specialization of 'runQuery' that checks whether affected/returned
 -- number of rows is in range [0, 1] and returns appropriate 'Bool' value.
 -- Otherwise, 'AffectedRowsMismatch' exception is thrown.
-runQuery01 :: (IsSQL sql, MonadDB m, MonadThrow m) => sql -> m Bool
-runQuery01 sql = do
+runQuery01 :: (HasCallStack, IsSQL sql, MonadDB m, MonadThrow m) => sql -> m Bool
+runQuery01 sql = withFrozenCallStack $ do
   n <- runQuery sql
   when (n > 1) $ throwDB AffectedRowsMismatch {
     rowsExpected = [(0, 1)]
@@ -67,38 +69,42 @@ runQuery01 sql = do
   return $ n == 1
 
 -- | Specialization of 'runQuery01' that discards the result.
-runQuery01_ :: (IsSQL sql, MonadDB m, MonadThrow m) => sql -> m ()
-runQuery01_ = void . runQuery01
+runQuery01_ :: (HasCallStack, IsSQL sql, MonadDB m, MonadThrow m) => sql -> m ()
+runQuery01_ = withFrozenCallStack $ void . runQuery01
 
 ----------------------------------------
 
 -- | Specialization of 'runQuery' to 'SQL' type.
-runSQL :: MonadDB m => SQL -> m Int
-runSQL = runQuery
+runSQL :: (HasCallStack, MonadDB m) => SQL -> m Int
+runSQL = withFrozenCallStack runQuery
 
 -- | Specialization of 'runQuery_' to 'SQL' type.
-runSQL_ :: MonadDB m => SQL -> m ()
-runSQL_ = runQuery_
+runSQL_ :: (HasCallStack, MonadDB m) => SQL -> m ()
+runSQL_ = withFrozenCallStack runQuery_
 
 -- | Specialization of 'runQuery01' to 'SQL' type.
-runSQL01 :: (MonadDB m, MonadThrow m) => SQL -> m Bool
-runSQL01 = runQuery01
+runSQL01 :: (HasCallStack, MonadDB m, MonadThrow m) => SQL -> m Bool
+runSQL01 = withFrozenCallStack runQuery01
 
 -- | Specialization of 'runQuery01_' to 'SQL' type.
-runSQL01_ :: (MonadDB m, MonadThrow m) => SQL -> m ()
-runSQL01_ = runQuery01_
+runSQL01_ :: (HasCallStack, MonadDB m, MonadThrow m) => SQL -> m ()
+runSQL01_ = withFrozenCallStack runQuery01_
 
 ----------------------------------------
 
 -- | Specialization of 'runPreparedQuery' that discards the result.
-runPreparedQuery_ :: (IsSQL sql, MonadDB m) => QueryName -> sql -> m ()
-runPreparedQuery_ name = void . runPreparedQuery name
+runPreparedQuery_ :: (HasCallStack, IsSQL sql, MonadDB m) => QueryName -> sql -> m ()
+runPreparedQuery_ name = withFrozenCallStack $ void . runPreparedQuery name
 
 -- | Specialization of 'runPreparedQuery' that checks whether affected/returned
 -- number of rows is in range [0, 1] and returns appropriate 'Bool' value.
 -- Otherwise, 'AffectedRowsMismatch' exception is thrown.
-runPreparedQuery01 :: (IsSQL sql, MonadDB m, MonadThrow m) => QueryName -> sql -> m Bool
-runPreparedQuery01 name sql = do
+runPreparedQuery01
+  :: (HasCallStack, IsSQL sql, MonadDB m, MonadThrow m)
+  => QueryName
+  -> sql
+  -> m Bool
+runPreparedQuery01 name sql = withFrozenCallStack $ do
   n <- runPreparedQuery name sql
   when (n > 1) $ throwDB AffectedRowsMismatch {
     rowsExpected = [(0, 1)]
@@ -107,23 +113,27 @@ runPreparedQuery01 name sql = do
   return $ n == 1
 
 -- | Specialization of 'runPreparedQuery01' that discards the result.
-runPreparedQuery01_ :: (IsSQL sql, MonadDB m, MonadThrow m) => QueryName -> sql -> m ()
-runPreparedQuery01_ name = void . runPreparedQuery01 name
+runPreparedQuery01_
+  :: (HasCallStack, IsSQL sql, MonadDB m, MonadThrow m)
+  => QueryName
+  -> sql
+  -> m ()
+runPreparedQuery01_ name = withFrozenCallStack $ void . runPreparedQuery01 name
 
 ----------------------------------------
 
 -- | Specialization of 'runPreparedQuery' to 'SQL' type.
-runPreparedSQL :: MonadDB m => QueryName -> SQL -> m Int
-runPreparedSQL = runPreparedQuery
+runPreparedSQL :: (HasCallStack, MonadDB m) => QueryName -> SQL -> m Int
+runPreparedSQL = withFrozenCallStack runPreparedQuery
 
 -- | Specialization of 'runPreparedQuery_' to 'SQL' type.
-runPreparedSQL_ :: MonadDB m => QueryName -> SQL -> m ()
-runPreparedSQL_ = runPreparedQuery_
+runPreparedSQL_ :: (HasCallStack, MonadDB m) => QueryName -> SQL -> m ()
+runPreparedSQL_ = withFrozenCallStack runPreparedQuery_
 
 -- | Specialization of 'runPreparedQuery01' to 'SQL' type.
-runPreparedSQL01 :: (MonadDB m, MonadThrow m) => QueryName -> SQL -> m Bool
-runPreparedSQL01 = runPreparedQuery01
+runPreparedSQL01 :: (HasCallStack, MonadDB m, MonadThrow m) => QueryName -> SQL -> m Bool
+runPreparedSQL01 = withFrozenCallStack runPreparedQuery01
 
 -- | Specialization of 'runPreparedQuery01_' to 'SQL' type.
-runPreparedSQL01_ :: (MonadDB m, MonadThrow m) => QueryName -> SQL -> m ()
-runPreparedSQL01_ = runPreparedQuery01_
+runPreparedSQL01_ :: (HasCallStack, MonadDB m, MonadThrow m) => QueryName -> SQL -> m ()
+runPreparedSQL01_ = withFrozenCallStack runPreparedQuery01_