From 767536ccf95d8352d146b6544857b28d9c42937e Mon Sep 17 00:00:00 2001 From: Andreas Herrmann Date: Thu, 7 Jun 2018 13:24:52 -0400 Subject: Fix unparseable pretty-printing of promoted data cons Previously we would print code which would not round-trip: ``` > :set -XDataKinds > :set -XPolyKinds > data Proxy k = Proxy > _ :: Proxy '[ 'True ] error: Found hole: _ :: Proxy '['True] > _ :: Proxy '['True] error: Invalid type signature: _ :: ... Should be of form :: ``` Test Plan: Validate with T14343 Reviewers: RyanGlScott, goldfire, bgamari, tdammers Reviewed By: RyanGlScott, bgamari Subscribers: tdammers, rwbarton, thomie, carter GHC Trac Issues: #14343 Differential Revision: https://phabricator.haskell.org/D4746 --- compiler/iface/IfaceType.hs | 18 ++++++++-- testsuite/tests/perf/compiler/T13035.stderr | 2 +- testsuite/tests/perf/compiler/T9872b.stderr | 32 +++++++++--------- testsuite/tests/printer/Makefile | 8 +++++ testsuite/tests/printer/T14343.hs | 12 +++++++ testsuite/tests/printer/T14343.stderr | 36 ++++++++++++++++++++ testsuite/tests/printer/T14343b.hs | 12 +++++++ testsuite/tests/printer/T14343b.stderr | 39 ++++++++++++++++++++++ testsuite/tests/printer/all.T | 2 ++ .../tests/typecheck/should_fail/T15067.stderr | 10 +++--- testsuite/tests/unboxedsums/T12711.stdout | 2 +- 11 files changed, 147 insertions(+), 26 deletions(-) create mode 100644 testsuite/tests/printer/T14343.hs create mode 100644 testsuite/tests/printer/T14343.stderr create mode 100644 testsuite/tests/printer/T14343b.hs create mode 100644 testsuite/tests/printer/T14343b.stderr diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index 2524593663..e2e51d8c58 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -933,6 +933,15 @@ criteria are met: ------------------- +-- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'. +pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc +pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _) + = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of + IsPromoted -> (space <>) + _ -> id +pprSpaceIfPromotedTyCon _ + = id + -- See equivalent function in TyCoRep.hs pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc -- Given a type-level list (t1 ': t2), see if we can print @@ -941,8 +950,8 @@ pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc pprIfaceTyList ctxt_prec ty1 ty2 = case gather ty2 of (arg_tys, Nothing) - -> char '\'' <> brackets (fsep (punctuate comma - (map (ppr_ty topPrec) (ty1:arg_tys)))) + -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep + (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys))))) (arg_tys, Just tl) -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1) 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]]) @@ -1136,8 +1145,11 @@ pprTuple ctxt_prec ConstraintTuple IsNotPromoted ITC_Nil pprTuple _ sort IsPromoted args = let tys = tcArgsIfaceTypes args args' = drop (length tys `div` 2) tys + spaceIfPromoted = case args' of + arg0:_ -> pprSpaceIfPromotedTyCon arg0 + _ -> id in pprPromotionQuoteI IsPromoted <> - tupleParens sort (pprWithCommas pprIfaceType args') + tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args')) pprTuple _ sort promoted args = -- drop the RuntimeRep vars. diff --git a/testsuite/tests/perf/compiler/T13035.stderr b/testsuite/tests/perf/compiler/T13035.stderr index fe1f0b2564..4fbc7c7e37 100644 --- a/testsuite/tests/perf/compiler/T13035.stderr +++ b/testsuite/tests/perf/compiler/T13035.stderr @@ -1,4 +1,4 @@ T13035.hs:141:28: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘'['Author] :: [Fields]’ + • Found type wildcard ‘_’ standing for ‘'[ 'Author] :: [Fields]’ • In the type signature: g :: MyRec RecipeFormatter _ diff --git a/testsuite/tests/perf/compiler/T9872b.stderr b/testsuite/tests/perf/compiler/T9872b.stderr index d2d8ad8441..6224056185 100644 --- a/testsuite/tests/perf/compiler/T9872b.stderr +++ b/testsuite/tests/perf/compiler/T9872b.stderr @@ -2,22 +2,22 @@ T9872b.hs:19:8: No instance for (Show (Proxy - '['['Cube 'G 'B 'W 'R 'B 'G, 'Cube 'W 'G 'B 'W 'R 'R, - 'Cube 'R 'W 'R 'B 'G 'R, 'Cube 'B 'R 'G 'G 'W 'W], - '['Cube 'G 'B 'R 'W 'B 'G, 'Cube 'R 'R 'W 'B 'G 'W, - 'Cube 'R 'G 'B 'R 'W 'R, 'Cube 'W 'W 'G 'G 'R 'B], - '['Cube 'G 'W 'R 'B 'B 'G, 'Cube 'W 'B 'W 'R 'G 'R, - 'Cube 'R 'R 'B 'G 'W 'R, 'Cube 'B 'G 'G 'W 'R 'W], - '['Cube 'G 'R 'W 'B 'B 'G, 'Cube 'R 'W 'B 'G 'R 'W, - 'Cube 'R 'B 'R 'W 'G 'R, 'Cube 'W 'G 'G 'R 'W 'B], - '['Cube 'G 'R 'B 'B 'W 'G, 'Cube 'W 'W 'R 'G 'B 'R, - 'Cube 'R 'B 'G 'W 'R 'R, 'Cube 'B 'G 'W 'R 'G 'W], - '['Cube 'G 'W 'B 'B 'R 'G, 'Cube 'R 'B 'G 'R 'W 'W, - 'Cube 'R 'R 'W 'G 'B 'R, 'Cube 'W 'G 'R 'W 'G 'B], - '['Cube 'G 'B 'B 'W 'R 'G, 'Cube 'W 'R 'G 'B 'W 'R, - 'Cube 'R 'G 'W 'R 'B 'R, 'Cube 'B 'W 'R 'G 'G 'W], - '['Cube 'G 'B 'B 'R 'W 'G, 'Cube 'R 'G 'R 'W 'B 'W, - 'Cube 'R 'W 'G 'B 'R 'R, 'Cube 'W 'R 'W 'G 'G 'B]])) + '[ '[ 'Cube 'G 'B 'W 'R 'B 'G, 'Cube 'W 'G 'B 'W 'R 'R, + 'Cube 'R 'W 'R 'B 'G 'R, 'Cube 'B 'R 'G 'G 'W 'W], + '[ 'Cube 'G 'B 'R 'W 'B 'G, 'Cube 'R 'R 'W 'B 'G 'W, + 'Cube 'R 'G 'B 'R 'W 'R, 'Cube 'W 'W 'G 'G 'R 'B], + '[ 'Cube 'G 'W 'R 'B 'B 'G, 'Cube 'W 'B 'W 'R 'G 'R, + 'Cube 'R 'R 'B 'G 'W 'R, 'Cube 'B 'G 'G 'W 'R 'W], + '[ 'Cube 'G 'R 'W 'B 'B 'G, 'Cube 'R 'W 'B 'G 'R 'W, + 'Cube 'R 'B 'R 'W 'G 'R, 'Cube 'W 'G 'G 'R 'W 'B], + '[ 'Cube 'G 'R 'B 'B 'W 'G, 'Cube 'W 'W 'R 'G 'B 'R, + 'Cube 'R 'B 'G 'W 'R 'R, 'Cube 'B 'G 'W 'R 'G 'W], + '[ 'Cube 'G 'W 'B 'B 'R 'G, 'Cube 'R 'B 'G 'R 'W 'W, + 'Cube 'R 'R 'W 'G 'B 'R, 'Cube 'W 'G 'R 'W 'G 'B], + '[ 'Cube 'G 'B 'B 'W 'R 'G, 'Cube 'W 'R 'G 'B 'W 'R, + 'Cube 'R 'G 'W 'R 'B 'R, 'Cube 'B 'W 'R 'G 'G 'W], + '[ 'Cube 'G 'B 'B 'R 'W 'G, 'Cube 'R 'G 'R 'W 'B 'W, + 'Cube 'R 'W 'G 'B 'R 'R, 'Cube 'W 'R 'W 'G 'G 'B]])) arising from a use of ‘print’ In the expression: print (Proxy :: Proxy (Solutions Cubes)) In an equation for ‘main’: diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile index 17fc65215f..044e44332e 100644 --- a/testsuite/tests/printer/Makefile +++ b/testsuite/tests/printer/Makefile @@ -229,3 +229,11 @@ T14289c: .PHONY: T14306 T14306: $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14306.hs + +.PHONY: T14343 +T14343: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14343.hs + +.PHONY: T14343b +T14343b: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14343b.hs diff --git a/testsuite/tests/printer/T14343.hs b/testsuite/tests/printer/T14343.hs new file mode 100644 index 0000000000..1fe6a9660b --- /dev/null +++ b/testsuite/tests/printer/T14343.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# OPTIONS_GHC -Werror=typed-holes #-} + +main :: IO () +main = undefined + +data Proxy k = Proxy + +test1 = _ :: Proxy '[ 'True ] +test2 = _ :: Proxy '[ '[ 1 ] ] +test3 = _ :: Proxy '[ '( "Symbol", 1 ) ] diff --git a/testsuite/tests/printer/T14343.stderr b/testsuite/tests/printer/T14343.stderr new file mode 100644 index 0000000000..1bceb67403 --- /dev/null +++ b/testsuite/tests/printer/T14343.stderr @@ -0,0 +1,36 @@ + +T14343.hs:10:9: error: + • Found hole: _ :: Proxy '[ 'True] + • In the expression: _ :: Proxy '[ 'True] + In an equation for ‘test1’: test1 = _ :: Proxy '[ 'True] + • Relevant bindings include + test1 :: Proxy '[ 'True] (bound at T14343.hs:10:1) + Valid hole fits include + test1 :: Proxy '[ 'True] (defined at T14343.hs:10:1) + Proxy :: forall k1 (k2 :: k1). Proxy k2 + with Proxy @[Bool] @'[ 'True] + (defined at T14343.hs:8:16) + +T14343.hs:11:9: error: + • Found hole: _ :: Proxy '[ '[1]] + • In the expression: _ :: Proxy '['[1]] + In an equation for ‘test2’: test2 = _ :: Proxy '['[1]] + • Relevant bindings include + test2 :: Proxy '[ '[1]] (bound at T14343.hs:11:1) + Valid hole fits include + test2 :: Proxy '[ '[1]] (defined at T14343.hs:11:1) + Proxy :: forall k1 (k2 :: k1). Proxy k2 + with Proxy @[[GHC.Types.Nat]] @'[ '[1]] + (defined at T14343.hs:8:16) + +T14343.hs:12:9: error: + • Found hole: _ :: Proxy '[ '("Symbol", 1)] + • In the expression: _ :: Proxy '['("Symbol", 1)] + In an equation for ‘test3’: test3 = _ :: Proxy '['("Symbol", 1)] + • Relevant bindings include + test3 :: Proxy '[ '("Symbol", 1)] (bound at T14343.hs:12:1) + Valid hole fits include + test3 :: Proxy '[ '("Symbol", 1)] (defined at T14343.hs:12:1) + Proxy :: forall k1 (k2 :: k1). Proxy k2 + with Proxy @[(GHC.Types.Symbol, GHC.Types.Nat)] @'[ '("Symbol", 1)] + (defined at T14343.hs:8:16) diff --git a/testsuite/tests/printer/T14343b.hs b/testsuite/tests/printer/T14343b.hs new file mode 100644 index 0000000000..6596a7a486 --- /dev/null +++ b/testsuite/tests/printer/T14343b.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# OPTIONS_GHC -Werror=typed-holes #-} + +main :: IO () +main = undefined + +data Proxy k = Proxy + +test1 = _ :: Proxy '( 'True, 'False ) +test2 = _ :: Proxy '( '( 'True, 'False ), 'False ) +test3 = _ :: Proxy '( '[ 1 ], 'False ) diff --git a/testsuite/tests/printer/T14343b.stderr b/testsuite/tests/printer/T14343b.stderr new file mode 100644 index 0000000000..1954f9465a --- /dev/null +++ b/testsuite/tests/printer/T14343b.stderr @@ -0,0 +1,39 @@ + +T14343b.hs:10:9: error: + • Found hole: _ :: Proxy '( 'True, 'False) + • In the expression: _ :: Proxy '( 'True, 'False) + In an equation for ‘test1’: test1 = _ :: Proxy '( 'True, 'False) + • Relevant bindings include + test1 :: Proxy '( 'True, 'False) (bound at T14343b.hs:10:1) + Valid hole fits include + test1 :: Proxy '( 'True, 'False) (defined at T14343b.hs:10:1) + Proxy :: forall k1 (k2 :: k1). Proxy k2 + with Proxy @(Bool, Bool) @'( 'True, 'False) + (defined at T14343b.hs:8:16) + +T14343b.hs:11:9: error: + • Found hole: _ :: Proxy '( '( 'True, 'False), 'False) + • In the expression: _ :: Proxy '('( 'True, 'False), 'False) + In an equation for ‘test2’: + test2 = _ :: Proxy '('( 'True, 'False), 'False) + • Relevant bindings include + test2 :: Proxy '( '( 'True, 'False), 'False) + (bound at T14343b.hs:11:1) + Valid hole fits include + test2 :: Proxy '( '( 'True, 'False), 'False) + (defined at T14343b.hs:11:1) + Proxy :: forall k1 (k2 :: k1). Proxy k2 + with Proxy @((Bool, Bool), Bool) @'( '( 'True, 'False), 'False) + (defined at T14343b.hs:8:16) + +T14343b.hs:12:9: error: + • Found hole: _ :: Proxy '( '[1], 'False) + • In the expression: _ :: Proxy '('[1], 'False) + In an equation for ‘test3’: test3 = _ :: Proxy '('[1], 'False) + • Relevant bindings include + test3 :: Proxy '( '[1], 'False) (bound at T14343b.hs:12:1) + Valid hole fits include + test3 :: Proxy '( '[1], 'False) (defined at T14343b.hs:12:1) + Proxy :: forall k1 (k2 :: k1). Proxy k2 + with Proxy @([GHC.Types.Nat], Bool) @'( '[1], 'False) + (defined at T14343b.hs:8:16) diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T index 7dda6b36fa..203efa4be4 100644 --- a/testsuite/tests/printer/all.T +++ b/testsuite/tests/printer/all.T @@ -54,3 +54,5 @@ test('T14289', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T1428 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('T14343', normal, compile_fail, ['']) +test('T14343b', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_fail/T15067.stderr b/testsuite/tests/typecheck/should_fail/T15067.stderr index 73056113ad..4ed3d3bc0a 100644 --- a/testsuite/tests/typecheck/should_fail/T15067.stderr +++ b/testsuite/tests/typecheck/should_fail/T15067.stderr @@ -1,13 +1,13 @@ -T15067.hs:9:14: - No instance for (Typeable (# 'GHC.Types.LiftedRep #)) +T15067.hs:9:14: error: + • No instance for (Typeable (# 'GHC.Types.LiftedRep #)) arising from a use of ‘typeRep’ GHC can't yet do polykinded Typeable ((# 'GHC.Types.LiftedRep #) :: * -> * -> TYPE ('GHC.Types.SumRep - '['GHC.Types.LiftedRep, - 'GHC.Types.LiftedRep])) - In the expression: typeRep + '[ 'GHC.Types.LiftedRep, + 'GHC.Types.LiftedRep])) + • In the expression: typeRep In an equation for ‘floopadoop’: floopadoop = typeRep diff --git a/testsuite/tests/unboxedsums/T12711.stdout b/testsuite/tests/unboxedsums/T12711.stdout index 7a623a3bd6..54af3fdfa6 100644 --- a/testsuite/tests/unboxedsums/T12711.stdout +++ b/testsuite/tests/unboxedsums/T12711.stdout @@ -1,2 +1,2 @@ (# _ | _ #) :: TYPE - ('GHC.Types.SumRep '['GHC.Types.LiftedRep, 'GHC.Types.LiftedRep]) + ('GHC.Types.SumRep '[ 'GHC.Types.LiftedRep, 'GHC.Types.LiftedRep]) -- cgit v1.2.1