Skip to content

Commit

Permalink
Implement instance Data (#614)
Browse files Browse the repository at this point in the history
* 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]>
(cherry picked from commit 1b9e6ec)
  • Loading branch information
Bodigrim authored and clyring committed Feb 1, 2024
1 parent 2fbb783 commit 3bded3c
Show file tree
Hide file tree
Showing 6 changed files with 46 additions and 12 deletions.
4 changes: 2 additions & 2 deletions .github/workflows/ci.yml
Original file line number Diff line number Diff line change
Expand Up @@ -135,11 +135,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
Expand Down
16 changes: 12 additions & 4 deletions Data/ByteString/Internal/Type.hs
Original file line number Diff line number Diff line change
Expand Up @@ -137,7 +137,7 @@ import Data.Bits ((.&.))
import Data.Char (ord)
import Data.Word

import Data.Data (Data(..), mkNoRepType)
import Data.Data (Data(..), mkConstr, mkNoRepType, Constr, DataType, Fixity(Prefix), constrIndex)

import GHC.Base (nullAddr#,realWorld#,unsafeChr)
import GHC.Exts (IsList(..), Addr#, minusAddr#)
Expand Down Expand Up @@ -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 = mkNoRepType "Data.ByteString.ByteString"

-- | @since 0.11.2.0
instance TH.Lift ByteString where
Expand Down
16 changes: 12 additions & 4 deletions Data/ByteString/Lazy/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -69,7 +69,7 @@ import Control.DeepSeq (NFData, rnf)

import Data.String (IsString(..))

import Data.Data (Data(..), mkNoRepType)
import Data.Data (Data(..), mkConstr, mkNoRepType, Constr, DataType, Fixity(Prefix), constrIndex)

import GHC.Exts (IsList(..))

Expand Down Expand Up @@ -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 = mkNoRepType "Data.ByteString.Lazy.ByteString"

------------------------------------------------------------------------
-- Packing and unpacking from lists
Expand Down
5 changes: 4 additions & 1 deletion Data/ByteString/Short/Internal.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
Expand Down Expand Up @@ -235,6 +236,8 @@ import GHC.Exts
, writeWord8Array#
, unsafeFreezeByteArray#
, touch# )
import GHC.Generics
( Generic )
import GHC.IO hiding ( unsafeDupablePerformIO )
import GHC.ForeignPtr
( ForeignPtr(ForeignPtr)
Expand Down Expand Up @@ -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.
Expand Down
3 changes: 2 additions & 1 deletion bytestring.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
14 changes: 14 additions & 0 deletions tests/Properties/ByteString.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -660,6 +662,18 @@ tests =
\s -> fromString s == B.pack (map (fromIntegral . ord :: Char -> Word8) s)
, 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
-- -- gread is broken on bytestring-0.12 and fixed on bytestring-master
-- , testProperty "gread . gshow = reads . show" $
-- \(x :: BYTESTRING_TYPE) -> gread (gshow x) === (reads (show x) :: [(BYTESTRING_TYPE, String)])
#endif
]

Expand Down

0 comments on commit 3bded3c

Please sign in to comment.