From eb11ff632b87d53c0187ca200a635d64dc545c35 Mon Sep 17 00:00:00 2001
From: mmzk1526 <yc4120@ic.ac.uk>
Date: Thu, 30 May 2024 19:27:32 +0100
Subject: [PATCH] Show the prefix itself inside error messages

---
 src/Data/KindID/Class.hs    | 17 +++++++++++------
 src/Data/TypeID/Error.hs    | 29 ++++++++++++++++-------------
 src/Data/TypeID/Internal.hs |  8 ++++----
 3 files changed, 31 insertions(+), 23 deletions(-)

diff --git a/src/Data/KindID/Class.hs b/src/Data/KindID/Class.hs
index 0f9b960..d1a86f4 100644
--- a/src/Data/KindID/Class.hs
+++ b/src/Data/KindID/Class.hs
@@ -75,18 +75,22 @@ type ValidPrefix prefix = ( KnownSymbol prefix
 
 -- | Contains a custom error message if the prefix 'Symbol' is too long.
 type family LengthLT64C (prefix :: Symbol) :: Constraint where
-  LengthLT64C s =
-    If (Compare (LengthSymbol s) 64 == 'LT) (() :: Constraint)
-       ( TypeError ( Text "Prefix with "
+  LengthLT64C s
+    = If (Compare (LengthSymbol s) 64 == 'LT) (() :: Constraint)
+       ( TypeError ( Text "The prefix "
+               :<>: ShowType s
+               :<>: Text " with "
                :<>: ShowType (LengthSymbol s)
                :<>: Text " characters is too long!" ) )
 
 -- | Contains a custom error message if the prefix 'Symbol' is not lowercase +
 -- underscore or it starts or ends with underscores.
 type family IsLUSymbolC (prefix :: Symbol) :: Constraint where
-  IsLUSymbolC s =
-    If (IsLUSymbol s) (() :: Constraint)
-       (TypeError (Text "Prefix is not valid!"))
+  IsLUSymbolC s
+    = If (IsLUSymbol s) (() :: Constraint)
+         ( TypeError ( Text "The prefix "
+                  :<>: ShowType s
+                  :<>: Text " is not valid!" ) )
 
 -- | The length of a 'Symbol' as a 'Nat'.
 type family LengthSymbol (prefix :: Symbol) :: Nat where
@@ -123,6 +127,7 @@ type family ILUSUH2 (uncons :: Maybe (Char, Symbol)) :: Bool where
   ILUSUH2 ('Just '( c, s ))  = (IsLowerChar c || IsUnderscore c)
                             && ILUSUH2 (UnconsSymbol s)
 
+
 --------------------------------------------------------------------------------
 -- Deprecated
 --------------------------------------------------------------------------------
diff --git a/src/Data/TypeID/Error.hs b/src/Data/TypeID/Error.hs
index 69aa0d7..fddb1c3 100644
--- a/src/Data/TypeID/Error.hs
+++ b/src/Data/TypeID/Error.hs
@@ -14,19 +14,20 @@ module Data.TypeID.Error
 
 import           Control.Exception
 import           Data.Text (Text)
+import qualified Data.Text as T
 
 -- | Errors from parsing TypeIDs.
 data TypeIDError
-  = -- | The prefix longer than 63 characters.
-    TypeIDErrorPrefixTooLong Int
+  = -- | The prefix is longer than 63 characters.
+    TypeIDErrorPrefixTooLong Text
     -- | The ID contains an extra underscore separator.
   | TypeIDExtraSeparator
     -- | The ID starts with an underscore separator.
-  | TypeIDStartWithUnderscore
+  | TypeIDStartWithUnderscore Text
     -- | The ID ends with an underscore separator.
-  | TypeIDEndWithUnderscore
+  | TypeIDEndWithUnderscore Text
     -- | The prefix contains an invalid character, namely not lowercase Latin.
-  | TypeIDErrorPrefixInvalidChar Char
+  | TypeIDErrorPrefixInvalidChar Text Char
     -- | From a `Data.KindID.KindID` conversion. The prefix doesn't match with
     -- the expected.
   | TypeIDErrorPrefixMismatch Text Text
@@ -36,16 +37,18 @@ data TypeIDError
 
 instance Show TypeIDError where
   show :: TypeIDError -> String
-  show (TypeIDErrorPrefixTooLong n)
-    = concat ["Prefix with ", show n, " characters is too long!"]
+  show (TypeIDErrorPrefixTooLong txt)
+    = concat [ "The prefix ", show txt
+             , " with ", show (T.length txt), " characters is too long!" ]
   show TypeIDExtraSeparator
     = "The underscore separator should not be present if the prefix is empty!"
-  show TypeIDStartWithUnderscore
-    = "The prefix should not start with an underscore!"
-  show TypeIDEndWithUnderscore
-    = "The prefix should not end with an underscore!"
-  show (TypeIDErrorPrefixInvalidChar c)
-    = concat ["Prefix contains invalid character ", show c, "!"]
+  show (TypeIDStartWithUnderscore txt)
+    = concat ["The prefix ", show txt, " should not start with an underscore!"]
+  show (TypeIDEndWithUnderscore txt)
+    = concat ["The prefix ", show txt, " should not end with an underscore!"]
+  show (TypeIDErrorPrefixInvalidChar txt c)
+    = concat [ "The prefix ", show txt
+             , " contains invalid character ", show c, "!"]
   show (TypeIDErrorPrefixMismatch expPrefix actPrefix)
     = concat [ "Expected prefix ", show expPrefix, " but got "
              , show actPrefix, "!" ]
diff --git a/src/Data/TypeID/Internal.hs b/src/Data/TypeID/Internal.hs
index 3d00fff..e472a3f 100644
--- a/src/Data/TypeID/Internal.hs
+++ b/src/Data/TypeID/Internal.hs
@@ -543,16 +543,16 @@ parseByteStringM = byteString2IDM
 -- | Check if the given prefix is a valid 'TypeID'' prefix.
 checkPrefix :: Text -> Maybe TypeIDError
 checkPrefix prefix
-  | T.length prefix > 63 = Just $ TypeIDErrorPrefixTooLong (T.length prefix)
+  | T.length prefix > 63 = Just $ TypeIDErrorPrefixTooLong prefix
   | T.null prefix        = Nothing
-  | T.head prefix == '_' = Just TypeIDStartWithUnderscore
-  | T.last prefix == '_' = Just TypeIDEndWithUnderscore
+  | T.head prefix == '_' = Just $ TypeIDStartWithUnderscore prefix
+  | T.last prefix == '_' = Just $ TypeIDEndWithUnderscore prefix
   | otherwise
       = case T.uncons ( T.dropWhile ( liftM2 (||) (== '_')
                                     $ liftM2 (&&) isLower isAscii)
                         prefix) of
         Nothing     -> Nothing
-        Just (c, _) -> Just $ TypeIDErrorPrefixInvalidChar c
+        Just (c, _) -> Just $ TypeIDErrorPrefixInvalidChar prefix c
 {-# INLINE checkPrefix #-}
 
 -- | Check if the prefix is valid and the suffix 'UUID' has the correct v7