From f6303dd0ab9954338a9179f63d06c177337f0f88 Mon Sep 17 00:00:00 2001
From: Li-yao Xia <lysxia@gmail.com>
Date: Fri, 28 Jul 2023 16:14:55 +0100
Subject: [PATCH] Make Lift Text work under RebindableSyntax

The Lift Int instance produces a polymorphic literal, which desugars to
fromIntegral under RebindableSyntax. Fixing that instance in base may be
too much of a breaking change if a lot of code relies on the accidental
polymorphism. We can at least fix Lift Text by not relying on Lift Int.
---
 src/Data/Text.hs                    |  6 ++++--
 tests/Tests.hs                      |  2 ++
 tests/Tests/RebindableSyntaxTest.hs | 14 ++++++++++++++
 text.cabal                          |  1 +
 4 files changed, 21 insertions(+), 2 deletions(-)
 create mode 100644 tests/Tests/RebindableSyntaxTest.hs

diff --git a/src/Data/Text.hs b/src/Data/Text.hs
index c2ab0901..0fca9bd9 100644
--- a/src/Data/Text.hs
+++ b/src/Data/Text.hs
@@ -418,8 +418,10 @@ instance TH.Lift Text where
 #if MIN_VERSION_template_haskell(2,16,0)
   lift txt = do
     let (ptr, len) = unsafePerformIO $ asForeignPtr txt
-    let lenInt = P.fromIntegral len
-    TH.appE (TH.appE (TH.varE 'unpackCStringLen#) (TH.litE . TH.bytesPrimL $ TH.mkBytes ptr 0 lenInt)) (TH.lift lenInt)
+        bytesQ = TH.litE . TH.bytesPrimL $ TH.mkBytes ptr 0 (P.fromIntegral len)
+        lenQ = liftInt (P.fromIntegral len)
+        liftInt n = (TH.appE (TH.conE 'Exts.I#) (TH.litE (TH.IntPrimL n)))
+    TH.varE 'unpackCStringLen# `TH.appE` bytesQ `TH.appE` lenQ
 #else
   lift = TH.appE (TH.varE 'pack) . TH.stringE . unpack
 #endif
diff --git a/tests/Tests.hs b/tests/Tests.hs
index 98d1ec00..17e132e6 100644
--- a/tests/Tests.hs
+++ b/tests/Tests.hs
@@ -9,10 +9,12 @@ import Test.Tasty (defaultMain, testGroup)
 import qualified Tests.Lift as Lift
 import qualified Tests.Properties as Properties
 import qualified Tests.Regressions as Regressions
+import qualified Tests.RebindableSyntaxTest as RST
 
 main :: IO ()
 main = defaultMain $ testGroup "All"
   [ Lift.tests
   , Properties.tests
   , Regressions.tests
+  , RST.tests
   ]
diff --git a/tests/Tests/RebindableSyntaxTest.hs b/tests/Tests/RebindableSyntaxTest.hs
new file mode 100644
index 00000000..ffe90b6a
--- /dev/null
+++ b/tests/Tests/RebindableSyntaxTest.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE RebindableSyntax, TemplateHaskell #-}
+
+module Tests.RebindableSyntaxTest where
+
+import qualified Data.Text as Text
+import Language.Haskell.TH.Syntax (lift)
+import Test.Tasty.HUnit (testCase, assertEqual)
+import Test.Tasty (TestTree, testGroup)
+import Prelude (($))
+
+tests :: TestTree
+tests = testGroup "RebindableSyntax"
+  [ testCase "test" $ assertEqual "a" $(lift (Text.pack "a")) (Text.pack "a")
+  ]
diff --git a/text.cabal b/text.cabal
index b9674a83..c61111a6 100644
--- a/text.cabal
+++ b/text.cabal
@@ -251,6 +251,7 @@ test-suite tests
     Tests.Properties.Text
     Tests.Properties.Transcoding
     Tests.QuickCheckUtils
+    Tests.RebindableSyntaxTest
     Tests.Regressions
     Tests.SlowFunctions
     Tests.Utils