diff options
| -rw-r--r-- | compiler/hsSyn/Convert.hs | 30 | ||||
| -rw-r--r-- | compiler/hsSyn/HsDecls.hs | 5 | ||||
| -rw-r--r-- | compiler/hsSyn/HsTypes.hs | 13 | ||||
| -rw-r--r-- | testsuite/tests/printer/Makefile | 12 | ||||
| -rw-r--r-- | testsuite/tests/printer/T14289.hs | 32 | ||||
| -rw-r--r-- | testsuite/tests/printer/T14289.stdout | 16 | ||||
| -rw-r--r-- | testsuite/tests/printer/T14289b.hs | 42 | ||||
| -rw-r--r-- | testsuite/tests/printer/T14289b.stdout | 16 | ||||
| -rw-r--r-- | testsuite/tests/printer/T14289c.hs | 40 | ||||
| -rw-r--r-- | testsuite/tests/printer/T14289c.stdout | 16 | ||||
| -rw-r--r-- | testsuite/tests/printer/all.T | 3 |
11 files changed, 219 insertions, 6 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index bffb2028c3..4336243e91 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -1330,14 +1330,38 @@ mk_apps head_ty (ty:tys) = ; p_ty <- add_parens ty ; mk_apps (HsAppTy head_ty' p_ty) tys } where - add_parens t@(L _ HsAppTy{}) = returnL (HsParTy t) - add_parens t@(L _ HsFunTy{}) = returnL (HsParTy t) - add_parens t = return t + -- See Note [Adding parens for splices] + add_parens t + | isCompoundHsType t = returnL (HsParTy t) + | otherwise = return t wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs) wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t) wrap_apps t = return t +-- --------------------------------------------------------------------- +-- Note [Adding parens for splices] +{- +The hsSyn representation of parsed source explicitly contains all the original +parens, as written in the source. + +When a Template Haskell (TH) splice is evaluated, the original splice is first +renamed and type checked and then finally converted to core in DsMeta. This core +is then run in the TH engine, and the result comes back as a TH AST. + +In the process, all parens are stripped out, as they are not needed. + +This Convert module then converts the TH AST back to hsSyn AST. + +In order to pretty-print this hsSyn AST, parens need to be adde back at certain +points so that the code is readable with its original meaning. + +So scattered through Convert.hs are various points where parens are added. + +See (among other closed issued) https://ghc.haskell.org/trac/ghc/ticket/14289 +-} +-- --------------------------------------------------------------------- + -- | Constructs an arrow type with a specified return type mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs) mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 35fccd3396..55d43fd058 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -1106,8 +1106,9 @@ instance (SourceTextX pass, OutputableBndrId pass) -- This complexity is to distinguish between -- deriving Show -- deriving (Show) - pp_dct [a@(HsIB { hsib_body = L _ HsAppsTy{} })] = parens (ppr a) - pp_dct [a] = ppr a + pp_dct [a@(HsIB { hsib_body = ty })] + | isCompoundHsType ty = parens (ppr a) + | otherwise = ppr a pp_dct _ = parens (interpp'SP dct) data NewOrData diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index e9fc71bdd7..f5b4149f99 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -65,7 +65,8 @@ module HsTypes ( -- Printing pprHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra, - pprHsContext, pprHsContextNoArrow, pprHsContextMaybe + pprHsContext, pprHsContextNoArrow, pprHsContextMaybe, + isCompoundHsType ) where import GhcPrelude @@ -1365,3 +1366,13 @@ ppr_app_ty (HsAppPrefix ty) = ppr_mono_lty ty ppr_tylit :: HsTyLit -> SDoc ppr_tylit (HsNumTy _ i) = integer i ppr_tylit (HsStrTy _ s) = text (show s) + + +-- | Return True for compound types that will need parens. +isCompoundHsType :: LHsType pass -> Bool +isCompoundHsType (L _ HsAppTy{} ) = True +isCompoundHsType (L _ HsAppsTy{}) = True +isCompoundHsType (L _ HsEqTy{} ) = True +isCompoundHsType (L _ HsFunTy{} ) = True +isCompoundHsType (L _ HsOpTy{} ) = True +isCompoundHsType _ = False diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile index 4565e83b4d..17fc65215f 100644 --- a/testsuite/tests/printer/Makefile +++ b/testsuite/tests/printer/Makefile @@ -214,6 +214,18 @@ T13550: T13942: $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13942.hs +.PHONY: T14289 +T14289: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289.hs + +.PHONY: T14289b +T14289b: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289b.hs + +.PHONY: T14289c +T14289c: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289c.hs + .PHONY: T14306 T14306: $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14306.hs diff --git a/testsuite/tests/printer/T14289.hs b/testsuite/tests/printer/T14289.hs new file mode 100644 index 0000000000..04b9176c69 --- /dev/null +++ b/testsuite/tests/printer/T14289.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-} + +import Language.Haskell.TH + +class C a b + +$([d| data Foo a = Foo a deriving (C a) |]) + +{- + +Note: to debug + +~/inplace/bin/ghc-stage2 --interactive +load the following +---------------------------------------- +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-} + +import Language.Haskell.TH + +class C a b + +main :: IO () +main = putStrLn $([d| data Foo a = Foo a deriving (C a) |] >>= stringE . show) + +---------------------------------------- + +-} diff --git a/testsuite/tests/printer/T14289.stdout b/testsuite/tests/printer/T14289.stdout new file mode 100644 index 0000000000..3f0754adca --- /dev/null +++ b/testsuite/tests/printer/T14289.stdout @@ -0,0 +1,16 @@ +T14289.hs:10:3-42: Splicing declarations + [d| data Foo a + = Foo a + deriving (C a) |] + ======> + data Foo a + = Foo a + deriving (C a) +T14289.ppr.hs:(7,3)-(9,25): Splicing declarations + [d| data Foo a + = Foo a + deriving (C a) |] + ======> + data Foo a + = Foo a + deriving (C a) diff --git a/testsuite/tests/printer/T14289b.hs b/testsuite/tests/printer/T14289b.hs new file mode 100644 index 0000000000..3ff39805d6 --- /dev/null +++ b/testsuite/tests/printer/T14289b.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-} + +import Language.Haskell.TH + +class (a `C` b) c + +$([d| data Foo a = Foo a deriving (y `C` z) |]) + +{- + +Note: to debug + +~/inplace/bin/ghc-stage2 --interactive +load the following +---------------------------------------- +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-} + +import Language.Haskell.TH + +class (a `C` b) c + +main :: IO () +main + = putStrLn $([d| data Foo a = Foo a deriving (y `C` z) |] >>= stringE . show) + +---------------------------------------- +Bceomes + + +[DataD [] Foo_0 [PlainTV a_2] Nothing + [NormalC Foo_1 [(Bang NoSourceUnpackedness NoSourceStrictness,VarT a_2)]] + [DerivClause Nothing + [AppT (AppT (ConT Main.C) (VarT y_6989586621679027885)) + (VarT z_6989586621679027886)]]] + +-} diff --git a/testsuite/tests/printer/T14289b.stdout b/testsuite/tests/printer/T14289b.stdout new file mode 100644 index 0000000000..5d4b248ac3 --- /dev/null +++ b/testsuite/tests/printer/T14289b.stdout @@ -0,0 +1,16 @@ +T14289b.hs:11:3-46: Splicing declarations + [d| data Foo a + = Foo a + deriving (y `C` z) |] + ======> + data Foo a + = Foo a + deriving (C y z) +T14289b.ppr.hs:(8,3)-(10,29): Splicing declarations + [d| data Foo a + = Foo a + deriving (y `C` z) |] + ======> + data Foo a + = Foo a + deriving (C y z) diff --git a/testsuite/tests/printer/T14289c.hs b/testsuite/tests/printer/T14289c.hs new file mode 100644 index 0000000000..6e58df1a54 --- /dev/null +++ b/testsuite/tests/printer/T14289c.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-} + +import Language.Haskell.TH + +$([d| data Foo a = Foo a deriving (a ~ a) |]) + +{- + +Note: to debug + +~/inplace/bin/ghc-stage2 --interactive +load the following +---------------------------------------- +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-} + +import Language.Haskell.TH + +class (a `C` b) c + +main :: IO () +main + = putStrLn $([d| data Foo a = Foo a deriving (a ~ a) |] >>= stringE . show) + +---------------------------------------- +Becomes + +[DataD [] Foo_0 [PlainTV a_2] Nothing + [NormalC Foo_1 [(Bang NoSourceUnpackedness NoSourceStrictness,VarT a_2)]] + [DerivClause Nothing + [AppT (AppT EqualityT (VarT a_2)) + (VarT a_2)]]] + + +-} diff --git a/testsuite/tests/printer/T14289c.stdout b/testsuite/tests/printer/T14289c.stdout new file mode 100644 index 0000000000..d200f99a2b --- /dev/null +++ b/testsuite/tests/printer/T14289c.stdout @@ -0,0 +1,16 @@ +T14289c.hs:9:3-44: Splicing declarations + [d| data Foo a + = Foo a + deriving (a ~ a) |] + ======> + data Foo a + = Foo a + deriving (a ~ a) +T14289c.ppr.hs:(7,3)-(9,27): Splicing declarations + [d| data Foo a + = Foo a + deriving (a ~ a) |] + ======> + data Foo a + = Foo a + deriving (a ~ a) diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T index 9a1170ec0a..7dda6b36fa 100644 --- a/testsuite/tests/printer/all.T +++ b/testsuite/tests/printer/all.T @@ -50,4 +50,7 @@ test('T13199', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T1319 test('T13050p', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13050p']) test('T13550', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13550']) test('T13942', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13942']) +test('T14289', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T14289']) +test('T14289b', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T14289b']) +test('T14289c', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T14289c']) test('T14306', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T14306']) |