TH Lift

.github/workflows/ci.yml

@@ -42,18 +42,20 @@ jobs:
         key: ${{ runner.os }}-${{ matrix.ghc }}
     # We rebuild tests several times to avoid intermittent failures on Windows
     # https://github.com/haskell/actions/issues/36
+    # We also use --enable-tests and --enable-benchmarks to avoid
+    # test and bench commands from reconfiguring and thus rebuilding.
     - name: Test
       run: |
         cabal sdist -z -o .
         cabal get bytestring-*.tar.gz
         cd bytestring-*/
-        bld() { cabal build bytestring:tests; }
+        bld() { cabal build bytestring:tests --enable-tests --enable-benchmarks; }
         bld || bld || bld
-        cabal test --test-show-details=direct all
+        cabal test --enable-tests --enable-benchmarks --test-show-details=direct all -j1
     - name: Bench
       run: |
         cd bytestring-*/
-        cabal bench --benchmark-option=-l all
+        cabal bench --enable-tests --enable-benchmarks --benchmark-option=-l all
     - name: Haddock
       run: cabal haddock
 

Data/ByteString/Internal.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE PatternSynonyms, ViewPatterns #-}
 {-# LANGUAGE Unsafe #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 {-# OPTIONS_HADDOCK not-home #-}
 
 -- |
@@ -163,6 +164,9 @@ import GHC.Types                (Int (..))
 import GHC.ForeignPtr           (unsafeWithForeignPtr)
 #endif
 
+import qualified Language.Haskell.TH.Lib as TH
+import qualified Language.Haskell.TH.Syntax as TH
+
 #if !MIN_VERSION_base(4,15,0)
 unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
 unsafeWithForeignPtr = withForeignPtr
@@ -270,6 +274,24 @@ instance Data ByteString where
   gunfold _ _    = error "Data.ByteString.ByteString.gunfold"
   dataTypeOf _   = mkNoRepType "Data.ByteString.ByteString"
 
+-- | @since 0.11.2.0
+instance TH.Lift ByteString where
+#if MIN_VERSION_template_haskell(2,16,0)
+  lift (BS ptr len) = [| unsafePackLenLiteral |]
+    `TH.appE` TH.litE (TH.integerL (fromIntegral len))
+    `TH.appE` TH.litE (TH.BytesPrimL $ TH.Bytes ptr 0 (fromIntegral len))
+#else
+  lift bs@(BS _ len) = [| unsafePackLenLiteral |]
+    `TH.appE` TH.litE (TH.integerL (fromIntegral len))
+    `TH.appE` TH.litE (TH.StringPrimL $ unpackBytes bs)
+#endif
+
+#if MIN_VERSION_template_haskell(2,17,0)
+  liftTyped = TH.unsafeCodeCoerce . TH.lift
+#elif MIN_VERSION_template_haskell(2,16,0)
+  liftTyped = TH.unsafeTExpCoerce . TH.lift
+#endif
+
 ------------------------------------------------------------------------
 -- Internal indexing
 

Data/ByteString/Lazy/Internal.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveLift #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE Unsafe #-}
 {-# OPTIONS_HADDOCK not-home #-}
@@ -70,6 +71,8 @@ import Data.Data                (Data(..), mkNoRepType)
 
 import GHC.Exts                 (IsList(..))
 
+import qualified Language.Haskell.TH.Syntax as TH
+
 -- | A space-efficient representation of a 'Word8' vector, supporting many
 -- efficient operations.
 --
@@ -78,7 +81,7 @@ import GHC.Exts                 (IsList(..))
 -- 8-bit characters.
 --
 data ByteString = Empty | Chunk {-# UNPACK #-} !S.ByteString ByteString
-    deriving (Typeable)
+    deriving (Typeable, TH.Lift)
 -- See 'invariant' function later in this module for internal invariants.
 
 -- | Type synonym for the lazy flavour of 'ByteString'.

Data/ByteString/Short/Internal.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 {-# LANGUAGE Unsafe #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 {-# OPTIONS_HADDOCK not-home #-}
 
 -- |
@@ -44,7 +45,8 @@ module Data.ByteString.Short.Internal (
     useAsCStringLen
   ) where
 
-import Data.ByteString.Internal (ByteString(..), accursedUnutterablePerformIO, c_strlen)
+import Data.ByteString.Internal (ByteString(..), accursedUnutterablePerformIO)
+import qualified Data.ByteString.Internal as BS
 
 import Data.Typeable    (Typeable)
 import Data.Data        (Data(..), mkNoRepType)
@@ -89,6 +91,9 @@ import Prelude ( Eq(..), Ord(..), Ordering(..), Read(..), Show(..)
                , return
                , Maybe(..) )
 
+import qualified Language.Haskell.TH.Lib as TH
+import qualified Language.Haskell.TH.Syntax as TH
+
 -- | A compact representation of a 'Word8' vector.
 --
 -- It has a lower memory overhead than a 'ByteString' and does not
@@ -105,6 +110,28 @@ import Prelude ( Eq(..), Ord(..), Ordering(..), Read(..), Show(..)
 data ShortByteString = SBS ByteArray#
     deriving Typeable
 
+-- | @since 0.11.2.0
+instance TH.Lift ShortByteString where
+#if MIN_VERSION_template_haskell(2,16,0)
+  lift sbs = [| unsafePackLenLiteral |]
+    `TH.appE` TH.litE (TH.integerL (fromIntegral len))
+    `TH.appE` TH.litE (TH.BytesPrimL $ TH.Bytes ptr 0 (fromIntegral len))
+    where
+      BS ptr len = fromShort sbs
+#else
+  lift sbs = [| unsafePackLenLiteral |]
+    `TH.appE` TH.litE (TH.integerL (fromIntegral len))
+    `TH.appE` TH.litE (TH.StringPrimL $ BS.unpackBytes bs)
+    where
+      bs@(BS _ len) = fromShort sbs
+#endif
+
+#if MIN_VERSION_template_haskell(2,17,0)
+  liftTyped = TH.unsafeCodeCoerce . TH.lift
+#elif MIN_VERSION_template_haskell(2,16,0)
+  liftTyped = TH.unsafeTExpCoerce . TH.lift
+#endif
+
 -- The ByteArray# representation is always word sized and aligned but with a
 -- known byte length. Our representation choice for ShortByteString is to leave
 -- the 0--3 trailing bytes undefined. This means we can use word-sized writes,
@@ -200,6 +227,9 @@ indexError sbs i =
   error $ "Data.ByteString.Short.index: error in array index; " ++ show i
        ++ " not in range [0.." ++ show (length sbs) ++ ")"
 
+unsafePackLenLiteral :: Int -> Addr# -> ShortByteString
+unsafePackLenLiteral len addr# =
+    accursedUnutterablePerformIO $ createFromPtr (Ptr addr#) len
 
 ------------------------------------------------------------------------
 -- Internal utils
@@ -527,7 +557,7 @@ copyByteArray# = GHC.Exts.copyByteArray#
 -- @since 0.10.10.0
 packCString :: CString -> IO ShortByteString
 packCString cstr = do
-  len <- c_strlen cstr
+  len <- BS.c_strlen cstr
   packCStringLen (cstr, fromIntegral len)
 
 -- | /O(n)./ Construct a new @ShortByteString@ from a @CStringLen@. The

bytestring.cabal

@@ -70,7 +70,7 @@ source-repository head
   location: https://github.com/haskell/bytestring
 
 library
-  build-depends:     base >= 4.9 && < 5, ghc-prim, deepseq
+  build-depends:     base >= 4.9 && < 5, ghc-prim, deepseq, template-haskell
 
   exposed-modules:   Data.ByteString
                      Data.ByteString.Char8
@@ -165,6 +165,15 @@ test-suite test-builder
   ghc-options:      -Wall -fwarn-tabs -threaded -rtsopts
   default-language: Haskell2010
 
+test-suite bytestring-th
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   tests
+  main-is:          bytestring-th.hs
+  other-extensions: TemplateHaskell
+  build-depends:    base, bytestring, template-haskell, tasty, tasty-hunit
+  ghc-options:      -Wall -fwarn-tabs -threaded -rtsopts
+  default-language: Haskell2010
+
 benchmark bytestring-bench
   main-is:          BenchAll.hs
   other-modules:    BenchBoundsCheckFusion

tests/bytestring-th.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Main (main) where
+
+import           Test.Tasty (defaultMain, testGroup)
+import           Test.Tasty.HUnit (testCase, (@=?))
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Short as SBS
+import qualified Language.Haskell.TH.Syntax as TH
+
+main :: IO ()
+main = defaultMain $ testGroup "bytestring-th"
+  [ testGroup "strict"
+    [ testCase "normal" $ do
+        let bs :: BS.ByteString
+            bs = "foobar"
+
+        bs @=? $(TH.lift $ BS.pack [102,111,111,98,97,114])
+
+    , testCase "binary" $ do
+        let bs :: BS.ByteString
+            bs = "\0\1\2\3\0\1\2\3"
+
+        bs @=? $(TH.lift $ BS.pack [0,1,2,3,0,1,2,3])
+
+#if MIN_VERSION_template_haskell(2,16,0)
+    , testCase "typed" $ do
+        let bs :: BS.ByteString
+            bs = "\0\1\2\3\0\1\2\3"
+
+        bs @=? $$(TH.liftTyped $ BS.pack [0,1,2,3,0,1,2,3])
+#endif
+    ]
+
+  , testGroup "lazy"
+    [ testCase "normal" $ do
+        let bs :: LBS.ByteString
+            bs = "foobar"
+
+        bs @=? $(TH.lift $ LBS.pack [102,111,111,98,97,114])
+
+    , testCase "binary" $ do
+        let bs :: LBS.ByteString
+            bs = "\0\1\2\3\0\1\2\3"
+
+        -- print $ LBS.unpack bs
+        -- print $ LBS.unpack $(TH.lift $ LBS.pack [0,1,2,3,0,1,2,3])
+
+        bs @=? $(TH.lift $ LBS.pack [0,1,2,3,0,1,2,3])
+
+#if MIN_VERSION_template_haskell(2,16,0)
+    , testCase "typed" $ do
+        let bs :: LBS.ByteString
+            bs = "\0\1\2\3\0\1\2\3"
+
+        bs @=? $$(TH.liftTyped $ LBS.pack [0,1,2,3,0,1,2,3])
+#endif
+    ]
+
+  , testGroup "short"
+    [ testCase "normal" $ do
+        let bs :: SBS.ShortByteString
+            bs = "foobar"
+
+        bs @=? $(TH.lift $ SBS.pack [102,111,111,98,97,114])
+
+    , testCase "binary" $ do
+        let bs :: SBS.ShortByteString
+            bs = "\0\1\2\3\0\1\2\3"
+
+        bs @=? $(TH.lift $ SBS.pack [0,1,2,3,0,1,2,3])
+
+#if MIN_VERSION_template_haskell(2,16,0)
+    , testCase "typed" $ do
+        let bs :: SBS.ShortByteString
+            bs = "\0\1\2\3\0\1\2\3"
+
+        bs @=? $$(TH.liftTyped $ SBS.pack [0,1,2,3,0,1,2,3])
+#endif
+    ]
+  ]