[Git][ghc/ghc][master] Fix #18052 by using pprPrefixOcc in more places
Marge Bot
gitlab at gitlab.haskell.org
Wed Apr 15 21:48:57 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
22cc8e51 by Ryan Scott at 2020-04-15T17:48:47-04:00
Fix #18052 by using pprPrefixOcc in more places
This fixes several small oversights in the choice of pretty-printing
function to use. Fixes #18052.
- - - - -
9 changed files:
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Tc/Module.hs
- + testsuite/tests/ghci/should_fail/T18052b.script
- + testsuite/tests/ghci/should_fail/T18052b.stderr
- testsuite/tests/ghci/should_fail/all.T
- testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
- + testsuite/tests/printer/T18052a.hs
- + testsuite/tests/printer/T18052a.stderr
- testsuite/tests/printer/all.T
Changes:
=====================================
compiler/GHC/Core/Ppr.hs
=====================================
@@ -123,11 +123,13 @@ ppr_binding ann (val_bdr, expr)
, pp_bind
]
where
+ pp_val_bdr = pprPrefixOcc val_bdr
+
pp_bind = case bndrIsJoin_maybe val_bdr of
Nothing -> pp_normal_bind
Just ar -> pp_join_bind ar
- pp_normal_bind = hang (ppr val_bdr) 2 (equals <+> pprCoreExpr expr)
+ pp_normal_bind = hang pp_val_bdr 2 (equals <+> pprCoreExpr expr)
-- For a join point of join arity n, we want to print j = \x1 ... xn -> e
-- as "j x1 ... xn = e" to differentiate when a join point returns a
@@ -135,7 +137,7 @@ ppr_binding ann (val_bdr, expr)
-- an n-argument function).
pp_join_bind join_arity
| bndrs `lengthAtLeast` join_arity
- = hang (ppr val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs))
+ = hang (pp_val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs))
2 (equals <+> pprCoreExpr rhs)
| otherwise -- Yikes! A join-binding with too few lambda
-- Lint will complain, but we don't want to crash
@@ -164,8 +166,10 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
-- an atomic value (e.g. function args)
ppr_expr add_par (Var name)
- | isJoinId name = add_par ((text "jump") <+> ppr name)
- | otherwise = ppr name
+ | isJoinId name = add_par ((text "jump") <+> pp_name)
+ | otherwise = pp_name
+ where
+ pp_name = pprPrefixOcc name
ppr_expr add_par (Type ty) = add_par (text "TYPE:" <+> ppr ty) -- Weird
ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co)
ppr_expr add_par (Lit lit) = pprLiteral add_par lit
@@ -429,7 +433,7 @@ pprKindedTyVarBndr tyvar
-- pprIdBndr does *not* print the type
-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
pprIdBndr :: Id -> SDoc
-pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
+pprIdBndr id = pprPrefixOcc id <+> pprIdBndrInfo (idInfo id)
pprIdBndrInfo :: IdInfo -> SDoc
pprIdBndrInfo info
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -2122,7 +2122,7 @@ tcRnStmt hsc_env rdr_stmt
}
where
bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:",
- nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
+ nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id))])
{-
--------------------------------------------------------------------------
@@ -2903,7 +2903,7 @@ ppr_types debug type_env
-- etc are suppressed (unless -dppr-debug),
-- because they appear elsewhere
- ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
+ ppr_sig id = hang (pprPrefixOcc id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc
ppr_tycons debug fam_insts type_env
@@ -2921,7 +2921,7 @@ ppr_tycons debug fam_insts type_env
| otherwise = isExternalName (tyConName tycon) &&
not (tycon `elem` fi_tycons)
ppr_tc tc
- = vcat [ hang (ppr (tyConFlavour tc) <+> ppr tc
+ = vcat [ hang (ppr (tyConFlavour tc) <+> pprPrefixOcc (tyConName tc)
<> braces (ppr (tyConArity tc)) <+> dcolon)
2 (ppr (tidyTopType (tyConKind tc)))
, nest 2 $
@@ -2955,7 +2955,7 @@ ppr_patsyns type_env
= ppr_things "PATTERN SYNONYMS" ppr_ps
(typeEnvPatSyns type_env)
where
- ppr_ps ps = ppr ps <+> dcolon <+> pprPatSynType ps
+ ppr_ps ps = pprPrefixOcc ps <+> dcolon <+> pprPatSynType ps
ppr_insts :: [ClsInst] -> SDoc
ppr_insts ispecs
=====================================
testsuite/tests/ghci/should_fail/T18052b.script
=====================================
@@ -0,0 +1,2 @@
+:set -XMagicHash
+let (%%%) = 1#
=====================================
testsuite/tests/ghci/should_fail/T18052b.stderr
=====================================
@@ -0,0 +1,3 @@
+
+<interactive>:1:1: error:
+ GHCi can't bind a variable of unlifted type: (%%%) :: GHC.Prim.Int#
=====================================
testsuite/tests/ghci/should_fail/all.T
=====================================
@@ -3,3 +3,4 @@ test('T10549a', [], ghci_script, ['T10549a.script'])
test('T15055', normalise_version('ghc'), ghci_script, ['T15055.script'])
test('T16013', [], ghci_script, ['T16013.script'])
test('T16287', [], ghci_script, ['T16287.script'])
+test('T18052b', [], ghci_script, ['T18052b.script'])
=====================================
testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
=====================================
@@ -1,28 +1,28 @@
TYPE SIGNATURES
- !! :: forall {a}. [a] -> Int -> a
- $ :: forall {a} {b}. (a -> b) -> a -> b
- $! :: forall {a} {b}. (a -> b) -> a -> b
- && :: Bool -> Bool -> Bool
- * :: forall {a}. Num a => a -> a -> a
- ** :: forall {a}. Floating a => a -> a -> a
- + :: forall {a}. Num a => a -> a -> a
- ++ :: forall {a}. [a] -> [a] -> [a]
- - :: forall {a}. Num a => a -> a -> a
- . :: forall {b} {c} {a}. (b -> c) -> (a -> b) -> a -> c
- / :: forall {a}. Fractional a => a -> a -> a
- /= :: forall {a}. Eq a => a -> a -> Bool
- < :: forall {a}. Ord a => a -> a -> Bool
- <= :: forall {a}. Ord a => a -> a -> Bool
- =<< ::
+ (!!) :: forall {a}. [a] -> Int -> a
+ ($) :: forall {a} {b}. (a -> b) -> a -> b
+ ($!) :: forall {a} {b}. (a -> b) -> a -> b
+ (&&) :: Bool -> Bool -> Bool
+ (*) :: forall {a}. Num a => a -> a -> a
+ (**) :: forall {a}. Floating a => a -> a -> a
+ (+) :: forall {a}. Num a => a -> a -> a
+ (++) :: forall {a}. [a] -> [a] -> [a]
+ (-) :: forall {a}. Num a => a -> a -> a
+ (.) :: forall {b} {c} {a}. (b -> c) -> (a -> b) -> a -> c
+ (/) :: forall {a}. Fractional a => a -> a -> a
+ (/=) :: forall {a}. Eq a => a -> a -> Bool
+ (<) :: forall {a}. Ord a => a -> a -> Bool
+ (<=) :: forall {a}. Ord a => a -> a -> Bool
+ (=<<) ::
forall {m :: * -> *} {a} {b}. Monad m => (a -> m b) -> m a -> m b
- == :: forall {a}. Eq a => a -> a -> Bool
- > :: forall {a}. Ord a => a -> a -> Bool
- >= :: forall {a}. Ord a => a -> a -> Bool
- >> :: forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b
- >>= ::
+ (==) :: forall {a}. Eq a => a -> a -> Bool
+ (>) :: forall {a}. Ord a => a -> a -> Bool
+ (>=) :: forall {a}. Ord a => a -> a -> Bool
+ (>>) :: forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b
+ (>>=) ::
forall {m :: * -> *} {a} {b}. Monad m => m a -> (a -> m b) -> m b
- ^ :: forall {b} {a}. (Integral b, Num a) => a -> b -> a
- ^^ :: forall {a} {b}. (Fractional a, Integral b) => a -> b -> a
+ (^) :: forall {b} {a}. (Integral b, Num a) => a -> b -> a
+ (^^) :: forall {a} {b}. (Fractional a, Integral b) => a -> b -> a
abs :: forall {a}. Num a => a -> a
acos :: forall {a}. Floating a => a -> a
acosh :: forall {a}. Floating a => a -> a
@@ -234,7 +234,7 @@ TYPE SIGNATURES
zipWith3 ::
forall {a} {b} {c} {d}.
(a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
- || :: Bool -> Bool -> Bool
+ (||) :: Bool -> Bool -> Bool
Dependent modules: []
-Dependent packages: [base-4.13.0.0, ghc-prim-0.6.1,
- integer-gmp-1.0.2.0]
+Dependent packages: [base-4.14.0.0, ghc-prim-0.6.1,
+ integer-gmp-1.0.3.0]
=====================================
testsuite/tests/printer/T18052a.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeOperators #-}
+module T18052a where
+
+(+++) = (++)
+pattern x :||: y = (x,y)
+type (^^^) = Either
+data (&&&)
=====================================
testsuite/tests/printer/T18052a.stderr
=====================================
@@ -0,0 +1,42 @@
+TYPE SIGNATURES
+ (+++) :: forall {a}. [a] -> [a] -> [a]
+TYPE CONSTRUCTORS
+ data type (&&&){0} :: *
+ type synonym (^^^){0} :: * -> * -> *
+PATTERN SYNONYMS
+ (:||:) :: forall {a} {b}. a -> b -> (a, b)
+Dependent modules: []
+Dependent packages: [base-4.14.0.0, ghc-prim-0.6.1,
+ integer-gmp-1.0.3.0]
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 18, types: 53, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18052a.$b:||: :: forall {a} {b}. a -> b -> (a, b)
+[GblId, Arity=2, Unf=OtherCon []]
+T18052a.$b:||: = GHC.Tuple.(,)
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+(+++) :: forall {a}. [a] -> [a] -> [a]
+[GblId]
+(+++) = (++)
+
+-- RHS size: {terms: 13, types: 20, coercions: 0, joins: 0/0}
+T18052a.$m:||:
+ :: forall {rep :: GHC.Types.RuntimeRep} {r :: TYPE rep} {a} {b}.
+ (a, b) -> (a -> b -> r) -> (GHC.Prim.Void# -> r) -> r
+[GblId, Arity=3, Unf=OtherCon []]
+T18052a.$m:||:
+ = \ (@(rep :: GHC.Types.RuntimeRep))
+ (@(r :: TYPE rep))
+ (@a)
+ (@b)
+ (scrut :: (a, b))
+ (cont :: a -> b -> r)
+ _ [Occ=Dead] ->
+ case scrut of { (x, y) -> cont x y }
+
+
+
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -57,3 +57,5 @@ test('T14306', ignore_stderr, makefile_test, ['T14306'])
test('T14343', normal, compile_fail, [''])
test('T14343b', normal, compile_fail, [''])
test('T15761', normal, compile_fail, [''])
+test('T18052a', normal, compile,
+ ['-ddump-simpl -ddump-types -dno-typeable-binds -dsuppress-uniques'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/22cc8e513fcfa89a4391f075534d903596a05895
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/22cc8e513fcfa89a4391f075534d903596a05895
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200415/7d87a1f7/attachment-0001.html>
More information about the ghc-commits
mailing list