diff options
| author | Ryan Scott <ryan.gl.scott@gmail.com> | 2021-04-27 19:02:03 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2021-05-12 20:27:10 -0400 |
| commit | 4a24635522790b0713de0f2eef4d1333fc8a4761 (patch) | |
| tree | e462b32a0e460c0685be36d99e375f56712fb054 | |
| parent | a7c9f8a79b2da9cb02e5b15147e33cebbb8b69c6 (diff) | |
| download | haskell-4a24635522790b0713de0f2eef4d1333fc8a4761.tar.gz | |
Propagate free variables in extract_lctxt correctly
This fixes an oversight in the implementation of `extract_lctxt` which
was introduced in commit ce85cffc. Fixes #19759.
(cherry picked from commit c2541c49f162f1d03b0ae55f47b9c76cc96df76f)
| -rw-r--r-- | compiler/GHC/Rename/HsType.hs | 2 | ||||
| -rw-r--r-- | testsuite/tests/th/T19759.hs | 25 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 1 |
3 files changed, 27 insertions, 1 deletions
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index a7f28b69cc..3a570e2e14 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -1911,7 +1911,7 @@ extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig }) = maybe [] extractHsTyRdrTyVars ksig extract_lctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> FreeKiTyVars -extract_lctxt Nothing = const [] +extract_lctxt Nothing = id extract_lctxt (Just ctxt) = extract_ltys (unLoc ctxt) extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)] diff --git a/testsuite/tests/th/T19759.hs b/testsuite/tests/th/T19759.hs new file mode 100644 index 0000000000..96c1684a0b --- /dev/null +++ b/testsuite/tests/th/T19759.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +module T19759 where + +import Language.Haskell.TH + +data T a where + MkT :: a -> b -> T a + +{- +pattern MkT' :: () => forall b. a -> b -> T a +pattern MkT' x y = MkT x y +-} + +$(do let mkT' = mkName "MkT'" + a <- newName "a" + b <- newName "b" + x <- newName "x" + y <- newName "y" + pure [ PatSynSigD mkT' $ ForallT [] [] $ ForallT [PlainTV b SpecifiedSpec] [] + $ ArrowT `AppT` VarT a `AppT` (ArrowT `AppT` VarT b `AppT` (ConT ''T `AppT` VarT a)) + , PatSynD mkT' (PrefixPatSyn [x, y]) ImplBidir $ + ConP 'MkT [] [VarP x, VarP y] + ]) + diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 36567db6e7..70342cc45a 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -522,3 +522,4 @@ test('T18740d', normal, compile_fail, ['']) test('T19363', normal, compile_and_run, ['']) test('T19377', normal, compile, ['']) test('T17804', normal, compile, ['']) +test('T19759', normal, compile, ['']) |