From 73ac1079acfa4f4f23669fed1fd2c085aa6e3036 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Domen=20Ko=C5=BEar?= <domen@dev.si>
Date: Thu, 4 Jan 2024 13:06:09 +0000
Subject: [PATCH] QueryError: add displayException

---
 library/Hasql/Private/Errors.hs | 64 ++++++++++++++++++++++++++++++++-
 1 file changed, 63 insertions(+), 1 deletion(-)

diff --git a/library/Hasql/Private/Errors.hs b/library/Hasql/Private/Errors.hs
index 2893b57..012b806 100644
--- a/library/Hasql/Private/Errors.hs
+++ b/library/Hasql/Private/Errors.hs
@@ -10,6 +10,7 @@
 -- * Row-by-row fetching.
 module Hasql.Private.Errors where
 
+import qualified Data.ByteString.Char8 as BC
 import Hasql.Private.Prelude
 
 -- |
@@ -19,7 +20,68 @@ data QueryError
   = QueryError ByteString [Text] CommandError
   deriving (Show, Eq, Typeable)
 
-instance Exception QueryError
+instance Exception QueryError where
+  displayException (QueryError query params commandError) =
+    let queryContext :: Maybe (ByteString, Int)
+        queryContext = case commandError of
+          ClientError _ -> Nothing
+          ResultError resultError -> case resultError of
+            ServerError _ message _ _ (Just position) -> Just (message, position)
+            _ -> Nothing
+
+        -- find the line number and position of the error
+        findLineAndPos :: ByteString -> Int -> (Int, Int)
+        findLineAndPos byteString errorPos =
+          let (_, line, pos) =
+                BC.foldl'
+                  ( \(total, line, pos) c ->
+                      case total + 1 of
+                        0 -> (total, line, pos)
+                        cursor
+                          | cursor == errorPos -> (-1, line, pos + 1)
+                          | c == '\n' -> (total + 1, line + 1, 0)
+                          | otherwise -> (total + 1, line, pos + 1)
+                  )
+                  (0, 1, 0)
+                  byteString
+           in (line, pos)
+
+        formatErrorContext :: ByteString -> ByteString -> Int -> ByteString
+        formatErrorContext query message errorPos =
+          let lines = BC.lines query
+              (lineNum, linePos) = findLineAndPos query errorPos
+           in BC.unlines (take lineNum lines)
+                <> BC.replicate (linePos - 1) ' '
+                <> "^ "
+                <> message
+
+        prettyQuery :: ByteString
+        prettyQuery = case queryContext of
+          Nothing -> query
+          Just (message, pos) -> formatErrorContext query message pos
+     in "QueryError!\n"
+          <> "\n  Query:\n"
+          <> BC.unpack prettyQuery
+          <> "\n"
+          <> "\n  Params: "
+          <> show params
+          <> "\n  Error: "
+          <> case commandError of
+            ClientError (Just message) -> "Client error: " <> show message
+            ClientError Nothing -> "Unknown client error"
+            ResultError resultError -> case resultError of
+              ServerError code message details hint position ->
+                "Server error "
+                  <> BC.unpack code
+                  <> ": "
+                  <> BC.unpack message
+                  <> maybe "" (\d -> "\n  Details: " <> BC.unpack d) details
+                  <> maybe "" (\h -> "\n  Hint: " <> BC.unpack h) hint
+              UnexpectedResult message -> "Unexpected result: " <> show message
+              RowError row column rowError ->
+                "Row error: " <> show row <> ":" <> show column <> " " <> show rowError
+              UnexpectedAmountOfRows amount ->
+                "Unexpected amount of rows: " <> show amount
 
 -- |
 -- An error of some command in the session.