PmCheck: Desugar string literal patterns with -XRebindableSyntax correctly (#18708)

Fixes #18708.

4 files changed, 38 insertions, 5 deletions

diff --git a/compiler/GHC/HsToCore/PmCheck/Types.hs b/compiler/GHC/HsToCore/PmCheck/Types.hs
index 3577a8d8ad..a4fad5f4b3 100644
--- a/compiler/GHC/HsToCore/PmCheck/Types.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Types.hs
@@ -350,16 +350,17 @@ coreExprAsPmLit e = case collectArgs e of
     -- Take care of -XRebindableSyntax. The last argument should be the (only)
     -- integer literal, otherwise we can't really do much about it.
     | [Lit l] <- dropWhile (not . is_lit) args
-    -- getOccFS because of -XRebindableSyntax
-    , getOccFS (idName x) == getOccFS fromIntegerName
+    , is_rebound_name x fromIntegerName
     -> literalToPmLit (literalType l) l >>= overloadPmLit (exprType e)
   (Var x, args)
     -- Similar to fromInteger case
     | [r] <- dropWhile (not . is_ratio) args
-    , getOccFS (idName x) == getOccFS fromRationalName
+    , is_rebound_name x fromRationalName
     -> coreExprAsPmLit r >>= overloadPmLit (exprType e)
-  (Var x, [Type _ty, _dict, s])
-    | idName x == fromStringName
+  (Var x, args)
+    | is_rebound_name x fromStringName
+    -- With -XRebindableSyntax or without: The first String argument is what we are after
+    , s:_ <- filter (eqType stringTy . exprType) args
     -- NB: Calls coreExprAsPmLit and then overloadPmLit, so that we return PmLitOverStrings
     -> coreExprAsPmLit s >>= overloadPmLit (exprType e)
   -- These last two cases handle String literals
@@ -382,6 +383,11 @@ coreExprAsPmLit e = case collectArgs e of
       | otherwise
       = False
 
+    -- | Compares the given Id to the Name based on OccName, to detect
+    -- -XRebindableSyntax.
+    is_rebound_name :: Id -> Name -> Bool
+    is_rebound_name x n = getOccFS (idName x) == getOccFS n
+
 instance Outputable PmLitValue where
   ppr (PmLitInt i)        = ppr i
   ppr (PmLitRat r)        = ppr (double (fromRat r)) -- good enough
diff --git a/testsuite/tests/pmcheck/should_compile/T18708.hs b/testsuite/tests/pmcheck/should_compile/T18708.hs
new file mode 100644
index 0000000000..8eafb69a76
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T18708.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE OverloadedStrings        #-}
+{-# LANGUAGE RebindableSyntax         #-}
+
+module A (main) where
+
+import           Prelude
+import           Data.Text
+
+
+fromString :: String -> Text
+fromString = pack
+
+y :: Text
+y = "y"
+
+main :: IO ()
+main =  do
+  case y of
+    "y" -> return ()
+  return ()
diff --git a/testsuite/tests/pmcheck/should_compile/T18708.stderr b/testsuite/tests/pmcheck/should_compile/T18708.stderr
new file mode 100644
index 0000000000..5949d92970
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T18708.stderr
@@ -0,0 +1,5 @@
+
+T18708.hs:18:3: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In a case alternative:
+        Patterns not matched: p where p is not one of {"y"}
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index bd5fc60f63..862c5e134a 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -148,6 +148,8 @@ test('T18572', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-incomplete-uni-patterns -fwarn-overlapping-patterns'])
 test('T18670', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T18708', normal, compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 
 # Other tests
 test('pmc001', [], compile,