Add Lift instances

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'.

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,60 @@
+{-# 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 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
+    ]
+  ]