Commit 99823ed2 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot
Browse files

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

We shouldn't compare pointer values but the actual bytes.
parent 22bf5c73
Pipeline #18660 passed with stages
in 463 minutes and 32 seconds
......@@ -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 @{}@
......
......@@ -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
......
{-# 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
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
......@@ -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, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment