Commit 6869864e authored by Alan Zimmerman's avatar Alan Zimmerman

Pretty-printing of derived multi-parameter classes omits parentheses

Summary:
Pretty printing a splice with an HsAppType in the deriving clause, such as

    $([d| data Foo a = Foo a deriving (C a) |])

would omit the parens.

Test Plan: ./validate

Reviewers: RyanGlScott, austin, bgamari

Subscribers: rwbarton, thomie

GHC Trac Issues: #14289

Differential Revision: https://phabricator.haskell.org/D4056
parent 9c3f7316
...@@ -1330,14 +1330,38 @@ mk_apps head_ty (ty:tys) = ...@@ -1330,14 +1330,38 @@ mk_apps head_ty (ty:tys) =
; p_ty <- add_parens ty ; p_ty <- add_parens ty
; mk_apps (HsAppTy head_ty' p_ty) tys } ; mk_apps (HsAppTy head_ty' p_ty) tys }
where where
add_parens t@(L _ HsAppTy{}) = returnL (HsParTy t) -- See Note [Adding parens for splices]
add_parens t@(L _ HsFunTy{}) = returnL (HsParTy t) add_parens t
add_parens t = return t | isCompoundHsType t = returnL (HsParTy t)
| otherwise = return t
wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs) wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs)
wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t) wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t)
wrap_apps t = return 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 -- | Constructs an arrow type with a specified return type
mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs) mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)
mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
......
...@@ -1106,8 +1106,9 @@ instance (SourceTextX pass, OutputableBndrId pass) ...@@ -1106,8 +1106,9 @@ instance (SourceTextX pass, OutputableBndrId pass)
-- This complexity is to distinguish between -- This complexity is to distinguish between
-- deriving Show -- deriving Show
-- deriving (Show) -- deriving (Show)
pp_dct [a@(HsIB { hsib_body = L _ HsAppsTy{} })] = parens (ppr a) pp_dct [a@(HsIB { hsib_body = ty })]
pp_dct [a] = ppr a | isCompoundHsType ty = parens (ppr a)
| otherwise = ppr a
pp_dct _ = parens (interpp'SP dct) pp_dct _ = parens (interpp'SP dct)
data NewOrData data NewOrData
......
...@@ -65,7 +65,8 @@ module HsTypes ( ...@@ -65,7 +65,8 @@ module HsTypes (
-- Printing -- Printing
pprHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra, pprHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
pprHsContext, pprHsContextNoArrow, pprHsContextMaybe pprHsContext, pprHsContextNoArrow, pprHsContextMaybe,
isCompoundHsType
) where ) where
import GhcPrelude import GhcPrelude
...@@ -1365,3 +1366,13 @@ ppr_app_ty (HsAppPrefix ty) = ppr_mono_lty ty ...@@ -1365,3 +1366,13 @@ ppr_app_ty (HsAppPrefix ty) = ppr_mono_lty ty
ppr_tylit :: HsTyLit -> SDoc ppr_tylit :: HsTyLit -> SDoc
ppr_tylit (HsNumTy _ i) = integer i ppr_tylit (HsNumTy _ i) = integer i
ppr_tylit (HsStrTy _ s) = text (show s) 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
...@@ -214,6 +214,18 @@ T13550: ...@@ -214,6 +214,18 @@ T13550:
T13942: T13942:
$(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13942.hs $(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 .PHONY: T14306
T14306: T14306:
$(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14306.hs $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14306.hs
{-# 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)
----------------------------------------
-}
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)
{-# 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)]]]
-}
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)
{-# 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)]]]
-}
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)
...@@ -50,4 +50,7 @@ test('T13199', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T1319 ...@@ -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('T13050p', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13050p'])
test('T13550', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13550']) 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('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']) test('T14306', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T14306'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment