[Git][ghc/ghc][wip/T18708] PmCheck: Desugar string literal patterns with -XRebindableSyntax correctly (#18708)

[Sebastian Graf]

Sebastian Graf pushed to branch wip/T18708 at Glasgow Haskell Compiler / GHC


Commits:
075ce0af by Sebastian Graf at 2020-09-23T10:06:10+02:00
PmCheck: Desugar string literal patterns with -XRebindableSyntax correctly (#18708)

Fixes #18708.

- - - - -


4 changed files:

- compiler/GHC/HsToCore/PmCheck/Types.hs
- + testsuite/tests/pmcheck/should_compile/T18708.hs
- + testsuite/tests/pmcheck/should_compile/T18708.stderr
- testsuite/tests/pmcheck/should_compile/all.T


Changes:

=====================================
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


=====================================
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 ()


=====================================
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"}


=====================================
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,



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/075ce0af6e59493d7efa2502630e40b11ca887c1

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/075ce0af6e59493d7efa2502630e40b11ca887c1
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200923/2693111a/attachment-0001.html>