diff options
| author | Zubin Duggal <zubin.duggal@gmail.com> | 2022-01-17 15:43:11 +0530 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-03-16 02:28:24 -0400 |
| commit | a33d10452c261ab39ce8c0954bac9053c212a6cc (patch) | |
| tree | 9844ab433b4400a1466c5e8edd5a929e0a70203f | |
| parent | c1fed9da095303591c37c53bad5f5559381048d7 (diff) | |
| download | haskell-a33d10452c261ab39ce8c0954bac9053c212a6cc.tar.gz | |
TH: allow negative patterns in quotes (#20711)
We still don't allow negative overloaded patterns. Earler all negative patterns
were treated as negative overloaded patterns. Now, we expliclty check the
extension field to see if the pattern is actually a negative overloaded pattern
| -rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 9 | ||||
| -rw-r--r-- | testsuite/tests/th/T20711.hs | 11 | ||||
| -rw-r--r-- | testsuite/tests/th/T20711.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 1 |
4 files changed, 22 insertions, 1 deletions
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 34282ec363..215b8f4da8 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -2077,7 +2077,14 @@ repP (ConPat NoExtField dc details) repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l ; repPlit a } repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } -repP p@(NPat _ _ (Just _) _) = notHandled (ThNegativeOverloadedPatterns p) +repP p@(NPat _ (L _ l) (Just _) _) + | OverLitRn rebindable _ <- ol_ext l + , rebindable = notHandled (ThNegativeOverloadedPatterns p) + | HsIntegral i <- ol_val l = do { a <- repOverloadedLiteral l{ol_val = HsIntegral (negateIntegralLit i)} + ; repPlit a } + | HsFractional i <- ol_val l = do { a <- repOverloadedLiteral l{ol_val = HsFractional (negateFractionalLit i)} + ; repPlit a } + | otherwise = notHandled (ThExoticPattern p) repP (SigPat _ p t) = do { p' <- repLP p ; t' <- repLTy (hsPatSigType t) ; repPsig p' t' } diff --git a/testsuite/tests/th/T20711.hs b/testsuite/tests/th/T20711.hs new file mode 100644 index 0000000000..f18b672ab5 --- /dev/null +++ b/testsuite/tests/th/T20711.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +main :: IO () +main = do + x <- [d| f (-1) = () |] + putStrLn $ pprint x + y <- [d| f (-10) = () |] + putStrLn $ pprint y diff --git a/testsuite/tests/th/T20711.stdout b/testsuite/tests/th/T20711.stdout new file mode 100644 index 0000000000..f14e7b3479 --- /dev/null +++ b/testsuite/tests/th/T20711.stdout @@ -0,0 +1,2 @@ +f_0 (-1) = GHC.Tuple.() +f_0 (-10) = GHC.Tuple.() diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 165ef6a7e2..01a64a3848 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -548,3 +548,4 @@ test('T21038', normal, compile, ['']) test('T20842', normal, compile_and_run, ['']) test('T15433a', [extra_files(['T15433_aux.hs'])], multimod_compile_fail, ['T15433a', '-v0']) test('T15433b', [extra_files(['T15433_aux.hs'])], multimod_compile, ['T15433b', '-v0']) +test('T20711', normal, compile_and_run, ['']) |