diff options
-rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Syntax.hs | 43 | ||||
-rw-r--r-- | libraries/template-haskell/changelog.md | 6 | ||||
-rw-r--r-- | testsuite/tests/th/TH_BytesShowEqOrd.hs | 40 | ||||
-rw-r--r-- | testsuite/tests/th/TH_BytesShowEqOrd.stdout | 6 | ||||
-rw-r--r-- | testsuite/tests/th/all.T | 1 |
5 files changed, 95 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 diff --git a/testsuite/tests/th/TH_BytesShowEqOrd.hs b/testsuite/tests/th/TH_BytesShowEqOrd.hs new file mode 100644 index 0000000000..e7640a7df3 --- /dev/null +++ b/testsuite/tests/th/TH_BytesShowEqOrd.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} + +module Main where + +import Language.Haskell.TH.Lib +import GHC.Ptr +import Foreign.ForeignPtr + +main :: IO () +main = do + + let + !x = "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz"# + !y = "ABCDEabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz"# + + p1 <- newForeignPtr_ (Ptr x) + p2 <- newForeignPtr_ (Ptr y) + + let + b1 = mkBytes p1 0 5 + b2 = mkBytes p1 10 5 + b3 = mkBytes p1 26 5 + b4 = mkBytes p2 5 5 + b5 = mkBytes p2 10 5 + + let myCmp a b = putStrLn $ "compare " ++ show a ++ " to " ++ show b ++ " => " ++ show (compare a b) + + putStr "same pointer, same offset, same bytes: " + myCmp b1 b1 + putStr "same pointer, different offset, same bytes: " + myCmp b1 b3 + putStr "same pointer, different offset, different bytes: " + myCmp b1 b2 + putStr "same pointer, different offset, different bytes: " + myCmp b2 b1 + putStr "different pointer, different offset, same bytes: " + myCmp b1 b4 + putStr "different pointer, different offset, different bytes: " + myCmp b1 b5 diff --git a/testsuite/tests/th/TH_BytesShowEqOrd.stdout b/testsuite/tests/th/TH_BytesShowEqOrd.stdout new file mode 100644 index 0000000000..8da996586c --- /dev/null +++ b/testsuite/tests/th/TH_BytesShowEqOrd.stdout @@ -0,0 +1,6 @@ +same pointer, same offset, same bytes: compare abcde to abcde => EQ +same pointer, different offset, same bytes: compare abcde to abcde => EQ +same pointer, different offset, different bytes: compare abcde to klmno => LT +same pointer, different offset, different bytes: compare klmno to abcde => GT +different pointer, different offset, same bytes: compare abcde to abcde => EQ +different pointer, different offset, different bytes: compare abcde to fghij => LT diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 127bdf665c..458b45d67f 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -504,3 +504,4 @@ test('T17688a', normal, compile, ['']) test('T17688b', normal, compile, ['']) test('TH_PprStar', normal, compile, ['-v0 -dsuppress-uniques']) test('TH_StringLift', normal, compile, ['']) +test('TH_BytesShowEqOrd', normal, compile_and_run, ['']) |