Commit 767536cc authored by Andreas Herrmann's avatar Andreas Herrmann Committed by Ben Gamari

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 <variable> :: <type>
```

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
parent e7678d6a
......@@ -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.
......
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 _
......@@ -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’:
......
......@@ -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
{-# 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 ) ]
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)
{-# 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 )
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)
......@@ -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, [''])
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
(# _ | _ #) :: TYPE
('GHC.Types.SumRep '['GHC.Types.LiftedRep, 'GHC.Types.LiftedRep])
('GHC.Types.SumRep '[ 'GHC.Types.LiftedRep, 'GHC.Types.LiftedRep])
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