TH: fix Show/Eq/Ord instances for Bytes (#16457)

We shouldn't compare pointer values but the actual bytes.

2 files changed, 48 insertions, 1 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index c14bec1f65..8e559dd854 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -45,12 +45,15 @@ import GHC.Generics     ( Generic )
 import GHC.Types        ( Int(..), Word(..), Char(..), Double(..), Float(..),
                           TYPE, RuntimeRep(..) )
 import GHC.Prim         ( Int#, Word#, Char#, Double#, Float#, Addr# )
+import GHC.Ptr          ( Ptr, plusPtr )
 import GHC.Lexeme       ( startsVarSym, startsVarId )
 import GHC.ForeignSrcLang.Type
 import Language.Haskell.TH.LanguageExtensions
 import Numeric.Natural
 import Prelude
 import Foreign.ForeignPtr
+import Foreign.C.String
+import Foreign.C.Types
 
 -----------------------------------------------------
 --
@@ -1868,7 +1871,45 @@ data Bytes = Bytes
    -- , bytesInitialized :: Bool -- ^ False: only use `bytesSize` to allocate
    --                            --   an uninitialized region
    }
-   deriving (Eq,Ord,Data,Generic,Show)
+   deriving (Data,Generic)
+
+-- We can't derive Show instance for Bytes because we don't want to show the
+-- pointer value but the actual bytes (similarly to what ByteString does). See
+-- #16457.
+instance Show Bytes where
+   show b = unsafePerformIO $ withForeignPtr (bytesPtr b) $ \ptr ->
+               peekCStringLen ( ptr `plusPtr` fromIntegral (bytesOffset b)
+                              , fromIntegral (bytesSize b)
+                              )
+
+-- We can't derive Eq and Ord instances for Bytes because we don't want to
+-- compare pointer values but the actual bytes (similarly to what ByteString
+-- does).  See #16457
+instance Eq Bytes where
+   (==) = eqBytes
+
+instance Ord Bytes where
+   compare = compareBytes
+
+eqBytes :: Bytes -> Bytes -> Bool
+eqBytes a@(Bytes fp off len) b@(Bytes fp' off' len')
+  | len /= len'              = False    -- short cut on length
+  | fp == fp' && off == off' = True     -- short cut for the same bytes
+  | otherwise                = compareBytes a b == EQ
+
+compareBytes :: Bytes -> Bytes -> Ordering
+compareBytes (Bytes _   _    0)    (Bytes _   _    0)    = EQ  -- short cut for empty Bytes
+compareBytes (Bytes fp1 off1 len1) (Bytes fp2 off2 len2) =
+    unsafePerformIO $
+      withForeignPtr fp1 $ \p1 ->
+      withForeignPtr fp2 $ \p2 -> do
+        i <- memcmp (p1 `plusPtr` fromIntegral off1)
+                    (p2 `plusPtr` fromIntegral off2)
+                    (fromIntegral (min len1 len2))
+        return $! (i `compare` 0) <> (len1 `compare` len2)
+
+foreign import ccall unsafe "memcmp"
+  memcmp :: Ptr a -> Ptr b -> CSize -> IO CInt
 
 
 -- | Pattern in Haskell given in @{}@
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 0b5fb2c10c..4a522837af 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -10,6 +10,12 @@
     and `unTypeQ` are also generalised in terms of `Quote` rather than specific
     to `Q`.
 
+  * Fix Eq/Ord instances for `Bytes`: we were comparing pointers while we should
+    compare the actual bytes (#16457).
+
+  * Fix Show instance for `Bytes`: we were showing the pointer value while we
+    want to show the contents (#16457).
+
 ## 2.16.0.0 *TBA*
 
   * Add support for tuple sections. (#15843) The type signatures of `TupE` and