From 915d9a273558e1879ff605095fc49ba2d2008203 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 | 54 ++++++++++++++++++++++++++++++++-
 1 file changed, 53 insertions(+), 1 deletion(-)

diff --git a/library/Hasql/Private/Errors.hs b/library/Hasql/Private/Errors.hs
index 2893b57..cf65b5e 100644
--- a/library/Hasql/Private/Errors.hs
+++ b/library/Hasql/Private/Errors.hs
@@ -12,6 +12,9 @@ module Hasql.Private.Errors where
 
 import Hasql.Private.Prelude
 
+import qualified Data.ByteString.Char8 as BC
+
+
 -- |
 -- An error during the execution of a query.
 -- Comes packed with the query template and a textual representation of the provided params.
@@ -19,7 +22,56 @@ 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
+      
+      -- Function to find the line number and position within the line
+      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
+              <> 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.