diff options
| author | Mario Blažević <blamario@protonmail.com> | 2022-08-13 18:36:04 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-08-22 22:06:21 -0400 |
| commit | fe4ff0f7cd50361cade3dd4bef15065dff075bfc (patch) | |
| tree | 3b47b4f98a83882d3f2893c569869e7605fd78c0 | |
| parent | b946232c328ed88fc34a7c83a335b2f5a4f777ed (diff) | |
| download | haskell-fe4ff0f7cd50361cade3dd4bef15065dff075bfc.tar.gz | |
Fix and test for issue #21723
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Ppr.hs | 27 | ||||
| -rw-r--r-- | testsuite/tests/th/T21723.hs | 8 | ||||
| -rw-r--r-- | testsuite/tests/th/T21723.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 1 |
4 files changed, 26 insertions, 12 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index d562ec2ddc..585b9bb295 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -817,10 +817,10 @@ pprType _ StarT = char '*' pprType _ ConstraintT = text "Constraint" pprType _ (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k) pprType _ WildCardT = char '_' -pprType _ t@(InfixT {}) = parens (pprInfixT t) -pprType _ t@(UInfixT {}) = parens (pprInfixT t) -pprType _ t@(PromotedInfixT {}) = parens (pprInfixT t) -pprType _ t@(PromotedUInfixT {}) = parens (pprInfixT t) +pprType p t@(InfixT {}) = pprInfixT p t +pprType p t@(UInfixT {}) = pprInfixT p t +pprType p t@(PromotedInfixT {}) = pprInfixT p t +pprType p t@(PromotedUInfixT {}) = pprInfixT p t pprType _ (ParensT t) = parens (pprType noPrec t) pprType p (ImplicitParamT n ty) = parensIf (p >= sigPrec) $ text ('?':n) <+> text "::" <+> pprType sigPrec ty @@ -836,15 +836,18 @@ pprType p t@AppKindT{} = pprTyApp p (split t) pprParendType :: Type -> Doc pprParendType = pprType appPrec -pprInfixT :: Type -> Doc -pprInfixT = \case - (InfixT x n y) -> with x n y "" ppr - (UInfixT x n y) -> with x n y "" pprInfixT - (PromotedInfixT x n y) -> with x n y "'" ppr - (PromotedUInfixT x n y) -> with x n y "'" pprInfixT - t -> ppr t +pprInfixT :: Precedence -> Type -> Doc +pprInfixT p = \case + InfixT x n y -> with x n y "" opPrec + UInfixT x n y -> with x n y "" unopPrec + PromotedInfixT x n y -> with x n y "'" opPrec + PromotedUInfixT x n y -> with x n y "'" unopPrec + t -> pprParendType t where - with x n y prefix ppr' = ppr' x <+> text prefix <> pprName' Infix n <+> ppr' y + with x n y prefix p' = + parensIf + (p >= p') + (pprType opPrec x <+> text prefix <> pprName' Infix n <+> pprType opPrec y) instance Ppr Type where ppr = pprType noPrec diff --git a/testsuite/tests/th/T21723.hs b/testsuite/tests/th/T21723.hs new file mode 100644 index 0000000000..17a0e73367 --- /dev/null +++ b/testsuite/tests/th/T21723.hs @@ -0,0 +1,8 @@ +module Main where + +import Language.Haskell.TH + +main :: IO () +main = do + putStrLn $ pprint (InfixT (ArrowT `AppT` StarT `AppT` StarT) (mkName ":>:") StarT) + putStrLn $ pprint (InfixT (ParensT $ ArrowT `AppT` StarT `AppT` StarT) (mkName ":>:") StarT) diff --git a/testsuite/tests/th/T21723.stdout b/testsuite/tests/th/T21723.stdout new file mode 100644 index 0000000000..b1ee8ff36b --- /dev/null +++ b/testsuite/tests/th/T21723.stdout @@ -0,0 +1,2 @@ +(* -> *) :>: * +(* -> *) :>: * diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index a475e9d5bb..3087fd19b2 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -553,3 +553,4 @@ test('T20711', normal, compile_and_run, ['']) test('T20868', normal, compile_and_run, ['']) test('Lift_ByteArray', normal, compile_and_run, ['']) test('T21920', normal, compile_and_run, ['']) +test('T21723', normal, compile_and_run, ['']) |