From 075ce0af6e59493d7efa2502630e40b11ca887c1 Mon Sep 17 00:00:00 2001
From: Sebastian Graf <sebastian.graf@kit.edu>
Date: Tue, 22 Sep 2020 18:01:09 +0200
Subject: PmCheck: Desugar string literal patterns with -XRebindableSyntax
 correctly (#18708)

Fixes #18708.
---
 compiler/GHC/HsToCore/PmCheck/Types.hs               | 16 +++++++++++-----
 testsuite/tests/pmcheck/should_compile/T18708.hs     | 20 ++++++++++++++++++++
 testsuite/tests/pmcheck/should_compile/T18708.stderr |  5 +++++
 testsuite/tests/pmcheck/should_compile/all.T         |  2 ++
 4 files changed, 38 insertions(+), 5 deletions(-)
 create mode 100644 testsuite/tests/pmcheck/should_compile/T18708.hs
 create mode 100644 testsuite/tests/pmcheck/should_compile/T18708.stderr

diff --git a/compiler/GHC/HsToCore/PmCheck/Types.hs b/compiler/GHC/HsToCore/PmCheck/Types.hs
index 12bd5f32fb..02c003d4e8 100644
--- a/compiler/GHC/HsToCore/PmCheck/Types.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Types.hs
@@ -349,16 +349,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
@@ -381,6 +382,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 c2f14ce664..30c368b33c 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -146,6 +146,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,
-- 
cgit v1.2.1