Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
6d0ce0eb by Sebastian Graf at 2020-09-24T13:17:07-04: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
=====================================
@@ -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
=====================================
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
=====================================
@@ -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,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d0ce0eb772bf69c57e14f30c16c606ab5035816
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d0ce0eb772bf69c57e14f30c16c606ab5035816
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/20200924/4b894355/attachment-0001.html>