Implement instance Data (#614)

* Add functionality for toConstr

* Other instances fixed

* Move test

* test passes

* Add gshow tests

* Typo

* Add explicit string test

* instance Data: implement gunfold and dataTypeOf

* instance Data: fix tests

* Fix emulated builds

* Restore derived instance Data ShortByteString

* Add instance Generic ShortByteString

* Review suggestions

---------

Co-authored-by: Colton Clemmer <[email protected]>

.github/workflows/ci.yml

@@ -133,11 +133,11 @@ jobs:
       timeout-minutes: 60
       with:
         arch: ${{ matrix.arch }}
-        distro: ubuntu22.04
+        distro: ubuntu_rolling
         githubToken: ${{ github.token }}
         install: |
           apt-get update -y
-          apt-get install -y curl ghc libghc-tasty-quickcheck-dev
+          apt-get install -y curl ghc libghc-tasty-quickcheck-dev libghc-syb-dev
         run: |
           curl -s https://hackage.haskell.org/package/data-array-byte-0.1/data-array-byte-0.1.tar.gz | tar xz
           ghc --version

Data/ByteString/Internal/Type.hs

@@ -137,7 +137,7 @@ import Data.Bits                ((.&.))
 import Data.Char                (ord)
 import Data.Word
 
-import Data.Data                (Data(..), mkNoRepType)
+import Data.Data                (Data(..), mkConstr ,mkDataType, Constr, DataType, Fixity(Prefix), constrIndex)
 
 import GHC.Base                 (nullAddr#,realWorld#,unsafeChr)
 import GHC.Exts                 (IsList(..), Addr#, minusAddr#)
@@ -354,9 +354,17 @@ instance IsString ByteString where
 
 instance Data ByteString where
   gfoldl f z txt = z packBytes `f` unpackBytes txt
-  toConstr _     = error "Data.ByteString.ByteString.toConstr"
-  gunfold _ _    = error "Data.ByteString.ByteString.gunfold"
-  dataTypeOf _   = mkNoRepType "Data.ByteString.ByteString"
+  toConstr _     = packConstr
+  gunfold k z c = case constrIndex c of
+    1 -> k (z packBytes)
+    _ -> error "gunfold: unexpected constructor of strict ByteString"
+  dataTypeOf _   = byteStringDataType
+
+packConstr :: Constr
+packConstr = mkConstr byteStringDataType "pack" [] Prefix
+
+byteStringDataType :: DataType
+byteStringDataType = mkDataType "Data.ByteString.ByteString" [packConstr]
 
 -- | @since 0.11.2.0
 instance TH.Lift ByteString where

Data/ByteString/Lazy/Internal.hs

@@ -69,7 +69,7 @@ import Control.DeepSeq  (NFData, rnf)
 
 import Data.String      (IsString(..))
 
-import Data.Data                (Data(..), mkNoRepType)
+import Data.Data                (Data(..), mkConstr ,mkDataType, Constr, DataType, Fixity(Prefix), constrIndex)
 
 import GHC.Exts                 (IsList(..))
 
@@ -153,9 +153,17 @@ instance IsString ByteString where
 
 instance Data ByteString where
   gfoldl f z txt = z packBytes `f` unpackBytes txt
-  toConstr _     = error "Data.ByteString.Lazy.ByteString.toConstr"
-  gunfold _ _    = error "Data.ByteString.Lazy.ByteString.gunfold"
-  dataTypeOf _   = mkNoRepType "Data.ByteString.Lazy.ByteString"
+  toConstr _     = packConstr
+  gunfold k z c = case constrIndex c of
+    1 -> k (z packBytes)
+    _ -> error "gunfold: unexpected constructor of lazy ByteString"
+  dataTypeOf _   = byteStringDataType
+
+packConstr :: Constr
+packConstr = mkConstr byteStringDataType "pack" [] Prefix
+
+byteStringDataType :: DataType
+byteStringDataType = mkDataType "Data.ByteString.Lazy.ByteString" [packConstr]
 
 ------------------------------------------------------------------------
 -- Packing and unpacking from lists

Data/ByteString/Short/Internal.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE BangPatterns             #-}
 {-# LANGUAGE CPP                      #-}
 {-# LANGUAGE DeriveDataTypeable       #-}
+{-# LANGUAGE DeriveGeneric            #-}
 {-# LANGUAGE DeriveLift               #-}
 {-# LANGUAGE ForeignFunctionInterface #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -235,6 +236,8 @@ import GHC.Exts
   , writeWord8Array#
   , unsafeFreezeByteArray#
   , touch# )
+import GHC.Generics
+  ( Generic )
 import GHC.IO hiding ( unsafeDupablePerformIO )
 import GHC.ForeignPtr
   ( ForeignPtr(ForeignPtr)
@@ -281,7 +284,7 @@ newtype ShortByteString =
   { unShortByteString :: ByteArray
   -- ^ @since 0.12.0.0
   }
-  deriving (Eq, TH.Lift, Data, NFData)
+  deriving (Eq, TH.Lift, Data, Generic, NFData)
 
 -- | Prior to @bytestring-0.12@ 'SBS' was a genuine constructor of 'ShortByteString',
 -- but now it is a bundled pattern synonym, provided as a compatibility shim.

bytestring.cabal

@@ -184,7 +184,8 @@ test-suite bytestring-tests
                     tasty,
                     tasty-quickcheck >= 0.8.1,
                     template-haskell,
-                    transformers >= 0.3
+                    transformers >= 0.3,
+                    syb
   ghc-options:      -fwarn-unused-binds
                     -threaded -rtsopts
   default-language: Haskell2010

tests/Properties/ByteString.hs

@@ -67,7 +67,9 @@ import Text.Read
 import Prelude hiding (head, tail)
 import Control.Arrow
 import Data.Char
+import Data.Data (toConstr, showConstr, Data)
 import Data.Foldable
+import Data.Generics.Text (gread, gshow)
 import qualified Data.List as List
 import qualified Data.List.NonEmpty as NE
 import Data.Semigroup
@@ -661,6 +663,17 @@ tests =
   , testProperty "fromString literal" $
     fromString "\0\1\2\3\4" == B.pack [0,1,2,3,4]
 #endif
+
+#ifndef BYTESTRING_SHORT
+  , testProperty "toConstr is pack" $
+    \(x :: BYTESTRING_TYPE) -> showConstr (toConstr x) === "pack"
+#ifndef BYTESTRING_CHAR8
+  , testProperty "gshow" $
+    \x -> gshow x === "(pack " ++ gshow (B.unpack x) ++ ")"
+#endif
+  , testProperty "gread . gshow = reads . show" $
+    \(x :: BYTESTRING_TYPE) -> gread (gshow x) === (reads (show x) :: [(BYTESTRING_TYPE, String)])
+#endif
   ]
 
 unsnoc :: [a] -> Maybe ([a], a)