diff options
| author | Zubin Duggal <zubin.duggal@gmail.com> | 2022-01-17 15:43:11 +0530 |
|---|---|---|
| committer | Zubin Duggal <zubin.duggal@gmail.com> | 2022-03-11 18:25:23 +0530 |
| commit | c3a6babd9c0901344b5b733278c21da00ce0fe9a (patch) | |
| tree | 4c878ad429b13e35f2b9703e03e7b3ae9d99a872 | |
| parent | 844cf1e14fe031c9ed7597b00a1183ad9b1ccc0a (diff) | |
| download | haskell-wip/neg-lits.tar.gz | |
TH: allow negative patterns in quotes (#20711)wip/neg-lits
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 5c95f14341..9d91788eea 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -2078,7 +2078,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, ['']) |