[commit: ghc] master: Fix #9062. (e79e2c3)
git at git.haskell.org
git at git.haskell.org
Wed Jun 11 13:32:25 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/e79e2c3996181a1179cf4a1357981f4ed9759203/ghc
>---------------------------------------------------------------
commit e79e2c3996181a1179cf4a1357981f4ed9759203
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date: Tue Jun 10 15:33:18 2014 -0400
Fix #9062.
Removed (pprEqPred (coercionKind co)) in favor of
(pprType (coercionType co)).
Also had to make "~R#" a *symbolic* identifier and BuiltInSyntax
to squelch prefix notation and module prefixes in output. These
changes are both sensible independent of #9062.
>---------------------------------------------------------------
e79e2c3996181a1179cf4a1357981f4ed9759203
compiler/basicTypes/OccName.lhs | 3 +++
compiler/coreSyn/CoreUtils.lhs | 2 +-
compiler/coreSyn/PprCore.lhs | 2 +-
compiler/prelude/TysPrim.lhs | 12 ++++++++++--
compiler/types/OptCoercion.lhs | 4 ++--
compiler/types/Type.lhs | 2 +-
compiler/types/TypeRep.lhs | 15 +--------------
testsuite/tests/roles/should_compile/Roles13.stderr | 3 +--
8 files changed, 20 insertions(+), 23 deletions(-)
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index 28aeff8..087298f 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -898,9 +898,12 @@ isLexConSym cs -- Infix type or data constructors
| otherwise = startsConSym (headFS cs)
isLexVarSym fs -- Infix identifiers e.g. "+"
+ | fs == (fsLit "~R#") = True
+ | otherwise
= case (if nullFS fs then [] else unpackFS fs) of
[] -> False
(c:cs) -> startsVarSym c && all isVarSymChar cs
+ -- See Note [Classification of generated names]
-------------
startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 6f21c4e..3bf07fe 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -217,7 +217,7 @@ mkCast expr co
-- if to_ty `eqType` from_ty
-- then expr
-- else
- WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
+ WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co))
(Cast expr co)
\end{code}
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 35c0630..f86a911 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -121,7 +121,7 @@ ppr_expr add_par (Cast expr co)
if gopt Opt_SuppressCoercions dflags
then ptext (sLit "...")
else parens $
- sep [ppr co, dcolon <+> pprEqPred (coercionKind co)]
+ sep [ppr co, dcolon <+> ppr (coercionType co)]
ppr_expr add_par expr@(Lam _ _)
diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index 0547c91..de151fd 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -159,7 +159,15 @@ mkPrimTc fs unique tycon
= mkWiredInName gHC_PRIM (mkTcOccFS fs)
unique
(ATyCon tycon) -- Relevant TyCon
- UserSyntax -- None are built-in syntax
+ UserSyntax
+
+mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name
+mkBuiltInPrimTc fs unique tycon
+ = mkWiredInName gHC_PRIM (mkTcOccFS fs)
+ unique
+ (ATyCon tycon) -- Relevant TyCon
+ BuiltInSyntax
+
charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, voidPrimTyConName :: Name
charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
@@ -176,7 +184,7 @@ statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey stat
voidPrimTyConName = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon
proxyPrimTyConName = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon
eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon
-eqReprPrimTyConName = mkPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon
+eqReprPrimTyConName = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon
realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon
byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon
diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs
index 12787b2..dc7ab78 100644
--- a/compiler/types/OptCoercion.lhs
+++ b/compiler/types/OptCoercion.lhs
@@ -88,8 +88,8 @@ opt_co env sym co
= pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $
co1 `seq`
pprTrace "opt_co done }" (ppr co1) $
- (WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (Pair s1 t1)
- $$ ppr co1 <+> dcolon <+> pprEqPred (Pair s2 t2) )
+ (WARN( not same_co_kind, ppr co <+> dcolon <+> ppr (coercionType co)
+ $$ ppr co1 <+> dcolon <+> ppr (coercionType co1) )
WARN( not (coreEqCoercion co1 simple_result),
(text "env=" <+> ppr env) $$
(text "input=" <+> ppr co) $$
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 13ceb44..0e93c96 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -130,7 +130,7 @@ module Type (
-- * Pretty-printing
pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing,
pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType,
- pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred,
+ pprTheta, pprThetaArrowTy, pprClassPred,
pprKind, pprParendKind, pprSourceTyCon,
-- * Tidying type related things up for printing
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 2a38a5d..c93a653 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -39,7 +39,7 @@ module TypeRep (
-- Pretty-printing
pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs,
pprTyThing, pprTyThingCategory, pprSigmaType,
- pprEqPred, pprTheta, pprForAll, pprUserForAll,
+ pprTheta, pprForAll, pprUserForAll,
pprThetaArrowTy, pprClassPred,
pprKind, pprParendKind, pprTyLit, suppressKinds,
TyPrec(..), maybeParen, pprTcApp,
@@ -82,7 +82,6 @@ import CoAxiom
import PrelNames
import Outputable
import FastString
-import Pair
import Util
import DynFlags
@@ -515,18 +514,6 @@ pprKind, pprParendKind :: Kind -> SDoc
pprKind = pprType
pprParendKind = pprParendType
-------------------
-pprEqPred :: Pair Type -> SDoc
--- NB: Maybe move to Coercion? It's only called after coercionKind anyway.
-pprEqPred (Pair ty1 ty2)
- = sep [ ppr_type FunPrec ty1
- , nest 2 (ptext (sLit "~#"))
- , ppr_type FunPrec ty2]
- -- Precedence looks like (->) so that we get
- -- Maybe a ~ Bool
- -- (a->a) ~ Bool
- -- Note parens on the latter!
-
------------
pprClassPred :: Class -> [Type] -> SDoc
pprClassPred clas tys = pprTypeApp (classTyCon clas) tys
diff --git a/testsuite/tests/roles/should_compile/Roles13.stderr b/testsuite/tests/roles/should_compile/Roles13.stderr
index 647e59b..b0dda24 100644
--- a/testsuite/tests/roles/should_compile/Roles13.stderr
+++ b/testsuite/tests/roles/should_compile/Roles13.stderr
@@ -13,8 +13,7 @@ Roles13.convert =
`cast` (<Roles13.Wrap Roles13.Age>_R
-> Roles13.NTCo:Wrap[0] Roles13.NTCo:Age[0]
:: (Roles13.Wrap Roles13.Age -> Roles13.Wrap Roles13.Age)
- ~#
- (Roles13.Wrap Roles13.Age -> GHC.Types.Int))
+ ~R# (Roles13.Wrap Roles13.Age -> GHC.Types.Int))
More information about the ghc-commits
mailing list